content: {- |
  Module     : Test.Specification
  Maintainer : seungheon.ooh@gmail.com
  Description: Helpers to build Specification for testing and bench-marking
  
  Constructors for building a specification for Plutarch scripts:
  
    - 'policySucceedsWith': checks that a minting policy succeeds.
  
    - 'policyFailsWith': checks that a minting policy fails.
  
    - 'validatorSucceedsWith': checks that validator succeeds.
  
    - 'validatorFailsWith': checks that validator fails.
  
    - 'effectSucceedsWith': checks that effect succeeds.
  
    - 'effectFailsWith': checks that effect fails.
  
    - 'scriptSucceeds': checks that an arbitrary script does not
      `perror`.
  
    - 'scriptFails': checks that an arbitrary script `perror`s out.
  -}
  module Test.Specification (
    -- * Structures
    Specification (..),
    SpecificationExpectation (..),
    SpecificationTree (..),
  
    -- * Spec helpers
    group,
    getSpecification,
    getSpecificationTree,
  
    -- * Spec builders
    scriptSucceeds,
    scriptFails,
    policySucceedsWith,
    policyFailsWith,
    validatorSucceedsWith,
    validatorFailsWith,
    effectSucceedsWith,
    effectFailsWith,
    testValidator,
    testPolicy,
  
    -- * Converters
    toTestTree,
  ) where
  
  import Control.Composition ((.**), (.***))
  import Data.Coerce (coerce)
  import Data.Text qualified as Text
  import Plutarch.Evaluate (evalScript)
  import Plutarch.Script (Script (Script))
  import PlutusCore.Data qualified as PLC
  import PlutusCore.MkPlc qualified as PLC
  import PlutusLedgerApi.V2 (
    Datum (..),
    Redeemer (Redeemer),
    ScriptContext,
    ToData (toBuiltinData),
    toData,
   )
  import PlutusPrelude (over)
  import PlutusTx.IsData qualified as PlutusTx (ToData)
  import Test.Tasty (TestTree, testGroup)
  import Test.Tasty.HUnit (assertFailure, testCase)
  import UntypedPlutusCore qualified as UPLC
  
  {- | Expectations upon execution of script
   @Success@ indicates a successful execution.
   @Failure@ inidcates a faulty execution.
   @FailureWith@ indicates a faulty execution but with expected reason for failure.
  -}
  data SpecificationExpectation
    = Success
    | Failure
    | FailureWith String
    deriving stock (Show)
  
  {- | Unit of specification. @Specification@ holds name, expectation, and
    script to be tested or executed later on.
  -}
  data Specification = Specification
    { sName :: String
    , sExpectation :: SpecificationExpectation
    , sScript :: Script
    }
    deriving stock (Show)
  
  -- | Tree-structure to group alike specifications--modeled after @TestTree@ from tasty.
  data SpecificationTree
    = Terminal Specification
    | Group String [SpecificationTree]
    deriving stock (Show)
  
  {- | Checks if given name exists in @SpecificationTree@ as either
   group name or specification name.
  -}
  exists :: String -> SpecificationTree -> Bool
  exists s (Terminal (Specification name _ _)) = s == name
  exists s (Group name st) = or (exists s <$> st) || s == name
  
  -- | Groups alike @SpecificationTree@s into a bigger tree.
  group :: String -> [SpecificationTree] -> SpecificationTree
  group name st
    | or $ exists name <$> st = error $ "Name already exists: " <> name
    | otherwise = Group name st
  
  -- | Query specific @Specification@ from a tree.
  getSpecification :: String -> SpecificationTree -> [Specification]
  getSpecification name (Terminal spec@(Specification sn _ _))
    | name == sn = [spec]
    | otherwise = []
  getSpecification name (Group _ st) = mconcat $ getSpecification name <$> st
  
  -- | Query specific @SpecificationTree@ from a tree.
  getSpecificationTree :: String -> SpecificationTree -> [SpecificationTree]
  getSpecificationTree name specTree@(Group gn st)
    | gn == name = [specTree]
    | otherwise = mconcat $ getSpecificationTree name <$> st
  getSpecificationTree _ _ = []
  
  -- | Convert @SpecificationTree@ into @TestTree@ to be used as a unit test.
  toTestTree :: SpecificationTree -> TestTree
  toTestTree (Group name st) = testGroup name $ toTestTree <$> st
  toTestTree (Terminal (Specification name expectation script)) =
    testCase name $ do
      case expectation of
        Success -> onSuccess
        Failure -> onFailure
        FailureWith s -> onFailureWith s
    where
      beautifyTraces =
        Text.unpack
          . Text.intercalate "\n"
          . map ("  " <>)
      (res, _budget, traces) = evalScript script
      ts = " Traces:\n" <> beautifyTraces traces
      onSuccess = case res of
        Left e ->
          assertFailure $
            show e <> ts
        _ -> pure ()
      onFailure = case res of
        Right v ->
          assertFailure $
            "Expected failure, but succeeded. "
              <> show v
              <> ts
        _ -> pure ()
      onFailureWith _s = case res of -- TODO: check Trace for this
        Right v ->
          assertFailure $
            "Expected failure, but succeeded. "
              <> show v
              <> ts
        _ -> pure ()
  
  -- | Check that an arbitrary script doesn't error when evaluated, given a name.
  scriptSucceeds :: String -> Script -> SpecificationTree
  scriptSucceeds name script = Terminal $ Specification name Success script
  
  -- | Check that an arbitrary script **does** error when evaluated, given a name.
  scriptFails :: String -> Script -> SpecificationTree
  scriptFails name script = Terminal $ Specification name Failure script
  
  mkRedeemer ::
    forall redeemer.
    (PlutusTx.ToData redeemer) =>
    redeemer ->
    Redeemer
  mkRedeemer = Redeemer . toBuiltinData
  
  mkDatum ::
    forall datum.
    (PlutusTx.ToData datum) =>
    datum ->
    Datum
  mkDatum = Datum . toBuiltinData
  
  applyMintingPolicy' ::
    (PlutusTx.ToData redeemer) =>
    Script ->
    redeemer ->
    ScriptContext ->
    Script
  applyMintingPolicy' policy redeemer scriptContext =
    applyArguments
      policy
      [ toData $ mkRedeemer redeemer
      , toData scriptContext
      ]
  
  applyValidator' ::
    ( PlutusTx.ToData datum
    , PlutusTx.ToData redeemer
    ) =>
    Script ->
    datum ->
    redeemer ->
    ScriptContext ->
    Script
  applyValidator' validator datum redeemer scriptContext =
    applyArguments
      validator
      [ toData $ mkDatum datum
      , toData $ mkRedeemer redeemer
      , toData scriptContext
      ]
  
  -- | Check that a policy script succeeds, given a name and arguments.
  policySucceedsWith ::
    (PlutusTx.ToData redeemer) =>
    String ->
    Script ->
    redeemer ->
    ScriptContext ->
    SpecificationTree
  policySucceedsWith tag =
    scriptSucceeds tag .** applyMintingPolicy'
  
  -- | Check that a policy script fails, given a name and arguments.
  policyFailsWith ::
    (PlutusTx.ToData redeemer) =>
    String ->
    Script ->
    redeemer ->
    ScriptContext ->
    SpecificationTree
  policyFailsWith tag =
    scriptFails tag .** applyMintingPolicy'
  
  -- | Check that a validator script succeeds, given a name and arguments.
  validatorSucceedsWith ::
    ( PlutusTx.ToData datum
    , PlutusTx.ToData redeemer
    ) =>
    String ->
    Script ->
    datum ->
    redeemer ->
    ScriptContext ->
    SpecificationTree
  validatorSucceedsWith tag =
    scriptSucceeds tag .*** applyValidator'
  
  -- | Check that a validator script fails, given a name and arguments.
  validatorFailsWith ::
    ( PlutusTx.ToData datum
    , PlutusTx.ToData redeemer
    ) =>
    String ->
    Script ->
    datum ->
    redeemer ->
    ScriptContext ->
    SpecificationTree
  validatorFailsWith tag =
    scriptFails tag .*** applyValidator'
  
  -- | Check that an effect succeeds, given a name and argument.
  effectSucceedsWith ::
    ( PlutusTx.ToData datum
    ) =>
    String ->
    Script ->
    datum ->
    ScriptContext ->
    SpecificationTree
  effectSucceedsWith tag eff datum = validatorSucceedsWith tag (coerce eff) datum ()
  
  -- | Check that an effect fails, given a name and argument.
  effectFailsWith ::
    ( PlutusTx.ToData datum
    ) =>
    String ->
    Script ->
    datum ->
    ScriptContext ->
    SpecificationTree
  effectFailsWith tag eff datum = validatorFailsWith tag (coerce eff) datum ()
  
  -- | Test a validator, given the expectation as a boolean value.
  testValidator ::
    forall datum redeemer.
    (PlutusTx.ToData datum, PlutusTx.ToData redeemer) =>
    -- | Is this test case expected to succeed?
    Bool ->
    String ->
    Script ->
    datum ->
    redeemer ->
    ScriptContext ->
    SpecificationTree
  testValidator isValid =
    if isValid
      then validatorSucceedsWith
      else validatorFailsWith
  
  -- | Test a policy, given the expectation as a boolean value.
  testPolicy ::
    forall redeemer.
    (PlutusTx.ToData redeemer) =>
    -- | Is this test case expected to succeed?
    Bool ->
    String ->
    Script ->
    redeemer ->
    ScriptContext ->
    SpecificationTree
  testPolicy isValid =
    if isValid
      then policySucceedsWith
      else policyFailsWith
  
  --------------------------------------------------------------------------------
  
  applyArguments :: Script -> [PLC.Data] -> Script
  applyArguments (Script p) args =
    let termArgs = fmap (PLC.mkConstant ()) args
        applied t = PLC.mkIterApp () t termArgs
     in Script $ over UPLC.progTerm applied p
  