Util.hs

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

-- | Utils for testing Indigo

module Test.Util
  ( testIndigoContract
  , testIndigo
  , testIndigoDoc

  , zeroDivFail
  , notNewKeyFail
  , notNewKeyM
  , negativeResM

  , validateContractSt
  , validateContractConst

  , validateStSuccess
  , validateStEither
  , validateStack2

  , noOptimizationContract
  , MichelsonFailureWithStack
  ) where

import Data.Text.IO.Utf8 qualified as Utf8 (readFile)
import Fmt (pretty)
import Hedgehog (Gen, MonadTest, PropertyT, annotate, failure, forAll, property, (===))
import Prelude
import Test.HUnit ((@?=))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)
import Test.Tasty.HUnit (testCase)

import Indigo.Lorentz
import Lorentz.Run (Contract(..))
import Morley.Michelson.Interpret (MichelsonFailed(..))
import Morley.Michelson.Interpret qualified as Interpret (MichelsonFailureWithStack(..))
import Morley.Michelson.Runtime.Dummy (dummyContractEnv)
import Morley.Michelson.Typed.Haskell.Value (IsoValuesStack)
import Test.Cleveland hiding (failure)
import Test.Cleveland.Doc (buildMarkdownDocTest)
import Test.Cleveland.Lorentz.Types (ToStorageType)

type MichelsonFailureWithStack = Interpret.MichelsonFailureWithStack Void

type IndigoInstrValidator m pm st out =
  pm -> st -> Either MichelsonFailureWithStack (Rec Identity out) -> m ()

--------------------------------------------------------------------------------
-- Tests
--------------------------------------------------------------------------------

-- | Takes a validating function, an Indigo-generated contract and a Lorentz
-- contract and checks that the two have equivalent code (aka made of the same
-- instructions) and that it passes validation for random param and storage.
testIndigoContract
  :: forall pm st.
     ( Show pm, Show st
     , NiceParameterFull pm, NiceStorageFull st
     , HasCallStack
     , HasEntrypointArg pm (EntrypointRef 'Nothing) pm
     )
  => String
  -> Gen pm
  -> Gen st
  -> (forall caps m. MonadCleveland caps m => pm -> st -> ContractHandle pm st () -> m [ContractEvent] -> m ())
  -> ContractCode pm st
  -> FilePath
  -> TestTree
testIndigoContract name genPm genSt propValidator iContract michelsonFile =
  testGroup ("Indigo contract: " <> name)
    [ testCase "matches Michelson reference contract" $ do
        expectedContract <- Utf8.readFile michelsonFile
        printLorentzContract False iContractWithoutOptimization @?= fromStrict expectedContract
    , testProperty "has the correct resulting state and operations" $ property $ do
        pm <- forAll genPm
        st <- forAll genSt
        testScenarioProps $ scenarioEmulated do
          h <- originate "contract" st iContractWithoutOptimization
          propValidator pm st h $ transfer h WithContractEvents $ calling def pm
    ]
  where
    iContractWithoutOptimization = noOptimizationContract iContract

testIndigoDoc
    :: forall pm st.
       String
    -> ContractCode pm st
    -> ContractCode pm st
    -> TestTree
testIndigoDoc name iContract lContract =
  testCase (name <> " matches Lorentz docs content") $
    buildMarkdownDocTest iContract @?= buildMarkdownDocTest lContract

-- | Takes a validating function and an Indigo-generated Lorentz `Instr` to check
-- the resulting stack content.
testIndigo
  :: (Show pm, Show st, IsoValue pm, IsoValue st, IsoValuesStack out)
  => String
  -> Gen pm
  -> Gen st
  -> IndigoInstrValidator (PropertyT IO) pm st out
  -> ('[pm, st] :-> out)
  -> TestTree
testIndigo name genPm genSt validator iInstr =
  testProperty (name <> " Indigo Expr has correct resulting stack") $ property $ do
    pm <- forAll genPm
    st <- forAll genSt
    stackProp pm st
  where
    stackProp param storage = validator param storage .
      interpretLorentzInstr dummyContractEnv iInstr $
        Identity param :& Identity storage :& RNil

--------------------------------------------------------------------------------
-- Common failures
--------------------------------------------------------------------------------

zeroDivFail :: MichelsonFailureWithStack
zeroDivFail = errorToMichelsonVal [mt|division by zero|]

notNewKeyFail :: MichelsonFailureWithStack
notNewKeyFail = errorToMichelsonVal notNewKeyM

notNewKeyM :: MText
notNewKeyM = [mt|not new key|]

negativeResM :: MText
negativeResM = [mt|unacceptable negative result|]

--------------------------------------------------------------------------------
-- Contract Validators
--------------------------------------------------------------------------------

-- | Makes a validator for `testIndigoContract` that can expect a
-- new storage from the given function.
validateContractSt
  :: forall st addr caps m pm.
     ( Show (AsRPC st), Eq (AsRPC st), NiceStorage (AsRPC st)
     , ToStorageType st addr, MonadCleveland caps m )
  => (pm -> st -> AsRPC st) -> pm -> st -> addr -> m [ContractEvent] -> m ()
validateContractSt val pm st h act = clarifyErrors "matches expected storage" do
  void $ act
  Showing <$> (getStorage @st h) @@== Showing (val pm st)

-- | Validator for `testIndigoContract` that expects the storage to remain
-- the same. Ignores the parameter.
validateContractConst
  :: forall st addr caps m pm.
     ( Show (AsRPC st), Eq (AsRPC st), NiceStorage (AsRPC st)
     , ToStorageType st addr, MonadCleveland caps m )
  => pm -> AsRPC st -> addr -> m [ContractEvent] -> m ()
validateContractConst _ st h act = clarifyErrors "storage doesn't change" do
  void $ act
  Showing <$> (getStorage @st h) @@== Showing st

--------------------------------------------------------------------------------
-- Instr Validators
--------------------------------------------------------------------------------

-- | Makes a validator for `testIndigo` that expects the stack not to change type
-- and the "storage" value to have changed as described by the given function.
-- Resulting "param" is ignored.
validateStSuccess
  :: forall pm st m. (MonadTest m, Eq st, Show st)
  => (pm -> st -> st)
  -> IndigoInstrValidator m pm st '[pm, st]
validateStSuccess fn = validateStEither (\p s -> Right $ fn p s)

-- | Makes a validator for `testIndigo` that expects the stack not to change type
-- and Either end with a failure or with a new stack. Resulting "param" is ignored.
validateStEither
  :: forall m st pm. (MonadTest m, Eq st, Show st)
  => (pm -> st -> Either MichelsonFailureWithStack st)
  -> IndigoInstrValidator m pm st '[pm, st]
validateStEither fn param st res = assertMichelsonResult (fn param st) res checkSt
  where
    checkSt :: st -> (Rec Identity '[pm, st]) -> m ()
    checkSt val resStack = do
      let Identity _ :& Identity newState :& RNil = resStack
      annotate "matches resulting state"
      val === newState

-- | Makes a validator for `testIndigo` that expects the stack to have 3 element
-- (in order and with given values) or a failure to occur.
validateStack2
  :: forall m st pm. (MonadTest m, Eq pm, Eq st, Show pm, Show st)
  => (pm -> st -> Either MichelsonFailureWithStack (pm, st))
  -> IndigoInstrValidator m pm st '[pm, st]
validateStack2 fn param st res = assertMichelsonResult (fn param st) res checkSt
  where
    checkSt :: (pm, st) -> (Rec Identity '[pm, st]) -> m ()
    checkSt val resStack = do
      let Identity newParam :& Identity newState :& RNil = resStack
      annotate "matches resulting state"
      val === (newParam, newState)

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

assertMichelsonResult
  :: MonadTest m
  => Either MichelsonFailureWithStack a
  -> Either MichelsonFailureWithStack b
  -> (a -> b -> m ())
  -> m ()
assertMichelsonResult mRes1 mRes2 validatorRight = case (mRes1, mRes2) of
  (Left err, Left e) -> annotate "expected failure" >> err === e
  (Left err, Right _) -> annotate ("should have failed with: " <> pretty err) >> failure
  (Right _, Left e) -> annotate ("unexpected failure: " <> pretty e) >> failure
  (Right val1, Right val2) -> validatorRight val1 val2

noOptimizationContract
  :: (NiceParameterFull param, NiceStorageFull st)
  => ContractCode param st -> Contract param st ()
noOptimizationContract = mkContractWith noOptimizationOptions

noOptimizationOptions :: CompilationOptions
noOptimizationOptions = defaultCompilationOptions { coOptimizerConf = Nothing }

errorToMichelsonVal :: IsError e => e -> MichelsonFailureWithStack
errorToMichelsonVal msg =
  errorToVal msg (flip Interpret.MichelsonFailureWithStack def . MichelsonFailedWith)