Restructure

`agora-spec` and `agora-spec` is merged to be `agora-specs`;
`agora-testlib` contains what previously was `Spec.Specification`.

agora-testlib/Test/Specification.hs

@@ -0,0 +1,255 @@
+{- |
+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,
+
+  -- * Converters
+  toTestTree,
+) where
+
+import Plutarch.Api.V1 (PMintingPolicy, PValidator)
+import Plutarch.Builtin (pforgetData)
+import Plutarch.Evaluate (evalScript)
+import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
+import Plutus.V1.Ledger.Api (Script, ScriptContext)
+import PlutusTx.IsData qualified as PlutusTx (ToData)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertFailure, testCase)
+
+{- | 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
+    (res, _budget, traces) = evalScript script
+    ts = " Traces: " <> show 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
+
+-- | Check that a policy script succeeds, given a name and arguments.
+policySucceedsWith ::
+  ( PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PMintingPolicy ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+policySucceedsWith tag policy redeemer scriptContext =
+  scriptSucceeds tag $
+    compile
+      ( policy
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that a policy script fails, given a name and arguments.
+policyFailsWith ::
+  ( PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PMintingPolicy ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+policyFailsWith tag policy redeemer scriptContext =
+  scriptFails tag $
+    compile
+      ( policy
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that a validator script succeeds, given a name and arguments.
+validatorSucceedsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  , PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+validatorSucceedsWith tag validator datum redeemer scriptContext =
+  scriptSucceeds tag $
+    compile
+      ( validator
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that a validator script fails, given a name and arguments.
+validatorFailsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  , PLift redeemer
+  , PlutusTx.ToData (PLifted redeemer)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  PLifted redeemer ->
+  ScriptContext ->
+  SpecificationTree
+validatorFailsWith tag validator datum redeemer scriptContext =
+  scriptFails tag $
+    compile
+      ( validator
+          # pforgetData (pconstantData datum)
+          # pforgetData (pconstantData redeemer)
+          # pconstant scriptContext
+      )
+
+-- | Check that an effect succeeds, given a name and argument.
+effectSucceedsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  SpecificationTree
+effectSucceedsWith tag eff datum = validatorSucceedsWith tag eff datum ()
+
+-- | Check that an effect fails, given a name and argument.
+effectFailsWith ::
+  ( PLift datum
+  , PlutusTx.ToData (PLifted datum)
+  ) =>
+  String ->
+  ClosedTerm PValidator ->
+  PLifted datum ->
+  ScriptContext ->
+  SpecificationTree
+effectFailsWith tag eff datum = validatorFailsWith tag eff datum ()