cleveland 0.2.0 → 0.2.1

raw patch · 59 files changed

+2965/−2201 lines, 59 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGES.md +34/−0
• cleveland.cabal +16/−1
• src/Hedgehog/Gen/Michelson/Typed.hs +4/−4
• src/Hedgehog/Gen/Tezos/Address.hs +5/−5
• src/Test/Cleveland.hs +30/−15
• src/Test/Cleveland/Instances.hs +18/−3
• src/Test/Cleveland/Internal/Abstract.hs +192/−52
• src/Test/Cleveland/Internal/Actions.hs +120/−1251
• src/Test/Cleveland/Internal/Actions/Assertions.hs +125/−0
• src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs +188/−0
• src/Test/Cleveland/Internal/Actions/Helpers.hs +12/−0
• src/Test/Cleveland/Internal/Actions/Misc.hs +552/−0
• src/Test/Cleveland/Internal/Actions/MonadOps.hs +38/−0
• src/Test/Cleveland/Internal/Actions/Originate.hs +225/−0
• src/Test/Cleveland/Internal/Actions/Transfer.hs +331/−0
• src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs +137/−0
• src/Test/Cleveland/Internal/Client.hs +142/−128
• src/Test/Cleveland/Internal/Hedgehog.hs +1/−3
• src/Test/Cleveland/Internal/Pure.hs +200/−238
• src/Test/Cleveland/Internal/Scenario.hs +47/−25
• src/Test/Cleveland/Lorentz.hs +3/−0
• src/Test/Cleveland/Lorentz/Ticketer.hs +6/−5
• src/Test/Cleveland/Lorentz/Types.hs +55/−5
• src/Test/Cleveland/Tasty/Internal.hs +15/−18
• src/Test/Cleveland/Tasty/Internal/Options.hs +4/−4
• src/Test/Cleveland/Util.hs +1/−1
• test/TestSuite/Cleveland/AddressRevealing.hs +2/−2
• test/TestSuite/Cleveland/BadAddressReuse.hs +21/−0
• test/TestSuite/Cleveland/BalanceCheck.hs +4/−4
• test/TestSuite/Cleveland/BatchOperation.hs +7/−8
• test/TestSuite/Cleveland/BatchTransferCheck.hs +4/−4
• test/TestSuite/Cleveland/BytesSigning.hs +3/−3
• test/TestSuite/Cleveland/CallStack.hs +57/−86
• test/TestSuite/Cleveland/ChainIdGet.hs +2/−2
• test/TestSuite/Cleveland/ContractAllocation.hs +5/−12
• test/TestSuite/Cleveland/DFS.hs +6/−12
• test/TestSuite/Cleveland/EmitMachinery.hs +62/−0
• test/TestSuite/Cleveland/EmptyImplicitAddress.hs +3/−3
• test/TestSuite/Cleveland/Emulated.hs +7/−7
• test/TestSuite/Cleveland/ErrorMessages.hs +18/−0
• test/TestSuite/Cleveland/ExpectFailure.hs +39/−51
• test/TestSuite/Cleveland/FailureLogs.hs +5/−5
• test/TestSuite/Cleveland/Import.hs +7/−7
• test/TestSuite/Cleveland/NetworkCaps.hs +18/−0
• test/TestSuite/Cleveland/NewAddressCheck.hs +1/−1
• test/TestSuite/Cleveland/OperationReplay.hs +5/−5
• test/TestSuite/Cleveland/PrettyFailWith.hs +3/−3
• test/TestSuite/Cleveland/PublicKeyToAddress.hs +8/−10
• test/TestSuite/Cleveland/RefillableAddress.hs +8/−13
• test/TestSuite/Cleveland/ResolveAddress.hs +28/−0
• test/TestSuite/Cleveland/RunCode.hs +79/−77
• test/TestSuite/Cleveland/StorageCheck.hs +13/−16
• test/TestSuite/Cleveland/StorageWithBigMaps.hs +24/−24
• test/TestSuite/Cleveland/Tasty/Report.hs +2/−2
• test/TestSuite/Cleveland/Tasty/Report/Examples.hs +2/−2
• test/TestSuite/Cleveland/TransferCheck.hs +8/−71
• test/TestSuite/Cleveland/VotingPower.hs +4/−4
• test/TestSuite/Cleveland/WithMoneybag.hs +1/−1
• test/TestSuite/Cleveland/WithSender.hs +8/−8

@@ -1,6 +1,40 @@ <!-- Unreleased: append new entries here -->  +0.2.1+=====+* [!1199](https://gitlab.com/morley-framework/morley/-/merge_requests/1199)+  Replace removed HasTezosClient actions with TezosClient.Impl version.+* [!1212](https://gitlab.com/morley-framework/morley/-/merge_requests/1212)+  Support contract events+  + Untie cleveland operation results from morley-client.+  + Introduce `ContractEvent` type for contract events.+  + Introduce new `WithContractEvents` flag for `transfer`, which tells it to+    return `[ContractEvent]`.+* [!1191](https://gitlab.com/morley-framework/morley/-/merge_requests/1191)+  General cleanup+  + Display contract's aliases in error messages when a transfer fails (emulator-mode only).+* [!1177](https://gitlab.com/morley-framework/morley/-/merge_requests/1177)+  Distinguish implicit/contract aliases and addresses on the type level+* [!1187](https://gitlab.com/morley-framework/morley/-/merge_requests/1187)+  Access MorleyClientEnv in network tests+  + Add `NetworkCaps` carrying `NetworkEnv`.+  + Replace `ScenarioCleveland` with `ScenarioNetwork`.+  + Reimplement `scenario` as a function in `MonadScenario` typeclass.+  + Rename `Scenario` to `Scenario'`, add `Scenario` synonym that bakes in+    `MonadScenario` constraint.+  + Allow `ifEmulation` to access `NetworkCaps` in the on-network branch.+* [!1168](https://gitlab.com/morley-framework/morley/-/merge_requests/1168)+  Support a mix of RPC and non-RPC representations in `runCode`+* [!1137](https://gitlab.com/morley-framework/morley/-/merge_requests/1137)+  Refactor Cleveland's originate\* and `transfer`/`transferMoney`/`call`+  functions+  + All 9 `originate*` functions are replaced with single `originate`,+    optionally accepting initial balance (as `Mutez`) and whether it's a large+    origination (using `Large` argument).+  + `transfer`, `transferMoney` and `call` functions replaced by `transfer` and+    two helpers, `calling` and `unsafeCalling`.+ 0.2.0 ===== * [!1172](https://gitlab.com/morley-framework/morley/-/merge_requests/1172)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           cleveland-version:        0.2.0+version:        0.2.1 synopsis:       Testing framework for Morley. description:    This package provides an eDSL for testing contracts written in Michelson, Morley or Lorentz. These tests can be run on an emulated environment or on a real network. category:       Blockchain@@ -58,6 +58,14 @@       Test.Cleveland.Instances       Test.Cleveland.Internal.Abstract       Test.Cleveland.Internal.Actions+      Test.Cleveland.Internal.Actions.Assertions+      Test.Cleveland.Internal.Actions.ExceptionHandling+      Test.Cleveland.Internal.Actions.Helpers+      Test.Cleveland.Internal.Actions.Misc+      Test.Cleveland.Internal.Actions.MonadOps+      Test.Cleveland.Internal.Actions.Originate+      Test.Cleveland.Internal.Actions.Transfer+      Test.Cleveland.Internal.Actions.TransferFailurePredicate       Test.Cleveland.Internal.Client       Test.Cleveland.Internal.Exceptions       Test.Cleveland.Internal.Hedgehog@@ -108,6 +116,7 @@       GADTs       GeneralizedNewtypeDeriving       ImportQualifiedPost+      InstanceSigs       LambdaCase       MultiParamTypeClasses       MultiWayIf@@ -187,6 +196,7 @@   other-modules:       TestSuite.Cleveland.AddressRevealing       TestSuite.Cleveland.Assertions+      TestSuite.Cleveland.BadAddressReuse       TestSuite.Cleveland.BalanceCheck       TestSuite.Cleveland.BatchOperation       TestSuite.Cleveland.BatchTransferCheck@@ -196,9 +206,11 @@       TestSuite.Cleveland.ChainIdGet       TestSuite.Cleveland.ContractAllocation       TestSuite.Cleveland.DFS+      TestSuite.Cleveland.EmitMachinery       TestSuite.Cleveland.EmptyImplicitAddress       TestSuite.Cleveland.Emulated       TestSuite.Cleveland.Entrypoints+      TestSuite.Cleveland.ErrorMessages       TestSuite.Cleveland.ExpectFailure       TestSuite.Cleveland.FailureLogs       TestSuite.Cleveland.Import@@ -207,11 +219,13 @@       TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator       TestSuite.Cleveland.Lorentz.Entrypoints       TestSuite.Cleveland.MismatchError+      TestSuite.Cleveland.NetworkCaps       TestSuite.Cleveland.NewAddressCheck       TestSuite.Cleveland.OperationReplay       TestSuite.Cleveland.PrettyFailWith       TestSuite.Cleveland.PublicKeyToAddress       TestSuite.Cleveland.RefillableAddress+      TestSuite.Cleveland.ResolveAddress       TestSuite.Cleveland.RunCode       TestSuite.Cleveland.StorageCheck       TestSuite.Cleveland.StorageWithBigMaps@@ -253,6 +267,7 @@       GADTs       GeneralizedNewtypeDeriving       ImportQualifiedPost+      InstanceSigs       LambdaCase       MultiParamTypeClasses       MultiWayIf

@@ -34,7 +34,7 @@ import Hedgehog.Range qualified as Range  import Hedgehog.Gen.Michelson.Untyped (genEpName)-import Hedgehog.Gen.Tezos.Address (genAddress)+import Hedgehog.Gen.Tezos.Address import Hedgehog.Gen.Tezos.Core (genChainId, genMutez, genTimestamp) import Hedgehog.Gen.Tezos.Crypto (genKeyHash, genPublicKey, genSignature) import Hedgehog.Gen.Tezos.Crypto.BLS12381 (genBls12381Fr, genBls12381G1, genBls12381G2)@@ -45,7 +45,7 @@ import Morley.Michelson.Typed.Haskell.Value (BigMap(..), BigMapId(..), ToT, WellTypedToT) import Morley.Michelson.Typed.Scope import Morley.Michelson.Typed.Value (RemFail(..))-import Morley.Tezos.Address (TxRollupL2Address(..))+import Morley.Tezos.Address (ConstrainedAddress(..), TxRollupL2Address(..)) import Morley.Tezos.Core (Mutez, Timestamp) import Morley.Tezos.Crypto (parseHash) import Morley.Tezos.Crypto.BLS12381 qualified as BLS@@ -79,7 +79,7 @@     <*> Gen.map (unLength <$> len) (liftA2 (,) genKey genVal)  genEpAddress :: (MonadGen m, GenBase m ~ Identity) => m EpAddress-genEpAddress = EpAddress <$> genAddress <*> genEpName+genEpAddress = EpAddress' <$> genAddress <*> genEpName  genValueKeyHash :: MonadGen m => m (Value' instr 'TKeyHash) genValueKeyHash = VKeyHash <$> genKeyHash@@ -128,7 +128,7 @@ genValueTicket   :: (MonadGen m, Comparable a)   => Range TicketAmount -> m (Value' instr a) -> m (Value' instr ('TTicket a))-genValueTicket range genVal = VTicket <$> genAddress <*> genVal+genValueTicket range genVal = VTicket . MkAddress <$> genContractAddress <*> genVal   <*> Gen.integral (unTicketAmount <$> range)  genValueChestAndKey :: MonadGen m => m (Value' instr 'TChest, Value' instr 'TChestKey)

@@ -14,14 +14,14 @@ import Hedgehog.Range qualified as Range  import Hedgehog.Gen.Tezos.Crypto (genKeyHash)-import Morley.Tezos.Address (Address(..))+import Morley.Tezos.Address import Morley.Tezos.Crypto  genAddress :: MonadGen m => m Address-genAddress = Gen.choice [genKeyAddress, genContractAddress]+genAddress = Gen.choice [MkAddress <$> genKeyAddress, MkAddress <$> genContractAddress] -genKeyAddress :: MonadGen m => m Address-genKeyAddress = KeyAddress <$> genKeyHash+genKeyAddress :: MonadGen m => m ImplicitAddress+genKeyAddress = ImplicitAddress <$> genKeyHash -genContractAddress :: MonadGen m => m Address+genContractAddress :: MonadGen m => m ContractAddress genContractAddress = ContractAddress . Hash HashContract <$> Gen.bytes (Range.singleton 20)

@@ -7,12 +7,17 @@ -- for usage instructions. module Test.Cleveland   ( Alias+  , ContractAlias+  , ImplicitAlias+  , KindedAddress+  , ContractAddress+  , ImplicitAddress   , ContractHandle (..)-  , OriginateData (..)-  , UntypedOriginateData (..)   , TransferData (..)+  , TypedContract (..)   , Scenario   , PureM+  , ClientM    -- * Validation   , TransferFailure@@ -20,7 +25,9 @@   -- * Real network implementation based on @tezos-client@ and RPC.   , testScenario   , testScenarioOnNetwork-  , scenario+  , scenarioNetwork+  , MonadScenario(..)+  , getMorleyClientEnv    -- * Emulation tests   , testScenarioOnEmulator@@ -50,17 +57,13 @@   , signBytes   , signBinary   , originate-  , originateSimple-  , originateUntyped-  , originateUntypedSimple-  , originateTypedSimple-  , originateLarge-  , originateLargeSimple-  , originateLargeUntyped-  , originateLargeUntypedSimple+  , Large (..)   , transfer-  , transferMoney-  , call+  , WithContractEvents (..)+  , ContractEvent (..)+  , calling+  , Default(def)+  , unsafeCalling   , importUntypedContract   , importContract   , noViews@@ -89,7 +92,6 @@   , getApproximateBlockInterval   , getMinBlockTime   , RunCode(..)-  , AsRPC.MaybeRPC(..)   , runCode   , branchout   , offshoot@@ -99,9 +101,16 @@   , ifEmulation   , inBatch +  -- * Address conversions+  , ToAddress(..)+  , ToL1Address(..)+  , ToL1TAddress(..)+   -- * Primitives re-exports   , EntrypointRef (..)   , VotingPowers+  , Mutez+  , tz   , mkVotingPowers   , mkVotingPowersFromMap @@ -153,6 +162,8 @@   , pattern DefEpName   , ep   , (?-)+  , (:!)+  , NamedF (..)    -- * Integration with @hedgehog@   , testScenarioProps@@ -178,12 +189,15 @@   , forEach   ) where -import Lorentz (EntrypointRef(..), pattern DefEpName)+import Data.Default (Default(def))++import Lorentz (EntrypointRef(..), Mutez, ToAddress(..), pattern DefEpName, tz) import Morley.AsRPC qualified as AsRPC import Morley.Client (MorleyClientEnv, MorleyClientEnv'(..)) import Morley.Client.TezosClient.Types (TezosClientEnv(..)) import Morley.Michelson.Interpret (MorleyLogs) import Morley.Michelson.Runtime (VotingPowers, mkVotingPowers, mkVotingPowersFromMap)+import Morley.Util.Named import Test.Cleveland.Instances () import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions@@ -191,5 +205,6 @@ import Test.Cleveland.Internal.Hedgehog import Test.Cleveland.Internal.Pure import Test.Cleveland.Internal.Scenario+import Test.Cleveland.Lorentz (ToL1Address(..), ToL1TAddress(..)) import Test.Cleveland.Tasty.Internal import Test.Cleveland.Util

@@ -7,17 +7,20 @@   ( HasErrorSrcPos (..)   ) where +import Data.Default (Default(..)) import Fmt (Buildable(..), eitherF, hexF, tupleF, (+|), (|+)) import GHC.Num qualified (fromInteger) import Test.Tasty.Runners (FailureReason(..)) import Time (Time) +import Lorentz.Entrypoints.Core (EntrypointRef(..), NiceEntrypointName) import Morley.Michelson.Text (MText, mkMText) import Morley.Michelson.Typed.Haskell.Value (BigMap(..)) import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Annotation (Annotation(..), mkAnnotation)-import Morley.Tezos.Address.Alias (Alias(..))+import Morley.Tezos.Address.Alias import Morley.Tezos.Core (Mutez(..), mkMutez, unsafeAddMutez, unsafeMulMutez, unsafeSubMutez)+import Morley.Util.TypeLits (symbolValT')  instance IsString (Annotation tag) where   fromString = unsafe . mkAnnotation . toText@@ -145,5 +148,17 @@ instance (Buildable a, Buildable b) => Buildable (Either a b) where   build = eitherF -instance IsString Alias where-  fromString = Alias . fromString+instance mname ~ 'Nothing => Default (EntrypointRef mname) where+  def = CallDefault++instance Default U.EpName where+  def = U.DefEpName++instance NiceEntrypointName sym => IsLabel sym U.EpName where+  fromLabel = unsafe . U.buildEpName $ symbolValT' @sym++instance IsString ImplicitAlias where+  fromString = ImplicitAlias . fromString++instance IsString ContractAlias where+  fromString = ContractAlias . fromString

@@ -35,8 +35,13 @@   , Sender (..)   , Moneybag (..)   , UntypedOriginateData (..)-  , RunCode(..)+  , TypedOriginateData (..)+  , LargeOrigination (..)+  , TypedContract (..)+  , RunCode (..)   , ClevelandInput+  , ClevelandResult+  , ContractEvent (..)    , DefaultAliasCounter (..)   , SpecificOrDefaultAlias (..)@@ -58,6 +63,7 @@   , runSingleOperation    -- * Validation+  , AddressAndAlias(..)   , TransferFailure (..)   , TransferFailureReason (..)   , FailedInBranch (..)@@ -72,21 +78,30 @@    -- * Morley client re-exports   , Alias+  , ImplicitAlias+  , ContractAlias+  , KindedAddress+  , ContractAddress+  , ImplicitAddress    -- * Capability records   , ClevelandCaps(..)   , EmulatedCaps(..)+  , NetworkCaps(..)   , HasClevelandCaps(..)   , senderL   , moneybagL   , getMiscCap   , getOpsCap   , HasEmulatedCaps(..)+  , HasNetworkCaps(..)    , MonadCleveland   , MonadEmulated+  , MonadNetwork   , ClevelandT   , EmulatedT+  , NetworkT    -- * Log utilities   , LogsInfo@@ -97,9 +112,16 @@   , filterLogsByAddrL   , logsForAddress   , collectLogs++  -- * Network environment+  , NetworkEnv(..)+  , neMorleyClientEnvL+  , neSecretKeyL+  , neMoneybagAliasL+  , neExplicitDataDirL   ) where -import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor)+import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor, makeLensesWith) import Data.Default (Default(..)) import Data.Type.Equality (pattern Refl) import Data.Typeable (cast)@@ -109,8 +131,9 @@  import Lorentz (Contract(..)) import Lorentz.Constraints-import Morley.AsRPC (HasRPCRepr(AsRPC), MaybeRPC)-import Morley.Client (Result)+import Lorentz.Entrypoints.Core (EntrypointRef(..), NiceEntrypointName, eprName)+import Morley.AsRPC (HasRPCRepr(AsRPC))+import Morley.Client (MorleyClientEnv, Result) import Morley.Client.Types import Morley.Micheline (Expression, fromExpression) import Morley.Michelson.ErrorPos (ErrorSrcPos)@@ -123,19 +146,25 @@ import Morley.Michelson.Typed.Scope (ConstantScope) import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address-import Morley.Tezos.Address.Alias (Alias(..))+import Morley.Tezos.Address.Alias import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.Batching+import Morley.Util.Lens (postfixLFields) import Morley.Util.Sing (eqI) import Morley.Util.TypeLits import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) import Test.Cleveland.Lorentz.Types -data OriginateData param st vd =+-- | Whether this contract should be originated in+-- a single origination operation or, if it goes over+-- the origination size limit, in multiple operations.+data LargeOrigination = IsLarge | NotLarge++data OriginateData param st vd (large :: LargeOrigination) =   OriginateData-  { odName :: Alias+  { odName :: ContractAlias   -- ^ Alias for the originated contract.   , odBalance :: Mutez   -- ^ Initial balance.@@ -151,8 +180,8 @@  -- | Untyped version of OriginateData. It can be used for interaction with raw -- Michelson contracts-data UntypedOriginateData = UntypedOriginateData-  { uodName :: Alias+data UntypedOriginateData (large :: LargeOrigination) = UntypedOriginateData+  { uodName :: ContractAlias   -- ^ Alias for the originated contract.   , uodBalance :: Mutez   -- ^ Initial balance.@@ -162,9 +191,22 @@   -- ^ The contract itself.   } +-- | Untyped version of OriginateData. It can be used for interaction with raw+-- Michelson contracts+data TypedOriginateData cp st vd (large :: LargeOrigination) = TypedOriginateData+  { todName :: ContractAlias+  -- ^ Alias for the originated contract.+  , todBalance :: Mutez+  -- ^ Initial balance.+  , todStorage :: st+  -- ^ Initial storage.+  , todContract :: T.Contract (T.ToT cp) (T.ToT st)+  -- ^ The contract itself.+  }+ -- | Information about transfer operation. data TransferData =-  forall v addr. (NiceParameter v, ToAddress addr) => TransferData+  forall v addr. (NiceParameter v, ToL1Address addr) => TransferData   { tdTo :: addr   -- ^ Receiver address for this transaction.   , tdAmount :: Mutez@@ -177,13 +219,31 @@   -- for transfers to key addresses.   } +-- | A wrapper around t'T.Contract' to reduce awkwardness+data TypedContract cp st vd where+  TypedContract :: T.Contract (T.ToT cp) (T.ToT st) -> TypedContract cp st vd+ -- | Designates an operation input. data ClevelandInput instance OperationInfoDescriptor ClevelandInput where   type TransferInfo ClevelandInput = TransferData-  type OriginationInfo ClevelandInput = UntypedOriginateData+  type OriginationInfo ClevelandInput = UntypedOriginateData 'NotLarge   type RevealInfo ClevelandInput = PublicKey +-- | Data structure representing a contract event.+data ContractEvent = ContractEvent+  { ceSource :: ContractAddress+  , ceTag :: Text+  , cePayload :: Maybe SomeAnnotatedValue+  }++-- | Designates an operation result.+data ClevelandResult+instance OperationInfoDescriptor ClevelandResult where+  type TransferInfo ClevelandResult = [ContractEvent]+  type OriginationInfo ClevelandResult = OriginationInfo Result+  type RevealInfo ClevelandResult = RevealInfo Result+ -- | A batch returned invalid output, e.g. origination address when transaction -- was supplied. data BatchResultMismatch@@ -200,7 +260,7 @@ -- This is initialized to @moneybag@ address and then can be locally modified. -- -- Operations in `ClevelandOpsImpl` are affected by this address.-newtype Sender = Sender { unSender :: Address }+newtype Sender = Sender { unSender :: ImplicitAddress }  -- | Designates the address that gifts money to new addresses. --@@ -212,24 +272,24 @@ -- moneybag is not necessary. If a user wraps a large piece of their script with -- 'Test.Cleveland.withSender' call and that changes the moneybag - this behaviour may be -- undesired and unexpected to the user.-newtype Moneybag = Moneybag { unMoneybag :: Address }+newtype Moneybag = Moneybag { unMoneybag :: ImplicitAddress }  -- | An alias with default value that can be used to define unique alias -- automatically. data SpecificOrDefaultAlias-  = SpecificAlias Alias+  = SpecificAlias ImplicitAlias   | DefaultAlias   deriving stock (Show)  instance IsString SpecificOrDefaultAlias where-  fromString = SpecificAlias . Alias . fromString+  fromString = SpecificAlias . ImplicitAlias . fromString  instance Default SpecificOrDefaultAlias where   def = DefaultAlias -mkDefaultAlias :: Natural -> Alias+mkDefaultAlias :: Natural -> ImplicitAlias mkDefaultAlias counter =-  Alias . fromString $ ("default_cleveland_alias" <> show counter)+  ImplicitAlias . fromString $ ("default_cleveland_alias" <> show counter)  -- | Helper to use automatically determined unique alias. auto :: SpecificOrDefaultAlias@@ -242,7 +302,7 @@ -- | A record data type with operations creating primitives. data ClevelandOpsImpl m = ClevelandOpsImpl   { coiRunOperationBatch-      :: HasCallStack => [OperationInfo ClevelandInput] -> m [OperationInfo Result]+      :: HasCallStack => [OperationInfo ClevelandInput] -> m [OperationInfo ClevelandResult]   -- ^ Perform a batch of operations.   } @@ -250,19 +310,19 @@ data ClevelandMiscImpl m = ClevelandMiscImpl   { cmiRunIO :: forall res. HasCallStack => IO res -> m res   -- ^ Runs an 'IO' action.-  , cmiResolveAddress :: HasCallStack => Alias -> m Address+  , cmiResolveAddress :: forall kind. HasCallStack => Alias kind -> m (KindedAddress kind)   -- ^ Get the address of the implicit account / contract associated with the given alias.-  , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m Address+  , cmiGenKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddress   -- ^ Generate a secret key and store it with given alias.   -- If a key with this alias already exists, the corresponding address   -- will be returned and no state will be changed.-  , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAlias -> m Address+  , cmiGenFreshKey :: HasCallStack => SpecificOrDefaultAlias -> m ImplicitAddress   -- ^ Generate a secret key and store it with given alias.   -- Unlike 'cmiGenKey' this function overwrites the existing key when   -- given alias is already stored.-  , cmiSignBytes :: HasCallStack => ByteString -> Address -> m Crypto.Signature+  , cmiSignBytes :: HasCallStack => ByteString -> ImplicitAddress -> m Crypto.Signature   -- ^ Get the signature of the preapplied operation.-  , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData -> m Address+  , cmiOriginateLargeUntyped :: HasCallStack => Sender -> UntypedOriginateData 'IsLarge -> m ContractAddress   -- ^ Originate a new raw Michelson contract that doesn't fit into the   -- origination size limit, by executing multiple operation steps.   --@@ -272,9 +332,9 @@   , cmiComment :: HasCallStack => Text -> m ()   -- ^ Print the given string verbatim as a comment.   -- At the moment, this is a no-op in emulator tests.-  , cmiGetBalance :: HasCallStack => Address -> m Mutez+  , cmiGetBalance :: HasCallStack => L1Address -> m Mutez   -- ^ Get the balance of the given address.-  , cmiGetSomeStorage :: HasCallStack => Address -> m SomeAnnotatedValue+  , cmiGetSomeStorage :: HasCallStack => ContractAddress -> m SomeAnnotatedValue   -- Retrieves the contract's storage.   , cmiGetBigMapValueMaybe       :: forall k v. (HasCallStack, NiceComparable k, NicePackedValue k, NiceUnpackedValue v)@@ -287,12 +347,12 @@       => BigMapId k v -> m (Maybe [v])   -- ^ Retrieve all big_map values, given a big_map ID.   -- Returns 'Nothing' when the big_map ID does not exist.-  , cmiGetPublicKey :: HasCallStack => Address -> m Crypto.PublicKey+  , cmiGetPublicKey :: HasCallStack => ImplicitAddress -> m Crypto.PublicKey   -- ^ Get the public key associated with the given address.   -- Fail if the given address is not an implicit account.-  , cmiGetDelegate :: HasCallStack => Address -> m (Maybe Crypto.KeyHash)+  , cmiGetDelegate :: HasCallStack => ContractAddress -> m (Maybe Crypto.KeyHash)   -- ^ Get the delegate for the given contract. Fails on implicit contracts.-  , cmiRegisterDelegate :: HasCallStack => Address -> m ()+  , cmiRegisterDelegate :: HasCallStack => ImplicitAddress -> m ()   -- ^ Register the given address as a valid delegate.   , cmiGetChainId :: HasCallStack => m ChainId   -- ^ Get the chain's @ChainId@.@@ -318,11 +378,12 @@   -- is minimal bound and real intervals can be larger.   , cmiAttempt :: forall a e. (Exception e, HasCallStack) => m a -> m (Either e a)   -- ^ Attempts to perform an action, returning either the result of the action or an exception.-  , cmiMarkAddressRefillable :: Address -> m ()+  , cmiMarkAddressRefillable :: ImplicitAddress -> m ()   -- ^ Marks a given address as "refillable", i.e. if the address lacks funds for the next operation,   -- some funds will automatically be transferred to it.-  , cmiEmulatedImpl :: m (Maybe (EmulatedImpl m))-  -- ^ Produce 'EmulatedImpl' if possible. Used to run emulated actions in polymorphic context.+  , cmiUnderlyingImpl :: m (Either (EmulatedImpl m) NetworkEnv)+  -- ^ Produce underlying implementation specific data. Used to run+  -- emulation-only or network-only actions in a polymorphic context.   , cmiRunCode       :: forall cp st vd. (HasCallStack, HasRPCRepr st, T.IsoValue (AsRPC st))       => Sender -> RunCode cp st vd -> m (AsRPC st)@@ -333,8 +394,20 @@ -- | The data needed to call the @/run_code@ RPC endpoint. data RunCode cp st vd = RunCode   { rcContract :: Contract cp st vd-  , rcStorage :: MaybeRPC st-  , rcParameter :: MaybeRPC cp+  , rcParameter :: U.Value+  -- ^ The parameter value should have the same "structure" as @cp@, except it _may_ also have big_map IDs.+  -- E.g. if the contract's parameter is @pair (big_map string string) (big_map string string)@,+  -- then 'rcParameter' may be one of:+  --+  -- * @pair (big_map string string) (big_map string string)@+  -- * @pair nat (big_map string string)@+  -- * @pair (big_map string string) nat@+  -- * @pair nat nat@+  --+  -- ... where @nat@ represents a big_map ID.+  , rcStorage :: U.Value+  -- ^ The storage value should have the same "structure" as @st@, except it _may_ also have big_map IDs.+  -- See the documentation of 'rcParameter'.   , rcAmount :: Mutez   -- ^ The value that will be returned by the @AMOUNT@ instruction.   , rcLevel :: Maybe Natural@@ -343,7 +416,7 @@   -- ^ The value that will be returned by the @NOW@ instruction.   , rcBalance :: Mutez   -- ^ The balance that will be returned by the @BALANCE@ instruction.-  , rcSource :: Maybe Address+  , rcSource :: Maybe ImplicitAddress   -- ^ The value that will be returned by the @SOURCE@ instruction.   } @@ -376,6 +449,13 @@   -- ^ Change voting power distribution.   } +data NetworkEnv = NetworkEnv+  { neMorleyClientEnv :: MorleyClientEnv+  , neSecretKey :: Maybe Crypto.SecretKey+  , neMoneybagAlias :: ImplicitAlias+  , neExplicitDataDir :: Bool+  }+ ---------------------------------------------------------------------------- -- Log helpers ----------------------------------------------------------------------------@@ -388,6 +468,7 @@ type LogsInfo = [ScenarioLogs]  makeLenses ''ScenarioLogs+makeLensesWith postfixLFields ''NetworkEnv  -- | An alias for 'slLog' with a clearer name logsL :: Lens' ScenarioLogs MorleyLogs@@ -426,7 +507,7 @@ -- @-XApplicativeDo@ extension for nicer experience. newtype ClevelandOpsBatch a = ClevelandOpsBatch   { unClevelandOpsBatch-      :: BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) Void a+      :: BatchingM (OperationInfo ClevelandInput) (OperationInfo ClevelandResult) Void a   } deriving newtype (Functor, Applicative)  instance@@ -480,7 +561,7 @@   :: (HasCallStack, Buildable e, Functor m)   => Proxy e   -> ClevelandOpsImpl m-  -> BatchingM (OperationInfo ClevelandInput) (OperationInfo Result) e a+  -> BatchingM (OperationInfo ClevelandInput) (OperationInfo ClevelandResult) e a   -> m a runOperationBatchM _ impl =   fmap snd . unsafeRunBatching (fmap ((), ) . coiRunOperationBatch impl)@@ -491,7 +572,7 @@   => ClevelandOpsImpl m   -> Text   -> OperationInfo ClevelandInput-  -> (OperationInfo Result -> Maybe a)+  -> (OperationInfo ClevelandResult -> Maybe a)   -> m a runSingleOperation impl desc opData parseRes =   runOperationBatchM (Proxy @BatchResultMismatch) impl $@@ -521,10 +602,17 @@     EOTVExpression e -> either (const $ build e) build $ fromExpression @U.Value e     EOTVTypedValue v -> build v +data AddressAndAlias = AddressAndAlias Address (Maybe ContractAlias)+  deriving stock (Show, Eq)++instance Buildable AddressAndAlias where+  build (AddressAndAlias addr mbAlias) =+    build addr +| maybe "" (\alias -> " (" +| alias |+ ")") mbAlias+ -- | Failures that could be expected in the execution of a transfer. -- These can be caught and handled with 'Test.Cleveland.attempt'. data TransferFailure = TransferFailure-  { tfAddress :: Address+  { tfAddressAndAlias :: AddressAndAlias   , tfReason :: TransferFailureReason   } deriving stock (Show, Eq) @@ -542,7 +630,7 @@   -- ^ Expect that interpretation of contract with the given address ended   -- with an overflow error.   | GasExhaustion-  -- TODO: [#284] add more errors here!+  -- TODO [#284]: add more errors here!   deriving stock (Show, Eq)  -- | When an exception is thrown in a 'Test.Cleveland.branchout' branch, we wrap it in this@@ -614,16 +702,39 @@ -- Other helpers ---------------------------------------------------------------------------- --- | A short partial constructor for 'EpName'. It is supposed to be--- applied to string constants, so programmer is responsible for--- validity. And this code is for tests anyway, so each failure is a--- programmer mistake.------ It is intentionally here and not in some deeper module because the--- name is really short and more suitable for writing scenarios.-ep :: HasCallStack => Text -> EpName-ep = unsafe . U.buildEpName+class NiceEntrypointName epName => EntrypointNameConstructor (epName :: Symbol) a where+  -- | A short partial constructor for 'EpName' or 'EntrypointRef'. It accepts a+  -- type-level string as its type argument. The programmer is responsible for+  -- validity. And this code is for tests anyway, so each failure is a+  -- programmer mistake.+  --+  -- Note that entrypoint names should be capitalized, e.g.+  --+  -- > ep @"Entrypoint"+  --+  -- corresponds to @entrypoint@, etc.+  --+  -- It is intentionally here and not in some deeper module because the name is+  -- really short and more suitable for writing scenarios.+  --+  -- For 'EpName', an instance is provided accepting a value-level t'Text'+  -- instead of a type-level symbol. This is mostly for cases where the+  -- type-level symbol doesn't work. Note that value-level string will be used+  -- verbatim, hence capitalization is arbitrary.+  --+  -- > ep "entrypoint"+  ep :: a +instance (NiceEntrypointName epName, mname ~ 'Just epName)+  => EntrypointNameConstructor epName (EntrypointRef mname) where+  ep = Call++instance NiceEntrypointName epName => EntrypointNameConstructor epName EpName where+  ep = eprName $ Call @epName++instance (any ~ "", t ~ Text) => EntrypointNameConstructor any (t -> EpName) where+  ep = unsafe . U.buildEpName+ -- | Runs a handler over every action. mapClevelandOpsImplExceptions   :: (forall a. HasCallStack => m a -> m a)@@ -662,7 +773,7 @@     , cmiAttempt = \action -> cmiAttempt action     , cmiMarkAddressRefillable = f . cmiMarkAddressRefillable     , cmiThrow = cmiThrow-    , cmiEmulatedImpl = f $ cmiEmulatedImpl+    , cmiUnderlyingImpl = f $ cmiUnderlyingImpl     , cmiRunCode = f ... cmiRunCode     } @@ -680,8 +791,15 @@   , ecClevelandCaps :: ClevelandCaps m   } +-- | A record with all the capabilities available to a cleveland test on the network.+data NetworkCaps m = NetworkCaps+  { ncNetworkEnv :: NetworkEnv+  , ncClevelandCaps :: ClevelandCaps m+  }+ makeLensesFor [("ccSender", "ccSenderL"), ("ccMoneybag", "ccMoneybagL")] ''ClevelandCaps makeLensesFor [("ecClevelandCaps", "ecClevelandCapsL")] ''EmulatedCaps+makeLensesFor [("ncClevelandCaps", "ncClevelandCapsL")] ''NetworkCaps  -- | A proof that the given @caps@ record contains -- the basic cleveland capabilities.@@ -691,7 +809,7 @@   clevelandCapsL :: Lens' caps (ClevelandCaps (ClevelandBaseMonad caps))  -- | A proof that the given @caps@ record contains--- the basic cleveland capabilities + the emulator capabiilities.+-- the basic cleveland capabilities + the emulator capabilities. class HasClevelandCaps caps => HasEmulatedCaps caps where   getEmulatedCap :: caps -> EmulatedImpl (ClevelandBaseMonad caps) @@ -718,21 +836,43 @@ instance Monad m => HasEmulatedCaps (EmulatedCaps m) where   getEmulatedCap = ecEmulatedCap +-- | A proof that the given @caps@ record contains+-- the basic cleveland capabilities + the network capabilities.+class HasClevelandCaps caps => HasNetworkCaps caps where+  getNetworkEnvCap :: caps -> NetworkEnv++instance Monad m => HasClevelandCaps (NetworkCaps m) where+  type ClevelandBaseMonad (NetworkCaps m) = m+  clevelandCapsL = ncClevelandCapsL++instance Monad m => HasNetworkCaps (NetworkCaps m) where+  getNetworkEnvCap = ncNetworkEnv+ -- | Constraint for a monad in which we can do cleveland actions. type MonadCleveland caps m =   ( m ~ ReaderT caps (ClevelandBaseMonad caps)   , HasClevelandCaps caps   ) --- | Constraint for a monad in which we can do cleveland actions that can't be run on a real network.--- It requires the 'EmulatedImpl' capability.+-- | Constraint for a monad in which we can do cleveland actions that can't be+-- run on a real network. It requires the 'EmulatedCaps' capability. type MonadEmulated caps m =   ( MonadCleveland caps m   , HasEmulatedCaps caps   ) +-- | Constraint for a monad in which we can do cleveland actions that can only+-- be run on a real network. It requires the 'NetworkCaps' capability.+type MonadNetwork caps m =+  ( MonadCleveland caps m+  , HasNetworkCaps caps+  )+ -- | Monad transformer that adds only the 'ClevelandCaps' capabilities. type ClevelandT m = ReaderT (ClevelandCaps m) m  -- | Monad transformer that adds both 'ClevelandCaps' and 'EmulatedCaps' capabilities. type EmulatedT m = ReaderT (EmulatedCaps m) m++-- | Monad transformer that adds both 'ClevelandCaps' and 'NetworkCaps' capabilities.+type NetworkT m = ReaderT (NetworkCaps m) m

@@ -3,1254 +3,123 @@  -- | Cleveland actions. module Test.Cleveland.Internal.Actions-  ( MonadOps(..)-  , withSender-  , withMoneybag-  , runIO-  , resolveAddress-  , refillable-  , newAddress-  , newAddresses-  , newFreshAddress-  , enumAliases-  , signBytes-  , signBinary-  , originate-  , originateSimple-  , originateUntyped-  , originateUntypedSimple-  , originateTypedSimple-  , originateLarge-  , originateLargeSimple-  , originateLargeUntyped-  , originateLargeUntypedSimple-  , transfer-  , transferMoney-  , call-  , inBatch-  , importUntypedContract-  , importContract-  , noViews-  , comment-  , getBalance-  , getStorage-  , getFullStorage-  , getSomeStorage-  , getAllBigMapValues-  , getAllBigMapValuesMaybe-  , getBigMapSize-  , getBigMapSizeMaybe-  , getBigMapValueMaybe-  , getBigMapValue-  , getMorleyLogs-  , getMorleyLogs_-  , getPublicKey-  , getChainId-  , advanceTime-  , advanceLevel-  , advanceToLevel-  , getNow-  , getLevel-  , getApproximateBlockInterval-  , getMinBlockTime-  , runCode-  , branchout-  , offshoot-  , getDelegate-  , registerDelegate-  , setVotingPowers-  , whenEmulation-  , whenNetwork-  , ifEmulation--  -- * Assertions-  , failure-  , assert-  , (@==)-  , (@/=)-  , (@@==)-  , (@@/=)-  , checkCompares-  , checkComparesWith-  , evalJust-  , evalRight--  -- * Exception handling-  , attempt-  , catchTransferFailure-  , checkTransferFailure-  , expectTransferFailure-  , expectFailedWith-  , expectError-  , expectCustomError-  , expectCustomError_-  , expectCustomErrorNoArg-  , expectNumericError-  , clarifyErrors-  -- ** TransferFailure predicates-  , TransferFailurePredicate(..)-  , shiftOverflow-  , emptyTransaction-  , badParameter-  , gasExhaustion-  , failedWith-  , addressIs-  -- ** @FAILWITH@ errors-  , constant-  , lerror-  , customError-  , customError_-  , customErrorNoArg-  , numericError--  -- * Helpers-  , withCap-  ) where--import Data.Constraint (Dict(Dict), (\\))-import Data.Either.Validation (Validation(..))-import Data.List.NonEmpty qualified as NE-import Data.Singletons (demote)-import Fmt (Buildable, Builder, build, indentF, nameF, pretty, unlinesF, (+|), (|+))-import Time (KnownDivRat, Second, Time, toNum)-import Unsafe qualified (fromIntegral)--import Lorentz-  (BigMapId, Contract(..), CustomError(..), DemoteViewsDescriptor, ErrorTagMap,-  HasEntrypointArg(useHasEntrypointArg), IsError, IsoValue, Label, MText, MustHaveErrorArg,-  ToTAddress, errorTagToMText, errorToVal, errorToValNumeric, noViews, pattern DefEpName,-  toMichelsonContract, toTAddress, toVal, zeroMutez)-import Lorentz.Bytes-import Lorentz.Constraints-import Morley.AsRPC (HasRPCRepr(..))-import Morley.Client (OperationInfo(..))-import Morley.Micheline (Expression, fromExpression, toExpression)-import Morley.Michelson.Printer.Util (buildRenderDoc)-import Morley.Michelson.Runtime (VotingPowers)-import Morley.Michelson.Runtime.Import qualified as Runtime-import Morley.Michelson.Typed-  (SomeAnnotatedValue, SomeConstant, SomeConstrainedValue(..), convertContract, untypeValue)-import Morley.Michelson.Typed qualified as T-import Morley.Michelson.Typed.AnnotatedValue (castTo, getT, value)-import Morley.Michelson.Untyped qualified as U-import Morley.Tezos.Address (Address)-import Morley.Tezos.Address.Alias (Alias(..))-import Morley.Tezos.Core (ChainId, Mutez, Timestamp)-import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature)-import Morley.Util.SizedList qualified as SL-import Morley.Util.SizedList.Types-import Test.Cleveland.Internal.Abstract-import Test.Cleveland.Internal.Client qualified as Client (TestError(..))-import Test.Cleveland.Internal.Exceptions (WithCallStack(..))-import Test.Cleveland.Internal.Pure as Pure (TestError(..))-import Test.Cleveland.Lorentz.Import qualified as LorentzImport-import Test.Cleveland.Lorentz.Types--{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}---- $setup--- >>> :m +Morley.Util.SizedList.Types--- >>> :{--- isEquivalentTo :: Show a => a -> a -> Bool--- isEquivalentTo a b = show a == show b--- infix 0 `isEquivalentTo`--- :}---- | Typeclass for monads where operations-related actions can occur.------ This is implemented for 'MonadCleveland' and batch context.------ Has 'Functor' as a superclass constraint for convenience, all the related methods--- require it.-class Functor m => MonadOps m where-  -- | Obtain 'ClevelandOpsImpl' suitable for the current \"monad\".-  ---  -- In CPS style, because the \"monad\" can be actually not a monad, so-  -- it can't work like 'ask' for 'ReaderT'.-  withOpsCap :: (ClevelandOpsImpl m -> m a) -> m a--instance MonadOps ClevelandOpsBatch where-  withOpsCap mkAction = mkAction batchedOpsImpl--instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOps (ReaderT caps m) where-  withOpsCap mkAction = do-    opsCap :: ClevelandOpsImpl m <- asks getOpsCap-    let opsCap' :: ClevelandOpsImpl (ReaderT caps m) =-          ClevelandOpsImpl-            { coiRunOperationBatch =  lift ... coiRunOperationBatch opsCap-            }-    mkAction opsCap'---- | Update the current sender on whose behalf transfers and originations are--- invoked.-withSender :: MonadCleveland caps m => Address -> m a -> m a-withSender addr =-  local (set senderL (Sender addr))---- | Update the current moneybag that transfers money on the newly created--- addresses. For the rare occasions when this is necessary.-withMoneybag :: MonadCleveland caps m => Address -> m a -> m a-withMoneybag addr =-  local (set moneybagL (Moneybag addr))---- | Runs an 'IO' action.-runIO :: (HasCallStack, MonadCleveland caps m) => IO res -> m res-runIO io = do-  withCap getMiscCap \cap -> cmiRunIO cap io---- | Get the address of the implicit account / contract associated with the given alias.-resolveAddress-  :: (HasCallStack, MonadCleveland caps m)-  => Alias -> m Address-resolveAddress alias = do-  withCap getMiscCap \cap -> cmiResolveAddress cap alias---- | Simple combinator that marks address as "refillable".------ If a refillable address lacks funds for the next operation,--- some funds will automatically be transferred to it.-refillable :: MonadCleveland caps m => m Address -> m Address-refillable action = do-  addr <- action-  withCap getMiscCap \cap -> cmiMarkAddressRefillable cap addr-  pure addr---- | If the given alias is already associated with an existing address,--- that address will be reused and returned.--- Otherwise, generate a new secret key and record it with given alias.------ If the account has too low of a balance, a small amount of XTZ will--- be transferred to it.------ Notes:------ * By default, the XTZ is transferred from the account associated with the @moneybag@ alias.---   This can be overriden with the @--cleveland-moneybag-alias@ command line option, the---   @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withMoneybag'.---     > do---     >   addr1 <- newAddress "alias"---     >   addr2 <- resolveAddress $ mkAlias "prefix.alias"---     >   addr1 @== addr2-newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m Address-newAddress alias = do-  addrs <- newAddresses $ alias :< Nil-  case addrs of-    addr :< Nil -> pure addr---- | Batched version of `newAddress`-newAddresses-  :: forall n n' caps m.-    (HasCallStack, MonadCleveland caps m, IsoNatPeano n n')-  => SizedList n SpecificOrDefaultAlias-  -> m (SizedList n Address)-newAddresses aliases = do-  addrs <- withCap getMiscCap \cap -> traverse (cmiGenKey cap) aliases-  Moneybag moneybag <- view moneybagL--  -- Addresses may exist from previous scenarios runs and have sufficient-  -- balance for the sake of testing; if so, we can save some time-  balances <- traverse getBalance addrs-  withSender moneybag do-    inBatch do-      sequenceA_ $-        SL.zipWith refillIfLowBalance addrs balances--  pure addrs--refillIfLowBalance :: (HasCallStack, Applicative m, MonadOps m) => Address -> Mutez -> m ()-refillIfLowBalance addr balance =-  when (balance < 0.5_e6) do  -- < 0.5 XTZ-    transferMoney addr 0.9_e6 -- 0.9 XTZ---- | Generate a new secret key and record it with given alias. If the--- alias is already known, the key will be overwritten. The address is--- guaranteed to be fresh, i. e. no operations on it have been made.------ Notes:------ * Beware that if an "alias prefix" is set, it'll be prepended to the given alias.---   An "alias prefix" can be set using the @--cleveland-alias-prefix@ command line option, the---   @TASTY_CLEVELAND_ALIAS_PREFIX@ env var, or with 'Test.Cleveland.Tasty.setAliasPrefix'.---     > do---     >   addr1 <- newFreshAddress "alias"---     >   addr2 <- resolveAddress $ mkAlias "prefix.alias"---     >   addr1 @== addr2-newFreshAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m Address-newFreshAddress alias = do-  withCap getMiscCap \cap -> cmiGenFreshKey cap alias---- | Get the signature of the preapplied operation.-signBytes :: (HasCallStack, MonadCleveland caps m) => ByteString -> Address -> m Signature-signBytes bytes signer = do-  withCap getMiscCap \cap -> cmiSignBytes cap bytes signer---- | Create a list of similarly named 'SpecificAlias'es.------ For example,------ >>> enumAliases @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil--- True-enumAliases-  :: forall n n'.-     (SingIPeano n, IsoNatPeano n n')-  => Alias -> SizedList n SpecificOrDefaultAlias-enumAliases (Alias pfx) = SpecificAlias <$> SL.generate @n (\n -> Alias $ pfx <> "-" <> show n)---- | Type-safer version of 'signBytes'.-signBinary :: (HasCallStack, BytesLike bs, MonadCleveland caps m) => bs -> Address -> m (TSignature bs)-signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr---- | Originate a new raw Michelson contract with given data.-originateUntyped :: (HasCallStack, MonadOps m) => UntypedOriginateData -> m Address-originateUntyped uod = withOpsCap \opsCap ->-  runSingleOperation opsCap "origination" (OpOriginate uod) \case-    OpOriginate addr -> Just addr-    _ -> Nothing---- | A simplified version of the originateUntyped command.--- The contract will have 0 balance.-originateUntypedSimple-  :: (HasCallStack, MonadOps m) => Alias -> U.Value -> U.Contract -> m Address-originateUntypedSimple uodName uodStorage uodContract = do-  let uodBalance = zeroMutez-  originateUntyped UntypedOriginateData{..}---- | Lorentz version for origination.------ By default, the sender is the account associated with the @moneybag@ alias.--- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the--- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'.-originate-  :: forall cp st vd m.-     (HasCallStack, MonadOps m)-  => OriginateData cp st vd -> m (ContractHandle cp st vd)-originate dat@OriginateData{ odContract = Contract{}, .. } = do-  addr <- originateUntyped (originateDataToUntyped dat)-  pure $ ContractHandle (pretty odName) addr---- | A simplified version of the originate command.--- The contract will have 0 balance.-originateSimple-  :: forall cp st vd m.-     ( HasCallStack-     , MonadOps m-     )-  => Alias-  -> st-  -> Contract cp st vd-  -> m (ContractHandle cp st vd)-originateSimple odName odStorage odContract = do-  let odBalance = zeroMutez-  originate OriginateData{..}---- | Like 'originateUntypedSimple', but accepts typed contract and initial storage--- as a Haskell value.-originateTypedSimple-  :: forall cp st vd m.-     ( HasCallStack-     , MonadOps m-     , NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd-     )-  => Alias -> st -> T.Contract (T.ToT cp) (T.ToT st) -> m (ContractHandle cp st vd)-originateTypedSimple name storage contract@T.Contract{} = do-  addr <- originateUntypedSimple name (untypeHelper storage) (convertContract contract)-  pure $ ContractHandle (pretty name) addr---- | Originate a new Michelson contract that doesn't fit into the--- origination size limit, by executing multiple operation steps.------ This operation cannot be batched (it simply may not fit).-originateLargeUntyped-  :: (HasCallStack, MonadCleveland caps m) => UntypedOriginateData -> m Address-originateLargeUntyped uod = do-  sender <- view senderL-  withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod---- | A simplified version of the originateLargeUntyped command.--- The contract will have 0 balance.-originateLargeUntypedSimple-  :: (HasCallStack, MonadCleveland caps m)-  => Alias -> U.Value -> U.Contract -> m Address-originateLargeUntypedSimple uodName uodStorage uodContract = do-  let uodBalance = zeroMutez-  originateLargeUntyped UntypedOriginateData{..}---- | Lorentz version for large origination.-originateLarge-  :: forall param st vd m caps.-     (HasCallStack, MonadCleveland caps m)-  => OriginateData param st vd -> m (ContractHandle param st vd)-originateLarge dat@OriginateData{ odContract = Contract{}, .. } = do-  addr <- originateLargeUntyped (originateDataToUntyped dat)-  pure $ ContractHandle (pretty odName) addr---- | A simplified version of the originateLarge command.--- The contract will have 0 balance.-originateLargeSimple-  :: forall param st vd m caps.-     ( HasCallStack-     , MonadCleveland caps m-     )-  => Alias-  -> st-  -> Contract param st vd-  -> m (ContractHandle param st vd)-originateLargeSimple odName odStorage odContract = do-  let odBalance = zeroMutez-  originateLarge OriginateData{..}---- | Base method for making a transfer.------ Avoid using this method in favour of 'transferMoney' and 'call', unless--- you need the semantics of both in one operation.-transfer :: (HasCallStack, MonadOps m) => TransferData -> m ()-transfer td = withOpsCap \opsCap ->-  runSingleOperation opsCap "transfer" (OpTransfer td) \case-    OpTransfer () -> Just ()-    _ -> Nothing---- | Simply transfer money to an address.------ This assumes that target address is either an implicit address or has--- a default entrypoint with a unit argument; otherwise the call fails.-transferMoney :: (HasCallStack, MonadOps m, ToAddress addr) => addr -> Mutez -> m ()-transferMoney to amount = transfer TransferData-  { tdTo = to-  , tdAmount = amount-  , tdEntrypoint = DefEpName-  , tdParameter = ()-  }---- | Call a certain entrypoint of the given contract.------ By default, the sender is the account associated with the @moneybag@ alias.--- This can be overriden with the @--cleveland-moneybag-alias@ command line option, the--- @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withSender'.-call-  :: forall param vd addr m epRef epArg.-     (HasCallStack, MonadOps m, ToTAddress param vd addr, HasEntrypointArg param epRef epArg-     , IsoValue epArg, Typeable epArg)-  => addr-  -> epRef-  -> epArg-  -> m ()-call to epRef param =-  case useHasEntrypointArg @param @epRef @epArg epRef of-    (Dict, epName) ->-      transfer TransferData-        { tdTo = toAddress $ toTAddress @param @vd @addr to-        , tdAmount = zeroMutez-        , tdEntrypoint = epName-        , tdParameter = param-        }---- | Import an untyped contract from file.-importUntypedContract :: (HasCallStack, MonadCleveland caps m) => FilePath -> m U.Contract-importUntypedContract = runIO . Runtime.importUntypedContract---- | Import a contract from file.------ The compiler must be able to infer the types of parameter, storage and views.--- In case there are no views or you don't care, you can use 'noViews'.-importContract-  :: ( HasCallStack, NiceParameter param, NiceStorage st-     , NiceViewsDescriptor vd, DemoteViewsDescriptor vd-     , MonadCleveland caps m-     )-  => FilePath -> m (Contract param st vd)-importContract = runIO . LorentzImport.importContract--{- | Run operations in a batch.-Best used with the @ApplicativeDo@ GHC extension.--Example:--@-{-# LANGUAGE ApplicativeDo #-}--contract <- inBatch $ do-  contract <- originate ...-  for_ [1..3] \i ->-    transfer ...-  return contract-@--Batched operations should be applied to chain faster, but note that batches have-their own limits. For instance, at the moment of writing, the gas limit on a-batch is 10x of gas limit applied to a single operation.--A context of a batch is only 'Applicative', not 'Monad'. This means that:--* Return values of one function cannot be passed to another function in the same-  batch, it can only be returned;-* Sometimes the compiler does not recognize that only 'Applicative' context is-  required, in case of any issues with that - follow the error messages.---}-inBatch :: (HasCallStack, MonadCleveland caps m) => ClevelandOpsBatch a -> m a-inBatch batch = do-  withCap getOpsCap \cap -> runBatched cap batch---- | Print the given string verbatim as a comment.--- At the moment, this is a no-op in emulator tests.-comment :: (HasCallStack, MonadCleveland caps m) => Text -> m ()-comment cmt = do-  withCap getMiscCap \cap -> cmiComment cap cmt---- | Get the balance of the given address.-getBalance :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m Mutez-getBalance addr = do-  withCap getMiscCap \cap -> cmiGetBalance cap (toAddress addr)---- | Get the delegate for the given contract. Fails on implicit contracts.-getDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m (Maybe KeyHash)-getDelegate addr = do-  withCap getMiscCap \cap -> cmiGetDelegate cap (toAddress addr)---- | Register the given address as a valid delegate.-registerDelegate :: (HasCallStack, MonadCleveland caps m, ToAddress addr) => addr -> m ()-registerDelegate addr = do-  withCap getMiscCap \cap -> cmiRegisterDelegate cap (toAddress addr)---- | Retrieve a contract's storage in its "RPC representation"--- (i.e., all its big_maps will be replaced by big_map IDs).------ If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' /--- 'Test.Cleveland.deriveManyRPC' should be used to create an RPC representation of the storage--- type.------ > data MyStorage = MyStorage { field1 :: Natural, field2 :: BigMap Integer MText }--- > deriveRPC "MyStorage"-getStorage-  :: forall st addr caps m.-    (HasCallStack, MonadCleveland caps m, ToStorageType st addr, IsoValue (AsRPC st))-  => addr-  -> m (AsRPC st)-getStorage contract = do-  someSt <- getSomeStorage contract-  case someSt ^? castTo @(AsRPC st) . value of-    Just st -> pure st-    Nothing -> failure $ unlinesF-      [ "Expected storage to be of type:"-      , indentF 2 $ build $ demote @(T.ToT (AsRPC st))-      , "But its type was:"-      , indentF 2 $ build $ getT someSt-      ]---- | Retrieve a contract's full storage, including the contents of its big_maps.------ This function can only be used in emulator-only tests.-getFullStorage-  :: forall st addr caps m.-    (HasCallStack, MonadEmulated caps m, ToStorageType st addr)-  => addr-  -> m st-getFullStorage contract = do-  withCap getEmulatedCap \cap -> eiGetStorage cap contract---- | Similar to 'getStorage', but doesn't require knowing--- the storage type in advance.------ Use the optics in 'Morley.Michelson.Typed.AnnotatedValue' to--- read data from the storage.-getSomeStorage-  :: forall addr caps m.-    (HasCallStack, MonadCleveland caps m, ToAddress addr)-  => addr-  -> m SomeAnnotatedValue-getSomeStorage contract = do-  withCap getMiscCap \cap -> cmiGetSomeStorage cap (toAddress contract)---- | Retrieve a big_map value, given a big_map ID and a key.--- Returns 'Nothing' when the big_map ID does not exist, or it exists but--- does not contain the given key.-getBigMapValueMaybe-  :: forall k v caps m.-   ( HasCallStack, MonadCleveland caps m-   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v-   )-  => BigMapId k v -> k -> m (Maybe v)-getBigMapValueMaybe bmId key = do-  withCap getMiscCap \cap -> cmiGetBigMapValueMaybe cap bmId key---- | Like 'getBigMapValueMaybe', but fails the tests instead of returning 'Nothing'.-getBigMapValue-  :: forall k v caps m.-   ( HasCallStack, MonadCleveland caps m-   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v-   , Buildable k-   )-  => BigMapId k v -> k -> m v-getBigMapValue bmId k =-  getBigMapValueMaybe bmId k >>= \case-    Just v -> pure v-    Nothing -> failure $ unlinesF @_ @Builder-      [ "Either:"-      , "  1. A big_map with ID '" +| bmId |+ "' does not exist, or"-      , "  2. It exists, but does not contain the key '" +| k |+ "'."-      ]---- | Retrieve all big_map values, given a big_map ID.--- Returns 'Nothing' when the big_map ID does not exist.-getAllBigMapValuesMaybe-  :: forall k v caps m.-  ( HasCallStack, MonadCleveland caps m-  , NiceComparable k, NiceUnpackedValue v-  )-  => BigMapId k v -> m (Maybe [v])-getAllBigMapValuesMaybe bmId = do-  withCap getMiscCap \cap -> cmiGetAllBigMapValuesMaybe cap bmId---- | Like 'getAllBigMapValuesMaybe', but fails the tests instead of returning 'Nothing'.-getAllBigMapValues-  :: forall k v caps m.-  ( HasCallStack, MonadCleveland caps m-  , NiceComparable k, NiceUnpackedValue v-  )-  => BigMapId k v -> m [v]-getAllBigMapValues bmId =-  getAllBigMapValuesMaybe bmId >>= \case-    Just vs -> pure vs-    Nothing -> failure $ "A big map with ID '" +| bmId |+ "' does not exist"---- | Retrieve a big_map size, given a big_map ID.--- Returns 'Nothing' when the big_map ID does not exist.------ /O(n)/, because it's implemented with 'Morley.Client.RPC.Getters.getBigMapValues'.-getBigMapSizeMaybe-  :: forall k v caps m.-  ( HasCallStack, MonadCleveland caps m-  , NiceComparable k, NiceUnpackedValue v-  )-  => BigMapId k v -> m (Maybe Natural)-getBigMapSizeMaybe bmId =-    fmap (fmap (Unsafe.fromIntegral @Int @Natural . length)) (getAllBigMapValuesMaybe bmId)---- | Like 'getBigMapSizeMaybe', but fails the tests instead of returning 'Nothing'.-getBigMapSize-  :: forall k v caps m.-  ( HasCallStack, MonadCleveland caps m-  , NiceComparable k, NiceUnpackedValue v-  )-  => BigMapId k v -> m Natural-getBigMapSize bmId =-  Unsafe.fromIntegral @Int @Natural . length <$> getAllBigMapValues bmId---- | Get the public key associated with given address.--- Fail if given address is not an implicit account.-getPublicKey :: (HasCallStack, MonadCleveland caps m) => Address -> m PublicKey-getPublicKey addr = do-  withCap getMiscCap \cap -> cmiGetPublicKey cap addr---- | Get the chain's @ChainId@.-getChainId :: (HasCallStack, MonadCleveland caps m) => m ChainId-getChainId = do-  withCap getMiscCap \cap -> cmiGetChainId cap---- | Advance at least the given amount of time, or until a new block is baked,--- whichever happens last.------ On a real network, this is implemented using @threadDelay@, so it's advisable--- to use small amounts of time only.-advanceTime-  :: forall unit caps m-  . (HasCallStack, MonadCleveland caps m, KnownDivRat unit Second)-  => Time unit -> m ()-advanceTime time = do-  withCap getMiscCap \cap -> cmiAdvanceTime cap time---- | Wait till the provided number of levels is past.-advanceLevel-  :: forall caps m-  . (HasCallStack, MonadCleveland caps m)-  => Natural -> m ()-advanceLevel l = do-  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (+ l)---- | Wait till the provided level is reached.-advanceToLevel-  :: forall caps m-  . (HasCallStack, MonadCleveland caps m)-  => Natural -> m ()-advanceToLevel target = do-  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (const target)---- | Get the timestamp observed by the last block to be baked.-getNow :: (HasCallStack, MonadCleveland caps m) => m Timestamp-getNow = do-  withCap getMiscCap \cap -> cmiGetNow cap---- | Get the current level observed by the last block to be baked.-getLevel :: (HasCallStack, MonadCleveland caps m) => m Natural-getLevel = do-  withCap getMiscCap \cap -> cmiGetLevel cap---- | Get approximate block interval in seconds. Note, that this value--- is minimal bound and real intervals can be larger, see--- http://tezos.gitlab.io/active/consensus.html#minimal-block-delay-function--- for more information about block delays.-getApproximateBlockInterval :: (HasCallStack, MonadCleveland caps m) => m (Time Second)-getApproximateBlockInterval = do-  withCap getMiscCap \cap -> cmiGetApproximateBlockInterval cap---- | Get minimal block delay in seconds. This is essentially the same as--- 'getApproximateBlockInterval', but returns a 'Natural' instead of @Time--- Second@.------ Can be useful when testing code using @MIN_BLOCK_TIME@ instruction.-getMinBlockTime :: (HasCallStack, MonadCleveland caps m) => m Natural-getMinBlockTime = toNum @Second <$> getApproximateBlockInterval---- | Execute a contract's code without originating it.--- The chain's state will not be modified.------ Notes:------ * If the contract's code emits operations, they will not be executed.--- * The sender's account won't be debited.--- * When running an _originated_ contract, the @BALANCE@ instruction returns the---   sum of the contract's balance before the transfer operation + the amount of tz being transferred.---   In other words, this invariant holds: @BALANCE >= AMOUNT@.---   However, since `runCode` allows overriding the @BALANCE@ instruction,---   then this invariant no longer holds. It's possible that @BALANCE < AMOUNT@.-runCode-  :: (HasCallStack, MonadCleveland caps m, HasRPCRepr st, IsoValue (AsRPC st))-  => RunCode cp st vd -> m (AsRPC st)-runCode rc = do-  sender <- view senderL-  withCap getMiscCap \cap -> cmiRunCode cap sender rc---- | Execute multiple testing scenarios independently.------ * Actions performed before 'branchout' will be observed by all branches.--- * Actions performed in branches will _not_ be observed by any actions performed after 'branchout'.--- * Actions performed in one branch will _not_ be observed by another branch.--- * The test succeeds IFF all branches succeed.--- * If any branch fails, the test ends immediately and the remaining branches---    won't be executed.------ The following property holds:------ > pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c]------ The list of branches must be non-empty.-branchout :: forall caps m. (MonadEmulated caps m) => [(Text, m ())] -> m ()-branchout branches = do-  caps <- ask-  let branches' :: [(Text, ClevelandBaseMonad caps ())] = second (flip runReaderT caps) <$> branches-  lift $ eiBranchout (getEmulatedCap caps) branches'---- | Execute one or more actions and roll them back afterwards.--- Actions performed in 'offshoot' will _not_ be observed by any--- actions performed after 'offshoot'.------ Similar to 'branchout', but accepts one single branch.-offshoot :: forall caps m. MonadEmulated caps m => Text -> m () -> m ()-offshoot branchName branch = branchout [(branchName, branch)]--{- | Returns the result of the action with the logs it produced. Logs are messages-printed by the Lorentz instruction 'Lorentz.printComment'.--This function can be combined either with lens-based accessors or helper functions to get-more specific information about logs.--Examples:--@-(logsInfo, _) <- getMorleyLogs scenario-logsInfo ^.. each . logsL @== [MorleyLogs ["log"], MorleyLogs ["log2"]]-logsInfo ^.. each . filterLogsByAddrL addr @== [MorleyLogs ["log"]]-@--@-(logsInfo, _) <- getMorleyLogs scenario-collectLogs logsInfo @== MorleyLogs ["log", "log2"]-logsForAddress logsInfo @== [MorleyLogs ["log"]]-@---}-getMorleyLogs :: forall a caps m. MonadEmulated caps m => m a -> m (LogsInfo, a)-getMorleyLogs action = do-  caps <- ask-  let action' :: ClevelandBaseMonad caps a = runReaderT action caps-  lift $ eiGetMorleyLogs (getEmulatedCap caps) action'---- | Version of `getMorleyLogs` for actions that don't return a result.-getMorleyLogs_ :: MonadEmulated caps m => m () -> m LogsInfo-getMorleyLogs_ action = fst <$> getMorleyLogs action---- | Updates voting power accessible via @VOTING_POWER@ and similar--- instructions.-setVotingPowers :: MonadEmulated caps m => VotingPowers -> m ()-setVotingPowers vp = do-  withCap getEmulatedCap \cap -> eiSetVotingPowers cap vp---- | A helper constraint synonym to make signatures below a bit shorter-type EqBaseMonad a b = ClevelandBaseMonad a ~ ClevelandBaseMonad b---- | Perform an action if we are currently in emulation mode.--- See also 'ifEmulation' note on constraints.-whenEmulation-  :: MonadCleveland caps m-  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 ())-  -> m ()-whenEmulation action = ifEmulation action pass---- | Perform an action if we are currently in network mode.--- See also 'ifEmulation' note on constraints.-whenNetwork-  :: MonadCleveland caps m-  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 ())-  -> m ()-whenNetwork action = ifEmulation pass action--{- | Perform one action if we are currently in emulation mode, another otherwise--Functions passed as the first two arguments are universally quantified over-the outer monad, so if additional constraints are required beyond-'MonadEmulated' or 'MonadCleveland', those constraints have to go on the base-monad, e.g.--@-someFunction :: (MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m ()-someFunction = whenEmulation do-  Just x <- pure (Just 1 :: Maybe Int) -- this would error without MonadFail-  runIO $ print x-@--}-ifEmulation-  :: forall a caps m-   . MonadCleveland caps m-  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 a)-  -> (forall caps1 m1. (EqBaseMonad caps caps1, MonadCleveland caps1 m1) => m1 a)-  -> m a-ifEmulation onEmu onNet = withCap getMiscCap cmiEmulatedImpl >>= \case-  Nothing -> onNet-  Just impl -> withCap (view clevelandCapsL) (runReaderT onEmu . EmulatedCaps impl)--------------------------------------------------------------------------------- Assertions--------------------------------------------------------------------------------- | Fails the test with the given error message.-failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Builder -> m a-failure msg = do-  withCap getMiscCap \cap -> cmiFailure cap msg---- | Fails the test with the given error message if the given condition is false.-assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m ()-assert b errMsg =-  unless b $ failure errMsg---- | @x \@== expected@ fails the test if @x@ is not equal to @expected@.-(@==)-  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)-  => a -- ^ The actual value.-  -> a -- ^ The expected value.-  -> m ()-actual @== expected =-  assert (actual == expected) $-    unlinesF-      [ "Failed comparison"-      , "━━ Expected (rhs) ━━"-      , build expected-      , "━━ Got (lhs) ━━"-      , build actual-      ]-infix 1 @==---- | Fails the test if the two given values are equal.-(@/=)-  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)-  => a -> a -> m ()-a @/= b =-  assert (a /= b) $-    unlinesF-      [ "The two values are equal:"-      , build a-      ]-infix 1 @/=---- | Monadic version of '@=='.------ > getBalance addr @@== 10-(@@==)-  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)-  => m a -- ^ The actual value.-  -> a -- ^ The expected value.-  -> m ()-getActual @@== expected = do-  actual <- getActual-  actual @== expected-infix 1 @@==---- | Monadic version of '@/='.------ > getBalance addr @@/= 10-(@@/=)-  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)-  => m a -> a -> m ()-getA @@/= b =  do-  a <- getA-  a @/= b-infix 1 @@/=---- | Fails the test if the comparison operator fails when applied to the given arguments.--- Prints an error message with both arguments.------ Example:------ > checkCompares 2 (>) 1-checkCompares-  :: forall a b caps m-   . (HasCallStack, MonadCleveland caps m, Buildable a, Buildable b)-  => a-  -> (a -> b -> Bool)-  -> b-  -> m ()-checkCompares a f b = checkComparesWith pretty a f pretty b---- | Like 'checkCompares', but with an explicit show function.--- This function does not have any constraint on the type parameters @a@ and @b@.------ For example, to print with 'Fmt.pretty':------ > checkComparesWith pretty a (<) pretty b-checkComparesWith-  :: forall a b caps m-   . (HasCallStack, MonadCleveland caps m)-  => (a -> Text)-  -> a-  -> (a -> b -> Bool)-  -> (b -> Text)-  -> b-  -> m ()-checkComparesWith showA a f showB b =-  assert (f a b) $-    unlinesF-      [ "Failed"-      , "━━ lhs ━━"-      , showA a-      , "━━ rhs ━━"-      , showB b-      ]---- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`.-evalJust :: (HasCallStack, MonadCleveland caps m) => Builder -> Maybe a -> m a-evalJust err = maybe (failure err) pure---- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`.-evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Builder) -> Either a b -> m b-evalRight mkErr = either (failure . mkErr) pure--------------------------------------------------------------------------------- Exception Handling--------------------------------------------------------------------------------- | Attempt to run an action and return its result or, if interpretation fails, an error.-attempt-  :: forall e caps m a. (HasCallStack, MonadCleveland caps m, Exception e)-  => m a -> m (Either e a)-attempt action = do-  caps <- ask-  let action' :: ClevelandBaseMonad caps a = runReaderT action caps-  lift $ cmiAttempt (getMiscCap caps) action'---- | Asserts that a transfer should fail, and returns the exception.-catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure-catchTransferFailure action =-  attempt action >>= \case-    Left err -> return err-    Right _ -> runIO $ throwM UnexpectedSuccess---- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the--- exception.------ > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $--- >   call contractAddr (Call @"Ep") arg------ > call contractAddr (Call @"Ep") arg & expectTransferFailure--- >   ( failedWith (customError #tag 3) &&--- >     addressIs contractAddr--- >   )-expectTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailurePredicate -> m a -> m ()-expectTransferFailure predicate act = do-  err <- catchTransferFailure act-  checkTransferFailure err predicate---- | Check whether a given predicate holds for a given 'TransferFailure'.-checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m ()-checkTransferFailure err predicate =-  case go predicate of-    Success () -> pass-    Failure expectedOutcome -> failure $ unlinesF-      [ "Expected transfer to fail with an error such that:"-      , ""-      , indentF 2 $ unlinesF expectedOutcome-      , ""-      , "But these conditions were not met."-      , "Actual transfer error:"-      , indentF 2 $ build err-      ]-  where-    go :: TransferFailurePredicate -> Validation (NonEmpty Builder) ()-    go = \case-      AndPredicate ps ->-        first (fmtExpectedOutcomes "AND") (traverse_ go ps)-      OrPredicate ps ->-        case traverse_ go ps of-          Success () -> Success ()-          Failure expectedOutcomes ->-            if length expectedOutcomes == length ps-              -- If all sub-predicates failed, then this predicate failed.-              then Failure $ fmtExpectedOutcomes "OR" expectedOutcomes-              -- If at least 1 sub-predicate succeeded, then this predicate succeeded.-              else Success ()-      TransferFailurePredicate p -> first one $ p err--    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder-    fmtExpectedOutcomes delimiter = \case-      expectedOutcome :| [] -> one expectedOutcome-      expectedOutcomes ->-        one $ unlinesF-          [ "("-          , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes-          , ")"-          ]---- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant--- value.-expectFailedWith-  :: forall err a caps m-   . (HasCallStack, MonadCleveland caps m, NiceConstant err)-  => err -> m a -> m ()-expectFailedWith err = expectTransferFailure $ failedWith (constant err)---- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz--- error.-expectError-  :: forall err a caps m-   . (HasCallStack, MonadCleveland caps m, IsError err)-  => err -> m a -> m ()-expectError err = expectTransferFailure $ failedWith (lerror err)---- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom--- lorentz error.-expectCustomError-  :: forall arg a tag caps m-   . ( HasCallStack, MonadCleveland caps m-     , IsError (CustomError tag)-     , MustHaveErrorArg tag (MText, arg)-     )-  => Label tag -> arg -> m a -> m ()-expectCustomError tag arg = expectTransferFailure $ failedWith (customError tag arg)---- | Version of 'expectCustomError' for error with @unit@ argument.-expectCustomError_-  :: ( HasCallStack, MonadCleveland caps m-     , IsError (CustomError tag)-     , MustHaveErrorArg tag (MText, ())-     )-  => Label tag -> m a -> m ()-expectCustomError_ tag = expectCustomError tag ()---- | Version of 'expectCustomError' specialized for expecting @NoErrorArg@s.-expectCustomErrorNoArg-  :: ( HasCallStack, MonadCleveland caps m-     , IsError (CustomError tag)-     , MustHaveErrorArg tag MText-     )-  => Label tag -> m a -> m ()-expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag)---- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz--- numeric error.-expectNumericError-  :: forall err a caps m-   . (HasCallStack, MonadCleveland caps m, IsError err)-  => ErrorTagMap -> err -> m a -> m ()-expectNumericError tagMap err = expectTransferFailure $ failedWith (numericError tagMap err)---- | Prefix /scenario-custom/ error messages (i.e. @CustomTestError@ either from pure or non-pure--- implementation), potentially thrown from the given code block.------ The prefix will be put at a separate line before the main text, if text is multiline, otherwise--- it will be separated from the main text with @: @.------ This affects errors produced by functions like 'failure', 'assert', '@==', etc.--- Errors related to events in the chain will not be touched.------ Example:------ > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $--- >   askContract i @@== i * 2-clarifyErrors :: forall caps m a. (MonadCleveland caps m)-              => Builder -> m a -> m a-clarifyErrors message action = do-  attempt action >>= \case-    Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e)-    Right val -> pure val-  where-  handle :: SomeException -> SomeException-  handle e = fromMaybe e $-        wrap testClientErrorHandler e-    <|> wrap testPureErrorHandler e-    <|> wrap withCallStackErrorHandler e--  wrap f = fmap (toException . f) . fromException--  addPrefix = pretty . nameF message . build--  testClientErrorHandler :: Client.TestError -> Client.TestError-  testClientErrorHandler = \case-    Client.CustomTestError msg -> Client.CustomTestError $ addPrefix msg--  testPureErrorHandler :: Pure.TestError -> Pure.TestError-  testPureErrorHandler = \case-    Pure.CustomTestError msg -> Pure.CustomTestError $ addPrefix msg-    err -> err--  withCallStackErrorHandler :: WithCallStack -> WithCallStack-  withCallStackErrorHandler (WithCallStack cst e) = WithCallStack cst $ handle e--------------------------------------------------------------------------------- TransferFailure Predicates--------------------------------------------------------------------------------- | A predicate that checks whether a transfer operation failed for the expected reason.------ Predicates can be combined using the '&&' and '||' operators.-data TransferFailurePredicate-  = TransferFailurePredicate-      (TransferFailure -> Validation Builder ())-      -- ^ A predicate that either returns () or, if it fails,-      -- a message explaining what the expected outcome was.-  | AndPredicate (NonEmpty TransferFailurePredicate)-  | OrPredicate (NonEmpty TransferFailurePredicate)--instance Boolean TransferFailurePredicate where-  AndPredicate l && AndPredicate r = AndPredicate $ l <> r-  AndPredicate l && r = AndPredicate $ l <> one r-  l && AndPredicate r = AndPredicate $ one l <> r-  l && r = AndPredicate $ one l <> one r--  OrPredicate l || OrPredicate r = OrPredicate $ l <> r-  OrPredicate l || r = OrPredicate $ l <> one r-  l || OrPredicate r = OrPredicate $ one l <> r-  l || r = OrPredicate $ one l <> one r--transferFailureReasonPredicate-  :: (TransferFailureReason -> Validation Builder ())-  -> TransferFailurePredicate-transferFailureReasonPredicate p = TransferFailurePredicate $-  \(TransferFailure _ reason) -> p reason---- | Asserts that interpretation of a contract failed due to an overflow error.-shiftOverflow :: TransferFailurePredicate-shiftOverflow = transferFailureReasonPredicate \case-  ShiftOverflow -> pass-  _ -> Failure "Contract failed due to an overflow error"---- | Asserts that an action failed due to an attempt to transfer 0tz towards a simple address.-emptyTransaction :: TransferFailurePredicate-emptyTransaction = transferFailureReasonPredicate \case-  EmptyTransaction -> pass-  _ -> Failure "Attempted to transfer 0tz to a simple address"---- | Asserts that an action failed due to an attempt to call a contract with an invalid parameter.-badParameter :: TransferFailurePredicate-badParameter = transferFailureReasonPredicate \case-  BadParameter -> pass-  _ -> Failure "Attempted to call a contract with a parameter of the wrong type"---- | Asserts that interpretation of a contract failed due to gas exhaustion.-gasExhaustion :: TransferFailurePredicate-gasExhaustion = transferFailureReasonPredicate \case-  GasExhaustion -> pass-  _ -> Failure "Execution failed due to gas exhaustion"---- | Asserts that interpretation of a contract ended with @FAILWITH@, throwing the given error.------ This function should be used together with one of the "@FAILWITH@ constructors"--- (e.g. 'constant', 'customError').-failedWith :: SomeConstant -> TransferFailurePredicate-failedWith expectedFailWithVal = transferFailureReasonPredicate \case-  FailedWith (EOTVExpression actualFailWithExpr) _-    | actualFailWithExpr `isEq` expectedFailWithVal -> pass-  FailedWith (EOTVTypedValue actualFailWithVal) _-    | toExpression actualFailWithVal `isEq` expectedFailWithVal -> pass-  _ -> Failure $ "Contract failed with: " <> buildRenderDoc expectedFailWithVal-  where-    isEq :: Expression -> SomeConstant -> Bool-    isEq expr (SomeConstant (v :: T.Value t)) =-      either (const False) (== v) (fromExpression @(T.Value t) expr)---- | Asserts that the error occurred while interpreting the contract with the given address.-addressIs-  :: ToAddress addr-  => addr -- ^ The expected address.-  -> TransferFailurePredicate-addressIs (toAddress -> expectedAddr) = TransferFailurePredicate \err -> do-  let TransferFailure actualAddr _ = err-  when (actualAddr /= expectedAddr) $-    Failure $ "Failure occurred in contract with address: " <> build expectedAddr--------------------------------------------------------------------------------- 'FAILWITH' errors--------------------------------------------------------------------------------- | A constant michelson value that a contract threw with @FAILWITH@.-constant :: forall err. NiceConstant err => err -> SomeConstant-constant err =-  withDict (niceConstantEvi @err) $-    SomeConstant $ toVal err---- | A lorentz error.-lerror :: forall err. IsError err => err -> SomeConstant-lerror err = errorToVal err SomeConstant---- | A custom lorentz error.-customError-  :: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg))-  => Label tag -> arg -> SomeConstant-customError tag arg =-  lerror $ CustomError tag (errorTagToMText tag, arg)---- | A custom lorentz error with a @unit@ argument.-customError_-  :: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ()))-  => Label tag -> SomeConstant-customError_ tag = customError tag ()---- | A custom lorentz error with no argument.-customErrorNoArg-  :: (IsError (CustomError tag), MustHaveErrorArg tag MText)-  => Label tag -> SomeConstant-customErrorNoArg tag =-  lerror $ CustomError tag (errorTagToMText tag)---- | A lorentz numeric error.-numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant-numericError tagMap err = errorToValNumeric tagMap err SomeConstant--------------------------------------------------------------------------------- Internal helpers-------------------------------------------------------------------------------withCap :: Monad m => (caps -> cap) -> (cap -> m a) -> ReaderT caps m a-withCap getCap useCap = do-  cap <- asks getCap-  lift $ useCap cap---- | Common conversion function from 'OriginateData' to 'UntypedOriginateData'-originateDataToUntyped :: OriginateData param st vd -> UntypedOriginateData-originateDataToUntyped OriginateData{ odContract = contract@Contract{}, .. } =-  UntypedOriginateData-  { uodName = odName-  , uodBalance = odBalance-  , uodStorage = untypeHelper odStorage-  , uodContract = convertContract $ toMichelsonContract contract-  }--untypeHelper :: forall st. NiceStorage st => st -> U.Value-untypeHelper = untypeValue . toVal \\ niceStorageEvi @st+  ( MonadOps+  , MonadTransfer+  , MonadOriginate+  , withSender+  , withMoneybag+  , runIO+  , resolveAddress+  , refillable+  , newAddress+  , newAddresses+  , newFreshAddress+  , enumAliases+  , signBytes+  , signBinary+  , originate+  , Large (..)+  , transfer+  , WithContractEvents (..)+  , calling+  , unsafeCalling+  , inBatch+  , importUntypedContract+  , importContract+  , noViews+  , comment+  , getBalance+  , getStorage+  , getFullStorage+  , getSomeStorage+  , getAllBigMapValues+  , getAllBigMapValuesMaybe+  , getBigMapSize+  , getBigMapSizeMaybe+  , getBigMapValueMaybe+  , getBigMapValue+  , getMorleyLogs+  , getMorleyLogs_+  , getPublicKey+  , getChainId+  , advanceTime+  , advanceLevel+  , advanceToLevel+  , getNow+  , getLevel+  , getApproximateBlockInterval+  , getMinBlockTime+  , runCode+  , branchout+  , offshoot+  , getDelegate+  , registerDelegate+  , setVotingPowers+  , whenEmulation+  , whenNetwork+  , ifEmulation+  , getMorleyClientEnv++  -- * Assertions+  , failure+  , assert+  , (@==)+  , (@/=)+  , (@@==)+  , (@@/=)+  , checkCompares+  , checkComparesWith+  , evalJust+  , evalRight++  -- * Exception handling+  , attempt+  , catchTransferFailure+  , checkTransferFailure+  , expectTransferFailure+  , expectFailedWith+  , expectError+  , expectCustomError+  , expectCustomError_+  , expectCustomErrorNoArg+  , expectNumericError+  , clarifyErrors+  -- ** TransferFailure predicates+  , TransferFailurePredicate(..)+  , shiftOverflow+  , emptyTransaction+  , badParameter+  , gasExhaustion+  , failedWith+  , addressIs+  -- ** @FAILWITH@ errors+  , constant+  , lerror+  , customError+  , customError_+  , customErrorNoArg+  , numericError+  ) where++import Test.Cleveland.Internal.Actions.Assertions+import Test.Cleveland.Internal.Actions.ExceptionHandling+import Test.Cleveland.Internal.Actions.Misc+import Test.Cleveland.Internal.Actions.Originate+import Test.Cleveland.Internal.Actions.Transfer+import Test.Cleveland.Internal.Actions.TransferFailurePredicate++-- | Synonym typeclass for monads where network operations can occur.+--+-- This has instances for @MonadCleveland@ and @ClevelandOpsBatch@ contexts.+--+-- Practically, if you want to use 'transfer' or 'originate' in a monad, add a+-- 'MonadOps' constraint on it, f. ex.:+--+-- > callEp1 :: MonadOps m => ContractHandle MyParam () () -> Integer -> m ()+-- > callEp1 ch = transfer ch . calling (ep @"Entrypoint1")+class (MonadTransfer m, MonadOriginate m) => MonadOps m+instance (MonadTransfer m, MonadOriginate m) => MonadOps m++-- Note: 'MonadOps' is a typeclass and not a constraint synonym because GHC (as+-- of 9.0) is being silly and complaining about impredicative polymorphism when+-- defining a constraint synonym with quantified constraints.

@@ -0,0 +1,125 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Various test assertions in the 'MonadCleveland' context.+module Test.Cleveland.Internal.Actions.Assertions+  ( module Test.Cleveland.Internal.Actions.Assertions+  ) where++import Fmt (Buildable, Builder, build, pretty, unlinesF)++import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Actions.Helpers++{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}++-- | Fails the test with the given error message.+failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Builder -> m a+failure msg = do+  withCap getMiscCap \cap -> cmiFailure cap msg++-- | Fails the test with the given error message if the given condition is false.+assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m ()+assert b errMsg =+  unless b $ failure errMsg++-- | @x \@== expected@ fails the test if @x@ is not equal to @expected@.+(@==)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => a -- ^ The actual value.+  -> a -- ^ The expected value.+  -> m ()+actual @== expected =+  assert (actual == expected) $+    unlinesF+      [ "Failed comparison"+      , "━━ Expected (rhs) ━━"+      , build expected+      , "━━ Got (lhs) ━━"+      , build actual+      ]+infix 1 @==++-- | Fails the test if the two given values are equal.+(@/=)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => a -> a -> m ()+a @/= b =+  assert (a /= b) $+    unlinesF+      [ "The two values are equal:"+      , build a+      ]+infix 1 @/=++-- | Monadic version of '@=='.+--+-- > getBalance addr @@== 10+(@@==)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => m a -- ^ The actual value.+  -> a -- ^ The expected value.+  -> m ()+getActual @@== expected = do+  actual <- getActual+  actual @== expected+infix 1 @@==++-- | Monadic version of '@/='.+--+-- > getBalance addr @@/= 10+(@@/=)+  :: (HasCallStack, MonadCleveland caps m, Eq a, Buildable a)+  => m a -> a -> m ()+getA @@/= b =  do+  a <- getA+  a @/= b+infix 1 @@/=++-- | Fails the test if the comparison operator fails when applied to the given arguments.+-- Prints an error message with both arguments.+--+-- Example:+--+-- > checkCompares 2 (>) 1+checkCompares+  :: forall a b caps m+   . (HasCallStack, MonadCleveland caps m, Buildable a, Buildable b)+  => a+  -> (a -> b -> Bool)+  -> b+  -> m ()+checkCompares a f b = checkComparesWith pretty a f pretty b++-- | Like 'checkCompares', but with an explicit show function.+-- This function does not have any constraint on the type parameters @a@ and @b@.+--+-- For example, to print with 'Fmt.pretty':+--+-- > checkComparesWith pretty a (<) pretty b+checkComparesWith+  :: forall a b caps m+   . (HasCallStack, MonadCleveland caps m)+  => (a -> Text)+  -> a+  -> (a -> b -> Bool)+  -> (b -> Text)+  -> b+  -> m ()+checkComparesWith showA a f showB b =+  assert (f a b) $+    unlinesF+      [ "Failed"+      , "━━ lhs ━━"+      , showA a+      , "━━ rhs ━━"+      , showB b+      ]++-- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`.+evalJust :: (HasCallStack, MonadCleveland caps m) => Builder -> Maybe a -> m a+evalJust err = maybe (failure err) pure++-- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`.+evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Builder) -> Either a b -> m b+evalRight mkErr = either (failure . mkErr) pure

@@ -0,0 +1,188 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Exception handling+module Test.Cleveland.Internal.Actions.ExceptionHandling+  ( module Test.Cleveland.Internal.Actions.ExceptionHandling+  ) where++import Data.Either.Validation (Validation(..))+import Data.List.NonEmpty qualified as NE+import Fmt (Builder, build, indentF, nameF, pretty, unlinesF)++import Lorentz (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg)+import Lorentz.Constraints+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Actions.Assertions+import Test.Cleveland.Internal.Actions.Helpers+import Test.Cleveland.Internal.Actions.Misc+import Test.Cleveland.Internal.Actions.TransferFailurePredicate+import Test.Cleveland.Internal.Client qualified as Client (TestError(..))+import Test.Cleveland.Internal.Exceptions (WithCallStack(..))+import Test.Cleveland.Internal.Pure as Pure (TestError(..))++-- | Attempt to run an action and return its result or, if interpretation fails, an error.+attempt+  :: forall e caps m a. (HasCallStack, MonadCleveland caps m, Exception e)+  => m a -> m (Either e a)+attempt action = do+  caps <- ask+  let action' :: ClevelandBaseMonad caps a = runReaderT action caps+  lift $ cmiAttempt (getMiscCap caps) action'++-- | Asserts that a transfer should fail, and returns the exception.+catchTransferFailure :: (HasCallStack, MonadCleveland caps m) => m a -> m TransferFailure+catchTransferFailure action =+  attempt action >>= \case+    Left err -> return err+    Right _ -> runIO $ throwM UnexpectedSuccess++-- | Asserts that a transfer should fail, and runs some 'TransferFailurePredicate's over the+-- exception.+--+-- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $+-- >   call contractAddr (Call @"Ep") arg+--+-- > call contractAddr (Call @"Ep") arg & expectTransferFailure+-- >   ( failedWith (customError #tag 3) &&+-- >     addressIs contractAddr+-- >   )+expectTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailurePredicate -> m a -> m ()+expectTransferFailure predicate act = do+  err <- catchTransferFailure act+  checkTransferFailure err predicate++-- | Check whether a given predicate holds for a given 'TransferFailure'.+checkTransferFailure :: (HasCallStack, MonadCleveland caps m) => TransferFailure -> TransferFailurePredicate -> m ()+checkTransferFailure err predicate =+  case go predicate of+    Success () -> pass+    Failure expectedOutcome -> failure $ unlinesF+      [ "Expected transfer to fail with an error such that:"+      , ""+      , indentF 2 $ unlinesF expectedOutcome+      , ""+      , "But these conditions were not met."+      , "Actual transfer error:"+      , indentF 2 $ build err+      ]+  where+    go :: TransferFailurePredicate -> Validation (NonEmpty Builder) ()+    go = \case+      AndPredicate ps ->+        first (fmtExpectedOutcomes "AND") (traverse_ go ps)+      OrPredicate ps ->+        case traverse_ go ps of+          Success () -> Success ()+          Failure expectedOutcomes ->+            if length expectedOutcomes == length ps+              -- If all sub-predicates failed, then this predicate failed.+              then Failure $ fmtExpectedOutcomes "OR" expectedOutcomes+              -- If at least 1 sub-predicate succeeded, then this predicate succeeded.+              else Success ()+      TransferFailurePredicate p -> first one $ p err++    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> NonEmpty Builder+    fmtExpectedOutcomes delimiter = \case+      expectedOutcome :| [] -> one expectedOutcome+      expectedOutcomes ->+        one $ unlinesF+          [ "("+          , indentF 2 $ unlinesF $ NE.intersperse delimiter expectedOutcomes+          , ")"+          ]++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given constant+-- value.+expectFailedWith+  :: forall err a caps m+   . (HasCallStack, MonadCleveland caps m, NiceConstant err)+  => err -> m a -> m ()+expectFailedWith err = expectTransferFailure $ failedWith (constant err)++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz+-- error.+expectError+  :: forall err a caps m+   . (HasCallStack, MonadCleveland caps m, IsError err)+  => err -> m a -> m ()+expectError err = expectTransferFailure $ failedWith (lerror err)++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given custom+-- lorentz error.+expectCustomError+  :: forall arg a tag caps m+   . ( HasCallStack, MonadCleveland caps m+     , IsError (CustomError tag)+     , MustHaveErrorArg tag (MText, arg)+     )+  => Label tag -> arg -> m a -> m ()+expectCustomError tag arg = expectTransferFailure $ failedWith (customError tag arg)++-- | Version of 'expectCustomError' for error with @unit@ argument.+expectCustomError_+  :: ( HasCallStack, MonadCleveland caps m+     , IsError (CustomError tag)+     , MustHaveErrorArg tag (MText, ())+     )+  => Label tag -> m a -> m ()+expectCustomError_ tag = expectCustomError tag ()++-- | Version of 'expectCustomError' specialized for expecting @NoErrorArg@s.+expectCustomErrorNoArg+  :: ( HasCallStack, MonadCleveland caps m+     , IsError (CustomError tag)+     , MustHaveErrorArg tag MText+     )+  => Label tag -> m a -> m ()+expectCustomErrorNoArg tag = expectTransferFailure $ failedWith (customErrorNoArg tag)++-- | Asserts that interpretation of a contract ended with @FAILWITH@, returning the given lorentz+-- numeric error.+expectNumericError+  :: forall err a caps m+   . (HasCallStack, MonadCleveland caps m, IsError err)+  => ErrorTagMap -> err -> m a -> m ()+expectNumericError tagMap err = expectTransferFailure $ failedWith (numericError tagMap err)++-- | Prefix /scenario-custom/ error messages (i.e. @CustomTestError@ either from pure or non-pure+-- implementation), potentially thrown from the given code block.+--+-- The prefix will be put at a separate line before the main text, if text is multiline, otherwise+-- it will be separated from the main text with @: @.+--+-- This affects errors produced by functions like 'failure', 'assert', '@==', etc.+-- Errors related to events in the chain will not be touched.+--+-- Example:+--+-- > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $+-- >   askContract i @@== i * 2+clarifyErrors :: forall caps m a. (MonadCleveland caps m)+              => Builder -> m a -> m a+clarifyErrors message action = do+  attempt action >>= \case+    Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e)+    Right val -> pure val+  where+  handle :: SomeException -> SomeException+  handle e = fromMaybe e $+        wrap testClientErrorHandler e+    <|> wrap testPureErrorHandler e+    <|> wrap withCallStackErrorHandler e++  wrap f = fmap (toException . f) . fromException++  addPrefix = pretty . nameF message . build++  testClientErrorHandler :: Client.TestError -> Client.TestError+  testClientErrorHandler = \case+    Client.CustomTestError msg -> Client.CustomTestError $ addPrefix msg++  testPureErrorHandler :: Pure.TestError -> Pure.TestError+  testPureErrorHandler = \case+    Pure.CustomTestError msg -> Pure.CustomTestError $ addPrefix msg+    err -> err++  withCallStackErrorHandler :: WithCallStack -> WithCallStack+  withCallStackErrorHandler (WithCallStack cst e) = WithCallStack cst $ handle e

@@ -0,0 +1,12 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Helpers for working in @MonadCleveland@ context.+module Test.Cleveland.Internal.Actions.Helpers+  ( module Test.Cleveland.Internal.Actions.Helpers+  ) where++withCap :: Monad m => (caps -> cap) -> (cap -> m a) -> ReaderT caps m a+withCap getCap useCap = do+  cap <- asks getCap+  lift $ useCap cap

@@ -0,0 +1,552 @@+-- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | The bulk of Cleveland actions.+module Test.Cleveland.Internal.Actions.Misc+  ( module Test.Cleveland.Internal.Actions.Misc+  , noViews+  ) where++import Data.Singletons (demote)+import Fmt (Buildable, Builder, build, indentF, unlinesF, (+|), (|+))+import Time (KnownDivRat, Second, Time, toNum)+import Unsafe qualified (fromIntegral)++import Lorentz (BigMapId, Contract(..), DemoteViewsDescriptor, IsoValue, noViews)+import Lorentz.Bytes+import Lorentz.Constraints+import Morley.AsRPC (HasRPCRepr(..))+import Morley.Client (MorleyClientEnv)+import Morley.Michelson.Runtime (VotingPowers)+import Morley.Michelson.Runtime.Import qualified as Runtime+import Morley.Michelson.Typed (SomeAnnotatedValue)+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Typed.AnnotatedValue (castTo, getT, value)+import Morley.Michelson.Untyped qualified as U+import Morley.Tezos.Address.Alias (Alias(..))+import Morley.Tezos.Core (ChainId, Mutez, Timestamp)+import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature)+import Morley.Util.SizedList qualified as SL+import Morley.Util.SizedList.Types+import Test.Cleveland.Instances ()+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Actions.Assertions+import Test.Cleveland.Internal.Actions.Helpers+import Test.Cleveland.Internal.Actions.Transfer+import Test.Cleveland.Lorentz.Import qualified as LorentzImport+import Test.Cleveland.Lorentz.Types++{-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}++-- $setup+-- >>> :m +Morley.Util.SizedList.Types+-- >>> :{+-- isEquivalentTo :: Show a => a -> a -> Bool+-- isEquivalentTo a b = Debug.show a == Debug.show b+-- infix 0 `isEquivalentTo`+-- :}++-- | Update the current sender on whose behalf transfers and originations are+-- invoked.+withSender :: MonadCleveland caps m => ImplicitAddress -> m a -> m a+withSender addr =+  local (set senderL (Sender addr))++-- | Update the current moneybag that transfers money on the newly created+-- addresses. For the rare occasions when this is necessary.+withMoneybag :: MonadCleveland caps m => ImplicitAddress -> m a -> m a+withMoneybag addr =+  local (set moneybagL (Moneybag addr))++-- | Runs an 'IO' action.+runIO :: (HasCallStack, MonadCleveland caps m) => IO res -> m res+runIO io = do+  withCap getMiscCap \cap -> cmiRunIO cap io++-- | Get the address of the implicit account / contract associated with the given alias.+resolveAddress+  :: (HasCallStack, MonadCleveland caps m)+  => Alias kind -> m (KindedAddress kind)+resolveAddress alias = do+  withCap getMiscCap \cap -> cmiResolveAddress cap alias++-- | Simple combinator that marks address as "refillable".+--+-- If a refillable address lacks funds for the next operation,+-- some funds will automatically be transferred to it.+refillable :: MonadCleveland caps m => m ImplicitAddress -> m ImplicitAddress+refillable action = do+  addr <- action+  withCap getMiscCap \cap -> cmiMarkAddressRefillable cap addr+  pure addr++-- | If the given alias is already associated with an existing address,+-- that address will be reused and returned.+-- Otherwise, generate a new secret key and record it with given alias.+--+-- If the account has too low of a balance, a small amount of XTZ will+-- be transferred to it.+--+-- Notes:+--+-- * By default, the XTZ is transferred from the account associated with the @moneybag@ alias.+--   This can be overridden with the @--cleveland-moneybag-alias@ command line option, the+--   @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or 'withMoneybag'.+newAddress :: (HasCallStack, MonadCleveland caps m) => SpecificOrDefaultAlias -> m ImplicitAddress+newAddress alias = do+  addrs <- newAddresses $ alias :< Nil+  case addrs of+    addr :< Nil -> pure addr++-- | Batched version of `newAddress`+newAddresses+  :: forall n n' caps m.+    (HasCallStack, MonadCleveland caps m, IsoNatPeano n n')+  => SizedList n SpecificOrDefaultAlias+  -> m (SizedList n ImplicitAddress)+newAddresses aliases = do+  addrs <- withCap getMiscCap \cap -> traverse (cmiGenKey cap) aliases+  Moneybag moneybag <- view moneybagL++  -- Addresses may exist from previous scenarios runs and have sufficient+  -- balance for the sake of testing; if so, we can save some time+  balances <- traverse getBalance addrs+  withSender moneybag do+    inBatch do+      sequenceA_ $+        SL.zipWith refillIfLowBalance addrs balances++  pure addrs+  where+    refillIfLowBalance addr balance =+      when (balance < 0.5_e6) do  -- < 0.5 XTZ+        transfer addr (0.9_e6 :: Mutez) -- 0.9 XTZ++-- | Generate a new secret key and record it with given alias. If the+-- alias is already known, the key will be overwritten. The address is+-- guaranteed to be fresh, i. e. no operations on it have been made.+newFreshAddress+  :: (HasCallStack, MonadCleveland caps m)+  => SpecificOrDefaultAlias -> m ImplicitAddress+newFreshAddress alias = do+  withCap getMiscCap \cap -> cmiGenFreshKey cap alias++-- | Get the signature of the preapplied operation.+signBytes :: (HasCallStack, MonadCleveland caps m) => ByteString -> ImplicitAddress -> m Signature+signBytes bytes signer = do+  withCap getMiscCap \cap -> cmiSignBytes cap bytes signer++-- | Create a list of similarly named 'SpecificAlias'es.+--+-- For example,+--+-- >>> enumAliases @2 "operator" `isEquivalentTo` "operator-0" :< "operator-1" :< Nil+-- True+enumAliases+  :: forall n n'.+     (SingIPeano n, IsoNatPeano n n')+  => ImplicitAlias -> SizedList n SpecificOrDefaultAlias+enumAliases (ImplicitAlias pfx) =+  SpecificAlias <$> SL.generate @n (\n -> ImplicitAlias $ pfx <> "-" <> show n)++-- | Type-safer version of 'signBytes'.+signBinary+  :: (HasCallStack, BytesLike bs, MonadCleveland caps m)+  => bs -> ImplicitAddress -> m (TSignature bs)+signBinary bs addr = TSignature <$> signBytes (toBytes bs) addr++-- | Import an untyped contract from file.+importUntypedContract :: (HasCallStack, MonadCleveland caps m) => FilePath -> m U.Contract+importUntypedContract = runIO . Runtime.importUntypedContract++-- | Import a contract from file.+--+-- The compiler must be able to infer the types of parameter, storage and views.+-- In case there are no views or you don't care, you can use 'noViews'.+importContract+  :: ( HasCallStack, NiceParameter param, NiceStorage st+     , NiceViewsDescriptor vd, DemoteViewsDescriptor vd+     , MonadCleveland caps m+     )+  => FilePath -> m (Contract param st vd)+importContract = runIO . LorentzImport.importContract++{- | Run operations in a batch.+Best used with the @ApplicativeDo@ GHC extension.++Example:++@+{-# LANGUAGE ApplicativeDo #-}++contract <- inBatch $ do+  contract <- originate ...+  for_ [1..3] \i ->+    transfer ...+  return contract+@++Batched operations should be applied to chain faster, but note that batches have+their own limits. For instance, at the moment of writing, the gas limit on a+batch is 10x of gas limit applied to a single operation.++A context of a batch is only 'Applicative', not 'Monad'. This means that:++* Return values of one function cannot be passed to another function in the same+  batch, it can only be returned;+* Sometimes the compiler does not recognize that only 'Applicative' context is+  required, in case of any issues with that - follow the error messages.++-}+inBatch :: (HasCallStack, MonadCleveland caps m) => ClevelandOpsBatch a -> m a+inBatch batch = do+  withCap getOpsCap \cap -> runBatched cap batch++-- | Print the given string verbatim as a comment.+-- At the moment, this is a no-op in emulator tests.+comment :: (HasCallStack, MonadCleveland caps m) => Text -> m ()+comment cmt = do+  withCap getMiscCap \cap -> cmiComment cap cmt++-- | Get the balance of the given address.+getBalance+  :: (HasCallStack, MonadCleveland caps m, ToL1Address addr)+  => addr -> m Mutez+getBalance addr = do+  withCap getMiscCap \cap -> cmiGetBalance cap (toL1Address addr)++-- | Get the delegate for the given contract. Fails on implicit contracts.+getDelegate+  :: (HasCallStack, MonadCleveland caps m, ToContractAddress addr)+  => addr -> m (Maybe KeyHash)+getDelegate addr = do+  withCap getMiscCap \cap -> cmiGetDelegate cap (toContractAddress addr)++-- | Register the given address as a valid delegate.+registerDelegate :: (HasCallStack, MonadCleveland caps m) => ImplicitAddress -> m ()+registerDelegate addr = do+  withCap getMiscCap \cap -> cmiRegisterDelegate cap addr++-- | Retrieve a contract's storage in its "RPC representation"+-- (i.e., all its big_maps will be replaced by big_map IDs).+--+-- If the storage is of a user-defined type, then 'Test.Cleveland.deriveRPC' /+-- 'Test.Cleveland.deriveManyRPC' should be used to create an RPC representation of the storage+-- type.+--+-- > data MyStorage = MyStorage { field1 :: Natural, field2 :: BigMap Integer MText }+-- > deriveRPC "MyStorage"+getStorage+  :: forall st addr caps m.+    (HasCallStack, MonadCleveland caps m, ToStorageType st addr, IsoValue (AsRPC st))+  => addr+  -> m (AsRPC st)+getStorage contract = do+  someSt <- getSomeStorage contract+  case someSt ^? castTo @(AsRPC st) . value of+    Just st -> pure st+    Nothing -> failure $ unlinesF+      [ "Expected storage to be of type:"+      , indentF 2 $ build $ demote @(T.ToT (AsRPC st))+      , "But its type was:"+      , indentF 2 $ build $ getT someSt+      ]++-- | Retrieve a contract's full storage, including the contents of its big_maps.+--+-- This function can only be used in emulator-only tests.+getFullStorage+  :: forall st addr caps m.+    (HasCallStack, MonadEmulated caps m, ToStorageType st addr)+  => addr+  -> m st+getFullStorage contract = do+  withCap getEmulatedCap \cap -> eiGetStorage cap contract++-- | Similar to 'getStorage', but doesn't require knowing+-- the storage type in advance.+--+-- Use the optics in 'Morley.Michelson.Typed.AnnotatedValue' to+-- read data from the storage.+getSomeStorage+  :: forall addr caps m.+    (HasCallStack, MonadCleveland caps m, ToContractAddress addr)+  => addr+  -> m SomeAnnotatedValue+getSomeStorage contract = do+  withCap getMiscCap \cap -> cmiGetSomeStorage cap (toContractAddress contract)++-- | Retrieve a big_map value, given a big_map ID and a key.+-- Returns 'Nothing' when the big_map ID does not exist, or it exists but+-- does not contain the given key.+getBigMapValueMaybe+  :: forall k v caps m.+   ( HasCallStack, MonadCleveland caps m+   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+   )+  => BigMapId k v -> k -> m (Maybe v)+getBigMapValueMaybe bmId key = do+  withCap getMiscCap \cap -> cmiGetBigMapValueMaybe cap bmId key++-- | Like 'getBigMapValueMaybe', but fails the tests instead of returning 'Nothing'.+getBigMapValue+  :: forall k v caps m.+   ( HasCallStack, MonadCleveland caps m+   , NiceComparable k, NicePackedValue k, NiceUnpackedValue v+   , Buildable k+   )+  => BigMapId k v -> k -> m v+getBigMapValue bmId k =+  getBigMapValueMaybe bmId k >>= \case+    Just v -> pure v+    Nothing -> failure $ unlinesF @_ @Builder+      [ "Either:"+      , "  1. A big_map with ID '" +| bmId |+ "' does not exist, or"+      , "  2. It exists, but does not contain the key '" +| k |+ "'."+      ]++-- | Retrieve all big_map values, given a big_map ID.+-- Returns 'Nothing' when the big_map ID does not exist.+getAllBigMapValuesMaybe+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NiceUnpackedValue v+  )+  => BigMapId k v -> m (Maybe [v])+getAllBigMapValuesMaybe bmId = do+  withCap getMiscCap \cap -> cmiGetAllBigMapValuesMaybe cap bmId++-- | Like 'getAllBigMapValuesMaybe', but fails the tests instead of returning 'Nothing'.+getAllBigMapValues+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NiceUnpackedValue v+  )+  => BigMapId k v -> m [v]+getAllBigMapValues bmId =+  getAllBigMapValuesMaybe bmId >>= \case+    Just vs -> pure vs+    Nothing -> failure $ "A big map with ID '" +| bmId |+ "' does not exist"++-- | Retrieve a big_map size, given a big_map ID.+-- Returns 'Nothing' when the big_map ID does not exist.+--+-- /O(n)/, because it's implemented with 'Morley.Client.RPC.Getters.getBigMapValues'.+getBigMapSizeMaybe+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NiceUnpackedValue v+  )+  => BigMapId k v -> m (Maybe Natural)+getBigMapSizeMaybe bmId =+    fmap (fmap (Unsafe.fromIntegral @Int @Natural . length)) (getAllBigMapValuesMaybe bmId)++-- | Like 'getBigMapSizeMaybe', but fails the tests instead of returning 'Nothing'.+getBigMapSize+  :: forall k v caps m.+  ( HasCallStack, MonadCleveland caps m+  , NiceComparable k, NiceUnpackedValue v+  )+  => BigMapId k v -> m Natural+getBigMapSize bmId =+  Unsafe.fromIntegral @Int @Natural . length <$> getAllBigMapValues bmId++-- | Get the public key associated with given address.+-- Fail if given address is not an implicit account.+getPublicKey :: (HasCallStack, MonadCleveland caps m) => ImplicitAddress -> m PublicKey+getPublicKey addr = do+  withCap getMiscCap \cap -> cmiGetPublicKey cap addr++-- | Get the chain's @ChainId@.+getChainId :: (HasCallStack, MonadCleveland caps m) => m ChainId+getChainId = do+  withCap getMiscCap \cap -> cmiGetChainId cap++-- | Advance at least the given amount of time, or until a new block is baked,+-- whichever happens last.+--+-- On a real network, this is implemented using @threadDelay@, so it's advisable+-- to use small amounts of time only.+advanceTime+  :: forall unit caps m+  . (HasCallStack, MonadCleveland caps m, KnownDivRat unit Second)+  => Time unit -> m ()+advanceTime time = do+  withCap getMiscCap \cap -> cmiAdvanceTime cap time++-- | Wait till the provided number of levels is past.+advanceLevel+  :: forall caps m+  . (HasCallStack, MonadCleveland caps m)+  => Natural -> m ()+advanceLevel l = do+  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (+ l)++-- | Wait till the provided level is reached.+advanceToLevel+  :: forall caps m+  . (HasCallStack, MonadCleveland caps m)+  => Natural -> m ()+advanceToLevel target = do+  withCap getMiscCap \cap -> cmiAdvanceToLevel cap (const target)++-- | Get the timestamp observed by the last block to be baked.+getNow :: (HasCallStack, MonadCleveland caps m) => m Timestamp+getNow = do+  withCap getMiscCap \cap -> cmiGetNow cap++-- | Get the current level observed by the last block to be baked.+getLevel :: (HasCallStack, MonadCleveland caps m) => m Natural+getLevel = do+  withCap getMiscCap \cap -> cmiGetLevel cap++-- | Get approximate block interval in seconds. Note, that this value+-- is minimal bound and real intervals can be larger, see+-- http://tezos.gitlab.io/active/consensus.html#minimal-block-delay-function+-- for more information about block delays.+getApproximateBlockInterval :: (HasCallStack, MonadCleveland caps m) => m (Time Second)+getApproximateBlockInterval = do+  withCap getMiscCap \cap -> cmiGetApproximateBlockInterval cap++-- | Get minimal block delay in seconds. This is essentially the same as+-- 'getApproximateBlockInterval', but returns a 'Natural' instead of @Time+-- Second@.+--+-- Can be useful when testing code using @MIN_BLOCK_TIME@ instruction.+getMinBlockTime :: (HasCallStack, MonadCleveland caps m) => m Natural+getMinBlockTime = toNum @Second <$> getApproximateBlockInterval++-- | Execute a contract's code without originating it.+-- The chain's state will not be modified.+--+-- Notes:+--+-- * If the contract's code emits operations, they will not be executed.+-- * The sender's account won't be debited.+-- * When running an _originated_ contract, the @BALANCE@ instruction returns the+--   sum of the contract's balance before the transfer operation + the amount of tz being transferred.+--   In other words, this invariant holds: @BALANCE >= AMOUNT@.+--   However, since `runCode` allows overriding the @BALANCE@ instruction,+--   then this invariant no longer holds. It's possible that @BALANCE < AMOUNT@.+runCode+  :: (HasCallStack, MonadCleveland caps m, HasRPCRepr st, IsoValue (AsRPC st))+  => RunCode cp st vd -> m (AsRPC st)+runCode rc = do+  sender <- view senderL+  withCap getMiscCap \cap -> cmiRunCode cap sender rc++-- | Execute multiple testing scenarios independently.+--+-- * Actions performed before 'branchout' will be observed by all branches.+-- * Actions performed in branches will _not_ be observed by any actions performed after 'branchout'.+-- * Actions performed in one branch will _not_ be observed by another branch.+-- * The test succeeds IFF all branches succeed.+-- * If any branch fails, the test ends immediately and the remaining branches+--    won't be executed.+--+-- The following property holds:+--+-- > pre >> branchout [a, b, c] = branchout [pre >> a, pre >> b, pre >> c]+--+-- The list of branches must be non-empty.+branchout :: forall caps m. (MonadEmulated caps m) => [(Text, m ())] -> m ()+branchout branches = do+  caps <- ask+  let branches' :: [(Text, ClevelandBaseMonad caps ())] = second (flip runReaderT caps) <$> branches+  lift $ eiBranchout (getEmulatedCap caps) branches'++-- | Execute one or more actions and roll them back afterwards.+-- Actions performed in 'offshoot' will _not_ be observed by any+-- actions performed after 'offshoot'.+--+-- Similar to 'branchout', but accepts one single branch.+offshoot :: forall caps m. MonadEmulated caps m => Text -> m () -> m ()+offshoot branchName branch = branchout [(branchName, branch)]++{- | Returns the result of the action with the logs it produced. Logs are messages+printed by the Lorentz instruction 'Lorentz.printComment'.++This function can be combined either with lens-based accessors or helper functions to get+more specific information about logs.++Examples:++@+(logsInfo, _) <- getMorleyLogs scenario+logsInfo ^.. each . logsL @== [MorleyLogs ["log"], MorleyLogs ["log2"]]+logsInfo ^.. each . filterLogsByAddrL addr @== [MorleyLogs ["log"]]+@++@+(logsInfo, _) <- getMorleyLogs scenario+collectLogs logsInfo @== MorleyLogs ["log", "log2"]+logsForAddress logsInfo @== [MorleyLogs ["log"]]+@++-}+getMorleyLogs :: forall a caps m. MonadEmulated caps m => m a -> m (LogsInfo, a)+getMorleyLogs action = do+  caps <- ask+  let action' :: ClevelandBaseMonad caps a = runReaderT action caps+  lift $ eiGetMorleyLogs (getEmulatedCap caps) action'++-- | Version of `getMorleyLogs` for actions that don't return a result.+getMorleyLogs_ :: MonadEmulated caps m => m () -> m LogsInfo+getMorleyLogs_ action = fst <$> getMorleyLogs action++-- | Updates voting power accessible via @VOTING_POWER@ and similar+-- instructions.+setVotingPowers :: MonadEmulated caps m => VotingPowers -> m ()+setVotingPowers vp = do+  withCap getEmulatedCap \cap -> eiSetVotingPowers cap vp++-- | A helper constraint synonym to make signatures below a bit shorter+type EqBaseMonad a b = ClevelandBaseMonad a ~ ClevelandBaseMonad b++-- | Perform an action if we are currently in emulation mode.+-- See also 'ifEmulation' note on constraints.+whenEmulation+  :: MonadCleveland caps m+  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 ())+  -> m ()+whenEmulation action = ifEmulation action pass++-- | Perform an action if we are currently in network mode.+-- See also 'ifEmulation' note on constraints.+whenNetwork+  :: MonadCleveland caps m+  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadNetwork caps1 m1) => m1 ())+  -> m ()+whenNetwork action = ifEmulation pass action++{- | Perform one action if we are currently in emulation mode, another otherwise++Functions passed as the first two arguments are universally quantified over+the outer monad, so if additional constraints are required beyond+'MonadEmulated' or 'MonadCleveland', those constraints have to go on the base+monad, e.g.++@+someFunction :: (MonadCleveland caps m, MonadFail (ClevelandBaseMonad caps)) => m ()+someFunction = whenEmulation do+  Just x <- pure (Just 1 :: Maybe Int) -- this would error without MonadFail+  runIO $ print x+@+-}+ifEmulation+  :: forall a caps m+   . MonadCleveland caps m+  => (forall caps1 m1. (EqBaseMonad caps caps1, MonadEmulated caps1 m1) => m1 a)+  -> (forall caps1 m1. (EqBaseMonad caps caps1, MonadNetwork caps1 m1) => m1 a)+  -> m a+ifEmulation onEmu onNet = withCap getMiscCap cmiUnderlyingImpl >>= \case+  Right impl -> withCap (view clevelandCapsL) (runReaderT onNet . NetworkCaps impl)+  Left impl -> withCap (view clevelandCapsL) (runReaderT onEmu . EmulatedCaps impl)++-- | Get a 'MorleyClientEnv' when running a test on network. Useful to run+-- f.ex. @tezos-client@ inside a network test.+--+-- This is considered a pretty low-level function, so it's better to avoid it in+-- most cases.+getMorleyClientEnv :: MonadNetwork caps m => m MorleyClientEnv+getMorleyClientEnv = asks (neMorleyClientEnv . getNetworkEnvCap)

@@ -0,0 +1,38 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Internally used typeclass for operations-related actions+module Test.Cleveland.Internal.Actions.MonadOps+  ( module Test.Cleveland.Internal.Actions.MonadOps+  ) where++import Test.Cleveland.Internal.Abstract++-- | Typeclass for monads where operations-related actions can occur.+--+-- This is implemented for 'MonadCleveland' and batch context.+--+-- Has 'Functor' as a superclass constraint for convenience, all the related methods+-- require it.+--+-- This is used internally to implement @originate@ and @transfer@. There is a+-- more specific, more user-friendly @MonadOps@ class defined in+-- "Test.Cleveland.Internal.Actions".+class Functor m => MonadOpsInternal m where+  -- | Obtain 'ClevelandOpsImpl' suitable for the current \"monad\".+  --+  -- In CPS style, because the \"monad\" can be actually not a monad, so+  -- it can't work like 'ask' for 'ReaderT'.+  withOpsCap :: (ClevelandOpsImpl m -> m a) -> m a++instance MonadOpsInternal ClevelandOpsBatch where+  withOpsCap mkAction = mkAction batchedOpsImpl++instance (HasClevelandCaps caps, ClevelandBaseMonad caps ~ m) => MonadOpsInternal (ReaderT caps m) where+  withOpsCap mkAction = do+    opsCap :: ClevelandOpsImpl m <- asks getOpsCap+    let opsCap' :: ClevelandOpsImpl (ReaderT caps m) =+          ClevelandOpsImpl+            { coiRunOperationBatch =  lift ... coiRunOperationBatch opsCap+            }+    mkAction opsCap'

@@ -0,0 +1,225 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Machinery for the variadic 'originate' function.+module Test.Cleveland.Internal.Actions.Originate+  ( module Test.Cleveland.Internal.Actions.Originate+  ) where++import Lorentz+  (Contract(..), NiceParameter, NiceStorage, NiceViewsDescriptor, niceStorageEvi,+  toMichelsonContract)++import Data.Constraint ((\\))+import GHC.TypeLits (ErrorMessage(..), TypeError)++import Morley.Client.Types+import Morley.Michelson.Typed (convertContract, toVal, untypeValue)+import Morley.Michelson.Typed qualified as T+import Morley.Michelson.Untyped qualified as U+import Morley.Tezos.Address+import Morley.Tezos.Core+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Actions.Helpers+import Test.Cleveland.Internal.Actions.MonadOps++-- | Originate a new contract with given data.+--+-- Can accept untypted or Lorentz contracts as-is. With typed Michelson contracts,+-- you need to wrap the contract in 'TypedContract' specifying its Haskell-land+-- parameter, storage types and view descriptors, e.g.+--+-- > originate "typed contract" defaultStorage $ TypedContract @Param @Storage @() michelsonContract+--+-- Storage type can be auto-deduced in most cases, so you can skip it with @\@_@.+--+-- After the mandatory arguments, you can add 'Large' or a 'Mutez' value, e.g.+-- by using @tz@ quasi-quoter:+--+-- > originate "contract" initialStorage contract Large+-- > originate "contract" initialStorage contract [tz|123micro|]+-- > originate "contract" initialStorage contract [tz|123micro|] Large+--+-- The order is arbitrary, but each can be specified at most once.+originate :: forall contract r. (HasCallStack, OriginateFunc contract 'NoBalance 'NotLarge r)+          => ContractAlias -> ContractStorage contract -> contract -> r+originate = originate'r @contract @'NoBalance @'NotLarge ... initialData @contract++----------------------------------------------------------------------------+-- Main origination implementations+----------------------------------------------------------------------------++-- | Class implementing actual origination.+class Originator od res where+  -- | Low-level polymorphic origination function.+  -- It takes 'UntypedOriginateData', 'TypedOriginateData' or 'OriginateData',+  -- and returns correspondingly an 'Address', or a 'ContractHandle', in a+  -- suitable monad.+  originateFn :: HasCallStack => od -> res++instance (a ~ ContractHandle cp st vd, MonadOpsInternal m+  , Originator (UntypedOriginateData large) (m ContractAddress))+  => Originator (OriginateData cp st vd large) (m a) where+  originateFn od@OriginateData{ odContract=Contract{}, ..} = do+    let uod = UntypedOriginateData @large+          odName+          odBalance+          (untypeValue (toVal odStorage) \\ niceStorageEvi @st)+          (convertContract $ toMichelsonContract (odContract od))+    ContractHandle odName <$> originateFn uod++instance (a ~ ContractHandle cp st vd, MonadOpsInternal m+  , Originator (UntypedOriginateData large) (m ContractAddress)+  , NiceStorage st, NiceViewsDescriptor vd, NiceParameter cp)+  => Originator (TypedOriginateData cp st vd large) (m a) where+  originateFn tod@TypedOriginateData{todContract = T.Contract{}, ..} = do+    let uod = UntypedOriginateData @large+          todName+          todBalance+          (untypeValue (toVal todStorage))+          (convertContract (todContract tod))+    ContractHandle todName <$> originateFn uod++instance (a ~ ContractAddress, MonadOpsInternal m)+  => Originator (UntypedOriginateData 'NotLarge) (m a) where+  originateFn uod = withOpsCap \opsCap ->+    runSingleOperation opsCap "origination" (OpOriginate uod) \case+      OpOriginate addr -> Just addr+      _ -> Nothing++instance (HasClevelandCaps caps, base ~ ClevelandBaseMonad caps, a ~ ContractAddress) =>+  Originator (UntypedOriginateData 'IsLarge) (ReaderT caps base a) where+  originateFn uod = do+    sender <- view senderL+    withCap getMiscCap \cap -> cmiOriginateLargeUntyped cap sender uod++----------------------------------------------------------------------------+-- ContractClass+----------------------------------------------------------------------------++-- | Type class that abstracts different contract types for the purpose of+-- origination.+class ContractClass contract where+  type ContractStorage contract+  type ContractOriginateData contract :: LargeOrigination -> Type+  initialData+    :: ContractAlias -> ContractStorage contract -> contract+    -> ContractOriginateData contract 'NotLarge++instance ContractClass (Contract cp st vd) where+  type ContractStorage (Contract cp st vd) = st+  type ContractOriginateData (Contract cp st vd) = OriginateData cp st vd+  initialData = flip OriginateData zeroMutez++instance ContractClass U.Contract where+  type ContractStorage U.Contract = U.Value+  type ContractOriginateData U.Contract = UntypedOriginateData+  initialData = flip UntypedOriginateData zeroMutez++instance ContractClass (TypedContract cp st vd) where+  type ContractStorage (TypedContract cp st vd) = st+  type ContractOriginateData (TypedContract cp st vd) = TypedOriginateData cp st vd+  initialData name store (TypedContract contract) =+    TypedOriginateData+      { todName = name+      , todBalance = zeroMutez+      , todStorage = store+      , todContract = contract+      }++----------------------------------------------------------------------------+-- "The printf trick"+----------------------------------------------------------------------------++-- | The class implementing a guarded "printf trick" for the 'originate' function.+--+-- If you see GHC asking for this constraint, you most likely need to add+-- 'MonadOriginate' constraint on the return monad instead.+class ContractClass contract => OriginateFunc contract (bal :: HasBalance) isLarge r where+  originate'r :: HasCallStack => ContractOriginateData contract isLarge -> r+  default originate'r+    :: (HasCallStack, Originator (ContractOriginateData contract isLarge) r)+    => ContractOriginateData contract isLarge -> r+  originate'r = originateFn++-- | Simple flag to track duplicate balance specification.+data HasBalance = NoBalance | HasBalance++-- | Type family raising a type error on 'HasBalance' argument. Used to improve+-- error reporting for 'OriginateFunc' instances with equality constraints.+type family CheckDupBalance mod :: Constraint where+  CheckDupBalance 'HasBalance = TypeError ('Text "Balance is specified more than once.")+  CheckDupBalance 'NoBalance = ()++instance+   ( ModifyOriginationData (ContractOriginateData ct)+   , OriginateFunc ct 'HasBalance isLarge r+   , CheckDupBalance bal, bal ~ 'NoBalance)+  => OriginateFunc ct bal isLarge (Mutez -> r) where+  originate'r initData x = originate'r @ct @'HasBalance $ setBalance x initData++-- | Type family raising a type error on 'IsLarge' argument. Used to improve+-- error reporting for 'OriginateFunc' instances with equality constraints.+type family CheckDupLarge mod :: Constraint where+  CheckDupLarge 'IsLarge = TypeError ('Text "Large is specified more than once.")+  CheckDupLarge 'NotLarge = ()++instance (ModifyOriginationData (ContractOriginateData ct)+   , OriginateFunc ct bal 'IsLarge r+   , CheckDupLarge isLarge, isLarge ~ 'NotLarge)+  => OriginateFunc ct bal isLarge (Large -> r) where+  originate'r initData Large = originate'r @ct @bal $ setLarge initData++-- | Convenience synonym.+type OFConstraint ct large r =+  ( ContractClass ct, Originator (ContractOriginateData ct large) r)++-- | The terminating case for batched transfer.+instance OFConstraint ct large (ClevelandOpsBatch a)+  => OriginateFunc ct bal large (ClevelandOpsBatch a)++-- | The terminating case for Cleveland monads.+instance OFConstraint ct large (ReaderT cap base a)+  => OriginateFunc ct bal large (ReaderT cap base a)++-- | A convenient synonym class to require the terminating instance for a given+-- monad without leaking too much implementation detail.+class (forall ct bal large a. OFConstraint ct large (m a) => OriginateFunc ct bal large (m a))+  => MonadOriginate m+instance (forall ct bal large a. OFConstraint ct large (m a) => OriginateFunc ct bal large (m a))+  => MonadOriginate m++-- | Catchall incoherent instance to report argument errors.+instance {-# INCOHERENT #-}+     ( ContractClass ct+     , TypeError ('Text "Incorrect argument for the 'originate' function: " ':<>: 'ShowType x ':$$:+      'Text "If in doubt, try adding a type annotation."))+  => OriginateFunc ct bal large (x -> r) where+  originate'r = error "impossible"++----------------------------------------------------------------------------+-- Applying modifiers to the initial data+----------------------------------------------------------------------------++-- | Mark a contract that doesn't fit into the origination size limit.+-- This will execute multiple origination steps.+--+-- Such origination cannot be batched (it simply may not fit).+data Large = Large++-- | Type class implementing modifications to origination data.+class ModifyOriginationData od where+  setBalance :: Mutez -> od large -> od large+  setLarge :: od 'NotLarge -> od 'IsLarge++instance ModifyOriginationData (OriginateData cp st vd) where+  setBalance bal od = od {odBalance = bal}+  setLarge OriginateData{..} = OriginateData{..}++instance ModifyOriginationData (UntypedOriginateData) where+  setBalance bal od = od {uodBalance = bal}+  setLarge UntypedOriginateData{..} = UntypedOriginateData{..}++instance ModifyOriginationData (TypedOriginateData cp st vd) where+  setBalance bal od = od {todBalance = bal}+  setLarge TypedOriginateData{..} = TypedOriginateData{..}

@@ -0,0 +1,331 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Machinery for the variadic 'transfer' function.+module Test.Cleveland.Internal.Actions.Transfer+  ( module Test.Cleveland.Internal.Actions.Transfer+  ) where++import Data.Singletons.TH (SingI(..), genSingletons)+import GHC.TypeLits (ErrorMessage(..), TypeError)++import Lorentz+import Morley.Client.Types+import Morley.Michelson.Typed (Dict(..))+import Morley.Michelson.Untyped qualified as U+import Morley.Tezos.Address+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Actions.MonadOps+import Test.Cleveland.Lorentz.Types++----------------------------------------------------------------------------+-- TransferResult and its singletons+----------------------------------------------------------------------------++-- | Simple flag to track whether we want to return list of emitted events.+data TransferResult = TransferIgnoreResult | TransferWithEmits++-- | Type family encoding the actual 'transfer' result depending on+-- 'TransferResult'+type family FTransferResult emit :: Type where+  FTransferResult 'TransferWithEmits = [ContractEvent]+  FTransferResult 'TransferIgnoreResult = ()++genSingletons [''TransferResult]++{-+Note [TransferResult singletons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++If you're wondering why this complicated song and dance with singletons and not+just multiple terminating instances for each 'TransferWithEmits' value, if we+want to keep 'MonadTransfer', we need terminating instances work for any @emit@,+possibly constrained; if we have instances for a specific value, it's ambiguous+which one to choose in 'MonadTransfer'.++They're declared at the top of the file because of TH staging rules.++-- @lierdakil+-}++----------------------------------------------------------------------------+-- transfer+----------------------------------------------------------------------------++-- | Base method for making a transfer.+--+-- You can specify additional arguments after the destination address to modify+-- optional transfer arguments. Those can either be 'Mutez' to specify transfer+-- amount (0 by default), or a specially constructed call descriptor. The order+-- is arbitrary, but it is usually more convenient to specify transfer amount+-- first. For example:+--+-- > transfer addr [tz|123u|] $ calling (ep @"Entrypoint") ()+-- > transfer addr [tz|123u|]+--+-- If the call isn't specified, then the default entrypoint will be called with+-- @()@, i.e.+--+-- > transfer addr+--+-- is functionally the same as+--+-- > transfer addr $ calling def ()+--+-- If the address in the first argument is untyped, the transfer is unchecked.+-- Unchecked transfers must use 'unsafeCalling' for the call specification. You+-- can also use 'unsafeCalling' with typed address to force an unchecked+-- transfer.+--+-- See "Test.Cleveland.Internal.Actions.Transfer" for further explanation of the+-- interface.+--+-- By default, the sender is the account associated with the @moneybag@ alias.+-- This can be overridden with the @--cleveland-moneybag-alias@ command line+-- option, the @TASTY_CLEVELAND_MONEYBAG_ALIAS@ env var, or @withSender@.+transfer :: forall addr r.+            ( HasCallStack+            , TransferFunc ('Incomplete (InitialTransferMode addr))+                'TransferIgnoreResult 'HasNoAmount r+            , ToL1Address addr )+         => addr -> r+transfer = transfer'r @_ @'TransferIgnoreResult @'HasNoAmount . initialData @addr++----------------------------------------------------------------------------+-- Initial transfer data and wrappers+----------------------------------------------------------------------------++-- | Data-kind for tracking what type of call we're making.+data TransferMode = Checked Type | Unchecked | Incomplete TransferMode++-- | Data-kind for call specification.+data GenericCall mode where+  CheckedCall+    :: (NiceParameter epArg, HasEntrypointArg param epRef epArg)+    => epRef -> epArg -> GenericCall ('Checked param)+  UncheckedCall :: NiceParameter epArg => U.EpName -> epArg -> GenericCall 'Unchecked+  UnspecifiedCall :: GenericCall ('Incomplete param)++-- | Generic version of 'TransferData'+data GenericTransferData mode =+  GenericTransferData+  { gtdAddr :: L1Address+  , gtdCall :: GenericCall mode+  , gtdAmount :: Mutez+  }++-- | Choose the initial 'TransferMode' based on the type of destination address.+type family InitialTransferMode addr :: TransferMode where+  InitialTransferMode ContractAddress = 'Unchecked+  InitialTransferMode ImplicitAddress = 'Unchecked+  InitialTransferMode L1Address = 'Unchecked+  InitialTransferMode (L1TAddress param _) = 'Checked param+  InitialTransferMode (ContractHandle param _ _) = 'Checked param++-- | Construct initial 'GenericTransferData' for a given address.+initialData+  :: ToL1Address addr+  => addr -> GenericTransferData ('Incomplete (InitialTransferMode addr))+initialData addr = GenericTransferData+  { gtdAddr = toL1Address addr+  , gtdAmount = zeroMutez+  , gtdCall = UnspecifiedCall+  }++----------------------------------------------------------------------------+-- "The printf trick" for transfer+----------------------------------------------------------------------------++-- | Simple flag to track duplicate amount specification.+data HasAmount = HasAmount | HasNoAmount++-- | The class implementing a guarded "printf trick" for the 'transfer' function.+--+-- If you see GHC asking for this constraint, you most likely need to add+-- 'MonadTransfer' constraint on the return monad instead.+class TransferFunc (mode :: TransferMode) (emit :: TransferResult) (hasAmount :: HasAmount) r where+  transfer'r :: HasCallStack => GenericTransferData mode -> r++-- | Type family raising a type error on 'HasAmount' argument. Used to improve+-- error reporting for 'TransferFunc' instances with equality constraints.+type family NoDuplicateAmount am :: Constraint where+  NoDuplicateAmount 'HasAmount = TypeError ('Text "Amount is specified more than once.")+  NoDuplicateAmount 'HasNoAmount = ()++instance (TransferFunc mode emit 'HasAmount r, NoDuplicateAmount am, am ~ 'HasNoAmount)+  => TransferFunc mode emit am (Mutez -> r) where+  transfer'r initData x = transfer'r @_ @emit @'HasAmount initData{gtdAmount = x}++-- | Type family raising a type error on 'TransferWithEmits' argument. Used to+-- improve error reporting for 'TransferFunc' instances with equality+-- constraints.+type family NoDuplicateEmit am :: Constraint where+  NoDuplicateEmit 'TransferWithEmits =+    TypeError ('Text "WithContractEvents is specified more than once.")+  NoDuplicateEmit 'TransferIgnoreResult = ()++instance (TransferFunc mode 'TransferWithEmits am r+  , NoDuplicateEmit emit, emit ~ 'TransferIgnoreResult)+  => TransferFunc mode emit am (WithContractEvents -> r) where+  transfer'r initData _ = transfer'r @_ @'TransferWithEmits @am initData++-- | Type family that defines possible mode conversions in 'TransferFunc'.+-- Basically, we don't allow unchecked calls to become checked, and we require+-- that checked calls do not change the parameter type mid-way.+type family MatchModes from to :: Constraint where+  MatchModes ('Incomplete _) 'Unchecked = ()+  MatchModes ('Incomplete ('Checked param1)) ('Checked param2) = param1 ~ param2+  MatchModes ('Incomplete 'Unchecked) _ = TypeError (+    'Text "Can not use this type of call with an untyped address."+    ':$$: 'Text "Try using 'unsafeCalling' instead."+    )+  MatchModes _ _ = TypeError ('Text "Call is specified more than once.")++instance (TransferFunc modeTo emit am r, MatchModes modeFrom modeTo)+  => TransferFunc modeFrom emit am (GenericCall modeTo -> r) where+  transfer'r GenericTransferData{..} x =+    transfer'r @_ @emit @am $ GenericTransferData{gtdCall = x, ..}++-- | The terminating case for batched transfer+instance ( SingI emit, DoTransfer mode, a ~ FTransferResult emit)+  => TransferFunc mode emit am (ClevelandOpsBatch a) where+  transfer'r = case sing @emit of+    STransferWithEmits -> doTransfer+    STransferIgnoreResult -> void . doTransfer++-- | The terminating case for Cleveland monads+instance ( SingI emit, DoTransfer mode, HasClevelandCaps cap+  , base ~ ClevelandBaseMonad cap, a ~ FTransferResult emit )+  => TransferFunc mode emit am (ReaderT cap base a) where+  transfer'r = case sing @emit of+    STransferWithEmits -> doTransfer+    STransferIgnoreResult -> void . doTransfer++-- | A convenient synonym class to require the terminating instance for a given+-- monad without leaking too much implementation detail.+class (+  forall mod am emit a. (SingI emit, DoTransfer mod, a ~ FTransferResult emit)+    => TransferFunc mod emit am (m a)+  ) => MonadTransfer m+instance (+  forall mod am emit a. (SingI emit, DoTransfer mod, a ~ FTransferResult emit)+    => TransferFunc mod emit am (m a)+  ) => MonadTransfer m++-- | Catchall incoherent instance to report argument errors.+instance {-# INCOHERENT #-}+     TypeError ('Text "Incorrect argument for the 'transfer' function: " ':<>: 'ShowType x ':$$:+      'Text "If in doubt, try adding a type annotation.")+  => TransferFunc mode emit am (x -> r) where+  transfer'r = error "impossible"++----------------------------------------------------------------------------+-- Making the actual transfer+----------------------------------------------------------------------------++-- | Typeclass abstracting making the actual transfer.+class DoTransfer mode where+  doTransfer :: (HasCallStack, MonadOpsInternal m) => GenericTransferData mode -> m [ContractEvent]++-- | Make the transfer given 'TransferData'+runTransfer :: (HasCallStack, MonadOpsInternal m) => TransferData -> m [ContractEvent]+runTransfer td = withOpsCap \opsCap ->+  runSingleOperation opsCap "transfer" (OpTransfer td) \case+    OpTransfer ops -> Just ops+    _ -> Nothing++instance DoTransfer 'Unchecked where+  doTransfer GenericTransferData+    { gtdAddr = tdTo+    , gtdAmount = tdAmount+    , gtdCall = UncheckedCall tdEntrypoint tdParameter+    } = runTransfer TransferData{..}++instance DoTransfer ('Checked param) where+  doTransfer GenericTransferData+    { gtdAddr = tdTo+    , gtdAmount = tdAmount+    , gtdCall = CheckedCall (epRef :: epRef) (tdParameter :: epArg)+    } | (Dict, tdEntrypoint) <- useHasEntrypointArg @param @epRef @epArg epRef+      = runTransfer TransferData{..}++instance HasEntrypointArg param (EntrypointRef 'Nothing) ()+  => DoTransfer ('Incomplete ('Checked param)) where+  doTransfer GenericTransferData{..} =+    doTransfer GenericTransferData {gtdCall = calling CallDefault @_ @param (), ..}++instance DoTransfer ('Incomplete 'Unchecked) where+  doTransfer GenericTransferData{..} =+    doTransfer GenericTransferData {gtdCall = unsafeCalling U.DefEpName (), ..}++----------------------------------------------------------------------------+-- Call specification+----------------------------------------------------------------------------++-- | Safely call an entrypoint specified by the first argument with the+-- provided parameter.+--+-- The first character of the entrypoint name must be capitalized.+--+-- This is "safe" in the sense that the contract is checked if it indeed has the+-- specified entrypoint and the entrypoint in question accepts the argument+-- provided, a type error is raised otherwise.+--+-- > transfer addr $ calling (ep @"Entrypoint") ()+--+-- Use 'CallDefault' or @def@ to call the default entrypoint.+--+-- > transfer addr $ calling def ()+--+-- Notice that type variables for entrypoint argument and full parameter are+-- specified after the entrypoint. This is done so more for readability. F. ex.:+--+-- > transfer addr $ calling def @Integer 123+--+-- This does also marginally simplify type inference in the case of partial+-- application.+calling+  :: forall mname.+      EntrypointRef mname+  -> forall epArg param. (NiceParameter epArg, HasEntrypointArg param (EntrypointRef mname) epArg)+  => epArg -> GenericCall ('Checked param)+calling arg = CheckedCall arg++-- | Unsafely call an entrypoint specified by the first argument with the+-- provided parameter.+--+-- This is "unsafe" in the sense that there is no check that the contract+-- indeed has the specified entrypoint or that the entrypoint in question+-- accepts the argument provided.+--+-- Also, no compile-time checks are performed on the entrypoint name, so it+-- can be malformed.+--+-- > transfer addr $ unsafeCalling (ep @"Entrypoint") ()+--+-- Overloaded labels are supported with 'unsafeCalling', so you can specify the+-- entrypoint as an overloaded label:+--+-- > transfer addr $ unsafeCalling #entrypoint ()+--+-- Use 'U.DefEpName' or @def@ to call the default entrypoint.+--+-- Notice that the type variable for the entrypoint argument is specified after+-- the entrypoint. This is done so more for readability. F. ex.:+--+-- > transfer addr $ calling def @Integer 123+--+-- This does also marginally simplify type inference in the case of partial+-- application.+unsafeCalling :: U.EpName -> forall epArg. NiceParameter epArg => epArg -> GenericCall 'Unchecked+unsafeCalling arg = UncheckedCall arg++----------------------------------------------------------------------------+-- Return value specification+----------------------------------------------------------------------------++-- | 'transfer' flag to signal we want contract events emitted by @EMIT@+-- returned. Passed in the variadic part of 'transfer', e.g.+--+-- > transfer addr [tz|123u|] WithContractEvents $ calling (ep @"Entrypoint") ()+data WithContractEvents = WithContractEvents

@@ -0,0 +1,137 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | 'TransferFailure' Predicates+module Test.Cleveland.Internal.Actions.TransferFailurePredicate+  ( module Test.Cleveland.Internal.Actions.TransferFailurePredicate+  ) where++import Data.Either.Validation (Validation(..))+import Fmt (Builder, build)++import Lorentz+  (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText,+  errorToVal, errorToValNumeric, toVal)+import Lorentz.Constraints+import Morley.Micheline (Expression, fromExpression, toExpression)+import Morley.Michelson.Printer.Util (buildRenderDoc)+import Morley.Michelson.Typed (SomeConstant, SomeConstrainedValue(..))+import Morley.Michelson.Typed qualified as T+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Lorentz.Types++-- | A predicate that checks whether a transfer operation failed for the expected reason.+--+-- Predicates can be combined using the '&&' and '||' operators.+data TransferFailurePredicate+  = TransferFailurePredicate+      (TransferFailure -> Validation Builder ())+      -- ^ A predicate that either returns () or, if it fails,+      -- a message explaining what the expected outcome was.+  | AndPredicate (NonEmpty TransferFailurePredicate)+  | OrPredicate (NonEmpty TransferFailurePredicate)++instance Boolean TransferFailurePredicate where+  AndPredicate l && AndPredicate r = AndPredicate $ l <> r+  AndPredicate l && r = AndPredicate $ l <> one r+  l && AndPredicate r = AndPredicate $ one l <> r+  l && r = AndPredicate $ one l <> one r++  OrPredicate l || OrPredicate r = OrPredicate $ l <> r+  OrPredicate l || r = OrPredicate $ l <> one r+  l || OrPredicate r = OrPredicate $ one l <> r+  l || r = OrPredicate $ one l <> one r++transferFailureReasonPredicate+  :: (TransferFailureReason -> Validation Builder ())+  -> TransferFailurePredicate+transferFailureReasonPredicate p = TransferFailurePredicate $+  \(TransferFailure _ reason) -> p reason++-- | Asserts that interpretation of a contract failed due to an overflow error.+shiftOverflow :: TransferFailurePredicate+shiftOverflow = transferFailureReasonPredicate \case+  ShiftOverflow -> pass+  _ -> Failure "Contract failed due to an overflow error"++-- | Asserts that an action failed due to an attempt to transfer 0tz towards a simple address.+emptyTransaction :: TransferFailurePredicate+emptyTransaction = transferFailureReasonPredicate \case+  EmptyTransaction -> pass+  _ -> Failure "Attempted to transfer 0tz to a simple address"++-- | Asserts that an action failed due to an attempt to call a contract with an invalid parameter.+badParameter :: TransferFailurePredicate+badParameter = transferFailureReasonPredicate \case+  BadParameter -> pass+  _ -> Failure "Attempted to call a contract with a parameter of the wrong type"++-- | Asserts that interpretation of a contract failed due to gas exhaustion.+gasExhaustion :: TransferFailurePredicate+gasExhaustion = transferFailureReasonPredicate \case+  GasExhaustion -> pass+  _ -> Failure "Execution failed due to gas exhaustion"++-- | Asserts that interpretation of a contract ended with @FAILWITH@, throwing the given error.+--+-- This function should be used together with one of the "@FAILWITH@ constructors"+-- (e.g. 'constant', 'customError').+failedWith :: SomeConstant -> TransferFailurePredicate+failedWith expectedFailWithVal = transferFailureReasonPredicate \case+  FailedWith (EOTVExpression actualFailWithExpr) _+    | actualFailWithExpr `isEq` expectedFailWithVal -> pass+  FailedWith (EOTVTypedValue actualFailWithVal) _+    | toExpression actualFailWithVal `isEq` expectedFailWithVal -> pass+  _ -> Failure $ "Contract failed with: " <> buildRenderDoc expectedFailWithVal+  where+    isEq :: Expression -> SomeConstant -> Bool+    isEq expr (SomeConstant (v :: T.Value t)) =+      either (const False) (== v) (fromExpression @(T.Value t) expr)++-- | Asserts that the error occurred while interpreting the contract with the given address.+addressIs+  :: ToAddress addr+  => addr -- ^ The expected address.+  -> TransferFailurePredicate+addressIs (toAddress -> expectedAddr) = TransferFailurePredicate \err -> do+  let TransferFailure (AddressAndAlias actualAddr _) _ = err+  when (actualAddr /= expectedAddr) $+    Failure $ "Failure occurred in contract with address: " <> build expectedAddr++----------------------------------------------------------------------------+-- 'FAILWITH' errors+----------------------------------------------------------------------------++-- | A constant michelson value that a contract threw with @FAILWITH@.+constant :: forall err. NiceConstant err => err -> SomeConstant+constant err =+  withDict (niceConstantEvi @err) $+    SomeConstant $ toVal err++-- | A lorentz error.+lerror :: forall err. IsError err => err -> SomeConstant+lerror err = errorToVal err SomeConstant++-- | A custom lorentz error.+customError+  :: forall arg tag. (IsError (CustomError tag), MustHaveErrorArg tag (MText, arg))+  => Label tag -> arg -> SomeConstant+customError tag arg =+  lerror $ CustomError tag (errorTagToMText tag, arg)++-- | A custom lorentz error with a @unit@ argument.+customError_+  :: (IsError (CustomError tag), MustHaveErrorArg tag (MText, ()))+  => Label tag -> SomeConstant+customError_ tag = customError tag ()++-- | A custom lorentz error with no argument.+customErrorNoArg+  :: (IsError (CustomError tag), MustHaveErrorArg tag MText)+  => Label tag -> SomeConstant+customErrorNoArg tag =+  lerror $ CustomError tag (errorTagToMText tag)++-- | A lorentz numeric error.+numericError :: forall err. IsError err => ErrorTagMap -> err -> SomeConstant+numericError tagMap err = errorToValNumeric tagMap err SomeConstant

@@ -6,7 +6,7 @@  module Test.Cleveland.Internal.Client   ( ClientM (..)-  , runClevelandT+  , runNetworkT    -- * Capability implementations   , networkOpsImpl@@ -20,7 +20,6 @@   , MoneybagConfigurationException (..)    -- * Environment-  , NetworkEnv (..)   , mkMorleyOnlyRpcEnvNetwork    -- * Lens for 'NetworkEnv'@@ -33,7 +32,7 @@   , InternalNetworkScenarioError(..)   ) where -import Control.Lens (_head, each, filtered, makeLensesWith)+import Control.Lens (_head, each, filtered) import Data.Aeson.Text qualified as J import Data.Constraint (withDict, (\\)) import Data.Default (def)@@ -45,53 +44,46 @@ import Time (KnownDivRat, Second, Time, sec, threadDelay, toNum, toUnit) import Unsafe qualified (fromIntegral) -import Lorentz (NicePackedValue, toAddress)+import Lorentz (NicePackedValue) import Lorentz qualified as L import Lorentz.Constraints.Scopes (NiceUnpackedValue, niceParameterEvi)-import Morley.AsRPC (AsRPC, HasRPCRepr(..), MaybeRPC(..), TAsRPC, notesAsRPC, rpcSingIEvi)+import Morley.AsRPC (AsRPC, HasRPCRepr(..), TAsRPC, notesAsRPC, rpcSingIEvi) import Morley.Client (MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, runMorleyClientM) import Morley.Client qualified as Client import Morley.Client.Action (Result) import Morley.Client.Action.Reveal qualified as RevealRPC+import Morley.Client.App (failOnTimeout, retryOnceOnTimeout) import Morley.Client.Init qualified as Client import Morley.Client.Logging (logInfo, logWarning) import Morley.Client.RPC.Error qualified as RPC (ClientRpcError(..), RunCodeErrors(..)) import Morley.Client.RPC.Types   (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp),-  BlockId(..), OperationHash, OriginationScript(..),+  BlockId(..), IntOpEvent(..), OriginationScript(..),   ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize))+import Morley.Client.TezosClient.Impl as TezosClient (getPublicKey, getSecretKey, importKey) import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) import Morley.Client.Util qualified as Client import Morley.Micheline   (Expression, MichelinePrimitive(..), StringEncode(..), TezosInt64, TezosMutez(..),-  _ExpressionPrim, _ExpressionSeq, fromExpression, mpaArgsL, mpaPrimL)+  _ExpressionPrim, _ExpressionSeq, fromExpression, mpaArgsL, mpaPrimL, toExpression)+import Morley.Michelson.Text (unMText) import Morley.Michelson.TypeCheck (typeCheckContractAndStorage, typeCheckingWith) import Morley.Michelson.Typed (BigMapId, SomeAnnotatedValue(..), SomeContractAndStorage(..), toVal) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Untyped qualified as U-import Morley.Tezos.Address (Address, mkKeyAddress)-import Morley.Tezos.Address.Alias (AddressOrAlias(..))+import Morley.Tezos.Address+import Morley.Tezos.Address.Alias import Morley.Tezos.Core as Tezos   (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMulMutez,   unsafeSubMutez) import Morley.Tezos.Crypto-import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.Exception-import Morley.Util.Lens (postfixLFields) import Morley.Util.Named import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Exceptions (addCallStack)+import Test.Cleveland.Lorentz (toL1Address) import Test.Cleveland.Util (ceilingUnit) -data NetworkEnv = NetworkEnv-  { neMorleyClientEnv :: MorleyClientEnv-  , neSecretKey :: Maybe Crypto.SecretKey-  , neMoneybagAlias :: Alias-  , neExplicitDataDir :: Bool-  }--makeLensesWith postfixLFields ''NetworkEnv- -- | Construct 'Client.MorleyOnlyRpcEnv' from 'NetworkEnv'. mkMorleyOnlyRpcEnvNetwork   :: NetworkEnv@@ -109,8 +101,8 @@ -- | This error designates that necessary preparations for running tests -- are not made. data MoneybagConfigurationException-  = NoMoneybagAddress Alias-  | TwoMoneybagKeys Alias SecretKey Address+  = NoMoneybagAddress ImplicitAlias+  | TwoMoneybagKeys ImplicitAlias SecretKey ImplicitAddress   deriving stock (Generic, Show, Eq)  instance Buildable MoneybagConfigurationException where@@ -144,7 +136,7 @@  data ClientState = ClientState   { csDefaultAliasCounter :: DefaultAliasCounter-  , csRefillableAddresses :: Set Address+  , csRefillableAddresses :: Set ImplicitAddress   , csMoneybagAddress :: Moneybag   } @@ -154,7 +146,7 @@   deriving newtype (Functor, Applicative, Monad, MonadIO,                     MonadThrow, MonadCatch, MonadReader (IORef ClientState), MonadFail) -data InternalNetworkScenarioError = TooManyRefillIterations Word Address+data InternalNetworkScenarioError = TooManyRefillIterations Word ImplicitAddress   deriving stock (Show)  instance Buildable InternalNetworkScenarioError where@@ -164,15 +156,18 @@ instance Exception InternalNetworkScenarioError where   displayException = pretty -runClevelandT :: NetworkEnv -> ClevelandT ClientM a -> IO a-runClevelandT env scenario = do+runNetworkT :: NetworkEnv -> NetworkT ClientM a -> IO a+runNetworkT env scenario = do   disableAlphanetWarning   moneybagAddr <- setupMoneybagAddress env-  let caps = ClevelandCaps-        { ccSender = Sender $ unMoneybag moneybagAddr-        , ccMoneybag = moneybagAddr-        , ccMiscCap = networkMiscImpl (neMorleyClientEnv env)-        , ccOpsCap = networkOpsImpl (neMorleyClientEnv env)+  let caps = NetworkCaps+        { ncNetworkEnv = env+        , ncClevelandCaps = ClevelandCaps+            { ccSender = Sender $ unMoneybag moneybagAddr+            , ccMoneybag = moneybagAddr+            , ccMiscCap = networkMiscImpl env+            , ccOpsCap = networkOpsImpl (neMorleyClientEnv env)+            }         }   ist <- newIORef ClientState     { csDefaultAliasCounter = DefaultAliasCounter 0@@ -195,21 +190,22 @@     (Nothing, Just addr) -> do       unless neExplicitDataDir do         ek <- runMorleyClientM setupEnv $-          Client.getSecretKey (AddressAlias neMoneybagAlias)+          (retryOnceOnTimeout ... TezosClient.getSecretKey)+          (AddressAlias neMoneybagAlias)         void $ runMorleyClientM neMorleyClientEnv $-          Client.importKey False neMoneybagAlias ek+          failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek       pure addr     (Nothing, Nothing) -> throwM $ NoMoneybagAddress neMoneybagAlias     (Just ek, Just sa)       | mkKeyAddress (toPublic ek) == sa -> do           unless neExplicitDataDir $ void $             runMorleyClientM neMorleyClientEnv $-              Client.importKey False neMoneybagAlias ek+              failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek           pure sa       | otherwise -> throwM $ TwoMoneybagKeys neMoneybagAlias ek sa     (Just ek, Nothing) -> do       runMorleyClientM neMorleyClientEnv $-        Client.importKey False neMoneybagAlias ek+        failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek       return $ mkKeyAddress (toPublic ek)  -- | Implementation that works with real network and uses @tezos-node@@@ -221,54 +217,57 @@     { coiRunOperationBatch = runOperationBatch env sender     } -networkMiscImpl :: MorleyClientEnv -> ClevelandMiscImpl ClientM-networkMiscImpl env = mapClevelandMiscImplExceptions (addCallStack . exceptionHandler)-  ClevelandMiscImpl+networkMiscImpl :: NetworkEnv -> ClevelandMiscImpl ClientM+networkMiscImpl env@NetworkEnv{..} =+  mapClevelandMiscImplExceptions (addCallStack . exceptionHandler) ClevelandMiscImpl     { cmiRunIO = liftIO -    , cmiOriginateLargeUntyped = \sender untypedOriginateData -> do-        (_, res) <- runClientOrigination env-          sender Client.originateLargeUntypedContract untypedOriginateData-        comment $-          "Originated large smart contract " +| uodName untypedOriginateData |+-          " with address " <> pretty res+    , cmiOriginateLargeUntyped = \(Sender sender) UntypedOriginateData{..} -> do+        let originationScenario =+              Client.originateLargeUntypedContract True uodName (AddressResolved sender)+                uodBalance uodContract uodStorage Nothing+        -- Note that tezos key reveal operation cost an additional fee+        -- so that's why we reveal keys in origination and transaction+        -- rather than doing it before scenario execution+        (_, res) <- liftIO $ do+          revealKeyUnlessRevealed neMorleyClientEnv sender+          runMorleyClientM neMorleyClientEnv originationScenario+        comment $ "Originated large smart contract " +| uodName |+ " with address " <> pretty res         pure res -    , cmiSignBytes = \hash signer -> liftIO $ runMorleyClientM env $+    , cmiSignBytes = \hash signer -> liftIO $ runMorleyClientM neMorleyClientEnv $         -- We don't use password protected accounts in cleveland tests         Client.signBytes (AddressResolved signer) Nothing hash      , cmiGenKey = \sodAlias -> do         alias <- resolveSpecificOrDefaultAlias sodAlias-        liftIO $ runMorleyClientM env $ Client.genKey alias+        liftIO $ runMorleyClientM neMorleyClientEnv $ Client.genKey alias      , cmiGenFreshKey = \sodAlias -> do         alias <- resolveSpecificOrDefaultAlias sodAlias-        liftIO $ runMorleyClientM env $ Client.genFreshKey alias+        liftIO $ runMorleyClientM neMorleyClientEnv $ Client.genFreshKey alias -    , cmiGetBalance = getBalanceHelper-    , cmiGetChainId = liftIO $ runMorleyClientM env Client.getChainId+    , cmiGetBalance = \(MkConstrainedAddress a) -> getBalanceHelper a+    , cmiGetChainId = liftIO $ runMorleyClientM neMorleyClientEnv Client.getChainId     , cmiAttempt = try     , cmiThrow = throwM     , cmiMarkAddressRefillable = setAddressRefillable-    , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM env $ do+    , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM neMorleyClientEnv $ do         alias <- Client.getAlias (AddressResolved addr)         Client.registerDelegate alias Nothing     , cmiComment = comment-    , cmiEmulatedImpl = pure Nothing+    , cmiUnderlyingImpl = pure $ Right env+    , cmiFailure = clientFailure     , ..     }   where-    cmiFailure :: Builder -> ClientM a-    cmiFailure = throwM . CustomTestError . pretty-     cmiGetBigMapValueMaybe :: (NicePackedValue k, NiceUnpackedValue v) => BigMapId k v -> k -> ClientM (Maybe v)     cmiGetBigMapValueMaybe bigMapId k =-      liftIO . runMorleyClientM env $ Client.readBigMapValueMaybe bigMapId k+      liftIO . runMorleyClientM neMorleyClientEnv $ Client.readBigMapValueMaybe bigMapId k      cmiGetAllBigMapValuesMaybe :: (NiceUnpackedValue v) => BigMapId k v -> ClientM (Maybe [v])     cmiGetAllBigMapValuesMaybe bigMapId =-      liftIO . runMorleyClientM env $ Client.readAllBigMapValuesMaybe bigMapId+      liftIO . runMorleyClientM neMorleyClientEnv $ Client.readAllBigMapValuesMaybe bigMapId      getStorageType :: Expression -> ClientM U.Ty     getStorageType contractExpr = do@@ -282,14 +281,14 @@           . _head        case storageTypeExprMb of-        Nothing -> cmiFailure $ unlinesF+        Nothing -> clientFailure $ unlinesF           [ "Contract expression did not contain a 'storage' expression."           , "Contract expression:"           , indentF 2 $ build (J.encodeToTextBuilder contractExpr)           ]         Just storageTypeExpr ->           case fromExpression @U.Ty storageTypeExpr of-            Left err -> cmiFailure $ unlinesF+            Left err -> clientFailure $ unlinesF               [ "'storage' expression was not a valid type expression."               , "Storage expression:"               , indentF 2 $ build (J.encodeToTextBuilder storageTypeExpr)@@ -298,9 +297,10 @@               ]             Right storageType -> pure storageType -    cmiGetSomeStorage :: Address -> ClientM SomeAnnotatedValue+    cmiGetSomeStorage :: ContractAddress -> ClientM SomeAnnotatedValue     cmiGetSomeStorage addr = do-      OriginationScript {osCode, osStorage} <- liftIO . runMorleyClientM env $ Client.getContractScript addr+      OriginationScript {osCode, osStorage} <-+        liftIO . runMorleyClientM neMorleyClientEnv $ Client.getContractScript addr       storageType <- getStorageType osCode       T.withUType storageType \(storageNotes :: T.Notes t) -> do         withDict (rpcSingIEvi @t) do@@ -308,7 +308,7 @@             Right storageValueRPC ->               pure $ SomeAnnotatedValue (notesAsRPC storageNotes) storageValueRPC             Left err ->-              cmiFailure $ unlinesF+              clientFailure $ unlinesF                 [ "Failed to decode storage expression."                 , "Storage expression:"                 , indentF 2 $ build (J.encodeToTextBuilder osStorage)@@ -316,27 +316,30 @@                 , indentF 2 $ build err                 ] -    cmiResolveAddress :: Alias -> ClientM Address-    cmiResolveAddress = liftIO . runMorleyClientM env . Client.resolveAddress . AddressAlias+    cmiResolveAddress :: Alias kind -> ClientM (KindedAddress kind)+    cmiResolveAddress =+      liftIO . runMorleyClientM neMorleyClientEnv . Client.resolveAddress . AddressAlias -    cmiGetPublicKey :: Address -> ClientM PublicKey-    cmiGetPublicKey = liftIO . runMorleyClientM env . Client.getPublicKey . AddressResolved+    cmiGetPublicKey :: ImplicitAddress -> ClientM PublicKey+    cmiGetPublicKey = liftIO . runMorleyClientM neMorleyClientEnv .+      (retryOnceOnTimeout ... TezosClient.getPublicKey) . AddressResolved -    getBalanceHelper :: Address -> ClientM Mutez-    getBalanceHelper = liftIO . runMorleyClientM env . Client.getBalance+    getBalanceHelper :: L1AddressKind kind => KindedAddress kind -> ClientM Mutez+    getBalanceHelper = liftIO . runMorleyClientM neMorleyClientEnv . Client.getBalance -    cmiGetDelegate :: Address -> ClientM (Maybe KeyHash)-    cmiGetDelegate = liftIO . runMorleyClientM env . Client.getDelegate+    cmiGetDelegate :: ContractAddress -> ClientM (Maybe KeyHash)+    cmiGetDelegate =+      liftIO . runMorleyClientM neMorleyClientEnv . Client.getDelegate      cmiGetNow :: ClientM Tezos.Timestamp-    cmiGetNow = timestampFromUTCTime <$> getLastBlockTimestamp env+    cmiGetNow = timestampFromUTCTime <$> getLastBlockTimestamp neMorleyClientEnv      cmiGetLevel :: ClientM Natural-    cmiGetLevel = getLastBlockLevel env+    cmiGetLevel = getLastBlockLevel neMorleyClientEnv      cmiGetApproximateBlockInterval :: ClientM (Time Second)     cmiGetApproximateBlockInterval = liftIO $ do-      pp <- runMorleyClientM env $ Client.getProtocolParameters+      pp <- runMorleyClientM neMorleyClientEnv $ Client.getProtocolParameters       return . sec $ (unStringEncode $ ppMinimalBlockDelay pp) % 1      cmiAdvanceTime :: (KnownDivRat unit Second) => Time unit -> ClientM ()@@ -350,12 +353,12 @@          deltaSec' :: NominalDiffTime         deltaSec' = secondsToNominalDiffTime $ toNum @Second deltaSec-      t0 <- getLastBlockTimestamp env+      t0 <- getLastBlockTimestamp neMorleyClientEnv       threadDelay deltaSec       let         go :: ClientM ()         go = do-          now <- getLastBlockTimestamp env+          now <- getLastBlockTimestamp neMorleyClientEnv           if (now `diffUTCTime` t0) >= deltaSec'             then pass             else threadDelay (sec 1) >> go@@ -363,7 +366,7 @@      cmiAdvanceToLevel :: (Natural -> Natural) -> ClientM ()     cmiAdvanceToLevel targetLevelFn = do-      lastLevel <- getLastBlockLevel env+      lastLevel <- getLastBlockLevel neMorleyClientEnv       let targetLevel = max (targetLevelFn lastLevel) lastLevel       let skippedLevels = targetLevel - lastLevel       -- In case we need to skip more than one level we'll jump ahead for@@ -386,21 +389,15 @@     cmiRunCode       :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st))       => Sender -> RunCode cp st vd -> ClientM (AsRPC st)-    cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcLevel rcNow rcBalance rcSource) =-      liftIO $ runMorleyClientM env do+    cmiRunCode (Sender sender) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) =+      liftIO $ runMorleyClientM neMorleyClientEnv do         -- Pattern match on the contract constructor to reveal-        -- a proof of `NiceParameter cp` and `NiceStorage st`+        -- a proof of `NiceStorage st`         L.Contract{} <- pure rcContract         T.fromVal <$> Client.runContract Client.RunContractParameters           { rcpContract = L.toMichelsonContract $ rcContract-          , rcpStorage =-              case rcStorage of-                NotRPC v -> NotRPC $ toVal v-                IsRPC v -> IsRPC $ toVal v-          , rcpParameter =-              case rcParameter of-                NotRPC v -> NotRPC $ toVal v-                IsRPC v -> IsRPC $ toVal v+          , rcpParameter = rcParameter+          , rcpStorage = rcStorage           , rcpAmount = rcAmount           , rcpBalance = rcBalance           , rcpSource = rcSource@@ -408,13 +405,19 @@           , rcpNow = rcNow           , rcpSender = Just sender           }-          \\ L.niceParameterEvi @cp           \\ L.niceStorageEvi @st +clientFailure :: Builder -> ClientM a+clientFailure = throwM . CustomTestError . pretty+ comment :: Text -> ClientM () comment msg = liftIO $ putTextLn msg >> hFlush stdout -getAlias :: MorleyClientEnv -> Address -> ClientM Alias+getAlias+  :: L1AddressKind kind+  => MorleyClientEnv+  -> KindedAddress kind+  -> ClientM (Alias kind) getAlias env = liftIO . runMorleyClientM env . Client.getAlias . AddressResolved  getLastBlockTimestamp :: MorleyClientEnv -> ClientM UTCTime@@ -426,7 +429,11 @@   bc <- liftIO $ runMorleyClientM env (Client.getBlockConstants HeadId)   pure . Unsafe.fromIntegral @Int64 @Natural . bhnhLevel $ bcHeader bc -runOperationBatch :: MorleyClientEnv -> Address -> [OperationInfo ClevelandInput] -> ClientM [OperationInfo Result]+runOperationBatch+  :: MorleyClientEnv+  -> ImplicitAddress+  -> [OperationInfo ClevelandInput]+  -> ClientM [OperationInfo ClevelandResult] runOperationBatch env sender ops = do   istRef <- ask   ClientState{csMoneybagAddress=Moneybag moneybag} <- readIORef istRef@@ -535,16 +542,47 @@     snd <$> Client.runOperations (AddressResolved sender) ops'    forM_ results $ \case-    OpTransfer () -> pass+    OpTransfer _ -> pass     OpOriginate addr -> do       alias <- getAlias env addr       comment $ "Originated smart contract '" +| alias |+         "' with address " <> pretty addr     OpReveal () -> pass -  return results+  mapM toClevelandResult results -dryRunOperations :: AddressOrAlias+toClevelandResult :: OperationInfo Result -> ClientM (OperationInfo ClevelandResult)+toClevelandResult = \case+  OpTransfer ops -> OpTransfer <$> mapM intOpEventToContractEvent ops+  OpOriginate ops -> pure $ OpOriginate ops+  OpReveal ops -> pure $ OpReveal ops++intOpEventToContractEvent :: IntOpEvent -> ClientM ContractEvent+intOpEventToContractEvent IntOpEvent{..} = do+  T.AsUType (ceType :: T.Notes t) <- either throwM (pure . toTy) $ fromExpression @U.T ioeType+  cePayload <- case ioePayload of+    Nothing -> pure Nothing+    Just payload -> case fromExpression @(T.Value t) . toExpression $ payload of+      Right value -> pure . Just $ SomeAnnotatedValue ceType value+      Left err ->+        clientFailure $ unlinesF+          [ "Failed to decode event payload expression."+          , "Payload expression:"+          , indentF 2 $ build (J.encodeToTextBuilder $ toExpression payload)+          , "Decoding error:"+          , indentF 2 $ build err+          ]+  pure $ ContractEvent+    { ceSource = ioeSource+    , ceTag = maybe "" unMText ioeTag+    , ..+    }+  where+    toTy :: U.T -> U.Ty+    toTy t = U.Ty t U.noAnn+++dryRunOperations :: ImplicitAddressOrAlias                   -> [OperationInfo Client.ClientInput]                   -> Client.MorleyClientM [(AppliedResult, Mutez)] dryRunOperations s = \case@@ -569,11 +607,12 @@  exceptionToTransferFailure :: RPC.ClientRpcError -> ClientM TransferFailure exceptionToTransferFailure = \case-  RPC.ContractFailed addr expr -> return $ TransferFailure addr $ FailedWith (EOTVExpression expr) Nothing-  RPC.BadParameter addr _ -> return $ TransferFailure addr BadParameter-  RPC.EmptyTransaction addr -> return $ TransferFailure addr EmptyTransaction-  RPC.ShiftOverflow addr -> return $ TransferFailure addr ShiftOverflow-  RPC.GasExhaustion addr -> return $ TransferFailure addr GasExhaustion+  RPC.ContractFailed addr expr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) $+    FailedWith (EOTVExpression expr) Nothing+  RPC.BadParameter addr _ -> return $ TransferFailure (AddressAndAlias addr Nothing) BadParameter+  RPC.EmptyTransaction addr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) EmptyTransaction+  RPC.ShiftOverflow addr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) ShiftOverflow+  RPC.GasExhaustion addr -> return $ TransferFailure (AddressAndAlias (MkAddress addr) Nothing) GasExhaustion   internalError -> throwM internalError  exceptionHandler :: ClientM a -> ClientM a@@ -581,32 +620,7 @@   Left err -> exceptionToTransferFailure err >>= throwM   Right res -> return res -runClientOrigination-  :: MorleyClientEnv-  -> Sender-  -> (  Bool-      -> Alias-      -> AddressOrAlias-      -> Mutez-      -> U.Contract-      -> U.Value-      -> Maybe Mutez-      -> Client.MorleyClientM (OperationHash, Address)-      )-  -> UntypedOriginateData-  -> ClientM (OperationHash, Address)-runClientOrigination env (Sender sender) mkScenario (UntypedOriginateData{..}) = do-  let originationScenario =-        mkScenario True uodName (AddressResolved sender)-          uodBalance uodContract uodStorage Nothing-  -- Note that tezos key reveal operation cost an additional fee-  -- so that's why we reveal keys in origination and transaction-  -- rather than doing it before scenario execution-  liftIO $ do-    revealKeyUnlessRevealed env sender-    runMorleyClientM env originationScenario--resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM Alias+resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM ImplicitAlias resolveSpecificOrDefaultAlias (SpecificAlias alias) = pure alias resolveSpecificOrDefaultAlias (DefaultAlias) = do   stateRef <- ask@@ -614,13 +628,13 @@   writeIORef stateRef ist{ csDefaultAliasCounter = DefaultAliasCounter $ counter + 1 }   pure $ mkDefaultAlias counter -setAddressRefillable :: Address -> ClientM ()+setAddressRefillable :: ImplicitAddress -> ClientM () setAddressRefillable addr = do   stRef <- ask   modifyIORef stRef $ \st@ClientState{..} ->     st{csRefillableAddresses=Set.insert addr csRefillableAddresses} -isAddressRefillable :: Address -> ClientM Bool+isAddressRefillable :: ImplicitAddress -> ClientM Bool isAddressRefillable addr = do   stRef <- ask   Set.member addr . csRefillableAddresses <$> readIORef stRef@@ -631,7 +645,7 @@  convertOriginateUntypedData   :: (MonadThrow m)-  => UntypedOriginateData -> m Client.OriginationData+  => UntypedOriginateData 'NotLarge -> m Client.OriginationData convertOriginateUntypedData UntypedOriginateData{..} = do   SomeContractAndStorage contract storage <-     throwLeft . pure $ typeCheckingWith def $@@ -649,7 +663,7 @@   :: TransferData -> Client.TransactionData convertTransferData TransferData{ tdParameter = param :: p, ..} =   Client.TransactionData Client.TD-    { tdReceiver = toAddress tdTo+    { tdReceiver = toL1Address tdTo     , tdAmount = tdAmount     , tdEpName = tdEntrypoint     , tdParam = toVal param@@ -657,7 +671,7 @@     } \\ niceParameterEvi @p  -- | Runs 'Client.revealKeyUnlessRevealed' with given client environment.-revealKeyUnlessRevealed :: MorleyClientEnv -> Address -> IO ()+revealKeyUnlessRevealed :: MorleyClientEnv -> ImplicitAddress -> IO () revealKeyUnlessRevealed env addr = runMorleyClientM env $   -- We don't use password protected accounts in cleveland.   Client.revealKeyUnlessRevealed addr Nothing

@@ -26,9 +26,7 @@ -- | Run an 'Scenario' via the "Morley.Michelson.Runtime" emulator, -- inside an @hedgehog@ property. testScenarioProps :: (HasCallStack, MonadIO m, MonadTest m) => Scenario PureM -> m ()-testScenarioProps = evalIO . \case-  ScenarioCleveland s -> runClevelandT moneybagAlias s-  ScenarioEmulated s -> runEmulatedT moneybagAlias s+testScenarioProps (ScenarioEmulated s) = evalIO $ runEmulatedT moneybagAlias s  evalIO :: (HasCallStack, MonadIO m, MonadTest m) => IO a -> m a evalIO m = either (withFrozenCallStack failWithException) pure =<< liftIO (tryAll m)

@@ -4,7 +4,6 @@ -- | Integration with integrational testing engine (pun intended). module Test.Cleveland.Internal.Pure   ( PureM(..)-  , runClevelandT   , runEmulatedT    -- * Capability implementations@@ -23,36 +22,31 @@   , emptyScenarioBranch    -- * Optics-  , psAliases+  , psSecretKeys   , psDefaultAliasesCounter   , psRefillableAddresses   , psNow   , psLevel   , psMinBlockTime   , psGState-  , psContractsNames   ) where -import Control.Lens (assign, at, makeLenses, modifying, to, (%=), (.=))+import Control.Lens (assign, at, each, makeLenses, modifying, to, (%=), (.=), (?=), (?~)) import Control.Lens.Unsound (lensProduct) import Control.Monad.Catch.Pure (CatchT, runCatchT) import Control.Monad.Writer (MonadWriter, WriterT, listen, runWriterT, tell) import Data.Constraint (Dict(..), withDict, (\\)) import Data.Default (def) import Data.Map qualified as Map-import Data.Monoid (Ap(..)) import Data.Ratio ((%)) import Data.Set qualified as Set-import Data.Singletons (sing)-import Data.Type.Equality (type (:~:)(Refl)) import Fmt (Buildable(..), Builder, build, pretty, unlinesF, (+|), (|+)) import Time (Second, toNum, toUnit)  import Lorentz (Mutez, NiceComparable, pattern DefEpName) import Lorentz qualified as L import Lorentz.Entrypoints (HasEntrypointArg, TrustEpName(..), useHasEntrypointArg)-import Morley.AsRPC-  (HasRPCRepr(AsRPC), MaybeRPC(..), notesAsRPC, replaceBigMapIds, rpcStorageScopeEvi, valueAsRPC)+import Morley.AsRPC (HasRPCRepr(AsRPC), notesAsRPC, rpcStorageScopeEvi, valueAsRPC) import Morley.Client (OperationInfo(..)) import Morley.Michelson.Interpret   (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..))@@ -61,37 +55,40 @@ import Morley.Michelson.Runtime.Dummy   (dummyLevel, dummyMaxSteps, dummyMinBlockTime, dummyNow, dummyOrigination) import Morley.Michelson.Runtime.GState-  (GState(..), asBalance, genesisAddress, genesisSecretKey, gsAddressesL, gsChainIdL, gsCounterL,-  gsVotingPowersL, initGState)-import Morley.Michelson.TypeCheck (TCError(..), typeCheckContractAndStorage, typeCheckingWith)+  (GState(..), genesisAddress, genesisSecretKey, gsChainIdL, gsContractAddressAliasesL,+  gsContractAddressesL, gsCounterL, gsImplicitAddressAliasesL, gsVotingPowersL, initGState,+  lookupBalance)+import Morley.Michelson.TypeCheck+  (BigMapFinder, TCError(..), TypeCheckOptions(..), typeCheckContractAndStorage,+  typeCheckValueRunCodeCompat, typeCheckingWith) import Morley.Michelson.Typed-  (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), ToT, Value, Value'(..), castM,-  dfsFoldMapValue, fromVal, requireEq, toVal)+  (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), SomeConstrainedValue(SomeValue),+  SomeVBigMap(..), SomeValue, ToT, Value, Value'(..), castM, dfsFoldMapValue, fromVal, toVal) import Morley.Michelson.Typed qualified as T-import Morley.Michelson.Typed.Operation (OriginationOperation(..), TransferOperation(..))+import Morley.Michelson.Typed.Operation+  (EmitOperation(..), OriginationOperation(..), TransferOperation(..)) import Morley.Michelson.Untyped qualified as U-import Morley.Tezos.Address (Address, detGenKeyAddress)-import Morley.Tezos.Address.Alias (Alias(..))+import Morley.Tezos.Address+import Morley.Tezos.Address.Alias import Morley.Tezos.Core (Timestamp, timestampPlusSeconds, unsafeSubMutez, zeroMutez) import Morley.Tezos.Crypto (SecretKey(..), detSecretKey, sign, toPublic) import Morley.Util.MismatchError import Morley.Util.Named +import Morley.Util.Bimap qualified as Bimap import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Exceptions (addCallStack, catchWithCallStack, throwWithCallStack) import Test.Cleveland.Lorentz import Test.Cleveland.Util (ceilingUnit)  data PureState = PureState-  { _psAliases :: Aliases+  { _psSecretKeys :: Map ImplicitAddress SecretKey   , _psDefaultAliasesCounter :: DefaultAliasCounter-  , _psRefillableAddresses :: Set Address+  , _psRefillableAddresses :: Set ImplicitAddress   , _psNow :: Timestamp   , _psLevel :: Natural   , _psMinBlockTime :: Natural   , _psGState :: GState-  , _psContractsNames :: Map Address Text-  -- ^ Map from contracts addresses to human-readable names.   }   deriving stock (Eq, Show) @@ -99,69 +96,49 @@   get = ask >>= readIORef   put = (ask >>=) . flip writeIORef -data AddressName = AddressName (Maybe Text) Address deriving stock (Show)- newtype PureM a = PureM   { unPureM :: ReaderT (IORef PureState) (CatchT (WriterT LogsInfo IO)) a   }   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch,                     MonadReader (IORef PureState), MonadWriter LogsInfo, MonadFail) -type Aliases = Map Alias AliasData---- | Datatype to store alias data, we store optional 'SecretKey' in addition--- to 'Address' in order to support bytes signing.-data AliasData = AliasData-  { adAddress :: Address-  , adMbSecretKey :: Maybe SecretKey-  }-  deriving stock (Eq, Show)- data TestError   = UnexpectedTypeCheckError TCError   | UnexpectedStorageType (MismatchError T.T)-  | UnexpectedBigMapKeyType (MismatchError T.T)-  | UnexpectedBigMapValueType (MismatchError T.T)+  | UnexpectedBigMapType Natural (MismatchError T.T)   | CustomTestError Text   deriving stock Show  makeLenses ''PureState -instance Buildable AddressName where-  build (AddressName mbName addr) =-    build addr +| maybe "" (\cName -> " (" +|cName |+ ")") mbName- instance Buildable TestError where-  build (UnexpectedTypeCheckError tcErr) =-    "Unexpected type check error. Reason: " +| tcErr |+ ""-  build (UnexpectedStorageType merr) =-    "Unexpected storage type.\n" +| merr |+ ""-  build (UnexpectedBigMapKeyType merr) =-    "Unexpected big map key type.\n" +| merr |+ ""-  build (UnexpectedBigMapValueType merr) =-    "Unexpected big map value type.\n" +| merr |+ ""-  build (CustomTestError msg) = pretty msg+  build = \case+    UnexpectedTypeCheckError tcErr ->+      "Unexpected type check error. Reason: " +| tcErr |+ ""+    UnexpectedStorageType merr ->+      "Unexpected storage type.\n" +| merr |+ ""+    UnexpectedBigMapType bigMapId mismatchError ->+      unlinesF+        [ "A big_map with the ID " +| bigMapId |+ " was found, but it does not have the expected type."+        , build mismatchError+        ]+    CustomTestError msg -> pretty msg  instance Exception TestError where   displayException = pretty -moneybagAlias :: Alias-moneybagAlias = Alias "moneybag"--runEmulatedT :: Alias -> EmulatedT PureM a -> IO a-runEmulatedT moneybagAlias' scenario =-  runClevelandT moneybagAlias' do-    clevelandCaps <- ask-    lift . runReaderT scenario $ EmulatedCaps emulatedImpl clevelandCaps+moneybagAlias :: ImplicitAlias+moneybagAlias = ImplicitAlias "moneybag" -runClevelandT :: Alias -> ClevelandT PureM a -> IO a-runClevelandT moneybagAlias' scenario = do-  let caps = ClevelandCaps+runEmulatedT :: ImplicitAlias -> EmulatedT PureM a -> IO a+runEmulatedT moneybagAlias' scenario = do+  let clevelandCaps = ClevelandCaps         { ccSender = Sender genesisAddress         , ccMoneybag = Moneybag genesisAddress         , ccMiscCap = clevelandMiscImpl         , ccOpsCap = clevelandOpsImpl         }+      caps = EmulatedCaps emulatedImpl clevelandCaps   let pureM = runReaderT scenario caps   env <- newIORef (initEnv moneybagAlias')   (res, _logs) <- runWriterT $ runCatchT $ runReaderT (unPureM pureM) env@@ -187,32 +164,41 @@     ClevelandOpsImpl     { coiRunOperationBatch = mapM \case         OpOriginate UntypedOriginateData{..} -> do-          ref <- originate uodContract (pretty uodName) uodStorage uodBalance-          OpOriginate <$> saveAlias uodName (toAddress ref) Nothing+          OpOriginate <$> originate uodContract uodName uodStorage uodBalance         OpTransfer TransferData{..} -> do           let fromAddr = #from :! sender-          let toAddr = #to :! toAddress tdTo+          let toAddr = #to :! toL1Address tdTo           refillable <- isAddressRefillable sender           when refillable $ do             balance <- getBalance sender             when (balance < tdAmount) $ do               let moneybag = #from :! genesisAddress                   toSender = #to :! sender-              transfer @() moneybag toSender (unsafeSubMutez tdAmount balance)+              void $ transfer @() moneybag toSender (unsafeSubMutez tdAmount balance)                 (TrustEpName DefEpName) ()           -- Here @toAddr@ is 'Address', so we can not check anything           -- about it and assume that entrypoint is correct. We pass           -- unit as contract parameter because it won't be checked           -- anyway.-          transfer @() fromAddr toAddr tdAmount+          emitOps <- transfer @() fromAddr toAddr tdAmount             (TrustEpName tdEntrypoint) tdParameter -          return $ OpTransfer ()+          return $ OpTransfer $ emitOpToContractEvent <$> emitOps         OpReveal{} -> do           -- We do not care about reveals in our Morley runtime           return $ OpReveal ()     } +emitOpToContractEvent :: EmitOperation -> ContractEvent+emitOpToContractEvent EmitOperation{eoEmit=T.Emit{..},..} = ContractEvent+  { cePayload = case T.notesT emNotes of+      -- A dirty hack to match reference+      T.TUnit -> Nothing+      _ -> Just $ SomeAnnotatedValue emNotes emValue+  , ceTag = emTag+  , ceSource = eoSource+  }+ clevelandMiscImpl :: ClevelandMiscImpl PureM clevelandMiscImpl =   mapClevelandMiscImplExceptions (addCallStack . exceptionHandler)@@ -221,19 +207,13 @@         Right res -> pure res         Left (err :: SomeException) -> throwM err -    , cmiResolveAddress = resolve+    , cmiResolveAddress = \case+        a@ImplicitAlias{} -> resolveImplicit a+        a@ContractAlias{} -> resolveContract a      , cmiSignBytes = \bs addr -> do-        -- TODO [#248]: make sure this performs fast-        alias <- getAlias addr-        aliases <- use psAliases-        let mbMbSk = Map.lookup alias aliases-        mbSk <- maybe (unknownAlias alias) (pure . adMbSecretKey) mbMbSk-        case mbSk of-          Nothing ->-            cmiFailure $-            "Given address doesn't have known associated secret key: " <> build alias-          Just sk -> liftIO $ sign sk bs+        sk <- getSecretKey addr+        liftIO $ sign sk bs      , cmiGenKey = \sodAlias -> do       alias <- resolveSpecificOrDefaultAlias sodAlias@@ -242,23 +222,15 @@     , cmiGenFreshKey =         \sodAlias -> do           alias <- resolveSpecificOrDefaultAlias sodAlias-          aliases <- use psAliases-          let mbSk = Map.lookup alias aliases-          smartGenKey (adAddress <$> mbSk) alias+          existingAddr <- use (psGState . gsImplicitAddressAliasesL . at alias)+          smartGenKey existingAddr alias      , cmiOriginateLargeUntyped = originateUntyped      -- Comments are not supported by integrational testing engine (yet).     , cmiComment = const pass     , cmiGetPublicKey = \addr -> do-        aliases <- use psAliases-        let mbAliasInfo = fmap snd $ find (\(_, AliasData addr' _) -> addr == addr') (Map.toList aliases)-        aliasInfo <- maybe (unknownAddress addr) pure mbAliasInfo-        case adMbSecretKey aliasInfo of-          Nothing ->-            cmiFailure $-            "Given address doesn't have known associated public key: " <> build addr-          Just sk -> pure $ toPublic sk+        toPublic <$> getSecretKey addr     , cmiGetDelegate = \addr -> do         ContractState _ _ _ delegate <- contractStorage addr         pure delegate@@ -278,20 +250,17 @@     , cmiAttempt = try     , cmiThrow = throwM     , cmiMarkAddressRefillable = setAddressRefillable-    , cmiGetBalance = getBalance-    , cmiEmulatedImpl = pure $ Just emulatedImpl+    , cmiGetBalance = \(MkConstrainedAddress a) -> getBalance a+    , cmiUnderlyingImpl = pure $ Left emulatedImpl+    , cmiFailure = failure     , ..     }   where-    cmiFailure :: forall a. Builder -> PureM a-    cmiFailure = throwM . CustomTestError . pretty-     setAddressRefillable addr = psRefillableAddresses %= Set.insert addr -    originateUntyped :: Sender -> UntypedOriginateData -> PureM Address+    originateUntyped :: Sender -> UntypedOriginateData 'IsLarge -> PureM ContractAddress     originateUntyped _ UntypedOriginateData {..} = do-      ref <- originate uodContract (pretty uodName) uodStorage uodBalance-      saveAlias uodName (toAddress ref) Nothing+      originate uodContract uodName uodStorage uodBalance      cmiGetBigMapValueMaybe       :: forall k v.@@ -300,6 +269,9 @@       -> k       -> PureM (Maybe v)     cmiGetBigMapValueMaybe (BigMapId bmId) k = runMaybeT do+      -- The RPC does not distinguish between "the bigmap does not exist"+      -- and "the bigmap exists, but the key doesn't", so we mimic the RPC's behaviour here.+      -- We simply return `Nothing` in both cases.       VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId       hoistMaybe $ fromVal @v <$> Map.lookup (toVal k) bigMap @@ -312,59 +284,6 @@       VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId       pure $ fromVal @v <$> Map.elems bigMap -    findBigMapById-      :: forall k v. (SingI v, SingI k)-      => Natural -> PureM (Value ('T.TBigMap k v))-    findBigMapById bigMapId =-      runMaybeT (findBigMapByIdMaybe @k @v bigMapId) >>= maybe notFound pure-      where-        notFound = cmiFailure $ "BigMap with ID " <> build bigMapId <> " not found."---    -- | Traverse storage values of all contracts and looks for a big_map with the given ID.-    -- If multiple big_maps with the given ID are found, it fails with error.-    findBigMapByIdMaybe-      :: forall k v. (SingI v, SingI k)-      => Natural -> MaybeT PureM (Value ('T.TBigMap k v))-    findBigMapByIdMaybe bigMapId = MaybeT do-      addresses <- use $ psGState . gsAddressesL . to Map.elems--      let Ap result =-            flip foldMap addresses \case-              ASContract ContractState{csStorage} ->-                findBigMapInStorage csStorage bigMapId-              ASSimple {} -> Ap $ Right []--      case result of-        -- The RPC does not distinguish between "the bigmap does not exist"-        -- and "the bigmap exists, but the key doesn't", so we mimic the RPC's behaviour here.-        -- We simply return `Nothing` in both cases.-        Right [] -> pure Nothing-        Right [bigMap] -> pure $ Just bigMap-        Right bigMaps ->-          error $ pretty $ unlinesF @_ @Builder-            [ "Expected all big_maps to have unique IDs, but found " +| length bigMaps |+ " big_maps with the ID " +| bigMapId |+ "."-            , "This is most likely a bug."-            ]-        Left (err :: TestError) -> throwM err--    -- | Traverse a storage value and looks for a big_map with the given ID.-    -- If multiple big_maps with the given ID are found, they'll all be returned.-    findBigMapInStorage-      :: forall k v st. (SingI k, SingI v)-      => Value st -> Natural -> Ap (Either TestError) [Value ('T.TBigMap k v)]-    findBigMapInStorage storage bigMapId =-      dfsFoldMapValue-        (\v -> case v of-            VBigMap (Just bigMapId') (_ :: Map (Value k') (Value v'))-              | bigMapId == bigMapId' -> do-                  Refl <- requireEq @k' @k (Ap . Left . UnexpectedBigMapKeyType)-                  Refl <- requireEq @v' @v (Ap . Left . UnexpectedBigMapValueType)-                  pure [v]-            _ -> Ap $ Right []-        )-        storage-     -- | In a real chain, when we retrieve a contract's storage via the Tezos RPC,     -- the storage expression will have all the big_maps replaced with their respective big_map IDs.     --@@ -375,7 +294,7 @@     --   * A contract with big_maps in its storage is originated     --   * A transfer is made and the parameter contains big_maps     --   * A contract's code is run and it calls `EMPTY_BIG_MAP`, `DUP` or `DUP n`.-    cmiGetSomeStorage :: Address -> PureM SomeAnnotatedValue+    cmiGetSomeStorage :: ContractAddress -> PureM SomeAnnotatedValue     cmiGetSomeStorage addr = do       ContractState _ contract (storage :: Value t) _ <- contractStorage addr       pure $@@ -384,23 +303,28 @@           (valueAsRPC storage)           \\ rpcStorageScopeEvi @t -    getAlias :: Address -> PureM Alias-    getAlias addr = do-      aliases <- use psAliases-      let maybeAlias = (fmap fst . find (\(_, AliasData addr' _) -> addr == addr') . Map.toList) aliases-      maybe (unknownAddress addr) pure maybeAlias--    -- Generate a fresh address which was never generated for given alias.-    -- If the address is not saved, we use the alias as its seed.-    -- Otherwise we concatenate the alias with the saved address.-    smartGenKey :: Maybe Address -> Alias -> PureM Address-    smartGenKey existingAddr alias@(Alias aliasTxt) =+    -- Generate a fresh address for a given alias.+    --+    -- If this alias is not yet associated with any address,+    -- we use the alias as the seed for generating a brand new address.+    --+    -- If this alias is already associated with an address,+    -- then we have to use a _different_ seed to guarantee we'll get a brand new address.+    -- Therefore, we concatenate the alias with the existing address and use the+    -- result as a seed for generating a brand new address.+    smartGenKey :: Maybe ImplicitAddress -> ImplicitAlias -> PureM ImplicitAddress+    smartGenKey existingAddr alias@(ImplicitAlias aliasTxt) = do       let         seed = maybe aliasTxt (mappend aliasTxt . pretty) existingAddr         sk = detSecretKey (encodeUtf8 seed)         addr = detGenKeyAddress (encodeUtf8 seed)-       in saveAlias alias addr $ Just sk +      -- Save alias/address association.+      psGState . gsImplicitAddressAliasesL . at alias ?= addr+      -- Save the address's secret key.+      psSecretKeys . at addr .= Just sk+      pure addr+     resolveSpecificOrDefaultAlias (SpecificAlias alias) =       return alias     resolveSpecificOrDefaultAlias DefaultAlias = do@@ -411,12 +335,13 @@     cmiRunCode       :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st))       => Sender -> RunCode cp st vd -> PureM (AsRPC st)-    cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcLevel rcNow rcBalance rcSource) = do+    cmiRunCode (Sender sender) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) = do       -- Pattern match on the contract constructor to reveal       -- a proof of `NiceParameter cp` and `NiceStorage st`       L.Contract{} <- pure rcContract-      param <- maybeRPCToVal rcParameter-      storage <- maybeRPCToVal rcStorage+      param <- typeCheckVal @(ToT cp) rcParameter+      storage <- typeCheckVal @(ToT st) rcStorage+       (now, level) <- use $ psNow `lensProduct` psLevel       psNow %= maybe id const rcNow       psLevel %= maybe id const rcLevel@@ -428,15 +353,15 @@               \\ L.niceStorageEvi @st               \\ L.niceParameterEvi @cp -        esSourceAddress .= rcSource+        esSourceAddress .= (MkConstrainedAddress <$> rcSource)         counter1 <- use $ esGState . gsCounterL         let overrideContractBalance = Just rcBalance         executeTransfer (#isGlobalOp :! False) overrideContractBalance def $           TransferOperation-            { toDestination = contractAddr+            { toDestination = MkAddress contractAddr             , toCounter = counter1             , toTxData = TxData-              { tdSenderAddress = sender+              { tdSenderAddress = MkConstrainedAddress sender               , tdParameter = TxTypedParam param \\ L.niceParameterEvi @cp               , tdEntrypoint = DefEpName               , tdAmount = rcAmount@@ -449,49 +374,83 @@         Left executorError -> throwEE executorError         Right (executorRes, contractAddr) -> do           -- Find the storage of the contract and return it in its RPC representation.-          case executorRes ^. erGState . gsAddressesL . at contractAddr of+          case executorRes ^. erGState . gsContractAddressesL . at contractAddr of             Nothing ->-              cmiFailure $ "Internal error: failed to find contract: '" +| contractAddr |+ "'"-            Just (ASSimple {}) ->-              cmiFailure $ "Internal error: expected address to belong to a contract: '" +| contractAddr |+ "'"-            Just (ASContract (ContractState _ _ (finalStorage :: Value actualSt) _)) -> do+              failure $ "Internal error: failed to find contract: '" +| contractAddr |+ "'"+            Just (ContractState _ _ (finalStorage :: Value actualSt) _) -> do               finalStorage' <- castM @actualSt @(ToT st) finalStorage (throwM . UnexpectedStorageType)               pure $ fromVal $ valueAsRPC finalStorage'       where-        maybeRPCToVal :: MaybeRPC v -> PureM (Value (ToT v))-        maybeRPCToVal = \case-          NotRPC v -> pure $ toVal v-          IsRPC v -> replaceBigMapIds findBigMapById sing $ toVal v+        typeCheckVal :: forall t. SingI t => U.Value -> PureM (Value t)+        typeCheckVal untypedVal = do+          bigMapFinder <- mkBigMapFinder+          let res =+                typeCheckingWith (TypeCheckOptions False False) $+                  typeCheckValueRunCodeCompat bigMapFinder untypedVal+          case res of+            Right val -> pure val+            Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr -isAddressRefillable :: Address -> PureM Bool+mkBigMapFinder :: PureM BigMapFinder+mkBigMapFinder = do+  pureState <- get++  pure \bigMapId ->+    pureState ^?+      psGState . gsContractAddressesL . each . to getContractStorage . to (getBigMapsWithId bigMapId) . each+  where+    getContractStorage :: ContractState -> SomeValue+    getContractStorage (ContractState _ _ storage _) = SomeValue storage++    getBigMapsWithId :: Natural -> SomeValue -> [SomeVBigMap]+    getBigMapsWithId bigMapId (SomeValue val) =+      dfsFoldMapValue+        (\v -> case v of+            VBigMap (Just bigMapId') _ | bigMapId' == bigMapId -> [SomeVBigMap v]+            _ -> []+        )+        val++-- | Traverse storage values of all contracts and looks for a big_map with the given ID.+findBigMapByIdMaybe+  ::forall k v. (SingI v, SingI k)+  => Natural -> MaybeT PureM (Value ('T.TBigMap k v))+findBigMapByIdMaybe bigMapId = do+  SomeVBigMap (v@VBigMap{} :: Value t) <- MaybeT $ mkBigMapFinder <*> pure bigMapId+  castM @t @('T.TBigMap k v) v $ throwM . UnexpectedBigMapType bigMapId++isAddressRefillable :: ImplicitAddress -> PureM Bool isAddressRefillable addr = Set.member addr <$> use psRefillableAddresses -getBalance :: Address -> PureM Mutez+getBalance :: L1AddressKind kind => KindedAddress kind -> PureM Mutez getBalance addr = do-  GState{..} <- use psGState-  return $ maybe zeroMutez asBalance $ Map.lookup addr gsAddresses--saveAlias :: Alias -> Address -> Maybe SecretKey -> PureM Address-saveAlias name addr mbSk = do-  psAliases %= Map.insert name (AliasData addr mbSk)-  pure addr+  gs <- use psGState+  pure $ fromMaybe zeroMutez $ lookupBalance addr gs  exceptionHandler :: PureM a -> PureM a exceptionHandler action = try action >>= \case   Left err -> exceptionToTransferFailure err >>= throwM   Right res -> return res   where-    exceptionToTransferFailure :: ExecutorError' AddressName -> PureM TransferFailure+    exceptionToTransferFailure :: ExecutorError' AddressAndAlias -> PureM TransferFailure     exceptionToTransferFailure err = case err of-      EEZeroTransaction addr -> return $ TransferFailure (addrNameToAddr addr) EmptyTransaction-      EEIllTypedParameter addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter-      EEUnexpectedParameterType addr _ -> return $ TransferFailure (addrNameToAddr addr) BadParameter+      EEZeroTransaction addr -> return $+        TransferFailure addr EmptyTransaction+      EEIllTypedParameter addr _ -> return $+        TransferFailure addr BadParameter+      EEUnexpectedParameterType addr _ -> return $+        TransferFailure addr BadParameter       EEInterpreterFailed addr (InterpretError (MichelsonFailureWithStack{..}, _)) ->         case mfwsFailed of-          MichelsonFailedWith val -> return $ TransferFailure (addrNameToAddr addr) $ FailedWith (EOTVTypedValue val) (Just mfwsErrorSrcPos)-          MichelsonArithError (T.ShiftArithError{}) -> return $ TransferFailure (addrNameToAddr addr) ShiftOverflow-          MichelsonArithError (T.MutezArithError errType _ _) -> return $ TransferFailure (addrNameToAddr addr) $ MutezArithError errType-          MichelsonGasExhaustion -> return $ TransferFailure (addrNameToAddr addr) GasExhaustion+          MichelsonFailedWith val -> return $+            TransferFailure addr $+              FailedWith (EOTVTypedValue val) (Just mfwsErrorSrcPos)+          MichelsonArithError (T.ShiftArithError{}) -> return $+            TransferFailure addr ShiftOverflow+          MichelsonArithError (T.MutezArithError errType _ _) -> return $+            TransferFailure addr $ MutezArithError errType+          MichelsonGasExhaustion -> return $+            TransferFailure addr GasExhaustion           _ -> throwM err       _ -> throwM err @@ -504,34 +463,34 @@   => addr -> PureM st getStorageImpl addr = do   withDict (pickNiceStorage @st addr) $ do-    ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toAddress addr)+    ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toContractAddress addr)     val <- castM @actualT @(ToT st) storage (throwM . UnexpectedStorageType)     pure $ T.fromVal val  -- Attempt to retrieve a ContractState given for the given address. Fails if the -- address is unknown or the address is a simple address (contract without -- code and storage).-contractStorage :: Address -> PureM ContractState+contractStorage :: ContractAddress -> PureM ContractState contractStorage addr = do   GState{..} <- use psGState-  case Map.lookup addr gsAddresses of-    Just (ASContract contractState) -> pure contractState-    Just (ASSimple {}) -> throwM . CustomTestError $-      "Expected address to be contract with storage, but it's a simple address: " <> pretty addr+  case Map.lookup addr gsContractAddresses of+    Just contractState -> pure contractState     Nothing -> unknownAddress addr -resolve :: Alias -> PureM Address-resolve name = do-  aliases <- use psAliases-  let maybeAddress = Map.lookup name aliases-  maybe (unknownAlias name) (pure . adAddress) maybeAddress+resolveImplicit :: ImplicitAlias -> PureM ImplicitAddress+resolveImplicit alias = do+  use (psGState . gsImplicitAddressAliasesL . at alias) >>= maybe (unknownAlias alias) pure -unknownAddress :: Address -> PureM whatever+resolveContract :: ContractAlias -> PureM ContractAddress+resolveContract alias = do+  use (psGState . gsContractAddressAliasesL . at alias) >>= maybe (unknownAlias alias) pure++unknownAddress :: KindedAddress kind -> PureM whatever unknownAddress =   throwM . CustomTestError .   mappend "Unknown address provided: " . pretty -unknownAlias :: Alias -> PureM whatever+unknownAlias :: Alias kind -> PureM whatever unknownAlias =   throwM . CustomTestError .   mappend "Unknown address alias: " . pretty@@ -546,32 +505,34 @@ appendScenarioBranch brName (ScenarioBranchName branches) =   ScenarioBranchName (brName : branches) +failure :: forall a. Builder -> PureM a+failure = throwM . CustomTestError . pretty++getSecretKey :: ImplicitAddress -> PureM SecretKey+getSecretKey addr = do+  use (psSecretKeys . at addr) >>= \case+    Nothing -> unknownAddress addr+    Just sk -> pure sk+ ---------------------------------------------------------------------------- -- Support functions ---------------------------------------------------------------------------- -initAliases :: Alias -> Aliases-initAliases alias = one ( alias-                        , AliasData genesisAddress $-                          Just $ genesisSecretKey-                        )--initEnv :: Alias -> PureState+initEnv :: ImplicitAlias -> PureState initEnv alias = PureState-  { _psAliases = initAliases alias+  { _psSecretKeys = one (genesisAddress, genesisSecretKey)   , _psDefaultAliasesCounter = DefaultAliasCounter 0   , _psRefillableAddresses = Set.empty   , _psNow = dummyNow   , _psLevel = dummyLevel-  , _psGState = initGState+  , _psGState = initGState & gsImplicitAddressAliasesL . at alias ?~ genesisAddress   , _psMinBlockTime = dummyMinBlockTime-  , _psContractsNames = Map.empty   }  failedInsideBranch :: Text -> SomeException -> FailedInBranch failedInsideBranch name err = case fromException @FailedInBranch err of-  Just (FailedInBranch branch failure) ->-    FailedInBranch (appendScenarioBranch name branch) failure+  Just (FailedInBranch branch exception) ->+    FailedInBranch (appendScenarioBranch name branch) exception   Nothing ->     FailedInBranch (appendScenarioBranch name emptyScenarioBranch) err @@ -582,12 +543,12 @@ transfer   :: forall cp vd epRef epArg addr.      (HasEntrypointArg cp epRef epArg, T.IsoValue epArg, L.ToTAddress cp vd addr)-  => "from" :! Address+  => "from" :! ImplicitAddress   -> "to" :! addr   -> Mutez   -> epRef   -> epArg-  -> PureM ()+  -> PureM [EmitOperation] transfer (arg #from -> from) (arg #to -> toAddr) money epRef param =   let L.TAddress to' = L.toTAddress @cp @vd toAddr in   case useHasEntrypointArg @cp @epRef @epArg epRef of@@ -597,7 +558,7 @@           { toDestination = to'           , toCounter = 0           , toTxData = TxData-            { tdSenderAddress = from+            { tdSenderAddress = MkConstrainedAddress from             , tdParameter = withDict (T.properParameterEvi @(ToT epArg)) $                 TxTypedParam (T.toVal param)             , tdEntrypoint = epName@@ -607,22 +568,30 @@  -- | Originate a contract with given initial storage and balance. Its -- address is returned.-originate :: U.Contract -> Text -> U.Value -> Mutez -> PureM Address-originate uContract contractName uStorage balance =+originate :: U.Contract -> ContractAlias -> U.Value -> Mutez -> PureM ContractAddress+originate uContract alias uStorage balance =   case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of     Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr     Right (T.SomeContractAndStorage contract storage) -> do       counter <- gsCounter <$> use psGState-      address <- registerInterpretation . executeGlobalOrigination $-        (dummyOrigination storage contract counter) { ooBalance = balance }--      psContractsNames %= Map.insert address contractName-      return address+      registerInterpretation . executeGlobalOrigination $+        (dummyOrigination storage contract counter)+          { ooBalance = balance+          , ooAlias = Just alias+          }  throwEE :: ExecutorError -> PureM a-throwEE err = do-  st <- get-  throwM $ flip addrToAddrName st <$> err+throwEE err =+  -- Replace all `Address`es with `AddressAndAlias` in the error and throw it.+  traverse addrToAddressAndAlias err >>= throwM+  where+    addrToAddressAndAlias :: Address -> PureM AddressAndAlias+    addrToAddressAndAlias addr@(MkAddress kindedAddr) =+      case kindedAddr of+        ContractAddress{} ->+          use $ psGState . gsContractAddressAliasesL . Bimap.flipped . at kindedAddr . to (AddressAndAlias addr)+        _ ->+          pure $ AddressAndAlias addr Nothing  -- | Runs a set of operations and updates the engine's state. registerInterpretation :: ExecutorM a -> PureM a@@ -652,10 +621,3 @@   gState <- use psGState   minBlockTime <- use psMinBlockTime   pure $ runExecutorM now level minBlockTime dummyMaxSteps gState action--addrToAddrName :: Address -> PureState -> AddressName-addrToAddrName addr iState =-  AddressName (Map.lookup addr (iState ^. psContractsNames)) addr--addrNameToAddr :: AddressName -> Address-addrNameToAddr (AddressName _ addr) = addr

@@ -2,42 +2,64 @@ -- SPDX-License-Identifier: LicenseRef-MIT-OA  module Test.Cleveland.Internal.Scenario-  ( Scenario(..)-  , scenario+  ( Scenario+  , Scenario'(..)+  , MonadScenario(..)   , scenarioEmulated+  , scenarioNetwork   , withInitialNow   , withInitialLevel   , withMinBlockTime   , withChainId   ) where +import Control.Monad.Reader (withReaderT)+ import Morley.Michelson.Runtime.GState (gsChainIdL) import Morley.Tezos.Core qualified as TC import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Client import Test.Cleveland.Internal.Pure --- | A type representing a finalized scenario-data Scenario m where-  ScenarioCleveland :: ClevelandT m () -> Scenario m-  ScenarioEmulated :: EmulatedT PureM () -> Scenario PureM+-- | A convenience type synonym for `Scenario'` that has 'MonadScenario'+-- constraint baked in.+type Scenario m = MonadScenario m => Scenario' m --- | Finalize a generic cleveland scenario.-scenario :: ClevelandT m () -> Scenario m-scenario = ScenarioCleveland+-- | A type representing a finalized scenario. Usually, when using this type+-- with a polymorphic argument, an additional 'MonadScenario' constraint on the+-- argument is required.+--+-- To avoid annotating with 'MonadScenario' everywhere, consider using+-- 'Scenario' instead when possible.+data Scenario' m where+  ScenarioEmulated :: EmulatedT PureM () -> Scenario' PureM+  ScenarioNetwork :: NetworkT ClientM () -> Scenario' ClientM +-- | Typeclass for base monads that can implement a scenario.+class MonadFail m => MonadScenario m where+  -- | Finalize a generic cleveland scenario.+  scenario :: ClevelandT m () -> Scenario' m++instance MonadScenario PureM where+  scenario = ScenarioEmulated . withReaderT (view clevelandCapsL)++instance MonadScenario ClientM where+  scenario = ScenarioNetwork . withReaderT (view clevelandCapsL)+ -- | Finalize a scenario that needs emulator-only features.-scenarioEmulated :: EmulatedT PureM () -> Scenario PureM+scenarioEmulated :: EmulatedT PureM () -> Scenario' PureM scenarioEmulated = ScenarioEmulated +-- | Finalize a scenario that needs network-only features.+scenarioNetwork :: NetworkT ClientM () -> Scenario' ClientM+scenarioNetwork = ScenarioNetwork+ withModifiedState   :: (PureState -> PureState)-  -> Scenario PureM-  -> Scenario PureM-withModifiedState modfn = \case-  ScenarioEmulated emulated ->-    ScenarioEmulated $ lift (modify modfn) >> emulated-  ScenarioCleveland cleveland ->-    ScenarioCleveland $ lift (modify modfn) >> cleveland+  -> Scenario' PureM+  -> Scenario' PureM+withModifiedState modfn (ScenarioEmulated emulated) =+  ScenarioEmulated $ lift (modify modfn) >> emulated  -- | Use with an emulated 'Scenario' to configure the initial @now@ value in tests. --@@ -46,27 +68,27 @@ -- > testScenarioOnEmulator "Testname" $ withInitialNow (Timestamp 10000000) $ scenario $ tests withInitialNow   :: TC.Timestamp-  -> Scenario PureM-  -> Scenario PureM+  -> Scenario' PureM+  -> Scenario' PureM withInitialNow = withModifiedState . set psNow  -- | Similar to 'withInitialNow' but for the initial level withInitialLevel   :: Natural-  -> Scenario PureM-  -> Scenario PureM+  -> Scenario' PureM+  -> Scenario' PureM withInitialLevel = withModifiedState . set psLevel  -- | Similar to 'withInitialNow' but for the @MINIMAL_BLOCK_DELAY@ protocol constant. withMinBlockTime   :: Natural-  -> Scenario PureM-  -> Scenario PureM+  -> Scenario' PureM+  -> Scenario' PureM withMinBlockTime = withModifiedState . set psMinBlockTime  -- | Similar to 'withInitialNow' but for the chain id withChainId   :: TC.ChainId-  -> Scenario PureM-  -> Scenario PureM+  -> Scenario' PureM+  -> Scenario' PureM withChainId = withModifiedState . set (psGState . gsChainIdL)

@@ -23,6 +23,9 @@   , chNiceParameterEvi   , chNiceStorageEvi +  , ToContractAddress (..)+  , ToL1Address (..)+  , ToL1TAddress (..)   , ToStorageType (..)    -- * Conversions

@@ -12,6 +12,7 @@ import Prelude (HasCallStack)  import Test.Cleveland+import Test.Cleveland.Internal.Actions.Transfer  -- | A contract that emits the desired tickets. --@@ -47,14 +48,14 @@  -- | Run a contract indirectly via calling the given ticketer contract. ----- The target contract will recieve a ticket and some payload. The exact+-- The target contract will receive a ticket and some payload. The exact -- structure of the passed argument is determined by the ticketer contract. callViaTicketer   :: forall targetArg payload td targetAddr ticketerParam ticketerAddr m.      ( HasCallStack-     , MonadOps m+     , MonadTransfer m      , ticketerParam ~ View_ (payload, (Natural, td)) targetArg-     , ToTAddress ticketerParam () ticketerAddr+     , ToL1TAddress ticketerParam () ticketerAddr      , ToContractRef targetArg targetAddr      , NiceParameterFull ticketerParam      )@@ -65,5 +66,5 @@   -> payload       -- ^ Main argument passed to the ticketer   -> m () callViaTicketer ticketer ticketAmount ticketData target payload =-  call @ticketerParam @() ticketer CallDefault-    (mkView_ (payload, (ticketAmount, ticketData)) target)+  transfer (toL1TAddress @ticketerParam @() ticketer) $ calling def $+    mkView_ (payload, (ticketAmount, ticketData)) target

@@ -6,7 +6,11 @@   ( ContractHandle (..)   , chNiceParameterEvi   , chNiceStorageEvi+  , L1TAddress (..) +  , ToContractAddress (..)+  , ToL1Address (..)+  , ToL1TAddress (..)   , ToStorageType (..)    , NiceParameter@@ -28,6 +32,8 @@ import Lorentz.Address import Lorentz.Constraints import Morley.Michelson.Typed qualified as T+import Morley.Tezos.Address+import Morley.Tezos.Address.Alias  -- | Handle to a contract. --@@ -40,8 +46,8 @@ data ContractHandle (cp :: Type) (st :: Type) (vd :: Type) =   (NiceParameter cp, NiceStorage st, NiceViewsDescriptor vd) =>   ContractHandle-  { chContractName :: Text-  , chAddress :: Address+  { chContractName :: ContractAlias+  , chAddress :: ContractAddress   }  deriving stock instance Show (ContractHandle cp st vd)@@ -51,7 +57,7 @@     "<handler to '" +| name |+ "' / " +| addr |+ ">"  instance ToAddress (ContractHandle cp st vd) where-  toAddress = chAddress+  toAddress = MkAddress . chAddress  -- TODO [#577]: simplify this instance once fundep in ToTAddress is added instance (cp' ~ cp, vd ~ vd') => ToTAddress cp' vd' (ContractHandle cp st vd) where@@ -70,15 +76,59 @@ chNiceStorageEvi :: forall param st vd. ContractHandle param st vd -> Dict (T.StorageScope $ T.ToT st) chNiceStorageEvi ContractHandle{} = mapDict (niceStorageEvi @st) Dict +class ToContractAddress addr where+  toContractAddress :: addr -> ContractAddress++instance ToContractAddress ContractAddress where+  toContractAddress = id++instance ToContractAddress (ContractHandle cp st vd) where+  toContractAddress = chAddress++class ToL1Address addr where+  toL1Address :: addr -> L1Address++instance ToL1Address (L1TAddress cp vd) where+  toL1Address = unL1TAddress++instance ToL1Address L1Address where+  toL1Address = id++instance L1AddressKind kind => ToL1Address (KindedAddress kind) where+  toL1Address = MkConstrainedAddress++instance ToL1Address (ContractHandle cp st vd) where+  toL1Address = MkConstrainedAddress . chAddress++-- | Counterpart of 'TAddress' that contains 'L1Address' instead of 'Address'.+newtype L1TAddress cp vd = L1TAddress { unL1TAddress :: L1Address }++instance (cp ~ cp', vd ~ vd') => ToTAddress cp' vd' (L1TAddress cp vd) where+  toTAddress = toTAddress . toAddress . unL1TAddress++-- | Counterpart of 'ToTAddress' that converts to 'L1TAddress' rather than+-- 'TAddress'.+class (ToTAddress cp vd addr, ToL1Address addr)+  => ToL1TAddress cp vd addr where+  toL1TAddress :: addr -> L1TAddress cp vd+instance (ToTAddress cp vd addr, ToL1Address addr)+  => ToL1TAddress cp vd addr where+  toL1TAddress = L1TAddress . toL1Address++-- NB: We declare ToL1TAddress as a typeclass for two reasons:+-- one, it defines a constraint synonym, and two, if we were to define+-- toL1Address as a simple function, GHC would complain about+-- ToTAddress being redundant -- it's not though, it constrains the types.+ -- | Declares that @addr@ points to an entity with a storage. -- -- @addr@ may fix storage type or may not - in the latter case the caller -- has to specify the storage type explicitly via type annotation.-class ToAddress addr => ToStorageType st addr where+class ToContractAddress addr => ToStorageType st addr where   -- | Pick proof of that storage type is valid.   pickNiceStorage :: addr -> Dict (NiceStorage st) -instance NiceStorage st => ToStorageType st Address where+instance NiceStorage st => ToStorageType st ContractAddress where   pickNiceStorage _ = Dict  instance (st ~ st') => ToStorageType st' (ContractHandle cp st vd) where

@@ -1,6 +1,5 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA-{-# LANGUAGE InstanceSigs #-}  -- | This module is the internal implementation of "Test.Cleveland.Tasty". module Test.Cleveland.Tasty.Internal@@ -53,10 +52,10 @@  import Morley.Client (MorleyClientConfig(..), mceTezosClientL, mkMorleyClientEnv) import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL)-import Test.Cleveland.Internal.Client as Client-  (ClientM, NetworkEnv(..), neMorleyClientEnvL, runClevelandT)+import Test.Cleveland.Internal.Abstract (NetworkEnv(..), neMorleyClientEnvL)+import Test.Cleveland.Internal.Client as Client (ClientM, runNetworkT) import Test.Cleveland.Internal.Exceptions (WithCallStack(WithCallStack))-import Test.Cleveland.Internal.Pure as Pure (PureM, runClevelandT, runEmulatedT)+import Test.Cleveland.Internal.Pure as Pure (PureM, runEmulatedT) import Test.Cleveland.Internal.Scenario import Test.Cleveland.Tasty.Internal.Options   (ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..), PathOpt(..),@@ -80,11 +79,11 @@ -- -- If a 'TestTree' contains many tests scheduled to run on a real Tezos network, -- those tests will be run sequentially.-testScenario :: TestName -> (forall m. MonadFail m => Scenario m) -> TestTree-testScenario testName scenario' =+testScenario :: TestName -> (forall m. Scenario m) -> TestTree+testScenario testName scenario_ =   testGroup testName-    [ singleTest "On emulator" (RunOnEmulator scenario')-    , singleTest onNetworkTag (RunOnNetwork scenario')+    [ singleTest "On emulator" (RunOnEmulator scenario_)+    , singleTest onNetworkTag (RunOnNetwork scenario_)     ]  -- | Create a tasty test case from an emulated 'Scenario'.@@ -92,29 +91,27 @@ -- This will create a test tree with 1 test, -- which will run the 'Scenario' on the "Morley.Michelson.Runtime" emulator. testScenarioOnEmulator ::  TestName -> Scenario PureM -> TestTree-testScenarioOnEmulator testname scenario' =+testScenarioOnEmulator testname scenario_ =   testGroup testname-    [ singleTest "On emulator" (RunOnEmulator scenario') ]+    [ singleTest "On emulator" (RunOnEmulator scenario_) ]  -- | Create a tasty test case from a 'Scenario'. -- -- This will create a test tree with 1 test, -- which will run the 'Scenario' on real Tezos network. testScenarioOnNetwork ::  TestName -> Scenario ClientM -> TestTree-testScenarioOnNetwork testname scenario' =+testScenarioOnNetwork testname scenario_ =   testGroup testname-    [ singleTest onNetworkTag (RunOnNetwork scenario') ]+    [ singleTest onNetworkTag (RunOnNetwork scenario_) ]  newtype RunOnEmulator = RunOnEmulator (Scenario PureM)  instance IsTest RunOnEmulator where   run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result-  run opts (RunOnEmulator scenario') _ = do+  run opts (RunOnEmulator (ScenarioEmulated emulatedT)) _ = do     let       MoneybagAliasOpt moneybagAlias = lookupOption opts-      io = case scenario' of-              ScenarioCleveland s -> Pure.runClevelandT moneybagAlias s-              ScenarioEmulated s -> Pure.runEmulatedT moneybagAlias s+      io = Pure.runEmulatedT moneybagAlias emulatedT     (io $> testPassed "") `catch` printFormattedException opts    testOptions = Tagged clevelandOptions@@ -123,11 +120,11 @@  instance IsTest RunOnNetwork where   run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result-  run opts (RunOnNetwork (ScenarioCleveland clevelandT)) _ = do+  run opts (RunOnNetwork (ScenarioNetwork clevelandT)) _ = do     let       tastyEnv = tastyEnvFromOpts opts     useNetworkEnv tastyEnv $ \networkEnv -> do-      let io = Client.runClevelandT networkEnv clevelandT+      let io = Client.runNetworkT networkEnv clevelandT       (io $> testPassed "") `catch` printFormattedException opts    -- If a 'RunOnNetwork' test is created somewhere in a suite,

@@ -25,7 +25,7 @@ import Test.Tasty.Options as Tasty (IsOption(..), OptionDescription(Option), safeRead)  import Morley.Client.Parser (baseUrlReader)-import Morley.Tezos.Address.Alias (Alias(..))+import Morley.Tezos.Address.Alias import Morley.Tezos.Crypto qualified as Crypto import Morley.Util.CLI (HasCLReader(getMetavar, getReader)) @@ -134,16 +134,16 @@   parseValue = mkParseValue (SecretKeyOpt . Just)   optionCLParser = mkOptionParser (SecretKeyOpt . Just) Nothing -newtype MoneybagAliasOpt = MoneybagAliasOpt Alias+newtype MoneybagAliasOpt = MoneybagAliasOpt ImplicitAlias   deriving stock (Show, Eq)   instance IsOption MoneybagAliasOpt where-  defaultValue = MoneybagAliasOpt $ Alias "moneybag"+  defaultValue = MoneybagAliasOpt $ ImplicitAlias "moneybag"   optionName = "cleveland-moneybag-alias"   optionHelp = "[Test.Cleveland] Alias of the account to be used to execute all transfers/originations " <>                "(unless overriden with `withSender`) and fund new accounts (unless overriden with `withMoneybag`)."-  parseValue = Just . MoneybagAliasOpt . Alias . fromString+  parseValue = Just . MoneybagAliasOpt . ImplicitAlias . fromString  data RunModeOpt   = RunAllMode

@@ -92,7 +92,7 @@ import Morley.Michelson.Doc (DocItem, docItemPosition) import Morley.Michelson.Typed (SingI, SomeConstrainedValue(..)) import Morley.Michelson.Typed qualified as T-import Morley.Tezos.Address (Address, parseAddressRaw)+import Morley.Tezos.Address  import Test.Cleveland.Instances () 

@@ -15,6 +15,6 @@     test <- newAddress auto     test2 <- newFreshAddress auto -    transferMoney test 1000+    transfer test [tz|1000u|]     comment "new key address is revealed"-    withSender test $ transferMoney test2 1+    withSender test $ transfer test2 [tz|1u|]

@@ -0,0 +1,21 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.BadAddressReuse (test_badAddressReuse) where++import Lorentz qualified as L++import Test.Tasty (TestTree)++import Test.Cleveland+import TestSuite.Util++test_badAddressReuse :: TestTree+test_badAddressReuse =+  testScenario "Bad smart contract address reuse (#729 regression test)" $ scenario do+    _ <- originate "abcdefgh" () $ idContract @() @()++    addr <- newAddress "abcdefgh"++    target <- newAddress "target"+    withSender addr $ transfer target [L.tz|0.1|]

@@ -8,7 +8,7 @@  import Test.Tasty (TestTree) -import Morley.Tezos.Address (Address)+import Morley.Tezos.Address import Morley.Util.SizedList qualified as SL import Morley.Util.SizedList.Types import Test.Cleveland@@ -16,10 +16,10 @@ test_BalanceCheck :: TestTree test_BalanceCheck =   testScenario "An address's balance can be checked" $ scenario do-    test :: Address <- newFreshAddress auto+    test :: ImplicitAddress <- newFreshAddress auto      comment "balance is updated after transfer"-    transferMoney test 100+    transfer test [tz|100u|]     getBalance test @@== 100  test_EmptyBalanceCheck :: TestTree@@ -28,5 +28,5 @@     test ::< dummy ::< Nil' <- traverse newFreshAddress $ SL.replicateT auto      -- Doing something in order not to get "validating empty scenario" error-    transferMoney dummy 1+    transfer dummy [tz|1u|]     getBalance test @@== 0

@@ -7,7 +7,7 @@  import Test.Tasty (TestTree) -import Morley.Tezos.Core (Mutez, mkMutez)+import Morley.Tezos.Core (mkMutez) import Morley.Util.SizedList qualified as SL import Test.Cleveland import Test.Cleveland.Lorentz.Consumer@@ -21,13 +21,13 @@       test1 <- newFreshAddress auto        contract1 <- inBatch $ do-        contract1 <- originateSimple "c" ([] :: [()]) contractConsumer-        transferMoney test1 100+        contract1 <- originate "c" ([] :: [()]) contractConsumer+        transfer test1 [tz|100u|]         return contract1        getBalance test1 @@== 100 -      transferMoney contract1 200+      transfer contract1 [tz|200u|]       getBalance contract1 @@== 200  @@ -35,16 +35,15 @@       addresses <- traverse newFreshAddress $ SL.replicateT @5 auto       let balances = SL.generate $ \i -> unsafeMkMutez' $ (i + 1) * 100 -      inBatch $ do-        for_ (SL.zip addresses balances) $ uncurry transferMoney+      inBatch $ for_ (SL.zip addresses balances) $ uncurry transfer        traverse getBalance addresses @@== balances     , testScenario "Can return multiple values from a batch" $ scenario do       (_contract1, _contract2) <- inBatch $ do-        contract1 <- originateSimple "c1" ([] :: [Integer]) contractConsumer-        contract2 <- originateSimple "c2" ([] :: [Integer]) contractConsumer+        contract1 <- originate "c1" ([] :: [Integer]) contractConsumer+        contract2 <- originate "c2" ([] :: [Integer]) contractConsumer         return (contract1, contract2)        return ()

@@ -23,8 +23,8 @@      comment "balance is updated after batch transfer"     inBatch $ do-      for_ [100, 200] $ transferMoney test1-      transferMoney test2 300+      for_ [100 :: Mutez, 200] $ transfer test1+      transfer test2 [tz|300u|]       return ()      traverse getBalance addrs @@== 300 :< 300 :< Nil@@ -56,12 +56,12 @@ test_BatchTransferLeapingCosts :: TestTree test_BatchTransferLeapingCosts =   testScenario "Check fees evaluation correctness for leaping transfer costs" $ scenario do-    contract <- originateSimple "contract" [] (leapingContract @L.MText)+    contract <- originate "contract" [] (leapingContract @L.MText)      comment "Perform batch transfer, second transaction should have much \             \higher cost with respect to the first one"     inBatch $-      for_ ["a", "b"] $ call contract CallDefault+      for_ ["a", "b"] $ transfer contract . calling def      comment "Sanity check on storage"     getStorage contract @@==

@@ -25,7 +25,7 @@   testScenario "Bytestrings can be signed" $ scenario do     dummy :< signer :< Nil <- traverse newFreshAddress $ "user" :< "signer" :< Nil -    helper <- originateSimple "helper" () checkSignatureContract+    helper <- originate "helper" () checkSignatureContract      let bytes = "some bytestring" @@ -34,5 +34,5 @@     dummyPK <- getPublicKey dummy      expectFailedWith [L.mt|Invalid signature|] $-      call helper CallDefault (dummyPK, (sig, bytes))-    call helper CallDefault (signerPK, (sig, bytes))+      transfer helper $ calling def (dummyPK, (sig, bytes))+    transfer helper $ calling def (signerPK, (sig, bytes))

@@ -30,8 +30,8 @@ import Morley.Client (TezosClientError(EConnreset), mceClientEnvL, mceTezosClientL) import Morley.Client.TezosClient (tceEndpointUrlL) import Morley.Michelson.Typed (convertContract, untypeValue)-import Morley.Tezos.Address (ta)-import Morley.Util.Interpolate (lit)+import Morley.Tezos.Address+import Morley.Util.Interpolate (it, lit) import Morley.Util.SizedList.Types import Test.Cleveland import Test.Cleveland.Internal.Client (neMorleyClientEnvL)@@ -159,94 +159,63 @@         do           void $ signBinary @ByteString "" invalidAddr -    , testFailureIncludesCallStack "callstack points to originateUntyped"-        [lit|-          void $ originateUntyped UntypedOriginateData-            { uodName = ""-            , uodBalance = 0-            , uodStorage = untypeValue $ toVal @Natural 3-            , uodContract = convertContract $ toMichelsonContract @() @() idContract-            }-            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-        |]-        do-          -- force a failure by using a storage of the wrong type-          void $ originateUntyped UntypedOriginateData-            { uodName = ""-            , uodBalance = 0-            , uodStorage = untypeValue $ toVal @Natural 3-            , uodContract = convertContract $ toMichelsonContract @() @() idContract-            }--    , testFailureIncludesCallStack "callstack points to originateUntypedSimple"+    , testFailureIncludesCallStack "callstack points to originate with untyped"         [lit|-          void $ originateUntypedSimple ""+          void $ originate ""             (untypeValue $ toVal @Natural 3)             (convertContract $ toMichelsonContract @() @() idContract)             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^         |]         do           -- force a failure by using a storage of the wrong type-          void $ originateUntypedSimple ""+          void $ originate ""             (untypeValue $ toVal @Natural 3)             (convertContract $ toMichelsonContract @() @() idContract) -    , testFailureIncludesCallStack "callstack points to originate"+    , testFailureIncludesCallStack "callstack points to originate with lorentz"         [lit|-          void $ originate OriginateData-            { odName = ""-            , odBalance = maxBound-            , odStorage = ()-            , odContract = idContract @() @()-            }-            ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          void $ originate+            ""+            ()+            (idContract @() @())+            (maxBound :: Mutez)+            ^^^^^^^^^^^^^^^^^^^^         |]         do           -- force a failure by transfering `maxBound` mutez-          void $ originate OriginateData-            { odName = ""-            , odBalance = maxBound-            , odStorage = ()-            , odContract = idContract @() @()-            }+          void $ originate+            ""+            ()+            (idContract @() @())+            (maxBound :: Mutez)      , testFailureIncludesCallStack "callstack points to transfer"         [lit|-          transfer TransferData-            { tdTo = invalidAddr-            , tdAmount = 0-            , tdEntrypoint = DefEpName-            , tdParameter = ()-            }-          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          transfer invalidAddr+          ^^^^^^^^^^^^^^^^^^^^         |]         do           -- force a failure by transfering from an unknown alias-          transfer TransferData-            { tdTo = invalidAddr-            , tdAmount = 0-            , tdEntrypoint = DefEpName-            , tdParameter = ()-            }+          transfer invalidAddr      , testFailureIncludesCallStack "callstack points to transferMoney"-        [lit|-          transferMoney invalidAddr 1-          ^^^^^^^^^^^^^^^^^^^^^^^^^^^+        [it|+          transfer invalidAddr [tz|1u|\&]+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^         |]         do           -- force a failure by transfering from an unknown address-          transferMoney invalidAddr 1+          transfer invalidAddr [tz|1u|]             & withSender invalidAddr      , testFailureIncludesCallStack "callstack points to call"         [lit|-          call invalidTAddr CallDefault ()-          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          transfer invalidTAddr+          ^^^^^^^^^^^^^^^^^^^^^         |]         do           -- force a failure by transfering to an unknown address-          call invalidTAddr CallDefault ()+          transfer invalidTAddr      , testFailureIncludesCallStack "callstack points to inBatch for batched transfers"         [lit|@@ -256,8 +225,8 @@         do           -- force a failure by transfering to an unknown address           inBatch $ do-            call (TAddress @() invalidAddr) CallDefault ()-            call (TAddress @() invalidAddr) CallDefault ()+            transfer invalidAddr+            transfer invalidAddr             return ()      , testFailureIncludesCallStack "callstack points to importUntypedContract"@@ -327,8 +296,8 @@           ^^^^^^^^^^^^^^^^^^^^^^^^         |]         do-          addr <- originateSimple "" () contractFailWith1-          err <- catchTransferFailure $ call addr CallDefault ()+          addr <- originate "" () contractFailWith1+          err <- catchTransferFailure $ transfer addr           checkTransferFailure err $ failedWith (constant @Natural 2)      , testGroup "expectTransferFailure" $@@ -356,8 +325,8 @@                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^           |]           do-            addr <- originateSimple "" () contractFailWith1-            call addr CallDefault ()+            addr <- originate "" () contractFailWith1+            transfer addr               & expectTransferFailure (failedWith (constant @Natural 2))       ] @@ -411,27 +380,27 @@      , testFailureIncludesCallStack "callstack points to getStorage"         [lit|-          void $ getStorage @() invalidAddr-                 ^^^^^^^^^^^^^^^^^^^^^^^^^^+          void $ getStorage @() invalidContractAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^         |]         do-          void $ getStorage @() invalidAddr+          void $ getStorage @() invalidContractAddr      , testFailureIncludesCallStackOnEmulator "callstack points to getFullStorage on emulator"         [lit|-          void $ getFullStorage @() invalidAddr-                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+          void $ getFullStorage @() invalidContractAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^         |]         do-          void $ getFullStorage @() invalidAddr+          void $ getFullStorage @() invalidContractAddr      , testFailureIncludesCallStackOnEmulator "callstack points to getSomeStorage on emulator"         [lit|-          void $ getSomeStorage invalidAddr-                 ^^^^^^^^^^^^^^^^^^^^^^^^^^+          void $ getSomeStorage invalidContractAddr+                 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^         |]         do-          void $ getSomeStorage invalidAddr+          void $ getSomeStorage invalidContractAddr      , sabotageNetworkEnv $         testFailureIncludesCallStackOnNetwork "callstack points to getBigMapValueMaybe"@@ -504,8 +473,8 @@           void $ runCode RunCode             { rcContract =                 L.defaultContract @() @() $ L.failUsing @MText "Contract should fail"-            , rcStorage = NotRPC ()-            , rcParameter = NotRPC ()+            , rcStorage = untypeValue $ toVal ()+            , rcParameter = untypeValue $ toVal ()             , rcAmount = 0             , rcBalance = 0             , rcSource = Nothing@@ -518,8 +487,8 @@           void $ runCode RunCode             { rcContract =                 L.defaultContract @() @() $ L.failUsing @MText "Contract should fail"-            , rcStorage = NotRPC ()-            , rcParameter = NotRPC ()+            , rcStorage = untypeValue $ toVal ()+            , rcParameter = untypeValue $ toVal ()             , rcAmount = 0             , rcBalance = 0             , rcSource = Nothing@@ -529,16 +498,16 @@     , testFailureIncludesCallStackOnEmulator         "when a branchout branch throws, the callstack points to the function inside the branch"         [lit|-                  getStorage @() invalidAddr-                  ^^^^^^^^^^^^^^^^^^^^^^^^^^+                  getStorage @() invalidContractAddr+                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^                   | In 'a' branch:-                  | Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC+                  | Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye         |]         do           branchout             [ "a" ?-                 void $-                  getStorage @() invalidAddr+                  getStorage @() invalidContractAddr             ]     , testFailureIncludesCallStackOnEmulator         "when a branchout branch throws ANY exception, the exception raised is printed in a right way"@@ -558,16 +527,16 @@     , testFailureIncludesCallStackOnEmulator         "when offshoot throws, the callstack points to the function inside offshoot"         [lit|-              getStorage @() invalidAddr-              ^^^^^^^^^^^^^^^^^^^^^^^^^^+              getStorage @() invalidContractAddr+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^               | In 'a' branch:-              | Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC+              | Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye          |]         do           offshoot "a" $             void $-              getStorage @() invalidAddr+              getStorage @() invalidContractAddr      , testFailureIncludesCallStack "callstack points to failure"         [lit|@@ -694,9 +663,11 @@     ]    where+    invalidAlias :: ContractAlias     invalidAlias = "UnknownAlias"     invalidAddr = [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|]-    invalidTAddr = TAddress @() invalidAddr+    invalidContractAddr = ContractAddress $ mkContractHashHack "asdf"+    invalidTAddr = ContractHandle @() @() @() "asdf" invalidContractAddr  test_callStack_property :: TestTree test_callStack_property =

@@ -22,8 +22,8 @@ test_ChainIdGet :: TestTree test_ChainIdGet =   testScenario "ChainId is retrievable" $ scenario do-    helperAddr <- originateSimple "helper" (#storage :! dummyChainId) checkChainIdContract+    helperAddr <- originate "helper" (#storage :! dummyChainId) checkChainIdContract      chainId <- getChainId-    call helperAddr CallDefault ()+    transfer helperAddr     getStorage helperAddr @@== #storage :! chainId

@@ -7,7 +7,7 @@  import Test.Tasty (TestTree) -import Morley.Tezos.Address (Address)+import Morley.Tezos.Address import Morley.Util.Named import Test.Cleveland @@ -16,15 +16,8 @@ test_ContractAllocation :: TestTree test_ContractAllocation =   testScenario "Contracts can be allocated and called" $ scenario do-    addresses :: [Address] <- replicateM 10 $ newFreshAddress auto-    let-      od = OriginateData-        { odName = "allocator"-        , odStorage = #storage :! (take 570 $ cycle addresses)-        , odBalance = 25-        , odContract = allocatorContract-        }--    allocatorAddr <- originate od+    addresses :: [Address] <- replicateM 10 $ toAddress <$> newFreshAddress auto+    let storage = #storage :! (take 570 $ cycle addresses)+    allocatorAddr <- originate "allocator" storage allocatorContract [tz|25micro|] -    call allocatorAddr CallDefault (take 25 $ cycle addresses)+    transfer allocatorAddr $ calling def (take 25 $ cycle addresses)

@@ -10,7 +10,6 @@ import Lorentz.Address import Lorentz.Entrypoints import Morley.Michelson.Typed qualified as T-import Morley.Tezos.Core (Mutez) import Test.Cleveland import TestSuite.Util.Contracts (inContractsDir) @@ -51,16 +50,11 @@   --    balance   [ testScenario "Operations are performed in DFS order" $ scenario do       transferAllAddr <--        importContract (inContractsDir "transfer_all.tz")-        >>= originateSimple @TransferAllParameter "transfer_all" () . noViews+        importContract @TransferAllParameter (inContractsDir "transfer_all.tz")+        >>= originate "transfer_all" () . noViews       transferAllCallerAddr <--        importContract (inContractsDir "transfer_all_caller.tz")-        >>= originateSimple @TransferAllCallerParameter "transfer_all_caller" () . noViews-      transfer $ TransferData-        { tdTo = transferAllAddr-        , tdAmount = 100-        , tdEntrypoint = ep "receiveXtz"-        , tdParameter = ()-        } -- transferAllAddr 100-      call transferAllCallerAddr (Call @"CallCPS") (toTAddress transferAllAddr)+        importContract @TransferAllCallerParameter (inContractsDir "transfer_all_caller.tz")+        >>= originate "transfer_all_caller" () . noViews+      transfer transferAllAddr [tz|100u|] $ calling (ep @"ReceiveXtz") ()+      transfer transferAllCallerAddr $ calling (ep @"CallCPS") $ toTAddress transferAllAddr   ]

@@ -0,0 +1,62 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.EmitMachinery+  ( test_SimpleEmit+  , test_InferredEmit+  , test_MultipleEmit+  ) where++import Fmt (pretty)+import Test.Tasty (TestTree)++import Lorentz (Contract)+import Test.Cleveland+import Test.Cleveland.Lorentz (embedContract)+import TestSuite.Util.Contracts++test_SimpleEmit :: TestTree+test_SimpleEmit =+  testScenario "transferWithEmit works on simple emit" $ scenario do+    simpleEmit <- originate "simple_emit" () contract+    [ContractEvent{..}] <- transfer simpleEmit WithContractEvents $ calling def ()+    pretty cePayload @== ("Right \"right\" :: or (nat %int) (string %str)" :: Text)+    toAddress ceSource @== toAddress simpleEmit+    ceTag @== "notify_client"+  where+    contract :: Contract () () ()+    contract = $$(embedContract (inContractsDir "simple_emit.tz"))++test_InferredEmit :: TestTree+test_InferredEmit =+  testScenario " on WithContractEvents inferred emit" $ scenario do+    inferredEmit <- originate "inferred_emit" () contract+    [ContractEvent{..}] <- transfer inferredEmit WithContractEvents $ calling def ()+    pretty cePayload @== ("Right \"right\" :: or nat string" :: Text)+    toAddress ceSource @== toAddress inferredEmit+    ceTag @== ""+  where+    contract :: Contract () () ()+    contract = $$(embedContract (inContractsDir "inferred_emit.tz"))++test_MultipleEmit :: TestTree+test_MultipleEmit =+  testScenario "transferWithEmit works on multiple emit" $ scenario do+    multipleEmit <- originate "multiple_emit" () contract+    evs <- transfer multipleEmit WithContractEvents $ calling def ()+    length evs @== 4+    let expected =+          [("one", Just "Right \"right\" :: or nat string")+          ,("two", Just "Left 123 :: or nat string")+          ,("three", Just "False :: bool")+          ,("four", Nothing)]+        check ContractEvent{..} (tag, ty) = do+          pretty <$> cePayload @== (ty :: Maybe Text)+          toAddress ceSource @== toAddress multipleEmit+          ceTag @== tag+    -- events are CONS'ed in the contract and hence end up reversed;+    -- the expectation is reversed here to simplify reasoning a bit.+    zipWithM_ check evs $ reverse expected+  where+    contract :: Contract () () ()+    contract = $$(embedContract (inContractsDir "multiple_emit.tz"))

@@ -17,8 +17,8 @@ test_EmptyImplicitAddressCalls =   testScenario "Calling a contract with empty implicit address fails" $ scenario do     addr <- newFreshAddress auto-    contract <- originateSimple "contract" () $ idContract @() @()-    call contract CallDefault ()+    contract <- originate "contract" () $ idContract @() @()+    transfer contract (calling def ())       & withSender addr       & shouldFailWithMessage "Empty implicit contract" @@ -27,6 +27,6 @@   testScenario "Transferring from empty implicit address fails" $ scenario do     addr <- newFreshAddress auto     recvr <- newAddress auto-    transferMoney recvr 0+    transfer recvr [tz|0|]       & withSender addr       & shouldFailWithMessage "Empty implicit contract"

@@ -23,7 +23,7 @@      , testScenarioOnEmulator "fails if any branch fails" $ scenarioEmulated do         addr <- newAddress auto-        let branchA = "a" ?- transferMoney addr 0+        let branchA = "a" ?- transfer addr [tz|0u|]         let branchB = "b" ?- pass         branchout [branchA, branchB] & expectTransferFailure emptyTransaction         branchout [branchB, branchA] & expectTransferFailure emptyTransaction@@ -33,10 +33,10 @@         initialBalance <- getBalance test         branchout           [ "a" ?- do-              transferMoney test 2+              transfer test [tz|2u|]               getBalance test @@== initialBalance + 2           , "b" ?- do-              transferMoney test 3+              transfer test [tz|3u|]               getBalance test @@== initialBalance + 3           ] @@ -44,26 +44,26 @@         test <- newAddress auto         initialBalance <- getBalance test         branchout-          [ "a" ?- transferMoney test 3 ]+          [ "a" ?- transfer test [tz|3u|] ]         getBalance test @@== initialBalance      , testScenarioOnEmulator "adds branch name to error" $ scenarioEmulated do         branchout           [ "<branch name>" ?- void $-              signBytes "" (unsafe $ parseAddress "tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM")+              signBytes "" [ta|tz1Zpj6cNhkVkvksGtRTwTrgfCG3WP9eA5BM|]           ]           & shouldFailWithMessage "<branch name>"     ]   , testGroup "offshoot"     [ testScenarioOnEmulator "fails if inner scenario fails" $ scenarioEmulated do         addr <- newAddress auto-        offshoot "a" (transferMoney addr 0)+        offshoot "a" (transfer addr [tz|0u|])           & expectTransferFailure emptyTransaction      , testScenarioOnEmulator "offshoot's effects are discarded" $ scenarioEmulated do         test <- newAddress auto         initialBalance <- getBalance test-        offshoot "a" $ transferMoney test 1+        offshoot "a" $ transfer test [tz|1u|]         getBalance test @@== initialBalance     ]   ]

@@ -0,0 +1,18 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.ErrorMessages+  ( test_error_message_shows_contract_alias+  ) where++import Lorentz as L+import Test.Cleveland+import Test.Tasty (TestTree)+import TestSuite.Util (shouldFailWithMessage)++test_error_message_shows_contract_alias :: TestTree+test_error_message_shows_contract_alias =+  testScenarioOnEmulator "Error message shows contract alias" $ scenario do+    ch <- originate "my-contract-alias" () $ L.defaultContract @() @() $ L.car # L.failWith+    shouldFailWithMessage "(my-contract-alias) failed with: Unit" do+      transfer ch

@@ -21,13 +21,13 @@  import Morley.Micheline (toExpression) import Morley.Michelson.Runtime.GState (genesisAddress1)-import Morley.Tezos.Address (parseAddress)+import Morley.Tezos.Address (ConstrainedAddress(..), ta) import Morley.Tezos.Core (parseChainId) import Morley.Util.Interpolate (i) import Test.Cleveland import Test.Cleveland.Internal.Abstract-  (ExpressionOrTypedValue(..), FailedInBranch(..), GenericTestError(..), TransferFailure(..),-  TransferFailureReason(..))+  (AddressAndAlias(..), ExpressionOrTypedValue(..), FailedInBranch(..), GenericTestError(..),+  TransferFailure(..), TransferFailureReason(..)) import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..)) import Test.Cleveland.Internal.Exceptions (WithCallStack(..)) import Test.Cleveland.Internal.Pure (emptyScenarioBranch)@@ -38,93 +38,81 @@ test_CatchExceptions =   testScenario "catches exceptions" $ scenario do     validAddr <- newAddress auto-    contractAddr <- originate OriginateData-      { odName = "test catchTransferFailure"-      , odStorage = ()-      , odBalance = 1-      , odContract = defaultContract testContractCode-      }+    contractAddr <- originate+      "test catchTransferFailure"+      ()+      (defaultContract testContractCode)+      [tz|1u|]      let (testContractWithNumericErrors, errorTagMap) = useNumericErrors testContractCode-    contractNumericAddr <- originate OriginateData-      { odName = "test catchTransferFailure numeric errors"-      , odStorage = ()-      , odBalance = 1-      , odContract = defaultContract testContractWithNumericErrors-      }+    contractNumericAddr <- originate+      "test catchTransferFailure numeric errors"+      ()+      (defaultContract testContractWithNumericErrors)+      [tz|1u|] -    attempt (call contractAddr (Call @"TriggerFailWith") ()) >>= \case+    attempt (transfer contractAddr $ calling (ep @"TriggerFailWith") ()) >>= \case       Left err -> checkTransferFailure err $ failedWith (constant [mt|oops|])       Right _ -> failure "Expected contract to fail"      catchTransferFailure $-      call contractAddr (Call @"TriggerFailWith") ()+      transfer contractAddr $ calling (ep @"TriggerFailWith") ()      expectTransferFailure (failedWith (constant [mt|oops|])) $-      call contractAddr (Call @"TriggerFailWith") ()+      transfer contractAddr $ calling (ep @"TriggerFailWith") ()      expectTransferFailure (failedWith (constant [mt|oops|]) && addressIs contractAddr) $-      call contractAddr (Call @"TriggerFailWith") ()+      transfer contractAddr $ calling (ep @"TriggerFailWith") ()      expectFailedWith [mt|oops|] $-      call contractAddr (Call @"TriggerFailWith") ()+      transfer contractAddr $ calling (ep @"TriggerFailWith") ()      expectError (VoidResult False) $-      call contractAddr (Call @"VoidEP") (mkVoid True)+      transfer contractAddr $ calling (ep @"VoidEP") (mkVoid True)      expectTransferFailure (failedWith $ constant (1 :: Natural, (2 :: Natural, 3 :: Natural)))  $-      call contractAddr (Call @"TriggerFailWithRightCombedPair") ()+      transfer contractAddr $ calling (ep @"TriggerFailWithRightCombedPair") ()      -- Check that string and bytes forms of 'chain_id' are equal if they are     -- used as error argument.     let c = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t"     expectTransferFailure       (failedWith (constant @ChainId c)) $-        call contractAddr (Call @"TriggerFailWithChainIdStr") ()+        transfer contractAddr $ calling (ep @"TriggerFailWithChainIdStr") ()      expectTransferFailure       (failedWith (constant @ChainId c)) $-        call contractAddr (Call @"TriggerFailWithChainIdBytes") ()+        transfer contractAddr $ calling (ep @"TriggerFailWithChainIdBytes") ()      expectCustomError #customError 1 $-      call contractAddr (Call @"TriggerFailWithCustomError") ()+      transfer contractAddr $ calling (ep @"TriggerFailWithCustomError") ()      expectCustomError_ #customErrorUnit1 $-      call contractAddr (Call @"TriggerFailWithCustomErrorUnit1") ()+      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit1") ()      expectCustomError_ #customErrorUnit2 $-      call contractAddr (Call @"TriggerFailWithCustomErrorUnit2") ()+      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit2") ()      expectCustomErrorNoArg #customErrorNoArg $-      call contractAddr (Call @"TriggerFailWithCustomErrorNoArg") ()+      transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") ()      expectNumericError errorTagMap (VoidResult False) $-      call contractNumericAddr (Call @"VoidEP") (mkVoid True)+      transfer contractNumericAddr $ calling (ep @"VoidEP") $ mkVoid True      expectTransferFailure shiftOverflow $-      call contractAddr (Call @"TriggerShiftOverflow") ()+      transfer contractAddr $ calling (ep @"TriggerShiftOverflow") ()      expectTransferFailure gasExhaustion $-      call contractAddr (Call @"TriggerGasExhaustion") ()+      transfer contractAddr $ calling (ep @"TriggerGasExhaustion") ()      expectTransferFailure emptyTransaction $-      transferMoney validAddr 0+      transfer validAddr [tz|0u|]      expectTransferFailure badParameter $-      transfer TransferData-        { tdTo = contractAddr-        , tdAmount = 0-        , tdEntrypoint = ep "expectAddress"-        , tdParameter = [mt|aa|]-        }+      transfer contractAddr $ unsafeCalling #expectAddress [mt|aa|]      expectTransferFailure badParameter $-      transfer TransferData-        { tdTo = contractAddr-        , tdAmount = 0-        , tdEntrypoint = ep "expectAddress"-        , tdParameter = (1 :: Natural)-        }+      transfer contractAddr $ unsafeCalling #expectAddress @Natural 1      -- check that an action throws one of many errors.     let expectedErrs =@@ -132,7 +120,7 @@           failedWith (constant @MText "oops") ||           failedWith (customError #customError 1) -    call contractAddr (Call @"TriggerFailWithCustomError") () &+    transfer contractAddr (calling (ep @"TriggerFailWithCustomError") ()) &       expectTransferFailure expectedErrs  test_FailsIfTheGivenActionDoesNotThrow :: TestTree@@ -150,7 +138,7 @@                 FailedInBranch emptyScenarioBranch $ SomeException $                   WithCallStack callStack $ SomeException $                     FailedInBranch emptyScenarioBranch $ SomeException $-                      TransferFailure (unsafe $ parseAddress "tz1fsFpWk691ncq1xwS62dbotECB67B13gfC") BadParameter+                      TransferFailure (AddressAndAlias (MkAddress [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|]) Nothing) BadParameter      res <- attempt @TransferFailure action @@ -314,12 +302,12 @@  impl_test_AndPredicate_succeeds_if_all_conditions_hold conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing     checkTransferFailure err $ failedWith (constant @Integer 1) && addressIs genesisAddress1  impl_test_OrPredicate_succeeds_if_any_condition_holds conv =   testScenario "AndPredicate succeeds if any condition holds" $ scenario do-    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing     checkTransferFailure err $       failedWith (constant @Integer 1) ||       failedWith (constant @Integer 2) ||@@ -327,7 +315,7 @@  impl_test_AndPredicate_fails_if_any_condition_fails conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( failedWith (constant @Integer 1) &&@@ -349,7 +337,7 @@  impl_test_OrPredicate_fails_if_all_conditions_fail conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( failedWith (constant @Integer 2) ||@@ -373,7 +361,7 @@  impl_test_checkTransferFailure_shows_only_failing_predicates conv =   testScenario "checkTransferFailure shows only failing predicates" $ scenario do-    let err = TransferFailure genesisAddress1 $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( (failedWith (constant @Integer 1) && failedWith (constant @Integer 2)) &&

@@ -15,19 +15,19 @@ test_FailureLogs :: TestTree test_FailureLogs =   testScenarioOnEmulator "Can get logs even on scenario failure" $ scenarioEmulated do-    contractAddr <- originateSimple "test catchTransferFailure" () testContract+    contractAddr <- originate "test catchTransferFailure" () testContract      (logs1, result1) <- fmap (first collectLogs) . getMorleyLogs $ try @_ @SomeException do-      call contractAddr L.CallDefault 0-      call contractAddr L.CallDefault 1+      transfer contractAddr $ calling def 0+      transfer contractAddr $ calling def 1       failure "some failure"     assert (isLeft result1) "result1 should be Left"     unMorleyLogs logs1 @== ["One", "Two", "Three", "Four", "One", "Two"]      (logs2, result2) <- fmap (first collectLogs) . getMorleyLogs $ try @_ @SomeException do-      call contractAddr L.CallDefault 0+      transfer contractAddr $ calling def 0       failure "some failure"-      call contractAddr L.CallDefault 1+      transfer contractAddr $ calling def 1     assert (isLeft result2) "result2 should be Left"     unMorleyLogs logs2 @== ["One", "Two", "Three", "Four"] 

@@ -15,7 +15,7 @@  import Test.Tasty (TestTree) -import Lorentz.Value (Address, Mutez)+import Lorentz.Value (Address) import Morley.Tezos.Address (ta) import Test.Cleveland import Test.Cleveland.Lorentz (embedContract, embedValue, importValue)@@ -23,19 +23,19 @@ test_Import :: [TestTree] test_Import =   [ testScenario "Can embed a contract" $ scenario do-      contract <- originateSimple "basic1" []+      contract <- originate "basic1" []         $$(embedContract @() @[Integer] @() "../../contracts/basic1.tz") -      call contract CallDefault ()+      transfer contract   ]  test_Embed :: [TestTree] test_Embed =   [ testScenario "Can embed a contract" $ scenario do       contractCode <- importContract @() @[Integer] @() "../../contracts/basic1.tz"-      contract <- originateSimple "basic1" [] contractCode+      contract <- originate "basic1" [] contractCode -      call contract CallDefault ()+      transfer contract   ]  test_ImportInt :: [TestTree]@@ -59,7 +59,7 @@   [ testScenarioOnEmulator "Can import an address value" $ scenario do       value <- runIO $ importValue @Address "./test/fixtures/addrValue.txt" -      value @== [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|]+      value @== toAddress [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|]   ]  test_EmbedAddress :: [TestTree]@@ -67,7 +67,7 @@   [ testScenarioOnEmulator "Can embed an address value" $ scenario do       let value = $$(embedValue @Address "./test/fixtures/addrValue.txt") -      value @== [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|]+      value @== toAddress [ta|tz1Se5MhFNJdPrur2iNwC3nCLvYzr1y9TsZp|]   ]  test_ImportMutez :: [TestTree]

@@ -0,0 +1,18 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.NetworkCaps+  ( test_network_caps+  ) where++import Test.Tasty (TestTree)++import Morley.Client qualified as Client+import Test.Cleveland++test_network_caps :: TestTree+test_network_caps = testScenarioOnNetwork "Network scenario can get NetworkEnv" $ scenarioNetwork do+  env <- getMorleyClientEnv+  chainID <- getChainId+  chainID' <- runIO $ Client.runMorleyClientM env Client.getChainId+  chainID @== chainID'

@@ -36,7 +36,7 @@         (toRemain, _) = balance `divModMutezInt` (5 :: Int) ?: error "Bad div"         toSpend = balance - toRemain -      transferMoney test2 toSpend+      transfer test2 toSpend         & withSender test        balance2 <- getBalance test

@@ -16,16 +16,16 @@ test_replayTransfer_fails :: TestTree test_replayTransfer_fails =   testScenarioOnEmulator "Transfer operation replay is prohibited" $ scenarioEmulated do-    dummyAddress <- chAddress <$> originateSimple @() @() "dummy" () idContract+    dummyAddress <- toAddress . chAddress <$> originate "dummy" () (idContract @() @())     contract <- importContract @Address @() @() (contractsDir </> "replay_transfer.tz")-    replayTransfer <- originateSimple "replayTransfer" () contract-    call replayTransfer CallDefault dummyAddress+    replayTransfer <- originate "replayTransfer" () contract+    transfer replayTransfer (calling def dummyAddress)       & shouldFailWithMessage "Operation replay attempt"  test_replayOrigination_fails :: TestTree test_replayOrigination_fails =   testScenarioOnEmulator "Origination operation replay is prohibited" $ scenarioEmulated do     contract <- importContract @() @() @() (contractsDir </> "replay_origination.tz")-    replayOrigination <- originateSimple "replayOrigination" () contract-    call replayOrigination CallDefault ()+    replayOrigination <- originate "replayOrigination" () contract+    transfer replayOrigination       & shouldFailWithMessage "Operation replay attempt"

@@ -16,10 +16,10 @@ test_PrettyFailWith :: TestTree test_PrettyFailWith = testScenarioOnEmulator "FailWith shows its argument using human-readable representation" $ scenarioEmulated do   addr <- newFreshAddress auto-  transferMoney addr 1 -- need at least some money to call+  transfer addr [tz|1u|] -- need at least some money to call   withSender addr do-    cont <- originateSimple "failing" () failing-    call cont CallDefault () &+    cont <- originate "failing" () failing+    transfer cont &       shouldFailWithMessage (fmt $ "failed with: \"" +| addr |+ "\"")  failing :: Contract () () ()

@@ -14,6 +14,7 @@ import Unsafe qualified (fromJust)  import Lorentz as L hiding (comment)+import Morley.Tezos.Address import Test.Cleveland import Test.Cleveland.Instances () import Test.Cleveland.Internal.Abstract (SpecificOrDefaultAlias(..))@@ -33,16 +34,13 @@   testProperty "The address is calculated correctly from the given public key" $     withTests 200 $ property $ do       alias <- fromString <$> (forAll $ Gen.string (Range.linear 0 100) Gen.unicode)-      testScenarioProps $ scenario $ scenario' alias--scenario' :: (MonadCleveland caps m) => Alias -> m ()-scenario' alias = do-  c <- originateSimple @PublicKey @(Maybe Address) "publicKeyToAddress" Nothing publicKeyToAddress+      testScenarioProps $ scenario do+        c <- originate "publicKeyToAddress" Nothing publicKeyToAddress -  addr1 <- newAddress $ SpecificAlias alias-  addr1pk <- getPublicKey addr1+        addr1 <- newAddress $ SpecificAlias alias+        addr1pk <- getPublicKey addr1 -  call c CallDefault addr1pk-  addr2 <- Unsafe.fromJust <$> getStorage @(Maybe Address) c+        transfer c $ calling def addr1pk+        addr2 <- Unsafe.fromJust <$> getStorage @(Maybe Address) c -  addr1 @== addr2+        MkAddress addr1 @== addr2

@@ -27,7 +27,7 @@       balanceSender <- getBalance refillableAddr        withSender refillableAddr do-        transferMoney receiver (balanceSender + 1000) -- obviously more than sender has+        transfer receiver (balanceSender + 1000) -- obviously more than sender has        getBalance receiver @@== (balanceSender + 1000)   , testScenario "A refillable address refills when transfer amount == balance - 1 μtz" $ scenario do@@ -37,7 +37,7 @@       balanceSender <- getBalance refillableAddr        withSender refillableAddr do-        transferMoney receiver (balanceSender - 1) -- also would fail without auto-refill, due to fees+        transfer receiver (balanceSender - 1) -- also would fail without auto-refill, due to fees         -- NOTE: the test crashes currently when transfer amount = balance; it seems like a         -- bug in the local chain code. Theoretically, this test should work either way. @@ -48,12 +48,7 @@       -- storage burn should be at least >= 1 XTZ due to the contract size       -- however, since 'refillableAddr' has at least 0.5 XTZ after 'refillable'       -- we also transfer 0.5 XTZ to the contract; this ensures we're overbudget.-      void $ withSender refillableAddr $ originate $ OriginateData-        { odName = "so_big"-        , odBalance = 0.5e6-        , odContract = soBigContract-        , odStorage = ()-        }+      void $ withSender refillableAddr $ originate "so_big" () soBigContract [tz|0.5|]   ]  test_AddressDoesntRefill :: [TestTree]@@ -72,17 +67,17 @@   nonRefillable ::< receiver ::< Nil' <- traverse newFreshAddress $ SL.replicateT auto    -- needed to reveal `nonRefillable`-  transferMoney nonRefillable 1+  transfer nonRefillable [tz|1u|]    shouldFailWithMessage errorMsg $-    withSender nonRefillable $ transferMoney receiver 100+    withSender nonRefillable $ transfer receiver [tz|100u|]  test_RefillFailure :: TestTree test_RefillFailure = testScenario "Refill should succeed even if moneybag can't make the call"   $ scenario do     owner <- refillable $ newFreshAddress "owner"-    transferMoney owner 400 -- a little more than revelation fee to avoid empty_implicit_contract-    contract <- originateSimple @() @L.Address @() "contract" owner $ L.defaultContract $+    transfer owner [tz|400u|] -- a little more than revelation fee to avoid empty_implicit_contract+    contract <- originate "contract" (L.toAddress owner) $ L.defaultContract @() @L.Address $           L.cdr       L.# L.dup       L.# L.sender@@ -90,7 +85,7 @@         (L.nil L.# L.pair)         (L.push @L.MText "Sender is not owner" L.# L.failWith)     balance1 <- getBalance owner-    withSender owner $ call contract CallDefault ()+    withSender owner $ transfer contract     balance2 <- getBalance owner     -- check that owner was in fact refilled     checkCompares balance1 (<=) balance2

@@ -0,0 +1,28 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.ResolveAddress+  ( test_resolves_address_of_contract+  , test_resolves_address_of_implicit_account+  ) where++import Test.Tasty (TestTree)++import Test.Cleveland+import Test.Cleveland.Internal.Abstract (SpecificOrDefaultAlias(SpecificAlias))+import Test.Cleveland.Lorentz.Types (toContractAddress)+import TestSuite.Util (idContract)++test_resolves_address_of_contract :: TestTree+test_resolves_address_of_contract =+  testScenario "Resolves address of contract" $ scenario do+    let alias = "contract-test-1"+    expectedAddress <- toContractAddress <$> originate alias () (idContract @() @())+    resolveAddress alias @@== expectedAddress++test_resolves_address_of_implicit_account :: TestTree+test_resolves_address_of_implicit_account =+  testScenario "Resolves address of implicit account" $ scenario do+    let alias = "contract-test-1"+    expectedAddress <- newAddress $ SpecificAlias alias+    resolveAddress alias @@== expectedAddress

@@ -4,12 +4,13 @@ -- Disable the warning generated by the `L.source` instruction. {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE OverloadedLists #-}+ module TestSuite.Cleveland.RunCode   ( test_runs_code   , test_emulator_state_is_not_modified   , test_other_operations_are_not_executed-  , test_handles_bigmap-  , test_handles_bigmap_ids+  , test_handles_mix_of_bigmaps_and_bigmap_ids   , test_env_vars_can_be_observed   , test_can_observe_existing_onchain_contracts_and_accounts   , test_self_address_does_not_exist_onchain@@ -23,7 +24,10 @@ import Lorentz qualified as L import Lorentz.Base import Lorentz.Value-import Morley.Michelson.Runtime.GState (gsAddressesL)+import Morley.Michelson.Runtime.GState (gsContractAddressesL)+import Morley.Michelson.Typed (untypeValue)+import Morley.Michelson.Untyped (Elt(..), Value'(..))+import Morley.Tezos.Address import Morley.Tezos.Core (Timestamp(..)) import Test.Cleveland import Test.Cleveland.Internal.Pure (psGState)@@ -34,8 +38,8 @@   testScenario "runs the given contract's code" $ scenario do     runCode RunCode       { rcContract = increment-      , rcStorage = NotRPC 5-      , rcParameter = NotRPC 3+      , rcStorage = untypeValue $ toVal @Integer 5+      , rcParameter = untypeValue $ toVal @Integer 3       , rcAmount = 0       , rcBalance = 0       , rcSource = Nothing@@ -55,8 +59,8 @@     before <- get     runCode RunCode       { rcContract = transferToSender-      , rcStorage = NotRPC ()-      , rcParameter = NotRPC ()+      , rcStorage = untypeValue $ toVal ()+      , rcParameter = untypeValue $ toVal ()       , rcAmount = 900       , rcBalance = 900       , rcSource = Nothing@@ -88,8 +92,8 @@     -- then the counter should only be increased to 1 and then stop.     runCode RunCode       { rcContract = unboundRecursion-      , rcStorage = NotRPC 0-      , rcParameter = NotRPC ()+      , rcStorage = untypeValue $ toVal @Integer 0+      , rcParameter = untypeValue $ toVal ()       , rcAmount = 0       , rcBalance = 0       , rcSource = Nothing@@ -97,7 +101,7 @@       , rcLevel = Nothing       } @@== 1   where-    -- | A contract that calls itself forever, increment the counter in its storage by 1 on every call.+    -- A contract that calls itself forever, increment the counter in its storage by 1 on every call.     unboundRecursion :: Contract () Integer ()     unboundRecursion = L.defaultContract $       L.cdr@@ -109,36 +113,30 @@       # L.dip L.nil # L.cons       # L.pair -test_handles_bigmap :: TestTree-test_handles_bigmap =-  testScenario "handles bigmaps in parameter/storage" $ scenario do-    (total, bigMapId) <- runCode RunCode-      { rcContract = lookupBigMapKey-      , rcStorage = NotRPC ((0, 0), one ("key", 50))-      , rcParameter = NotRPC ("key", one ("key", 20))-      , rcAmount = 0-      , rcBalance = 0-      , rcSource = Nothing-      , rcNow = Nothing-      , rcLevel = Nothing-      }--    total @== (50, 20)-    -- Check that the bigmap was not actually created on-chain.-    getBigMapValueMaybe bigMapId "key" @@== Nothing--test_handles_bigmap_ids :: TestTree-test_handles_bigmap_ids =-  testScenario "handles bigmap IDs in parameter/storage" $ scenario do+test_handles_mix_of_bigmaps_and_bigmap_ids :: TestTree+test_handles_mix_of_bigmaps_and_bigmap_ids =+  testScenario "handles a mix of bigmaps and bigmap IDs in parameter/storage" $ scenario do     -- Originate a contract with a big_map in its storage     -- in order to actually create a valid on-chain bigmap ID.-    handle <- originateSimple @() @(BigMap MText Integer) @() "bigmap" (one ("key", 30)) idContract+    handle <- originate "bigmap" (one ("key", 20)) $ idContract @() @(BigMap MText Integer)     bigMapId <- getStorage handle -    (total, _) <- runCode RunCode+    (_, results) <- runCode RunCode       { rcContract = lookupBigMapKey-      , rcStorage = IsRPC ((0, 0), bigMapId)-      , rcParameter = IsRPC ("key", bigMapId)+      , rcParameter =+          -- a list with a big_map ID and a big_map value+          ValueSeq+            [ untypeValue $ toVal bigMapId+            , ValueMap [Elt (ValueString "key") (ValueInt 30)]+            ]+      , rcStorage =+          ValuePair+            (ValueSeq+              [ untypeValue $ toVal bigMapId+              , ValueMap [Elt (ValueString "key") (ValueInt 40)]+              ]+            )+            (ValueNil)       , rcAmount = 0       , rcBalance = 0       , rcSource = Nothing@@ -146,7 +144,7 @@       , rcLevel = Nothing       } -    total @== (30, 30)+    results @== [40, 20, 30, 20]  test_env_vars_can_be_observed :: TestTree test_env_vars_can_be_observed =@@ -156,8 +154,8 @@      envVars <- withSender sender $ runCode RunCode       { rcContract = readEnvVars-      , rcStorage = NotRPC Nothing-      , rcParameter = NotRPC ()+      , rcStorage = untypeValue $ toVal $ Nothing @EnvVars+      , rcParameter = untypeValue $ toVal ()       , rcAmount = 456       , rcBalance = 123       , rcSource = Just source@@ -168,8 +166,8 @@     envLevel envVars @== 29     envNow envVars @== Timestamp 8     getChainId @@== envChainId envVars-    envSender envVars @== sender-    envSource envVars @== source+    envSender envVars @== toAddress sender+    envSource envVars @== toAddress source     envAmount envVars @== 456     envBalance envVars @== 123   where@@ -204,13 +202,7 @@ test_can_observe_existing_onchain_contracts_and_accounts :: TestTree test_can_observe_existing_onchain_contracts_and_accounts =   testScenario "existing onchain contracts/acounts can be observed" $ scenario do-    contractAddress <- toAddress <$> originate OriginateData-      { odName = "contract"-      , odBalance = 123-      , odStorage = ()-      , odContract = idContract @Integer @()-      }-+    contractAddress <- toAddress <$> originate "contract" () (idContract @Integer @()) [tz|123u|]     let       checkContractExists :: Contract () (Maybe Address) ()       checkContractExists = L.defaultContract $@@ -224,8 +216,8 @@      runCode RunCode       { rcContract = checkContractExists-      , rcStorage = IsRPC Nothing-      , rcParameter = IsRPC ()+      , rcStorage = untypeValue $ toVal $ Nothing @Address+      , rcParameter = untypeValue $ toVal ()       , rcAmount = 0       , rcBalance = 0       , rcSource = Nothing@@ -249,10 +241,10 @@         # L.assertSome @MText "Expected to find a contract with parameter `Integer`."         # L.address # L.some # L.nil # L.pair -    selfAddr <- runCode RunCode+    MkAddress selfAddr@ContractAddress{} <- runCode RunCode       { rcContract = returnSelf-      , rcStorage = IsRPC Nothing-      , rcParameter = IsRPC 0+      , rcStorage = untypeValue $ toVal $ Nothing @Address+      , rcParameter = untypeValue $ toVal @Integer 0       , rcAmount = 0       , rcBalance = 0       , rcSource = Nothing@@ -260,41 +252,51 @@       , rcLevel = Nothing       } >>= evalJust "Expected contract to return a `Some`" -    emulatorState ^. gsAddressesL . at selfAddr @== Nothing+    emulatorState ^. gsContractAddressesL . at selfAddr @== Nothing  ---------------------------------------------------------------------------- -- Helpers ---------------------------------------------------------------------------- --- | Looks up an integer in:------ * The big_map given in the parameter--- * The big_map in the storage+-- | This contracts has a list of big_maps in its storage, and takes an additional+-- list of big_maps in its parameter. ----- ... and stores both results in the storage.-lookupBigMapKey :: Contract (MText, BigMap MText Integer) ((Integer, Integer), BigMap MText Integer) ()+-- When called, it looks up the key "key" in all big_maps, and stores+-- all results in a @[Integer]@ in the storage.+lookupBigMapKey+  :: Contract [BigMap MText Integer]+              ([BigMap MText Integer], [Integer])+              () lookupBigMapKey = L.mkContractWith L.intactCompilationOptions $ L.mkContractCode $+  -- Unpair everything   L.unpair-  # L.dip L.cdr-  # L.unpair-  # L.stackType @'[MText, BigMap MText Integer, BigMap MText Integer]--  # L.dup-  # L.dip L.swap-  # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer]+  # L.dip L.unpair+  # L.stackType @'[[BigMap MText Integer], [BigMap MText Integer], [Integer]] -  -- Make a copy of the bigmap in the storage-  # L.dupN @4-  # L.dug @4-  # L.stackType @'[MText, BigMap MText Integer, MText, BigMap MText Integer, BigMap MText Integer]+  -- Discard the `[Integer]` in the storage+  # L.dipN @2 L.drop+  # L.stackType @'[[BigMap MText Integer], [BigMap MText Integer]] -  -- Retrieve keys-  # L.get-  # L.assertSome @MText "Expected Some, found None."-  # L.dug @2-  # L.get-  # L.assertSome @MText "Expected Some, found None."+  -- Get the value at key "key" from all big_maps+  # L.nil @Integer+  # L.swap+  # getValues+  # L.stackType @'[[Integer], [BigMap MText Integer]]+  # L.swap+  # getValues+  # L.stackType @'[[Integer]] -  # L.pair+  # L.nil   # L.pair   # L.nil @Operation # L.pair+  where+    -- Get the value at key "key" from all big_maps+    getValues :: [BigMap MText Integer] ': [Integer] ': s :-> [Integer] ': s+    getValues =+      L.iter+        (+          L.push @MText "key"+          # L.get+          # L.assertSome @MText "Expected Some, found None."+          # L.cons+        )