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_Errors
  , unit_gatherErrorTags
  , unit_Numeric_simple
  , unit_Numeric_append
  , unit_errorFromValNumeric
  ) where

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

import Lorentz as L
import Lorentz.Test.Integrational

{- Checking that errors of old format still can be used fine -}

data ErrorOfOldFormat
  = ErrorCase1
  | ErrorCase2 Integer
  deriving stock Generic

deriveCustomError ''ErrorOfOldFormat

_canFailUsing :: s :-> s'
_canFailUsing = failUsing ErrorCase1

_canFailUsingArg :: Integer : s :-> s'
_canFailUsingArg = failUsingArg @ErrorOfOldFormat #cErrorCase2

-- Needed to make this module compile
unit_Errors :: IO ()
unit_Errors = pass

----------------------------------------------------------------------------
-- 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 = [mt|Aa|]
str2 = [mt|Qq|]

unit_errorFromValNumeric :: Assertion
unit_errorFromValNumeric = integrationalTestExpectation $ do
  let
    (voidSample', errorTagMap) = useNumericErrors voidSample
  ref <- lOriginate (defaultContract voidSample') "voidSample" () minBound
  lCall ref (mkVoid True) `catchExpectedError`
    lExpectErrorNumeric errorTagMap (== VoidResult False)

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