ContractOp.hs

-- | Module, containing spec to test contract_op.tz contract.
module Test.Interpreter.ContractOp
  ( test_contract_op
  ) where

import qualified Data.Map as M
import Fmt (pretty)
import Test.QuickCheck (Property, (===))
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck (testProperty)

import Michelson.Interpret (ContractEnv(..), ContractReturn)
import Michelson.Test (contractProp, dummyContractEnv, failedProp, testTreesWithTypedContract)
import Michelson.Typed (FullContract, ToT, fromVal)
import Michelson.Untyped (ParameterType(..), T(..), Type(..), noAnn)
import Tezos.Address

import Test.Util.Contracts

-- | Spec to test @contract_op.tz@ contract.
--
-- Test results are confirmed by the reference implementation.
test_contract_op :: IO [TestTree]
test_contract_op =
  testTreesWithTypedContract (inContractsDir "contract_op.tz") $ \contract -> pure $
  [ testProperty "contract not found" $
      contractProp' False [] contract
  ] <>
  map (\(res, paramType) ->
          testProperty (msg res paramType) $
          contractProp' res [(addr, paramType)] contract
      )
  [ (True, ParameterType intQ "root")
  , (True, ParameterType int "root")
  , (False, ParameterType intQ noAnn)
  , (False, ParameterType int noAnn)
  , (False, ParameterType intP noAnn)
  , (False, ParameterType string noAnn)
  , (False, ParameterType intP "root")
  , (False, ParameterType intQ "another_root")
  ]
  where
    msg isGood paramType =
      "parameter in environment is '" <> pretty paramType <> "', " <>
      bool "" "but "  isGood <> "contract expects '%root int :q'"

    intQ = Type TInt "q"
    int = Type TInt noAnn
    intP = Type TInt "p"
    string = Type TString noAnn

    addr = unsafeParseContractHash "KT1WsLzQ61xtMNJHfwgCHh2RnALGgFAzeSx9"

    validate
      :: Bool
      -> ContractReturn (ToT Bool)
      -> Property
    validate ex (Right ([], fromVal -> l), _) = l === ex
    validate _ (Left _, _) = failedProp "Unexpected fail in interepreter"
    validate _ _ = failedProp "Unexpected result of script execution"

    contractProp'
      :: Bool -> [(ContractHash, ParameterType)] -> FullContract (ToT Address) (ToT Bool)
      -> Property
    contractProp' res ctrs contract =
      contractProp
        contract
        (validate res)
        dummyContractEnv {ceContracts = M.fromList ctrs}
        (ContractAddress addr)
        False