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

{-# OPTIONS_HADDOCK not-home #-}

-- | Internal utilities for unit testing.
module Test.Cleveland.Lorentz.Internal.Entrypoints
  ( module Test.Cleveland.Lorentz.Internal.Entrypoints
  ) where

import Lorentz hiding (contract)

import Data.Map qualified as Map
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.HUnit (testCase)

import Morley.Michelson.Typed (HandleImplicitDefaultEp(..), convertContract, flattenEntrypoints)
import Morley.Michelson.Untyped qualified as U
import Morley.Util.Named

import Test.Cleveland.Michelson.Internal.Entrypoints qualified as M

-- | Utility type synonym
type ContractEPTypeTest expectedEps
  =  forall contractEps st vd.
     (NiceParameterFull expectedEps, NiceParameterFull contractEps)
  => Contract contractEps st vd -> TestTree

-- | Utility type synonym
type ContractEPTest contractEps st vd
  =  Contract contractEps st vd
  -> Map EpName U.Ty
  -> TestTree

-- | Expect the contract to match with the entrypoints given in spec passed as the first type
-- argument. Checks both the contract type and the contract itself (when represented as an untyped
-- Michelson contract).
-- Comparison is defined by the first argument; use @ignoreExtraEntrypoints@ for cover test,
-- @id@ for match test.
testCompareContractEntrypointsT
  :: forall expectedEps.
     (M.EPMismatch -> M.EPMismatch)
  -> TestName -> ContractEPTypeTest expectedEps
testCompareContractEntrypointsT :: forall expectedEps.
(EPMismatch -> EPMismatch)
-> TestName -> ContractEPTypeTest expectedEps
testCompareContractEntrypointsT EPMismatch -> EPMismatch
compareMode TestName
name Contract contractEps st vd
contract =
  let entrypoints :: Map EpName Ty
entrypoints = HandleImplicitDefaultEp
-> ParamNotes (ToT expectedEps) -> Map EpName Ty
forall (t :: T).
HandleImplicitDefaultEp -> ParamNotes t -> Map EpName Ty
flattenEntrypoints HandleImplicitDefaultEp
WithoutImplicitDefaultEp (ParamNotes (ToT expectedEps) -> Map EpName Ty)
-> ParamNotes (ToT expectedEps) -> Map EpName Ty
forall a b. (a -> b) -> a -> b
$
        forall cp. ParameterDeclaresEntrypoints cp => ParamNotes (ToT cp)
parameterEntrypointsToNotes @expectedEps
  in (EPMismatch -> EPMismatch)
-> TestName -> ContractEPTest contractEps st vd
forall contractEps st vd.
NiceParameterFull contractEps =>
(EPMismatch -> EPMismatch)
-> TestName -> ContractEPTest contractEps st vd
testCompareContractEntrypoints EPMismatch -> EPMismatch
compareMode TestName
name Contract contractEps st vd
contract Map EpName Ty
entrypoints

-- | Expect the contract to match with the entrypoints given in spec (with matching types).
-- Checks both the contract type and the contract itself (when represented as an untyped Michelson
-- contract).
-- Comparison is defined by the first argument; use @ignoreExtraEntrypoints@ for cover test,
-- @id@ for match test.
testCompareContractEntrypoints
  :: forall contractEps st vd.
     NiceParameterFull contractEps
  => (M.EPMismatch -> M.EPMismatch)
  -> TestName -> ContractEPTest contractEps st vd
testCompareContractEntrypoints :: forall contractEps st vd.
NiceParameterFull contractEps =>
(EPMismatch -> EPMismatch)
-> TestName -> ContractEPTest contractEps st vd
testCompareContractEntrypoints EPMismatch -> EPMismatch
compareMode TestName
name contract :: Contract contractEps st vd
contract@Contract{} Map EpName Ty
spec =
  let entrypointsInType :: Map EpName Ty
entrypointsInType = HandleImplicitDefaultEp
-> ParamNotes (ToT contractEps) -> Map EpName Ty
forall (t :: T).
HandleImplicitDefaultEp -> ParamNotes t -> Map EpName Ty
flattenEntrypoints HandleImplicitDefaultEp
wantsDefaultEp (ParamNotes (ToT contractEps) -> Map EpName Ty)
-> ParamNotes (ToT contractEps) -> Map EpName Ty
forall a b. (a -> b) -> a -> b
$
        forall cp. ParameterDeclaresEntrypoints cp => ParamNotes (ToT cp)
parameterEntrypointsToNotes @contractEps
      wantsDefaultEp :: HandleImplicitDefaultEp
wantsDefaultEp
        | EpName -> Map EpName Ty -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member EpName
DefEpName Map EpName Ty
spec = HandleImplicitDefaultEp
WithImplicitDefaultEp
        | Bool
otherwise = HandleImplicitDefaultEp
WithoutImplicitDefaultEp
      contract' :: Contract
contract' = Contract (ToT contractEps) (ToT st) -> Contract
forall (param :: T) (store :: T). Contract param store -> Contract
convertContract (Contract (ToT contractEps) (ToT st) -> Contract)
-> (Contract contractEps st vd
    -> Contract (ToT contractEps) (ToT st))
-> Contract contractEps st vd
-> Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contract contractEps st vd -> Contract (ToT contractEps) (ToT st)
forall cp st vd. Contract cp st vd -> Contract (ToT cp) (ToT st)
toMichelsonContract (Contract contractEps st vd -> Contract)
-> Contract contractEps st vd -> Contract
forall a b. (a -> b) -> a -> b
$ Contract contractEps st vd
contract
  in TestName -> [TestTree] -> TestTree
testGroup TestName
name
      [ TestName -> Assertion -> TestTree
testCase TestName
"Contract type matches entrypoint spec" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
          Either TcTypeError EPMismatch -> Assertion
M.assertEPComparisonSuccessful (Either TcTypeError EPMismatch -> Assertion)
-> (EPMismatch -> Either TcTypeError EPMismatch)
-> EPMismatch
-> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EPMismatch -> Either TcTypeError EPMismatch
forall a b. b -> Either a b
Right (EPMismatch -> Either TcTypeError EPMismatch)
-> (EPMismatch -> EPMismatch)
-> EPMismatch
-> Either TcTypeError EPMismatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EPMismatch -> EPMismatch
compareMode (EPMismatch -> Assertion) -> EPMismatch -> Assertion
forall a b. (a -> b) -> a -> b
$
            ("expected" :! Map EpName Ty)
-> ("actual" :! Map EpName Ty) -> EPMismatch
M.compareEntrypoints (IsLabel "expected" (Name "expected")
Name "expected"
#expected Name "expected" -> Map EpName Ty -> "expected" :! Map EpName Ty
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
:! Map EpName Ty
spec) (IsLabel "actual" (Name "actual")
Name "actual"
#actual Name "actual" -> Map EpName Ty -> "actual" :! Map EpName Ty
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
:! Map EpName Ty
entrypointsInType)
      , (EPMismatch -> EPMismatch)
-> TestName -> Contract -> Map EpName Ty -> TestTree
M.testContractEntrypoints EPMismatch -> EPMismatch
compareMode
          TestName
"Untyped contract matches entrypoint spec" Contract
contract' Map EpName Ty
spec
      ]