{- | Utilities for golden testing

To regenerate golden tests it is enough to remove @./goldens@ directory and rerun tests
-}
module Plutarch.Test.Golden (
  GoldenTestTree,
  plutarchGolden,
  goldenGroup,
  goldenEval,
  goldenEvalWithConfig,
  goldenEvalFail,
) where

import Data.Aeson (ToJSON (toEncoding, toJSON), encode, object, pairs, (.=))
import Data.Bifunctor (first)
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.ByteString.Short qualified as Short
import Data.Int (Int64)
import Data.Kind (Type)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Encoding
import Plutarch.Evaluate (evalScript)
import Plutarch.Internal.Other (printScript)
import Plutarch.Internal.Term (
  Config (Tracing),
  LogLevel (LogInfo),
  S,
  Script,
  Term,
  TracingMode (DetTracing),
  compile,
 )
import Plutarch.Script (Script (unScript))
import PlutusCore qualified as PLC (DefaultFun, DefaultUni, NamedDeBruijn)
import PlutusLedgerApi.Common (serialiseUPLC)
import PlutusLedgerApi.V1 (ExBudget (ExBudget), ExCPU, ExMemory)
import System.FilePath ((</>))
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.Golden (goldenVsString)
import Test.Tasty.HUnit (assertFailure, testCase)
import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek (CekEvaluationException)

{- | Opaque type representing tree of golden tests

@since 1.0.0
-}
data GoldenTestTree where
  GoldenTestTree :: TestName -> [GoldenTestTree] -> GoldenTestTree
  GoldenTestTreeEval :: forall (a :: S -> Type). Config -> TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
  GoldenTestTreeEvalFail :: forall (a :: S -> Type). TestName -> (forall (s :: S). Term s a) -> GoldenTestTree

{- | Convert tree of golden tests into standard Tasty `TestTree`, capturing results produced
by nested golden tests

@since 1.0.0
-}
plutarchGolden ::
  TestName ->
  {- | Base file name of golden file path.

  e.g. @"foo"@ will result in goldens:

  * @.//goldens//foo.bench.golden@ - With execution units and size

  * @.//goldens//foo.uplc.eval.golden@ - With AST after evaluation

  * @.//goldens//foo.uplc.golden@ - With AST before evaluation
  -}
  FilePath ->
  [GoldenTestTree] ->
  TestTree
plutarchGolden :: TestName -> TestName -> [GoldenTestTree] -> TestTree
plutarchGolden TestName
topName TestName
goldenPath [GoldenTestTree]
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
topName [TestTree]
testsWithGoldens
  where
    -- Implementation note: Because we want to collect all Benchmarks created by nested tests
    -- we cannot use plain TestTree for these (without hacks like passing some MVars around)
    -- so we have out own GoldenTestTree that when being converted to TestTree will execute
    -- all terms and collect the results. Additionally this ensures that goldens remain the same
    -- when using `--pattern` to filter tests because even though assertions won't run the
    -- scripts will still be evaluated

    ([TestTree]
tests', [[(TestName, Benchmark)]]
benchmarks') = [(TestTree, [(TestName, Benchmark)])]
-> ([TestTree], [[(TestName, Benchmark)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TestTree, [(TestName, Benchmark)])]
 -> ([TestTree], [[(TestName, Benchmark)]]))
-> [(TestTree, [(TestName, Benchmark)])]
-> ([TestTree], [[(TestName, Benchmark)]])
forall a b. (a -> b) -> a -> b
$ (GoldenTestTree -> (TestTree, [(TestName, Benchmark)]))
-> [GoldenTestTree] -> [(TestTree, [(TestName, Benchmark)])]
forall a b. (a -> b) -> [a] -> [b]
map GoldenTestTree -> (TestTree, [(TestName, Benchmark)])
mkTest [GoldenTestTree]
tests
    benchmarks :: [(TestName, Benchmark)]
benchmarks = [[(TestName, Benchmark)]] -> [(TestName, Benchmark)]
forall a. Monoid a => [a] -> a
mconcat [[(TestName, Benchmark)]]
benchmarks'
    goldenTests :: [TestTree]
goldenTests =
      [ TestName -> [TestTree] -> TestTree
testGroup
          TestName
"Golden Files"
          [ TestName -> TestName -> IO ByteString -> TestTree
goldenVsString
              (TestName
goldenPath TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
".bench.golden")
              (TestName
"goldens" TestName -> TestName -> TestName
</> TestName
goldenPath TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
".bench.golden")
              (ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [(TestName, Benchmark)] -> ByteString
mkBenchGoldenValue [(TestName, Benchmark)]
benchmarks)
          , TestName -> TestName -> IO ByteString -> TestTree
goldenVsString
              (TestName
goldenPath TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
".uplc.golden")
              (TestName
"goldens" TestName -> TestName -> TestName
</> TestName
goldenPath TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
".uplc.golden")
              (ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [(TestName, Benchmark)] -> ByteString
mkUplcGoldenValue [(TestName, Benchmark)]
benchmarks)
          , TestName -> TestName -> IO ByteString -> TestTree
goldenVsString
              (TestName
goldenPath TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
".uplc.eval.golden")
              (TestName
"goldens" TestName -> TestName -> TestName
</> TestName
goldenPath TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
".uplc.eval.golden")
              (ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ [(TestName, Benchmark)] -> ByteString
mkUplcEvalGoldenValue [(TestName, Benchmark)]
benchmarks)
          ]
      ]
    testsWithGoldens :: [TestTree]
testsWithGoldens = [TestTree]
goldenTests [TestTree] -> [TestTree] -> [TestTree]
forall a. Semigroup a => a -> a -> a
<> [TestTree]
tests'

{- | Like `Test.Tasty.testGroup` but for golden tests

Goldens in the group will be prefixed by the group name

@since 1.0.0
-}
goldenGroup :: TestName -> [GoldenTestTree] -> GoldenTestTree
goldenGroup :: TestName -> [GoldenTestTree] -> GoldenTestTree
goldenGroup = TestName -> [GoldenTestTree] -> GoldenTestTree
GoldenTestTree

{- | Like `Plutarch.Test.Unit.testEval` but will append to goldens created by enclosing `plutarchGolden`

@since 1.0.0
-}
goldenEval :: forall (a :: S -> Type). TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
goldenEval :: forall (a :: S -> Type).
TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
goldenEval = Config -> TestName -> (forall {s :: S}. Term s a) -> GoldenTestTree
forall (a :: S -> Type).
Config -> TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
GoldenTestTreeEval Config
testConfig

{- | Like `Plutarch.Test.Unit.testEvalFail` but will append to goldens created by enclosing `plutarchGolden`

@since 1.0.0
-}
goldenEvalFail :: forall (a :: S -> Type). TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
goldenEvalFail :: forall (a :: S -> Type).
TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
goldenEvalFail = TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
forall (a :: S -> Type).
TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
GoldenTestTreeEvalFail

{- | As 'goldenEval', but allows setting the 'Config' to use for compiling the
script.

@since 1.0.3
-}
goldenEvalWithConfig :: forall (a :: S -> Type). Config -> TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
goldenEvalWithConfig :: forall (a :: S -> Type).
Config -> TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
goldenEvalWithConfig = Config -> TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
forall (a :: S -> Type).
Config -> TestName -> (forall (s :: S). Term s a) -> GoldenTestTree
GoldenTestTreeEval

-- Internals

mkFailed :: TestName -> (e -> String) -> Either e a -> Either (TestTree, [(TestName, Benchmark)]) a
mkFailed :: forall e a.
TestName
-> (e -> TestName)
-> Either e a
-> Either (TestTree, [(TestName, Benchmark)]) a
mkFailed TestName
name e -> TestName
showErr = (e -> Either (TestTree, [(TestName, Benchmark)]) a)
-> (a -> Either (TestTree, [(TestName, Benchmark)]) a)
-> Either e a
-> Either (TestTree, [(TestName, Benchmark)]) a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((TestTree, [(TestName, Benchmark)])
-> Either (TestTree, [(TestName, Benchmark)]) a
forall a b. a -> Either a b
Left ((TestTree, [(TestName, Benchmark)])
 -> Either (TestTree, [(TestName, Benchmark)]) a)
-> (e -> (TestTree, [(TestName, Benchmark)]))
-> e
-> Either (TestTree, [(TestName, Benchmark)]) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[]) (TestTree -> (TestTree, [(TestName, Benchmark)]))
-> (e -> TestTree) -> e -> (TestTree, [(TestName, Benchmark)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Assertion -> TestTree
testCase TestName
name (Assertion -> TestTree) -> (e -> Assertion) -> e -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Assertion
forall a. HasCallStack => TestName -> IO a
assertFailure (TestName -> Assertion) -> (e -> TestName) -> e -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> TestName
showErr) a -> Either (TestTree, [(TestName, Benchmark)]) a
forall a b. b -> Either a b
Right

mkTest :: GoldenTestTree -> (TestTree, [(TestName, Benchmark)])
mkTest :: GoldenTestTree -> (TestTree, [(TestName, Benchmark)])
mkTest (GoldenTestTree TestName
name [GoldenTestTree]
tests) = (TestName -> [TestTree] -> TestTree
testGroup TestName
name [TestTree]
tests', [(TestName, Benchmark)]
benchmarks)
  where
    ([TestTree]
tests', [[(TestName, Benchmark)]]
benchmarks') = [(TestTree, [(TestName, Benchmark)])]
-> ([TestTree], [[(TestName, Benchmark)]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TestTree, [(TestName, Benchmark)])]
 -> ([TestTree], [[(TestName, Benchmark)]]))
-> [(TestTree, [(TestName, Benchmark)])]
-> ([TestTree], [[(TestName, Benchmark)]])
forall a b. (a -> b) -> a -> b
$ (GoldenTestTree -> (TestTree, [(TestName, Benchmark)]))
-> [GoldenTestTree] -> [(TestTree, [(TestName, Benchmark)])]
forall a b. (a -> b) -> [a] -> [b]
map GoldenTestTree -> (TestTree, [(TestName, Benchmark)])
mkTest [GoldenTestTree]
tests
    benchmarks :: [(TestName, Benchmark)]
benchmarks = ([(TestName, Benchmark)] -> [(TestName, Benchmark)])
-> [[(TestName, Benchmark)]] -> [(TestName, Benchmark)]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((TestName, Benchmark) -> (TestName, Benchmark))
-> [(TestName, Benchmark)] -> [(TestName, Benchmark)]
forall a b. (a -> b) -> [a] -> [b]
map ((TestName -> TestName)
-> (TestName, Benchmark) -> (TestName, Benchmark)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((TestName
name TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
".") <>))) [[(TestName, Benchmark)]]
benchmarks'
mkTest (GoldenTestTreeEval Config
config TestName
name forall (s :: S). Term s a
term) = ((TestTree, [(TestName, Benchmark)])
 -> (TestTree, [(TestName, Benchmark)]))
-> ((TestTree, [(TestName, Benchmark)])
    -> (TestTree, [(TestName, Benchmark)]))
-> Either
     (TestTree, [(TestName, Benchmark)])
     (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a. a -> a
id (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a. a -> a
id (Either
   (TestTree, [(TestName, Benchmark)])
   (TestTree, [(TestName, Benchmark)])
 -> (TestTree, [(TestName, Benchmark)]))
-> Either
     (TestTree, [(TestName, Benchmark)])
     (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a b. (a -> b) -> a -> b
$ do
  Benchmark
benchmark <- TestName
-> (Text -> TestName)
-> Either Text Benchmark
-> Either (TestTree, [(TestName, Benchmark)]) Benchmark
forall e a.
TestName
-> (e -> TestName)
-> Either e a
-> Either (TestTree, [(TestName, Benchmark)]) a
mkFailed TestName
name Text -> TestName
Text.unpack (Either Text Benchmark
 -> Either (TestTree, [(TestName, Benchmark)]) Benchmark)
-> Either Text Benchmark
-> Either (TestTree, [(TestName, Benchmark)]) Benchmark
forall a b. (a -> b) -> a -> b
$ Config -> (forall (s :: S). Term s a) -> Either Text Benchmark
forall (a :: S -> Type).
Config -> (forall (s :: S). Term s a) -> Either Text Benchmark
benchmarkTerm Config
config Term s a
forall (s :: S). Term s a
term
  Script
_ <- TestName
-> (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
    -> TestName)
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
-> Either (TestTree, [(TestName, Benchmark)]) Script
forall e a.
TestName
-> (e -> TestName)
-> Either e a
-> Either (TestTree, [(TestName, Benchmark)]) a
mkFailed TestName
name CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> TestName
forall a. Show a => a -> TestName
show (Either
   (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
 -> Either (TestTree, [(TestName, Benchmark)]) Script)
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
-> Either (TestTree, [(TestName, Benchmark)]) Script
forall a b. (a -> b) -> a -> b
$ Benchmark
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
result Benchmark
benchmark
  (TestTree, [(TestName, Benchmark)])
-> Either
     (TestTree, [(TestName, Benchmark)])
     (TestTree, [(TestName, Benchmark)])
forall a. a -> Either (TestTree, [(TestName, Benchmark)]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TestName -> Assertion -> TestTree
testCase TestName
name (() -> Assertion
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()), [(TestName
name, Benchmark
benchmark)])
mkTest (GoldenTestTreeEvalFail TestName
name forall (s :: S). Term s a
term) = ((TestTree, [(TestName, Benchmark)])
 -> (TestTree, [(TestName, Benchmark)]))
-> ((TestTree, [(TestName, Benchmark)])
    -> (TestTree, [(TestName, Benchmark)]))
-> Either
     (TestTree, [(TestName, Benchmark)])
     (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a. a -> a
id (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a. a -> a
id (Either
   (TestTree, [(TestName, Benchmark)])
   (TestTree, [(TestName, Benchmark)])
 -> (TestTree, [(TestName, Benchmark)]))
-> Either
     (TestTree, [(TestName, Benchmark)])
     (TestTree, [(TestName, Benchmark)])
-> (TestTree, [(TestName, Benchmark)])
forall a b. (a -> b) -> a -> b
$ do
  Benchmark
benchmark <- TestName
-> (Text -> TestName)
-> Either Text Benchmark
-> Either (TestTree, [(TestName, Benchmark)]) Benchmark
forall e a.
TestName
-> (e -> TestName)
-> Either e a
-> Either (TestTree, [(TestName, Benchmark)]) a
mkFailed TestName
name Text -> TestName
Text.unpack (Either Text Benchmark
 -> Either (TestTree, [(TestName, Benchmark)]) Benchmark)
-> Either Text Benchmark
-> Either (TestTree, [(TestName, Benchmark)]) Benchmark
forall a b. (a -> b) -> a -> b
$ Config -> (forall (s :: S). Term s a) -> Either Text Benchmark
forall (a :: S -> Type).
Config -> (forall (s :: S). Term s a) -> Either Text Benchmark
benchmarkTerm Config
testConfig Term s a
forall (s :: S). Term s a
term
  (TestTree, [(TestName, Benchmark)])
-> Either
     (TestTree, [(TestName, Benchmark)])
     (TestTree, [(TestName, Benchmark)])
forall a. a -> Either (TestTree, [(TestName, Benchmark)]) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((TestTree, [(TestName, Benchmark)])
 -> Either
      (TestTree, [(TestName, Benchmark)])
      (TestTree, [(TestName, Benchmark)]))
-> (TestTree, [(TestName, Benchmark)])
-> Either
     (TestTree, [(TestName, Benchmark)])
     (TestTree, [(TestName, Benchmark)])
forall a b. (a -> b) -> a -> b
$ case Benchmark
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
result Benchmark
benchmark of
    Left CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
_ -> (TestName -> Assertion -> TestTree
testCase TestName
name (() -> Assertion
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()), [(TestName
name, Benchmark
benchmark)])
    Right Script
_ ->
      ( TestName -> Assertion -> TestTree
testCase TestName
name (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName -> Assertion
forall a. HasCallStack => TestName -> IO a
assertFailure TestName
"Script did not terminate with error as expected"
      , [(TestName
name, Benchmark
benchmark)]
      )

benchmarkTerm :: forall (a :: S -> Type). Config -> (forall (s :: S). Term s a) -> Either Text Benchmark
benchmarkTerm :: forall (a :: S -> Type).
Config -> (forall (s :: S). Term s a) -> Either Text Benchmark
benchmarkTerm Config
conf forall (s :: S). Term s a
term = do
  Script
compiled <- Config -> (forall (s :: S). Term s a) -> Either Text Script
forall (a :: S -> Type).
Config -> (forall (s :: S). Term s a) -> Either Text Script
compile Config
conf Term s a
forall (s :: S). Term s a
term
  let (Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
res, ExBudget ExCPU
cpu ExMemory
mem, [Text]
_traces) = Script
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      Script,
    ExBudget, [Text])
evalScript Script
compiled
  Benchmark -> Either Text Benchmark
forall a. a -> Either Text a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Benchmark -> Either Text Benchmark)
-> Benchmark -> Either Text Benchmark
forall a b. (a -> b) -> a -> b
$ ExCPU
-> ExMemory
-> Int64
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
-> Script
-> Benchmark
Benchmark ExCPU
cpu ExMemory
mem (Script -> Int64
scriptSize Script
compiled) Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
res Script
compiled

testConfig :: Config
testConfig :: Config
testConfig = LogLevel -> TracingMode -> Config
Tracing LogLevel
LogInfo TracingMode
DetTracing

scriptSize :: Script -> Int64
scriptSize :: Script -> Int64
scriptSize = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> (Script -> Int) -> Script -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Int
Short.length (ShortByteString -> Int)
-> (Script -> ShortByteString) -> Script -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun () -> ShortByteString
serialiseUPLC (Program DeBruijn DefaultUni DefaultFun () -> ShortByteString)
-> (Script -> Program DeBruijn DefaultUni DefaultFun ())
-> Script
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> Program DeBruijn DefaultUni DefaultFun ()
unScript

data Benchmark = Benchmark
  { Benchmark -> ExCPU
exBudgetCPU :: ExCPU
  -- ^ CPU budget used by the script.
  , Benchmark -> ExMemory
exBudgetMemory :: ExMemory
  -- ^ Memory budget used by the script.
  , Benchmark -> Int64
scriptSizeBytes :: Int64
  -- ^ Size of Plutus script in bytes
  , Benchmark
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
result :: Either (Cek.CekEvaluationException PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun) Script
  , Benchmark -> Script
unevaluated :: Script
  }
  deriving stock (Int -> Benchmark -> TestName -> TestName
[Benchmark] -> TestName -> TestName
Benchmark -> TestName
(Int -> Benchmark -> TestName -> TestName)
-> (Benchmark -> TestName)
-> ([Benchmark] -> TestName -> TestName)
-> Show Benchmark
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> Benchmark -> TestName -> TestName
showsPrec :: Int -> Benchmark -> TestName -> TestName
$cshow :: Benchmark -> TestName
show :: Benchmark -> TestName
$cshowList :: [Benchmark] -> TestName -> TestName
showList :: [Benchmark] -> TestName -> TestName
Show)

newtype PerfBenchmark = PerfBenchmark Benchmark

instance ToJSON PerfBenchmark where
  toJSON :: PerfBenchmark -> Value
toJSON (PerfBenchmark (Benchmark ExCPU
cpu ExMemory
mem Int64
size Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
_ Script
_)) =
    [Pair] -> Value
object
      [ Key
"exBudgetCPU" Key -> ExCPU -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ExCPU
cpu
      , Key
"exBudgetMemory" Key -> ExMemory -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ExMemory
mem
      , Key
"scriptSizeBytes" Key -> Int64 -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int64
size
      ]
  toEncoding :: PerfBenchmark -> Encoding
toEncoding (PerfBenchmark (Benchmark ExCPU
cpu ExMemory
mem Int64
size Either
  (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
_ Script
_)) =
    Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
      [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat
        [ Key
"exBudgetCPU" Key -> ExCPU -> Item [Series]
forall v. ToJSON v => Key -> v -> Item [Series]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ExCPU
cpu
        , Key
"exBudgetMemory" Key -> ExMemory -> Item [Series]
forall v. ToJSON v => Key -> v -> Item [Series]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ExMemory
mem
        , Key
"scriptSizeBytes" Key -> Int64 -> Item [Series]
forall v. ToJSON v => Key -> v -> Item [Series]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int64
size
        ]

mkBenchmarkValue :: (Benchmark -> ByteString) -> [(TestName, Benchmark)] -> ByteString
mkBenchmarkValue :: (Benchmark -> ByteString) -> [(TestName, Benchmark)] -> ByteString
mkBenchmarkValue Benchmark -> ByteString
go =
  [ByteString] -> ByteString
LBS.unlines
    ([ByteString] -> ByteString)
-> ([(TestName, Benchmark)] -> [ByteString])
-> [(TestName, Benchmark)]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TestName, Benchmark) -> ByteString)
-> [(TestName, Benchmark)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map
      ( \(TestName
testName, Benchmark
benchmark) ->
          [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
            [ TestName -> ByteString
encodeStringUtf8 TestName
testName
            , Item [ByteString]
ByteString
" "
            , Benchmark -> ByteString
go Benchmark
benchmark
            ]
      )

mkBenchGoldenValue :: [(TestName, Benchmark)] -> ByteString
mkBenchGoldenValue :: [(TestName, Benchmark)] -> ByteString
mkBenchGoldenValue = (Benchmark -> ByteString) -> [(TestName, Benchmark)] -> ByteString
mkBenchmarkValue (PerfBenchmark -> ByteString
forall a. ToJSON a => a -> ByteString
encode (PerfBenchmark -> ByteString)
-> (Benchmark -> PerfBenchmark) -> Benchmark -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark -> PerfBenchmark
PerfBenchmark)

mkUplcEvalGoldenValue :: [(TestName, Benchmark)] -> ByteString
mkUplcEvalGoldenValue :: [(TestName, Benchmark)] -> ByteString
mkUplcEvalGoldenValue = (Benchmark -> ByteString) -> [(TestName, Benchmark)] -> ByteString
mkBenchmarkValue ((CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
 -> ByteString)
-> (Script -> ByteString)
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString
-> CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> ByteString
forall a b. a -> b -> a
const ByteString
"program 1.0.0 error") (TestName -> ByteString
encodeStringUtf8 (TestName -> ByteString)
-> (Script -> TestName) -> Script -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> TestName
printScript) (Either
   (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
 -> ByteString)
-> (Benchmark
    -> Either
         (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
         Script)
-> Benchmark
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark
-> Either
     (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) Script
result)

mkUplcGoldenValue :: [(TestName, Benchmark)] -> ByteString
mkUplcGoldenValue :: [(TestName, Benchmark)] -> ByteString
mkUplcGoldenValue = (Benchmark -> ByteString) -> [(TestName, Benchmark)] -> ByteString
mkBenchmarkValue (TestName -> ByteString
encodeStringUtf8 (TestName -> ByteString)
-> (Benchmark -> TestName) -> Benchmark -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script -> TestName
printScript (Script -> TestName)
-> (Benchmark -> Script) -> Benchmark -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark -> Script
unevaluated)

encodeStringUtf8 :: String -> ByteString
encodeStringUtf8 :: TestName -> ByteString
encodeStringUtf8 = ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (TestName -> ByteString) -> TestName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Encoding.encodeUtf8 (Text -> ByteString)
-> (TestName -> Text) -> TestName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Text
Text.pack