cleveland-0.4.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, 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.Abstract (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 "" invalidAddrWAlias
^^^^^^^^^
|]
do
void $ signBytes "" invalidAddrWAlias
, testFailureIncludesCallStack "callstack points to signBinary"
[lit|
void $ signBinary @ByteString "" invalidAddrWAlias
^^^^^^^^^^
|]
do
void $ signBinary @ByteString "" invalidAddrWAlias
, testFailureIncludesCallStack "callstack points to originate with untyped"
[lit|
void $ originate ""
^^^^^^^^^
|]
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
^^^^^^^^^
|]
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 invalidAddrWAlias
, 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 "<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
^^^^^^^^^^^^^^^^^^^^
|]
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 expectCustomErrorAnyArg"
[lit|
expectCustomErrorAnyArg #anyCustomError pass
^^^^^^^^^^^^^^^^^^^^^^^
|]
do
expectCustomErrorAnyArg #anyCustomError 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 invalidAddrWAlias
^^^^^^^^^^^^
|]
do
void $ getPublicKey invalidAddrWAlias
, 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
^^^^^^^
|]
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|]
invalidAddrWAlias = AddressWithAlias invalidAddr "invalid-addr"
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)