cleveland-0.2.0: test/TestSuite/Cleveland/CallStack.hs
-- 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)
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 (ta)
import Morley.Util.Interpolate (lit)
import Morley.Util.SizedList.Types
import Test.Cleveland
import Test.Cleveland.Internal.Client (neMorleyClientEnvL)
import Test.Cleveland.Internal.Pure (TestError(CustomTestError))
import Test.Cleveland.Tasty
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 originateUntyped"
[lit|
void $ originateUntyped UntypedOriginateData
{ uodName = ""
, uodBalance = 0
, uodStorage = untypeValue $ toVal @Natural 3
, uodContract = convertContract $ toMichelsonContract @() @() idContract
}
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
-- force a failure by using a storage of the wrong type
void $ originateUntyped UntypedOriginateData
{ uodName = ""
, uodBalance = 0
, uodStorage = untypeValue $ toVal @Natural 3
, uodContract = convertContract $ toMichelsonContract @() @() idContract
}
, testFailureIncludesCallStack "callstack points to originateUntypedSimple"
[lit|
void $ originateUntypedSimple ""
(untypeValue $ toVal @Natural 3)
(convertContract $ toMichelsonContract @() @() idContract)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
-- force a failure by using a storage of the wrong type
void $ originateUntypedSimple ""
(untypeValue $ toVal @Natural 3)
(convertContract $ toMichelsonContract @() @() idContract)
, testFailureIncludesCallStack "callstack points to originate"
[lit|
void $ originate OriginateData
{ odName = ""
, odBalance = maxBound
, odStorage = ()
, odContract = idContract @() @()
}
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
-- force a failure by transfering `maxBound` mutez
void $ originate OriginateData
{ odName = ""
, odBalance = maxBound
, odStorage = ()
, odContract = idContract @() @()
}
, testFailureIncludesCallStack "callstack points to transfer"
[lit|
transfer TransferData
{ tdTo = invalidAddr
, tdAmount = 0
, tdEntrypoint = DefEpName
, tdParameter = ()
}
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
-- force a failure by transfering from an unknown alias
transfer TransferData
{ tdTo = invalidAddr
, tdAmount = 0
, tdEntrypoint = DefEpName
, tdParameter = ()
}
, testFailureIncludesCallStack "callstack points to transferMoney"
[lit|
transferMoney invalidAddr 1
^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
-- force a failure by transfering from an unknown address
transferMoney invalidAddr 1
& withSender invalidAddr
, testFailureIncludesCallStack "callstack points to call"
[lit|
call invalidTAddr CallDefault ()
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
-- force a failure by transfering to an unknown address
call invalidTAddr CallDefault ()
, testFailureIncludesCallStack "callstack points to inBatch for batched transfers"
[lit|
inBatch $ do
^^^^^^^
|]
do
-- force a failure by transfering to an unknown address
inBatch $ do
call (TAddress @() invalidAddr) CallDefault ()
call (TAddress @() invalidAddr) CallDefault ()
return ()
, testFailureIncludesCallStack "callstack points to importUntypedContract"
[lit|
void $ importUntypedContract "<invalid file path>"
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
void $ importUntypedContract "<invalid file path>"
, 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 <- originateSimple "" () contractFailWith1
err <- catchTransferFailure $ call addr CallDefault ()
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 <- originateSimple "" () contractFailWith1
call addr CallDefault ()
& 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 @() invalidAddr
^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
void $ getStorage @() invalidAddr
, testFailureIncludesCallStackOnEmulator "callstack points to getFullStorage on emulator"
[lit|
void $ getFullStorage @() invalidAddr
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
void $ getFullStorage @() invalidAddr
, testFailureIncludesCallStackOnEmulator "callstack points to getSomeStorage on emulator"
[lit|
void $ getSomeStorage invalidAddr
^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
void $ getSomeStorage invalidAddr
, 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 = NotRPC ()
, rcParameter = NotRPC ()
, rcAmount = 0
, rcBalance = 0
, rcSource = Nothing
, rcNow = Nothing
, rcLevel = Nothing
}
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|]
do
void $ runCode RunCode
{ rcContract =
L.defaultContract @() @() $ L.failUsing @MText "Contract should fail"
, rcStorage = NotRPC ()
, rcParameter = NotRPC ()
, 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 @() invalidAddr
^^^^^^^^^^^^^^^^^^^^^^^^^^
| In 'a' branch:
| Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC
|]
do
branchout
[ "a" ?-
void $
getStorage @() invalidAddr
]
, testFailureIncludesCallStackOnEmulator
"when a branchout branch throws ANY exception, the exception raised is printed in a right way"
[lit|
runIO $ throwM DummyException
^^^^^
| In 'a' branch:
| DummyException
|]
do
branchout
[ "a" ?-
runIO $ throwM DummyException
]
, testFailureIncludesCallStackOnEmulator
"when offshoot throws, the callstack points to the function inside offshoot"
[lit|
getStorage @() invalidAddr
^^^^^^^^^^^^^^^^^^^^^^^^^^
| In 'a' branch:
| Unknown address provided: tz1fsFpWk691ncq1xwS62dbotECB67B13gfC
|]
do
offshoot "a" $
void $
getStorage @() invalidAddr
, 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 = "UnknownAlias"
invalidAddr = [ta|tz1fsFpWk691ncq1xwS62dbotECB67B13gfC|]
invalidTAddr = TAddress @() invalidAddr
test_callStack_property :: TestTree
test_callStack_property =
testGroup "Error messages of property tests include a helpful callstack" $
[ testFailureIncludesCallStackProperty "callstack points to line which led scenario to error"
[lit|
f x y = x @== y
^^^^^^^^^^^^^^^
|]
dummyProp
, testFailureIncludesCallStackProperty "callstack does not point to internals when a pure error is thrown"
-- TODO [#818]: include the actual error message
-- NB: a single quote with two of these lines unindented causes tasty to output a different error message
(List.unlines
[ [lit|dummyPropWithPureError = property $ testScenarioProps $ scenario do|]
, [lit|^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^|]])
dummyPropWithPureError
, testFailureIncludesCallStackProperty "callstack does not point to internals when a nested pure error is thrown"
(List.unlines
[ [lit|dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do|]
, [lit|^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^|]])
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 =
runPropertyViaTasty testName mempty prop $ \tastyResult -> do
outcomeIsFailure tastyResult
checkErrorMessage (resultDescription tastyResult) expectedErrorLines
-- | 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 (List.lines -> expectedLines) = do
Unsafe.head (List.lines err) `shouldContain` ("test" </> "TestSuite" </> "Cleveland" </> "CallStack.hs")
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 =
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
----------------------------------------------------------------------------
-- 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)
dummyPropWithPureError :: Property
dummyPropWithPureError = property $ testScenarioProps $ scenario do
error "Pure error" @== (1 :: Int)
dummyPropWithNestedPureError :: Property
dummyPropWithNestedPureError = property $ testScenarioProps $ scenario do
(10 - 11 :: Mutez) @== 0