Errors.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# OPTIONS_GHC -Wno-deprecations #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Lorentz.Errors
  ( unit_gatherErrorTags
  , unit_Numeric_simple
  , unit_Numeric_append
  , test_errorFromValNumeric
  ) where

import Lorentz as L

import qualified Data.Bimap as Bimap
import qualified Data.HashSet as HS
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (Assertion, (@?=))

import Test.Cleveland

----------------------------------------------------------------------------
-- Numeric representation
----------------------------------------------------------------------------

unit_gatherErrorTags :: Assertion
unit_gatherErrorTags = sampleGatheredTags @?= HS.fromList [str1, str2]

unit_Numeric_simple :: Assertion
unit_Numeric_simple = useNumericErrors sample @?=
  (sampleNumericErrors (0, 1), Bimap.fromList [(0, str1), (1, str2)])

unit_Numeric_append :: Assertion
unit_Numeric_append =
  applyErrorTagMap newMap sample @?=
  sampleNumericErrors (5, 4)
  where
    existingMap :: ErrorTagMap
    existingMap = Bimap.fromList [(4, str2)]

    newMap = existingMap `addNewErrorTags` sampleGatheredTags

type instance ErrorArg "aa" = Bool
instance CustomErrorHasDoc "aa" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "patak"

sample :: '[ MText] :-> '[ MText]
sample =
  pushTrue #
  -- FailWithString
  if_
    (push str1 # failWith)
    pushTrue #
  -- Non-typical fail
  if_
    (push str1 # push str1 # pair # pair # failWith)
    pushTrue #
  -- FailWithStackValue
  if_
    (push str1 # pair # failWith)
    (pushTrue) #
  -- FailWithStackValue via 'failCustom'
  if_
    (pushTrue # failCustom #aa)
    (none @()) #
  -- Deeper FailWithString
  ifNone
    (unit # pushTrue # if_ (push str2 # failWith) nop)
    nop #
  -- FailWithConstantPair
  push (str2, ()) # failWith

-- Arguments are numeric codes for 'str1' and 'str2'.
sampleNumericErrors :: (Natural, Natural) -> '[ MText] :-> '[ MText]
sampleNumericErrors (code1, code2) =
  pushTrue #
  if_
    (push code1 # failWith)
    pushTrue #

  if_
    (push str1 # push str1 # pair # pair # failWith)
    pushTrue #

  if_
    (push code1 # pair # failWith)
    pushTrue #

  -- Here we lose doc item and rely on the fact that instructions are
  -- compared by transpiling them to Michelson.
  if_
    (pushTrue # push code1 # pair # failWith)
    (none @()) #

  ifNone
    (unit # pushTrue # if_ (push code2 # failWith) nop)
    nop #

  push (code2, ()) # failWith

sampleGatheredTags :: HashSet MText
sampleGatheredTags = gatherErrorTags sample

pushTrue :: forall s. s :-> Bool ': s
pushTrue = push True

str1, str2 :: MText
str1 = "Aa"
str2 = "Qq"

test_errorFromValNumeric :: TestTree
test_errorFromValNumeric = testScenario "Expect Numeric Error" $ scenario do
  let
    (voidSample', errorTagMap) = useNumericErrors voidSample
  ref <- originate $ OriginateData "voidSample" minBound () (defaultContract voidSample')
  expectNumericError errorTagMap (VoidResult False) $ call ref CallDefault (mkVoid True)

voidSample :: ContractCode (Void_ Bool Bool) ()
voidSample = car # void_ L.not