{-# 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,
) 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.Size (Size (..))
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, getPir, getPirNoAnn)
import PlutusTx.Test.Orphans ()
import PlutusTx.Test.Run.Uplc (runPlcCek, runPlcCekBudget, runPlcCekTrace)
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]
    Program Name DefaultUni DefaultFun ()
uplc <- CompiledCode a
-> ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc CompiledCode a
compiledCode
    let
      termSize :: Size
termSize = Program Name DefaultUni DefaultFun () -> Size
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> Size
UPLC.programSize Program Name DefaultUni DefaultFun ()
uplc
      flatSize :: Integer
flatSize = UnrestrictedProgram Name DefaultUni DefaultFun () -> Integer
forall a. Flat a => a -> Integer
UPLC.serialisedSize (UnrestrictedProgram Name DefaultUni DefaultFun () -> Integer)
-> UnrestrictedProgram Name DefaultUni DefaultFun () -> Integer
forall a b. (a -> b) -> a -> b
$ Program Name DefaultUni DefaultFun ()
-> UnrestrictedProgram Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram Program Name DefaultUni DefaultFun ()
uplc
    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 (ExBudget -> Size -> Integer -> Doc Any
forall ann. ExBudget -> Size -> Integer -> Doc ann
prettyBudget ExBudget
budget Size
termSize Integer
flatSize))

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
    Program Name DefaultUni DefaultFun ()
uplc <- CompiledCode a
-> ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc CompiledCode a
compiledCode
    let
      termSize :: Size
termSize = Program Name DefaultUni DefaultFun () -> Size
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> Size
UPLC.programSize Program Name DefaultUni DefaultFun ()
uplc
      flatSize :: Integer
flatSize = UnrestrictedProgram Name DefaultUni DefaultFun () -> Integer
forall a. Flat a => a -> Integer
UPLC.serialisedSize (UnrestrictedProgram Name DefaultUni DefaultFun () -> Integer)
-> UnrestrictedProgram Name DefaultUni DefaultFun () -> Integer
forall a b. (a -> b) -> a -> b
$ Program Name DefaultUni DefaultFun ()
-> UnrestrictedProgram Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram Program Name DefaultUni DefaultFun ()
uplc

    let contents :: Doc ann
contents =
          [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ ExBudget -> Size -> Integer -> Doc ann
forall ann. ExBudget -> Size -> Integer -> Doc ann
prettyBudget ExBudget
budget Size
termSize Integer
flatSize
            , 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)

{- |
This function formats budget and size information.


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.
-}
prettyBudget :: PLC.ExBudget -> Size -> Integer -> Doc ann
prettyBudget :: forall ann. ExBudget -> Size -> Integer -> Doc ann
prettyBudget (PLC.ExBudget (ExCPU CostingInteger
cpu) (ExMemory CostingInteger
mem)) (Size Integer
termSize) Integer
flatSize =
  [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)
    , 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
  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)