Entrypoints.hs

-- SPDX-FileCopyrightText: 2021 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

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

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

import qualified Lorentz as L

import Data.List (isInfixOf)
import Test.Tasty (testGroup)
import Test.Tasty.HUnit
import Test.Tasty.Providers (IsTest, run)
import Test.Tasty.Runners

import Lorentz.Annotation
import Lorentz.Constraints
import Lorentz.Entrypoints
import Lorentz.Run
import Lorentz.Value
import qualified Morley.Michelson.Untyped as U

import Test.Cleveland.Lorentz.Entrypoints

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

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

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

dummyContract :: NiceParameterFull param => Contract param () ()
dummyContract = L.defaultContract $
  L.drop L.# L.unit L.# L.nil L.# L.pair

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 (U.unsafeMkAnnotation "param1")
                (U.unsafeMkAnnotation "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 str `isInfixOf` resultDescription
        then pass
        else assertFailure $ "Expected '" <> resultDescription <> "' to contain '" <> str <> "'"

test_ContractCoversEntrypoints :: [TestTree]
test_ContractCoversEntrypoints =
  [ testContractCoversEntrypoints
      "testContractCoversEntrypoints works as expected"
        (dummyContract @MyEntrypoints1) epSpecPartial
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints fails on wrong type"
        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]
      & expectFailure "Expected: nat"
  , testContractCoversEntrypoints
      "testContractCoversEntrypoints fails on missing entrypoints"
        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]
      & expectFailure "Missing entrypoints in the contract: do123"
  ]

test_ContractMatchEntrypoints :: [TestTree]
test_ContractMatchEntrypoints =
  [ testContractMatchesEntrypoints
      "testContractMatchesEntrypoints works as expected" (dummyContract @MyEntrypoints1) epSpecFull
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on wrong type"
        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do1", U.Ty (U.TNat) def ) ]
      & expectFailure "Expected: nat"
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on missing entrypoints"
        (dummyContract @MyEntrypoints1) [ ( U.UnsafeEpName "do123", U.Ty (U.TInt) def ) ]
      & expectFailure "Missing entrypoints in the contract: do123"
  , testContractMatchesEntrypoints
      "testContractMatchesEntrypoints fails on extraneous entrypoints"
        (dummyContract @MyEntrypoints1) epSpecPartial
      & expectFailure "Extraneous entrypoints in the contract: do4:\
                      \ pair (unit %param1) (bytes %param2)"
  ]

test_ContractMatchEntrypointsT :: [TestTree]
test_ContractMatchEntrypointsT =
  [ testContractMatchesEntrypointsT @MyEntrypoints1
      "testContractMatchesEntrypointsT works as expected" (dummyContract @MyEntrypoints1)
  , testContractMatchesEntrypointsT @MyEntrypoints2
      "testContractMatchesEntrypointsT fails on extra entrypoints" (dummyContract @MyEntrypoints1)
      & expectFailure "Extraneous entrypoints in the contract"
  ]

test_ContractCoverEntrypointsT :: [TestTree]
test_ContractCoverEntrypointsT =
  [ testContractCoversEntrypointsT @MyEntrypoints2
      "testContractCoversEntrypointsT works on partial spec" (dummyContract @MyEntrypoints1)
  , testContractCoversEntrypointsT @MyEntrypoints1
      "testContractCoversEntrypointsT works on full spec" (dummyContract @MyEntrypoints1)
  ]