-
Notifications
You must be signed in to change notification settings - Fork 11
/
Pretty.hs
174 lines (150 loc) · 6.36 KB
/
Pretty.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Cooked.Tx.Constraints.Pretty where
import Cooked.MockChain.UtxoState
import Cooked.MockChain.Wallet
import Cooked.Tx.Constraints.Type
import Data.Char
import Data.Default
import Data.Maybe (catMaybes, mapMaybe)
import qualified Ledger as Pl hiding (unspentOutputs)
import qualified Ledger.Typed.Scripts as Pl (DatumType, TypedValidator, validatorScript)
import Prettyprinter (Doc, (<+>))
import qualified Prettyprinter as PP
prettyEnum :: Doc ann -> Doc ann -> [Doc ann] -> Doc ann
prettyEnum title tag items =
PP.hang 1 $ PP.vsep $ title : map (tag <+>) items
prettyTxSkel :: [Wallet] -> TxSkel -> Doc ann
prettyTxSkel signers (TxSkel lbl opts constraintsSpec) =
let (cs :=>: ocs) = toConstraints constraintsSpec
in PP.vsep $
map ("-" <+>) $
catMaybes
[ Just $ "Signers:" <+> PP.list (map (prettyWallet . walletPKHash) signers),
fmap (("Label:" <+>) . prettyDatum) lbl,
fmap ("Opts:" <+>) (prettyOpts opts),
Just $ prettyEnum "Constraints:" "/\\" $ map prettyMiscConstraint cs <> map prettyOutConstraint ocs
]
prettyWallet :: Pl.PubKeyHash -> Doc ann
prettyWallet pkh =
"wallet" <+> (maybe phash ((<+> PP.parens phash) . ("#" <>) . PP.pretty) . walletPKHashToId $ pkh)
where
phash = prettyHash pkh
prettyOutConstraint :: OutConstraint -> Doc ann
prettyOutConstraint (PaysScript val datum value) =
prettyEnum ("PaysScript" <+> prettyTypedValidator val) "-" (map (uncurry (prettyDatumVal val)) [(datum, value)])
prettyOutConstraint (PaysPKWithDatum pkh stak dat val) =
prettyEnum
("PaysPK" <+> prettyWallet pkh)
PP.emptyDoc
( catMaybes
[ fmap (("StakePKH:" <+>) . PP.pretty) stak,
fmap (("Datum:" <+>) . prettyDatum) dat,
mPrettyValue val
]
)
prettyMiscConstraint :: MiscConstraint -> Doc ann
prettyMiscConstraint (SpendsPK out) =
let (ppAddr, mppVal) = prettyTxOut $ Pl.toTxOut $ snd out
in prettyEnum "SpendsPK" "-" $ catMaybes [Just ppAddr, mppVal]
prettyMiscConstraint (Mints mr policies val) =
prettyEnum "Mints" "-" $
catMaybes
[ mPrettyValue val,
fmap (("Redeemer:" <+>) . prettyDatum) mr,
Just $ "Policies:" <+> PP.list (map prettyMintingPolicy policies)
]
prettyMiscConstraint (SignedBy pkhs) = prettyEnum "SignedBy" "-" $ prettyWallet <$> pkhs
prettyMiscConstraint _ = "<constraint without pretty def>"
prettyHash :: (Show a) => a -> Doc ann
prettyHash = PP.pretty . take 6 . show
prettyMintingPolicy :: Pl.MintingPolicy -> Doc ann
prettyMintingPolicy = prettyHash . Pl.mintingPolicyHash
prettyOutputDatum :: (Show (Pl.DatumType a)) => Pl.TypedValidator a -> (SpendableOut, Pl.DatumType a) -> Doc ann
prettyOutputDatum _ (out, dat) =
let (ppAddr, mppVal) = prettyTxOut $ Pl.toTxOut $ snd out
in PP.align $
PP.vsep $
catMaybes
[Just $ "Output" <+> "at" <+> ppAddr, mppVal, Just $ "Datum:" <+> prettyDatum dat]
prettyTxOut :: Pl.TxOut -> (Doc ann, Maybe (Doc ann))
prettyTxOut tout = (prettyAddressTypeAndHash $ Pl.txOutAddress tout, mPrettyValue $ Pl.txOutValue tout)
prettyTypedValidator :: Pl.TypedValidator a -> Doc ann
prettyTypedValidator = prettyAddressTypeAndHash . Pl.scriptAddress . Pl.validatorScript
prettyDatumVal ::
(Show (Pl.DatumType a)) =>
Pl.TypedValidator a ->
Pl.DatumType a ->
Pl.Value ->
Doc ann
prettyDatumVal _ d value =
PP.align $ PP.vsep $ catMaybes [Just $ prettyDatum d, mPrettyValue value]
-- | Prettifies a 'TxOpts'; returns 'Nothing' if we're looking at default options.
prettyOpts :: TxOpts -> Maybe (Doc ann)
prettyOpts opts = case mapMaybe cmpAgainstDefAndPrint fields of
[] -> Nothing
xs -> Just $ PP.sep $ map (PP.semi <+>) xs
where
cmpAgainstDefAndPrint :: Field TxOpts -> Maybe (Doc ann)
cmpAgainstDefAndPrint (Field fn f)
| f opts == f def = Nothing
| otherwise = Just $ PP.pretty fn <> PP.colon <+> PP.viaShow (f opts)
-- Internal: if you add fields to TxOpts, make sure to add them here.
fields :: [Field TxOpts]
fields =
[ Field "adjustUnbalTx" adjustUnbalTx,
Field "awaitTxConfirmed" awaitTxConfirmed,
Field "autoSlotIncrease" autoSlotIncrease,
Field "unsafeModTx" unsafeModTx,
Field "balance" balance,
Field "collateral" collateral,
Field "balanceOutputPolicy" balanceOutputPolicy
]
data Field record where
Field :: (Show x, Eq x) => String -> (record -> x) -> Field record
-- * Shortening Hashes from Show Instances
-- | The 'prettyDatum' relies on Haskell's default show implementation,
-- but it display shortened hashes. It is a big hack to detect hashes and
-- it works in the vast majority of cases. It might shorten a string that
-- /is not/ a hash iff such string has more than 24 hexadecimal characters,
-- which arguably, is pretty unlikely for something that is not a hash.
prettyDatum :: (Show a) => a -> Doc ann
prettyDatum = PP.align . prettyWordPunct . map fixHashes . words' . show
where
-- TODO: It might be worthwhile to make a little parser for haskell records
-- and actually prettify the output. Legibility is a massively important
-- factor for us to be able to diagnose tests that go wrong.
isHashChar c = 'a' <= c && c <= 'f' || isDigit c
fixHashes :: WordPunct -> WordPunct
fixHashes (Punct str) = Punct str
fixHashes (Word str)
| length str < 24 = Word str
| all isHashChar str = Word $ take 6 str
| otherwise = Word str
words' :: String -> [WordPunct]
words' = concatMap splitPunct . words
splitPunct :: String -> [WordPunct]
splitPunct [] = []
splitPunct s =
let (p, s') = span isPunctuation s
(w, s'') = break isPunctuation s'
in appP p $ appW w $ splitPunct s''
where
appP [] = id
appP x = (Punct x :)
appW [] = id
appW x = (Word x :)
prettyWordPunct :: [WordPunct] -> Doc ann
prettyWordPunct = go
where
go (Word w : Word y : zs) = PP.pretty w <+> go (Word y : zs)
go (Word w : Punct y : zs)
| w == "=" = PP.pretty w <+> go (Punct y : zs)
| otherwise = PP.pretty w <> go (Punct y : zs)
go (Punct w : zs) = PP.pretty w <> go zs
go [Word w] = PP.pretty w
go [] = PP.emptyDoc
data WordPunct = Word String | Punct String
deriving (Show)