cleveland 0.2.1 → 0.3.0

raw patch · 46 files changed

+1382/−593 lines, 46 filesdep +dependent-mapdep +somedep −bytestringdep −nameddep −safe-exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: dependent-map, some

Dependencies removed: bytestring, named, safe-exceptions

API changes (from Hackage documentation)

Files

• CHANGES.md +56/−0
• cleveland.cabal +14/−7
• src/Hedgehog/Gen/Michelson/Typed.hs +4/−5
• src/Hedgehog/Range/Defaults.hs +1/−1
• src/Test/Cleveland.hs +8/−4
• src/Test/Cleveland/Instances.hs +1/−0
• src/Test/Cleveland/Internal/Abstract.hs +40/−54
• src/Test/Cleveland/Internal/Actions.hs +9/−1
• src/Test/Cleveland/Internal/Actions/Assertions.hs +2/−0
• src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs +8/−30
• src/Test/Cleveland/Internal/Actions/Helpers.hs +2/−0
• src/Test/Cleveland/Internal/Actions/Misc.hs +37/−9
• src/Test/Cleveland/Internal/Actions/MonadOps.hs +2/−0
• src/Test/Cleveland/Internal/Actions/Originate.hs +76/−50
• src/Test/Cleveland/Internal/Actions/Transfer.hs +114/−34
• src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs +6/−6
• src/Test/Cleveland/Internal/Actions/View.hs +111/−0
• src/Test/Cleveland/Internal/Client.hs +70/−36
• src/Test/Cleveland/Internal/Exceptions.hs +21/−81
• src/Test/Cleveland/Internal/Exceptions/Annotated.hs +183/−0
• src/Test/Cleveland/Internal/Exceptions/CallStack.hs +55/−0
• src/Test/Cleveland/Internal/Exceptions/ErrorsClarification.hs +24/−0
• src/Test/Cleveland/Internal/Exceptions/ScenarioBranchName.hs +26/−0
• src/Test/Cleveland/Internal/Hedgehog.hs +5/−6
• src/Test/Cleveland/Internal/Pure.hs +72/−134
• src/Test/Cleveland/Internal/Scenario.hs +2/−0
• src/Test/Cleveland/Lorentz.hs +0/−2
• src/Test/Cleveland/Lorentz/Internal/Entrypoints.hs +20/−16
• src/Test/Cleveland/Lorentz/Requester.hs +1/−1
• src/Test/Cleveland/Lorentz/Ticketer.hs +3/−1
• src/Test/Cleveland/Lorentz/Types.hs +3/−16
• src/Test/Cleveland/Michelson/Internal/Entrypoints.hs +14/−7
• src/Test/Cleveland/Tasty/Internal.hs +9/−8
• src/Test/Cleveland/Tasty/Internal/Options.hs +5/−3
• src/Test/Cleveland/Tasty/Internal/Report.hs +2/−0
• src/Test/Cleveland/Util.hs +3/−2
• test/TestSuite/Cleveland/CallStack.hs +65/−30
• test/TestSuite/Cleveland/CallStack/Fixtures.hs +19/−0
• test/TestSuite/Cleveland/Delegates.hs +60/−0
• test/TestSuite/Cleveland/Entrypoints.hs +1/−1
• test/TestSuite/Cleveland/ErrorMessages.hs +1/−1
• test/TestSuite/Cleveland/ExpectFailure.hs +22/−23
• test/TestSuite/Cleveland/Lorentz/Entrypoints.hs +67/−23
• test/TestSuite/Cleveland/MonadOps.hs +49/−0
• test/TestSuite/Cleveland/ViewCall.hs +88/−0
• test/TestSuite/Cleveland/WithMoneybag.hs +1/−1

@@ -1,6 +1,62 @@ <!-- Unreleased: append new entries here -->  +0.3.0+=====+* [!1281](https://gitlab.com/morley-framework/morley/-/merge_requests/1281)+  Use the new binaries names, `octez-client` and `octez-node`+* [!1270](https://gitlab.com/morley-framework/morley/-/merge_requests/1270)+  Add lima protocol TICKET instruction, rename old one to TICKET_DEPRECATED+  + The `TICKET` instruction was renamed to `TICKET_DEPRECATED`+  + A new `TICKET` instuction was added which no longer allows zero amount tickets.+    It now returns `Some Ticket` and `None` in case of zero ammount supplied.+* [!1252](https://gitlab.com/morley-framework/morley/-/merge_requests/1252)+  Better errors on stuck GetEntrypointArgCustom+  + Particularly in `transfer` with polymorphic/ambiguous contract parameter.+* [!1258](https://gitlab.com/morley-framework/morley/-/merge_requests/1258)+  Support implicit contract delegates and setting delegates during origination+  + New function `setDelegate` for setting the delegate on implicit addresses.+  + `originate` now allows specifying optional delegate by passing a `KeyHash` value as argument.+  + `getDelegate` now accepts either implicit or contract addresses.+* [!1226](https://gitlab.com/morley-framework/morley/-/merge_requests/1226)+  Implement delegation operation via RPC+* [!1257](https://gitlab.com/morley-framework/morley/-/merge_requests/1257)+  Add ability to call on-chain views directly from test scenarios+* [!1244](https://gitlab.com/morley-framework/morley/-/merge_requests/1244)+  Carry verbosity setting to only-rpc env in `mkMorleyOnlyRpcEnvNetwork`+* [!1243](https://gitlab.com/morley-framework/morley/-/merge_requests/1243)+  Use Morley's `run_code` emulation+* [!1242](https://gitlab.com/morley-framework/morley/-/merge_requests/1242)+  Use `Constrained` utility existential+* [!1246](https://gitlab.com/morley-framework/morley/-/merge_requests/1246)+  Fix `MonadOriginate` blowing up with `Reduction stack overflow`+  + `MonadOriginate` constraint caused GHC to go loopy; now it doesn't, and a+    test was added to prevent this in the future.+* [!1247](https://gitlab.com/morley-framework/morley/-/merge_requests/1247)+  Refactor MorleyClientEnv+  + Removed `MorleyClientEnv'`, constructor now lives in `MorleyClientEnv`+  + Removed `Morley.Client.Env` module+  + `MorleyClientEnv`, `mkMorleyClientEnv` and `MorleyClientEnv` lenses moved to `Morley.Client.Full`+* [!1220](https://gitlab.com/morley-framework/morley/-/merge_requests/1220)+  Better `transfer` errors on bad address type+* [!1219](https://gitlab.com/morley-framework/morley/-/merge_requests/1219)+  Add resolving contract aliases in network tests+* [!1237](https://gitlab.com/morley-framework/morley/-/merge_requests/1237)+  Support delegate registration on the emulator+* [!1178](https://gitlab.com/morley-framework/morley/-/merge_requests/1178)+  Fix `contract t` typed value generator+  + `contract t` value generator where `t /= unit` could produce implicit+    addresses. This is invalid. Now it only produces smart contract addresses.+  + `contract unit` generator can still produce both implicit and smart contract+    addresses.+* [!1228](https://gitlab.com/morley-framework/morley/-/merge_requests/1228)+  Handle implicit default entrypoint in `testContractCoversEntrypoints` &c+  + Implicit default entrypoint is considered in entrypoint coverage tests iff+    the default entrypoint is defined in the spec. Otherwise, implicit default+    is ignored. Explicit default entrypoint is always considered.+* [!1211](https://gitlab.com/morley-framework/morley/-/merge_requests/1211)+  Unify handling of annotated exceptions+ 0.2.1 ===== * [!1199](https://gitlab.com/morley-framework/morley/-/merge_requests/1199)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           cleveland-version:        0.2.1+version:        0.3.0 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@@ -66,8 +66,13 @@       Test.Cleveland.Internal.Actions.Originate       Test.Cleveland.Internal.Actions.Transfer       Test.Cleveland.Internal.Actions.TransferFailurePredicate+      Test.Cleveland.Internal.Actions.View       Test.Cleveland.Internal.Client       Test.Cleveland.Internal.Exceptions+      Test.Cleveland.Internal.Exceptions.Annotated+      Test.Cleveland.Internal.Exceptions.CallStack+      Test.Cleveland.Internal.Exceptions.ErrorsClarification+      Test.Cleveland.Internal.Exceptions.ScenarioBranchName       Test.Cleveland.Internal.Hedgehog       Test.Cleveland.Internal.Pure       Test.Cleveland.Internal.Scenario@@ -145,18 +150,18 @@       UndecidableInstances       UndecidableSuperClasses       ViewPatterns-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode   build-depends:       HUnit     , MonadRandom     , aeson     , base-noprelude >=4.7 && <5-    , bytestring     , constraints >=0.11     , containers     , criterion     , cryptonite     , data-default+    , dependent-map     , directory     , either     , exceptions@@ -170,13 +175,12 @@     , morley-client     , morley-prelude     , mtl-    , named     , o-clock     , optparse-applicative-    , safe-exceptions     , servant-client-core     , singletons     , singletons-base+    , some     , statistics     , tagged     , tasty >=1.4@@ -203,8 +207,10 @@       TestSuite.Cleveland.BlockIntervalGetter       TestSuite.Cleveland.BytesSigning       TestSuite.Cleveland.CallStack+      TestSuite.Cleveland.CallStack.Fixtures       TestSuite.Cleveland.ChainIdGet       TestSuite.Cleveland.ContractAllocation+      TestSuite.Cleveland.Delegates       TestSuite.Cleveland.DFS       TestSuite.Cleveland.EmitMachinery       TestSuite.Cleveland.EmptyImplicitAddress@@ -219,6 +225,7 @@       TestSuite.Cleveland.Lorentz.Contracts.ContractAllocator       TestSuite.Cleveland.Lorentz.Entrypoints       TestSuite.Cleveland.MismatchError+      TestSuite.Cleveland.MonadOps       TestSuite.Cleveland.NetworkCaps       TestSuite.Cleveland.NewAddressCheck       TestSuite.Cleveland.OperationReplay@@ -236,6 +243,7 @@       TestSuite.Cleveland.TransferCheck       TestSuite.Cleveland.UsedFramework       TestSuite.Cleveland.Util+      TestSuite.Cleveland.ViewCall       TestSuite.Cleveland.VotingPower       TestSuite.Cleveland.WithMoneybag       TestSuite.Cleveland.WithSender@@ -296,7 +304,7 @@       UndecidableInstances       UndecidableSuperClasses       ViewPatterns-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"   build-tool-depends:       tasty-discover:tasty-discover   build-depends:@@ -312,7 +320,6 @@     , morley     , morley-client     , morley-prelude-    , named     , o-clock     , servant-client     , tasty

@@ -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 (ConstrainedAddress(..), TxRollupL2Address(..))+import Morley.Tezos.Address (Constrained(..), TxRollupL2Address(..)) import Morley.Tezos.Core (Mutez, Timestamp) import Morley.Tezos.Crypto (parseHash) import Morley.Tezos.Crypto.BLS12381 qualified as BLS@@ -172,10 +172,9 @@   STList (STPair STBls12381G1 STBls12381G2) -> genBls12Pairing   STList st -> genValueList def $ genValue' st   STSet st -> genValueSet def $ genValue' st-  STContract (s :: SingT p) -> case (checkOpPresence s, checkNestedBigMapsPresence s) of-    (OpAbsent, NestedBigMapsAbsent) -> VContract <$> genAddress <*> pure unsafeSepcCallRoot-    _ -> Gen.discard-  STTicket (s :: SingT p) -> genValueTicket def $ genValue' s+  STContract STUnit -> VContract <$> genAddress <*> pure unsafeSepcCallRoot+  STContract _ -> VContract <$> (MkAddress <$> genContractAddress) <*> pure unsafeSepcCallRoot+  STTicket s -> genValueTicket def $ genValue' s   STPair STChestKey STChest -> VPair . bimap VChestKey VChest . swap <$> genChestAndKey   STPair l r -> VPair <$> ((,) <$> genNoOpValue l <*> genNoOpValue r)   STOr l r -> VOr <$> Gen.choice

@@ -44,7 +44,7 @@   deriving newtype (Eq, Ord, Enum, Integral, Real, Num)  instance Default (Range TicketAmount) where-  def = MkTicketAmount <$> Range.linearFrom 0 0 1000+  def = MkTicketAmount <$> Range.linearFrom 1 1 1000  -- | Newtype for the range of @ValueInt@ constructor of untyped @Value'@. newtype ValueInt = MkValueInt { unValueInt :: Integer }

@@ -22,7 +22,7 @@   -- * Validation   , TransferFailure -  -- * Real network implementation based on @tezos-client@ and RPC.+  -- * Real network implementation based on @octez-client@ and RPC.   , testScenario   , testScenarioOnNetwork   , scenarioNetwork@@ -71,6 +71,7 @@   , getBalance   , getDelegate   , registerDelegate+  , setDelegate   , getMorleyLogs   , getMorleyLogs_   , getStorage@@ -127,6 +128,10 @@   , evalRight   , Showing(..) +  -- * Calling views+  , callView+  , unsafeCallView+     -- * Exception handling   , attempt   , catchTransferFailure@@ -170,8 +175,7 @@    -- * Config (reexports)   , TezosClientEnv(..)-  , MorleyClientEnv-  , MorleyClientEnv'(..)+  , MorleyClientEnv(..)   , NetworkEnv (..)   , MorleyLogs   -- ** Config utilities@@ -193,7 +197,7 @@  import Lorentz (EntrypointRef(..), Mutez, ToAddress(..), pattern DefEpName, tz) import Morley.AsRPC qualified as AsRPC-import Morley.Client (MorleyClientEnv, MorleyClientEnv'(..))+import Morley.Client (MorleyClientEnv(..)) import Morley.Client.TezosClient.Types (TezosClientEnv(..)) import Morley.Michelson.Interpret (MorleyLogs) import Morley.Michelson.Runtime (VotingPowers, mkVotingPowers, mkVotingPowersFromMap)

@@ -123,6 +123,7 @@     U.LOOP ops                  -> U.LOOP $ withoutEsp' ops     U.LOOP_LEFT ops             -> U.LOOP_LEFT $ withoutEsp' ops     U.LAMBDA va ty1 ty2 ops     -> U.LAMBDA va ty1 ty2 (withoutEsp' ops)+    U.LAMBDA_REC va ty1 ty2 ops -> U.LAMBDA_REC va ty1 ty2 (withoutEsp' ops)     U.DIP ops                   -> U.DIP $ withoutEsp' ops     U.DIPN n ops -> U.DIPN n (withoutEsp' ops)     U.CREATE_CONTRACT va1 va2 c ->

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Abstract cleveland interface not bound to a particular -- implementation. --@@ -20,7 +22,7 @@ -- before trying to run scenario on a live network. -- -- Also this interface uses 'Address' rather than 'EpAddress'.--- I (\@gromak) concluded that 'EpAddress' can not be passed to @tezos-client@.+-- I (\@gromak) concluded that 'EpAddress' can not be passed to @octez-client@. -- For key addresses it just does not make sense and for contract addresses -- I get such errors: --@@ -66,8 +68,6 @@   , AddressAndAlias(..)   , TransferFailure (..)   , TransferFailureReason (..)-  , FailedInBranch (..)-  , ScenarioBranchName(..)   , GenericTestError (..)   , ExpressionOrTypedValue (..) @@ -119,12 +119,13 @@   , neSecretKeyL   , neMoneybagAliasL   , neExplicitDataDirL+  , neVerbosityL   ) where  import Control.Lens (Each, each, filtered, makeLenses, makeLensesFor, makeLensesWith)+import Data.Constraint (Bottom(..), (\\)) import Data.Default (Default(..)) import Data.Type.Equality (pattern Refl)-import Data.Typeable (cast) import Fmt (Buildable(..), Builder, pretty, (+|), (|+)) import Prelude hiding (Each) import Time (KnownDivRat, Second, Time)@@ -154,7 +155,7 @@ import Morley.Util.Lens (postfixLFields) import Morley.Util.Sing (eqI) import Morley.Util.TypeLits-import Test.Cleveland.Internal.Exceptions (WithCallStack(..))+import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Lorentz.Types  -- | Whether this contract should be originated in@@ -176,6 +177,8 @@   -- We are using Lorentz version here which is convenient. However, keep in   -- mind that if someone wants to test a contract from @.tz@ file, they should use   -- 'UntypedOriginateData'.+  , odDelegate :: Maybe KeyHash+  -- ^ Contract delegate.   }  -- | Untyped version of OriginateData. It can be used for interaction with raw@@ -189,6 +192,8 @@   -- ^ Initial storage.   , uodContract :: U.Contract   -- ^ The contract itself.+  , uodDelegate :: Maybe KeyHash+  -- ^ Contract delegate.   }  -- | Untyped version of OriginateData. It can be used for interaction with raw@@ -202,6 +207,8 @@   -- ^ Initial storage.   , todContract :: T.Contract (T.ToT cp) (T.ToT st)   -- ^ The contract itself.+  , todDelegate :: Maybe KeyHash+  -- ^ Contract delegate.   }  -- | Information about transfer operation.@@ -229,6 +236,7 @@   type TransferInfo ClevelandInput = TransferData   type OriginationInfo ClevelandInput = UntypedOriginateData 'NotLarge   type RevealInfo ClevelandInput = PublicKey+  type DelegationInfo ClevelandInput = Maybe KeyHash  -- | Data structure representing a contract event. data ContractEvent = ContractEvent@@ -243,6 +251,7 @@   type TransferInfo ClevelandResult = [ContractEvent]   type OriginationInfo ClevelandResult = OriginationInfo Result   type RevealInfo ClevelandResult = RevealInfo Result+  type DelegationInfo ClevelandResult = DelegationInfo Result  -- | A batch returned invalid output, e.g. origination address when transaction -- was supplied.@@ -350,10 +359,8 @@   , 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 => ContractAddress -> m (Maybe Crypto.KeyHash)+  , cmiGetDelegate :: HasCallStack => L1Address -> m (Maybe Crypto.KeyHash)   -- ^ Get the delegate for the given contract. Fails on implicit contracts.-  , cmiRegisterDelegate :: HasCallStack => ImplicitAddress -> m ()-  -- ^ Register the given address as a valid delegate.   , cmiGetChainId :: HasCallStack => m ChainId   -- ^ Get the chain's @ChainId@.   , cmiAdvanceTime :: forall unit. (HasCallStack, KnownDivRat unit Second) => Time unit -> m ()@@ -454,6 +461,7 @@   , neSecretKey :: Maybe Crypto.SecretKey   , neMoneybagAlias :: ImplicitAlias   , neExplicitDataDir :: Bool+  , neVerbosity :: Word   }  ----------------------------------------------------------------------------@@ -511,15 +519,16 @@   } deriving newtype (Functor, Applicative)  instance-  TypeError-  ( 'Text "Attempt to use monad capabilities within a batch" ':$$:-    'Text "In case you are using a do-block, make sure that" ':$$:-    'Text "• `ApplicativeDo` extension is enabled" ':$$:-    'Text "• there is a return statement in the end" ':$$:-    'Text "• returned value picks variables in the order in which they are defined"-  ) =>-  Monad ClevelandOpsBatch where-    (>>=) = error "impossible"+  ( Bottom+  , TypeError+        ( 'Text "Attempt to use monad capabilities within a batch" ':$$:+          'Text "In case you are using a do-block, make sure that" ':$$:+          'Text "• `ApplicativeDo` extension is enabled" ':$$:+          'Text "• there is a return statement in the end" ':$$:+          'Text "• returned value picks variables in the order in which they are defined"+        )+  ) => Monad ClevelandOpsBatch where+    (>>=) = no  {- | Run a series of operations within a batch. @@ -602,9 +611,19 @@     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)+data AddressAndAlias = forall kind. AddressAndAlias (KindedAddress kind) (Maybe (Alias kind)) +deriving stock instance Show AddressAndAlias++instance Eq AddressAndAlias where+  (AddressAndAlias (addr1 :: KindedAddress kind1) _) ==+    (AddressAndAlias (addr2 :: KindedAddress kind2) _) =+      maybe False (\Refl -> addr1 == addr2) $+        eqI @kind1 @kind2 \\ addressKindSanity addr1 \\ addressKindSanity addr2++instance ToAddress AddressAndAlias where+  toAddress (AddressAndAlias a _) = toAddress a+ instance Buildable AddressAndAlias where   build (AddressAndAlias addr mbAlias) =     build addr +| maybe "" (\alias -> " (" +| alias |+ ")") mbAlias@@ -633,20 +652,6 @@   -- 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--- constructor to remember in _which_ branch it was thrown.--- We use this information to provide better error messages when a test fails.-data FailedInBranch = FailedInBranch ScenarioBranchName SomeException-  deriving stock (Show)---- | When using 'Test.Cleveland.branchout' function for building test scenarios - names--- of branches we are currently within.-newtype ScenarioBranchName = ScenarioBranchName { unTestBranch :: [Text] }-  deriving stock (Show, Eq)--instance Buildable ScenarioBranchName where-  build = mconcat . intersperse "/" . map build . unTestBranch- instance Buildable TransferFailure where   build (TransferFailure addr reason) = case reason of     EmptyTransaction -> reason |+ ": " +| addr |+ ""@@ -663,10 +668,6 @@     ShiftOverflow -> "overflow error"     GasExhaustion -> "gas exhaustion" -instance Buildable FailedInBranch where-  build (FailedInBranch branchName (SomeException err)) = "In '" +| branchName |+-    "' branch:\n" +| (build $ displayException err)- data GenericTestError   = UnexpectedSuccess   deriving stock Show@@ -678,25 +679,11 @@  instance Exception TransferFailure where   displayException = pretty-  fromException someEx@(SomeException ex) =-    cast @_ @TransferFailure ex-    <|>-    ( do-        WithCallStack _ exInner <- fromException @WithCallStack someEx-        fromException exInner-    )-    <|>-    ( do-        FailedInBranch _ exInner <- fromException @FailedInBranch someEx-        fromException exInner-    )---instance Exception FailedInBranch where-  displayException = pretty+  fromException = fromPossiblyAnnotatedException  instance Exception GenericTestError where   displayException = pretty+  fromException = fromPossiblyAnnotatedException  ---------------------------------------------------------------------------- -- Other helpers@@ -762,7 +749,6 @@     , cmiGetAllBigMapValuesMaybe = \bmId -> f $ cmiGetAllBigMapValuesMaybe bmId     , cmiGetPublicKey = \addr -> f $ cmiGetPublicKey addr     , cmiGetDelegate = f <$> cmiGetDelegate-    , cmiRegisterDelegate = f <$> cmiRegisterDelegate     , cmiGetChainId = f $ cmiGetChainId     , cmiAdvanceTime = \time -> f $ cmiAdvanceTime time     , cmiAdvanceToLevel = \level -> f $ cmiAdvanceToLevel level

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Cleveland actions. module Test.Cleveland.Internal.Actions   ( MonadOps@@ -54,6 +56,7 @@   , offshoot   , getDelegate   , registerDelegate+  , setDelegate   , setVotingPowers   , whenEmulation   , whenNetwork@@ -72,6 +75,10 @@   , evalJust   , evalRight +  -- * Calling views+  , callView+  , unsafeCallView+   -- * Exception handling   , attempt   , catchTransferFailure@@ -104,9 +111,10 @@ 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.Originate hiding (setDelegate) import Test.Cleveland.Internal.Actions.Transfer import Test.Cleveland.Internal.Actions.TransferFailurePredicate+import Test.Cleveland.Internal.Actions.View  -- | Synonym typeclass for monads where network operations can occur. --

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Various test assertions in the 'MonadCleveland' context. module Test.Cleveland.Internal.Actions.Assertions   ( module Test.Cleveland.Internal.Actions.Assertions

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Exception handling module Test.Cleveland.Internal.Actions.ExceptionHandling   ( module Test.Cleveland.Internal.Actions.ExceptionHandling@@ -8,7 +10,7 @@  import Data.Either.Validation (Validation(..)) import Data.List.NonEmpty qualified as NE-import Fmt (Builder, build, indentF, nameF, pretty, unlinesF)+import Fmt (Builder, build, indentF, unlinesF)  import Lorentz (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg) import Lorentz.Constraints@@ -17,9 +19,7 @@ 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(..))+import Test.Cleveland.Internal.Exceptions  -- | Attempt to run an action and return its result or, if interpretation fails, an error. attempt@@ -145,8 +145,7 @@   => 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.+-- | Prefix error messages 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 @: @.@@ -160,29 +159,8 @@ -- >   askContract i @@== i * 2 clarifyErrors :: forall caps m a. (MonadCleveland caps m)               => Builder -> m a -> m a-clarifyErrors message action = do+clarifyErrors message action =   attempt action >>= \case-    Left (e :: SomeException) -> withCap getMiscCap \cap -> cmiThrow cap (handle e)+    Left e -> withCap getMiscCap \cap -> cmiThrow cap $+      insertAnnEx (ErrorsClarification [message]) 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

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Helpers for working in @MonadCleveland@ context. module Test.Cleveland.Internal.Actions.Helpers   ( module Test.Cleveland.Internal.Actions.Helpers

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | The bulk of Cleveland actions. module Test.Cleveland.Internal.Actions.Misc   ( module Test.Cleveland.Internal.Actions.Misc@@ -16,13 +18,15 @@ import Lorentz.Bytes import Lorentz.Constraints import Morley.AsRPC (HasRPCRepr(..))-import Morley.Client (MorleyClientEnv)-import Morley.Michelson.Runtime (VotingPowers)+import Morley.Client (MorleyClientEnv, OperationInfo(..), RunError(..), UnexpectedErrors(..))+import Morley.Michelson.Runtime (ExecutorError'(..), VotingPowers)+import Morley.Michelson.Runtime.GState (GStateUpdateError(..)) 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 (unImplicitAddress) import Morley.Tezos.Address.Alias (Alias(..)) import Morley.Tezos.Core (ChainId, Mutez, Timestamp) import Morley.Tezos.Crypto (KeyHash, PublicKey, Signature)@@ -32,7 +36,9 @@ import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions.Assertions import Test.Cleveland.Internal.Actions.Helpers+import Test.Cleveland.Internal.Actions.MonadOps import Test.Cleveland.Internal.Actions.Transfer+import Test.Cleveland.Internal.Exceptions (fromPossiblyAnnotatedException) import Test.Cleveland.Lorentz.Import qualified as LorentzImport import Test.Cleveland.Lorentz.Types @@ -215,18 +221,40 @@ getBalance addr = do   withCap getMiscCap \cap -> cmiGetBalance cap (toL1Address addr) --- | Get the delegate for the given contract. Fails on implicit contracts.+-- | Get the delegate for the given contract/implicit address. getDelegate-  :: (HasCallStack, MonadCleveland caps m, ToContractAddress addr)+  :: (HasCallStack, MonadCleveland caps m, ToL1Address addr)   => addr -> m (Maybe KeyHash) getDelegate addr = do-  withCap getMiscCap \cap -> cmiGetDelegate cap (toContractAddress addr)+  withCap getMiscCap \cap -> cmiGetDelegate cap (toL1Address addr) --- | Register the given address as a valid delegate.-registerDelegate :: (HasCallStack, MonadCleveland caps m) => ImplicitAddress -> m ()+-- | Register the given implicit address as a delegate.+registerDelegate+  :: (HasCallStack, MonadCleveland caps m)+  => ImplicitAddress -> m () registerDelegate addr = do-  withCap getMiscCap \cap -> cmiRegisterDelegate cap addr+  caps <- ask+  r <- lift $ cmiAttempt (getMiscCap caps) $+    runReaderT (setDelegate addr $ Just $ unImplicitAddress addr) caps+  -- NB: we do some exception wrangling such that registerDelegate doesn't error+  -- out if an address is already a delegate. The primary reason for this is the+  -- disconnect between network, which remembers delegation state between+  -- scenarios, and the emulator, which does not. Hence we want registerDelegate+  -- to be idempotent.+  case r of+    Right () -> pass+    Left e+      | Just (UnexpectedRunErrors [DelegateAlreadyActive]) <- fromPossiblyAnnotatedException e -> pass+      | Just (EEFailedToApplyUpdates GStateAlreadySetDelegate{} :: ExecutorError' AddressAndAlias)+        <- fromPossiblyAnnotatedException e+      -> pass+      | otherwise -> lift $ cmiThrow (getMiscCap caps) e +-- | Set/unset delegate+setDelegate :: (HasCallStack, MonadCleveland caps m) => ImplicitAddress -> Maybe KeyHash -> m ()+setDelegate addr kh = void $ withSender addr $+  withOpsCap \cap -> coiRunOperationBatch cap [OpDelegation kh]+ -- | Retrieve a contract's storage in its "RPC representation" -- (i.e., all its big_maps will be replaced by big_map IDs). --@@ -544,7 +572,7 @@   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.+-- f.ex. @octez-client@ inside a network test. -- -- This is considered a pretty low-level function, so it's better to avoid it in -- most cases.

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Internally used typeclass for operations-related actions module Test.Cleveland.Internal.Actions.MonadOps   ( module Test.Cleveland.Internal.Actions.MonadOps

@@ -1,17 +1,17 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | 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 Lorentz (Contract(..), NiceParameter, NiceStorage, NiceViewsDescriptor, toMichelsonContract) -import Data.Constraint ((\\))-import GHC.TypeLits (ErrorMessage(..), TypeError)+import Data.Constraint (Bottom(..))+import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)  import Morley.Client.Types import Morley.Michelson.Typed (convertContract, toVal, untypeValue)@@ -19,6 +19,7 @@ import Morley.Michelson.Untyped qualified as U import Morley.Tezos.Address import Morley.Tezos.Core+import Morley.Tezos.Crypto (KeyHash) import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions.Helpers import Test.Cleveland.Internal.Actions.MonadOps@@ -41,9 +42,10 @@ -- > 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)+originate :: forall contract r. ( HasCallStack, ContractClass contract+                                , OriginateFunc contract '[] r)           => ContractAlias -> ContractStorage contract -> contract -> r-originate = originate'r @contract @'NoBalance @'NotLarge ... initialData @contract+originate = originate'r @contract @'[] ... initialData @contract  ---------------------------------------------------------------------------- -- Main origination implementations@@ -64,8 +66,9 @@     let uod = UntypedOriginateData @large           odName           odBalance-          (untypeValue (toVal odStorage) \\ niceStorageEvi @st)+          (untypeValue (toVal odStorage))           (convertContract $ toMichelsonContract (odContract od))+          odDelegate     ContractHandle odName <$> originateFn uod  instance (a ~ ContractHandle cp st vd, MonadOpsInternal m@@ -78,6 +81,7 @@           todBalance           (untypeValue (toVal todStorage))           (convertContract (todContract tod))+          todDelegate     ContractHandle todName <$> originateFn uod  instance (a ~ ContractAddress, MonadOpsInternal m)@@ -109,12 +113,12 @@ 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+  initialData name store contract = OriginateData name zeroMutez store contract Nothing  instance ContractClass U.Contract where   type ContractStorage U.Contract = U.Value   type ContractOriginateData U.Contract = UntypedOriginateData-  initialData = flip UntypedOriginateData zeroMutez+  initialData name store contract = UntypedOriginateData name zeroMutez store contract Nothing  instance ContractClass (TypedContract cp st vd) where   type ContractStorage (TypedContract cp st vd) = st@@ -125,6 +129,7 @@       , todBalance = zeroMutez       , todStorage = store       , todContract = contract+      , todDelegate = Nothing       }  ----------------------------------------------------------------------------@@ -135,67 +140,84 @@ -- -- 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+class OriginateFunc contract (props :: [Prop]) r where+  originate'r :: HasCallStack => ContractOriginateData contract (GetLarge props) -> r   default originate'r-    :: (HasCallStack, Originator (ContractOriginateData contract isLarge) r)-    => ContractOriginateData contract isLarge -> r+    :: (HasCallStack, Originator (ContractOriginateData contract (GetLarge props)) r)+    => ContractOriginateData contract (GetLarge props) -> r   originate'r = originateFn --- | Simple flag to track duplicate balance specification.-data HasBalance = NoBalance | HasBalance+-- | Enum for props we track duplicates of.+data Prop = PropBalance | PropDelegate | PropLarge --- | 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 = ()+-- | Pretty prop name.+type PropName :: Prop -> Symbol+type family PropName a where+  PropName 'PropBalance = "Balance"+  PropName 'PropDelegate = "Delegate"+  PropName 'PropLarge = "Large" -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+-- | Convert a list of props into 'LargeOrigination'.+type GetLarge :: [Prop] -> LargeOrigination+type family GetLarge a where+  GetLarge ('PropLarge ': _) = 'IsLarge+  GetLarge (_ ': xs) = GetLarge xs+  GetLarge '[] = 'NotLarge --- | Type family raising a type error on 'IsLarge' argument. Used to improve+-- | Type family raising a type error if element is in list. 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 = ()+type CheckDupProp :: Prop -> [Prop] -> Constraint+type family CheckDupProp name props where+  CheckDupProp name (name ': _) =+    TypeError ('Text (PropName name) ':<>: 'Text " is specified more than once.")+  CheckDupProp name (_ ': xs) = CheckDupProp name xs+  CheckDupProp _ '[] = () -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 for constraints used in OriginateFunc instances.+type OFConstraints ct prop props r =+  ( ModifyOriginationData (ContractOriginateData ct)+  , OriginateFunc ct (prop ': props) r+  , CheckDupProp prop props) --- | Convenience synonym.-type OFConstraint ct large r =-  ( ContractClass ct, Originator (ContractOriginateData ct large) r)+-- | Set balance.+instance OFConstraints ct 'PropBalance props r => OriginateFunc ct props (Mutez -> r) where+  originate'r initData x = originate'r @ct @('PropBalance : props) $ setBalance x initData +-- | Set delegate.+instance OFConstraints ct 'PropDelegate props r => OriginateFunc ct props (KeyHash -> r) where+  originate'r initData x = originate'r @ct @('PropDelegate : props) $ setDelegate x initData++-- | Set large origination.+instance (OFConstraints ct 'PropLarge props r, GetLarge props ~ 'NotLarge)+  => OriginateFunc ct props (Large -> r) where+  originate'r initData Large = originate'r @ct @('PropLarge ': props) $ setLarge initData+ -- | The terminating case for batched transfer.-instance OFConstraint ct large (ClevelandOpsBatch a)-  => OriginateFunc ct bal large (ClevelandOpsBatch a)+instance Originator (ContractOriginateData ct (GetLarge props)) (ClevelandOpsBatch a)+  => OriginateFunc ct props (ClevelandOpsBatch a)  -- | The terminating case for Cleveland monads.-instance OFConstraint ct large (ReaderT cap base a)-  => OriginateFunc ct bal large (ReaderT cap base a)+instance Originator (ContractOriginateData ct (GetLarge props)) (ReaderT cap base a)+  => OriginateFunc ct props (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))+class (MonadOpsInternal m+  , forall ct props a. Originator (ContractOriginateData ct (GetLarge props)) (m a)+      => OriginateFunc ct props (m a))   => MonadOriginate m-instance (forall ct bal large a. OFConstraint ct large (m a) => OriginateFunc ct bal large (m a))+instance (MonadOpsInternal m+  , forall ct props a. Originator (ContractOriginateData ct (GetLarge props)) (m a)+      => OriginateFunc ct props (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"+    ( TypeError ('Text "Incorrect argument for the 'originate' function: " ':<>: 'ShowType x ':$$:+     'Text "If in doubt, try adding a type annotation.")+    , Bottom)+  => OriginateFunc ct props (x -> r) where+  originate'r = no  ---------------------------------------------------------------------------- -- Applying modifiers to the initial data@@ -210,16 +232,20 @@ -- | Type class implementing modifications to origination data. class ModifyOriginationData od where   setBalance :: Mutez -> od large -> od large+  setDelegate :: KeyHash -> od large -> od large   setLarge :: od 'NotLarge -> od 'IsLarge  instance ModifyOriginationData (OriginateData cp st vd) where   setBalance bal od = od {odBalance = bal}+  setDelegate kh od = od {odDelegate = Just kh}   setLarge OriginateData{..} = OriginateData{..}  instance ModifyOriginationData (UntypedOriginateData) where   setBalance bal od = od {uodBalance = bal}+  setDelegate kh od = od {uodDelegate = Just kh}   setLarge UntypedOriginateData{..} = UntypedOriginateData{..}  instance ModifyOriginationData (TypedOriginateData cp st vd) where   setBalance bal od = od {todBalance = bal}+  setDelegate kh od = od {todDelegate = Just kh}   setLarge TypedOriginateData{..} = TypedOriginateData{..}

@@ -1,11 +1,14 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Machinery for the variadic 'transfer' function. module Test.Cleveland.Internal.Actions.Transfer   ( module Test.Cleveland.Internal.Actions.Transfer   ) where +import Data.Constraint (Bottom(..)) import Data.Singletons.TH (SingI(..), genSingletons) import GHC.TypeLits (ErrorMessage(..), TypeError) @@ -18,6 +21,9 @@ import Test.Cleveland.Internal.Actions.MonadOps import Test.Cleveland.Lorentz.Types +-- $setup+-- >>> :m Lorentz.Constraints.Scopes Lorentz.Entrypoints.Core Test.Cleveland+ ---------------------------------------------------------------------------- -- TransferResult and its singletons ----------------------------------------------------------------------------@@ -52,37 +58,100 @@ -- 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@.+{- | 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@.++In some polymorphic cases, you may need to add 'HasEntrypointArg' constraint:++>>> :{+example+  :: (MonadCleveland caps m, NiceParameter cp)+  => ContractHandle cp st vd -> m ()+example ch = transfer ch (123 :: Mutez)+:}+...+... Can not look up entrypoints in type+...   cp+... The most likely reason it is ambiguous, or you need+...   HasEntrypointArg cp (EntrypointRef 'Nothing) ()+... constraint+...++You can fix this by adding the constraint:++>>> :{+example+  :: ( MonadCleveland caps m, NiceParameter cp+     , HasEntrypointArg cp (EntrypointRef 'Nothing) ())+  => ContractHandle cp st vd -> m ()+example ch = transfer ch (123 :: Mutez)+:}++GHC may not always figure out the type of the entrypoint parameter. In that+case, it'll show unbound type variable, usually @arg0@:++>>> :{+example+  :: (MonadCleveland caps m, NiceParameter cp, NiceParameter arg)+  => ContractHandle cp st vd -> arg -> m ()+example ch x = transfer ch (123 :: Mutez) $ calling def x+:}+...+... Can not look up entrypoints in type+...   cp+... The most likely reason it is ambiguous, or you need+...   HasEntrypointArg cp (EntrypointRef 'Nothing) arg0+... constraint+...++Either specifying a concrete type in the constraint, or leaving it polymorphic,+fixes this:++>>> :{+example+  :: ( MonadCleveland caps m, NiceParameter cp, NiceParameter arg+     , HasEntrypointArg cp (EntrypointRef 'Nothing) Integer)+  => ContractHandle cp st vd -> Integer -> m ()+example ch x = transfer ch (123 :: Mutez) $ calling def x+:}++>>> :{+example+  :: ( MonadCleveland caps m, NiceParameter cp, NiceParameter arg+     , HasEntrypointArg cp (EntrypointRef 'Nothing) arg)+  => ContractHandle cp st vd -> arg -> m ()+example ch x = transfer ch (123 :: Mutez) $ calling def x+:}+-} transfer :: forall addr r.             ( HasCallStack             , TransferFunc ('Incomplete (InitialTransferMode addr))@@ -121,6 +190,16 @@   InitialTransferMode L1Address = 'Unchecked   InitialTransferMode (L1TAddress param _) = 'Checked param   InitialTransferMode (ContractHandle param _ _) = 'Checked param+  InitialTransferMode Address = TypeError (+    'Text "'Address' can not be used as the first argument of 'transfer'." ':$$:+    'Text "Perhaps you meant to use 'L1Address'?")+  InitialTransferMode (TAddress _ _) = TypeError (+    'Text "'TAddress' can not be used as the first argument of 'transfer'." ':$$:+    'Text "Perhaps you meant to use 'L1TAddress'?")+  InitialTransferMode x = TypeError (+    'Text "Address type '" ':<>: 'ShowType x ':<>: 'Text "' is unsupported or ambiguous." ':$$:+    'Text "The supported address types are" ':$$:+    'Text "'ContractAddress', 'ImplicitAddress', 'L1Address', 'L1TAddress', and 'ContractHandle'")  -- | Construct initial 'GenericTransferData' for a given address. initialData@@ -214,10 +293,11 @@  -- | 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.")+     ( Bottom+     , 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"+  transfer'r = no  ---------------------------------------------------------------------------- -- Making the actual transfer

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | 'TransferFailure' Predicates module Test.Cleveland.Internal.Actions.TransferFailurePredicate   ( module Test.Cleveland.Internal.Actions.TransferFailurePredicate@@ -15,7 +17,7 @@ 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 (Constrained(..), SomeConstant) import Morley.Michelson.Typed qualified as T import Test.Cleveland.Internal.Abstract import Test.Cleveland.Lorentz.Types@@ -94,8 +96,8 @@   => addr -- ^ The expected address.   -> TransferFailurePredicate addressIs (toAddress -> expectedAddr) = TransferFailurePredicate \err -> do-  let TransferFailure (AddressAndAlias actualAddr _) _ = err-  when (actualAddr /= expectedAddr) $+  let TransferFailure addrAndAlias _ = err+  when (toAddress addrAndAlias /= expectedAddr) $     Failure $ "Failure occurred in contract with address: " <> build expectedAddr  ----------------------------------------------------------------------------@@ -104,9 +106,7 @@  -- | 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+constant err = SomeConstant $ toVal err  -- | A lorentz error. lerror :: forall err. IsError err => err -> SomeConstant

@@ -0,0 +1,111 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | On-chain view utilities.+module Test.Cleveland.Internal.Actions.View+  ( module Test.Cleveland.Internal.Actions.View+  ) where++import Data.Constraint (pattern Dict)+import Fmt ((+|), (|+))++import Lorentz (Contract(..), HasView, Label, NiceViewable, toVal)+import Lorentz qualified as L+import Morley.AsRPC+import Morley.Michelson.Typed (pattern (:#))+import Morley.Michelson.Typed qualified as T+import Morley.Util.TypeLits (KnownSymbol, symbolValT')+import Test.Cleveland.Internal.Abstract+import Test.Cleveland.Internal.Actions.Assertions (failure)+import Test.Cleveland.Internal.Actions.Misc+import Test.Cleveland.Lorentz.Types++-- | Call an on-chain view by name. The existence of the view is checked at+-- compile time. If you don't have compile-time information about views, see+-- 'unsafeCallView'.+--+-- Example:+--+-- > callView contract #sum (123, -321)+callView+  :: forall name arg ret cp st vd m caps.+    ( MonadCleveland caps m, HasView vd name arg ret+    , NiceParameter arg, NiceViewable ret, NiceStorage ret+    , NiceParameter cp, KnownSymbol name, HasRPCRepr ret+    , T.IsoValue (AsRPC ret))+  => ContractHandle cp st vd -- ^ Contract to call.+  -> Label name -- ^ View name. Use @OverloadedLabels@ syntax.+  -> arg -- ^ Parameter to pass to the view.+  -> m (AsRPC ret)+callView = unsafeCallView @ret+  where _ = Dict @(HasView vd name arg ret) -- silence redundant constraint warning++-- | Version of 'callView' that doesn't check if the view exists in the type.+-- You'll have to specify the return type. You can use @TypeApplications@ syntax+-- for that.+--+-- If the view doesn't exist or has incorrect type, a test failure will be+-- thrown.+--+-- Note that first type argument is return type, the second is parameter type.+-- The reason for this inversion is you often only need to specify the return+-- type, while the parameter type can be either inferred or explicitly specified+-- with a type annotation on the parameter argument value.+--+-- Examples:+--+-- > unsafeCallView @() contract #id ()+-- Calls view @id@ with argument @unit@ and return type @unit@.+--+-- > unsafeCallView @(Integer, MText) contract #query [mt|hello|]+-- Calls view @query@ with argument @string@ and return type @pair int string@.+--+-- > unsafeCallView @Integer contract #sum (123 :: Natural, -321 :: Integer)+-- Calls view @sum@ with argument @pair nat int@ and return type @int@. Type+-- annotations are required due to polymorphic numeric literals.+--+-- This last example could also be written as+--+-- > unsafeCallView @Integer @(Natural, Integer) contract #sum (123, -321)+unsafeCallView+  :: forall ret arg name addr m caps.+    ( MonadCleveland caps m, NiceParameter arg, NiceViewable ret+    , NiceStorage ret, KnownSymbol name+    , HasRPCRepr ret, T.IsoValue (AsRPC ret)+    , ToContractAddress addr)+  => addr -- ^ Contract to call.+  -> Label name -- ^ View name. Use @OverloadedLabels@ syntax.+  -> arg -- ^ Parameter to pass to the view.+  -> m (AsRPC ret)+unsafeCallView (toContractAddress -> ch) _ arg = do+  Sender sender' <- Prelude.view senderL+  contractBalance <- getBalance ch+  let ct = runnerContract @name @arg @ret ch+      callFail = failure $ "Failed to call view " +| symbolValT' @name |++        ": either it doesn't exist or types don't match."+  res <- runCode RunCode+    { rcAmount = 0+    , rcBalance = contractBalance+    , rcSource = Just sender'+    , rcContract = ct+    , rcParameter = T.untypeValue $ T.toVal arg+    , rcStorage = T.untypeValue $ T.toVal (Nothing :: Maybe ret)+    , rcLevel = Nothing+    , rcNow = Nothing+    }+  maybe callFail pure res++-- | Contract that calls a view and saves the result to storage.+runnerContract+  :: forall name arg ret. (NiceParameter arg, NiceViewable ret, NiceStorage ret, KnownSymbol name)+  => ContractAddress -> Contract arg (Maybe ret) ()+runnerContract ch = flip Contract fakeDoc $ T.defaultContract $+  -- NB: It's not a Lorentz contract to avoid requiring NiceParameterFull and+  -- NiceStorageFull on arg and ret respectively.+  T.CAR :# T.DIP (T.PUSH $ toVal $ toAddress ch)+    :# T.VIEW (T.UnsafeViewName $ symbolValT' @name)+    :# T.NIL :# T.PAIR+  where+    fakeDoc = L.ContractCode $ L.fakeCoercing L.nop

@@ -1,8 +1,10 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Implementation that works with real Tezos network, it--- talks to a Tezos node and uses @tezos-client@.+-- talks to a Tezos node and uses @octez-client@.  module Test.Cleveland.Internal.Client   ( ClientM (..)@@ -34,7 +36,7 @@  import Control.Lens (_head, each, filtered) import Data.Aeson.Text qualified as J-import Data.Constraint (withDict, (\\))+import Data.Constraint (withDict) import Data.Default (def) import Data.Ratio ((%)) import Data.Set qualified as Set@@ -46,21 +48,23 @@  import Lorentz (NicePackedValue) import Lorentz qualified as L-import Lorentz.Constraints.Scopes (NiceUnpackedValue, niceParameterEvi)+import Lorentz.Constraints.Scopes (NiceUnpackedValue) import Morley.AsRPC (AsRPC, HasRPCRepr(..), TAsRPC, notesAsRPC, rpcSingIEvi)-import Morley.Client (MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, runMorleyClientM)+import Morley.Client+  (AliasBehavior(..), MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, runMorleyClientM) import Morley.Client qualified as Client import Morley.Client.Action (Result)+import Morley.Client.Action.Common (DelegationData(..), runErrorsToClientError) import Morley.Client.Action.Reveal qualified as RevealRPC import Morley.Client.App (failOnTimeout, retryOnceOnTimeout)-import Morley.Client.Init qualified as Client+import Morley.Client.Full 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(..), IntOpEvent(..), OriginationScript(..),   ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize))-import Morley.Client.TezosClient.Impl as TezosClient (getPublicKey, getSecretKey, importKey)+import Morley.Client.TezosClient.Impl qualified as TezosClient import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) import Morley.Client.Util qualified as Client import Morley.Micheline@@ -77,10 +81,11 @@   (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMulMutez,   unsafeSubMutez) import Morley.Tezos.Crypto+import Morley.Util.Constrained import Morley.Util.Exception import Morley.Util.Named import Test.Cleveland.Internal.Abstract-import Test.Cleveland.Internal.Exceptions (addCallStack)+import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Lorentz (toL1Address) import Test.Cleveland.Util (ceilingUnit) @@ -91,7 +96,7 @@   -> Client.MorleyOnlyRpcEnv mkMorleyOnlyRpcEnvNetwork NetworkEnv{..} extraSecrets =   Client.MorleyOnlyRpcEnv-  { moreLogAction = Client.mkLogAction 0+  { moreLogAction = Client.mkLogAction neVerbosity   , moreClientEnv = Client.mceClientEnv neMorleyClientEnv   , moreSecretKeys = mconcat       [ one (mkKeyAddress (toPublic sk), sk)@@ -133,6 +138,7 @@  instance Exception MoneybagConfigurationException where   displayException = pretty+  fromException = fromPossiblyAnnotatedException  data ClientState = ClientState   { csDefaultAliasCounter :: DefaultAliasCounter@@ -155,6 +161,7 @@  instance Exception InternalNetworkScenarioError where   displayException = pretty+  fromException = fromPossiblyAnnotatedException  runNetworkT :: NetworkEnv -> NetworkT ClientM a -> IO a runNetworkT env scenario = do@@ -208,24 +215,24 @@         failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek       return $ mkKeyAddress (toPublic ek) --- | Implementation that works with real network and uses @tezos-node@--- RPC and @tezos-client@.+-- | Implementation that works with real network and uses @octez-node@+-- RPC and @octez-client@. networkOpsImpl :: MorleyClientEnv -> Sender -> ClevelandOpsImpl ClientM networkOpsImpl env (Sender sender) =-  mapClevelandOpsImplExceptions (addCallStack . exceptionHandler)+  mapClevelandOpsImplExceptions (addCallStack . exceptionHandler env)     ClevelandOpsImpl     { coiRunOperationBatch = runOperationBatch env sender     }  networkMiscImpl :: NetworkEnv -> ClevelandMiscImpl ClientM networkMiscImpl env@NetworkEnv{..} =-  mapClevelandMiscImplExceptions (addCallStack . exceptionHandler) ClevelandMiscImpl+  mapClevelandMiscImplExceptions (addCallStack . exceptionHandler neMorleyClientEnv) ClevelandMiscImpl     { cmiRunIO = liftIO      , cmiOriginateLargeUntyped = \(Sender sender) UntypedOriginateData{..} -> do         let originationScenario =-              Client.originateLargeUntypedContract True uodName (AddressResolved sender)-                uodBalance uodContract uodStorage Nothing+              Client.originateLargeUntypedContract OverwriteDuplicateAlias uodName+                (AddressResolved sender) uodBalance uodContract uodStorage Nothing uodDelegate         -- 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@@ -247,14 +254,11 @@         alias <- resolveSpecificOrDefaultAlias sodAlias         liftIO $ runMorleyClientM neMorleyClientEnv $ Client.genFreshKey alias -    , cmiGetBalance = \(MkConstrainedAddress a) -> getBalanceHelper a+    , cmiGetBalance = foldConstrained getBalanceHelper     , cmiGetChainId = liftIO $ runMorleyClientM neMorleyClientEnv Client.getChainId     , cmiAttempt = try     , cmiThrow = throwM     , cmiMarkAddressRefillable = setAddressRefillable-    , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM neMorleyClientEnv $ do-        alias <- Client.getAlias (AddressResolved addr)-        Client.registerDelegate alias Nothing     , cmiComment = comment     , cmiUnderlyingImpl = pure $ Right env     , cmiFailure = clientFailure@@ -327,7 +331,7 @@     getBalanceHelper :: L1AddressKind kind => KindedAddress kind -> ClientM Mutez     getBalanceHelper = liftIO . runMorleyClientM neMorleyClientEnv . Client.getBalance -    cmiGetDelegate :: ContractAddress -> ClientM (Maybe KeyHash)+    cmiGetDelegate :: L1Address -> ClientM (Maybe KeyHash)     cmiGetDelegate =       liftIO . runMorleyClientM neMorleyClientEnv . Client.getDelegate @@ -389,7 +393,7 @@     cmiRunCode       :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st))       => Sender -> RunCode cp st vd -> ClientM (AsRPC st)-    cmiRunCode (Sender sender) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) =+    cmiRunCode (Sender sender) (RunCode rcContract rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) = do       liftIO $ runMorleyClientM neMorleyClientEnv do         -- Pattern match on the contract constructor to reveal         -- a proof of `NiceStorage st`@@ -405,7 +409,11 @@           , rcpNow = rcNow           , rcpSender = Just sender           }-          \\ L.niceStorageEvi @st+      `catch` \case+        err@(RPC.RunCodeErrors errs)+          | Just clientErr <- runErrorsToClientError errs+          -> throwM =<< exceptionToTransferFailure neMorleyClientEnv clientErr+          | otherwise -> throwM err  clientFailure :: Builder -> ClientM a clientFailure = throwM . CustomTestError . pretty@@ -418,8 +426,15 @@   => MorleyClientEnv   -> KindedAddress kind   -> ClientM (Alias kind)-getAlias env = liftIO . runMorleyClientM env . Client.getAlias . AddressResolved+getAlias env = liftIO . runMorleyClientM env . TezosClient.getAlias . AddressResolved +getAliasMaybe+  :: L1AddressKind kind+  => MorleyClientEnv+  -> KindedAddress kind+  -> ClientM (Maybe (Alias kind))+getAliasMaybe env = liftIO . runMorleyClientM env . Client.getAliasMaybe . AddressResolved+ getLastBlockTimestamp :: MorleyClientEnv -> ClientM UTCTime getLastBlockTimestamp env = liftIO $   bhnhTimestamp . bcHeader <$> runMorleyClientM env (Client.getBlockConstants HeadId)@@ -452,6 +467,11 @@         { rdPublicKey = key         , rdMbFee = Nothing         }+    OpDelegation delegate ->+      pure $ OpDelegation DelegationData+        { ddDelegate = delegate+        , ddMbFee = Nothing+        }    let refill :: Word -> Client.MorleyClientM Word       refill iter = do@@ -524,6 +544,7 @@               OpOriginate uod -> (uodBalance uod, originationSz)               OpTransfer td -> (tdAmount td, 0)               OpReveal _ -> (zeroMutez, 0)+              OpDelegation _ -> (zeroMutez, 0)             storageDiff AppliedResult{..} = safetyStorage + Unsafe.fromIntegral @TezosInt64 @Natural arPaidStorageDiff             storageBurnInBytes = originationSize + sum (map storageDiff appliedResults)             storageBurnInMutez = unsafeMulMutez costPerByte storageBurnInBytes@@ -548,6 +569,7 @@       comment $ "Originated smart contract '" +| alias |+         "' with address " <> pretty addr     OpReveal () -> pass+    OpDelegation () -> pass    mapM toClevelandResult results @@ -556,6 +578,7 @@   OpTransfer ops -> OpTransfer <$> mapM intOpEventToContractEvent ops   OpOriginate ops -> pure $ OpOriginate ops   OpReveal ops -> pure $ OpReveal ops+  OpDelegation ops -> pure $ OpDelegation ops  intOpEventToContractEvent :: IntOpEvent -> ClientM ContractEvent intOpEventToContractEvent IntOpEvent{..} = do@@ -605,19 +628,28 @@ findCantPayStorageFee (_:xs) = findCantPayStorageFee xs findCantPayStorageFee [] = False -exceptionToTransferFailure :: RPC.ClientRpcError -> ClientM TransferFailure-exceptionToTransferFailure = \case-  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+resolveAddressAndAlias :: MorleyClientEnv -> KindedAddress kind -> ClientM AddressAndAlias+resolveAddressAndAlias env addr =+   case addr of+     ImplicitAddress{} -> AddressAndAlias addr <$> getAliasMaybe env addr+     ContractAddress{} -> AddressAndAlias addr <$> getAliasMaybe env addr+     TxRollupAddress{} -> pure (AddressAndAlias addr Nothing) -exceptionHandler :: ClientM a -> ClientM a-exceptionHandler action = try action >>= \case-  Left err -> exceptionToTransferFailure err >>= throwM+exceptionToTransferFailure :: MorleyClientEnv -> RPC.ClientRpcError -> ClientM TransferFailure+exceptionToTransferFailure env = \case+    RPC.ContractFailed addr expr -> mkTransferFailure addr $ FailedWith (EOTVExpression expr) Nothing+    RPC.BadParameter (MkAddress addr) _ -> mkTransferFailure addr BadParameter+    RPC.EmptyTransaction addr -> mkTransferFailure addr EmptyTransaction+    RPC.ShiftOverflow addr -> mkTransferFailure addr ShiftOverflow+    RPC.GasExhaustion addr -> mkTransferFailure addr GasExhaustion+    internalError -> throwM internalError+    where+      mkTransferFailure :: KindedAddress kind -> TransferFailureReason -> ClientM TransferFailure+      mkTransferFailure addr e = TransferFailure <$> resolveAddressAndAlias env addr <*> pure e++exceptionHandler :: MorleyClientEnv -> ClientM a -> ClientM a+exceptionHandler env action = try action >>= \case+  Left err -> exceptionToTransferFailure env err >>= throwM   Right res -> return res  resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM ImplicitAlias@@ -651,12 +683,13 @@     throwLeft . pure $ typeCheckingWith def $       typeCheckContractAndStorage uodContract uodStorage   return Client.OriginationData-    { odReplaceExisting = True+    { odAliasBehavior = OverwriteDuplicateAlias     , odName = uodName     , odBalance = uodBalance     , odContract = contract     , odStorage = storage     , odMbFee = Nothing+    , odDelegate = uodDelegate     }  convertTransferData@@ -668,7 +701,7 @@     , tdEpName = tdEntrypoint     , tdParam = toVal param     , tdMbFee = Nothing-    } \\ niceParameterEvi @p+    }  -- | Runs 'Client.revealKeyUnlessRevealed' with given client environment. revealKeyUnlessRevealed :: MorleyClientEnv -> ImplicitAddress -> IO ()@@ -687,6 +720,7 @@  instance Exception TestError where   displayException = pretty+  fromException = fromPossiblyAnnotatedException  instance Buildable TestError where   build (CustomTestError msg) = build msg

@@ -1,87 +1,27 @@--- SPDX-FileCopyrightText: 2021 Oxhead Alpha+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- | This module defines common exception types and exception-related functions--- used throughout the "Test.Cleveland" modules.-module Test.Cleveland.Internal.Exceptions-  ( WithCallStack(..)-  , addCallStack-  , throwWithCallStack-  , tryWithCallStack-  , catchWithCallStack-  ) where--import Data.Typeable (cast)-import Fmt (Buildable(..), pretty, unlinesF)--------------------------------------------------------------------------------- WithCallStack--------------------------------------------------------------------------------- | Wraps an exception and adds some callstack information.-data WithCallStack where-  WithCallStack :: CallStack -> SomeException -> WithCallStack--deriving stock instance Show WithCallStack--instance Buildable WithCallStack where-  build (WithCallStack cstack e) = unlinesF-    [ prettyCallStack cstack-    , displayException e-    ]--instance Exception WithCallStack where-  displayException = pretty---- | Wrap any exceptions thrown by some monadic action with 'WithCallStack'.------ If the action throws an exception already wrapped in 'WithCallStack',--- that callstack will be overriden with the current one.-addCallStack :: forall m a. (HasCallStack, MonadCatch m) => m a -> m a-addCallStack ma =-  ma `catch` \se@(SomeException ex) ->-    case fromException @WithCallStack se of-      Just (WithCallStack _ innerEx) -> throwWithCallStack callStack innerEx-      Nothing -> throwWithCallStack callStack ex--throwWithCallStack :: forall e a m. (MonadThrow m, Exception e) => CallStack -> e -> m a-throwWithCallStack cstack ex = throwM (WithCallStack cstack (toException ex))+{-# OPTIONS_HADDOCK not-home #-} +-- | This module defines common exception helpers.+module Test.Cleveland.Internal.Exceptions+  ( ExceptionAnnotation(..)+  , annotateExceptions+  , fromPossiblyAnnotatedException --- | Similar to 'catch', but also catches exceptions of type @e@ wrapped in 'WithCallStack'.-catchWithCallStack-  :: forall e a m. (Exception e, MonadCatch m)-  => m a -> (Maybe CallStack -> e -> m a) -> m a-catchWithCallStack ma f =-  ma `catch` \(se :: SomeException) ->-    case fromExceptionWithCallStack @e se of-      Just (cstackMb, e) -> f cstackMb e-      Nothing -> throwM se+  -- * Utilities+  , lookupAnnEx+  , insertAnnEx+  , removeAnnEx --- | Attempts to run the given action.------ If it:------ * suceeds, the value will be returned in a 'Right'.--- * throws an exception of the given type @e@ (or an exception of---   type @e@ wrapped in 'WithCallStack'), it will be returned in a 'Left'.--- * throws an exception of any other type, it'll be rethrown---   (retaining the original callstack, if any).-tryWithCallStack :: forall e a m. (MonadCatch m, Exception e) => m a -> m (Either (Maybe CallStack, e) a)-tryWithCallStack ma =-  try @_ @SomeException ma >>= \case-    Right a -> pure (Right a)-    Left se ->-      case fromExceptionWithCallStack @e se of-        Just e -> pure (Left e)-        Nothing -> throwM se+  -- * Specific annotations+  , ErrorsClarification(..)+  , ScenarioBranchName(..)+  , CallStackAnnotation(..)+  , addCallStack+  ) where -fromExceptionWithCallStack :: forall e. Exception e => SomeException -> Maybe (Maybe CallStack, e)-fromExceptionWithCallStack se =-  (do-    WithCallStack cstack e <- fromException @WithCallStack se-    e' <- cast @_ @e e-    Just (Just cstack, e')-  )-  <|>-  (fromException @e se <&> (Nothing,))+import Test.Cleveland.Internal.Exceptions.Annotated+import Test.Cleveland.Internal.Exceptions.CallStack+import Test.Cleveland.Internal.Exceptions.ErrorsClarification+import Test.Cleveland.Internal.Exceptions.ScenarioBranchName

@@ -0,0 +1,183 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | This module defines annotated exceptions and machinery to work with them.+module Test.Cleveland.Internal.Exceptions.Annotated+  ( module Test.Cleveland.Internal.Exceptions.Annotated+  ) where++import Data.Dependent.Map qualified as Map+import Data.GADT.Compare (GCompare(..), GEq(..), GOrdering(..))+import Data.Typeable (cast, eqT)+import Fmt (Buildable(..), Builder, build, pretty)+import Text.Show qualified as Show (Show(..))+import Type.Reflection (typeRep)++-- $setup+-- >>> import Test.Cleveland.Internal.Abstract+-- >>> import Test.Cleveland.Internal.Exceptions.CallStack++----------------------------------------------------------------------------+-- AnnotatedException+----------------------------------------------------------------------------++-- | 'SomeException' augmented with arbitrary annotations.+data AnnotatedException = AnnotatedException AnnotationMap SomeException+  deriving stock Show++instance Exception AnnotatedException where+  displayException (AnnotatedException annmap e) =+    pretty $ printAnnotations annmap (displayException e)++-- | Insert a new annotation into 'AnnotatedException'.+insertAnnEx'+  :: (Semigroup ann, ExceptionAnnotation ann)+  => ann -> AnnotatedException -> AnnotatedException+insertAnnEx' ann (AnnotatedException anns ex) = AnnotatedException (insertAnn ann anns) ex++-- | Insert a new annotation into 'SomeException'.+--+-- If it's already an 'AnnotatedException', simply adds a new annotation.+-- Otherwise, wraps the exception into 'AnnotatedException' first.+insertAnnEx+  :: (Semigroup ann, ExceptionAnnotation ann)+  => ann -> SomeException -> SomeException+insertAnnEx ann se = toException $! case fromException @AnnotatedException se of+  Just ex -> insertAnnEx' ann ex+  Nothing -> AnnotatedException (singletonAnn ann) se++-- | Remove an annotation of the given type from 'AnnotatedException'.+removeAnnEx' :: forall ann. ExceptionAnnotation ann => AnnotatedException -> AnnotatedException+removeAnnEx' (AnnotatedException anns ex) = AnnotatedException (removeAnn @ann anns) ex++-- | Remove an annotation of the given type from 'SomeException'. If it's not an+-- 'AnnotatedException', this is a no-op.+removeAnnEx :: forall ann. ExceptionAnnotation ann => SomeException -> SomeException+removeAnnEx se = case fromException @AnnotatedException se of+  Just ex -> toException $ removeAnnEx' @ann ex+  Nothing -> se++-- | Extract the given annotation type from 'AnnotatedException' if possible.+lookupAnnEx' :: forall ann. (ExceptionAnnotation ann) => AnnotatedException -> Maybe ann+lookupAnnEx' (AnnotatedException anns _) = lookupAnn @ann anns++-- | Extract the given annotation type from 'SomeException' if possible.+lookupAnnEx :: forall ann. (ExceptionAnnotation ann) => SomeException -> Maybe ann+lookupAnnEx se = lookupAnnEx' =<< fromException @AnnotatedException se++{- | Try to extract a given exception type, skipping over annotations. This+essentially makes 'AnnotatedException' transparent for this function.++This is intended to be used as the default implementation of 'fromException' for+exception types that are expected to be annotated, as to make+'AnnotatedException' transparent for 'catch', 'try', etc.++For example:++@+instance Exception GenericTestError where+  displayException = pretty+  fromException = fromPossiblyAnnotatedException+@++Now, when catching @GenericTestError@, it'll work even if wrapped in+'AnnotatedException':++>>> try @_ @GenericTestError (addCallStack $ throwM UnexpectedSuccess)+Left UnexpectedSuccess++When catching exceptions not explicitly set up like this, this trick+unfortunately won't work, so using this function explicitly is required:++>>> data ExceptionToCatch = ExceptionToCatch deriving stock Show+>>> instance Exception ExceptionToCatch+>>> action = addCallStack $ throwM ExceptionToCatch+>>> try @_ @ExceptionToCatch action+*** Exception: AnnotatedException ...+...ExceptionToCatch+>>> :{+action `catch` \(err :: SomeException) -> case fromPossiblyAnnotatedException err of+  Just (err' :: ExceptionToCatch) -> pass+  Nothing -> throwM err+:}+-}+fromPossiblyAnnotatedException :: Exception e => SomeException -> Maybe e+fromPossiblyAnnotatedException se =+  (do+    AnnotatedException _ e <- fromException se+    fromException e+  ) <|> fromExceptionDefault se+  where+    fromExceptionDefault (SomeException e) = cast e++----------------------------------------------------------------------------+-- AnnotationMap+----------------------------------------------------------------------------++data Key ann where+  Key :: ExceptionAnnotation a => Key a++instance GEq Key where+  geq (Key :: Key a) (Key :: Key b) = eqT @a @b++instance GCompare Key where+  gcompare (Key :: Key a) (Key :: Key b) =+    case compare (annotationPriority @a) (annotationPriority @b) of+      LT -> GLT+      GT -> GGT+      EQ -> gcompare (typeRep @a) (typeRep @b)++-- | A map from 'Key' to corresponding annotation.+newtype AnnotationMap = AnnotationMap { unAnnotationMap :: Map.DMap Key Identity }++instance Show AnnotationMap where+  show = Map.showTreeWith (\Key -> Show.show) True False . unAnnotationMap++-- | Print all annotations from an 'AnnotationMap', given the initial message.+--+-- Essentially right-fold using 'displayAnnotation'.+printAnnotations :: Buildable a => AnnotationMap -> a -> Builder+printAnnotations (AnnotationMap annmap) = flip (Map.foldrWithKey go) annmap . build+  where+    go :: Key t -> Identity t -> Builder -> Builder+    go Key (Identity a) acc = displayAnnotation a acc++-- | Try to find the given type @t@ in an 'AnnotationMap'.+lookupAnn :: ExceptionAnnotation t => AnnotationMap -> Maybe t+lookupAnn (AnnotationMap anns) = runIdentity <$> Map.lookup Key anns++-- | Construct a singleton 'AnnotationMap'.+singletonAnn :: ExceptionAnnotation t => t -> AnnotationMap+singletonAnn = AnnotationMap . Map.singleton Key . Identity++-- | Insert a new annotation into an 'AnnotationMap'. If an annotation of this+-- type already exists, merge the annotations using the 'Semigroup' instance.+insertAnn :: (Semigroup t, ExceptionAnnotation t) => t -> AnnotationMap -> AnnotationMap+insertAnn x (AnnotationMap anns) = AnnotationMap $ Map.insertWith (<>) Key (Identity x) anns++-- | Remove an annotation of a given type @t@ from 'AnnotationMap'.+removeAnn :: forall t. ExceptionAnnotation t => AnnotationMap -> AnnotationMap+removeAnn (AnnotationMap am) = AnnotationMap $ Map.delete (Key @t) am++----------------------------------------------------------------------------+-- ExceptionAnnotation+----------------------------------------------------------------------------++-- | Type class for exception annotations.+class (Show ann, Typeable ann) => ExceptionAnnotation ann where+  -- | Given an annotation and the error message (as 'Builder'), produce the+  -- text annotated with the annotation.+  displayAnnotation :: ann -> Builder -> Builder++  -- | Relative priority for sorting annotations. Annotations with higher+  -- priority will be applied first. Default is @0@.+  annotationPriority :: Int+  annotationPriority = 0++-- | Add an annotation to exceptions thrown by a monadic action.+annotateExceptions+  :: forall m a ann. (MonadCatch m, Semigroup ann, ExceptionAnnotation ann)+  => ann -> m a -> m a+annotateExceptions ann ma = ma `catch` (throwM . insertAnnEx ann)

@@ -0,0 +1,55 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | This module defines 'CallStackAnnotation' and required helpers and+-- instances to use it with 'ExceptionAnnotation'.+module Test.Cleveland.Internal.Exceptions.CallStack+  ( CallStackAnnotation(..)+  , addCallStack+  ) where++import Fmt (build, unlinesF)+import GHC.Exception (SrcLoc(..), fromCallSiteList)+import GHC.Stack (popCallStack)++import Test.Cleveland.Internal.Exceptions.Annotated++-- | Newtype wrapper for 'CallStack' to avoid orphan instances.+--+-- Has instance of 'ExceptionAnnotation'.+newtype CallStackAnnotation = CallStackAnnotation { unCallStackAnnotation :: CallStack }+  deriving stock Show++-- | A convenience synonym for @annotateExceptions (CallStackAnnotation callStack)@.+addCallStack :: (MonadCatch m, HasCallStack) => m a -> m a+addCallStack = annotateExceptions (CallStackAnnotation $ popCallStack callStack)+-- NB: 'popCallStack' is required to hide 'addCallStack' itself from the stack.++instance ExceptionAnnotation CallStackAnnotation where+  displayAnnotation cs acc = unlinesF+    [ acc+    , ""+    , build $ prettyCallStack $ unCallStackAnnotation cs+    ]+  annotationPriority = -1000+  -- NB: we want call stacks to be basically printed last.++instance Semigroup CallStackAnnotation where+  a <> b = CallStackAnnotation $ unCallStackAnnotation a `mergeCallStacks` unCallStackAnnotation b++-- | Merge two 'CallStack's, removing duplicates, but keeping the ordering.+mergeCallStacks :: CallStack -> CallStack -> CallStack+mergeCallStacks a b = fromCallSiteList+  $ fmap (fmap unOrdSrcLoc)+  $ ordNub+  $ fmap (fmap OrdSrcLoc)+  $ getCallStack a <> getCallStack b++newtype OrdSrcLoc = OrdSrcLoc { unOrdSrcLoc :: SrcLoc }+  deriving newtype Eq++instance Ord OrdSrcLoc where+  compare (OrdSrcLoc (SrcLoc a b c d e f g)) (OrdSrcLoc (SrcLoc a' b' c' d' e' f' g'))+    = compare (a, b, c, d, e, f, g) (a', b', c', d', e', f', g')

@@ -0,0 +1,24 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | This module defines 'ErrorsClarification' and required instances to use it+-- with 'ExceptionAnnotation'.+module Test.Cleveland.Internal.Exceptions.ErrorsClarification+  ( ErrorsClarification(..)+  ) where++import Fmt (Builder, nameF)++import Test.Cleveland.Internal.Exceptions.Annotated++-- | Used to add text prefixes to exception messages.+--+-- Implementation detail of 'Test.Cleveland.clarifyErrors'.+newtype ErrorsClarification = ErrorsClarification [Builder]+  deriving stock Show+  deriving newtype Semigroup++instance ExceptionAnnotation ErrorsClarification where+  displayAnnotation (ErrorsClarification as) = flip (foldr nameF) as

@@ -0,0 +1,26 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# OPTIONS_HADDOCK not-home #-}++-- | This module defines 'ScenarioBranchName' and required instances to use it+-- with 'ExceptionAnnotation'.+module Test.Cleveland.Internal.Exceptions.ScenarioBranchName+  (ScenarioBranchName(..)+  ) where++import Fmt (Buildable(..), nameF, (+|), (|+))++import Test.Cleveland.Internal.Exceptions.Annotated++-- | When using 'Test.Cleveland.branchout' function for building test scenarios - names+-- of branches we are currently within.+newtype ScenarioBranchName = ScenarioBranchName { unTestBranch :: [Text] }+  deriving stock (Show, Eq)+  deriving newtype Semigroup++instance ExceptionAnnotation ScenarioBranchName where+  displayAnnotation ann = nameF ("In branch '" +| ann |+ "'")++instance Buildable ScenarioBranchName where+  build = mconcat . intersperse "/" . map build . unTestBranch

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Hedgehog-related helpers module Test.Cleveland.Internal.Hedgehog   ( MonadTest (..)@@ -19,7 +21,7 @@ import Hedgehog.Internal.Property (Failure(..), MonadTest(..), mkTest) import Hedgehog.Internal.Source (ColumnNo(..), LineNo(..), Span(..)) -import Test.Cleveland.Internal.Exceptions (WithCallStack(..))+import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Internal.Pure import Test.Cleveland.Internal.Scenario @@ -33,11 +35,8 @@  failWithException :: (HasCallStack, MonadTest m) => SomeException -> m a failWithException e =-  case fromException @WithCallStack e of-    Just (WithCallStack cs _) -> failWithCallStack cs message-    _                         -> failWithCallStack callStack message-  where-    message = formatException e+  failWithCallStack (fromMaybe callStack $ unCallStackAnnotation <$> lookupAnnEx e) $+    formatException e  failWithCallStack :: (MonadTest m) => CallStack -> String -> m a failWithCallStack cs message = liftTest $ mkTest

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Integration with integrational testing engine (pun intended). module Test.Cleveland.Internal.Pure   ( PureM(..)@@ -17,9 +19,7 @@   , initEnv    -- * Support functions-  , failedInsideBranch   , moneybagAlias-  , emptyScenarioBranch    -- * Optics   , psSecretKeys@@ -31,7 +31,7 @@   , psGState   ) where -import Control.Lens (assign, at, each, makeLenses, modifying, to, (%=), (.=), (?=), (?~))+import Control.Lens (assign, at, makeLenses, modifying, to, (%=), (.=), (?=), (?~)) import Control.Lens.Unsound (lensProduct) import Control.Monad.Catch.Pure (CatchT, runCatchT) import Control.Monad.Writer (MonadWriter, WriterT, listen, runWriterT, tell)@@ -51,33 +51,32 @@ import Morley.Michelson.Interpret   (InterpretError(..), InterpretResult(..), MichelsonFailed(..), MichelsonFailureWithStack(..)) import Morley.Michelson.Runtime hiding (ExecutorOp(..), transfer)-import Morley.Michelson.Runtime qualified as Runtime (ExecutorOp(..))+import Morley.Michelson.Runtime qualified as Runtime import Morley.Michelson.Runtime.Dummy   (dummyLevel, dummyMaxSteps, dummyMinBlockTime, dummyNow, dummyOrigination) import Morley.Michelson.Runtime.GState-  (GState(..), genesisAddress, genesisSecretKey, gsChainIdL, gsContractAddressAliasesL,-  gsContractAddressesL, gsCounterL, gsImplicitAddressAliasesL, gsVotingPowersL, initGState,-  lookupBalance)-import Morley.Michelson.TypeCheck-  (BigMapFinder, TCError(..), TypeCheckOptions(..), typeCheckContractAndStorage,-  typeCheckValueRunCodeCompat, typeCheckingWith)+  (AddressStateFam, GState(..), ImplicitState(..), addressesL, genesisAddress, genesisSecretKey,+  gsChainIdL, gsContractAddressAliasesL, gsContractAddressesL, gsImplicitAddressAliasesL,+  gsVotingPowersL, initGState, lookupBalance)+import Morley.Michelson.TypeCheck (TcError, typeCheckContractAndStorage, typeCheckingWith) import Morley.Michelson.Typed-  (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), SomeConstrainedValue(SomeValue),-  SomeVBigMap(..), SomeValue, ToT, Value, Value'(..), castM, dfsFoldMapValue, fromVal, toVal)+  (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), SomeVBigMap(..), ToT, Value, Value'(..),+  castM, fromVal, toVal) import Morley.Michelson.Typed qualified as T import Morley.Michelson.Typed.Operation-  (EmitOperation(..), OriginationOperation(..), TransferOperation(..))+  (EmitOperation(..), OriginationOperation(..), SetDelegateOperation(..), TransferOperation(..)) import Morley.Michelson.Untyped qualified as U 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.Tezos.Crypto (KeyHash, SecretKey(..), detSecretKey, sign, toPublic)+import Morley.Util.Constrained 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.Internal.Exceptions import Test.Cleveland.Lorentz import Test.Cleveland.Util (ceilingUnit) @@ -103,7 +102,7 @@                     MonadReader (IORef PureState), MonadWriter LogsInfo, MonadFail)  data TestError-  = UnexpectedTypeCheckError TCError+  = UnexpectedTypeCheckError TcError   | UnexpectedStorageType (MismatchError T.T)   | UnexpectedBigMapType Natural (MismatchError T.T)   | CustomTestError Text@@ -126,6 +125,7 @@  instance Exception TestError where   displayException = pretty+  fromException = fromPossiblyAnnotatedException  moneybagAlias :: ImplicitAlias moneybagAlias = ImplicitAlias "moneybag"@@ -151,8 +151,7 @@         forM_ scenarios $ \(name, scenario) -> do           aliasesState <- get           newRef <- newIORef aliasesState-          local (\_ -> newRef) scenario `catchWithCallStack` \originalCallStackMb err ->-            maybe throwM throwWithCallStack originalCallStackMb $ failedInsideBranch name err+          local (\_ -> newRef) scenario & annotateExceptions (ScenarioBranchName [name])       , eiGetStorage = addCallStack . exceptionHandler . getStorageImpl     , eiGetMorleyLogs = getMorleyLogsImpl     , eiSetVotingPowers = assign (psGState . gsVotingPowersL)@@ -164,7 +163,7 @@     ClevelandOpsImpl     { coiRunOperationBatch = mapM \case         OpOriginate UntypedOriginateData{..} -> do-          OpOriginate <$> originate uodContract uodName uodStorage uodBalance+          OpOriginate <$> originate uodContract uodName uodStorage uodBalance uodDelegate         OpTransfer TransferData{..} -> do           let fromAddr = #from :! sender           let toAddr = #to :! toL1Address tdTo@@ -187,6 +186,7 @@         OpReveal{} -> do           -- We do not care about reveals in our Morley runtime           return $ OpReveal ()+        OpDelegation mbAddress -> OpDelegation <$> setDelegate sender mbAddress     }  emitOpToContractEvent :: EmitOperation -> ContractEvent@@ -231,10 +231,9 @@     , cmiComment = const pass     , cmiGetPublicKey = \addr -> do         toPublic <$> getSecretKey addr-    , cmiGetDelegate = \addr -> do-        ContractState _ _ _ delegate <- contractStorage addr-        pure delegate-    , cmiRegisterDelegate = const pass+    , cmiGetDelegate = \(Constrained addr) -> addressState addr <&> case addr of+        ContractAddress{} -> csDelegate+        ImplicitAddress{} -> isDelegate     , cmiGetChainId = use $ psGState . gsChainIdL     , cmiAdvanceTime = \time -> do         modifying psNow . flip timestampPlusSeconds $@@ -250,7 +249,7 @@     , cmiAttempt = try     , cmiThrow = throwM     , cmiMarkAddressRefillable = setAddressRefillable-    , cmiGetBalance = \(MkConstrainedAddress a) -> getBalance a+    , cmiGetBalance = foldConstrained getBalance     , cmiUnderlyingImpl = pure $ Left emulatedImpl     , cmiFailure = failure     , ..@@ -260,7 +259,7 @@      originateUntyped :: Sender -> UntypedOriginateData 'IsLarge -> PureM ContractAddress     originateUntyped _ UntypedOriginateData {..} = do-      originate uodContract uodName uodStorage uodBalance+      originate uodContract uodName uodStorage uodBalance uodDelegate      cmiGetBigMapValueMaybe       :: forall k v.@@ -284,7 +283,7 @@       VBigMap _ bigMap <- findBigMapByIdMaybe @(ToT k) @(ToT v) bmId       pure $ fromVal @v <$> Map.elems bigMap -    -- | In a real chain, when we retrieve a contract's storage via the Tezos RPC,+    -- 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.     --     -- Here, we mimic the RPC's behaviour.@@ -296,7 +295,7 @@     --   * A contract's code is run and it calls `EMPTY_BIG_MAP`, `DUP` or `DUP n`.     cmiGetSomeStorage :: ContractAddress -> PureM SomeAnnotatedValue     cmiGetSomeStorage addr = do-      ContractState _ contract (storage :: Value t) _ <- contractStorage addr+      ContractState _ contract (storage :: Value t) _ <- addressState addr       pure $         SomeAnnotatedValue           (notesAsRPC $ T.cStoreNotes contract)@@ -336,87 +335,38 @@       :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st))       => Sender -> RunCode cp st vd -> PureM (AsRPC st)     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 <- typeCheckVal @(ToT cp) rcParameter-      storage <- typeCheckVal @(ToT st) rcStorage+      contract@T.Contract{..} <- pure $ L.toMichelsonContract rcContract+      T.MkEntrypointCallRes _ (epc :: T.EntrypointCallT (T.ToT cp) arg) <- pure $+        T.mkDefEntrypointCall cParamNotes        (now, level) <- use $ psNow `lensProduct` psLevel-      psNow %= maybe id const rcNow-      psLevel %= maybe id const rcLevel-      res <- interpret do-        counter0 <- use $ esGState . gsCounterL-        contractAddr <--          executeOrigination ! #isGlobalOp True $-            (dummyOrigination storage (L.toMichelsonContract rcContract) counter0) { ooBalance = zeroMutez }-              \\ L.niceStorageEvi @st-              \\ L.niceParameterEvi @cp--        esSourceAddress .= (MkConstrainedAddress <$> rcSource)-        counter1 <- use $ esGState . gsCounterL-        let overrideContractBalance = Just rcBalance-        executeTransfer (#isGlobalOp :! False) overrideContractBalance def $-          TransferOperation-            { toDestination = MkAddress contractAddr-            , toCounter = counter1-            , toTxData = TxData-              { tdSenderAddress = MkConstrainedAddress sender-              , tdParameter = TxTypedParam param \\ L.niceParameterEvi @cp-              , tdEntrypoint = DefEpName-              , tdAmount = rcAmount-              }+      knownContracts <- use $ psGState . gsContractAddressesL+      bigMapFinder <- registerInterpretation Runtime.mkBigMapFinder+      let tcBm :: forall (t :: T.T). T.SingI t => U.Value -> PureM (T.Value t)+          tcBm = either (throwM . UnexpectedTypeCheckError) pure .+            resolveRunCodeBigMaps bigMapFinder+      rcParameterT <- tcBm rcParameter+      rcStorageT <- tcBm rcStorage+      (_, finalStorage) <- either (throwEE . EEInterpreterFailed (toAddress sender)) pure $+        Runtime.runCode+          (Runtime.runCodeParameters contract rcStorageT epc rcParameterT)+            { Runtime.rcAmount = rcAmount+            , Runtime.rcLevel = fromMaybe level rcLevel+            , Runtime.rcNow = fromMaybe now rcNow+            , Runtime.rcBalance = rcBalance+            , Runtime.rcSource = Constrained $ fromMaybe genesisAddress rcSource+            , Runtime.rcKnownContracts = knownContracts+            , Runtime.rcSender = Constrained sender             }-        pure contractAddr-      psNow .= now-      psLevel .= level-      case res of-        Left executorError -> throwEE executorError-        Right (executorRes, contractAddr) -> do-          -- Find the storage of the contract and return it in its RPC representation.-          case executorRes ^. erGState . gsContractAddressesL . at contractAddr of-            Nothing ->-              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-        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--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+      pure $ fromVal $ valueAsRPC finalStorage  -- | 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+  SomeVBigMap (v@VBigMap{} :: Value t) <- MaybeT $+    registerInterpretation Runtime.mkBigMapFinder <*> pure bigMapId   castM @t @('T.TBigMap k v) v $ throwM . UnexpectedBigMapType bigMapId  isAddressRefillable :: ImplicitAddress -> PureM Bool@@ -463,19 +413,13 @@   => addr -> PureM st getStorageImpl addr = do   withDict (pickNiceStorage @st addr) $ do-    ContractState _ _ (storage :: Value actualT) _ <- contractStorage (toContractAddress addr)+    ContractState _ _ (storage :: Value actualT) _ <- addressState (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 :: ContractAddress -> PureM ContractState-contractStorage addr = do-  GState{..} <- use psGState-  case Map.lookup addr gsContractAddresses of-    Just contractState -> pure contractState-    Nothing -> unknownAddress addr+addressState :: KindedAddress kind -> PureM (AddressStateFam kind)+addressState addr = maybe (unknownAddress addr) pure =<<+  use (psGState . addressesL addr . at addr)  resolveImplicit :: ImplicitAlias -> PureM ImplicitAddress resolveImplicit alias = do@@ -495,16 +439,6 @@   throwM . CustomTestError .   mappend "Unknown address alias: " . pretty --- | Make branch names for a case when we are not within any branch.-emptyScenarioBranch :: ScenarioBranchName-emptyScenarioBranch = ScenarioBranchName []---- | Add a new branch element to names provided by inner--- 'Test.Cleveland.branchout' calls.-appendScenarioBranch :: Text -> ScenarioBranchName -> ScenarioBranchName-appendScenarioBranch brName (ScenarioBranchName branches) =-  ScenarioBranchName (brName : branches)- failure :: forall a. Builder -> PureM a failure = throwM . CustomTestError . pretty @@ -529,13 +463,6 @@   , _psMinBlockTime = dummyMinBlockTime   } -failedInsideBranch :: Text -> SomeException -> FailedInBranch-failedInsideBranch name err = case fromException @FailedInBranch err of-  Just (FailedInBranch branch exception) ->-    FailedInBranch (appendScenarioBranch name branch) exception-  Nothing ->-    FailedInBranch (appendScenarioBranch name emptyScenarioBranch) err- ---------------------------------------------------------------------------- -- Emulator internals ----------------------------------------------------------------------------@@ -558,9 +485,8 @@           { toDestination = to'           , toCounter = 0           , toTxData = TxData-            { tdSenderAddress = MkConstrainedAddress from-            , tdParameter = withDict (T.properParameterEvi @(ToT epArg)) $-                TxTypedParam (T.toVal param)+            { tdSenderAddress = Constrained from+            , tdParameter = TxTypedParam (T.toVal param)             , tdEntrypoint = epName             , tdAmount = money             }@@ -568,8 +494,8 @@  -- | Originate a contract with given initial storage and balance. Its -- address is returned.-originate :: U.Contract -> ContractAlias -> U.Value -> Mutez -> PureM ContractAddress-originate uContract alias uStorage balance =+originate :: U.Contract -> ContractAlias -> U.Value -> Mutez -> Maybe KeyHash -> PureM ContractAddress+originate uContract alias uStorage balance delegate =   case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of     Left tcErr -> throwM $ UnexpectedTypeCheckError tcErr     Right (T.SomeContractAndStorage contract storage) -> do@@ -578,6 +504,7 @@         (dummyOrigination storage contract counter)           { ooBalance = balance           , ooAlias = Just alias+          , ooDelegate = delegate           }  throwEE :: ExecutorError -> PureM a@@ -586,12 +513,14 @@   traverse addrToAddressAndAlias err >>= throwM   where     addrToAddressAndAlias :: Address -> PureM AddressAndAlias-    addrToAddressAndAlias addr@(MkAddress kindedAddr) =+    addrToAddressAndAlias (MkAddress kindedAddr) =       case kindedAddr of         ContractAddress{} ->-          use $ psGState . gsContractAddressAliasesL . Bimap.flipped . at kindedAddr . to (AddressAndAlias addr)+          use $ psGState . gsContractAddressAliasesL . Bimap.flipped . at kindedAddr . to (AddressAndAlias kindedAddr)+        ImplicitAddress{} ->+          use $ psGState . gsImplicitAddressAliasesL . Bimap.flipped . at kindedAddr . to (AddressAndAlias kindedAddr)         _ ->-          pure $ AddressAndAlias addr Nothing+          pure $ AddressAndAlias kindedAddr Nothing  -- | Runs a set of operations and updates the engine's state. registerInterpretation :: ExecutorM a -> PureM a@@ -621,3 +550,12 @@   gState <- use psGState   minBlockTime <- use psMinBlockTime   pure $ runExecutorM now level minBlockTime dummyMaxSteps gState action++setDelegate :: ImplicitAddress -> Maybe KeyHash -> PureM ()+setDelegate addr mbKh = void $ registerInterpretation $+  executeGlobalOperations def $ one $+    Runtime.SetDelegateOp SetDelegateOperation+      { sdoContract = Constrained addr+      , sdoDelegate = mbKh+      , sdoCounter = 0+      }

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ module Test.Cleveland.Internal.Scenario   ( Scenario   , Scenario'(..)

@@ -20,8 +20,6 @@    -- * Basic types   , ContractHandle (..)-  , chNiceParameterEvi-  , chNiceStorageEvi    , ToContractAddress (..)   , ToL1Address (..)

@@ -1,8 +1,9 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- | Internal utilities for unit testing.+{-# OPTIONS_HADDOCK not-home #-} +-- | Internal utilities for unit testing. module Test.Cleveland.Lorentz.Internal.Entrypoints   ( -- * Entrypoint spec passed on the type level     testCompareContractEntrypointsT@@ -17,10 +18,11 @@  import Lorentz hiding (contract) +import Data.Map qualified as Map import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (testCase) -import Morley.Michelson.Typed (convertContract, flattenEntrypoints)+import Morley.Michelson.Typed (HandleImplicitDefaultEp(..), convertContract, flattenEntrypoints) import Morley.Michelson.Untyped qualified as U import Morley.Util.Named @@ -48,9 +50,9 @@      (M.EPMismatch -> M.EPMismatch)   -> TestName -> ContractEPTypeTest expectedEps testCompareContractEntrypointsT compareMode name contract =-  withDict (niceParameterEvi @expectedEps) $-    let entrypoints = flattenEntrypoints $ parameterEntrypointsToNotes @expectedEps-    in testCompareContractEntrypoints compareMode name contract entrypoints+  let entrypoints = flattenEntrypoints WithoutImplicitDefaultEp $+        parameterEntrypointsToNotes @expectedEps+  in testCompareContractEntrypoints compareMode name contract entrypoints  -- | Expect the contract to match with the entrypoints given in spec (with matching types). -- Checks both the contract type and the contract itself (when represented as an untyped Michelson@@ -63,14 +65,16 @@   => (M.EPMismatch -> M.EPMismatch)   -> TestName -> ContractEPTest contractEps st vd testCompareContractEntrypoints compareMode name contract@Contract{} spec =-  withDict (niceParameterEvi @contractEps) $-  withDict (niceStorageEvi @st) $-    let entrypointsInType = flattenEntrypoints $ parameterEntrypointsToNotes @contractEps-        contract' = convertContract . toMichelsonContract $ contract-    in testGroup name-        [ testCase "Contract type matches entrypoint spec" $-            M.assertEPComparisonSuccessful . Right . compareMode $-              M.compareEntrypoints (#expected :! spec) (#actual :! entrypointsInType)-        , M.testContractEntrypoints compareMode-            "Untyped contract matches entrypoint spec" contract' spec-        ]+  let entrypointsInType = flattenEntrypoints wantsDefaultEp $+        parameterEntrypointsToNotes @contractEps+      wantsDefaultEp+        | Map.member DefEpName spec = WithImplicitDefaultEp+        | otherwise = WithoutImplicitDefaultEp+      contract' = convertContract . toMichelsonContract $ contract+  in testGroup name+      [ testCase "Contract type matches entrypoint spec" $+          M.assertEPComparisonSuccessful . Right . compareMode $+            M.compareEntrypoints (#expected :! spec) (#actual :! entrypointsInType)+      , M.testContractEntrypoints compareMode+          "Untyped contract matches entrypoint spec" contract' spec+      ]

@@ -9,7 +9,7 @@ -- _active_ - you call it, not the contract containing the view, in order to -- access the view. ----- TODO [#708]: mention that calling views directly should be preferred.+-- Prefer using @callView@ or @unsafeCallView@. module Test.Cleveland.Lorentz.Requester   ( contractRequester   ) where

@@ -32,7 +32,9 @@   -> Contract (View_ (payload, (Natural, td)) callbackArg) () () ticketerContract' mkCallbackArg = defaultContract $   unpair # view_-    ( dip (drop @()) # unpair # dip (unpair # swap # ticket) # framed mkCallbackArg+    ( dip (drop @()) # unpair #+      dip (unpair # swap # ticket # assertSome @MText "Zero amount tickets are not allowed") #+      framed mkCallbackArg     )  -- | A simpler version of 'ticketerContract\'' where the target

@@ -4,8 +4,6 @@ -- | Basic types for the test framework. module Test.Cleveland.Lorentz.Types   ( ContractHandle (..)-  , chNiceParameterEvi-  , chNiceStorageEvi   , L1TAddress (..)    , ToContractAddress (..)@@ -26,12 +24,11 @@   -- $noteTAddress   ) where -import Data.Constraint (Dict(..), mapDict)+import Data.Constraint (Dict(..)) import Fmt (Buildable(..), (+|), (|+))  import Lorentz.Address import Lorentz.Constraints-import Morley.Michelson.Typed qualified as T import Morley.Tezos.Address import Morley.Tezos.Address.Alias @@ -66,16 +63,6 @@ instance ToContractRef arg (TAddress cp vd) => ToContractRef arg (ContractHandle cp st vd) where   toContractRef = toContractRef . toTAddress @cp --- | Extract the evidence in typed Michelson that the parameter type is valid--- for such scope.-chNiceParameterEvi :: forall param st vd. ContractHandle param st vd -> Dict (T.ParameterScope $ T.ToT st)-chNiceParameterEvi ContractHandle{} = mapDict (niceParameterEvi @st) Dict---- | Extract the evidence in typed Michelson that the storage type is valid--- for such scope.-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 @@ -95,10 +82,10 @@   toL1Address = id  instance L1AddressKind kind => ToL1Address (KindedAddress kind) where-  toL1Address = MkConstrainedAddress+  toL1Address = Constrained  instance ToL1Address (ContractHandle cp st vd) where-  toL1Address = MkConstrainedAddress . chAddress+  toL1Address = Constrained . chAddress  -- | Counterpart of 'TAddress' that contains 'L1Address' instead of 'Address'. newtype L1TAddress cp vd = L1TAddress { unL1TAddress :: L1Address }

@@ -1,8 +1,9 @@ -- SPDX-FileCopyrightText: 2022 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA --- | Internal utilities for unit testing.+{-# OPTIONS_HADDOCK not-home #-} +-- | Internal utilities for unit testing. module Test.Cleveland.Michelson.Internal.Entrypoints   ( EPList   , EPMismatch(.., EPComparisonResultOK)@@ -27,7 +28,7 @@ import Morley.Michelson.Parser (MichelsonSource(MSUnspecified)) import Morley.Michelson.Printer (printUntypedContract) import Morley.Michelson.Runtime (parseExpandContract)-import Morley.Michelson.TypeCheck (TCError, mkSomeParamType)+import Morley.Michelson.TypeCheck (TcTypeError, mkSomeParamType) import Morley.Michelson.Untyped hiding (Contract) import Morley.Michelson.Untyped qualified as U import Morley.Util.MismatchError (MismatchError(..))@@ -84,18 +85,24 @@  -- | Check if the contract exactly matches the given entrypoints. Will report both -- missing and extraneous entrypoint names, and type mismatches.-contractMatchesEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TCError EPMismatch+contractMatchesEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TcTypeError EPMismatch contractMatchesEntrypoints (contractParameter -> pt) expected = case mkSomeParamType pt of-  Right{} -> Right $ compareEntrypoints (#expected :! expected) (#actual :! mkEntrypointsMap pt)+  Right{} -> Right $ compareEntrypoints+    (#expected :! expected)+    (#actual :! mkEntrypointsMap wantsDefaultEp pt)   Left err -> Left err+  where+    wantsDefaultEp+      | Map.member DefEpName expected = WithImplicitDefaultEp+      | otherwise = WithoutImplicitDefaultEp  -- | Check if the contract contains the entrypoints given in spec (with matching types). -- Ignores any additional entrypoints present in the contract.-contractCoversEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TCError EPMismatch+contractCoversEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TcTypeError EPMismatch contractCoversEntrypoints = second ignoreExtraEntrypoints ... contractMatchesEntrypoints --- | Turn 'Either' 'TCError' 'EPMismatch' into an 'Assertion'-assertEPComparisonSuccessful :: Either TCError EPMismatch -> Assertion+-- | Turn 'Either' 'TcTypeError' 'EPMismatch' into an 'Assertion'+assertEPComparisonSuccessful :: Either TcTypeError EPMismatch -> Assertion assertEPComparisonSuccessful = \case   Right EPComparisonResultOK -> pass   Left tcerr -> assertFailure $ pretty tcerr

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | This module is the internal implementation of "Test.Cleveland.Tasty". module Test.Cleveland.Tasty.Internal   (@@ -54,7 +56,7 @@ import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) 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.Exceptions import Test.Cleveland.Internal.Pure as Pure (PureM, runEmulatedT) import Test.Cleveland.Internal.Scenario import Test.Cleveland.Tasty.Internal.Options@@ -133,13 +135,11 @@  printFormattedException :: OptionSet -> SomeException -> IO Result printFormattedException opts se =-  case fromException @WithCallStack se of-    Nothing ->-      pure (testFailed $ displayException se)--    Just (WithCallStack cs ex) -> do-      msg <- formatError contextLines cs (displayException ex)-      pure (testFailed (pretty msg))+  case lookupAnnEx se of+    Nothing -> pure $ testFailed $ displayException se+    Just (CallStackAnnotation cs) -> testFailed . pretty <$> formatError contextLines cs (+      displayException $ removeAnnEx @CallStackAnnotation se+      )   where     ContextLinesOpt contextLines = lookupOption opts @@ -219,6 +219,7 @@             , neSecretKey = sk             , neMoneybagAlias = origAlias             , neExplicitDataDir = isJust dataDir+            , neVerbosity = verbosity             }  -- | Heuristics to check whether we are running within CI.

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | This module declares all options/flags that @tasty@ will -- parse from the command line/environment variables. --@@ -78,9 +80,9 @@   deriving stock (Show, Eq)  instance IsOption PathOpt where-  defaultValue = PathOpt "tezos-client"+  defaultValue = PathOpt "octez-client"   optionName = "cleveland-client-path"-  optionHelp = "[Test.Cleveland] Path to tezos-client binary"+  optionHelp = "[Test.Cleveland] Path to `octez-client` binary"   parseValue = mkParseValue PathOpt   optionCLParser = mkOptionParser PathOpt (Just 'I') @@ -90,7 +92,7 @@ instance IsOption DataDirOpt where   defaultValue = DataDirOpt Nothing   optionName = "cleveland-data-dir"-  optionHelp = "[Test.Cleveland] Path to tezos-client data directory"+  optionHelp = "[Test.Cleveland] Path to `octez-client` data directory"   parseValue = mkParseValue (DataDirOpt . Just)   optionCLParser = mkOptionParser (DataDirOpt . Just) (Just 'd') 

@@ -1,6 +1,8 @@ -- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA +{-# OPTIONS_HADDOCK not-home #-}+ -- | Pretty-printers for reports in Tasty logs. module Test.Cleveland.Tasty.Internal.Report   ( formatError

@@ -90,9 +90,10 @@   RatioNat, Second, Time, mcs, minute, ms, ns, sec, time, timeout, toUnit, unTime, unitNameVal)  import Morley.Michelson.Doc (DocItem, docItemPosition)-import Morley.Michelson.Typed (SingI, SomeConstrainedValue(..))+import Morley.Michelson.Typed (SingI, SomeConstrainedValue) import Morley.Michelson.Typed qualified as T import Morley.Tezos.Address+import Morley.Util.Constrained  import Test.Cleveland.Instances () @@ -301,7 +302,7 @@ formatValue v = "" +| build v |+ " of type " +| demote @t |+ ""  formatSomeValue :: (forall t. c t => SingI t) => SomeConstrainedValue c -> Builder-formatSomeValue (SomeConstrainedValue v) = formatValue v+formatSomeValue = foldConstrained formatValue  -- | Derive a 'Show' instance for a type using a custom "show" function. -- Note: the `show`n value is paren-wrapped iff it's a subexpression,

@@ -10,7 +10,7 @@   , test_callStack_property   ) where -import Lorentz hiding (assert, comment, not)+import Lorentz hiding (assert, comment, not, or) import Lorentz qualified as L import Unsafe qualified @@ -31,12 +31,14 @@ import Morley.Client.TezosClient (tceEndpointUrlL) import Morley.Michelson.Typed (convertContract, untypeValue) import Morley.Tezos.Address-import Morley.Util.Interpolate (it, lit)+import Morley.Util.Interpolate (it, lit, litu) import Morley.Util.SizedList.Types import Test.Cleveland import Test.Cleveland.Internal.Client (neMorleyClientEnvL)+import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Internal.Pure (TestError(CustomTestError)) import Test.Cleveland.Tasty+import TestSuite.Cleveland.CallStack.Fixtures  import TestSuite.Util   (idContract, outcomeIsFailure, runPropertyViaTasty, runViaTastyOnEmulator, runViaTastyOnNetwork)@@ -500,8 +502,7 @@         [lit|                   getStorage @() invalidContractAddr                   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-                  | In 'a' branch:-                  | Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye+                  | In branch 'a': Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye         |]         do           branchout@@ -510,12 +511,26 @@                   getStorage @() invalidContractAddr             ]     , testFailureIncludesCallStackOnEmulator+        "when a nested branchout branch throws, the callstack branch name is correct"+        [lit|+                  void $ getStorage @() invalidContractAddr+                         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+                         | In branch 'a/b': Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye+        |]+        do+          branchout+            [ "a" ?-+              branchout+                ["b" ?-+                  void $ getStorage @() invalidContractAddr+                ]+            ]+    , testFailureIncludesCallStackOnEmulator         "when a branchout branch throws ANY exception, the exception raised is printed in a right way"         [lit|                 runIO $ throwM DummyException                 ^^^^^-                | In 'a' branch:-                | DummyException+                | In branch 'a': DummyException          |]         do@@ -529,8 +544,7 @@         [lit|               getStorage @() invalidContractAddr               ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-              | In 'a' branch:-              | Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye+              | In branch 'a': Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye          |]         do@@ -670,25 +684,37 @@     invalidTAddr = ContractHandle @() @() @() "asdf" invalidContractAddr  test_callStack_property :: TestTree-test_callStack_property =-  testGroup "Error messages of property tests include a helpful callstack" $+test_callStack_property = let+  fixturePath = "test" </> "TestSuite" </> "Cleveland" </> "CallStack" </> "Fixtures.hs"+  in testGroup "Error messages of property tests include a helpful callstack" $     [ testFailureIncludesCallStackProperty "callstack points to line which led scenario to error"         [lit|     f x y = x @== y     ^^^^^^^^^^^^^^^         |]         dummyProp-    , testFailureIncludesCallStackProperty "callstack does not point to internals when a pure error is thrown"-        -- TODO [#818]: include the actual error message+    , testFailureIncludesCallStackProperty' "callstack does not point to internals when a pure error is thrown"         -- NB: a single quote with two of these lines unindented causes tasty to output a different error message-        (List.unlines-          [ [lit|dummyPropWithPureError = property $ testScenarioProps $ scenario do|]-          , [lit|^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^|]])+        ([litu|+           dummyPropWithPureError :: Property+           dummyPropWithPureError = property $ testScenarioProps $ scenario do+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+           │ ━━━ Exception (ErrorCall) ━━━+           │ Pure error+           │ CallStack (from HasCallStack):+           │   error, called at test/TestSuite/Cleveland/CallStack/Fixtures.hs:15:5 in main:TestSuite.Cleveland.CallStack.Fixtures+               error "Pure error" @== (1 :: Int)+           |])+        fixturePath         dummyPropWithPureError-    , testFailureIncludesCallStackProperty "callstack does not point to internals when a nested pure error is thrown"-        (List.unlines-          [ [lit|dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do|]-          , [lit|^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^|]])+    , testFailureIncludesCallStackProperty' "callstack does not point to internals when a nested pure error is thrown"+        ([litu|+           dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+           │ ━━━ Exception (ErrorCall) ━━━+           │ unsafeSubMutez: underflow+           |])+        fixturePath         dummyPropWithNestedPureError     ] @@ -733,9 +759,15 @@   :: HasCallStack   => TestName -> String -> Property -> TestTree testFailureIncludesCallStackProperty testName expectedErrorLines prop =+  testFailureIncludesCallStackProperty' testName expectedErrorLines thisPath prop++testFailureIncludesCallStackProperty'+  :: HasCallStack+  => TestName -> String -> String -> Property -> TestTree+testFailureIncludesCallStackProperty' testName expectedErrorLines testPath prop =   runPropertyViaTasty testName mempty prop $ \tastyResult -> do     outcomeIsFailure tastyResult-    checkErrorMessage (resultDescription tastyResult) expectedErrorLines+    checkErrorMessage' (resultDescription tastyResult) expectedErrorLines testPath  -- | If we can't force a function to fail on a network by, e.g., -- passing the wrong arguments or violating its pre-conditions,@@ -760,9 +792,18 @@ -- | Checks that an error message includes a pretty-printed callstack, -- and that it points to this file and contains the expected lines. checkErrorMessage :: HasCallStack => String -> String -> Assertion-checkErrorMessage err (List.lines -> expectedLines) = do-  Unsafe.head (List.lines err) `shouldContain` ("test" </> "TestSuite" </> "Cleveland" </> "CallStack.hs")+checkErrorMessage err expectedLines = checkErrorMessage' err expectedLines thisPath +-- | Path to this file to use for tests in a couple of places.+thisPath :: String+thisPath = "test" </> "TestSuite" </> "Cleveland" </> "CallStack.hs"++-- | Checks that an error message includes a pretty-printed callstack,+-- and that it points to the provided path and contains the expected lines.+checkErrorMessage' :: HasCallStack => String -> String -> String -> Assertion+checkErrorMessage' err (List.lines -> expectedLines) path = do+  Unsafe.head (List.lines err) `shouldContain` path+   if expectedLines `List.isInfixOf` strippedErrorLines     then pass     else@@ -784,6 +825,7 @@      -- Strip 1) the header, 2) the callstack entries, 3) the line numbers and 4) the vertical border     -- from the error message, to make writing these tests easier.+    strippedErrorLines :: [String]     strippedErrorLines =       err       & List.lines@@ -815,6 +857,7 @@   deriving stock (Eq, Show)  instance Exception DummyException where+  fromException = fromPossiblyAnnotatedException  ---------------------------------------------------------------------------- -- Test scenarios@@ -830,11 +873,3 @@     g y   = f 10 y    g (20 :: Int)--dummyPropWithPureError :: Property-dummyPropWithPureError = property $ testScenarioProps $ scenario do-  error "Pure error" @== (1 :: Int)--dummyPropWithNestedPureError :: Property-dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do-  (10 - 11 :: Mutez) @== 0

@@ -0,0 +1,19 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.CallStack.Fixtures+  ( dummyPropWithPureError+  , dummyPropWithNestedPureError+  ) where++import Hedgehog (Property, property)+import Morley.Tezos.Core+import Test.Cleveland++dummyPropWithPureError :: Property+dummyPropWithPureError = property $ testScenarioProps $ scenario do+    error "Pure error" @== (1 :: Int)++dummyPropWithNestedPureError :: Property+dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do+    (10 - 11 :: Mutez) @== 0

@@ -0,0 +1,60 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.Delegates+  ( test_Delegates+  ) where++import Test.Tasty (TestTree)++import Morley.Tezos.Address+import Test.Cleveland+import TestSuite.Util++test_Delegates :: [TestTree]+test_Delegates =+  [ testScenario "Registering delegate works" $ scenario do+      addr@(ImplicitAddress kh) <- newFreshAddress "delegated"+      transfer addr [tz|1milli|] -- just about enough to pay all the fees+      getDelegate addr @@== Nothing+      registerDelegate addr+      getDelegate addr @@== Just kh+  , testScenario "Setting delegate on origination works" $ scenario do+      addr@(ImplicitAddress kh) <- newFreshAddress "delegated"+      transfer addr [tz|1milli|] -- just about enough to pay all the fees+      registerDelegate addr+      contract <- originate "idContract" () (idContract @()) kh+      getDelegate contract @@== Just kh+  , testScenario "Registering delegate twice doesn't error" $ scenario do+      addr@(ImplicitAddress kh) <- newFreshAddress "delegated"+      transfer addr [tz|1milli|] -- just about enough to pay all the fees+      registerDelegate addr+      getDelegate addr @@== Just kh+      registerDelegate addr+      getDelegate addr @@== Just kh+  , testScenario "Setting/unsetting delegate explicitly works" $ scenario do+      addr <- newFreshAddress "delegated"+      transfer addr [tz|2milli|]+      delegate@(ImplicitAddress delegateKh) <- newAddress "delegate"+      registerDelegate delegate+      getDelegate addr @@== Nothing+      setDelegate addr (Just delegateKh)+      getDelegate addr @@== Just delegateKh+      setDelegate addr Nothing+      getDelegate addr @@== Nothing+  , testScenario "Can't set/unset delegate on a registered delegate" $ scenario do+      addr@(ImplicitAddress kh) <- newFreshAddress "delegated"+      transfer addr [tz|1milli|]+      delegate@(ImplicitAddress delegateKh) <- newAddress "delegate"+      registerDelegate delegate+      registerDelegate addr+      getDelegate addr @@== Just kh+      errorMessage <- ifEmulation+        (pure "Delegate deletion is forbidden")+        (pure "Failed to withdraw delegation for")+      setDelegate addr (Just delegateKh)+        & shouldFailWithMessage errorMessage+      setDelegate addr Nothing+        & shouldFailWithMessage errorMessage+      getDelegate addr @@== Just kh+  ]

@@ -15,7 +15,7 @@ test_duplicateEntrypoints :: TestTree test_duplicateEntrypoints = testContractMatchesEntrypoints "Ill-typed contract fails the test"   illTypedContract mempty-  & expectFailure "invalid parameter declaration:  Duplicated entrypoint names: 'do1'"+  & expectFailure "Duplicated entrypoint names: 'do1'"   where     n = unsafe $ mkAnnotation ""     do1 = unsafe $ mkAnnotation "do1"

@@ -12,7 +12,7 @@  test_error_message_shows_contract_alias :: TestTree test_error_message_shows_contract_alias =-  testScenarioOnEmulator "Error message shows contract alias" $ scenario do+  testScenario "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,16 +21,15 @@  import Morley.Micheline (toExpression) import Morley.Michelson.Runtime.GState (genesisAddress1)-import Morley.Tezos.Address (ConstrainedAddress(..), ta)+import Morley.Tezos.Address (ta) import Morley.Tezos.Core (parseChainId)-import Morley.Util.Interpolate (i)+import Morley.Util.Interpolate (it) import Test.Cleveland import Test.Cleveland.Internal.Abstract-  (AddressAndAlias(..), ExpressionOrTypedValue(..), FailedInBranch(..), GenericTestError(..),-  TransferFailure(..), TransferFailureReason(..))+  (AddressAndAlias(..), ExpressionOrTypedValue(..), GenericTestError(..), TransferFailure(..),+  TransferFailureReason(..)) import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..))-import Test.Cleveland.Internal.Exceptions (WithCallStack(..))-import Test.Cleveland.Internal.Pure (emptyScenarioBranch)+import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Util (failedTest, fromHex) import TestSuite.Util (shouldFailWithMessage) @@ -133,12 +132,12 @@ test_BranchErrorHandleInRightWay =   testScenario "catchTransferFailure and attempt unwrap exceptions with extra info" $ scenario do     let action =-          runIO . throwM $-              WithCallStack callStack $ SomeException $-                FailedInBranch emptyScenarioBranch $ SomeException $-                  WithCallStack callStack $ SomeException $-                    FailedInBranch emptyScenarioBranch $ SomeException $-                      TransferFailure (AddressAndAlias (MkAddress [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|]) Nothing) BadParameter+          runIO $+              addCallStack $+                annotateExceptions (ScenarioBranchName ["a"]) $+                  addCallStack $+                    annotateExceptions (ScenarioBranchName ["b"]) $+                      throwM $ TransferFailure (AddressAndAlias [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] Nothing) BadParameter      res <- attempt @TransferFailure action @@ -302,12 +301,12 @@  impl_test_AndPredicate_succeeds_if_all_conditions_hold conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias 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 (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing     checkTransferFailure err $       failedWith (constant @Integer 1) ||       failedWith (constant @Integer 2) ||@@ -315,14 +314,14 @@  impl_test_AndPredicate_fails_if_any_condition_fails conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( failedWith (constant @Integer 1) &&         failedWith (constant @Integer 2) &&         failedWith (constant @Integer 3)       )-      & shouldFailWithMessage [i|+      & shouldFailWithMessage [it| Expected transfer to fail with an error such that:    (@@ -333,18 +332,18 @@  But these conditions were not met. Actual transfer error:-  Contract: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]+  Contract: #{genesisAddress1} failed with: 1|]  impl_test_OrPredicate_fails_if_all_conditions_fail conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( failedWith (constant @Integer 2) ||         failedWith (constant @Integer 3) ||         failedWith (constant @Integer 4)       )-      & shouldFailWithMessage [i|+      & shouldFailWithMessage [it| Expected transfer to fail with an error such that:    (@@ -357,11 +356,11 @@  But these conditions were not met. Actual transfer error:-  Contract: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]+  Contract: #{genesisAddress1} failed with: 1|]  impl_test_checkTransferFailure_shows_only_failing_predicates conv =   testScenario "checkTransferFailure shows only failing predicates" $ scenario do-    let err = TransferFailure (AddressAndAlias (toAddress genesisAddress1) Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( (failedWith (constant @Integer 1) && failedWith (constant @Integer 2)) &&@@ -369,7 +368,7 @@         (failedWith (constant @Integer 1) || failedWith (constant @Integer 6)) &&         (failedWith (constant @Integer 7) || failedWith (constant @Integer 8))       )-      & shouldFailWithMessage [i|+      & shouldFailWithMessage [it| Expected transfer to fail with an error such that:    (@@ -388,4 +387,4 @@  But these conditions were not met. Actual transfer error:-  Contract: tz1bTXrPQCMsGbjPQcSH4uHCbbwtqotAuvHF failed with: 1|]+  Contract: #{genesisAddress1} failed with: 1|]

@@ -22,6 +22,8 @@ import Lorentz.Annotation import Lorentz.Entrypoints import Lorentz.Value+import Morley.Michelson.Parser (utypeQ)+import Morley.Michelson.Typed.Convert (convertParamNotes) import Morley.Michelson.Untyped qualified as U import Morley.Util.Interpolate @@ -42,6 +44,12 @@   deriving stock Generic   deriving anyclass (IsoValue) +data MyEntrypoints3+  = Default Natural+  | Do33 Integer+  deriving stock Generic+  deriving anyclass (IsoValue)+ data MyParams = MyParams   { param1 :: ()   , param2 :: ByteString@@ -55,27 +63,19 @@ instance ParameterHasEntrypoints MyEntrypoints2 where   type ParameterEntrypointsDerivation MyEntrypoints2 = EpdPlain +instance ParameterHasEntrypoints MyEntrypoints3 where+  type ParameterEntrypointsDerivation MyEntrypoints3 = EpdPlain+ epSpecPartial :: Map EpName U.Ty epSpecPartial =-  [ ( U.UnsafeEpName "do1", U.Ty (U.TInt) def )-  , ( U.UnsafeEpName "do2"-    , U.Ty (U.TPair def def def def (U.Ty U.TInt def) (U.Ty U.TInt def)) def )-  , ( U.UnsafeEpName "do10", U.Ty (U.TUnit) def )-  , ( U.UnsafeEpName "do11", U.Ty (U.TNat) def )+  [ ( #do1, [utypeQ| int |] )+  , ( #do2, [utypeQ| pair int int |] )+  , ( #do10, [utypeQ| unit |] )+  , ( #do11, [utypeQ| nat |] )   ]  epSpecFull :: Map EpName U.Ty-epSpecFull = epSpecPartial <>-  [ ( U.UnsafeEpName "do4"-    , U.Ty (-        U.TPair (unsafe $ U.mkAnnotation "param1")-                (unsafe $ U.mkAnnotation "param2")-                def-                def-                (U.Ty U.TUnit def)-                (U.Ty U.TBytes def)-        ) def )-  ]+epSpecFull = epSpecPartial <> [ ( #do4, [utypeQ| pair (unit %param1) (bytes %param2) |]) ]  extractTests :: TestTree -> (forall t. IsTest t => String -> t -> TestTree) -> TestTree extractTests tree f = case tree of@@ -103,23 +103,36 @@         (idContract @MyEntrypoints1 @()) epSpecPartial   , testContractCoversEntrypoints       "testContractCoversEntrypoints fails on wrong type"-        (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]+        (idContract @MyEntrypoints1 @()) [ ( #do1, [utypeQ| nat |] ) ]       & expectFailure "Expected: nat\nActual:   int"   , testContractCoversEntrypoints       "testContractCoversEntrypoints fails on missing entrypoints"-        (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]+        (idContract @MyEntrypoints1 @()) [ ( #do123, [utypeQ| int |] ) ]       & expectFailure "Entrypoints do not match specification: \           \Missing entrypoints in the contract: do123: int"+  , testContractCoversEntrypoints+      "testContractCoversEntrypoints handles implicit default entrypoints if those are expected"+        (idContract @MyEntrypoints2 @()) [ ( U.DefEpName, [utypeQ| or (unit %do10) (nat %do11) |] ) ]+  , testContractCoversEntrypoints+      "testContractCoversEntrypoints handles explicit default entrypoints if those are expected"+        (idContract @MyEntrypoints3 @()) [ ( U.DefEpName, [utypeQ| nat |] ) ]+  , testContractCoversEntrypoints+      "testContractCoversEntrypoints fails on invalid implicit default entrypoint"+        (idContract @MyEntrypoints2 @()) [ ( U.DefEpName, [utypeQ| int |] ) ]+      & expectFailure [it|+          Type mismatch in entrypoints:+            <default>:+      |]   ]  genBigPair :: Int -> U.Ty-genBigPair 0 = U.Ty U.TBytes def+genBigPair 0 = [utypeQ| bytes |] genBigPair n = U.Ty (     U.TPair (unsafe $ U.mkAnnotation "param1")             (unsafe $ U.mkAnnotation "param2")             def             def-            (U.Ty U.TUnit def)+            [utypeQ| unit |]             (genBigPair (n - 1))     ) def @@ -129,11 +142,11 @@       "testContractMatchesEntrypoints works as expected" (idContract @MyEntrypoints1 @()) epSpecFull   , testContractMatchesEntrypoints       "testContractMatchesEntrypoints fails on wrong type"-        (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]+        (idContract @MyEntrypoints1 @()) [ ( #do1, [utypeQ| nat |] ) ]       & expectFailure  "Expected: nat\nActual:   int"   , testContractMatchesEntrypoints       "testContractMatchesEntrypoints fails on wrong nested type"-        (idContract @MyEntrypoints1 @()) [( U.UnsafeEpName "do4", genBigPair 6)]+        (idContract @MyEntrypoints1 @()) [( #do4, genBigPair 6)]       & expectFailure [it|             pair (unit %param1)           -      (pair %param2 (unit %param1)@@ -147,19 +160,48 @@           |]   , testContractMatchesEntrypoints       "testContractMatchesEntrypoints fails on missing entrypoints"-        (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]+        (idContract @MyEntrypoints1 @()) [ ( #do123, [utypeQ| int |] ) ]       & expectFailure "Missing entrypoints in the contract: do123: int"   , testContractMatchesEntrypoints       "testContractMatchesEntrypoints fails on extraneous entrypoints"         (idContract @MyEntrypoints1 @()) epSpecPartial       & expectFailure "Entrypoints do not match specification:\           \ Extraneous entrypoints in the contract: do4: pair (unit %param1) (bytes %param2)"+  , testContractMatchesEntrypoints+      "testContractMatchesEntrypoints handles implicit default entrypoints if those are expected"+        (idContract @MyEntrypoints1 @()) $+          epSpecFull+          <> [ ( U.DefEpName, stripRootAnn $ convertParamNotes $+                   parameterEntrypointsToNotes @MyEntrypoints1 ) ]+  , testContractMatchesEntrypoints+      "testContractMatchesEntrypoints handles explicit default entrypoints if those are expected"+        (idContract @MyEntrypoints3 @())+          [ ( U.DefEpName, [utypeQ| nat |] ), (#do33, [utypeQ| int |]) ]+  , testContractMatchesEntrypoints+      "testContractMatchesEntrypoints handles explicit default entrypoints if those are unexpected"+        (idContract @MyEntrypoints3 @()) [ (#do33, [utypeQ| int |]) ]+      & expectFailure "Entrypoints do not match specification: \+          \Extraneous entrypoints in the contract: <default>: nat"+  , testContractMatchesEntrypoints+      "testContractMatchesEntrypoints fails on type mismatch in default entrypoint"+        (idContract @MyEntrypoints1 @()) (epSpecFull <> [ ( U.DefEpName, [utypeQ| unit |] ) ])+      & expectFailure [it|+          Type mismatch in entrypoints:+            <default>:+              Expected: unit+      |]   ] +stripRootAnn :: U.ParameterType -> U.Ty+stripRootAnn (U.ParameterType ty _) = ty+ test_ContractMatchEntrypointsT :: [TestTree] test_ContractMatchEntrypointsT =   [ testContractMatchesEntrypointsT @MyEntrypoints1       "testContractMatchesEntrypointsT works as expected" (idContract @MyEntrypoints1 @())+  , testContractMatchesEntrypointsT @MyEntrypoints3+      "testContractMatchesEntrypointsT works as expected with explicit default"+        (idContract @MyEntrypoints3 @())   , testContractMatchesEntrypointsT @MyEntrypoints2       "testContractMatchesEntrypointsT fails on extra entrypoints" (idContract @MyEntrypoints1 @())       & expectFailure [it|@@ -176,4 +218,6 @@       "testContractCoversEntrypointsT works on partial spec" (idContract @MyEntrypoints1 @())   , testContractCoversEntrypointsT @MyEntrypoints1       "testContractCoversEntrypointsT works on full spec" (idContract @MyEntrypoints1 @())+  , testContractCoversEntrypointsT @MyEntrypoints3+      "testContractCoversEntrypointsT works on explicit default" (idContract @MyEntrypoints3 @())   ]

@@ -0,0 +1,49 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++module TestSuite.Cleveland.MonadOps+  ( test_MonadOps+  , test_MonadOpsBatch+  ) where++import Test.Tasty (TestTree)++import Morley.Util.SizedList (IsoNatPeano, SizedList)+import Test.Cleveland+import Test.Cleveland.Internal.Actions (MonadOriginate, MonadTransfer)++import TestSuite.Util++test_MonadOps :: TestTree+test_MonadOps =+  testScenario "MonadOps works" $ scenario go++test_MonadOpsBatch :: TestTree+test_MonadOpsBatch =+  testScenario "Batched MonadOps works" $ scenario do+    addrs <- newAddresses $ enumAliases "test"+    inBatch $ goBatch @3 addrs++-- NB: We're testing 'MonadOps' behavior here, hence it's important for 'go' and+-- 'goBatch' to be separate polymorphic functions, otherwise those would just+-- run in 'MonadCleveland' context.++go :: (Monad m, MonadOps m) => m ()+go = do+  ct <- originateMonadOps+  transferMonadOps ct++goBatch+  :: forall n n' m. (IsoNatPeano n n', Applicative m, MonadOps m)+  => SizedList n ImplicitAddress -> m ()+goBatch addrs = for_ addrs \addr -> transfer addr (123 :: Mutez)++-- NB: The same applies to 'MonadOriginate' and 'MonadTransfer' in functions+-- below as to 'MonadOps' above -- we want those to be separate polymorphic+-- functions as it's basically the point of these tests.++originateMonadOps :: MonadOriginate m => m (ContractHandle () () ())+originateMonadOps = originate "idContract" () idContract++transferMonadOps :: MonadTransfer m => ContractHandle () () () -> m ()+transferMonadOps ct = transfer ct (123 :: Mutez) $ calling def ()

@@ -0,0 +1,88 @@+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++-- | Views are tested mainly in lorentz-test, but here we check everything at+-- least works in simple scenarios.+module TestSuite.Cleveland.ViewCall+  ( test_RequesterContract+  , test_ViewCall+  , test_UnsafeViewCall+  ) where++import Lorentz+import Prelude hiding (drop, some, swap, take, view)++import Test.Tasty (TestTree)++import Morley.Michelson.Untyped (pattern ValueUnit)+import Test.Cleveland+import Test.Cleveland.Lorentz+import Test.Cleveland.Lorentz.Requester+import Test.Cleveland.Michelson.Import (testTreesWithUntypedContract)+import TestSuite.Util+import TestSuite.Util.Contracts (inContractsDir)++type Views = ViewsList+  [ "add" ?:: Natural >-> Natural+  , "id" ?:: Natural >-> (Natural, ())+  , "fail" ?:: MText >-> Never+  ]++viewedContract :: Contract Never () Views+viewedContract = $$(embedContract $ inContractsDir "view_example.tz")++test_RequesterContract :: TestTree+test_RequesterContract = testScenario "Views can be called via requester contract" $ scenario do+  viewed <- originate "viewed" () viewedContract++  clarifyErrors "Calling view 'add'" do+    requester <- originate "requester" [] (contractRequester @"add" viewed)+    forM_ [5, 10] $ transfer requester . calling def+    getStorage requester @@== [11, 6]++  clarifyErrors "Calling view 'fail'" do+    requester <- originate "requester" [] (contractRequester @"fail" viewed)+    transfer requester (calling def [mt|nyan|])+      & expectFailedWith [mt|nyan|]++  clarifyErrors "Calling view 'id'" do+    requester <- originate "requester" [] (contractRequester @"id" viewed)+    forM_ [5, 0] $ transfer requester . calling def+    getStorage requester @@== [(0, ()), (5, ())]++test_ViewCall :: TestTree+test_ViewCall = testScenario "Views can be called directly" $ scenario do+  viewed <- originate "viewed" () viewedContract++  clarifyErrors "Calling view 'add'" do+    forM [5, 10] (callView viewed #add) @@== [6, 11]++  clarifyErrors "Calling view 'fail'" do+    callView viewed #fail [mt|nyan|]+      & expectFailedWith [mt|nyan|]++  clarifyErrors "Calling view 'id'" do+    forM [5, 0] (callView viewed #id) @@== [(5, ()), (0, ())]++test_UnsafeViewCall :: IO [TestTree]+test_UnsafeViewCall = testTreesWithUntypedContract (inContractsDir "view_example.tz") \ct ->+  pure $ pure $ testScenario "Views can be called directly" $ scenario do+    viewed <- originate "viewed" ValueUnit ct++    clarifyErrors "Calling view 'add'" do+      forM [5 :: Natural, 10] (unsafeCallView @Natural viewed #add) @@== [6, 11]++    clarifyErrors "Calling view 'fail'" do+      unsafeCallView @Never viewed #fail [mt|nyan|]+        & expectFailedWith [mt|nyan|]++    clarifyErrors "Calling view 'id'" do+      forM [5 :: Natural, 0] (unsafeCallView @(Natural, ()) viewed #id) @@== [(5, ()), (0, ())]++    clarifyErrors "Calling view 'nonexistent' which doesn't exist" do+      unsafeCallView @Never viewed #nonexistent ()+        & shouldFailWithMessage "Failed to call view nonexistent"++    clarifyErrors "Calling view 'id' with incorrect types" do+      unsafeCallView @Never viewed #id ()+        & shouldFailWithMessage "Failed to call view id"

@@ -17,7 +17,7 @@      -- At the end of this test, we want to check that `newAddress` transfers funds from "newMoneybag" to "testAccount".     -- However, this will only happen if:-    --   1. the "testAccount" alias is not yet known to tezos-client+    --   1. the "testAccount" alias is not yet known to @octez-client@     --   2. or, it is known, but it has less than 0.5 XTZ.     -- We use `newFreshAddress` here to ensure "testAccount" is a known alias with 0 XTZ.     _ <- newFreshAddress "testAccount"