-- | Mirrors 'Michelson.Test.Integrational' module in a Lorentz way.
module Lorentz.Test.Integrational
  (
    -- * Re-exports
    TxData (..)
  , genesisAddresses
  , genesisAddress
  -- * More genesis addresses which can be used in tests
  , genesisAddress1
  , genesisAddress2
  , genesisAddress3
  , genesisAddress4
  , genesisAddress5
  , genesisAddress6

    -- * Testing engine for bare Typed primitives
  , tOriginate
  , tTransfer
  , tExpectStorageConst

    -- * Testing engine
  , I.IntegrationalValidator
  , SuccessValidator
  , IntegrationalScenarioM
  , I.IntegrationalScenario
  , I.ValidationError (..)
  , I.integrationalTestExpectation
  , I.integrationalTestProperty
  , lOriginate
  , lOriginateEmpty
  , lTransfer
  , lCall
  , I.validate
  , I.setMaxSteps
  , I.setNow
  , I.rewindTime
  , I.withSender
  , I.setChainId
  , I.branchout
  , (I.?-)
  , I.offshoot

  -- * Validators
  , I.composeValidators
  , I.composeValidatorsList
  , I.expectAnySuccess
  , I.expectNoUpdates
  , I.expectNoStorageUpdates
  , lExpectStorageUpdate
  , lExpectBalance
  , lExpectStorageConst
  -- * Errors
  , lExpectMichelsonFailed
  , lExpectFailWith
  , lExpectError
  , lExpectErrorNumeric
  , lExpectCustomError
  , lExpectCustomErrorNumeric
  , lExpectCustomError_
  , lExpectCustomErrorNumeric_

  -- ** Consumer
  , lExpectConsumerStorage
  , lExpectViewConsumerStorage
  ) where

import Data.Default (Default(..))
import Data.Singletons (SingI)
import Data.Typeable (gcast)
import Data.Vinyl.Derived (Label)
import Fmt (Buildable, listF, (+|), (|+))
import Named ((:!), arg)

import qualified Lorentz as L
import Lorentz.Constraints
import Lorentz.Run
import Lorentz.Value
import Michelson.Interpret (InterpretError(..), MichelsonFailed(..))
import Michelson.Runtime
import Michelson.Runtime.GState
import Michelson.Test.Integrational (IntegrationalScenarioM, SuccessValidator)
import qualified Michelson.Test.Integrational as I
import Michelson.TypeCheck (typeVerifyValue)
import qualified Michelson.Typed as T
import Michelson.Typed.Scope
import Tezos.Core
import Util.Named ((.!))

----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------

-- TODO: how to call they normally? :thinking:
-- Preserving just the same names like @transfer@ or @originate@
-- looks very bad because no one will import this or
-- 'Michelson.Test.Integrational' module qualified
-- and thus finding which exact function is used would become too painful.

-- | Like 'originate', but for typed contract and value.
tOriginate
  :: (ParameterScope cp, StorageScope st)
  => T.Contract cp st -> Text -> T.Value st -> Mutez -> IntegrationalScenarioM Address
tOriginate contract name value balance =
  I.originate (T.convertContract contract) name (T.untypeValue value) balance

-- | Like 'originate', but for Lorentz contracts.
lOriginate
  :: forall cp st.
     (NiceParameter cp, NiceStorage st)
  => L.Contract cp st
  -> Text
  -> st
  -> Mutez
  -> IntegrationalScenarioM (ContractRef cp)
lOriginate contract name value balance =
  withDict (niceParameterEvi @cp) $
  withDict (niceStorageEvi @st) $ do
    addr <- tOriginate (compileLorentz contract) name (T.toVal value) balance
    return (L.ContractRef addr def)

-- | Originate a contract with empty balance and default storage.
lOriginateEmpty
  :: (NiceParameter cp, NiceStorage st, Default st)
  => L.Contract cp st
  -> Text
  -> IntegrationalScenarioM (ContractRef cp)
lOriginateEmpty contract name = lOriginate contract name def (unsafeMkMutez 0)

-- | Similar to 'transfer', for typed values.
tTransfer
  :: forall cp.
     (ParameterScope cp)
  => "from" :! Address
  -> "to" :! Address
  -> Mutez
  -> T.Value cp
  -> IntegrationalScenarioM ()
tTransfer (arg #from -> from) (arg #to -> to) money param =
  let txData = TxData
        { tdSenderAddress = from
        , tdParameter =
            withDict (properParameterEvi @cp) $
            T.untypeValue param
        , tdAmount = money
        }
  in I.transfer txData to

-- | Similar to 'transfer', for Lorentz values.
lTransfer
  :: forall cp contract.
     (NiceParameter cp, ToContractRef cp contract)
  => "from" :! Address
  -> "to" :! contract
  -> Mutez
  -> cp
  -> IntegrationalScenarioM ()
lTransfer from (convertContractRef @cp @Address . arg #to -> to) money param =
  withDict (niceParameterEvi @cp) $
    tTransfer from (#to .! to) money (T.toVal param)

-- | Call a contract without caring about the source address. Transfers 0 mutez.
lCall
  :: forall cp contract.
     (NiceParameter cp, ToContractRef cp contract)
  => contract -> cp -> IntegrationalScenarioM ()
lCall contract param =
  lTransfer (#from .! genesisAddress) (#to .! contract)
    (unsafeMkMutez 0) param

----------------------------------------------------------------------------
-- Validators to be used within 'IntegrationalValidator'
----------------------------------------------------------------------------

-- Expect something successful

-- | Similar to 'expectStorageUpdate', for Lorentz values.
lExpectStorageUpdate
  :: forall st addr.
     (NiceStorage st, ToAddress addr, HasCallStack)
  => addr -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectStorageUpdate (toAddress -> addr) predicate =
  I.expectStorageUpdate addr $ \got -> do
    val <- first I.UnexpectedTypeCheckError $ typeCheck got
    predicate $ T.fromVal val
  where
    typeCheck uval =
      evaluatingState initSt . runExceptT $
      usingReaderT def $
      typeVerifyValue uval
    initSt = error "Typechecker state unavailable"

-- | Like 'expectBalance', for Lorentz values.
lExpectBalance :: ToAddress addr => addr -> Mutez -> SuccessValidator
lExpectBalance (toAddress -> addr) money = I.expectBalance addr money

-- | Similar to 'expectStorageConst', for typed stuff.
tExpectStorageConst
  :: forall st.
     (StorageScope st)
  => Address -> Value st -> SuccessValidator
tExpectStorageConst addr expected =
  I.expectStorageConst addr (T.untypeValue expected)

-- | Similar to 'expectStorageConst', for Lorentz values.
lExpectStorageConst
  :: forall st addr.
     (NiceStorage st, ToAddress addr)
  => addr -> st -> SuccessValidator
lExpectStorageConst (toAddress -> addr) expected =
  withDict (niceStorageEvi @st) $
    tExpectStorageConst addr (T.toVal expected)

-- Expect errors

-- | Expect that interpretation of contract with given address ended
-- with [FAILED].
lExpectMichelsonFailed
  :: forall addr. (ToAddress addr)
  => (MichelsonFailed -> Bool) -> addr -> InterpreterError -> Bool
lExpectMichelsonFailed predicate (toAddress -> addr) =
  I.expectMichelsonFailed predicate addr

-- | Expect contract to fail with "FAILWITH" instruction and provided value
-- to match against the given predicate.
lExpectFailWith
  :: forall e.
      (Typeable (T.ToT e), T.IsoValue e)
  => (e -> Bool) -> InterpreterError -> Bool
lExpectFailWith predicate =
  \case
    IEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->
        case gcast err of
          Just errT -> predicate $ T.fromVal @e errT
          Nothing -> False
    _ -> False

-- | Expect contract to fail with given error.
lExpectError
  :: forall e.
      (L.IsError e)
  => (e -> Bool) -> InterpreterError -> Bool
lExpectError = lExpectError' L.errorFromVal

-- | Version of 'lExpectError' for the case when numeric
-- representation of errors is used.
lExpectErrorNumeric
  :: forall e.
      (L.IsError e)
  => L.ErrorTagMap -> (e -> Bool) -> InterpreterError -> Bool
lExpectErrorNumeric errorTagMap =
  lExpectError' (L.errorFromValNumeric errorTagMap)

lExpectError' ::
     forall e.
     (forall t. (Typeable t, SingI t) =>
                  Value t -> Either Text e)
  -> (e -> Bool)
  -> InterpreterError
  -> Bool
lExpectError' errorFromValImpl predicate =
  \case
    IEInterpreterFailed _ (RuntimeFailure (MichelsonFailedWith err, _)) ->
        case errorFromValImpl err of
          Right err' -> predicate err'
          Left _ -> False
    _ -> False

-- | Expect contract to fail with given 'CustomError'.
lExpectCustomError
  :: forall tag arg.
      (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)
  => Label tag -> arg -> InterpreterError -> Bool
lExpectCustomError l a =
  lExpectError (== L.CustomError l a)

-- | Version of 'lExpectCustomError' for the case when numeric
-- representation of errors is used.
lExpectCustomErrorNumeric
  :: forall tag arg.
      (L.IsError (L.CustomError tag), arg ~ L.ErrorArg tag, Eq arg)
  => L.ErrorTagMap -> Label tag -> arg -> InterpreterError -> Bool
lExpectCustomErrorNumeric errorTagMap l a =
  lExpectErrorNumeric errorTagMap (== L.CustomError l a)

-- | Specialization of 'lExpectCustomError' for non-arg error case.
lExpectCustomError_
  :: forall tag.
      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
  => Label tag -> InterpreterError -> Bool
lExpectCustomError_ l =
  lExpectCustomError l ()

-- | Version of 'lExpectCustomError_' for the case when numeric
-- representation of errors is used.
lExpectCustomErrorNumeric_
  :: forall tag.
      (L.IsError (L.CustomError tag), L.ErrorArg tag ~ ())
  => L.ErrorTagMap -> Label tag -> InterpreterError -> Bool
lExpectCustomErrorNumeric_ errorTagMap l =
  lExpectCustomErrorNumeric errorTagMap l ()

-- Consumer

-- | Version of 'lExpectStorageUpdate' specialized to "consumer" contract
-- (see 'Lorentz.Contracts.Consumer.contractConsumer').
lExpectConsumerStorage
  :: forall cp st contract.
     (st ~ [cp], NiceStorage st, ToContractRef cp contract)
  => contract -> (st -> Either I.ValidationError ()) -> SuccessValidator
lExpectConsumerStorage = lExpectStorageUpdate . toContractRef @cp

-- | Assuming that "consumer" contract receives a value from 'View', expect
-- this view return value to be the given one.
--
-- Despite consumer stores parameters it was called with in reversed order,
-- this function cares about it, so you should provide a list of expected values
-- in the same order in which the corresponding events were happenning.
lExpectViewConsumerStorage
  :: ( st ~ [cp]
     , Eq cp, Buildable cp
     , NiceStorage st
     , ToContractRef cp contract
     )
  => contract -> [cp] -> SuccessValidator
lExpectViewConsumerStorage addr expected =
  lExpectConsumerStorage addr (matchExpected . reverse)
  where
    mkError = Left . I.CustomValidationError
    matchExpected got
      | got == expected = pass
      | otherwise = mkError $ "Expected " +| listF expected |+
                              ", but got " +| listF got |+ ""