cleveland 0.3.1 → 0.3.2

raw patch · 31 files changed

+606/−255 lines, 31 filesdep −fmtPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: fmt

API changes (from Hackage documentation)

Files

• CHANGES.md +14/−0
• cleveland.cabal +2/−3
• src/Hedgehog/Gen/Michelson/Typed.hs +11/−16
• src/Hedgehog/Gen/Michelson/Untyped.hs +64/−14
• src/Hedgehog/Gen/Morley/Micheline.hs +1/−1
• src/Test/Cleveland/Doc/Michelson.hs +2/−3
• src/Test/Cleveland/Instances.hs +1/−24
• src/Test/Cleveland/Internal/Abstract.hs +110/−9
• src/Test/Cleveland/Internal/Actions/Assertions.hs +5/−5
• src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs +4/−4
• src/Test/Cleveland/Internal/Actions/Misc.hs +7/−9
• src/Test/Cleveland/Internal/Actions/TransferFailurePredicate.hs +8/−10
• src/Test/Cleveland/Internal/Actions/View.hs +1/−1
• src/Test/Cleveland/Internal/Client.hs +60/−27
• src/Test/Cleveland/Internal/Exceptions/Annotated.hs +5/−5
• src/Test/Cleveland/Internal/Exceptions/ErrorsClarification.hs +2/−2
• src/Test/Cleveland/Internal/Pure.hs +38/−30
• src/Test/Cleveland/Michelson/Internal/Entrypoints.hs +2/−2
• src/Test/Cleveland/Tasty/Internal/Report.hs +13/−11
• src/Test/Cleveland/Util.hs +4/−4
• test/TestSuite/Cleveland/Assertions.hs +8/−6
• test/TestSuite/Cleveland/Entrypoints.hs +1/−1
• test/TestSuite/Cleveland/ExpectFailure.hs +18/−18
• test/TestSuite/Cleveland/FailureSequence.hs +171/−0
• test/TestSuite/Cleveland/Lorentz/Entrypoints.hs +13/−6
• test/TestSuite/Cleveland/MismatchError.hs +21/−21
• test/TestSuite/Cleveland/StorageCheck.hs +2/−3
• test/TestSuite/Cleveland/StorageWithBigMaps.hs +4/−7
• test/TestSuite/Cleveland/Tasty/Report.hs +10/−8
• test/TestSuite/Cleveland/TicketBalance.hs +1/−1
• test/TestSuite/Util.hs +3/−4

@@ -1,6 +1,20 @@ <!-- Unreleased: append new entries here -->  +0.3.2+=====+* [!1323](https://gitlab.com/morley-framework/morley/-/merge_requests/1323)+  Trace called contracts on error+  + Display sequence of contracts calls and other operations on error+* [!1310](https://gitlab.com/morley-framework/morley/-/merge_requests/1310)+  Various parser fixes+  + Add Hedgehog generator for Michelson macros `genMacro`+* [!1341](https://gitlab.com/morley-framework/morley/-/merge_requests/1341)+  Refactor scope constraints+  + Avoid redundant `check*Presence` uses+* [!1333](https://gitlab.com/morley-framework/morley/-/merge_requests/1333)+  Improve typechecker error rendering+ 0.3.1 ===== * [!1339](https://gitlab.com/morley-framework/morley/-/merge_requests/1339)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           cleveland-version:        0.3.1+version:        0.3.2 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@@ -169,7 +169,6 @@     , directory     , exceptions     , file-embed-    , fmt     , hedgehog >=1.0.3     , hex-text     , lens@@ -222,6 +221,7 @@       TestSuite.Cleveland.ErrorMessages       TestSuite.Cleveland.ExpectFailure       TestSuite.Cleveland.FailureLogs+      TestSuite.Cleveland.FailureSequence       TestSuite.Cleveland.ImplicitTickets       TestSuite.Cleveland.Import       TestSuite.Cleveland.InitialState@@ -316,7 +316,6 @@       base-noprelude >=4.7 && <5     , cleveland     , filepath-    , fmt     , hedgehog >=1.0.3     , hspec-expectations     , lens

@@ -27,6 +27,7 @@   ) where  import Control.Exception qualified as Ex+import Data.Constraint ((\\)) import Data.Singletons (Sing) import Hedgehog (GenBase, MonadGen) import Hedgehog.Gen qualified as Gen@@ -70,7 +71,7 @@  genValueBigMap   :: forall (k :: T) (v :: T) m instr.-     (MonadGen m, WellTyped k, WellTyped v, HasNoBigMap v, Comparable k)+     (MonadGen m, WellTyped k, WellTyped v, ForbidBigMap v, Comparable k)   => Range Length -> m (Value' instr k) -> m (Value' instr v) -> m (Value' instr ('TBigMap k v)) genValueBigMap len genKey genVal =   VBigMap@@ -135,7 +136,7 @@  genValue   :: forall t m.-      (MonadGen m, GenBase m ~ Identity, HasNoOp t, WellTyped t)+      (MonadGen m, GenBase m ~ Identity, ForbidOp t, WellTyped t)   => m (Value' Instr t) genValue = genValue' (sing @t) @@ -157,7 +158,7 @@ genBigMapId = Gen.integral (Range.constant 0 100000000)  genValue'-  :: (MonadGen m, GenBase m ~ Identity, HasNoOp t, WellTyped t)+  :: (MonadGen m, GenBase m ~ Identity, ForbidOp t, WellTyped t)   => Sing t -> m (Value' Instr t) genValue' = \case   STKey -> VKey <$> genPublicKey@@ -175,16 +176,17 @@   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-    [ Left <$> genNoOpValue l-    , Right <$> genNoOpValue r+  STPair l r -> deMorganForbidT SPSOp l r $+    VPair <$> ((,) <$> genValue' l <*> genValue' r)+  STOr l r -> deMorganForbidT SPSOp l r $ VOr <$> Gen.choice+    [ Left <$> genValue' l+    , Right <$> genValue' r     ]   -- It's quite hard to generate proper lambda of given type, so it always returns FAILWITH.   -- Such implementation is sufficient for now.   STLambda{} -> pure $ mkVLam $ RfAlwaysFails $ Seq UNIT FAILWITH-  STMap k v -> genValueMap def (genNoOpValue k) (genNoOpValue v)-  STBigMap k v -> genValueBigMap def (genNoOpValue k) (genNoOpValue v)+  STMap k v -> genValueMap def (genValue' k) (genValue' v) \\ comparableImplies k+  STBigMap k v -> genValueBigMap def (genValue' k) (genValue' v)   STInt -> genValueInt def   STNat -> genValueNat def   STString -> genValueString def@@ -204,13 +206,6 @@   STSaplingState _ -> error "genValue': Cannot generate `sapling_state` value."   STSaplingTransaction _ -> error "genValue': Cannot generate `sapling_transaction` value."   where-    genNoOpValue-      :: (MonadGen m, GenBase m ~ Identity, WellTyped t')-      => Sing t' -> m (Value' Instr t')-    genNoOpValue st = case checkOpPresence st of-      OpAbsent -> genValue' st-      _ -> Gen.discard-     genBls12Pairing       :: MonadGen m       => m (Value' Instr ('TList $ 'TPair 'TBls12381G1 'TBls12381G2))

@@ -23,6 +23,7 @@   , genEpName   , genAnnotation   , genT+  , genMacro   ) where  import Prelude hiding (EQ, GT, LT)@@ -33,6 +34,7 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range +import Morley.Michelson.Macro import Morley.Michelson.Untyped  import Hedgehog.Gen.Michelson (genErrorSrcPos, genMText)@@ -61,7 +63,7 @@   , Gen.subtermM genExpandedOp $ \expandedOp -> WithSrcEx <$> genErrorSrcPos <*> pure expandedOp   ] -genExtInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (ExtInstrAbstract op)+genExtInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (ExtInstrAbstract [] op) genExtInstrAbstract genOp = Gen.choice   [ STACKTYPE <$> genStackTypePattern   , UTEST_ASSERT <$> genTestAssert genOp@@ -77,7 +79,7 @@ genStackRef range = StackRef <$> Gen.integral (unStackRef <$> range)   where unStackRef (StackRef x) = x -genTestAssert :: MonadGen m => m op -> m (TestAssert op)+genTestAssert :: MonadGen m => m op -> m (TestAssert [] op) genTestAssert genOp = TestAssert <$> genSmallText <*> genPrintComment def <*> genSmallList genOp  genStackTypePattern :: (MonadGen m, GenBase m ~ Identity) => m StackTypePattern@@ -85,11 +87,11 @@   [ pure StkEmpty, pure StkRest ]   [ Gen.subtermM genStackTypePattern $ \stp -> StkCons <$> genTyVar <*> pure stp ] -genInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (InstrAbstract op)+genInstrAbstract :: (MonadGen m, GenBase m ~ Identity) => m op -> m (InstrAbstract [] op) genInstrAbstract genOp =   Gen.choice $ instrAbstractWithOp genOp <> instrAbstractWithoutOp -instrAbstractWithOp :: (MonadGen m, GenBase m ~ Identity) => m op -> [m (InstrAbstract op)]+instrAbstractWithOp :: (MonadGen m, GenBase m ~ Identity) => m op -> [m (InstrAbstract [] op)] instrAbstractWithOp genOp =   [ EXT <$> genExtInstrAbstract genOp   , PUSH <$> genAnnotation <*> genType <*> genValue' genOp@@ -107,7 +109,7 @@   , CREATE_CONTRACT <$> genAnnotation <*> genAnnotation <*> genContract' genOp   ] -instrAbstractWithoutOp :: (MonadGen m, GenBase m ~ Identity) => [m (InstrAbstract op)]+instrAbstractWithoutOp :: (MonadGen m, GenBase m ~ Identity) => [m (InstrAbstract [] op)] instrAbstractWithoutOp =   [ DROPN <$> Gen.word Range.linearBounded   , pure DROP@@ -197,9 +199,9 @@ genContract' genOp = Contract   <$> genParameterType   <*> genType-  <*> genSmallList genOp+  <*> genOp   <*> genEntriesOrder-  <*> fmap UnsafeViewsSet (Gen.map (Range.exponential 0 2) genSomeViewWithName)+  <*> fmap ViewsSet (Gen.map (Range.exponential 0 2) genSomeViewWithName)   where     genSomeViewWithName = do       v <- genSomeView genOp@@ -219,21 +221,21 @@   <$> genViewName   <*> genType   <*> genType-  <*> genSmallList genOp+  <*> genOp  genValue :: (MonadGen m, GenBase m ~ Identity) => m Value genValue = genValue' genExpandedOp -genValueInt :: MonadGen m => Range ValueInt -> m (Value' op)+genValueInt :: MonadGen m => Range ValueInt -> m (Value' [] op) genValueInt range = ValueInt <$> Gen.integral (unValueInt <$> range) -genValueString :: MonadGen m => Range Length -> m (Value' op)+genValueString :: MonadGen m => Range Length -> m (Value' [] op) genValueString = fmap ValueString . genMText -genValueBytes :: MonadGen m => Range Length -> m (Value' op)+genValueBytes :: MonadGen m => Range Length -> m (Value' [] op) genValueBytes = fmap ValueBytes . genInternalByteString -genValue' :: MonadGen m => m op -> m (Value' op)+genValue' :: MonadGen m => m op -> m (Value' [] op) genValue' genOp = Gen.recursive Gen.choice   -- non-recursive constructors   [ genValueInt def@@ -252,10 +254,10 @@   , Gen.subterm (genValue' genOp) ValueSome   , ValueSeq <$> genSmallNonEmpty (genValue' genOp)   , ValueMap <$> genSmallNonEmpty (genElt genOp)-  , ValueLambda <$> genSmallNonEmpty genOp+  , ValueLambda . toList <$> genSmallNonEmpty genOp   ] -genElt :: MonadGen m => m op -> m (Elt op)+genElt :: MonadGen m => m op -> m (Elt [] op) genElt genOp = Elt <$> genValue' genOp <*> genValue' genOp  genParameterType :: (MonadGen m, GenBase m ~ Identity) => m ParameterType@@ -352,3 +354,51 @@  genSmallText :: MonadGen m => m Text genSmallText = Gen.text (Range.linear 0 10) Gen.unicodeAll++genMacro :: (MonadGen m, GenBase m ~ Identity) => m Macro+genMacro = Gen.choice+  [ CMP <$> cmp+  , IFX <$> cmp <*> seq' <*> seq'+  , IFCMP <$> cmp <*> seq' <*> seq'+  , pure FAIL+  , PAPAIR <$> pair <*> ann <*> ann+  , UNPAPAIR <$> unpair+  , CADR <$> cadr <*> ann <*> ann+  , CARN <$> ann <*> word+  , CDRN <$> ann <*> word+  , SET_CADR <$> cadr <*> ann <*> ann+  , MAP_CADR <$> cadr <*> ann <*> ann <*> seq'+  , DIIP <$> word <*> seq'+  , DUUP <$> word <*> ann+  , pure ASSERT+  , ASSERTX <$> cmp+  , ASSERT_CMP <$> cmp+  , pure ASSERT_NONE+  , pure ASSERT_SOME+  , pure ASSERT_LEFT+  , pure ASSERT_RIGHT+  , IF_SOME <$> seq' <*> seq'+  , IF_RIGHT <$> seq' <*> seq'+  ]+  where+    seq' = pure $ PSSequence []+    cmp = Gen.choice+      [ EQ <$> ann+      , NEQ <$> ann+      , LT <$> ann+      , GT <$> ann+      , LE <$> ann+      , GE <$> ann+      ]+    ann = genAnnotation+    word = Gen.integral $ Range.linear 1 10+    pair = Gen.choice+      [ F <$> ann+      , P <$> pair <*> pair+      ]+    unpair = Gen.choice+      [ pure UF+      , UP <$> unpair <*> unpair+      ]+    cadr = genSmallList cadr1+    cadr1 = Gen.choice [pure A, pure D]

@@ -112,7 +112,7 @@     <*> Gen.list (unSmallLength <$> def) doGenExp     <*> genAnnots   where-    genMichelinePrimitive = MichelinePrimitive <$> (Gen.element $ toList michelsonPrimitive)+    genMichelinePrimitive = Gen.enumBounded     genAnnots = Gen.list (unSmallLength <$> def) genExprAnnotation  genExprAnnotation :: (MonadGen m, GenBase m ~ Identity) => m Annotation

@@ -17,8 +17,7 @@   ) where  import Data.Text qualified as T-import Data.Text.Lazy.Builder (toLazyText)-import Fmt (blockListF, fmt, nameF)+import Fmt (blockListF, fmt, nameF, pretty) import Test.HUnit (assertBool, assertFailure)  import Morley.Michelson.Doc@@ -106,7 +105,7 @@   \contractDoc ->     let res =           allContractDocItems contractDoc <&> \(DDescription desc) ->-            check (toText $ toLazyText desc)+            check (pretty desc)     in case nonEmpty (lefts res) of       Nothing -> pass       Just errs -> assertFailure . fmt $

@@ -8,7 +8,7 @@   ) where  import Data.Default (Default(..))-import Fmt (Buildable(..), eitherF, hexF, tupleF, (+|), (|+))+import Fmt (Buildable(..), hexF, (+|), (|+)) import GHC.Num qualified (fromInteger) import Test.Tasty.Runners (FailureReason(..)) import Time (Time)@@ -74,26 +74,6 @@ instance (Eq k, Eq v) => Eq (BigMap k v) where   BigMap _ bm1 == BigMap _ bm2 = bm1 == bm2 -instance Buildable () where build _ = "()"--instance (Buildable a, Buildable b) => Buildable (a, b) where build = tupleF-instance (Buildable a, Buildable b, Buildable c) => Buildable (a, b, c) where-  build = tupleF-instance (Buildable a, Buildable b, Buildable c, Buildable d) =>-  Buildable (a, b, c, d) where build = tupleF-instance (Buildable a, Buildable b, Buildable c, Buildable d, Buildable e) =>-    Buildable (a, b, c, d, e) where build = tupleF-instance (Buildable a, Buildable b, Buildable c,-          Buildable d, Buildable e, Buildable f) =>-          Buildable (a, b, c, d, e, f) where build = tupleF-instance (Buildable a, Buildable b, Buildable c,-          Buildable d, Buildable e, Buildable f,-          Buildable g) => Buildable (a, b, c, d, e, f, g) where build = tupleF-instance (Buildable a, Buildable b, Buildable c,-          Buildable d, Buildable e, Buildable f,-          Buildable g, Buildable h) =>-          Buildable (a, b, c, d, e, f, g, h) where build = tupleF- instance Buildable ByteString where build bs = "0x" <> hexF bs instance Buildable LByteString where build bs = "0x" <> hexF bs @@ -144,9 +124,6 @@     TestThrewException e -> "Test threw exception: " +| displayException e |+ ""     TestTimedOut s -> "Test timed out: " +| s |+ ""     TestDepFailed -> "Test skipped because its dependency failed"--instance (Buildable a, Buildable b) => Buildable (Either a b) where-  build = eitherF  instance mname ~ 'Nothing => Default (EntrypointRef mname) where   def = CallDefault

@@ -38,7 +38,7 @@ import Data.Constraint (Bottom(..), (\\)) import Data.Default (Default(..)) import Data.Type.Equality (pattern Refl)-import Fmt (Buildable(..), Builder, pretty, (+|), (|+))+import Fmt (Buildable(..), Doc, blockListF, pretty, unlinesF, (+|), (|+)) import Prelude hiding (Each) import Time (KnownDivRat, Second, Time) @@ -309,7 +309,7 @@   -- ^ Get the timestamp observed by the last block to be baked.   , cmiGetLevel :: HasCallStack => m Natural   -- ^ Get the current level observed by the last block to be baked.-  , cmiFailure :: forall a. HasCallStack => Builder -> m a+  , cmiFailure :: forall a. HasCallStack => Doc -> m a   -- ^ Fails the test with the given error message.   , cmiThrow :: forall a. HasCallStack => SomeException -> m a   -- ^ Rethrow arbitrary error without affecting the call stack. Used@@ -331,7 +331,7 @@   -- ^ Execute a contract's code without originating it.   -- The chain's state will not be modified.   , cmiTicketBalance-    :: forall t. (T.HasNoOp t, T.Comparable t)+    :: forall t. (T.ForbidOp t, T.Comparable t)     => L1Address -> ContractAddress -> T.Value t -> m Natural   -- ^ Get balance for a praticular ticket.   , cmiAllTicketBalances :: ContractAddress -> m [SomeTicket]@@ -587,9 +587,106 @@ -- These can be caught and handled with 'Test.Cleveland.attempt'. data TransferFailure = TransferFailure   { tfAddressAndAlias :: AddressAndAlias+  , tfCallSeqence :: CallSequence   , tfReason :: TransferFailureReason-  } deriving stock (Show, Eq)+  } +deriving stock instance Show TransferFailure++newtype CallSequence = CallSequence [CallSequenceOp]+  deriving stock Show+  deriving newtype (Container, Semigroup, Monoid)++instance Buildable CallSequence where+  build (CallSequence xs)+    | null xs = mempty+    | otherwise = blockListF xs++-- | Build only the last branch of 'CallSequence' as a linear array.+buildLastBranchLinear :: CallSequence -> Doc+buildLastBranchLinear = blockListF . go+  where+    go (CallSequence xs) = nonEmpty xs &+      maybe mempty+      \(last -> CallSequenceOp{..}) -> build csoData : go csoSubCalls++data CallSequenceOp =+  forall a. (Buildable a, Show a) => CallSequenceOp+    { csoData :: a+    , csoSubCalls :: CallSequence+    }+deriving stock instance Show CallSequenceOp++instance Buildable CallSequenceOp where+  build CallSequenceOp{..}+    | null csoSubCalls = build csoData+    | otherwise = unlinesF+        [ build csoData+        , build csoSubCalls+        ]++-- | Helper synonym for 'toCallSeq'+type ToCallSeqM k = State [(k, [CallSequenceOp])]++{- | Given a linear list of operations, reconstruct the "call sequence tree".++The function is polymorphic to support both emulated and network operations.++Uses a rather straightforward stack-based algorithm for reconstruction in+$O(n)$. However, bear in mind perfect reconstruction is not always possible, so+this is merely best-effort.++In the following example @Int@ substitutes for @Address@ for simplicity.++>>> import Morley.Util.Interpolate (i)+>>> :{+aux :: (Int, Int) -> ToCallSeqM Int (Maybe (Int, CallSequenceOp))+aux (caller, callee) =+  Just . (caller,) . CallSequenceOp [i|#{caller} calling #{callee}|] . CallSequence+    <$> popToCallSeq callee+:}++>>> :{+Fmt.pretty $ toCallSeq aux+  [(1, 2), (2, 3), (2, 3), (2, 4), (4, 2), (2, 5), (5, 1), (5, 3), (2, 3), (7, 1)]+:}+- 1 calling 2+  - 2 calling 3+  - 2 calling 3+  - 2 calling 4+    - 4 calling 2+      - 2 calling 5+        - 5 calling 1+        - 5 calling 3+      - 2 calling 3+- 7 calling 1++Note that in this call sequence, it is ambiguous whether the last @2 calling 3@+happens from @1@ or @4@. The algorithm used here will always assume deepest+nesting in such cases.+-}+toCallSeq :: Eq k => (a -> ToCallSeqM k (Maybe (k, CallSequenceOp))) -> [a] -> CallSequence+toCallSeq toCallOp = CallSequence . concatMap snd . executingState mempty . go . reverse+  where+    go = \case+      [] -> pass+      (y : ys) -> toCallOp y >>= maybe pass (uncurry push) >> go ys++    push src op = modify \case+      (src', ops) : xs | src == src' -> (src', op:ops) : xs+      xs -> (src, [op]) : xs++-- | Helper function for 'toCallSeq'. Pops the top of the stack if key matches+-- the supplied argument.+popToCallSeq :: Eq k => k -> ToCallSeqM k [CallSequenceOp]+popToCallSeq src = get >>= \case+  (src', ops) : xs | src == src' -> put xs >> pure ops+  _ -> pure mempty++instance Eq TransferFailure where+  tf1 == tf2 = tfAddressAndAlias tf1 == tfAddressAndAlias tf2+    && tfReason tf1 == tfReason tf2+ data TransferFailureReason   = FailedWith ExpressionOrTypedValue (Maybe ErrorSrcPos)   -- ^ Expect that interpretation of contract with the given address ended@@ -608,11 +705,15 @@   deriving stock (Show, Eq)  instance Buildable TransferFailure where-  build (TransferFailure addr reason) = case reason of-    EmptyTransaction -> reason |+ ": " +| addr |+ ""-    BadParameter -> "Attempted to call contract " +| addr |+ " with a " +| reason |+ ""-    FailedWith{} -> "Contract: " +| addr |+ " " +| reason |+ ""-    _ -> "Contract: " +| addr |+ " failed due to a " +| reason |+ ""+  build (TransferFailure addr stack reason) = unlinesF [message, rest]+    where+      message = case reason of+        EmptyTransaction -> reason |+ ": " +| addr |+ ""+        BadParameter -> "Attempted to call contract " +| addr |+ " with a " +| reason |+ ""+        FailedWith{} -> "Contract: " +| addr |+ " " +| reason |+ ""+        _ -> "Contract: " +| addr |+ " failed due to a " +| reason |+ ""+      rest | null stack = mempty+           | otherwise = "Call chain:\n" <> buildLastBranchLinear stack  instance Buildable TransferFailureReason where   build = \case

@@ -8,7 +8,7 @@   ( module Test.Cleveland.Internal.Actions.Assertions   ) where -import Fmt (Buildable, Builder, build, pretty, unlinesF)+import Fmt (Buildable, Doc, build, pretty, unlinesF)  import Test.Cleveland.Internal.Abstract import Test.Cleveland.Internal.Actions.Helpers@@ -16,12 +16,12 @@ {-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}  -- | Fails the test with the given error message.-failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Builder -> m a+failure :: forall a caps m. (HasCallStack, MonadCleveland caps m) => Doc -> m a failure msg = do   withCap getMiscCap \cap -> cmiFailure cap msg  -- | Fails the test with the given error message if the given condition is false.-assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Builder -> m ()+assert :: (HasCallStack, MonadCleveland caps m) => Bool -> Doc -> m () assert b errMsg =   unless b $ failure errMsg @@ -119,9 +119,9 @@       ]  -- | Fails the test if the `Maybe` is `Nothing`, otherwise returns the value in the `Just`.-evalJust :: (HasCallStack, MonadCleveland caps m) => Builder -> Maybe a -> m a+evalJust :: (HasCallStack, MonadCleveland caps m) => Doc -> Maybe a -> m a evalJust err = maybe (failure err) pure  -- | Fails the test if the `Either` is `Left`, otherwise returns the value in the `Right`.-evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Builder) -> Either a b -> m b+evalRight :: (HasCallStack, MonadCleveland caps m) => (a -> Doc) -> Either a b -> m b evalRight mkErr = either (failure . mkErr) pure

@@ -9,7 +9,7 @@   ) where  import Data.List.NonEmpty qualified as NE-import Fmt (Builder, build, indentF, unlinesF)+import Fmt (Doc, build, indentF, unlinesF)  import Lorentz   (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText)@@ -71,7 +71,7 @@   where     -- Collect descriptions of all failed predicates     -- Note that 'Nothing' signifies success here, and Just is a failure description.-    go :: TransferFailurePredicate -> Maybe Builder+    go :: TransferFailurePredicate -> Maybe Doc     go = \case       AndPredicate ps -> fmap (fmtExpectedOutcomes "AND") . nonEmpty . mapMaybe go $ toList ps         -- if all results are successful, i.e. 'Nothing', the result is 'Nothing'@@ -81,7 +81,7 @@         | p err -> Nothing         | otherwise -> Just $ build desc -    fmtExpectedOutcomes :: Builder -> NonEmpty Builder -> Builder+    fmtExpectedOutcomes :: Doc -> NonEmpty Doc -> Doc     fmtExpectedOutcomes delimiter = \case       expectedOutcome :| [] -> expectedOutcome       expectedOutcomes ->@@ -179,7 +179,7 @@ -- > for [1..10] \i -> clarifyErrors ("For i=" +| i |+ "") $ -- >   askContract i @@== i * 2 clarifyErrors :: forall caps m a. (MonadCleveland caps m)-              => Builder -> m a -> m a+              => Doc -> m a -> m a clarifyErrors message action =   attempt action >>= \case     Left e -> withCap getMiscCap \cap -> cmiThrow cap $

@@ -9,9 +9,8 @@   ) where  import Data.Singletons (demote)-import Fmt (Buildable, Builder, build, indentF, unlinesF, (+|), (|+))+import Fmt (Buildable, Doc, build, indentF, unlinesF, (+|), (|+)) import Time (KnownDivRat, Second, Time, toNum)-import Unsafe qualified (fromIntegral)  import Lorentz (BigMapId, Contract(..), DemoteViewsDescriptor, IsoValue) import Lorentz.Bytes@@ -20,7 +19,7 @@ import Morley.Client   (MorleyClientEnv, MorleyOnlyRpcEnv, OperationInfo(..), RunError(..), UnexpectedErrors(..)) import Morley.Client.Types (ImplicitAddressWithAlias, awaAddress)-import Morley.Michelson.Runtime (ExecutorError'(..), VotingPowers)+import Morley.Michelson.Runtime (ExecutorErrorPrim(..), VotingPowers) import Morley.Michelson.Runtime.GState (GStateUpdateError(..)) import Morley.Michelson.Runtime.Import qualified as Runtime import Morley.Michelson.Typed (SomeAnnotatedValue)@@ -255,8 +254,8 @@     Right () -> pass     Left e       | Just (UnexpectedRunErrors [DelegateAlreadyActive]) <- fromPossiblyAnnotatedException e -> pass-      | Just (EEFailedToApplyUpdates GStateAlreadySetDelegate{} :: ExecutorError' AddressAndAlias)-        <- fromPossiblyAnnotatedException e+      | Just (EEFailedToApplyUpdates GStateAlreadySetDelegate{})+        <- fromPossiblyAnnotatedException @(ExecutorErrorPrim AddressAndAlias) e       -> pass       | otherwise -> lift $ cmiThrow (getMiscCap caps) e @@ -339,7 +338,7 @@ getBigMapValue bmId k =   getBigMapValueMaybe bmId k >>= \case     Just v -> pure v-    Nothing -> failure $ unlinesF @_ @Builder+    Nothing -> failure $ unlinesF @_ @Doc       [ "Either:"       , "  1. A big_map with ID '" +| bmId |+ "' does not exist, or"       , "  2. It exists, but does not contain the key '" +| k |+ "'."@@ -379,7 +378,7 @@   )   => BigMapId k v -> m (Maybe Natural) getBigMapSizeMaybe bmId =-    fmap (fmap (Unsafe.fromIntegral @Int @Natural . length)) (getAllBigMapValuesMaybe bmId)+    fmap (fmap length) (getAllBigMapValuesMaybe bmId)  -- | Like 'getBigMapSizeMaybe', but fails the tests instead of returning 'Nothing'. getBigMapSize@@ -388,8 +387,7 @@   , NiceComparable k, NiceUnpackedValue v   )   => BigMapId k v -> m Natural-getBigMapSize bmId =-  Unsafe.fromIntegral @Int @Natural . length <$> getAllBigMapValues bmId+getBigMapSize bmId = length <$> getAllBigMapValues bmId  -- | Get the public key associated with given address. -- Fail if given address is not an implicit account.

@@ -9,14 +9,13 @@   ) where  import Control.Lens (makeLenses)-import Fmt (Buildable(..), Builder)+import Fmt (Buildable(..), Doc)  import Lorentz   (CustomError(..), ErrorTagMap, IsError, Label, MText, MustHaveErrorArg, errorTagToMText,   errorToVal, errorToValNumeric, toVal) import Lorentz.Constraints import Morley.Micheline (Expression, fromExpression, toExpression)-import Morley.Michelson.Printer.Util (buildRenderDoc) import Morley.Michelson.Typed (Constrained(..), SomeConstant) import Test.Cleveland.Internal.Abstract import Test.Cleveland.Lorentz.Types@@ -33,7 +32,7 @@  data TransferFailurePredicateDesc = TransferFailurePredicateDesc   { _tfpdNegated :: Bool-  , _tfpdDescription :: Builder+  , _tfpdDescription :: Doc   }  makeLenses ''TransferFailurePredicateDesc@@ -46,7 +45,7 @@ instance IsString TransferFailurePredicateDesc where   fromString = tfpd . fromString -tfpd :: Builder -> TransferFailurePredicateDesc+tfpd :: Doc -> TransferFailurePredicateDesc tfpd = TransferFailurePredicateDesc False  instance Boolean TransferFailurePredicate where@@ -66,11 +65,10 @@     OrPredicate xs -> AndPredicate $ not <$> xs  transferFailureReasonPredicate-  :: Builder+  :: Doc   -> (TransferFailureReason -> Bool)   -> TransferFailurePredicate-transferFailureReasonPredicate b p = TransferFailurePredicate (tfpd b)-  \(TransferFailure _ reason) -> p reason+transferFailureReasonPredicate b p = TransferFailurePredicate (tfpd b) (p . tfReason)  -- | Asserts that interpretation of a contract failed due to an overflow error. shiftOverflow :: TransferFailurePredicate@@ -102,7 +100,7 @@ -- (e.g. 'constant', 'customError'). failedWith :: SomeConstant -> TransferFailurePredicate failedWith expectedFailWithVal = failedWithPredicate-  ("Contract failed with: " <> buildRenderDoc expectedFailWithVal)+  ("Contract failed with: " <> build expectedFailWithVal)   (isEq expectedFailWithVal)   where     isEq :: SomeConstant -> Expression -> Bool@@ -110,7 +108,7 @@  -- | Asserts that interpretation of a contract ended with @FAILWITH@, and the -- error satisfies the given predicate.-failedWithPredicate :: Builder -> (Expression -> Bool) -> TransferFailurePredicate+failedWithPredicate :: Doc -> (Expression -> Bool) -> TransferFailurePredicate failedWithPredicate msg valPredicate = transferFailureReasonPredicate msg $ \case   FailedWith eotv _ -> valPredicate $ case eotv of     EOTVExpression expr -> expr@@ -124,7 +122,7 @@   -> TransferFailurePredicate addressIs (toAddress -> expectedAddr) = TransferFailurePredicate   (tfpd $ "Failure occurred in contract with address: " <> build expectedAddr)-  \(TransferFailure addrAndAlias _) -> toAddress addrAndAlias == expectedAddr+  \TransferFailure{..} -> toAddress tfAddressAndAlias == expectedAddr  ---------------------------------------------------------------------------- -- 'FAILWITH' errors

@@ -35,7 +35,7 @@   :: 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+    , KnownSymbol name, HasRPCRepr ret     , T.IsoValue (AsRPC ret))   => ContractHandle cp st vd -- ^ Contract to call.   -> Label name -- ^ View name. Use @OverloadedLabels@ syntax.

@@ -12,12 +12,13 @@  import Control.Lens (_head, each, filtered) import Data.Aeson.Text qualified as J-import Data.Constraint (withDict)+import Data.Constraint (withDict, (\\)) import Data.Ratio ((%)) import Data.Set qualified as Set+import Data.Singletons (demote) import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, secondsToNominalDiffTime)-import Data.Type.Equality (pattern Refl)-import Fmt (Buildable(build), Builder, indentF, pretty, unlinesF, (+|), (|+))+import Data.Typeable (cast)+import Fmt (Buildable(build), Doc, indentF, pretty, unlinesF, (+|), (|+)) import System.IO (hFlush) import Time (KnownDivRat, Second, Time, sec, threadDelay, toNum, toUnit) import Unsafe qualified (fromIntegral)@@ -35,11 +36,13 @@ import Morley.Client.App (failOnTimeout, retryOnceOnTimeout) 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.Error qualified as RPC import Morley.Client.RPC.Types   (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp),-  BlockId(..), IntOpEvent(..), OperationHash, OriginationScript(..),-  ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize))+  BlockId(..), EventOperation(..), OperationHash, OriginationScript(..),+  ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize),+  WithSource(..))+import Morley.Client.RPC.Types qualified as RPC import Morley.Client.TezosClient.Impl qualified as TezosClient import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL) import Morley.Client.Util qualified as Client@@ -87,7 +90,7 @@  instance Buildable MoneybagConfigurationException where   build = \case-    NoMoneybagAddress alias -> unlinesF @_ @Builder+    NoMoneybagAddress alias -> unlinesF @_ @Doc       [ "Moneybag alias is not registered in the tezos node: " <> build alias       , ""       , "Cleveland's network tests require a special address with plenty of XTZ for"@@ -98,7 +101,7 @@       , "  * Use a different alias, supplied via '--cleveland-moneybag-alias'."       , "  * Import a moneybag account, by supplying its secret key via '--cleveland-moneybag-secret-key'."       ]-    TwoMoneybagKeys alias envKey existingAddress -> unlinesF @_ @Builder+    TwoMoneybagKeys alias envKey existingAddress -> unlinesF @_ @Doc       [ "Tried to import the secret key supplied via '--cleveland-moneybag-secret-key' and"       , "associate it with the alias '" +| alias |+ "', but the alias already exists."       , ""@@ -254,7 +257,7 @@     }   where     cmiTicketBalance-      :: forall t. (T.HasNoOp t, T.SingI t)+      :: forall t. (T.ForbidOp t, T.SingI t)       => L1Address -> ContractAddress -> T.Value t -> ClientM Natural     cmiTicketBalance owner ticketer value = liftIO . runMorleyClientM neMorleyClientEnv $       Client.getTicketBalance owner Client.GetTicketBalance@@ -307,7 +310,7 @@           _ExpressionSeq           . each           . _ExpressionPrim-          . filtered (\prim -> prim ^. mpaPrimL == MichelinePrimitive "storage")+          . filtered (\prim -> prim ^. mpaPrimL == Prim_storage)           . mpaArgsL           . _head @@ -439,10 +442,10 @@       `catch` \case         err@(RPC.RunCodeErrors errs)           | Just clientErr <- runErrorsToClientError errs-          -> throwM =<< exceptionToTransferFailure neMorleyClientEnv clientErr+          -> throwM =<< exceptionToTransferFailure neMorleyClientEnv [] clientErr           | otherwise -> throwM err -clientFailure :: Builder -> ClientM a+clientFailure :: Doc -> ClientM a clientFailure = throwM . CustomTestError . pretty  comment :: Text -> ClientM ()@@ -502,9 +505,8 @@         , tdMbFee = Nothing         }     OpTransferTicket TransferTicketData{..}-      | T.VTicket ttdTicketTicketer (ttdTicketContents :: T.Value t) ttdTicketAmount <- ttdParameter-      , Refl <- T.comparabilityImpliesNoNestedBigMaps @t-      , Refl <- T.comparabilityImpliesNoOp @t+      | T.VTicket ttdTicketTicketer ttdTicketContents ttdTicketAmount <- ttdParameter+      , T.Dict <- T.comparableImplies ttdTicketContents       -> pure $ OpTransferTicket Client.TransferTicketData         { ttdDestination = L.toAddress $ toL1Address ttdTo         , ttdMbFee = Nothing@@ -631,10 +633,10 @@   OpReveal ops -> pure $ OpReveal ops   OpDelegation ops -> pure $ OpDelegation ops -intOpEventToContractEvent :: IntOpEvent -> ClientM ContractEvent-intOpEventToContractEvent IntOpEvent{..} = do-  T.AsUType (ceType :: T.Notes t) <- either throwM (pure . toTy) $ fromExpression @U.T ioeType-  cePayload <- case ioePayload of+intOpEventToContractEvent :: WithSource EventOperation -> ClientM ContractEvent+intOpEventToContractEvent WithSource{wsOtherData = EventOperation{..}, ..} = do+  T.AsUType (ceType :: T.Notes t) <- either throwM (pure . toTy) $ fromExpression @U.T eoType+  cePayload <- case eoPayload of     Nothing -> pure Nothing     Just payload -> case fromExpression @(T.Value t) . toExpression $ payload of       Right value -> pure . Just $ SomeAnnotatedValue ceType value@@ -646,9 +648,13 @@           , "Decoding error:"           , indentF 2 $ build err           ]+  ceSource :: ContractAddress <- case wsSource of+    Constrained ceSource@ContractAddress{} -> pure ceSource+    Constrained (addr :: KindedAddress kind) ->+      throwM $ CustomTestError $ "Unexpected event source kind: " <> pretty (demote @kind)+        \\ addressKindSanity addr   pure $ ContractEvent-    { ceSource = ioeSource-    , ceTag = maybe "" unMText ioeTag+    { ceTag = maybe "" unMText eoTag     , ..     }   where@@ -686,8 +692,12 @@      ContractAddress{} -> AddressAndAlias addr <$> getAliasMaybe env addr      SmartRollupAddress{} -> pure (AddressAndAlias addr Nothing) -exceptionToTransferFailure :: MorleyClientEnv -> RPC.ClientRpcError -> ClientM TransferFailure-exceptionToTransferFailure env = \case+exceptionToTransferFailure+  :: MorleyClientEnv+  -> [RPC.OperationResp RPC.WithSource]+  -> RPC.ClientRpcError+  -> ClientM TransferFailure+exceptionToTransferFailure env stack = \case     RPC.ContractFailed addr expr -> mkTransferFailure addr $ FailedWith (EOTVExpression expr) Nothing     RPC.BadParameter (MkAddress addr) _ -> mkTransferFailure addr BadParameter     RPC.EmptyTransaction addr -> mkTransferFailure addr EmptyTransaction@@ -696,12 +706,35 @@     internalError -> throwM internalError     where       mkTransferFailure :: KindedAddress kind -> TransferFailureReason -> ClientM TransferFailure-      mkTransferFailure addr e = TransferFailure <$> resolveAddressAndAlias env addr <*> pure e+      mkTransferFailure addr e = do+        addr' <- resolveAddressAndAlias env addr+        pure $ TransferFailure addr' (rpcToCallSeq stack) e +rpcToCallSeq :: [RPC.OperationResp RPC.WithSource] -> CallSequence+rpcToCallSeq = toCallSeq \case+  RPC.TransactionOpResp RPC.WithSource{wsOtherData=to@RPC.TransactionOperation{..},..} ->+    Just . (wsSource,) . CallSequenceOp to . CallSequence <$> popToCallSeq toDestination+  RPC.TransferTicketOpResp RPC.WithSource{wsOtherData=to@RPC.TransferTicketOperation{..},..} ->+    Just . (wsSource,) . CallSequenceOp to . CallSequence <$> popToCallSeq ttoDestination+  RPC.OriginationOpResp RPC.WithSource{..} ->+    pure $ Just (wsSource, CallSequenceOp wsOtherData mempty)+  RPC.DelegationOpResp RPC.WithSource{..} ->+    pure $ Just (wsSource, CallSequenceOp wsOtherData mempty)+  RPC.RevealOpResp RPC.WithSource{..} ->+    pure $ Just (wsSource, CallSequenceOp wsOtherData mempty)+  RPC.EventOpResp RPC.WithSource{..} ->+    pure $ Just (wsSource, CallSequenceOp wsOtherData mempty)+  RPC.OtherOpResp _ ->+    pure Nothing++ exceptionHandler :: MorleyClientEnv -> ClientM a -> ClientM a-exceptionHandler env action = try action >>= \case-  Left err -> exceptionToTransferFailure env err >>= throwM-  Right res -> return res+exceptionHandler env action = action `catch` \case+  se@(SomeException e)+    | Just err <- cast e -> throwM =<< exceptionToTransferFailure env [] err+    | Just RPC.ClientRpcErrorWithStack{..} <- cast e+    -> throwM =<< exceptionToTransferFailure env (toList crewsStack) crewsError+    | otherwise -> throwM se  resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM ImplicitAlias resolveSpecificOrDefaultAlias (SpecificAlias alias) = pure alias

@@ -11,7 +11,7 @@ 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 Fmt (Buildable(..), Doc, build, pretty) import Text.Show qualified as Show (Show(..)) import Type.Reflection (typeRep) @@ -138,10 +138,10 @@ -- | Print all annotations from an 'AnnotationMap', given the initial message. -- -- Essentially right-fold using 'displayAnnotation'.-printAnnotations :: Buildable a => AnnotationMap -> a -> Builder+printAnnotations :: Buildable a => AnnotationMap -> a -> Doc printAnnotations (AnnotationMap annmap) = flip (Map.foldrWithKey go) annmap . build   where-    go :: Key t -> Identity t -> Builder -> Builder+    go :: Key t -> Identity t -> Doc -> Doc     go Key (Identity a) acc = displayAnnotation a acc  -- | Try to find the given type @t@ in an 'AnnotationMap'.@@ -167,9 +167,9 @@  -- | Type class for exception annotations. class (Show ann, Typeable ann) => ExceptionAnnotation ann where-  -- | Given an annotation and the error message (as 'Builder'), produce the+  -- | Given an annotation and the error message (as 'Doc'), produce the   -- text annotated with the annotation.-  displayAnnotation :: ann -> Builder -> Builder+  displayAnnotation :: ann -> Doc -> Doc    -- | Relative priority for sorting annotations. Annotations with higher   -- priority will be applied first. Default is @0@.

@@ -9,14 +9,14 @@   ( module Test.Cleveland.Internal.Exceptions.ErrorsClarification   ) where -import Fmt (Builder, nameF)+import Fmt (Doc, 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]+newtype ErrorsClarification = ErrorsClarification [Doc]   deriving stock Show   deriving newtype Semigroup 

@@ -21,8 +21,7 @@ import Data.Map qualified as Map import Data.Ratio ((%)) import Data.Set qualified as Set-import Data.Type.Equality (pattern Refl)-import Fmt (Buildable(..), Builder, build, pretty, unlinesF, (+|), (|+))+import Fmt (Buildable(..), Doc, build, nameF, pretty, unlinesF, (+|), (|+)) import Time (Second, toNum, toUnit)  import Lorentz (Mutez, NiceComparable, pattern DefEpName)@@ -32,7 +31,7 @@ import Morley.Client.Types (AddressWithAlias(..)) import Morley.Michelson.Interpret   (InterpretError(..), MichelsonFailed(..), MichelsonFailureWithStack(..), ResultStateLogs(..))-import Morley.Michelson.Runtime hiding (ExecutorOp(..), transfer)+import Morley.Michelson.Runtime hiding (transfer) import Morley.Michelson.Runtime qualified as Runtime import Morley.Michelson.Runtime.Dummy   (dummyLevel, dummyMaxSteps, dummyMinBlockTime, dummyNow, dummyOrigination)@@ -41,6 +40,7 @@   gsChainIdL, gsContractAddressAliasesL, gsContractAddressesL, gsImplicitAddressAliasesL,   gsVotingPowersL, initGState, lookupBalance, toTicketKey) import Morley.Michelson.TypeCheck (TcError)+import Morley.Michelson.TypeCheck qualified as TC import Morley.Michelson.Typed   (BigMapId(..), IsoValue, SingI, SomeAnnotatedValue(..), SomeVBigMap(..), ToT, Value, Value'(..),   castM, fromVal, toVal)@@ -95,10 +95,9 @@  instance Buildable TestError where   build = \case-    UnexpectedTypeCheckError tcErr ->-      "Unexpected type check error. Reason: " +| tcErr |+ ""-    UnexpectedStorageType merr ->-      "Unexpected storage type.\n" +| merr |+ ""+    UnexpectedTypeCheckError tcErr -> nameF "Unexpected type check error. Reason" $ build tcErr+    UnexpectedStorageType merr -> build $+      TC.UnexpectedTopLevelType TC.TltStorageType merr     UnexpectedBigMapType bigMapId mismatchError ->       unlinesF         [ "A big_map with the ID " +| bigMapId |+ " was found, but it does not have the expected type."@@ -150,10 +149,9 @@         OpTransfer TransferData{..} ->           OpTransfer <$> doTransfer sender tdTo tdAmount tdEntrypoint tdParameter         OpTransferTicket TransferTicketData{..}-          | T.VTicket _ (_ :: T.Value t) _ <- ttdParameter-          , Refl <- T.comparabilityImpliesNoOp @t-          -> OpTransferTicket <$>-            doTransfer sender ttdTo zeroMutez ttdEntrypoint ttdParameter+          | T.VTicket _ val _ <- ttdParameter+          , T.Dict <- T.comparableImplies val+          -> OpTransferTicket <$> doTransfer sender ttdTo zeroMutez ttdEntrypoint ttdParameter         OpReveal{} -> do           -- We do not care about reveals in our Morley runtime           return $ OpReveal ()@@ -302,7 +300,7 @@           \\ rpcStorageScopeEvi @t      cmiTicketBalance-      :: forall t. (T.HasNoOp t, T.Comparable t)+      :: forall t. (T.Comparable t)       => L1Address -> ContractAddress -> T.Value t -> PureM Natural     cmiTicketBalance (Constrained owner) ticketer value = case owner of       ContractAddress{} -> do@@ -345,7 +343,7 @@         seedInt = os2ip seedBytes         keyTypes = filter (/= KeyTypeBLS) [minBound..]         keyType = keyTypes Unsafe.!!-          (fromIntegralOverflowing $ seedInt `mod` fromIntegral (length keyTypes))+          (fromIntegralOverflowing $ seedInt `mod` length keyTypes)         sk = detSecretKey' keyType seedBytes        importSecretKey sk alias@@ -383,7 +381,8 @@             resolveRunCodeBigMaps bigMapFinder       rcParameterT <- tcBm rcParameter       rcStorageT <- tcBm rcStorage-      (_, finalStorage) <- either (throwEE . EEInterpreterFailed (toAddress sender)) pure $+      let liftError = throwEE . ExecutorError mempty .  EEInterpreterFailed (toAddress sender)+      (_, finalStorage) <- either liftError pure $         Runtime.runCode           (Runtime.runCodeParameters contract rcStorageT epc rcParameterT)             { Runtime.rcAmount = rcAmount@@ -419,27 +418,35 @@   Right res -> return res   where     exceptionToTransferFailure :: ExecutorError' AddressAndAlias -> PureM TransferFailure-    exceptionToTransferFailure err = case err of+    exceptionToTransferFailure err@ExecutorError{..} = case eeError of       EEZeroTransaction addr -> return $-        TransferFailure addr EmptyTransaction+        TransferFailure addr callSeq EmptyTransaction       EEIllTypedParameter addr _ -> return $-        TransferFailure addr BadParameter+        TransferFailure addr callSeq BadParameter       EEUnexpectedParameterType addr _ -> return $-        TransferFailure addr BadParameter+        TransferFailure addr callSeq BadParameter       EEInterpreterFailed addr (InterpretError{ieFailure=MichelsonFailureWithStack{..}}) ->-        case mfwsFailed of-          MichelsonFailedWith val -> return $-            TransferFailure addr $-              FailedWith (EOTVTypedValue val) (Just mfwsErrorSrcPos)-          MichelsonArithError (T.ShiftArithError{}) -> return $-            TransferFailure addr ShiftOverflow-          MichelsonArithError (T.MutezArithError errType _ _) -> return $-            TransferFailure addr $ MutezArithError errType-          MichelsonGasExhaustion -> return $-            TransferFailure addr GasExhaustion+        TransferFailure addr callSeq <$> case mfwsFailed of+          MichelsonFailedWith val -> pure $ FailedWith (EOTVTypedValue val) (Just mfwsErrorSrcPos)+          MichelsonArithError (T.ShiftArithError{}) -> pure ShiftOverflow+          MichelsonArithError (T.MutezArithError errType _ _) -> pure $ MutezArithError errType+          MichelsonGasExhaustion -> pure GasExhaustion           _ -> throwM err       _ -> throwM err+      where+        callSeq = pureToCallSeq eeCallStack +pureToCallSeq :: [ExecutorOp] -> CallSequence+pureToCallSeq = toCallSeq \op -> case op of+  TransferOp TransferOperation{..} ->+    Just . (toAddress $ tdSenderAddress toTxData,) . CallSequenceOp op . CallSequence+      <$> popToCallSeq toDestination+  OriginateOp OriginationOperation{..} ->+    pure $ Just (toAddress ooOriginator, CallSequenceOp op mempty)+  SetDelegateOp SetDelegateOperation{..} ->+    pure $ Just (toAddress sdoContract, CallSequenceOp op mempty)+  EmitOp EmitOperation{..} ->+    pure $ Just (toAddress eoSource, CallSequenceOp op mempty)  getMorleyLogsImpl :: PureM a -> PureM (LogsInfo, a) getMorleyLogsImpl action = swap <$> listen action@@ -490,7 +497,7 @@   throwM . CustomTestError .   mappend "Unknown address alias: " . pretty -failure :: forall a. Builder -> PureM a+failure :: forall a. Doc -> PureM a failure = throwM . CustomTestError . pretty  getSecretKey :: ImplicitAddress -> PureM SecretKey@@ -582,7 +589,8 @@   where     extractLogs :: Either ExecutorError (ExecutorRes, a) -> [ScenarioLogs]     extractLogs = \case-      Left (EEInterpreterFailed addr InterpretError{..}) -> [ScenarioLogs addr ieLogs]+      Left (ExecutorError _ (EEInterpreterFailed addr InterpretError{..})) ->+        [ScenarioLogs addr ieLogs]       Right (res, _) -> res ^. erInterpretResults <&>         \(addr, SomeInterpretResult ResultStateLogs{..}) -> ScenarioLogs addr rslLogs       _ -> []

@@ -10,7 +10,7 @@  import Data.Aeson (eitherDecode, encode) import Data.Map qualified as Map-import Fmt (Buildable(..), blockMapF, nameF, pretty, unlinesF)+import Fmt (Buildable(..), blockMapF, isEmpty, nameF, pretty, unlinesF) import Test.HUnit (Assertion, assertFailure) import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (testCase)@@ -48,7 +48,7 @@ instance Buildable EPMismatch where   build EPComparisonResultOK = "Entrypoints match specificaton"   build EPMismatch{..} = nameF "Entrypoints do not match specification" $-    unlinesF $ filter (/=mempty) [extra, missing, typemm]+    unlinesF $ filter (not . isEmpty) [extra, missing, typemm]     where     extra | null epmmExtra = mempty           | otherwise = nameF "Extraneous entrypoints in the contract" $ blockMapF epmmExtra

@@ -11,8 +11,9 @@ import Data.Char (isPrint, isSpace) import Data.Ix (Ix(inRange)) import Data.List qualified as List+import Data.Text (justifyRight) import Data.Text.IO.Utf8 qualified as Utf8-import Fmt (Buildable(build), Builder, indentF, padLeftF, unlinesF, (+|), (|+))+import Fmt (Buildable(build), Doc, indentF, unlinesF, (+|), (|+)) import GHC.Stack (SrcLoc(..)) import System.Directory (makeRelativeToCurrentDirectory) import System.IO.Error@@ -60,7 +61,7 @@   :: Natural -- ^ The number of source code lines to print before and after the location of the error   -> CallStack -- ^ The error's callstack   -> String -- ^ The error message to display below the expression that caused the error-  -> IO Builder+  -> IO Doc formatError contextLines cstack errMsg = do   case getLocation cstack of     Nothing -> pure $ build errMsg@@ -86,7 +87,7 @@         <> (srcLineF lineNumberPadding <$> afterLines)         <> ["", build (prettyCallStack cstack)]   where-    handleIOError :: IOError -> IO Builder+    handleIOError :: IOError -> IO Doc     handleIOError err =       if isAlreadyInUseError err || isDoesNotExistError err || isPermissionError err         then pure $ unlinesF $@@ -132,33 +133,34 @@ -- Formatters ---------------------------------------------------------------------------- -verticalBorder :: Builder+verticalBorder :: Doc verticalBorder = " ┃ " -headerF :: Int -> FilePath -> Builder+headerF :: Int -> FilePath -> Doc headerF lineNumberPadding path =   indentF lineNumberPadding $     " ┏━━ " +| path |+ " ━━━" -srcLineF :: Int -> Line -> Builder+srcLineF :: Int -> Line -> Doc srcLineF lineNumberPadding line =-  padLeftF lineNumberPadding ' ' (lineNumber line) +| verticalBorder +| build (lineText line)+  justifyRight lineNumberPadding ' ' (show $ lineNumber line)+     |+ verticalBorder +| build (lineText line) -errorMsgF :: Int -> SrcLoc -> NonEmpty Line -> String -> [Builder]+errorMsgF :: Int -> SrcLoc -> NonEmpty Line -> String -> [Doc] errorMsgF lineNumberPadding loc errorLines errMsg =   indentF lineNumberPadding . addPadding <$>     (carets : errLines)   where     (startColumn, endColumn) = caretColumns loc errorLines -    addPadding :: Builder -> Builder+    addPadding :: Doc -> Doc     addPadding line =       verticalBorder +| indentF (startColumn - 1) line -    carets :: Builder+    carets :: Doc     carets = build $ replicate (endColumn - startColumn) '^' -    errLines :: [Builder]+    errLines :: [Doc]     errLines = List.lines errMsg <&> \line ->       "| " +| build line 

@@ -68,7 +68,7 @@ import Data.Text qualified as T import Data.Time (NominalDiffTime, secondsToNominalDiffTime) import Data.Typeable (typeRep)-import Fmt (Buildable, Builder, build, pretty, (+|), (|+))+import Fmt (Buildable, Doc, build, pretty, (+|), (|+)) import Hedgehog   (Gen, MonadGen, MonadTest, Property, annotate, evalIO, failure, forAll, property, success,   tripping, withTests)@@ -80,8 +80,8 @@ import Statistics.Types (Estimate(estPoint)) import Test.HUnit (Assertion, assertFailure) import Test.Tasty (TestTree)-import Test.Tasty.HUnit (testCase) import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty.HUnit (testCase) import Text.Hex (decodeHex) import Text.Printf (printf) import Text.Show qualified@@ -298,10 +298,10 @@ -- Pretty-printing ---------------------------------------------------------------------------- -formatValue :: forall t. SingI t => T.Value t -> Builder+formatValue :: forall t. SingI t => T.Value t -> Doc formatValue v = "" +| build v |+ " of type " +| demote @t |+ "" -formatSomeValue :: (forall t. c t => SingI t) => SomeConstrainedValue c -> Builder+formatSomeValue :: (forall t. c t => SingI t) => SomeConstrainedValue c -> Doc formatSomeValue = foldConstrained formatValue  -- | Derive a 'Show' instance for a type using a custom "show" function.

@@ -20,7 +20,7 @@  import Test.Cleveland -import Morley.Util.Interpolate (i)+import Morley.Util.Interpolate (i, itu) import TestSuite.Util (shouldFailWithMessage)  {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}@@ -92,11 +92,13 @@ test_checkComparesWith_fails =   testScenario "`checkComparesWith` fails when the comparison fails and prints values" $ scenario do     checkComparesWith @Int toCardinal 1 elem (pretty . fmap toOrdinal) [2, 3]-      & shouldFailWithMessage [i|-━━ lhs ━━-One-━━ rhs ━━-[Second,Third]|]+      & shouldFailWithMessage [itu|+          Failed+          ━━ lhs ━━+          One+          ━━ rhs ━━+          [Second, Third]+          |]   where     toCardinal = \case       1 -> "One"

@@ -26,7 +26,7 @@             Ty (TOr do1 do1 (Ty TInt n)                  (Ty (TPair n n n n (Ty TInt n) (Ty TInt n)) n)) n) n         , contractStorage = Ty TUnit n-        , contractCode = []+        , contractCode = SeqEx []         , entriesOrder = def         , contractViews = def         }

@@ -13,7 +13,7 @@  import Lorentz as L hiding (comment) -import Fmt (Builder, jsonListF', pretty, unlinesF)+import Fmt (Doc, listF', nameF, pretty) import Hedgehog (Gen, Property, PropertyT, forAllWith, property) import Hedgehog.Gen qualified as Gen import Test.Tasty (TestTree, testGroup)@@ -25,8 +25,8 @@ import Morley.Util.Interpolate (it) import Test.Cleveland import Test.Cleveland.Internal.Abstract-  (AddressAndAlias(..), ExpressionOrTypedValue(..), GenericTestError(..), TransferFailure(..),-  TransferFailureReason(..))+  (AddressAndAlias(..), CallSequence, ExpressionOrTypedValue(..), GenericTestError(..),+  TransferFailure(..), TransferFailureReason(..)) import Test.Cleveland.Internal.Actions (TransferFailurePredicate(..)) import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Util (failedTest, fromHex)@@ -156,7 +156,7 @@                 annotateExceptions (ScenarioBranchName ["a"]) $                   addCallStack $                     annotateExceptions (ScenarioBranchName ["b"]) $-                      throwM $ TransferFailure (AddressAndAlias [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] Nothing) BadParameter+                      throwM $ TransferFailure (AddressAndAlias [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] Nothing) fcs BadParameter      res <- attempt @TransferFailure action @@ -273,20 +273,16 @@            forM_ ps (isFlattened predicate) -    showPredicate :: TransferFailurePredicate -> Builder+    showPredicate :: TransferFailurePredicate -> Doc     showPredicate = \case       TransferFailurePredicate{} ->         "TransferFailurePredicate (TransferFailurePredicateDesc  \"\" (const True))"       AndPredicate ps ->-        pretty $ unlinesF-          [ "AndPredicate"-          , jsonListF' showPredicate ps-          ]+        pretty $ nameF "AndPredicate" $+          listF' showPredicate ps       OrPredicate ps ->-        pretty $ unlinesF-          [ "OrPredicate"-          , jsonListF' showPredicate ps-          ]+        pretty $ nameF "OrPredicate" $+          listF' showPredicate ps      genTransferFailurePredicate :: Gen TransferFailurePredicate     genTransferFailurePredicate =@@ -322,12 +318,12 @@  impl_test_AndPredicate_succeeds_if_all_conditions_hold conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) fcs $ 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 genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) fcs $ FailedWith (conv $ toVal @Integer 1) Nothing     checkTransferFailure err $       failedWith (constant @Integer 1) ||       failedWith (constant @Integer 2) ||@@ -335,7 +331,7 @@  impl_test_AndPredicate_fails_if_any_condition_fails conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) fcs $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( failedWith (constant @Integer 1) &&@@ -357,7 +353,7 @@  impl_test_OrPredicate_fails_if_all_conditions_fail conv =   testScenario "AndPredicate succeeds if all conditions hold" $ scenario do-    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) fcs $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( failedWith (constant @Integer 2) ||@@ -381,7 +377,7 @@  impl_test_checkTransferFailure_shows_only_failing_predicates conv =   testScenario "checkTransferFailure shows only failing predicates" $ scenario do-    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) $ FailedWith (conv $ toVal @Integer 1) Nothing+    let err = TransferFailure (AddressAndAlias genesisAddress1 Nothing) fcs $ FailedWith (conv $ toVal @Integer 1) Nothing      checkTransferFailure err       ( (failedWith (constant @Integer 1) && failedWith (constant @Integer 2)) &&@@ -409,3 +405,7 @@ But these conditions were not met. Actual transfer error:   Contract: #{genesisAddress1} failed with: 1|]++-- | Fake contract call sequence.+fcs :: CallSequence+fcs = mempty

@@ -0,0 +1,171 @@+-- SPDX-FileCopyrightText: 2023 Oxhead Alpha+-- SPDX-License-Identifier: LicenseRef-MIT-OA++{-# LANGUAGE QualifiedDo, NoApplicativeDo #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++module TestSuite.Cleveland.FailureSequence+  ( test_FailureSequence+  , test_FailureTree+  ) where++import Lorentz qualified as L+import Lorentz.Instr as L+import Lorentz.Macro as L++import Test.Tasty (TestTree)++import Morley.Michelson.Typed (untypeValueOptimized)+import Morley.Michelson.Untyped qualified as U+import Morley.Tezos.Crypto.Util (encodeBase58Check)+import Morley.Util.Interpolate (itu)+import Test.Cleveland+import Test.Cleveland.Internal.Abstract (Sender(..), senderL)+import TestSuite.Util+import TestSuite.Util.Contracts (inContractsDir)++test_FailureSequence :: TestTree+test_FailureSequence =+  testScenario "Prints contract call sequence on failure" $ scenario do+    testContract <- importContract @Integer @Natural @() $+      inContractsDir "call_self_several_times_then_fail_in_view.tz"+    contractHndl <- originate "Test failure call sequence" 0 testContract [tz|100u|]+    Sender (toAddress -> senderAddr) <- Prelude.view senderL++    let contractAddr = toAddress contractHndl++    msg <- ifEmulation+      (pure [itu|+        Call chain:+        - Transfer to #{contractAddr} entrypoint <default> from+          #{senderAddr} with parameter '9' and amount 0 μꜩ+        - Transfer to #{contractAddr} entrypoint <default> from+          #{contractAddr} with parameter '8' and amount 1 μꜩ+        - Transfer to #{contractAddr} entrypoint <default> from+          #{contractAddr} with parameter '7' and amount 1 μꜩ+        - Transfer to #{contractAddr} entrypoint <default> from+          #{contractAddr} with parameter '6' and amount 1 μꜩ++        |])+      (pure [itu|+        Call chain:+        - Transaction with amount: 0 μꜩ, destination:+          #{contractAddr}, and parameter:+          entrypoint: default, value: 9+        - Transaction with amount: 1 μꜩ, destination:+          #{contractAddr}, and parameter:+          entrypoint: default, value: 8+        - Transaction with amount: 1 μꜩ, destination:+          #{contractAddr}, and parameter:+          entrypoint: default, value: 7+        - Transaction with amount: 1 μꜩ, destination:+          #{contractAddr}, and parameter:+          entrypoint: default, value: 6++        |])++    transfer contractHndl (calling def 9) &+      shouldFailWithMessage msg++test_FailureTree :: TestTree+test_FailureTree =+  testScenario "Prints only the last branch of the call tree on failure" $ scenario do+    (callingSelf, callingOther, callingTree) <- inBatch $+      (,,) <$> (L.toContractRef <$> originate "CallingSelf" () callingSelfCt)+           <*> (L.toContractRef <$> originate "CallingOther" () callingOtherCt)+           <*> (originate "CallingTree" () callingTreeCt)+    Sender (toAddress -> senderAddr) <- Prelude.view senderL++    let selfBs = formatAddr $ toAddress callingSelf+        otherBs = formatAddr $ toAddress callingOther+        -- annoyingly, address is passed as bytes, and when we get it as+        -- Expression from network, it's like this.+        formatAddr = encodeBase58Check . unBytes . untypeValueOptimized . L.toVal+        unBytes = \case+          U.ValueBytes (U.InternalByteString bs) -> bs+          _ -> error "impossible"+        callingTreeAddr = toAddress callingTree+        callingSelfAddr = toAddress callingSelf+        callingOtherAddr = toAddress callingOther++    msg <- ifEmulation+      (pure [itu|+        Call chain:+        - Transfer to #{callingTreeAddr} entrypoint <default> from+          #{senderAddr} with parameter+            Pair+              "#{callingSelfAddr}"+              "#{callingOtherAddr}"+          and amount 0 μꜩ+        - Transfer to #{callingSelfAddr} entrypoint <default> from+          #{callingTreeAddr} with parameter '-1' and amount 0 μꜩ++        |])+      (pure [itu|+        Call chain:+        - Transaction with amount: 0 μꜩ, destination:+          #{callingTreeAddr}, and parameter:+          entrypoint: default, value:+          [#{selfBs}, #{otherBs}]+        - Transaction with amount: 0 μꜩ, destination:+          #{callingSelfAddr}, and parameter:+          entrypoint: default, value: -1++        |])++    addr <- newFreshAddress auto++    inBatch (transfer addr [tz|100u|] *> transfer callingTree (calling def (callingSelf, callingOther))) &+      shouldFailWithMessage msg++    transfer callingTree (calling def (callingSelf, callingOther)) &+      shouldFailWithMessage msg++callingSelfCt :: L.Contract Integer () ()+callingSelfCt = L.defaultContract L.do+  car+  dup+  dup+  isNat+  assertSome [L.mt|foobar|]+  L.drop+  ifEq0 (L.drop L.# unit L.# nil L.# pair) L.do+    push @Integer 1+    rsub+    dip L.do+      selfCalling @Integer CallDefault+      push 0+    transferTokens+    dip nil+    cons+    dip unit+    pair++callingOtherCt :: L.Contract (L.ContractRef Integer) () ()+callingOtherCt = L.defaultContract L.do+  car+  push 0+  push 5+  transferTokens+  dip nil+  cons+  dip unit+  pair++callingTreeCt :: L.Contract (L.ContractRef Integer, L.ContractRef (L.ContractRef Integer)) () ()+callingTreeCt = L.defaultContract L.do+  car+  unpair+  dup+  dip L.do+    dip $ push 0+    transferTokens+    dip nil+  push 0+  push (-1)+  transferTokens+  L.swap+  dip cons+  cons+  dip unit+  pair

@@ -108,8 +108,10 @@   , testContractCoversEntrypoints       "testContractCoversEntrypoints fails on missing entrypoints"         (idContract @MyEntrypoints1 @()) [ ( #do123, [utypeQ| int |] ) ]-      & expectFailure "Entrypoints do not match specification: \-          \Missing entrypoints in the contract: do123: int"+      & expectFailure [itu|+          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) |] ) ]@@ -168,8 +170,11 @@   , 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)"+      & expectFailure [itu|+          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 @()) $@@ -183,8 +188,10 @@   , 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"+      & expectFailure [itu|+          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 |] ) ])

@@ -10,7 +10,7 @@   , unit_StackEqError   ) where -import Fmt (pretty)+import Fmt (pretty, prettyText) import Test.Tasty.HUnit (Assertion, (@?=))  import Morley.Michelson.TypeCheck.Error@@ -36,13 +36,13 @@  unit_StackEqErrorSimple :: Assertion unit_StackEqErrorSimple = do-  pretty @_ @Text (+  prettyText (     StackEqError       MkMismatchError { meExpected = [T.TInt], meActual = [T.TUnit] })     @?= [itu|       Stacks not equal:-      Expected: [int]-      Actual:   [unit]+        Expected: [int]+        Actual:   [unit]       |]  unit_UnexpectedStorageType :: Assertion@@ -61,7 +61,7 @@  unit_StackEqError :: Assertion unit_StackEqError = do-  pretty @_ @Text (+  prettyText (     StackEqError       MkMismatchError         { meExpected =@@ -74,28 +74,28 @@           ]})     @?= [itu|       Stacks not equal:-      Expected: [pair int nat bytes, pair nat unit bool]-      Actual:   [pair unit nat bytes, pair nat int bool, pair nat nat]-      Mismatch:-        --- expected +++ actual-      - [ pair int nat bytes-      - , pair nat unit bool-      + [ pair unit nat bytes-      + , pair nat int bool-      + , pair nat nat-        ]+        Expected: [pair int nat bytes, pair nat unit bool]+        Actual:   [pair unit nat bytes, pair nat int bool, pair nat nat]+        Mismatch:+          --- expected +++ actual+        - [ pair int nat bytes+        - , pair nat unit bool+        + [ pair unit nat bytes+        + , pair nat int bool+        + , pair nat nat+          ]       |]  expectedSimple :: Text expectedSimple = [itu|-  Unexpected storage type.-  Expected: int-  Actual:   unit+  Unexpected storage type:+    Expected: int+    Actual:   unit   |]  expected :: Text expected = [itu|-  Unexpected storage type.-  Expected: int-  Actual:   pair unit nat bytes+  Unexpected storage type:+    Expected: int+    Actual:   pair unit nat bytes   |]

@@ -12,7 +12,7 @@   ) where  import Control.Lens (from, (^?!))-import Fmt (Buildable(..), GenericBuildable(..))+import Fmt (Buildable(..)) import System.FilePath ((</>)) import Test.Tasty (TestTree) @@ -31,8 +31,7 @@   , _stField2 :: BigMap Natural MText   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (IsoValue, HasAnnotation)-  deriving Buildable via GenericBuildable Storage+  deriving anyclass (IsoValue, HasAnnotation, Buildable)  deriveRPC "Storage" 

@@ -22,9 +22,8 @@ import Control.Lens (to) import Data.Data (Data) import Data.Data.Lens (biplate)-import Fmt (Builder, blockListF, unlinesF)+import Fmt (Doc, blockListF, unlinesF) import Test.Tasty (TestTree, testGroup)-import Unsafe qualified (fromIntegral)  import Test.Cleveland import TestSuite.Util (idContract, saveInStorageContract)@@ -239,7 +238,7 @@     length bigMapIds @== 30      assert (bigMapIds == ordNub bigMapIds) $-      unlinesF @[] @Builder+      unlinesF @[] @Doc         [ "Expected all big_maps to have unique IDs, but some duplicates were found:"         , blockListF (sort bigMapIds)         ]@@ -271,15 +270,13 @@ test_getBigMapSize :: TestTree test_getBigMapSize =   testScenario "getBigMapSize retrieves the correct size" $ scenario do-    let-      bmList = sampleList ++ [(5, "d")]-      expectedSize = Unsafe.fromIntegral @Int @Natural $ length bmList+    let bmList = sampleList ++ [(5, "d")]     c <- originate "contract" (mkBigMap bmList) $ idContract @() @(BigMap Integer MText)      bigMapId <- getStorage c     bmSize <- getBigMapSize bigMapId -    bmSize @== expectedSize+    bmSize @== length bmList  test_getAllBigMapValues :: TestTree test_getAllBigMapValues =

@@ -8,7 +8,7 @@  import Data.Char (isSpace) import Data.Text qualified as Text-import Fmt (build, indentF, pretty, unlinesF)+import Fmt (build, indentF, pretty, prettyText, unlinesF) import GHC.Stack (SrcLoc(..), fromCallSiteList) import System.FilePath ((</>)) import Test.Tasty (TestName, TestTree, testGroup)@@ -16,6 +16,8 @@ import Test.Tasty.Options (singleOption) import Test.Tasty.Runners (Result(resultDescription)) +import Morley.Util.Interpolate (itu)+ import Test.Cleveland import Test.Cleveland.Tasty.Internal.Options (ContextLinesOpt(ContextLinesOpt)) import Test.Cleveland.Tasty.Internal.Report (formatError)@@ -66,10 +68,10 @@       )       "err msg" -  pretty builder @?=-    unlines-      [ "err msg"-      , ""-      , "CallStack (from HasCallStack):"-      , toText ("  expectCustomError_, called at src" </> "invalid" </> "path:1:1 in pkg:Module")-      ]+  prettyText builder @?= let path = "src" </> "invalid" </> "path" in+    [itu|+      err msg++      CallStack (from HasCallStack):+        expectCustomError_, called at #{path}:1:1 in pkg:Module+      |]

@@ -70,7 +70,7 @@   assert (x `elem` xs) $ "Expected " +| xs |+ " to contain " +| x |+ ""  ticketerContract-  :: (NiceComparable t, NiceParameter t, HasAnnotation t)+  :: (NiceComparable t, NiceParameter t, NiceStorage t, HasAnnotation t)   => Contract (t, Natural) [Ticket t] () ticketerContract = defaultContract   $ unpair

@@ -21,11 +21,11 @@ import Lorentz  import Data.List (isInfixOf)-import Fmt (Buildable, GenericBuildable(..), build, indentF, pretty, unlinesF)+import Fmt (Buildable, build, indentF, pretty, unlinesF) import Hedgehog (Property) import System.Environment (lookupEnv, setEnv, unsetEnv)-import Test.Tasty.HUnit (Assertion, assertFailure, testCase) import Test.Tasty.Hedgehog (testProperty)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase) import Test.Tasty.Options (OptionSet, singleOption) import Test.Tasty.Providers (IsTest(run), TestName) import Test.Tasty.Runners@@ -165,5 +165,4 @@   , ssField2 :: Natural   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (IsoValue)-  deriving Buildable via GenericBuildable BigMapInStorage+  deriving anyclass (IsoValue, Buildable)