Entrypoints.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- To avoid explicitly depending on @containers@
{-# LANGUAGE OverloadedLists #-}

module TestSuite.Cleveland.Lorentz.Entrypoints
  ( test_ContractCoversEntrypoints
  , test_ContractMatchEntrypoints
  , test_ContractMatchEntrypointsT
  , test_ContractCoverEntrypointsT
  , expectFailure
  ) where

import Data.List (isInfixOf)
import Data.Text (strip)
import Test.Tasty (testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase)
import Test.Tasty.Providers (IsTest, run)
import Test.Tasty.Runners (FailureReason(..), Outcome(..), Result(..), TestTree(..))

import Lorentz.Annotation
import Lorentz.Entrypoints
import Lorentz.Value
import Morley.Michelson.Parser (utypeQ)
import Morley.Michelson.Typed.Convert (convertParamNotes)
import Morley.Michelson.Untyped qualified as U
import Morley.Util.Interpolate

import Test.Cleveland.Lorentz.Entrypoints
import TestSuite.Util

data MyEntrypoints1
  = Do1 Integer
  | Do2 (Integer, Integer)
  | Do3 MyEntrypoints2
  | Do4 MyParams
  deriving stock Generic
  deriving anyclass (IsoValue)

data MyEntrypoints2
  = Do10
  | Do11 Natural
  deriving stock Generic
  deriving anyclass (IsoValue)

data MyEntrypoints3
  = Default Natural
  | Do33 Integer
  deriving stock Generic
  deriving anyclass (IsoValue)

data MyParams = MyParams
  { param1 :: ()
  , param2 :: ByteString
  }
  deriving stock Generic
  deriving anyclass (IsoValue, HasAnnotation)

instance ParameterHasEntrypoints MyEntrypoints1 where
  type ParameterEntrypointsDerivation MyEntrypoints1 = EpdRecursive

instance ParameterHasEntrypoints MyEntrypoints2 where
  type ParameterEntrypointsDerivation MyEntrypoints2 = EpdPlain

instance ParameterHasEntrypoints MyEntrypoints3 where
  type ParameterEntrypointsDerivation MyEntrypoints3 = EpdPlain

epSpecPartial :: Map EpName U.Ty
epSpecPartial =
  [ ( #do1, [utypeQ| int |] )
  , ( #do2, [utypeQ| pair int int |] )
  , ( #do10, [utypeQ| unit |] )
  , ( #do11, [utypeQ| nat |] )
  ]

epSpecFull :: Map EpName U.Ty
epSpecFull = epSpecPartial <> [ ( #do4, [utypeQ| pair (unit %param1) (bytes %param2) |]) ]

extractTests :: TestTree -> (forall t. IsTest t => String -> t -> TestTree) -> TestTree
extractTests tree f = case tree of
  SingleTest name t -> f name t
  TestGroup name ts -> testGroup name $ map (`extractTests` f) ts
  _ -> error "unsupported"

expectFailure :: String -> TestTree -> TestTree
expectFailure str tree = AskOptions $ \opts ->
  extractTests tree $ \name test -> testCase name do
    result <- run opts test (const $ pure ())
    case result of
      Result{..} -> do
        assertBool "Result is failure" $ case resultOutcome of
          Failure TestFailed -> True
          _ -> False
        if (strip <$> lines (toText str)) `isInfixOf` (strip <$> lines (toText resultDescription))
        then pass
        else assertFailure $ "Expected '" <> resultDescription <> "' to contain '" <> str <> "'"

test_ContractCoversEntrypoints :: [TestTree]
test_ContractCoversEntrypoints =
  [ testContractCoversEntrypoints
      "testContractCoversEntrypoints works as expected"
        (idContract @MyEntrypoints1 @()) epSpecPartial
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints fails on wrong type"
        (idContract @MyEntrypoints1 @()) [ ( #do1, [utypeQ| nat |] ) ]
      & expectFailure "Expected: nat\nActual:   int"
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints fails on missing entrypoints"
        (idContract @MyEntrypoints1 @()) [ ( #do123, [utypeQ| int |] ) ]
      & expectFailure "Entrypoints do not match specification: \
          \Missing entrypoints in the contract: do123: int"
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints handles implicit default entrypoints if those are expected"
        (idContract @MyEntrypoints2 @()) [ ( U.DefEpName, [utypeQ| or (unit %do10) (nat %do11) |] ) ]
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints handles explicit default entrypoints if those are expected"
        (idContract @MyEntrypoints3 @()) [ ( U.DefEpName, [utypeQ| nat |] ) ]
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints fails on invalid implicit default entrypoint"
        (idContract @MyEntrypoints2 @()) [ ( U.DefEpName, [utypeQ| int |] ) ]
      & expectFailure [it|
          Type mismatch in entrypoints:
            <default>:
      |]
  ]

genBigPair :: Int -> U.Ty
genBigPair 0 = [utypeQ| bytes |]
genBigPair n = U.Ty (
    U.TPair (unsafe $ U.mkAnnotation "param1")
            (unsafe $ U.mkAnnotation "param2")
            def
            def
            [utypeQ| unit |]
            (genBigPair (n - 1))
    ) def

test_ContractMatchEntrypoints :: [TestTree]
test_ContractMatchEntrypoints =
  [ testContractMatchesEntrypoints
      "testContractMatchesEntrypoints works as expected" (idContract @MyEntrypoints1 @()) epSpecFull
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on wrong type"
        (idContract @MyEntrypoints1 @()) [ ( #do1, [utypeQ| nat |] ) ]
      & expectFailure  "Expected: nat\nActual:   int"
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on wrong nested type"
        (idContract @MyEntrypoints1 @()) [( #do4, genBigPair 6)]
      & expectFailure [it|
          - pair
          -   (unit %param1)
          -   (pair %param2
          -     (unit %param1)
          -     (pair %param2
          -       (unit %param1)
          -       (pair %param2
          -         (unit %param1)
          -         (pair %param2
          -           (unit %param1)
          -           (pair %param2 (unit %param1) (bytes %param2))))))
          + pair (unit %param1) (bytes %param2)
          |]
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on missing entrypoints"
        (idContract @MyEntrypoints1 @()) [ ( #do123, [utypeQ| int |] ) ]
      & expectFailure "Missing entrypoints in the contract: do123: int"
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on extraneous entrypoints"
        (idContract @MyEntrypoints1 @()) epSpecPartial
      & expectFailure "Entrypoints do not match specification:\
          \ Extraneous entrypoints in the contract: do4: pair (unit %param1) (bytes %param2)"
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints handles implicit default entrypoints if those are expected"
        (idContract @MyEntrypoints1 @()) $
          epSpecFull
          <> [ ( U.DefEpName, stripRootAnn $ convertParamNotes $
                   parameterEntrypointsToNotes @MyEntrypoints1 ) ]
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints handles explicit default entrypoints if those are expected"
        (idContract @MyEntrypoints3 @())
          [ ( U.DefEpName, [utypeQ| nat |] ), (#do33, [utypeQ| int |]) ]
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints handles explicit default entrypoints if those are unexpected"
        (idContract @MyEntrypoints3 @()) [ (#do33, [utypeQ| int |]) ]
      & expectFailure "Entrypoints do not match specification: \
          \Extraneous entrypoints in the contract: <default>: nat"
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on type mismatch in default entrypoint"
        (idContract @MyEntrypoints1 @()) (epSpecFull <> [ ( U.DefEpName, [utypeQ| unit |] ) ])
      & expectFailure [it|
          Type mismatch in entrypoints:
            <default>:
              Expected: unit
      |]
  ]

stripRootAnn :: U.ParameterType -> U.Ty
stripRootAnn (U.ParameterType ty _) = ty

test_ContractMatchEntrypointsT :: [TestTree]
test_ContractMatchEntrypointsT =
  [ testContractMatchesEntrypointsT @MyEntrypoints1
      "testContractMatchesEntrypointsT works as expected" (idContract @MyEntrypoints1 @())
  , testContractMatchesEntrypointsT @MyEntrypoints3
      "testContractMatchesEntrypointsT works as expected with explicit default"
        (idContract @MyEntrypoints3 @())
  , testContractMatchesEntrypointsT @MyEntrypoints2
      "testContractMatchesEntrypointsT fails on extra entrypoints" (idContract @MyEntrypoints1 @())
      & expectFailure [it|
          Extraneous entrypoints in the contract:
            do1: int
            do2: pair int int
            do4: pair (unit %param1) (bytes %param2)
            |]
  ]

test_ContractCoverEntrypointsT :: [TestTree]
test_ContractCoverEntrypointsT =
  [ testContractCoversEntrypointsT @MyEntrypoints2
      "testContractCoversEntrypointsT works on partial spec" (idContract @MyEntrypoints1 @())
  , testContractCoversEntrypointsT @MyEntrypoints1
      "testContractCoversEntrypointsT works on full spec" (idContract @MyEntrypoints1 @())
  , testContractCoversEntrypointsT @MyEntrypoints3
      "testContractCoversEntrypointsT works on explicit default" (idContract @MyEntrypoints3 @())
  ]