EntryPoints.hs

{-# LANGUAGE DeriveAnyClass #-}

-- | Tests for Lorentz compilation which uses 'LorentzCompilationWay'.
module Test.EntryPoints
  ( test_EpAddress
  , test_ParamNotes
  , test_ParamEpError
  ) where

import Prelude hiding (or)

import Data.Default (def)
import Fmt (pretty)
import Test.HUnit (assertBool, (@?=))
import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Michelson.Typed
import Michelson.Untyped (ann, noAnn)
import Tezos.Address
import Util.Test.Arbitrary

import Test.Util.QuickCheck

test_EpAddress :: [TestTree]
test_EpAddress =
  [ testGroup "Parsing" $
    [ testCase "Simple entrypoint" $
        parseEpAddress (formatAddress addr <> "%ab")
          @?= Right (EpAddress addr (EpNameUnsafe "ab"))

    , testCase "No entrypoint" $
        parseEpAddress (formatAddress addr)
          @?= Right (EpAddress addr def)

    , testCase "Weird entrypoint" $
        parseEpAddress (formatAddress addr <> "%a%b")
          @?= Right (EpAddress addr (EpNameUnsafe "a%b"))
    ]

  , testGroup "parse . format = pure"
    [ roundtripTestSTB formatEpAddress parseEpAddress ]
  ]
  where
    addr = runGen 123 arbitrary

test_ParamNotes :: [TestTree]
test_ParamNotes =
  [ testGroup "Duplications are handled" $
    [ testCase "One duplicated entrypoint" $
        mkParamNotes (or "a" "a" prim prim) noAnn
          @?= Left (ParamEpDuplicatedNames (EpNameUnsafe "a" :| []))
    , testCase "Several duplicated entrypoint" $
        mkParamNotes (or "" "" (or "a" "b" prim prim) (or "b" "a" prim prim)) noAnn
          @?= Left (ParamEpDuplicatedNames (EpNameUnsafe "a" :| [EpNameUnsafe "b"]))
    , testCase "Duplicated default entrypoint" $
        mkParamNotes (or "default" "default" prim prim) noAnn
          @?= Left (ParamEpDuplicatedNames (DefEpName :| []))
    ]

  , testGroup "All entrypoints callable check" $
    [ testCase "Non-callable entrypoint is detected in simple case" $
        mkParamNotes (or "default" "" prim (or "" "q" prim prim)) noAnn
          @?= Left (ParamEpUncallableArm [AcRight, AcLeft])
    , testCase "Non-callable entrypoint is detected in complex case" $
        mkParamNotes (or "a" "" prim (or "" "default" (or "b" "" prim prim) prim)) noAnn
          @?= Left (ParamEpUncallableArm [AcRight, AcLeft, AcRight])

    , testCase "Having all leaves named is enough for callability" $
        mkParamNotes (or "default" "" prim (or "q" "" prim (or "a" "b" prim prim))) noAnn
          & assertBool "All arms should've considered callable" . isRight
    , testCase "Having all leaves named is enough for callability" $
        mkParamNotes (or "default" "a" prim (or "" "" prim (or "" "" prim prim))) noAnn
          & assertBool "All arms should've considered callable" . isRight
    ]
  ]
  where
    or a1 a2 = NTOr noAnn (ann a1) (ann a2)
    prim = NTKey noAnn

test_ParamEpError :: [TestTree]
test_ParamEpError =
  [ testGroup "Buildable instance"
    [ testCase "Duplicated entrypoints error" $
        pretty @_ @Text (ParamEpDuplicatedNames $ EpNameUnsafe "a" :| [EpNameUnsafe ""])
        @?= "Duplicated entrypoint names: 'a', '<default>'"
    , testCase "Uncallable arms error" $
        pretty @_ @Text (ParamEpUncallableArm [AcLeft, AcRight])
        @?= "Due to presence of 'default' entrypoint, one of contract \"arms\" \
            \cannot be called: \"left - right\" (in top-to-bottom order)"
    ]
  ]