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.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 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

epSpecPartial :: Map EpName U.Ty
epSpecPartial =
  [ ( U.UnsafeEpName "do1", U.Ty (U.TInt) def )
  , ( U.UnsafeEpName "do2"
    , U.Ty (U.TPair def def def def (U.Ty U.TInt def) (U.Ty U.TInt def)) def )
  , ( U.UnsafeEpName "do10", U.Ty (U.TUnit) def )
  , ( U.UnsafeEpName "do11", U.Ty (U.TNat) def )
  ]

epSpecFull :: Map EpName U.Ty
epSpecFull = epSpecPartial <>
  [ ( U.UnsafeEpName "do4"
    , U.Ty (
        U.TPair (unsafe $ U.mkAnnotation "param1")
                (unsafe $ U.mkAnnotation "param2")
                def
                def
                (U.Ty U.TUnit def)
                (U.Ty U.TBytes def)
        ) def )
  ]

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 @()) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]
      & expectFailure "Expected: nat\nActual:   int"
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints fails on missing entrypoints"
        (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]
      & expectFailure "Entrypoints do not match specification: \
          \Missing entrypoints in the contract: do123: int"
  ]

genBigPair :: Int -> U.Ty
genBigPair 0 = U.Ty U.TBytes def
genBigPair n = U.Ty (
    U.TPair (unsafe $ U.mkAnnotation "param1")
            (unsafe $ U.mkAnnotation "param2")
            def
            def
            (U.Ty U.TUnit def)
            (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 @()) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]
      & expectFailure  "Expected: nat\nActual:   int"
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on wrong nested type"
        (idContract @MyEntrypoints1 @()) [( U.UnsafeEpName "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))))))
          +      (bytes %param2)
          |]
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on missing entrypoints"
        (idContract @MyEntrypoints1 @()) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]
      & 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)"
  ]

test_ContractMatchEntrypointsT :: [TestTree]
test_ContractMatchEntrypointsT =
  [ testContractMatchesEntrypointsT @MyEntrypoints1
      "testContractMatchesEntrypointsT works as expected" (idContract @MyEntrypoints1 @())
  , 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 @())
  ]