POC for polysemy

IntersectMBO · May 17, 2024 · 2ae181c · 2ae181c
1 parent 8ebae88
commit 2ae181c
Show file tree

Hide file tree

Showing 5 changed files with 136 additions and 51 deletions.
diff --git a/cabal.project b/cabal.project
@@ -13,7 +13,7 @@ repository cardano-haskell-packages
 -- See CONTRIBUTING for information about these, including some Nix commands
 -- you need to run if you change them
 index-state:
-  , hackage.haskell.org 2024-05-02T11:03:23Z
+  , hackage.haskell.org 2024-05-17T14:38:43Z
   , cardano-haskell-packages 2024-05-14T04:43:46Z
 
 packages:
@@ -41,3 +41,8 @@ write-ghc-environment-files: always
 -- IMPORTANT
 -- Do NOT add more source-repository-package stanzas here unless they are strictly
 -- temporary! Please read the section in CONTRIBUTING about updating dependencies.
+
+-- Add upper bound to io-classes-mtl:
+
+constraints:
+  io-classes-mtl < 0.1.2.0
diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal
@@ -259,6 +259,7 @@ library cardano-cli-test-lib
   visibility:           public
   hs-source-dirs:       test/cardano-cli-test-lib
   exposed-modules:      Test.Cardano.CLI.Aeson
+                        Test.Cardano.CLI.Polysemy
                         Test.Cardano.CLI.Util
   build-depends:        aeson
                       , aeson-pretty
@@ -270,6 +271,8 @@ library cardano-cli-test-lib
                       , filepath
                       , hedgehog
                       , hedgehog-extras ^>= 0.6.1.0
+                      , hw-polysemy:core ^>= 0.2.3.0
+                      , hw-polysemy:hedgehog ^>= 0.2.3.0
                       , lifted-base
                       , monad-control
                       , process
@@ -293,10 +296,10 @@ test-suite cardano-cli-test
                       , cardano-ledger-alonzo
                       , cardano-slotting
                       , containers
+                      , exceptions
                       , filepath
                       , hedgehog
                       , hedgehog-extras ^>= 0.6.1.0
-                      , exceptions
                       , regex-tdfa
                       , tasty
                       , tasty-hedgehog
@@ -354,6 +357,8 @@ test-suite cardano-cli-golden
                       , filepath
                       , hedgehog ^>= 1.4
                       , hedgehog-extras ^>= 0.6.1.0
+                      , hw-polysemy:core ^>= 0.2.3.0
+                      , hw-polysemy:hedgehog ^>= 0.2.3.0
                       , regex-compat
                       , regex-tdfa
                       , tasty

diff --git a/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs b/cardano-cli/test/cardano-cli-golden/Test/Golden/Byron/Tx.hs
@@ -1,30 +1,28 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
+{- HLINT ignore "Use camelCase" -}
+
 module Test.Golden.Byron.Tx where
 
 import           Cardano.Api
 
 import           Cardano.Chain.UTxO (ATxAux)
 import           Cardano.CLI.Byron.Tx
 
-import           Control.Monad (void)
-import           Data.ByteString (ByteString)
-
-import           Test.Cardano.CLI.Util
-
-import           Hedgehog (Property, (===))
-import qualified Hedgehog as H
-import qualified Hedgehog.Extras.Test.Base as H
-import           Hedgehog.Internal.Property (failWith)
+import           Test.Cardano.CLI.Polysemy
 
-{- HLINT ignore "Use camelCase" -}
+import           HaskellWorks.Polysemy
+import           HaskellWorks.Polysemy.Hedgehog
+import           HaskellWorks.Prelude
 
 hprop_byronTx_legacy :: Property
-hprop_byronTx_legacy = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do
-  signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
-  expectedTx <- noteInputFile "test/cardano-cli-golden/files/input/byron/tx/legacy.tx"
-  createdTx <- noteTempFile tempDir "tx"
-  void $ execCardanoCLI
+hprop_byronTx_legacy = propertyOnce $ localWorkspace $ do
+  signingKey <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/keys/legacy.skey"
+  expectedTx <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/tx/legacy.tx"
+  createdTx <- jotTempFile "tx"
+
+  execCardanoCli_
     [ "byron", "transaction", "issue-utxo-expenditure"
     , "--mainnet"
     , "--byron-legacy-formats"
@@ -34,14 +32,15 @@ hprop_byronTx_legacy = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do
     , "--txout", "(\"2657WMsDfac6eFirdvKVPVMxNVYuACd1RGM2arH3g1y1yaQCr1yYpb2jr2b2aSiDZ\",999)"
     ]
 
-  compareByronTxs createdTx expectedTx
+  void $ compareByronTxs createdTx expectedTx
 
 hprop_byronTx :: Property
-hprop_byronTx = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do
-  signingKey <- noteInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
-  expectedTx <- noteInputFile "test/cardano-cli-golden/files/input/byron/tx/normal.tx"
-  createdTx <- noteTempFile tempDir "tx"
-  void $ execCardanoCLI
+hprop_byronTx = propertyOnce $ localWorkspace $ do
+  signingKey <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/keys/byron.skey"
+  expectedTx <- jotPkgInputFile "test/cardano-cli-golden/files/input/byron/tx/normal.tx"
+  createdTx <- jotTempFile "tx"
+
+  execCardanoCli_
     [ "byron", "transaction", "issue-utxo-expenditure"
     , "--mainnet"
     , "--byron-formats"
@@ -53,16 +52,26 @@ hprop_byronTx = propertyOnce $ H.moduleWorkspace "tmp" $ \tempDir -> do
 
   compareByronTxs createdTx expectedTx
 
-getTxByteString :: FilePath -> H.PropertyT IO (ATxAux ByteString)
-getTxByteString txFp = do
-  eATxAuxBS <- liftIO . runExceptT $ readByronTx $ File txFp
-  case eATxAuxBS of
-    Left err -> failWith Nothing . docToString $ renderByronTxError err
-    Right aTxAuxBS -> return aTxAuxBS
-
-compareByronTxs :: FilePath -> FilePath -> H.PropertyT IO ()
+compareByronTxs :: ()
+  => HasCallStack
+  => Member (Embed IO) r
+  => Member Hedgehog r
+  => FilePath
+  -> FilePath
+  -> Sem r ()
 compareByronTxs createdTx expectedTx = do
   createdATxAuxBS <- getTxByteString createdTx
   expectedATxAuxBS <- getTxByteString expectedTx
 
   normalByronTxToGenTx expectedATxAuxBS === normalByronTxToGenTx createdATxAuxBS
+
+getTxByteString :: ()
+  => Member Hedgehog r
+  => Member (Embed IO) r
+  => FilePath
+  -> Sem r (ATxAux ByteString)
+getTxByteString txFp = do
+  eATxAuxBS <- embed $ runExceptT $ readByronTx $ File txFp
+  case eATxAuxBS of
+    Left err -> failWith Nothing . docToString $ renderByronTxError err
+    Right aTxAuxBS -> pure aTxAuxBS
diff --git a/...cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs b/...cli/test/cardano-cli-golden/Test/Golden/Shelley/StakeAddress/DeregistrationCertificate.hs
@@ -2,41 +2,37 @@
 
 module Test.Golden.Shelley.StakeAddress.DeregistrationCertificate where
 
-import           Control.Monad (void)
-import           System.FilePath ((</>))
+import           Test.Cardano.CLI.Polysemy
 
-import           Test.Cardano.CLI.Util
-
-import           Hedgehog (Property)
-import qualified Hedgehog.Extras.Test.Base as H
-import qualified Hedgehog.Extras.Test.Process as H
-import qualified Hedgehog.Extras.Test.Golden as H
+import           HaskellWorks.Polysemy.Hedgehog
+import           HaskellWorks.Polysemy.Hedgehog.Golden
 
 {- HLINT ignore "Use camelCase" -}
 
 hprop_golden_shelley_stake_address_deregistration_certificate :: Property
-hprop_golden_shelley_stake_address_deregistration_certificate = propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do
-  base <- H.getProjectBase
+hprop_golden_shelley_stake_address_deregistration_certificate = propertyOnce $ localWorkspace $ do
+  verificationKeyFile <- jotPkgInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key"
+  deregistrationCertFile <- jotTempFile "deregistrationCertFile"
+  scriptDeregistrationCertFile <- jotTempFile "scripDeregistrationCertFile"
+  exampleScript <- jotRootInputFile "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus"
 
-  verificationKeyFile <- noteInputFile "test/cardano-cli-golden/files/input/shelley/keys/stake_keys/verification_key"
-  deregistrationCertFile <- noteTempFile tempDir "deregistrationCertFile"
-  scriptDeregistrationCertFile <- noteTempFile tempDir "scripDeregistrationCertFile"
-  exampleScript <- noteInputFile $ base </> "scripts/plutus/scripts/v1/custom-guess-42-datum-42.plutus"
+  jot_ exampleScript
 
-  void $ execCardanoCLI
+  execCardanoCli_
     [ "babbage", "stake-address","deregistration-certificate"
     , "--staking-verification-key-file", verificationKeyFile
     , "--out-file", deregistrationCertFile
     ]
 
-  goldenFile1 <- H.note "test/cardano-cli-golden/files/golden/shelley/dereg-cert-1.json"
-  H.diffFileVsGoldenFile deregistrationCertFile goldenFile1
+  goldenFile1 <- jotPkgGoldenFile "test/cardano-cli-golden/files/golden/shelley/dereg-cert-1.json"
+  diffFileVsGoldenFile deregistrationCertFile goldenFile1
 
-  void $ execCardanoCLI
+  execCardanoCli_
     [ "babbage", "stake-address","deregistration-certificate"
     , "--stake-script-file", exampleScript
     , "--out-file", scriptDeregistrationCertFile
     ]
 
-  goldenFile2 <- H.note "test/cardano-cli-golden/files/golden/shelley/dereg-cert-2.json"
-  H.diffFileVsGoldenFile scriptDeregistrationCertFile goldenFile2
+  goldenFile2 <- jotPkgGoldenFile "test/cardano-cli-golden/files/golden/shelley/dereg-cert-2.json"
+
+  diffFileVsGoldenFile scriptDeregistrationCertFile goldenFile2
diff --git a/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Polysemy.hs b/cardano-cli/test/cardano-cli-test-lib/Test/Cardano/CLI/Polysemy.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Test.Cardano.CLI.Polysemy
+  ( cardanoCliPath
+  , execCardanoCli
+  , execCardanoCli_
+  , localWorkspace
+  ) where
+
+import           HaskellWorks.Polysemy
+import           HaskellWorks.Polysemy.Error.Types
+import           HaskellWorks.Polysemy.Hedgehog
+import           HaskellWorks.Polysemy.Hedgehog.Assert
+import           HaskellWorks.Polysemy.Hedgehog.Process
+import           HaskellWorks.Polysemy.Prelude
+
+cardanoCliPath :: FilePath
+cardanoCliPath = "cardano-cli"
+
+-- | Execute cardano-cli via the command line.
+--
+-- Waits for the process to finish and returns the stdout.
+execCardanoCli :: ()
+  => HasCallStack
+  => Member (Embed IO) r
+  => Member Hedgehog r
+  => Member Log r
+  => [String]
+  -- ^ Arguments to the CLI command
+  -> Sem r String
+  -- ^ Captured stdout
+execCardanoCli args = withFrozenCallStack $
+  execFlexOk "cardano-cli" "CARDANO_CLI" args
+    & trapFail @GenericError
+    & trapFail @IOException
+
+execCardanoCli_ :: ()
+  => HasCallStack
+  => Member (Embed IO) r
+  => Member Hedgehog r
+  => Member Log r
+  => [String]
+  -- ^ Arguments to the CLI command
+  -> Sem r ()
+execCardanoCli_ args = withFrozenCallStack $
+  void $ execCardanoCli args
+
+localWorkspace ::  ()
+  => Member Hedgehog r
+  => Member Log r
+  => Member (Embed IO) r
+  => Sem
+        ( Reader Workspace
+        : Reader ProjectRoot
+        : Reader PackagePath
+        : Resource
+        : r)
+        ()
+  -> Sem r ()
+localWorkspace f = do
+  cabalProjectDir <- findCabalProjectDir "."
+
+  f & moduleWorkspace "cardano-cli"
+    & runReader (ProjectRoot cabalProjectDir)
+    & runReader (PackagePath "cardano-cli")
+    & runResource