Numeric.hs

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Lorentz.Errors.Numeric
  ( test_Documentation
  ) where

import qualified Data.Kind as Kind
import Data.Typeable (eqT)
import Test.HUnit (assertFailure)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

import qualified Lorentz as L
import Lorentz.Base
import Lorentz.Doc
import Lorentz.Errors
import Lorentz.Value
import Lorentz.Errors.Numeric
import Michelson.Doc (lookupDocBlockSection)

type instance ErrorArg "myError" = ()
type instance ErrorArg "myNonMappedError" = ()

instance CustomErrorHasDoc "myError" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "An error happened"

instance CustomErrorHasDoc "myNonMappedError" where
  customErrClass = ErrClassActionException
  customErrDocMdCause = "A non-mapped error happened"

contract :: Lambda () ()
contract =
  L.push True #
  L.if_ (L.failCustom_ #myError)
        (L.failCustom_ #myNonMappedError)

errorTagMap :: ErrorTagMap
errorTagMap =
  excludeErrorTags (one [mt|MyNonMappedError|]) $
  buildErrorTagMap $ gatherErrorTags contract

test_Documentation :: [TestTree]
test_Documentation =
  [ testCase "Documentation is updated" $ do
      let docum = buildLorentzDoc $ applyErrorTagToErrorsDoc errorTagMap contract
          contents = cdContents docum
          dThrows = lookupDocBlockSection @DThrows contents
                 ?: error "Suddenly found no DThrow doc items"

      let
        throws :: forall (e :: Kind.Type). Typeable e => DThrows -> Bool
        throws (DThrows (_ :: Proxy e')) = isJust $ eqT @e @e'

        anyThrows :: forall (e :: Kind.Type). Typeable e => Bool
        anyThrows = any (throws @e) dThrows

      when (anyThrows @(CustomError "myError")) $
        assertFailure "Old 'myError' remained"
      unless (anyThrows @(NumericErrorWrapper 0 (CustomError "myError"))) $
        assertFailure "Mapped 'myError' does not appear in the result with tag 0"

      unless (anyThrows @(CustomError "myNonMappedError")) $
        assertFailure "Old 'myNonMappedError' is not remained"
      when (anyThrows @(NumericErrorWrapper 1 (CustomError "myNonMappedError"))) $
        assertFailure "'myNonMappedError' appears mapped in the result"
  ]