{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

module PlutusTx.Test.Golden (
  -- * TH CodGen
  goldenCodeGen,

  -- * Compilation testing
  goldenPir,
  goldenPirReadable,
  goldenPirReadableU,
  goldenPirBy,
  goldenTPlc,
  goldenUPlc,
  goldenUPlcReadable,
  goldenBudget,
  goldenSize,

  -- * Golden evaluation testing
  goldenEvalCek,
  goldenEvalCekCatch,
  goldenEvalCekCatchBudget,
  goldenEvalCekLog,

  -- * Combined testing
  goldenBundle,
  goldenBundle',

  -- * Pretty-printing
  prettyBudget,
  prettyCodeSize,
) where

import Prelude

import Control.Lens (Field1 (_1), view)
import Control.Monad.Except (runExceptT)
import Data.List qualified as List
import Data.SatInt (fromSatInt)
import Data.Text (Text)
import Flat (Flat)
import Language.Haskell.TH qualified as TH
import PlutusCore qualified as PLC
import PlutusCore.Evaluation.Machine.ExBudget qualified as PLC
import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..))
import PlutusCore.Pretty (Doc, Pretty (pretty), PrettyBy (prettyBy), PrettyConfigClassic,
                          PrettyConfigName, PrettyUni, Render (render), prettyClassicSimple,
                          prettyPlcClassicSimple, prettyReadable, prettyReadableSimple)
import PlutusCore.Test (TestNested, ToUPlc (..), goldenSize, goldenTPlc, goldenUPlc,
                        goldenUPlcReadable, nestedGoldenVsDoc, nestedGoldenVsDocM, ppCatch, rethrow,
                        runUPlcBudget)
import PlutusIR.Core.Type (progTerm)
import PlutusIR.Test ()
import PlutusTx.Code (CompiledCode, CompiledCodeIn (..), countAstNodes, getPir, getPirNoAnn)
import PlutusTx.Test.Orphans ()
import PlutusTx.Test.Run.Uplc (runPlcCek, runPlcCekBudget, runPlcCekTrace)
import PlutusTx.Test.Util.Compiled (countFlatBytes)
import Prettyprinter (fill, vsep, (<+>))
import Test.Tasty (TestName)
import Test.Tasty.Extras ()
import Text.Printf (printf)
import UntypedPlutusCore qualified as UPLC

-- Value assertion tests
goldenCodeGen :: (TH.Ppr a) => TestName -> TH.Q a -> TH.ExpQ
goldenCodeGen :: forall a. Ppr a => TestName -> Q a -> ExpQ
goldenCodeGen TestName
name Q a
code = do
  a
c <- Q a
code
  [|nestedGoldenVsDoc name ".th" $(TestName -> ExpQ
forall (m :: * -> *). Quote m => TestName -> m Exp
TH.stringE (TestName -> ExpQ) -> TestName -> ExpQ
forall a b. (a -> b) -> a -> b
$ a -> TestName
forall a. Ppr a => a -> TestName
TH.pprint a
c)|]

goldenBudget :: TestName -> CompiledCode a -> TestNested
goldenBudget :: forall a. TestName -> CompiledCode a -> TestNested
goldenBudget TestName
name CompiledCode a
compiledCode = do
  TestName -> TestName -> IO (Doc Any) -> TestNested
forall ann. TestName -> TestName -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM TestName
name TestName
".budget" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT SomeException IO Text -> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch (ExceptT SomeException IO Text -> IO (Doc Any))
-> ExceptT SomeException IO Text -> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ do
    ExBudget
budget <- [CompiledCode a] -> ExceptT SomeException IO ExBudget
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO ExBudget
runUPlcBudget [CompiledCode a
compiledCode]
    Text -> ExceptT SomeException IO Text
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExceptT SomeException IO Text)
-> Text -> ExceptT SomeException IO Text
forall a b. (a -> b) -> a -> b
$
      forall str ann. Render str => Doc ann -> str
render @Text (Doc Any -> Text) -> Doc Any -> Text
forall a b. (a -> b) -> a -> b
$
        [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vsep
          [ ExBudget -> Doc Any
forall ann. ExBudget -> Doc ann
prettyBudget ExBudget
budget
          , CompiledCode a -> Doc Any
forall a ann. CompiledCodeIn DefaultUni DefaultFun a -> Doc ann
prettyCodeSize CompiledCode a
compiledCode
          ]

goldenBundle
  :: TestName
  -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a
  -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun b
  -> TestNested
goldenBundle :: forall a b.
TestName
-> CompiledCodeIn DefaultUni DefaultFun a
-> CompiledCodeIn DefaultUni DefaultFun b
-> TestNested
goldenBundle TestName
name CompiledCodeIn DefaultUni DefaultFun a
x CompiledCodeIn DefaultUni DefaultFun b
y = do
  TestName -> CompiledCodeIn DefaultUni DefaultFun a -> TestNested
forall (uni :: * -> *) fun a.
(PrettyUni uni, Pretty fun, Everywhere uni Flat, Flat fun) =>
TestName -> CompiledCodeIn uni fun a -> TestNested
goldenPirReadable TestName
name CompiledCodeIn DefaultUni DefaultFun a
x
  TestName -> CompiledCodeIn DefaultUni DefaultFun a -> TestNested
forall a.
ToUPlc a DefaultUni DefaultFun =>
TestName -> a -> TestNested
goldenUPlcReadable TestName
name CompiledCodeIn DefaultUni DefaultFun a
x
  TestName -> CompiledCodeIn DefaultUni DefaultFun b -> TestNested
forall a. TestName -> CompiledCode a -> TestNested
goldenEvalCekCatchBudget TestName
name CompiledCodeIn DefaultUni DefaultFun b
y

goldenBundle'
  :: TestName
  -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a
  -> TestNested
goldenBundle' :: forall a. TestName -> CompiledCode a -> TestNested
goldenBundle' TestName
name CompiledCodeIn DefaultUni DefaultFun a
x = TestName
-> CompiledCodeIn DefaultUni DefaultFun a
-> CompiledCodeIn DefaultUni DefaultFun a
-> TestNested
forall a b.
TestName
-> CompiledCodeIn DefaultUni DefaultFun a
-> CompiledCodeIn DefaultUni DefaultFun b
-> TestNested
goldenBundle TestName
name CompiledCodeIn DefaultUni DefaultFun a
x CompiledCodeIn DefaultUni DefaultFun a
x

-- | Does not print uniques.
goldenPir
  :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun)
  => TestName
  -> CompiledCodeIn uni fun a
  -> TestNested
goldenPir :: forall (uni :: * -> *) fun a.
(PrettyUni uni, Pretty fun, Everywhere uni Flat, Flat fun) =>
TestName -> CompiledCodeIn uni fun a -> TestNested
goldenPir TestName
name CompiledCodeIn uni fun a
value =
  TestName -> TestName -> Doc Any -> TestNested
forall ann. TestName -> TestName -> Doc ann -> TestNested
nestedGoldenVsDoc TestName
name TestName
".pir"
    (Doc Any -> TestNested)
-> (Maybe (Program TyName Name uni fun ()) -> Doc Any)
-> Maybe (Program TyName Name uni fun ())
-> TestNested
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any
-> (Program TyName Name uni fun () -> Doc Any)
-> Maybe (Program TyName Name uni fun ())
-> Doc Any
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      Doc Any
"PIR not found in CompiledCode"
      (Term TyName Name uni fun () -> Doc Any
forall a ann. PrettyClassic a => a -> Doc ann
prettyClassicSimple (Term TyName Name uni fun () -> Doc Any)
-> (Program TyName Name uni fun () -> Term TyName Name uni fun ())
-> Program TyName Name uni fun ()
-> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Term TyName Name uni fun ())
  (Program TyName Name uni fun ())
  (Term TyName Name uni fun ())
-> Program TyName Name uni fun () -> Term TyName Name uni fun ()
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Term TyName Name uni fun ())
  (Program TyName Name uni fun ())
  (Term TyName Name uni fun ())
forall tyname1 name1 (uni1 :: * -> *) fun1 ann tyname2 name2
       (uni2 :: * -> *) fun2 (f :: * -> *).
Functor f =>
(Term tyname1 name1 uni1 fun1 ann
 -> f (Term tyname2 name2 uni2 fun2 ann))
-> Program tyname1 name1 uni1 fun1 ann
-> f (Program tyname2 name2 uni2 fun2 ann)
progTerm)
    (Maybe (Program TyName Name uni fun ()) -> TestNested)
-> Maybe (Program TyName Name uni fun ()) -> TestNested
forall a b. (a -> b) -> a -> b
$ CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
getPirNoAnn CompiledCodeIn uni fun a
value

-- | Does not print uniques.
goldenPirReadable
  :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun)
  => TestName
  -> CompiledCodeIn uni fun a
  -> TestNested
goldenPirReadable :: forall (uni :: * -> *) fun a.
(PrettyUni uni, Pretty fun, Everywhere uni Flat, Flat fun) =>
TestName -> CompiledCodeIn uni fun a -> TestNested
goldenPirReadable TestName
name CompiledCodeIn uni fun a
value =
  TestName -> TestName -> Doc Any -> TestNested
forall ann. TestName -> TestName -> Doc ann -> TestNested
nestedGoldenVsDoc TestName
name TestName
".pir"
    (Doc Any -> TestNested)
-> (Maybe (Program TyName Name uni fun ()) -> Doc Any)
-> Maybe (Program TyName Name uni fun ())
-> TestNested
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any
-> (Program TyName Name uni fun () -> Doc Any)
-> Maybe (Program TyName Name uni fun ())
-> Doc Any
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      Doc Any
"PIR not found in CompiledCode"
      (Term TyName Name uni fun () -> Doc Any
forall a ann. PrettyReadable a => a -> Doc ann
prettyReadableSimple (Term TyName Name uni fun () -> Doc Any)
-> (Program TyName Name uni fun () -> Term TyName Name uni fun ())
-> Program TyName Name uni fun ()
-> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Term TyName Name uni fun ())
  (Program TyName Name uni fun ())
  (Term TyName Name uni fun ())
-> Program TyName Name uni fun () -> Term TyName Name uni fun ()
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Term TyName Name uni fun ())
  (Program TyName Name uni fun ())
  (Term TyName Name uni fun ())
forall tyname1 name1 (uni1 :: * -> *) fun1 ann tyname2 name2
       (uni2 :: * -> *) fun2 (f :: * -> *).
Functor f =>
(Term tyname1 name1 uni1 fun1 ann
 -> f (Term tyname2 name2 uni2 fun2 ann))
-> Program tyname1 name1 uni1 fun1 ann
-> f (Program tyname2 name2 uni2 fun2 ann)
progTerm)
    (Maybe (Program TyName Name uni fun ()) -> TestNested)
-> Maybe (Program TyName Name uni fun ()) -> TestNested
forall a b. (a -> b) -> a -> b
$ CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
getPirNoAnn CompiledCodeIn uni fun a
value

{-| Prints uniques. This should be used sparingly: a simple change to a script or a
compiler pass may change all uniques, making it difficult to see the actual
change if all uniques are printed. It is nonetheless useful sometimes.
-}
goldenPirReadableU
  :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun)
  => TestName
  -> CompiledCodeIn uni fun a
  -> TestNested
goldenPirReadableU :: forall (uni :: * -> *) fun a.
(PrettyUni uni, Pretty fun, Everywhere uni Flat, Flat fun) =>
TestName -> CompiledCodeIn uni fun a -> TestNested
goldenPirReadableU TestName
name CompiledCodeIn uni fun a
value =
  TestName -> TestName -> Doc Any -> TestNested
forall ann. TestName -> TestName -> Doc ann -> TestNested
nestedGoldenVsDoc TestName
name TestName
".pir"
    (Doc Any -> TestNested)
-> (Maybe (Program TyName Name uni fun ()) -> Doc Any)
-> Maybe (Program TyName Name uni fun ())
-> TestNested
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any
-> (Program TyName Name uni fun () -> Doc Any)
-> Maybe (Program TyName Name uni fun ())
-> Doc Any
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Any
"PIR not found in CompiledCode" (Term TyName Name uni fun () -> Doc Any
forall a ann. PrettyReadable a => a -> Doc ann
prettyReadable (Term TyName Name uni fun () -> Doc Any)
-> (Program TyName Name uni fun () -> Term TyName Name uni fun ())
-> Program TyName Name uni fun ()
-> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Term TyName Name uni fun ())
  (Program TyName Name uni fun ())
  (Term TyName Name uni fun ())
-> Program TyName Name uni fun () -> Term TyName Name uni fun ()
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Term TyName Name uni fun ())
  (Program TyName Name uni fun ())
  (Term TyName Name uni fun ())
forall tyname1 name1 (uni1 :: * -> *) fun1 ann tyname2 name2
       (uni2 :: * -> *) fun2 (f :: * -> *).
Functor f =>
(Term tyname1 name1 uni1 fun1 ann
 -> f (Term tyname2 name2 uni2 fun2 ann))
-> Program tyname1 name1 uni1 fun1 ann
-> f (Program tyname2 name2 uni2 fun2 ann)
progTerm)
    (Maybe (Program TyName Name uni fun ()) -> TestNested)
-> Maybe (Program TyName Name uni fun ()) -> TestNested
forall a b. (a -> b) -> a -> b
$ CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
getPirNoAnn CompiledCodeIn uni fun a
value

goldenPirBy
  :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun)
  => PrettyConfigClassic PrettyConfigName
  -> TestName
  -> CompiledCodeIn uni fun a
  -> TestNested
goldenPirBy :: forall (uni :: * -> *) fun a.
(PrettyUni uni, Pretty fun, Everywhere uni Flat, Flat fun) =>
PrettyConfigClassic PrettyConfigName
-> TestName -> CompiledCodeIn uni fun a -> TestNested
goldenPirBy PrettyConfigClassic PrettyConfigName
config TestName
name CompiledCodeIn uni fun a
value =
  TestName -> TestName -> Doc Any -> TestNested
forall ann. TestName -> TestName -> Doc ann -> TestNested
nestedGoldenVsDoc TestName
name TestName
".pir" (Doc Any -> TestNested) -> Doc Any -> TestNested
forall a b. (a -> b) -> a -> b
$ PrettyConfigClassic PrettyConfigName
-> Maybe (Program TyName Name uni fun SrcSpans) -> Doc Any
forall ann.
PrettyConfigClassic PrettyConfigName
-> Maybe (Program TyName Name uni fun SrcSpans) -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigClassic PrettyConfigName
config (Maybe (Program TyName Name uni fun SrcSpans) -> Doc Any)
-> Maybe (Program TyName Name uni fun SrcSpans) -> Doc Any
forall a b. (a -> b) -> a -> b
$ CompiledCodeIn uni fun a
-> Maybe (Program TyName Name uni fun SrcSpans)
forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a
-> Maybe (Program TyName Name uni fun SrcSpans)
getPir CompiledCodeIn uni fun a
value

goldenEvalCek
  :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun)
  => TestName
  -> a
  -> TestNested
goldenEvalCek :: forall a.
ToUPlc a DefaultUni DefaultFun =>
TestName -> a -> TestNested
goldenEvalCek TestName
name a
value =
  TestName -> TestName -> IO (Doc Any) -> TestNested
forall ann. TestName -> TestName -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM TestName
name TestName
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$
    Term Name DefaultUni DefaultFun () -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcClassicSimple (Term Name DefaultUni DefaultFun () -> Doc Any)
-> IO (Term Name DefaultUni DefaultFun ()) -> IO (Doc Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
-> IO (Term Name DefaultUni DefaultFun ())
forall a. ExceptT SomeException IO a -> IO a
rethrow (a -> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
forall a.
ToUPlc a DefaultUni DefaultFun =>
a -> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
runPlcCek a
value)

goldenEvalCekCatch
  :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun)
  => TestName -> a -> TestNested
goldenEvalCekCatch :: forall a.
ToUPlc a DefaultUni DefaultFun =>
TestName -> a -> TestNested
goldenEvalCekCatch TestName
name a
value =
  TestName -> TestName -> IO (Doc Any) -> TestNested
forall ann. TestName -> TestName -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM TestName
name TestName
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$
    (SomeException -> Doc Any)
-> (Term Name DefaultUni DefaultFun () -> Doc Any)
-> Either SomeException (Term Name DefaultUni DefaultFun ())
-> Doc Any
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TestName -> Doc Any
forall ann. TestName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (TestName -> Doc Any)
-> (SomeException -> TestName) -> SomeException -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> TestName
forall a. Show a => a -> TestName
show) Term Name DefaultUni DefaultFun () -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcClassicSimple
      (Either SomeException (Term Name DefaultUni DefaultFun ())
 -> Doc Any)
-> IO (Either SomeException (Term Name DefaultUni DefaultFun ()))
-> IO (Doc Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
-> IO (Either SomeException (Term Name DefaultUni DefaultFun ()))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (a -> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
forall a.
ToUPlc a DefaultUni DefaultFun =>
a -> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
runPlcCek a
value)

goldenEvalCekCatchBudget :: TestName -> CompiledCode a -> TestNested
goldenEvalCekCatchBudget :: forall a. TestName -> CompiledCode a -> TestNested
goldenEvalCekCatchBudget TestName
name CompiledCode a
compiledCode =
  TestName -> TestName -> IO (Doc Any) -> TestNested
forall ann. TestName -> TestName -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM TestName
name TestName
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT SomeException IO Text -> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch (ExceptT SomeException IO Text -> IO (Doc Any))
-> ExceptT SomeException IO Text -> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ do
    (Term Name DefaultUni DefaultFun ()
termRes, ExBudget
budget) <- CompiledCode a
-> ExceptT
     SomeException IO (Term Name DefaultUni DefaultFun (), ExBudget)
forall a.
ToUPlc a DefaultUni DefaultFun =>
a
-> ExceptT
     SomeException IO (Term Name DefaultUni DefaultFun (), ExBudget)
runPlcCekBudget CompiledCode a
compiledCode
    let contents :: Doc ann
contents =
          [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ ExBudget -> Doc ann
forall ann. ExBudget -> Doc ann
prettyBudget ExBudget
budget
            , CompiledCode a -> Doc ann
forall a ann. CompiledCodeIn DefaultUni DefaultFun a -> Doc ann
prettyCodeSize CompiledCode a
compiledCode
            , Doc ann
forall a. Monoid a => a
mempty
            , Term Name DefaultUni DefaultFun () -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcClassicSimple Term Name DefaultUni DefaultFun ()
termRes
            ]
    Text -> ExceptT SomeException IO Text
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall str ann. Render str => Doc ann -> str
render @Text Doc Any
forall {ann}. Doc ann
contents)

goldenEvalCekLog
  :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun)
  => TestName -> a -> TestNested
goldenEvalCekLog :: forall a.
ToUPlc a DefaultUni DefaultFun =>
TestName -> a -> TestNested
goldenEvalCekLog TestName
name a
value =
  TestName -> TestName -> IO (Doc Any) -> TestNested
forall ann. TestName -> TestName -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM TestName
name TestName
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$
    [Text] -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcClassicSimple ([Text] -> Doc Any)
-> (([Text], CekExTally DefaultFun,
     Term Name DefaultUni DefaultFun ())
    -> [Text])
-> ([Text], CekExTally DefaultFun,
    Term Name DefaultUni DefaultFun ())
-> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  [Text]
  ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
  [Text]
-> ([Text], CekExTally DefaultFun,
    Term Name DefaultUni DefaultFun ())
-> [Text]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  [Text]
  ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
  [Text]
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
  ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
  [Text]
  [Text]
_1 (([Text], CekExTally DefaultFun,
  Term Name DefaultUni DefaultFun ())
 -> Doc Any)
-> IO
     ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
-> IO (Doc Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  SomeException
  IO
  ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
-> IO
     ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
forall a. ExceptT SomeException IO a -> IO a
rethrow (a
-> ExceptT
     SomeException
     IO
     ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
forall a.
ToUPlc a DefaultUni DefaultFun =>
a
-> ExceptT
     SomeException
     IO
     ([Text], CekExTally DefaultFun, Term Name DefaultUni DefaultFun ())
runPlcCekTrace a
value)

-- | Pretty-print an Execution Budget
prettyBudget :: PLC.ExBudget -> Doc ann
prettyBudget :: forall ann. ExBudget -> Doc ann
prettyBudget (PLC.ExBudget (ExCPU CostingInteger
cpu) (ExMemory CostingInteger
mem)) =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fill Int
10 Doc ann
"CPU:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall i ann. Integral i => i -> Doc ann
prettyIntRightAligned (forall a. Num a => CostingInteger -> a
fromSatInt @Int CostingInteger
cpu)
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fill Int
10 Doc ann
"Memory:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall i ann. Integral i => i -> Doc ann
prettyIntRightAligned (forall a. Num a => CostingInteger -> a
fromSatInt @Int CostingInteger
mem)
    ]

{-| Pretty-print compiled code size

Given a UPLC program, there are two quantification of "size": Term size and Flat size.
Term Size measures AST nodes of the given UPLC program. Flat Size measures the number
of bytes when the given program serialized into bytestring using binary flat encoding format.

Cost of storing smart contract onchain is partially determined by the Flat size. So it
is useful to have Flat size measurement in case we adopt new or introduce optimizations
to the flat encoding format.
-}
prettyCodeSize :: CompiledCodeIn PLC.DefaultUni PLC.DefaultFun a -> Doc ann
prettyCodeSize :: forall a ann. CompiledCodeIn DefaultUni DefaultFun a -> Doc ann
prettyCodeSize CompiledCodeIn DefaultUni DefaultFun a
compiledCode =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fill Int
10 Doc ann
"Term Size:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
forall i ann. Integral i => i -> Doc ann
prettyIntRightAligned Integer
termSize
    , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
fill Int
10 Doc ann
"Flat Size:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
forall i ann. Integral i => i -> Doc ann
prettyIntRightAligned Integer
flatSize
    ]
 where
  termSize :: Integer
termSize = CompiledCodeIn DefaultUni DefaultFun a -> Integer
forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Integer
countAstNodes CompiledCodeIn DefaultUni DefaultFun a
compiledCode
  flatSize :: Integer
flatSize = CompiledCodeIn DefaultUni DefaultFun a -> Integer
forall ann. CompiledCode ann -> Integer
countFlatBytes CompiledCodeIn DefaultUni DefaultFun a
compiledCode

prettyIntRightAligned :: (Integral i) => i -> Doc ann
prettyIntRightAligned :: forall i ann. Integral i => i -> Doc ann
prettyIntRightAligned =
  forall a ann. Pretty a => a -> Doc ann
pretty @String
    (TestName -> Doc ann) -> (i -> TestName) -> i -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> TestName -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%19s"
    (TestName -> TestName) -> (i -> TestName) -> i -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> TestName
forall a. [a] -> [a]
reverse
    (TestName -> TestName) -> (i -> TestName) -> i -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
List.intercalate TestName
"_"
    ([TestName] -> TestName) -> (i -> [TestName]) -> i -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TestName -> [TestName]
forall {a}. Int -> [a] -> [[a]]
chunksOf Int
3
    (TestName -> [TestName]) -> (i -> TestName) -> i -> [TestName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> TestName
forall a. [a] -> [a]
reverse
    (TestName -> TestName) -> (i -> TestName) -> i -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> TestName
show @Integer
    (Integer -> TestName) -> (i -> Integer) -> i -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
 where
  chunksOf :: Int -> [a] -> [[a]]
chunksOf Int
_ [] = []
  chunksOf Int
n [a]
xs = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n [a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
chunksOf Int
n (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n [a]
xs)