Further improvements to pretty-printing in cooked v2

cooked-validators/cooked-validators.cabal

@@ -29,6 +29,7 @@ library
       Cooked.MockChain.UtxoState
       Cooked.Output
       Cooked.Pretty
+      Cooked.Pretty.Class
       Cooked.RawUPLC
       Cooked.Skeleton
       Cooked.Tweak

cooked-validators/src/Cooked.hs

@@ -8,6 +8,7 @@ import Cooked.Ltl as X
 import Cooked.MockChain as X
 import Cooked.Output as X
 import Cooked.Pretty as X
+import Cooked.Pretty.Class as X
 import Cooked.RawUPLC as X
 import Cooked.Skeleton as X
 import Cooked.Tweak as X

cooked-validators/src/Cooked/Attack/DatumHijacking.hs

@@ -12,14 +12,14 @@ module Cooked.Attack.DatumHijacking where
 
 import Control.Monad
 import Cooked.Output
+import Cooked.Pretty.Class
 import Cooked.RawUPLC
 import Cooked.Skeleton
 import Cooked.Tweak
 import qualified Ledger as L
 import qualified Ledger.Typed.Scripts as L
 import Optics.Core
 import qualified PlutusTx as Pl
-import Prettyprinter
 import Type.Reflection
 
 -- | Redirect script outputs from one validator to another validator of the same
@@ -72,7 +72,7 @@ datumHijackingAttack ::
   forall a m.
   ( MonadTweak m,
     Show (L.DatumType a),
-    Pretty (L.DatumType a),
+    PrettyCooked (L.DatumType a),
     Pl.ToData (L.DatumType a),
     Typeable (L.DatumType a),
     Typeable a

cooked-validators/src/Cooked/Attack/DoubleSat.hs

@@ -177,7 +177,9 @@ doubleSatAttack optic extra attacker mode = do
           TryCombinations ->
             nubBy sameDeltas $
               map joinDeltas $
-                tail $ allCombinations $ map (mempty :) deltas
+                tail $
+                  allCombinations $
+                    map (mempty :) deltas
       )
   addLabelTweak DoubleSatLbl
   where

cooked-validators/src/Cooked/MockChain/GenerateTx.hs

@@ -282,7 +282,7 @@ generateTxBodyContent GenTxParams {..} theParams managedData managedTxOuts manag
                     <$> left
                       (ToCardanoError "txSkelMintsToTxMintValue, calculating the witness map")
                       (Pl.toCardanoPolicyId (Pl.mintingPolicyHash policy))
-                      <*> mkMintWitness policy redeemer
+                    <*> mkMintWitness policy redeemer
               )
               $ txSkelMintsToList mints
 
@@ -320,11 +320,11 @@ txSkelOutToCardanoTxOut theParams (Pays output) =
   left (ToCardanoError "txSkelOutToTxOut") $
     C.TxOut
       <$> Pl.toCardanoAddressInEra (Pl.pNetworkId theParams) (outputAddress output)
-        <*> Pl.toCardanoTxOutValue (outputValue output)
-        <*> ( case output ^. outputDatumL of
-                TxSkelOutNoDatum -> Right Pl.toCardanoTxOutNoDatum
-                TxSkelOutDatumHash datum -> Pl.toCardanoTxOutDatumHash . Pl.datumHash . Pl.Datum . Pl.toBuiltinData $ datum
-                TxSkelOutDatum datum -> Right . Pl.toCardanoTxOutDatumInTx . Pl.Datum . Pl.toBuiltinData $ datum
-                TxSkelOutInlineDatum datum -> Right . Pl.toCardanoTxOutDatumInline . Pl.Datum . Pl.toBuiltinData $ datum
-            )
-        <*> Pl.toCardanoReferenceScript (toScript <$> output ^. outputReferenceScriptL)
+      <*> Pl.toCardanoTxOutValue (outputValue output)
+      <*> ( case output ^. outputDatumL of
+              TxSkelOutNoDatum -> Right Pl.toCardanoTxOutNoDatum
+              TxSkelOutDatumHash datum -> Pl.toCardanoTxOutDatumHash . Pl.datumHash . Pl.Datum . Pl.toBuiltinData $ datum
+              TxSkelOutDatum datum -> Right . Pl.toCardanoTxOutDatumInTx . Pl.Datum . Pl.toBuiltinData $ datum
+              TxSkelOutInlineDatum datum -> Right . Pl.toCardanoTxOutDatumInline . Pl.Datum . Pl.toBuiltinData $ datum
+          )
+      <*> Pl.toCardanoReferenceScript (toScript <$> output ^. outputReferenceScriptL)

cooked-validators/src/Cooked/MockChain/Staged.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -20,16 +19,12 @@ import Cooked.Ltl
 import Cooked.MockChain.BlockChain
 import Cooked.MockChain.Direct
 import Cooked.MockChain.UtxoState
-import Cooked.Pretty
+import Cooked.Pretty.Class
 import Cooked.Skeleton
 import Cooked.Tweak.Common
 import Data.Default
-import Data.Map (Map)
 import qualified Ledger as Pl
 import qualified Plutus.V2.Ledger.Api as PV2
-import Prettyprinter (Doc, (<+>))
-import qualified Prettyprinter as PP
-import qualified Prettyprinter.Render.String as PP
 
 -- * Interpreting and running 'StagedMockChain'
 
@@ -39,17 +34,24 @@ import qualified Prettyprinter.Render.String as PP
 interpretAndRunWith ::
   (forall m. Monad m => MockChainT m a -> m res) ->
   StagedMockChain a ->
-  [(res, TraceDescr)]
+  [(res, MockChainLog)]
 interpretAndRunWith f smc = runWriterT $ f $ interpret smc
 
 interpretAndRun ::
   StagedMockChain a ->
-  [(Either MockChainError (a, UtxoState), TraceDescr)]
+  [(Either MockChainError (a, UtxoState), MockChainLog)]
 interpretAndRun = interpretAndRunWith runMockChainT
 
+data MockChainLogEntry
+  = MCLogSubmittedTxSkel SkelContext TxSkel
+  | MCLogNewTx Pl.TxId
+  | MCLogFail String
+
+type MockChainLog = [MockChainLogEntry]
+
 -- | The semantic domain in which 'StagedMockChain' gets interpreted; see
 --  the 'interpret' function for more.
-type InterpMockChain = MockChainT (WriterT TraceDescr [])
+type InterpMockChain = MockChainT (WriterT MockChainLog [])
 
 -- | The 'interpret' function gives semantics to our traces. One
 --  'StagedMockChain' computation yields a potential list of 'MockChainT'
@@ -71,7 +73,7 @@ data MockChainBuiltin a where
   AwaitSlot :: Pl.Slot -> MockChainBuiltin Pl.Slot
   GetCurrentTime :: MockChainBuiltin Pl.POSIXTime
   AwaitTime :: Pl.POSIXTime -> MockChainBuiltin Pl.POSIXTime
-  DatumFromHash :: Pl.DatumHash -> MockChainBuiltin (Maybe (Pl.Datum, Doc ()))
+  DatumFromHash :: Pl.DatumHash -> MockChainBuiltin (Maybe (Pl.Datum, DocCooked))
   OwnPubKey :: MockChainBuiltin Pl.PubKeyHash
   AllUtxos :: MockChainBuiltin [(Pl.TxOutRef, PV2.TxOut)]
   -- the following are not strictly blockchain specific, but they allow us to
@@ -120,8 +122,18 @@ instance InterpLtl (UntypedTweak InterpMockChain) MockChainBuiltin InterpMockCha
         let managedTxOuts = utxoIndexToTxOutMap . mcstIndex $ mcst
             managedDatums = mcstDatums mcst
         (_, skel') <- lift $ runTweakInChain now skel
-        lift $ lift $ tell $ prettyMockChainOp managedTxOuts managedDatums $ Builtin $ ValidateTxSkel skel'
+        lift $
+          lift $
+            tell
+              [ MCLogSubmittedTxSkel
+                  (SkelContext managedTxOuts managedDatums)
+                  skel'
+              ]
         tx <- validateTxSkel skel'
+        lift $
+          lift $
+            tell
+              [MCLogNewTx (Pl.getCardanoTxId tx)]
         put later
         return tx
   interpBuiltin (TxOutByRef o) = txOutByRef o
@@ -135,10 +147,7 @@ instance InterpLtl (UntypedTweak InterpMockChain) MockChainBuiltin InterpMockCha
   interpBuiltin Empty = mzero
   interpBuiltin (Alt l r) = interpLtl l `mplus` interpLtl r
   interpBuiltin (Fail msg) = do
-    mcst <- lift get
-    let managedTxOuts = utxoIndexToTxOutMap . mcstIndex $ mcst
-        managedDatums = mcstDatums mcst
-    lift $ lift $ tell $ prettyMockChainOp managedTxOuts managedDatums $ Builtin $ Fail msg
+    lift $ lift $ tell [MCLogFail msg]
     fail msg
 
 -- ** Helpers to run tweaks for use in tests for tweaks
@@ -199,39 +208,3 @@ instance MonadBlockChainWithoutValidation StagedMockChain where
 
 instance MonadBlockChain StagedMockChain where
   validateTxSkel = singletonBuiltin . ValidateTxSkel
-
--- * Human Readable Traces
-
--- | Generates a 'TraceDescr'iption for the given operation; we're mostly interested in seeing
---  the transactions that were validated, so many operations have no description.
-prettyMockChainOp :: Map Pl.TxOutRef PV2.TxOut -> Map Pl.DatumHash (Pl.Datum, Doc ()) -> MockChainOp a -> TraceDescr
-prettyMockChainOp managedTxOuts managedDatums (Builtin (ValidateTxSkel skel)) =
-  trSingleton $
-    PP.hang 2 $
-      PP.vsep ["ValidateTxSkel", prettyTxSkel managedTxOuts managedDatums skel]
-prettyMockChainOp _ _ (Builtin (Fail reason)) =
-  trSingleton $ PP.hang 2 $ PP.vsep ["Fail", PP.pretty reason]
-prettyMockChainOp _ _ _ = mempty
-
--- | A 'TraceDescr' is a list of 'Doc' encoded as a difference list for
---  two reasons (check 'ShowS' if you're confused about how this works, its the same idea).
---    1) Naturally, these make for efficient concatenation
---    2) More importantly, this makes it easy to define the empty 'TraceDescr'
---       as @TraceDescr id@ instead of relying on 'PP.emptyDoc', which generates
---       empty lines when used with 'PP.vsep'. This avoids generating these empty lines
-newtype TraceDescr = TraceDescr {trApp :: [Doc ()] -> [Doc ()]}
-
-trSingleton :: Doc ann -> TraceDescr
-trSingleton d = TraceDescr (void d :)
-
-instance Show TraceDescr where
-  show (TraceDescr gen) =
-    let tr = gen []
-        numbered = zipWith (\n d -> PP.pretty n <> ")" <+> PP.align d) [1 :: Integer ..] tr
-     in PP.renderString . PP.layoutPretty PP.defaultLayoutOptions $ PP.vsep numbered
-
-instance Semigroup TraceDescr where
-  x <> y = TraceDescr $ trApp x . trApp y
-
-instance Monoid TraceDescr where
-  mempty = TraceDescr id