diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,15 @@ +0.4.0 +===== +* [!1369](https://gitlab.com/morley-framework/morley/-/merge_requests/1369) + Move `Default` instance for `EntrypointRef` to Lorentz +* [!1364](https://gitlab.com/morley-framework/morley/-/merge_requests/1364) + Update to LTS-21.4 (GHC 9.4.5) +* [!1358](https://gitlab.com/morley-framework/morley/-/merge_requests/1358) + Make missing Generic errors more readable + 0.3.2 ===== * [!1323](https://gitlab.com/morley-framework/morley/-/merge_requests/1323) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ -> :warning: **Note: this project is being deprecated.** +> :warning: **Note: this project is deprecated.** > -> It will no longer be maintained after the activation of protocol "N" on the Tezos mainnet. +> It is no longer maintained since the activation of protocol "Nairobi" on the Tezos mainnet (June 24th, 2023). # Cleveland: A testing framework for Morley diff --git a/cleveland.cabal b/cleveland.cabal --- a/cleveland.cabal +++ b/cleveland.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: cleveland -version: 0.3.2 +version: 0.4.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 @@ -154,7 +154,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 + 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-missing-kind-signatures -Wno-implicit-lift -Wno-unticked-promoted-constructors build-depends: HUnit , MonadRandom @@ -309,7 +309,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 -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 -Wno-missing-kind-signatures -Wno-implicit-lift -Wno-unticked-promoted-constructors -threaded -rtsopts "-with-rtsopts=-N -A64m -AL256m" -Wno-unused-imports build-tool-depends: tasty-discover:tasty-discover build-depends: diff --git a/src/Lorentz/Test/DupableScan.hs b/src/Lorentz/Test/DupableScan.hs --- a/src/Lorentz/Test/DupableScan.hs +++ b/src/Lorentz/Test/DupableScan.hs @@ -21,9 +21,14 @@ import Lorentz import Morley.Michelson.Typed.Scope +import Morley.Util.Generic import Morley.Util.Type import Morley.Util.TypeLits +{- $setup +>>> import Lorentz +-} + -- | Bind on 'Either's that return nothing. type SumEithers :: Either l () -> Either l () -> Either l r type family SumEithers e1 e2 where @@ -50,9 +55,16 @@ -- | For the given type, check that at the left subtree of pairs tree it -- contains only dupable elements, and at the right - only non-dupable ones. -type family CheckDupablesDistribution (a :: Type) :: Either (Bool, Maybe Symbol, Type) () where - CheckDupablesDistribution a = GCheckDupablesDistribution (G.Rep a) +-- +-- On ambiguity, evaluation is delayed to avoid exposing Generic internals. +type CheckDupablesDistribution :: Type -> Either (Bool, Maybe Symbol, Type) () +type family CheckDupablesDistribution a where + CheckDupablesDistribution ThisTypeShallNotBeExported = TypeError ('Text "impossible") + CheckDupablesDistribution a = GCheckDupablesDistribution (GRep a) +-- | Dummy type to delay evaluation of 'CheckDupablesDistribution'. +data ThisTypeShallNotBeExported + -- | Error for 'checkDupablesDistribution'. data BadElement = BadElement { beExpectedDupability :: Bool @@ -76,7 +88,35 @@ , beRecType = typeRep (Proxy @ty) } --- | 'CheckDupablesDistribution' for term-level. +{- | 'CheckDupablesDistribution' for term-level. + +Shows decent error messages on missing 'Generic' instance. + +>>> checkDupablesDistribution +... +... Ambiguous type variable ‘a0’ arising from a use of ‘checkDupablesDistribution’ +... prevents the constraint ‘(Lorentz.Test.DupableScan.DemoteRes +... (CheckDupablesDistribution a0))’ from being solved. +... + +The type must have a 'Generic' instance. + +>>> data Foo = Foo () (Ticket ()) +>>> checkDupablesDistribution @Foo +... +... GHC.Generics.Rep Foo +... is stuck. Likely +... Generic Foo +... instance is missing or out of scope. +... + +The type itself needn't necessarily have @IsoValue@ instance, but all its leaves +must. + +>>> data Foo = Foo () (Ticket ()) deriving Generic +>>> checkDupablesDistribution @Foo +Right () +-} checkDupablesDistribution :: forall a. (DemoteRes (CheckDupablesDistribution a)) => Either BadElement () diff --git a/src/Test/Cleveland/Instances.hs b/src/Test/Cleveland/Instances.hs --- a/src/Test/Cleveland/Instances.hs +++ b/src/Test/Cleveland/Instances.hs @@ -13,7 +13,7 @@ import Test.Tasty.Runners (FailureReason(..)) import Time (Time) -import Lorentz.Entrypoints.Core (EntrypointRef(..), NiceEntrypointName) +import Lorentz.Entrypoints.Core (NiceEntrypointName) import Morley.Michelson.Text (MText, mkMText) import Morley.Michelson.Typed.Haskell.Value (BigMap(..)) import Morley.Michelson.Untyped qualified as U @@ -124,9 +124,6 @@ TestThrewException e -> "Test threw exception: " +| displayException e |+ "" TestTimedOut s -> "Test timed out: " +| s |+ "" TestDepFailed -> "Test skipped because its dependency failed" - -instance mname ~ 'Nothing => Default (EntrypointRef mname) where - def = CallDefault instance Default U.EpName where def = U.DefEpName diff --git a/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs b/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs --- a/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs +++ b/src/Test/Cleveland/Internal/Actions/ExceptionHandling.hs @@ -43,9 +43,9 @@ -- exception. -- -- > expectTransferFailure (failedWith (constant @MText "NOT_ADMIN")) $ --- > call contractAddr (Call @"Ep") arg +-- > call contractAddr #ep arg -- --- > call contractAddr (Call @"Ep") arg & expectTransferFailure +-- > call contractAddr #ep arg & expectTransferFailure -- > ( failedWith (customError #tag 3) && -- > addressIs contractAddr -- > ) diff --git a/src/Test/Cleveland/Internal/Actions/Misc.hs b/src/Test/Cleveland/Internal/Actions/Misc.hs --- a/src/Test/Cleveland/Internal/Actions/Misc.hs +++ b/src/Test/Cleveland/Internal/Actions/Misc.hs @@ -10,7 +10,7 @@ import Data.Singletons (demote) import Fmt (Buildable, Doc, build, indentF, unlinesF, (+|), (|+)) -import Time (KnownDivRat, Second, Time, toNum) +import Time (KnownDivRat, Second, Time, floorRat) import Lorentz (BigMapId, Contract(..), DemoteViewsDescriptor, IsoValue) import Lorentz.Bytes @@ -116,7 +116,7 @@ :: forall n n' caps m. (HasCallStack, MonadCleveland caps m, IsoNatPeano n n') => SizedList n SpecificOrDefaultAlias - -> m (SizedList n ImplicitAddressWithAlias) + -> m (SizedList' n' ImplicitAddressWithAlias) newAddresses aliases = do addrs <- withCap getMiscCap \cap -> traverse (cmiGenKey cap) aliases Moneybag moneybag <- view moneybagL @@ -160,7 +160,7 @@ enumAliases :: forall n n'. (SingIPeano n, IsoNatPeano n n') - => ImplicitAlias -> SizedList n SpecificOrDefaultAlias + => ImplicitAlias -> SizedList' n' SpecificOrDefaultAlias enumAliases (ImplicitAlias pfx) = SpecificAlias <$> SL.generate @n (\n -> ImplicitAlias $ pfx <> "-" <> show n) @@ -452,7 +452,7 @@ -- -- Can be useful when testing code using @MIN_BLOCK_TIME@ instruction. getMinBlockTime :: (HasCallStack, MonadCleveland caps m) => m Natural -getMinBlockTime = toNum @Second <$> getApproximateBlockInterval +getMinBlockTime = floorRat <$> getApproximateBlockInterval -- | Execute a contract's code without originating it. -- The chain's state will not be modified. diff --git a/src/Test/Cleveland/Internal/Actions/MonadOps.hs b/src/Test/Cleveland/Internal/Actions/MonadOps.hs --- a/src/Test/Cleveland/Internal/Actions/MonadOps.hs +++ b/src/Test/Cleveland/Internal/Actions/MonadOps.hs @@ -19,7 +19,7 @@ -- 'MonadOps' constraint on it, f. ex.: -- -- > callEp1 :: MonadOps m => ContractHandle MyParam () () -> Integer -> m () --- > callEp1 ch = transfer ch . calling (ep @"Entrypoint1") +-- > callEp1 ch = transfer ch . calling #entrypoint1 class (MonadTransfer m, MonadOriginate m) => MonadOps m instance (MonadTransfer m, MonadOriginate m) => MonadOps m diff --git a/src/Test/Cleveland/Internal/Actions/Transfer.hs b/src/Test/Cleveland/Internal/Actions/Transfer.hs --- a/src/Test/Cleveland/Internal/Actions/Transfer.hs +++ b/src/Test/Cleveland/Internal/Actions/Transfer.hs @@ -66,7 +66,7 @@ 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|] $ calling #entrypoint () > transfer addr [tz|123u|] If the call isn't specified, then the default entrypoint will be called with @@ -117,7 +117,7 @@ :} GHC may not always figure out the type of the entrypoint parameter. In that -case, it'll show unbound type variable, usually @arg0@: +case, it'll show unbound type variable, usually @arg@ or @arg0@: >>> :{ example @@ -129,7 +129,7 @@ ... Can not look up entrypoints in type ... cp ... The most likely reason it is ambiguous, or you need -... HasEntrypointArg cp (EntrypointRef 'Nothing) arg0 +... HasEntrypointArg cp (EntrypointRef 'Nothing) arg ... constraint ... @@ -353,7 +353,7 @@ -- specified entrypoint and the entrypoint in question accepts the argument -- provided, a type error is raised otherwise. -- --- > transfer addr $ calling (ep @"Entrypoint") () +-- > transfer addr $ calling #entrypoint () -- -- Use 'CallDefault' or @def@ to call the default entrypoint. -- @@ -383,11 +383,6 @@ -- Also, no compile-time checks are performed on the entrypoint name, so it -- can be malformed. -- --- > transfer addr $ unsafeCalling (ep @"Entrypoint") () --- --- Overloaded labels are supported with 'unsafeCalling', so you can specify the --- entrypoint as an overloaded label: --- -- > transfer addr $ unsafeCalling #entrypoint () -- -- Use 'U.DefEpName' or @def@ to call the default entrypoint. @@ -409,5 +404,5 @@ -- | 'transfer' flag to signal we want contract events emitted by @EMIT@ -- returned. Passed in the variadic part of 'transfer', e.g. -- --- > transfer addr [tz|123u|] WithContractEvents $ calling (ep @"Entrypoint") () +-- > transfer addr [tz|123u|] WithContractEvents $ calling #entrypoint () data WithContractEvents = WithContractEvents diff --git a/src/Test/Cleveland/Internal/Client.hs b/src/Test/Cleveland/Internal/Client.hs --- a/src/Test/Cleveland/Internal/Client.hs +++ b/src/Test/Cleveland/Internal/Client.hs @@ -20,7 +20,7 @@ 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 Time (KnownDivRat, Second, Time, floorRat, sec, threadDelay, toFractional, toUnit) import Unsafe qualified (fromIntegral) import Lorentz (NicePackedValue) @@ -169,8 +169,7 @@ if neExplicitDataDir then id else Client.mceTezosClientL . tceMbTezosClientDataDirL .~ Nothing - storageAddress <- runMorleyClientM setupEnv $ - Client.resolveAddressMaybe (AddressAlias neMoneybagAlias) + storageAddress <- runMorleyClientM setupEnv $ Client.resolveAddressMaybe neMoneybagAlias Moneybag <$> case (neSecretKey, storageAddress) of (Nothing, Just addr) -> do unless neExplicitDataDir do @@ -386,7 +385,7 @@ deltaSec = ceilingUnit $ toUnit @Second delta deltaSec' :: NominalDiffTime - deltaSec' = secondsToNominalDiffTime $ toNum @Second deltaSec + deltaSec' = secondsToNominalDiffTime $ toFractional deltaSec t0 <- getLastBlockTimestamp neMorleyClientEnv threadDelay deltaSec let @@ -410,7 +409,7 @@ when (skippedLevels > 0) $ do when (skippedLevels > 1) $ do minBlockInterval <- cmiGetApproximateBlockInterval - let waitTime = (skippedLevels - 1) * toNum @Second minBlockInterval + let waitTime = (skippedLevels - 1) * floorRat minBlockInterval threadDelay . sec $ waitTime % 1 -- A chain's time resolution is never smaller than a second, so with (less -- than) a level to go we can wait for 1s in loop until we reach the target. @@ -456,14 +455,14 @@ => MorleyClientEnv -> KindedAddress kind -> ClientM (Alias kind) -getAlias env = liftIO . runMorleyClientM env . TezosClient.getAlias . AddressResolved +getAlias env = liftIO . runMorleyClientM env . TezosClient.getAlias getAliasMaybe :: L1AddressKind kind => MorleyClientEnv -> KindedAddress kind -> ClientM (Maybe (Alias kind)) -getAliasMaybe env = liftIO . runMorleyClientM env . Client.getAliasMaybe . AddressResolved +getAliasMaybe env = liftIO . runMorleyClientM env . Client.getAliasMaybe getLastBlockTimestamp :: MorleyClientEnv -> ClientM UTCTime getLastBlockTimestamp env = liftIO $ diff --git a/src/Test/Cleveland/Internal/Pure.hs b/src/Test/Cleveland/Internal/Pure.hs --- a/src/Test/Cleveland/Internal/Pure.hs +++ b/src/Test/Cleveland/Internal/Pure.hs @@ -22,7 +22,7 @@ import Data.Ratio ((%)) import Data.Set qualified as Set import Fmt (Buildable(..), Doc, build, nameF, pretty, unlinesF, (+|), (|+)) -import Time (Second, toNum, toUnit) +import Time (Second, ceilingRat, toUnit) import Lorentz (Mutez, NiceComparable, pattern DefEpName) import Lorentz qualified as L @@ -61,7 +61,6 @@ import Test.Cleveland.Internal.Common import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Lorentz -import Test.Cleveland.Util (ceilingUnit) data PureState = PureState { _psSecretKeys :: Map ImplicitAddress SecretKey @@ -235,7 +234,7 @@ , cmiGetChainId = use $ psGState . gsChainIdL , cmiAdvanceTime = \time -> do modifying psNow . flip timestampPlusSeconds $ - toNum @Second @Integer $ ceilingUnit $ toUnit @Second time + ceilingRat @Integer @Second $ toUnit @Second time , cmiAdvanceToLevel = \fn -> -- do not go back in levels diff --git a/test/TestSuite/Cleveland/CallStack.hs b/test/TestSuite/Cleveland/CallStack.hs --- a/test/TestSuite/Cleveland/CallStack.hs +++ b/test/TestSuite/Cleveland/CallStack.hs @@ -48,7 +48,7 @@ [ testFailureIncludesCallStack "Custom errors are prefixed with clarifyErrors" [lit| failure ("Some failure") - ^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^ | For i=1: Some failure |] do @@ -58,7 +58,7 @@ , testFailureIncludesCallStack "clarifyErrors properly formats multiline errors" [lit| failure ("Some failure\nSome text") - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^ | For i=1: | Some failure | Some text @@ -109,7 +109,7 @@ [ testFailureIncludesCallStack "callstack points to runIO" [lit| runIO (throwM DummyException) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^ |] do runIO (throwM DummyException) @@ -117,7 +117,7 @@ , testFailureIncludesCallStack "callstack points to resolveAddress" [lit| void $ resolveAddress invalidAlias - ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^ |] do -- force a failure by using an unknown alias @@ -126,7 +126,7 @@ , testFailureIncludesCallStack "callstack points to newAddress" [lit| void $ newAddress "b" - ^^^^^^^^^^^^^^ + ^^^^^^^^^^ |] do addr <- newFreshAddress "a" @@ -148,7 +148,7 @@ , testFailureIncludesCallStack "callstack points to signBytes" [lit| void $ signBytes "" invalidAddrWAlias - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^ |] do void $ signBytes "" invalidAddrWAlias @@ -156,7 +156,7 @@ , testFailureIncludesCallStack "callstack points to signBinary" [lit| void $ signBinary @ByteString "" invalidAddrWAlias - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^ |] do void $ signBinary @ByteString "" invalidAddrWAlias @@ -164,9 +164,7 @@ , testFailureIncludesCallStack "callstack points to originate with untyped" [lit| void $ originate "" - (untypeValue $ toVal @Natural 3) - (convertContract $ toMichelsonContract @() @() idContract) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^ |] do -- force a failure by using a storage of the wrong type @@ -177,11 +175,7 @@ , testFailureIncludesCallStack "callstack points to originate with lorentz" [lit| void $ originate - "" - () - (idContract @() @()) - (maxBound :: Mutez) - ^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^ |] do -- force a failure by transfering `maxBound` mutez @@ -194,7 +188,7 @@ , testFailureIncludesCallStack "callstack points to transfer" [lit| transfer invalidAddr - ^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^ |] do -- force a failure by transfering from an unknown alias @@ -203,7 +197,7 @@ , testFailureIncludesCallStack "callstack points to transferMoney" [it| transfer invalidAddr [tz|1u|\&] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^ |] do -- force a failure by transfering from an unknown address @@ -213,7 +207,7 @@ , testFailureIncludesCallStack "callstack points to call" [lit| transfer invalidTAddr - ^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^ |] do -- force a failure by transfering to an unknown address @@ -234,7 +228,7 @@ , testFailureIncludesCallStack "callstack points to importUntypedContract" [lit| void $ importUntypedContract "" - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^ |] do void $ importUntypedContract "" @@ -256,7 +250,6 @@ [ testFailureIncludesCallStack "when action does not throw, callstack points to catchTransferFailure" [lit| catchTransferFailure - pass ^^^^^^^^^^^^^^^^^^^^ |] do @@ -283,7 +276,7 @@ testName [lit| runIO (throwM ex) - ^^^^^^^^^^^^^^^^^ + ^^^^^ |] do void $ catchTransferFailure $ do @@ -295,7 +288,7 @@ , testFailureIncludesCallStack "when exception predicate fails, callstack points to checkTransferFailure" [lit| checkTransferFailure err $ failedWith (constant @Natural 2) - ^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^ |] do addr <- originate "" () contractFailWith1 @@ -306,7 +299,7 @@ [ testFailureIncludesCallStack "when action does not throw, callstack points to expectTransferFailure" [lit| & expectTransferFailure emptyTransaction - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^ |] do pass @@ -315,7 +308,7 @@ , testFailureIncludesCallStack "when action throws an unexpected exception, callstack points to action" [lit| runIO (throwM DummyException) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^ |] do runIO (throwM DummyException) @@ -324,7 +317,7 @@ , testFailureIncludesCallStack "when exception predicate fails, callstack points to expectTransferFailure" [lit| & expectTransferFailure (failedWith (constant @Natural 2)) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^ |] do addr <- originate "" () contractFailWith1 @@ -335,7 +328,7 @@ , testFailureIncludesCallStack "callstack points to expectFailedWith" [lit| expectFailedWith @MText "" pass - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^ |] do expectFailedWith @MText "" pass @@ -343,7 +336,7 @@ , testFailureIncludesCallStack "callstack points to expectError" [lit| expectError @MText "" pass - ^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^ |] do expectError @MText "" pass @@ -351,7 +344,7 @@ , testFailureIncludesCallStack "callstack points to expectCustomError" [lit| expectCustomError #unitError () pass - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^ |] do expectCustomError #unitError () pass @@ -359,7 +352,7 @@ , testFailureIncludesCallStack "callstack points to expectCustomError_" [lit| expectCustomError_ #unitError pass - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^ |] do expectCustomError_ #unitError pass @@ -367,7 +360,7 @@ , testFailureIncludesCallStack "callstack points to expectCustomErrorNoArg" [lit| expectCustomErrorNoArg #noArgError pass - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^ |] do expectCustomErrorNoArg #noArgError pass @@ -375,7 +368,7 @@ , testFailureIncludesCallStack "callstack points to expectCustomErrorAnyArg" [lit| expectCustomErrorAnyArg #anyCustomError pass - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^ |] do expectCustomErrorAnyArg #anyCustomError pass @@ -383,7 +376,7 @@ , testFailureIncludesCallStack "callstack points to expectNumericError" [lit| expectNumericError @MText [] "" pass - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^ |] do expectNumericError @MText [] "" pass @@ -391,7 +384,7 @@ , testFailureIncludesCallStack "callstack points to getStorage" [lit| void $ getStorage @() invalidContractAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^ |] do void $ getStorage @() invalidContractAddr @@ -399,7 +392,7 @@ , testFailureIncludesCallStackOnEmulator "callstack points to getFullStorage on emulator" [lit| void $ getFullStorage @() invalidContractAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^ |] do void $ getFullStorage @() invalidContractAddr @@ -407,7 +400,7 @@ , testFailureIncludesCallStackOnEmulator "callstack points to getSomeStorage on emulator" [lit| void $ getSomeStorage invalidContractAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^ |] do void $ getSomeStorage invalidContractAddr @@ -416,7 +409,7 @@ testFailureIncludesCallStackOnNetwork "callstack points to getBigMapValueMaybe" [lit| void $ getBigMapValueMaybe @Integer @Integer 999999999999999999 0 - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^ |] do void $ getBigMapValueMaybe @Integer @Integer 999999999999999999 0 @@ -424,7 +417,7 @@ , testFailureIncludesCallStack "callstack points to getBigMapValue" [lit| void $ getBigMapValue @Integer @Integer 999999999999999999 0 - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^ |] do void $ getBigMapValue @Integer @Integer 999999999999999999 0 @@ -432,7 +425,7 @@ , testFailureIncludesCallStack "callstack points to getPublicKey" [lit| void $ getPublicKey invalidAddrWAlias - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^ |] do void $ getPublicKey invalidAddrWAlias @@ -450,7 +443,7 @@ testFailureIncludesCallStackOnNetwork "callstack points to advanceTime on network" [lit| advanceTime (sec 1) - ^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^ |] do advanceTime (sec 1) @@ -458,7 +451,7 @@ testFailureIncludesCallStackOnNetwork "callstack points to advanceLevel on network" [lit| advanceLevel 1 - ^^^^^^^^^^^^^^ + ^^^^^^^^^^^^ |] do advanceLevel 1 @@ -481,17 +474,7 @@ , testFailureIncludesCallStack "callstack points to runCode" [lit| void $ runCode RunCode - { rcContract = - L.defaultContract @() @() $ L.failUsing @MText "Contract should fail" - , rcStorage = untypeValue $ toVal () - , rcParameter = untypeValue $ toVal () - , rcAmount = 0 - , rcBalance = 0 - , rcSource = Nothing - , rcNow = Nothing - , rcLevel = Nothing - } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^ |] do void $ runCode RunCode @@ -509,7 +492,7 @@ "when a branchout branch throws, the callstack points to the function inside the branch" [lit| getStorage @() invalidContractAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^ | In branch 'a': Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye |] do @@ -522,7 +505,7 @@ "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 @@ -551,7 +534,7 @@ "when offshoot throws, the callstack points to the function inside offshoot" [lit| getStorage @() invalidContractAddr - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^ | In branch 'a': Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye |] @@ -563,7 +546,7 @@ , testFailureIncludesCallStack "callstack points to failure" [lit| failure "a" - ^^^^^^^^^^^ + ^^^^^^^ |] do failure "a" @@ -571,7 +554,7 @@ , testFailureIncludesCallStack "callstack points to assert" [lit| assert False "a" - ^^^^^^^^^^^^^^^^ + ^^^^^^ |] do assert False "a" @@ -611,7 +594,7 @@ , testFailureIncludesCallStack "callstack points to checkCompares" [lit| checkCompares @Int 1 (==) 2 - ^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^ |] do checkCompares @Int 1 (==) 2 @@ -619,7 +602,7 @@ , testFailureIncludesCallStack "callstack points to checkComparesWith" [lit| checkComparesWith @Int show 1 (==) show 2 - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^ |] do checkComparesWith @Int show 1 (==) show 2 @@ -627,7 +610,7 @@ , testFailureIncludesCallStack "callstack points to evalJust" [lit| Nothing & evalJust "" - ^^^^^^^^^^^ + ^^^^^^^^ |] do Nothing & evalJust "" @@ -635,7 +618,7 @@ , testFailureIncludesCallStack "callstack points to evalRight" [lit| Left @Integer 1 & evalRight \_ -> "" - ^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^ |] do Left @Integer 1 & evalRight \_ -> "" @@ -644,7 +627,7 @@ [ testFailureIncludesCallStack "callstack points to helper using @==" [lit| bulkCheck [0, 1] [0, 2] - ^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^ |] do let @@ -659,7 +642,7 @@ [ testFailureIncludesCallStackOnEmulator "with whenEmulation" [lit| runIO (throwM DummyException) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^ |] do whenEmulation $ @@ -667,7 +650,7 @@ , testFailureIncludesCallStack "with ifEmulation" [lit| (runIO (throwM DummyException)) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^ |] do ifEmulation @@ -676,7 +659,7 @@ , testFailureIncludesCallStackOnNetwork "with whenNetwork" [lit| runIO (throwM DummyException) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^ |] do whenNetwork $ diff --git a/test/TestSuite/Cleveland/DFS.hs b/test/TestSuite/Cleveland/DFS.hs --- a/test/TestSuite/Cleveland/DFS.hs +++ b/test/TestSuite/Cleveland/DFS.hs @@ -55,6 +55,6 @@ transferAllCallerAddr <- importContract @TransferAllCallerParameter (inContractsDir "transfer_all_caller.tz") >>= originate "transfer_all_caller" () . noViews - transfer transferAllAddr [tz|100u|] $ calling (ep @"ReceiveXtz") () - transfer transferAllCallerAddr $ calling (ep @"CallCPS") $ toTAddress transferAllAddr + transfer transferAllAddr [tz|100u|] $ calling #receiveXtz () + transfer transferAllCallerAddr $ calling #callCPS $ toTAddress transferAllAddr ] diff --git a/test/TestSuite/Cleveland/ExpectFailure.hs b/test/TestSuite/Cleveland/ExpectFailure.hs --- a/test/TestSuite/Cleveland/ExpectFailure.hs +++ b/test/TestSuite/Cleveland/ExpectFailure.hs @@ -49,79 +49,79 @@ (defaultContract testContractWithNumericErrors) [tz|1u|] - attempt (transfer contractAddr $ calling (ep @"TriggerFailWith") ()) >>= \case + attempt (transfer contractAddr $ calling #triggerFailWith ()) >>= \case Left err -> checkTransferFailure err $ failedWith (constant [mt|oops|]) Right _ -> failure "Expected contract to fail" catchTransferFailure $ - transfer contractAddr $ calling (ep @"TriggerFailWith") () + transfer contractAddr $ calling #triggerFailWith () expectTransferFailure (failedWith (constant [mt|oops|])) $ - transfer contractAddr $ calling (ep @"TriggerFailWith") () + transfer contractAddr $ calling #triggerFailWith () expectTransferFailure (failedWith (constant [mt|oops|]) && addressIs contractAddr) $ - transfer contractAddr $ calling (ep @"TriggerFailWith") () + transfer contractAddr $ calling #triggerFailWith () expectFailedWith [mt|oops|] $ - transfer contractAddr $ calling (ep @"TriggerFailWith") () + transfer contractAddr $ calling #triggerFailWith () expectError (VoidResult False) $ - transfer contractAddr $ calling (ep @"VoidEP") (mkVoid True) + transfer contractAddr $ calling #voidEP (mkVoid True) expectTransferFailure (failedWith $ constant (1 :: Natural, (2 :: Natural, 3 :: Natural))) $ - transfer contractAddr $ calling (ep @"TriggerFailWithRightCombedPair") () + transfer contractAddr $ calling #triggerFailWithRightCombedPair () -- Check that string and bytes forms of 'chain_id' are equal if they are -- used as error argument. let c = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t" expectTransferFailure (failedWith (constant @ChainId c)) $ - transfer contractAddr $ calling (ep @"TriggerFailWithChainIdStr") () + transfer contractAddr $ calling #triggerFailWithChainIdStr () expectTransferFailure (failedWith (constant @ChainId c)) $ - transfer contractAddr $ calling (ep @"TriggerFailWithChainIdBytes") () + transfer contractAddr $ calling #triggerFailWithChainIdBytes () expectCustomError #customError 1 $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomError") () + transfer contractAddr $ calling #triggerFailWithCustomError () expectCustomError_ #customErrorUnit1 $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit1") () + transfer contractAddr $ calling #triggerFailWithCustomErrorUnit1 () expectCustomError_ #customErrorUnit2 $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit2") () + transfer contractAddr $ calling #triggerFailWithCustomErrorUnit2 () expectCustomErrorNoArg #customErrorNoArg $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") () + transfer contractAddr $ calling #triggerFailWithCustomErrorNoArg () expectCustomErrorAnyArg #customError $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomError") () + transfer contractAddr $ calling #triggerFailWithCustomError () expectCustomErrorAnyArg #customErrorUnit1 $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorUnit1") () + transfer contractAddr $ calling #triggerFailWithCustomErrorUnit1 () expectCustomErrorAnyArg #customErrorNoArg $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") () + transfer contractAddr $ calling #triggerFailWithCustomErrorNoArg () shouldFailWithMessage "Contract failed with any custom error tagged with \"WrongErrorTag\"" $ expectCustomErrorAnyArg #wrongErrorTag $ - transfer contractAddr $ calling (ep @"TriggerFailWithCustomErrorNoArg") () + transfer contractAddr $ calling #triggerFailWithCustomErrorNoArg () shouldFailWithMessage "Contract failed with any custom error tagged with \"CustomError\"" $ expectCustomErrorAnyArg #customError $ - transfer contractAddr $ calling (ep @"TriggerShiftOverflow") () + transfer contractAddr $ calling #triggerShiftOverflow () shouldFailWithMessage "Expected an exception to be thrown, but it wasn't" $ expectCustomErrorAnyArg #customErrorNoArg pass expectNumericError errorTagMap (VoidResult False) $ - transfer contractNumericAddr $ calling (ep @"VoidEP") $ mkVoid True + transfer contractNumericAddr $ calling #voidEP $ mkVoid True expectTransferFailure shiftOverflow $ - transfer contractAddr $ calling (ep @"TriggerShiftOverflow") () + transfer contractAddr $ calling #triggerShiftOverflow () expectTransferFailure gasExhaustion $ - transfer contractAddr $ calling (ep @"TriggerGasExhaustion") () + transfer contractAddr $ calling #triggerGasExhaustion () expectTransferFailure emptyTransaction $ transfer validAddr [tz|0u|] @@ -138,7 +138,7 @@ failedWith (constant @MText "oops") || failedWith (customError #customError 1) - transfer contractAddr (calling (ep @"TriggerFailWithCustomError") ()) & + transfer contractAddr (calling #triggerFailWithCustomError ()) & expectTransferFailure expectedErrs test_FailsIfTheGivenActionDoesNotThrow :: TestTree diff --git a/test/TestSuite/Cleveland/Tasty/Report/Examples.hs b/test/TestSuite/Cleveland/Tasty/Report/Examples.hs --- a/test/TestSuite/Cleveland/Tasty/Report/Examples.hs +++ b/test/TestSuite/Cleveland/Tasty/Report/Examples.hs @@ -30,7 +30,7 @@ ┏━━ #{reportExamplesPath} ━━━ 24 ┃ example1 :: EmulatedT PureM () 25 ┃ example1 = void $ signBytes "" unknownAddr - ┃ ^^^^^^^^^^^^^^^^^^^^^^^^ + ┃ ^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z 26 ┃ @@ -53,7 +53,7 @@ ┏━━ #{reportExamplesPath} ━━━ 47 ┃ exampleWithHelperFunction1Helper :: EmulatedT PureM () 48 ┃ exampleWithHelperFunction1Helper = void $ signBytes "" unknownAddr - ┃ ^^^^^^^^^^^^^^^^^^^^^^^^ + ┃ ^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z 49 ┃ @@ -108,15 +108,15 @@ ┏━━ #{reportExamplesPath} ━━━ 100 ┃ exampleMultipleLines1 = 101 ┃ void ( signBytes - 102 ┃ "" - 103 ┃ unknownAddr ) - ┃ ^^^^^^^^^^^^^ + ┃ ^^^^^^^^^ ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 104 ┃ + 102 ┃ "" CallStack (from HasCallStack): |] + + exampleMultipleLines2 :: EmulatedT PureM () exampleMultipleLines2 = void ( signBytes @@ -129,15 +129,15 @@ ┏━━ #{reportExamplesPath} ━━━ 121 ┃ exampleMultipleLines2 = 122 ┃ void ( signBytes + ┃ ^^^^^^^^^ + ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z 123 ┃ "" - 124 ┃ unknownAddr ) - ┃ ^^^^^^^^^^^^^ - ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 125 ┃ CallStack (from HasCallStack): |] + + exampleMultipleLines3 :: EmulatedT PureM () exampleMultipleLines3 = void ( signBytes @@ -150,15 +150,15 @@ ┏━━ #{reportExamplesPath} ━━━ 142 ┃ exampleMultipleLines3 = 143 ┃ void ( signBytes + ┃ ^^^^^^^^^ + ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z 144 ┃ "" - 145 ┃ unknownAddr ) - ┃ ^^^^^^^^^^^ - ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 146 ┃ CallStack (from HasCallStack): |] + + exampleMultipleLines4 :: EmulatedT PureM () exampleMultipleLines4 = void ( signBytes @@ -171,15 +171,15 @@ ┏━━ #{reportExamplesPath} ━━━ 163 ┃ exampleMultipleLines4 = 164 ┃ void ( signBytes + ┃ ^^^^^^^^^ + ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z 165 ┃ "" - 166 ┃ unknownAddr ) - ┃ ^^^^^^^^^^^^^^ - ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 167 ┃ CallStack (from HasCallStack): |] + + exampleMultipleLines5 :: EmulatedT PureM () exampleMultipleLines5 = void ( signBytes @@ -192,15 +192,15 @@ ┏━━ #{reportExamplesPath} ━━━ 184 ┃ exampleMultipleLines5 = 185 ┃ void ( signBytes + ┃ ^^^^^^^^^ + ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z 186 ┃ "" - 187 ┃ unknownAddr ) - ┃ ^^^^^^^^^^^^^^ - ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 188 ┃ CallStack (from HasCallStack): |] + + exampleMultipleLines6 :: EmulatedT PureM () exampleMultipleLines6 = void ( signBytes @@ -213,14 +213,14 @@ ┏━━ #{reportExamplesPath} ━━━ 205 ┃ exampleMultipleLines6 = 206 ┃ void ( signBytes + ┃ ^^^^^^^^^ + ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z 207 ┃ "" - 208 ┃ unknownAddr ) - ┃ ^^^^^^^^^^^ - ┃ | Unknown address provided: tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z - 209 ┃ CallStack (from HasCallStack): |] + + unknownAddr :: ImplicitAddressWithAlias unknownAddr = AddressWithAlias [ta|tz1X59tp9P7sk8qdPwqqATVbURbN6o8sMZ7Z|] "unknown-addr"