ComparableSet.hs

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

-- | Module, containing spec to test compare.tz contract.
module Test.Interpreter.ComparableSet
  ( test_comparable_set
  ) where

import Data.Set as Set (fromList, toList)
import Hedgehog (MonadTest, forAll, property, withTests, (===))
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty (TestTree)
import Test.Tasty.Hedgehog (testProperty)

import Michelson.Interpret (InterpreterState, MichelsonFailed)
import Michelson.Test (contractProp, testTreesWithTypedContract)
import Michelson.Test.Dummy
import Michelson.Test.Util (failedTest, genTuple2)
import Michelson.Typed (ToT, fromVal)
import qualified Michelson.Typed as T

import Test.Util.Contracts

type Param = Set (Integer, Integer)
type HContractStorage = Maybe (Integer, Integer)
type ContractStorage = T.Value (ToT HContractStorage)
type ContractResult x
   = ( Either MichelsonFailed ([x], ContractStorage)
     , InterpreterState)

-- | Spec to test comparable_set.tz contract.
test_comparable_set :: IO [TestTree]
test_comparable_set =
  testTreesWithTypedContract (inContractsDir "comparable_set.tz") $ \contract ->
    let
      contractProp' inputParam =
        contractProp contract (validate (mkExpected inputParam))
        dummyContractEnv inputParam initStorage
    in pure
    [ testProperty "success test" $ property $
        contractProp'
          (fromList  [ (10, 11) , (10, 12)])
    , testProperty "Random check" $
        withTests 200 $ property $ do
          let genInteger = Gen.integral (Range.linearFrom 0 -1000 1000)
          inputParam <- forAll $ Gen.set (Range.linear 0 100) (genTuple2 genInteger genInteger)
          contractProp' inputParam
    ]
  where
    initStorage :: HContractStorage
    initStorage = Nothing

    mkExpected :: Param -> HContractStorage
    mkExpected x = case Set.toList x of
      [] -> Nothing
      _ -> Just $ maximum x

    validate
      :: MonadTest m
      => HContractStorage
      -> ContractResult x
      -> m ()
    validate e (Right ([], fromVal -> l), _) = l === e
    validate _ (Left _, _) = failedTest "Unexpected fail of script."
    validate _ _ = failedTest "Invalid result got."