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/MockChain/Staged.hs

@@ -20,16 +20,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 +35,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 +74,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 +123,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 +148,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 +209,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

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

@@ -10,6 +10,8 @@ import Control.Monad
 import Cooked.MockChain.Direct
 import Cooked.MockChain.Staged
 import Cooked.MockChain.UtxoState
+import Cooked.Pretty
+import Cooked.Pretty.Class
 import Cooked.Wallet
 import Data.Default
 import qualified Data.Text as T
@@ -68,85 +70,90 @@ a .||. b = testDisjoin [a, b]
 
 -- | Ensure that all results produced by the staged mockchain /succeed/, starting
 -- from the default initial distribution
-testSucceeds :: (IsProp prop) => StagedMockChain a -> prop
-testSucceeds = testSucceedsFrom def
+testSucceeds :: (IsProp prop) => PrettyCookedOpts -> StagedMockChain a -> prop
+testSucceeds pcOpts = testSucceedsFrom pcOpts def
 
 -- | Ensure that all results produced by the staged mockchain /fail/ starting
 -- from the default initial distribution
-testFails :: (IsProp prop, Show a) => StagedMockChain a -> prop
-testFails = testFailsFrom def
+testFails :: (IsProp prop, Show a) => PrettyCookedOpts -> StagedMockChain a -> prop
+testFails pcOpts = testFailsFrom pcOpts def
 
 -- | Ensure that all results produced by the staged mockchain succeed starting
 -- from some initial distribution but doesn't impose any additional condition on success.
 -- Use 'testSucceedsFrom'' for that.
 testSucceedsFrom ::
   (IsProp prop) =>
+  PrettyCookedOpts ->
   InitialDistribution ->
   StagedMockChain a ->
   prop
-testSucceedsFrom = testSucceedsFrom' (\_ _ -> testSuccess)
+testSucceedsFrom pcOpts = testSucceedsFrom' pcOpts (\_ _ -> testSuccess)
 
 -- | Ensure that all results produced by the staged mockchain succeed starting
 -- from some initial distribution. Additionally impose a condition over the
 -- resulting state and value.
 testSucceedsFrom' ::
   (IsProp prop) =>
+  PrettyCookedOpts ->
   (a -> UtxoState -> prop) ->
   InitialDistribution ->
   StagedMockChain a ->
   prop
-testSucceedsFrom' prop = testAllSatisfiesFrom (either (testFailureMsg . show) (uncurry prop))
+testSucceedsFrom' pcOpts prop = testAllSatisfiesFrom pcOpts (either (testFailureMsg . renderString (prettyCookedOpt pcOpts)) (uncurry prop))
 
 -- | Ensure that all results produced by the staged mockchain /fail/ starting
 -- from some initial distribution
 testFailsFrom ::
   (IsProp prop, Show a) =>
+  PrettyCookedOpts ->
   InitialDistribution ->
   StagedMockChain a ->
   prop
-testFailsFrom = testFailsFrom' (const testSuccess)
+testFailsFrom pcOpts = testFailsFrom' pcOpts (const testSuccess)
 
 -- | Ensure that all results produced by the staged mockchain /fail/ starting
 -- from some initial distribution, moreover, ensures that a certain predicate
 -- over the error holds.
 testFailsFrom' ::
   (IsProp prop, Show a) =>
+  PrettyCookedOpts ->
   (MockChainError -> prop) ->
   InitialDistribution ->
   StagedMockChain a ->
   prop
-testFailsFrom' predi = testAllSatisfiesFrom (either predi (testFailureMsg . show))
+testFailsFrom' pcOpts predi = testAllSatisfiesFrom pcOpts (either predi (testFailureMsg . renderString (prettyEndState pcOpts)))
 
 -- | Is satisfied when the given 'MockChainError' is wrapping a @CekEvaluationFailure@.
 -- This is particularly important when writing negative tests. For example, if we are simulating
 -- an attack and writing a test with 'testFailsFrom', we might have made a mistake in the attack,
 -- yielding a test that fails for reasons such as @ValueLessThanMinAda@ or @ValueNotPreserved@, which
 -- does not rule out the attack being caught by the validator script. For these scenarios it is
 -- paramount to rely on @testFailsFrom' isCekEvaluationFailure@ instead.
-isCekEvaluationFailure :: (IsProp prop) => MockChainError -> prop
-isCekEvaluationFailure (MCEValidationError (_, ScriptFailure _)) = testSuccess
-isCekEvaluationFailure e = testFailureMsg $ "Expected 'CekEvaluationFailure', got: " ++ show e
+isCekEvaluationFailure :: (IsProp prop) => PrettyCookedOpts -> MockChainError -> prop
+isCekEvaluationFailure _ (MCEValidationError (_, ScriptFailure _)) = testSuccess
+isCekEvaluationFailure pcOpts e = testFailureMsg $ "Expected 'CekEvaluationFailure', got: " ++ renderString (prettyCookedOpt pcOpts) e
 
 -- | Similar to 'isCekEvaluationFailure', but enables us to check for a specific error message in the error.
-isCekEvaluationFailureWithMsg :: (IsProp prop) => (String -> Bool) -> MockChainError -> prop
-isCekEvaluationFailureWithMsg f (MCEValidationError (_, ScriptFailure (EvaluationError msgs _)))
+isCekEvaluationFailureWithMsg :: (IsProp prop) => PrettyCookedOpts -> (String -> Bool) -> MockChainError -> prop
+isCekEvaluationFailureWithMsg _ f (MCEValidationError (_, ScriptFailure (EvaluationError msgs _)))
   | any (f . T.unpack) msgs = testSuccess
-isCekEvaluationFailureWithMsg _ e = testFailureMsg $ "Expected 'CekEvaluationFailure' with specific messages, got: " ++ show e
+isCekEvaluationFailureWithMsg pcOpts _ e = testFailureMsg $ "Expected 'CekEvaluationFailure' with specific messages, got: " ++ renderString (prettyCookedOpt pcOpts) e
 
 -- | Ensure that all results produced by the set of traces encoded by the 'StagedMockChain'
 -- satisfy the given predicate. If you wish to build custom predicates
 -- you can use 'testSatisfiesFrom'' directly and see 'testBinaryRelatedBy' as an example.
 testAllSatisfiesFrom ::
   forall prop a.
   (IsProp prop) =>
+  PrettyCookedOpts ->
   (Either MockChainError (a, UtxoState) -> prop) ->
   InitialDistribution ->
   StagedMockChain a ->
   prop
-testAllSatisfiesFrom f = testSatisfiesFrom' (testAll go)
+testAllSatisfiesFrom pcOpts f = testSatisfiesFrom' (testAll go)
   where
-    go :: (Either MockChainError (a, UtxoState), TraceDescr) -> prop
-    go (prop, tr) = testCounterexample (show tr) (f prop)
+    go :: (Either MockChainError (a, UtxoState), MockChainLog) -> prop
+    go (prop, mcLog) = testCounterexample (renderString (prettyMockChainLog pcOpts) mcLog) (f prop)
 
 -- | Asserts that the given 'StagedMockChain' produces exactly two outcomes, both of which
 -- are successful and have their resulting states related by a given predicate. A typical
@@ -157,28 +164,29 @@ testAllSatisfiesFrom f = testSatisfiesFrom' (testAll go)
 -- >   execOption1 x <|> execOption2 x
 testBinaryRelatedBy ::
   (IsProp prop) =>
+  PrettyCookedOpts ->
   (UtxoState -> UtxoState -> prop) ->
   InitialDistribution ->
   StagedMockChain a ->
   prop
-testBinaryRelatedBy rel = testSatisfiesFrom' $ \case
+testBinaryRelatedBy pcOpts rel = testSatisfiesFrom' $ \case
   [(ra, ta), (rb, tb)] -> case (ra, rb) of
     (Right resA, Right resB) -> rel (snd resA) (snd resB)
     (Left errA, Right _) ->
-      testFailureMsg $ concat ["Expected two outcomes, the first failed with:", show errA, "\n", show ta]
+      testFailureMsg $ concat ["Expected two outcomes, the first failed with:", renderString (prettyCookedOpt pcOpts) errA, "\n", renderString (prettyMockChainLog pcOpts) ta]
     (Right _, Left errB) ->
-      testFailureMsg $ concat ["Expected two outcomes, the second failed with:", show errB, "\n", show tb]
+      testFailureMsg $ concat ["Expected two outcomes, the second failed with:", renderString (prettyCookedOpt pcOpts) errB, "\n", renderString (prettyMockChainLog pcOpts) tb]
     (Left errA, Left errB) ->
       testFailureMsg $
         concat
           [ "Expected two outcomes, both failed with:",
-            show errA,
+            renderString (prettyCookedOpt pcOpts) errA,
             "; ",
-            show errB,
+            renderString (prettyCookedOpt pcOpts) errB,
             "\n First: ",
-            show ta,
+            renderString (prettyMockChainLog pcOpts) ta,
             "\nSecond: ",
-            show tb
+            renderString (prettyMockChainLog pcOpts) tb
           ]
   xs -> testFailureMsg $ "Expected exactly two outcomes, received: " ++ show (length xs)
 
@@ -192,20 +200,21 @@ testBinaryRelatedBy rel = testSatisfiesFrom' $ \case
 -- to the same equivalence class. This function does /not/ check each pointwise case.
 testOneEquivClass ::
   (IsProp prop) =>
+  PrettyCookedOpts ->
   (UtxoState -> UtxoState -> prop) ->
   InitialDistribution ->
   StagedMockChain a ->
   prop
-testOneEquivClass rel = testSatisfiesFrom' $ \case
+testOneEquivClass pcOpts rel = testSatisfiesFrom' $ \case
   [] -> testFailureMsg "Expected two of more outcomes, received: 0"
   [_] -> testFailureMsg "Expected two of more outcomes, received: 1"
-  ((Left errX, tx) : _) -> testFailureMsg $ concat ["First outcome is a failure: ", show errX, "\n", show tx]
+  ((Left errX, tx) : _) -> testFailureMsg $ concat ["First outcome is a failure: ", renderString (prettyCookedOpt pcOpts) errX, "\n", renderString (prettyMockChainLog pcOpts) tx]
   ((Right resX, _) : xs) -> go (snd resX) xs
   where
     -- we can flag a success here because 'xs' above is guarnateed to have at least
     -- one element since we ruled out the empty and the singleton lists in the \case
     go _resX [] = testSuccess
-    go _resX ((Left errY, ty) : _) = testFailureMsg $ concat ["An outcome is a failure: ", show errY, "\n", show ty]
+    go _resX ((Left errY, ty) : _) = testFailureMsg $ concat ["An outcome is a failure: ", renderString (prettyCookedOpt pcOpts) errY, "\n", renderString (prettyMockChainLog pcOpts) ty]
     go resX ((Right (_, resY), _) : ys) = testConjoin [rel resX resY, go resX ys]
 
 -- | Asserts that the results produced by running the given 'StagedMockChain' from
@@ -217,7 +226,7 @@ testOneEquivClass rel = testSatisfiesFrom' $ \case
 -- it can be useful in building some custom predicates. Check 'testAllSatisfiesFrom'
 -- or 'testBinaryRelatedBy' for examples on using this.
 testSatisfiesFrom' ::
-  ([(Either MockChainError (a, UtxoState), TraceDescr)] -> prop) ->
+  ([(Either MockChainError (a, UtxoState), MockChainLog)] -> prop) ->
   InitialDistribution ->
   StagedMockChain a ->
   prop

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

@@ -2,13 +2,13 @@
 
 module Cooked.MockChain.UtxoState where
 
+import Cooked.Pretty.Class (DocCooked)
 import Data.Function (on)
 import qualified Data.List as L
 import qualified Data.Map.Strict as M
 import qualified Ledger as Pl
 import qualified Ledger.Value as Pl
 import qualified PlutusTx.Numeric as Pl
-import Prettyprinter (Doc)
 
 -- | A 'UtxoState' provides us with the mental picture of the state of the UTxO graph:
 -- Each address has a set of UTxOs that consist in a value and some potential datum.
@@ -51,7 +51,7 @@ utxoStateTotal = mconcat . map utxoValueSetTotal . M.elems . utxoState
 data UtxoDatum = UtxoDatum
   { utxoDatum :: Pl.Datum,
     utxoInlined :: Bool,
-    utxoDoc :: Doc ()
+    utxoDoc :: DocCooked
   }
 
 -- We ignore the pretty-printed document when implementing ordering and