module Michelson.Test.Unit
( ContractReturn
, ContractPropValidator
, contractProp
, contractPropVal
, contractHasEntryPoints
, matchContractEntryPoints
, hasEp
) where
import Data.Default (def)
import Data.List.NonEmpty (fromList)
import qualified Data.Map as Map
import Michelson.Interpret (ContractEnv, ContractReturn, interpret)
import Michelson.Printer (printUntypedContract)
import Michelson.Runtime (parseExpandContract)
import Michelson.Typed (Contract, IsoValue(..), ToT, epNameToParamAnn)
import qualified Michelson.Typed as T
import Michelson.Untyped (EpName, para)
import Michelson.Untyped hiding (Contract)
import qualified Michelson.Untyped as U
type ContractPropValidator st prop = ContractReturn st -> prop
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 instr check env param initSt =
contractPropVal instr check env (toVal param) (toVal initSt)
contractPropVal
:: (T.ParameterScope cp)
=> Contract cp st
-> ContractPropValidator st prop
-> ContractEnv
-> T.Value cp
-> T.Value st
-> prop
contractPropVal instr check env param initSt =
check $ interpret instr def param initSt env
hasEp :: T -> (EpName, U.Type) -> Bool
hasEp (TOr lFieldAnn rFieldAnn lType@(Type lT _) rType@(Type rT _))
ep@(epNameToParamAnn -> epAnn, epType) = or
[ (epAnn == lFieldAnn && epType == lType)
, (epAnn == rFieldAnn && epType == rType)
, hasEp lT ep
, hasEp rT ep ]
hasEp _ _ = False
contractHasEntryPoints :: U.Contract -> Map EpName U.Type -> Bool
contractHasEntryPoints contract eps = isRight $ matchContractEntryPoints contract eps
matchContractEntryPoints
:: HasCallStack
=> U.Contract
-> Map EpName U.Type
-> Either (NonEmpty (EpName, U.Type)) ()
matchContractEntryPoints contract eps =
phi $ fromRight (error "Impossible") parsedContract
where
parsedContract = parseExpandContract Nothing
(toText $ printUntypedContract True contract)
phi (para -> Type t _) = conv $ filter (\ep -> not (hasEp t ep)) (Map.toList eps)
conv l | null l = Right ()
| otherwise = Left $ fromList l