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

-- | Utility functions for unit testing.

module Michelson.Test.Unit
  ( ContractReturn
  , ContractPropValidator
  , contractProp
  , contractPropVal
  , contractHasEntryPoints
  , matchContractEntryPoints
  , mkEntrypointsMap
  , hasEp
  , validateSuccess
  , validateStorageIs
  , validateMichelsonFailsWith
  ) where

import Data.List.NonEmpty (fromList)
import qualified Data.Map as Map
import Fmt ((+|), (|+))
import Test.Hspec.Expectations (Expectation, shouldBe, shouldSatisfy)
import Test.HUnit (Assertion, assertFailure, (@?=))

import Michelson.Interpret (ContractEnv, ContractReturn, MichelsonFailed(..), interpret)
import Michelson.Printer (printUntypedContract)
import Michelson.Runtime (parseExpandContract)
import Michelson.Typed (Contract, IsoValue(..), ToT)
import qualified Michelson.Typed as T
import Michelson.Untyped hiding (Contract)
import qualified Michelson.Untyped as U

-- | Type for contract execution validation.
--
-- It's a function which is supplied with contract execution output
-- (failure or new storage with operation list).
--
-- Function returns a property which type is designated by type variable @prop@
-- and might be 'Test.QuickCheck.Property' or 'Test.Hspec.Expectation'
-- or anything else relevant.
type ContractPropValidator st prop = ContractReturn st -> prop

-- | ContractCode's property tester against given input.
-- Takes contract environment, initial storage and parameter,
-- interprets contract on this input and invokes validation function.
contractProp
  :: ( IsoValue param, IsoValue storage
     , ToT param ~ cp, ToT storage ~ st
     , T.ParameterScope cp
     )
  => Contract cp st
  -> ContractPropValidator st prop
  -> ContractEnv
  -> param
  -> storage
  -> prop
contractProp :: Contract cp st
-> ContractPropValidator st prop
-> ContractEnv
-> param
-> storage
-> prop
contractProp instr :: Contract cp st
instr check :: ContractPropValidator st prop
check env :: ContractEnv
env param :: param
param initSt :: storage
initSt =
  Contract cp st
-> ContractPropValidator st prop
-> ContractEnv
-> Value cp
-> Value st
-> prop
forall (cp :: T) (st :: T) prop.
ParameterScope cp =>
Contract cp st
-> ContractPropValidator st prop
-> ContractEnv
-> Value cp
-> Value st
-> prop
contractPropVal Contract cp st
instr ContractPropValidator st prop
check ContractEnv
env (param -> Value (ToT param)
forall a. IsoValue a => a -> Value (ToT a)
toVal param
param) (storage -> Value (ToT storage)
forall a. IsoValue a => a -> Value (ToT a)
toVal storage
initSt)

-- | Version of 'contractProp' which takes 'Val' as arguments instead
-- of regular Haskell values.
--
-- This function assumes that contract has no explicit default entrypoints
-- and you always have to construct parameter manually; if you need to test
-- contract calling specific entrypoints, use integrational testing defined
-- by "Michelson.Test.Integrational" module.
contractPropVal
  :: (T.ParameterScope cp)
  => Contract cp st
  -> ContractPropValidator st prop
  -> ContractEnv
  -> T.Value cp
  -> T.Value st
  -> prop
contractPropVal :: Contract cp st
-> ContractPropValidator st prop
-> ContractEnv
-> Value cp
-> Value st
-> prop
contractPropVal instr :: Contract cp st
instr check :: ContractPropValidator st prop
check env :: ContractEnv
env param :: Value cp
param initSt :: Value st
initSt =
  ContractPropValidator st prop
check ContractPropValidator st prop -> ContractPropValidator st prop
forall a b. (a -> b) -> a -> b
$ ContractCode cp st
-> EntryPointCallT cp cp
-> Value cp
-> Value st
-> ContractEnv
-> ContractReturn st
forall (cp :: T) (st :: T) (arg :: T).
ContractCode cp st
-> EntryPointCallT cp arg
-> Value arg
-> Value st
-> ContractEnv
-> ContractReturn st
interpret (Contract cp st -> ContractCode cp st
forall (cp :: T) (st :: T). Contract cp st -> ContractCode cp st
T.cCode Contract cp st
instr) EntryPointCallT cp cp
forall (param :: T).
ParameterScope param =>
EntryPointCallT param param
T.epcCallRootUnsafe Value cp
param Value st
initSt ContractEnv
env

-- | Check if entrypoint is present in `T`.
hasEp :: T -> (EpName, U.Type) -> Bool
hasEp :: T -> (EpName, Type) -> Bool
hasEp (TOr lFieldAnn :: FieldAnn
lFieldAnn rFieldAnn :: FieldAnn
rFieldAnn lType :: Type
lType@(Type lT :: T
lT _) rType :: Type
rType@(Type rT :: T
rT _))
      ep :: (EpName, Type)
ep@(EpName -> FieldAnn
epNameToParamAnn -> FieldAnn
epAnn, epType :: Type
epType) = [Bool] -> Bool
forall t. (Container t, Element t ~ Bool) => t -> Bool
or
  [ (FieldAnn
epAnn FieldAnn -> FieldAnn -> Bool
forall a. Eq a => a -> a -> Bool
== FieldAnn
lFieldAnn Bool -> Bool -> Bool
&& Type
epType Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
lType)
  , (FieldAnn
epAnn FieldAnn -> FieldAnn -> Bool
forall a. Eq a => a -> a -> Bool
== FieldAnn
rFieldAnn Bool -> Bool -> Bool
&& Type
epType Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
rType)
  , T -> (EpName, Type) -> Bool
hasEp T
lT (EpName, Type)
ep
  , T -> (EpName, Type) -> Bool
hasEp T
rT (EpName, Type)
ep ]
hasEp _ _ = Bool
False

-- | Check whether the given set of entrypoints is present in contract.
contractHasEntryPoints :: U.Contract -> Map EpName U.Type -> Bool
contractHasEntryPoints :: Contract -> Map EpName Type -> Bool
contractHasEntryPoints contract :: Contract
contract eps :: Map EpName Type
eps = Either (NonEmpty (EpName, Type)) () -> Bool
forall a b. Either a b -> Bool
isRight (Either (NonEmpty (EpName, Type)) () -> Bool)
-> Either (NonEmpty (EpName, Type)) () -> Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
Contract -> Map EpName Type -> Either (NonEmpty (EpName, Type)) ()
Contract -> Map EpName Type -> Either (NonEmpty (EpName, Type)) ()
matchContractEntryPoints Contract
contract Map EpName Type
eps

-- | Match the given contract with provided set of entrypoints, return left if some
-- entrypoints were not found.
matchContractEntryPoints
  :: HasCallStack
  => U.Contract
  -> Map EpName U.Type
  -> Either (NonEmpty (EpName, U.Type)) ()
matchContractEntryPoints :: Contract -> Map EpName Type -> Either (NonEmpty (EpName, Type)) ()
matchContractEntryPoints contract :: Contract
contract eps :: Map EpName Type
eps =
  Contract -> Either (NonEmpty (EpName, Type)) ()
phi (Contract -> Either (NonEmpty (EpName, Type)) ())
-> Contract -> Either (NonEmpty (EpName, Type)) ()
forall a b. (a -> b) -> a -> b
$ Contract -> Either ParserException Contract -> Contract
forall b a. b -> Either a b -> b
fromRight (Text -> Contract
forall a. HasCallStack => Text -> a
error "Impossible") Either ParserException Contract
parsedContract
  where
    parsedContract :: Either ParserException Contract
parsedContract = Maybe FilePath -> Text -> Either ParserException Contract
parseExpandContract Maybe FilePath
forall a. Maybe a
Nothing
      (Text -> Text
forall a. ToText a => a -> Text
toText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> Contract -> Text
forall op. RenderDoc op => Bool -> Contract' op -> Text
printUntypedContract Bool
True Contract
contract)
    phi :: Contract -> Either (NonEmpty (EpName, Type)) ()
phi (Contract -> ParameterType
forall op. Contract' op -> ParameterType
contractParameter -> ParameterType (Type t :: T
t _) _) =
      [(EpName, Type)] -> Either (NonEmpty (EpName, Type)) ()
forall a. [a] -> Either (NonEmpty a) ()
conv ([(EpName, Type)] -> Either (NonEmpty (EpName, Type)) ())
-> [(EpName, Type)] -> Either (NonEmpty (EpName, Type)) ()
forall a b. (a -> b) -> a -> b
$ ((EpName, Type) -> Bool) -> [(EpName, Type)] -> [(EpName, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ep :: (EpName, Type)
ep -> Bool -> Bool
not (T -> (EpName, Type) -> Bool
hasEp T
t (EpName, Type)
ep)) (Map EpName Type -> [(EpName, Type)]
forall k a. Map k a -> [(k, a)]
Map.toList Map EpName Type
eps)
    conv :: [a] -> Either (NonEmpty a) ()
conv l :: [a]
l | [a] -> Bool
forall t. Container t => t -> Bool
null [a]
l = () -> Either (NonEmpty a) ()
forall a b. b -> Either a b
Right ()
           | Bool
otherwise = NonEmpty a -> Either (NonEmpty a) ()
forall a b. a -> Either a b
Left (NonEmpty a -> Either (NonEmpty a) ())
-> NonEmpty a -> Either (NonEmpty a) ()
forall a b. (a -> b) -> a -> b
$ [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
fromList [a]
l

----------------------------------------------------------------------------
-- Validators
----------------------------------------------------------------------------

-- | 'ContractPropValidator' that expects a successful termination.
validateSuccess :: HasCallStack => ContractPropValidator st Expectation
validateSuccess :: ContractPropValidator st Expectation
validateSuccess (res :: Either MichelsonFailed ([Operation], Value st)
res, _) = Either MichelsonFailed ([Operation], Value st)
res Either MichelsonFailed ([Operation], Value st)
-> (Either MichelsonFailed ([Operation], Value st) -> Bool)
-> Expectation
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
`shouldSatisfy` Either MichelsonFailed ([Operation], Value st) -> Bool
forall a b. Either a b -> Bool
isRight

-- | 'ContractPropValidator' that expects contract execution to
-- succeed and update storage to a particular constant value.
validateStorageIs
  :: IsoValue st
  => st -> ContractPropValidator (ToT st) Assertion
validateStorageIs :: st -> ContractPropValidator (ToT st) Expectation
validateStorageIs expected :: st
expected (res :: Either MichelsonFailed ([Operation], Value (ToT st))
res, _) =
  case Either MichelsonFailed ([Operation], Value (ToT st))
res of
    Left err :: MichelsonFailed
err ->
      FilePath -> Expectation
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> Expectation) -> FilePath -> Expectation
forall a b. (a -> b) -> a -> b
$ "Unexpected interpretation failure: " Builder -> Builder -> FilePath
forall b. FromBuilder b => Builder -> Builder -> b
+| MichelsonFailed
err MichelsonFailed -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ""
    Right (_ops :: [Operation]
_ops, got :: Value (ToT st)
got) ->
      Value (ToT st)
got Value (ToT st) -> Value (ToT st) -> Expectation
forall a. (HasCallStack, Eq a, Show a) => a -> a -> Expectation
@?= st -> Value (ToT st)
forall a. IsoValue a => a -> Value (ToT a)
toVal st
expected

-- | 'ContractPropValidator' that expects a given failure.
validateMichelsonFailsWith
  :: IsoValue v
  => v -> ContractPropValidator st Expectation
validateMichelsonFailsWith :: v -> ContractPropValidator st Expectation
validateMichelsonFailsWith v :: v
v (res :: Either MichelsonFailed ([Operation], Value st)
res, _) = Either MichelsonFailed ([Operation], Value st)
res Either MichelsonFailed ([Operation], Value st)
-> Either MichelsonFailed ([Operation], Value st) -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` MichelsonFailed -> Either MichelsonFailed ([Operation], Value st)
forall a b. a -> Either a b
Left (Value (ToT v) -> MichelsonFailed
forall (t :: T). KnownT t => Value t -> MichelsonFailed
MichelsonFailedWith (Value (ToT v) -> MichelsonFailed)
-> Value (ToT v) -> MichelsonFailed
forall a b. (a -> b) -> a -> b
$ v -> Value (ToT v)
forall a. IsoValue a => a -> Value (ToT a)
toVal v
v)