Compare.hs

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

-- | Module, containing spec to test compare.tz contract.
module Test.Interpreter.Compare
  ( test_compare
  , test_Equality_vs_compare
  ) where

import Hedgehog (MonadTest, discard, forAll, property, withDiscards, withTests, (===))
import Test.Tasty (TestTree)
import Test.Tasty.Hedgehog (testProperty)

import Hedgehog.Gen.Michelson.Typed
import Hedgehog.Gen.Michelson.Untyped qualified as U
import Hedgehog.Gen.Tezos.Core (genMutez)
import Morley.Michelson.Interpret (ContractReturn)
import Morley.Michelson.Typed (ToT, fromVal)
import Morley.Michelson.Typed qualified as T
import Morley.Tezos.Core (Mutez)
import Test.Cleveland
import Test.Cleveland.Lorentz.Import (embedContract)
import Test.Cleveland.Util (failedTest, genTuple2)

import Test.Util.Contracts

type Param = (Mutez, Mutez)
type ContractResult = ContractReturn (ToT [Bool])

-- | Spec to test compare.tz contract.
test_compare :: [TestTree]
test_compare =
    [ testScenarioOnEmulator "success test" $ myScenario (10, 11)
    , testProperty "Random check" $
        withTests 200 $ property $ do
          inputParam <- forAll $ genTuple2 genMutez genMutez
          testScenarioProps $ myScenario inputParam
    ]
  where
    contract = $$(embedContract @Param @[Bool] @() (inContractsDir "tezos_examples/macros/compare.tz"))

    myScenario :: Monad m => Param -> Scenario m
    myScenario inp = scenario do
      handle <- originateSimple "compare" [] contract
      call handle CallDefault inp
      getStorage handle @@== mkExpected inp
      pure ()

    initStorage :: [Bool]
    initStorage = []

    mkExpected :: Param -> [Bool]
    mkExpected (a, b) = [a == b, a > b, a < b, a >= b, a <= b]

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

{-# ANN module ("HLint: ignore Redundant compare" :: Text) #-}

-- | This test is necessary because there exist two notions of comparable
-- values - in Michelson world (works only for specific types) and in
-- Haskell world (works for all values).
-- And at the moment of writing we define 'Ord' instance for 'Value' as in
-- Michelson, while 'Eq' instance is produced by Haskell means automatically.
--
-- In various places we rely on the fact that instance produced by Haskell
-- matches the Michelson definitions, so we have to ensure that on comparable
-- types (in terms of Michelson) our @Eq@ and @Ord@ instances match.
test_Equality_vs_compare :: TestTree
test_Equality_vs_compare =
  testProperty "Eq and Ord instances on Value match" $
    withDiscards 200 $ property $ do
      T.AsUTypeExt st _ <- forAll U.genValidType
      case (T.checkComparability st, T.checkOpPresence st, T.getWTP' st) of
        (T.CanBeCompared, T.OpAbsent, Right T.Dict) -> do
          value1 <- forAll $ genValue' st
          value2 <- forAll $ genValue' st
          forM_ ((,) <$> [value1, value2] <*> [value1, value2]) $ \(v1, v2) ->
            (compare v1 v2 == EQ) === (v1 == v2)
        _ -> discard