-- SPDX-FileCopyrightText: 2021 Oxhead Alpha -- SPDX-License-Identifier: LicenseRef-MIT-OA {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE OverloadedLists #-} module TestSuite.Cleveland.CallStack ( test_callStack , test_clarifyErrors , test_callStack_property ) where import Lorentz hiding (assert, comment, not, or) import Lorentz qualified as L import Unsafe qualified import Data.Char (isNumber, isSpace) import Data.List qualified as List import Fmt ((+|), (|+)) import Hedgehog (Property, property) import Servant.Client (BaseUrl(BaseUrl), ClientEnv(baseUrl), ClientError(ConnectionError), Scheme(Http)) import System.FilePath (()) import Test.Hspec.Expectations (shouldContain) import Test.Tasty (TestName, TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertFailure) import Test.Tasty.Runners (Result(resultDescription)) import Time (sec) import Morley.Client (TezosClientError(EConnreset), mceClientEnvL, mceTezosClientL) import Morley.Client.TezosClient (tceEndpointUrlL) import Morley.Michelson.Typed (convertContract, untypeValue) import Morley.Tezos.Address import Morley.Util.Interpolate (it, lit, litu) import Morley.Util.SizedList.Types import Test.Cleveland import Test.Cleveland.Internal.Client (neMorleyClientEnvL) import Test.Cleveland.Internal.Exceptions import Test.Cleveland.Internal.Pure (TestError(CustomTestError)) import Test.Cleveland.Tasty import TestSuite.Cleveland.CallStack.Fixtures import TestSuite.Util (idContract, outcomeIsFailure, runPropertyViaTasty, runViaTastyOnEmulator, runViaTastyOnNetwork) test_clarifyErrors :: [TestTree] test_clarifyErrors = [ testFailureIncludesCallStack "Custom errors are prefixed with clarifyErrors" [lit| failure ("Some failure") ^^^^^^^^^^^^^^^^^^^^^^^^ | For i=1: Some failure |] do for_ ([1..10] :: [Int]) \i -> clarifyErrors ("For i=" +| i |+ "") $ failure ("Some failure") , testFailureIncludesCallStack "clarifyErrors properly formats multiline errors" [lit| failure ("Some failure\nSome text") ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | For i=1: | Some failure | Some text |] do for_ ([1..10] :: [Int]) \i -> clarifyErrors ("For i=" +| i |+ "") $ failure ("Some failure\nSome text") , testFailureIncludesCallStack "clarifyErrors properly works for equality tests" [lit| i @== 1 ^^^ | For i=2: | Failed comparison | ━━ Expected (rhs) ━━ | 1 | ━━ Got (lhs) ━━ | 2 |] do for_ ([1..10] :: [Int]) \i -> clarifyErrors ("For i=" +| i |+ "") $ i @== 1 , testFailureIncludesCallStack "clarifyErrors nests well" [lit| i @== j ^^^ | For i=1: | For j=2: | Failed comparison | ━━ Expected (rhs) ━━ | 2 | ━━ Got (lhs) ━━ | 1 |] do for_ ([1..10] :: [Int]) \i -> clarifyErrors ("For i=" +| i |+ "") $ for_ ([1..10] :: [Int]) \j -> clarifyErrors ("For j=" +| j |+ "") $ i @== j ] test_callStack :: TestTree test_callStack = testGroup "Error messages include a helpful callstack" $ [ testFailureIncludesCallStack "callstack points to runIO" [lit| runIO (throwM DummyException) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do runIO (throwM DummyException) , testFailureIncludesCallStack "callstack points to resolveAddress" [lit| void $ resolveAddress invalidAlias ^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by using an unknown alias void $ resolveAddress invalidAlias , testFailureIncludesCallStack "callstack points to newAddress" [lit| void $ newAddress "b" ^^^^^^^^^^^^^^ |] do addr <- newFreshAddress "a" -- force a failure by using an address without money as the donator withMoneybag addr $ void $ newAddress "b" , testFailureIncludesCallStack "callstack points to newAddresses" [lit| void $ newAddresses $ "b" :< Nil ^^^^^^^^^^^^ |] do addr <- newFreshAddress "a" -- force a failure by using an address without money as the donator withMoneybag addr $ void $ newAddresses $ "b" :< Nil , testFailureIncludesCallStack "callstack points to signBytes" [lit| void $ signBytes "" invalidAddr ^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ signBytes "" invalidAddr , testFailureIncludesCallStack "callstack points to signBinary" [lit| void $ signBinary @ByteString "" invalidAddr ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ signBinary @ByteString "" invalidAddr , 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 void $ originate "" (untypeValue $ toVal @Natural 3) (convertContract $ toMichelsonContract @() @() idContract) , testFailureIncludesCallStack "callstack points to originate with lorentz" [lit| void $ originate "" () (idContract @() @()) (maxBound :: Mutez) ^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering `maxBound` mutez void $ originate "" () (idContract @() @()) (maxBound :: Mutez) , testFailureIncludesCallStack "callstack points to transfer" [lit| transfer invalidAddr ^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering from an unknown alias transfer invalidAddr , testFailureIncludesCallStack "callstack points to transferMoney" [it| transfer invalidAddr [tz|1u|\&] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering from an unknown address transfer invalidAddr [tz|1u|] & withSender invalidAddr , testFailureIncludesCallStack "callstack points to call" [lit| transfer invalidTAddr ^^^^^^^^^^^^^^^^^^^^^ |] do -- force a failure by transfering to an unknown address transfer invalidTAddr , testFailureIncludesCallStack "callstack points to inBatch for batched transfers" [lit| inBatch $ do ^^^^^^^ |] do -- force a failure by transfering to an unknown address inBatch $ do transfer invalidAddr transfer invalidAddr return () , testFailureIncludesCallStack "callstack points to importUntypedContract" [lit| void $ importUntypedContract "" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ importUntypedContract "" , testGroup "attempt" [ testFailureIncludesCallStack "when action throws an unexpected exception, callstack points to action" [lit| runIO $ throwM DummyException ^^^^^ | DummyException |] do void $ attempt @TransferFailure $ runIO $ throwM DummyException ] , testGroup "catchTransferFailure" $ [ testFailureIncludesCallStack "when action does not throw, callstack points to catchTransferFailure" [lit| catchTransferFailure pass ^^^^^^^^^^^^^^^^^^^^ |] do void $ catchTransferFailure pass , testGroup "when action throws an unexpected exception, callstack points to action" $ let unexpectedExceptions = [ ( "DummyException" , SomeException DummyException ) , ( "unexpected TestError constructor" , SomeException $ CustomTestError "err" ) , ( "Servant ClientError" , SomeException $ ConnectionError (SomeException DummyException) ) , ( "TezosClientError" , SomeException EConnreset ) ] in flip fmap unexpectedExceptions $ \(testName, SomeException ex) -> testFailureIncludesCallStack testName [lit| runIO (throwM ex) ^^^^^^^^^^^^^^^^^ |] do void $ catchTransferFailure $ do pass runIO (throwM ex) pass ] , testFailureIncludesCallStack "when exception predicate fails, callstack points to checkTransferFailure" [lit| checkTransferFailure err $ failedWith (constant @Natural 2) ^^^^^^^^^^^^^^^^^^^^^^^^ |] do addr <- originate "" () contractFailWith1 err <- catchTransferFailure $ transfer addr checkTransferFailure err $ failedWith (constant @Natural 2) , testGroup "expectTransferFailure" $ [ testFailureIncludesCallStack "when action does not throw, callstack points to expectTransferFailure" [lit| & expectTransferFailure emptyTransaction ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do pass & expectTransferFailure emptyTransaction , testFailureIncludesCallStack "when action throws an unexpected exception, callstack points to action" [lit| runIO (throwM DummyException) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do runIO (throwM DummyException) & expectTransferFailure emptyTransaction , testFailureIncludesCallStack "when exception predicate fails, callstack points to expectTransferFailure" [lit| & expectTransferFailure (failedWith (constant @Natural 2)) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do addr <- originate "" () contractFailWith1 transfer addr & expectTransferFailure (failedWith (constant @Natural 2)) ] , testFailureIncludesCallStack "callstack points to expectFailedWith" [lit| expectFailedWith @MText "" pass ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do expectFailedWith @MText "" pass , testFailureIncludesCallStack "callstack points to expectError" [lit| expectError @MText "" pass ^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do expectError @MText "" pass , testFailureIncludesCallStack "callstack points to expectCustomError" [lit| expectCustomError #unitError () pass ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do expectCustomError #unitError () pass , testFailureIncludesCallStack "callstack points to expectCustomError_" [lit| expectCustomError_ #unitError pass ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do expectCustomError_ #unitError pass , testFailureIncludesCallStack "callstack points to expectCustomErrorNoArg" [lit| expectCustomErrorNoArg #noArgError pass ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do expectCustomErrorNoArg #noArgError pass , testFailureIncludesCallStack "callstack points to expectNumericError" [lit| expectNumericError @MText [] "" pass ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do expectNumericError @MText [] "" pass , testFailureIncludesCallStack "callstack points to getStorage" [lit| void $ getStorage @() invalidContractAddr ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ getStorage @() invalidContractAddr , testFailureIncludesCallStackOnEmulator "callstack points to getFullStorage on emulator" [lit| void $ getFullStorage @() invalidContractAddr ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ getFullStorage @() invalidContractAddr , testFailureIncludesCallStackOnEmulator "callstack points to getSomeStorage on emulator" [lit| void $ getSomeStorage invalidContractAddr ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ getSomeStorage invalidContractAddr , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to getBigMapValueMaybe" [lit| void $ getBigMapValueMaybe @Integer @Integer 999999999999999999 0 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ getBigMapValueMaybe @Integer @Integer 999999999999999999 0 , testFailureIncludesCallStack "callstack points to getBigMapValue" [lit| void $ getBigMapValue @Integer @Integer 999999999999999999 0 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ getBigMapValue @Integer @Integer 999999999999999999 0 , testFailureIncludesCallStack "callstack points to getPublicKey" [lit| void $ getPublicKey invalidAddr ^^^^^^^^^^^^^^^^^^^^^^^^ |] do void $ getPublicKey invalidAddr , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to getChainId on network" [lit| void getChainId ^^^^^^^^^^ |] do void getChainId , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to advanceTime on network" [lit| advanceTime (sec 1) ^^^^^^^^^^^^^^^^^^^ |] do advanceTime (sec 1) , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to advanceLevel on network" [lit| advanceLevel 1 ^^^^^^^^^^^^^^ |] do advanceLevel 1 , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to getNow on network" [lit| void getNow ^^^^^^ |] do void getNow , sabotageNetworkEnv $ testFailureIncludesCallStackOnNetwork "callstack points to getLevel on network" [lit| void getLevel ^^^^^^^^ |] do void getLevel , 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 { 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 } , testFailureIncludesCallStackOnEmulator "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 branchout [ "a" ?- void $ getStorage @() invalidContractAddr ] , testFailureIncludesCallStackOnEmulator "when a nested branchout branch throws, the callstack branch name is correct" [lit| void $ getStorage @() invalidContractAddr ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | In branch 'a/b': Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye |] do branchout [ "a" ?- branchout ["b" ?- void $ getStorage @() invalidContractAddr ] ] , testFailureIncludesCallStackOnEmulator "when a branchout branch throws ANY exception, the exception raised is printed in a right way" [lit| runIO $ throwM DummyException ^^^^^ | In branch 'a': DummyException |] do branchout [ "a" ?- runIO $ throwM DummyException ] , testFailureIncludesCallStackOnEmulator "when offshoot throws, the callstack points to the function inside offshoot" [lit| getStorage @() invalidContractAddr ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ | In branch 'a': Unknown address provided: KT1BRd2ka5q2cPRdXALtXD1QZ38CPam2j1ye |] do offshoot "a" $ void $ getStorage @() invalidContractAddr , testFailureIncludesCallStack "callstack points to failure" [lit| failure "a" ^^^^^^^^^^^ |] do failure "a" , testFailureIncludesCallStack "callstack points to assert" [lit| assert False "a" ^^^^^^^^^^^^^^^^ |] do assert False "a" , testFailureIncludesCallStack "callstack points to @==" [lit| 1 @== (2 :: Int) ^^^ |] do 1 @== (2 :: Int) , testFailureIncludesCallStack "callstack points to @/=" [lit| 1 @/= (1 :: Int) ^^^ |] do 1 @/= (1 :: Int) , testFailureIncludesCallStack "callstack points to @@==" [lit| pure 1 @@== (2 :: Int) ^^^^ |] do pure 1 @@== (2 :: Int) , testFailureIncludesCallStack "callstack points to @@/=" [lit| pure 1 @@/= (1 :: Int) ^^^^ |] do pure 1 @@/= (1 :: Int) , testFailureIncludesCallStack "callstack points to checkCompares" [lit| checkCompares @Int 1 (==) 2 ^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do checkCompares @Int 1 (==) 2 , testFailureIncludesCallStack "callstack points to checkComparesWith" [lit| checkComparesWith @Int show 1 (==) show 2 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do checkComparesWith @Int show 1 (==) show 2 , testFailureIncludesCallStack "callstack points to evalJust" [lit| Nothing & evalJust "" ^^^^^^^^^^^ |] do Nothing & evalJust "" , testFailureIncludesCallStack "callstack points to evalRight" [lit| Left @Integer 1 & evalRight \_ -> "" ^^^^^^^^^^^^^^^^^^ |] do Left @Integer 1 & evalRight \_ -> "" , testGroup "callstack points to a method at its top" [ testFailureIncludesCallStack "callstack points to helper using @==" [lit| bulkCheck [0, 1] [0, 2] ^^^^^^^^^^^^^^^^^^^^^^^ |] do let bulkCheck :: (MonadCleveland caps m, HasCallStack) => [Int] -> [Int] -> m () bulkCheck = sequence_ ... zipWith (@==) bulkCheck [0, 1] [0, 2] ] , testGroup "callstack points to a reasonable location" [ testFailureIncludesCallStackOnEmulator "with whenEmulation" [lit| runIO (throwM DummyException) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do whenEmulation $ runIO (throwM DummyException) , testFailureIncludesCallStack "with ifEmulation" [lit| (runIO (throwM DummyException)) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do ifEmulation (runIO (throwM DummyException)) (runIO (throwM DummyException)) , testFailureIncludesCallStackOnNetwork "with whenNetwork" [lit| runIO (throwM DummyException) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ |] do whenNetwork $ runIO (throwM DummyException) ] ] where invalidAlias :: ContractAlias invalidAlias = "UnknownAlias" invalidAddr = [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|] invalidContractAddr = ContractAddress $ mkContractHashHack "asdf" invalidTAddr = ContractHandle @() @() @() "asdf" invalidContractAddr test_callStack_property :: TestTree test_callStack_property = let fixturePath = "test" "TestSuite" "Cleveland" "CallStack" "Fixtures.hs" in testGroup "Error messages of property tests include a helpful callstack" $ [ testFailureIncludesCallStackProperty "callstack points to line which led scenario to error" [lit| f x y = x @== y ^^^^^^^^^^^^^^^ |] dummyProp , testFailureIncludesCallStackProperty' "callstack does not point to internals when a pure error is thrown" -- NB: a single quote with two of these lines unindented causes tasty to output a different error message ([litu| dummyPropWithPureError :: Property dummyPropWithPureError = property $ testScenarioProps $ scenario do ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ │ ━━━ Exception (ErrorCall) ━━━ │ Pure error │ CallStack (from HasCallStack): │ error, called at test/TestSuite/Cleveland/CallStack/Fixtures.hs:15:5 in main:TestSuite.Cleveland.CallStack.Fixtures error "Pure error" @== (1 :: Int) |]) fixturePath dummyPropWithPureError , testFailureIncludesCallStackProperty' "callstack does not point to internals when a nested pure error is thrown" ([litu| dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ │ ━━━ Exception (ErrorCall) ━━━ │ unsafeSubMutez: underflow |]) fixturePath dummyPropWithNestedPureError ] -- | Check that exceptions thrown by the given function contain a callstack that points to that function. -- -- The scenario is run on both the emulator and on a network. testFailureIncludesCallStack :: HasCallStack => TestName -> String -> (forall caps m. MonadCleveland caps m => m ()) -> TestTree testFailureIncludesCallStack testName expectedErrorLines test = testGroup testName [ testFailureIncludesCallStackOnEmulator "On emulator" expectedErrorLines test , testFailureIncludesCallStackOnNetwork "On network" expectedErrorLines test ] testFailureIncludesCallStackOnEmulator :: HasCallStack => TestName -> String -> (forall m. Monad m => EmulatedT m ()) -> TestTree testFailureIncludesCallStackOnEmulator testName expectedErrorLines cleveland = runViaTastyOnEmulator testName mempty cleveland $ \tastyResult -> do outcomeIsFailure tastyResult checkErrorMessage (resultDescription tastyResult) expectedErrorLines testFailureIncludesCallStackOnNetwork :: HasCallStack => TestName -> String -> (forall m. Monad m => ClevelandT m ()) -> TestTree testFailureIncludesCallStackOnNetwork testName expectedErrorLines cleveland = runViaTastyOnNetwork testName mempty cleveland $ \tastyResult -> do outcomeIsFailure tastyResult checkErrorMessage (resultDescription tastyResult) expectedErrorLines testFailureIncludesCallStackProperty :: HasCallStack => TestName -> String -> Property -> TestTree testFailureIncludesCallStackProperty testName expectedErrorLines prop = testFailureIncludesCallStackProperty' testName expectedErrorLines thisPath prop testFailureIncludesCallStackProperty' :: HasCallStack => TestName -> String -> String -> Property -> TestTree testFailureIncludesCallStackProperty' testName expectedErrorLines testPath prop = runPropertyViaTasty testName mempty prop $ \tastyResult -> do outcomeIsFailure tastyResult checkErrorMessage' (resultDescription tastyResult) expectedErrorLines testPath -- | If we can't force a function to fail on a network by, e.g., -- passing the wrong arguments or violating its pre-conditions, -- we can use this function to mess with the 'NetworkEnv' config and force -- the test to crash. -- -- For example, 'newAddress' and 'getChainId' don't normally fail, -- but if we mess with the config, they will. sabotageNetworkEnv :: TestTree -> TestTree sabotageNetworkEnv = modifyNetworkEnv f where faultyBaseUrl = BaseUrl Http "" 0 "" f :: NetworkEnv -> NetworkEnv f = (neMorleyClientEnvL.mceTezosClientL.tceEndpointUrlL .~ faultyBaseUrl) . (neMorleyClientEnvL.mceClientEnvL %~ \clientEnv -> clientEnv { baseUrl = faultyBaseUrl } ) -- | Checks that an error message includes a pretty-printed callstack, -- and that it points to this file and contains the expected lines. checkErrorMessage :: HasCallStack => String -> String -> Assertion checkErrorMessage err expectedLines = checkErrorMessage' err expectedLines thisPath -- | Path to this file to use for tests in a couple of places. thisPath :: String thisPath = "test" "TestSuite" "Cleveland" "CallStack.hs" -- | Checks that an error message includes a pretty-printed callstack, -- and that it points to the provided path and contains the expected lines. checkErrorMessage' :: HasCallStack => String -> String -> String -> Assertion checkErrorMessage' err (List.lines -> expectedLines) path = do Unsafe.head (List.lines err) `shouldContain` path if expectedLines `List.isInfixOf` strippedErrorLines then pass else assertFailure $ List.unlines $ [ "Expected the error message to contain: " ] <> expectedLines <> [ "But it didn't. Actual error message was: "] <> strippedErrorLines where stripLineNumber line = line & List.dropWhile isSpace & List.dropWhile isNumber & List.dropWhile isSpace & List.dropWhile (== '┃') & List.drop 1 -- Strip 1) the header, 2) the callstack entries, 3) the line numbers and 4) the vertical border -- from the error message, to make writing these tests easier. strippedErrorLines :: [String] strippedErrorLines = err & List.lines & List.takeWhile (/= "CallStack (from HasCallStack):") & Unsafe.tail <&> stripLineNumber ---------------------------------------------------------------------------- -- Test data ---------------------------------------------------------------------------- type instance ErrorArg "unitError" = UnitErrorArg instance CustomErrorHasDoc "unitError" where customErrClass = ErrClassActionException customErrDocMdCause = "Error for testing custom error handling in cleveland" type instance ErrorArg "noArgError" = NoErrorArg instance CustomErrorHasDoc "noArgError" where customErrClass = ErrClassActionException customErrDocMdCause = "Error for testing custom error handling in cleveland" contractFailWith1 :: Contract () () () contractFailWith1 = defaultContract $ push @Natural 1 # failWith data DummyException = DummyException deriving stock (Eq, Show) instance Exception DummyException where fromException = fromPossiblyAnnotatedException ---------------------------------------------------------------------------- -- Test scenarios ---------------------------------------------------------------------------- -- Note: it's important to define property test as a top-level function. -- If we inline it, the test will always pass, because 'hedgehog' captures -- the whole function body, which contains expectation, into the error message. dummyProp :: Property dummyProp = property $ testScenarioProps $ scenario do let f x y = x @== y g y = f 10 y g (20 :: Int)