-
Notifications
You must be signed in to change notification settings - Fork 155
/
Pretty.hs
1607 lines (1295 loc) · 44.1 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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Cardano.Ledger.Pretty where
import Cardano.Chain.Common
( AddrAttributes (..),
Address (..),
Attributes (..),
HDAddressPayload (..),
NetworkMagic (..),
UnparsedFields (..),
)
import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Address
( Addr (..),
BootstrapAddress (..),
RewardAcnt (..),
)
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
import Cardano.Ledger.BaseTypes
( ActiveSlotCoeff,
BlocksMade (..),
BoundedRational (..),
DnsName,
FixedPoint,
Globals (..),
Network (..),
Nonce (..),
Port (..),
StrictMaybe (..),
UnitInterval,
Url (..),
activeSlotLog,
activeSlotVal,
dnsToText,
)
import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
import Cardano.Ledger.Compactible (Compactible (..))
import Cardano.Ledger.Core (PParamsDelta)
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Credential
( Credential (KeyHashObj, ScriptHashObj),
GenesisCredential (..),
Ptr (..),
StakeReference (..),
)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Era (Era)
import qualified Cardano.Ledger.Era as E (Crypto)
import qualified Cardano.Ledger.Era as Era (TxSeq)
import Cardano.Ledger.Keys
( GKeys (..),
GenDelegPair (..),
GenDelegs (..),
KeyHash (..),
KeyPair (..),
KeyRole (Staking),
VKey (..),
VerKeyKES,
)
import Cardano.Ledger.SafeHash (SafeHash, extractHash)
import Cardano.Ledger.Shelley.Address.Bootstrap (BootstrapWitness (..), ChainCode (..))
import Cardano.Ledger.Shelley.BlockChain (Block (..))
import Cardano.Ledger.Shelley.CompactAddr (CompactAddr (..), decompactAddr)
import Cardano.Ledger.Shelley.EpochBoundary
( SnapShot (..),
SnapShots (..),
Stake (..),
)
import Cardano.Ledger.Shelley.LedgerState
( AccountState (..),
DPState (..),
DState (..),
EpochState (..),
FutureGenDeleg (..),
InstantaneousRewards (..),
Ix,
LedgerState (..),
NewEpochState (..),
PPUPState (..),
PState (..),
UTxOState (..),
)
import Cardano.Ledger.Shelley.Metadata (Metadata (..), Metadatum (..))
import Cardano.Ledger.Shelley.PParams
( PPUpdateEnv (..),
PParams' (..),
ProposedPPUpdates (..),
ProtVer (..),
Update (..),
)
import Cardano.Ledger.Shelley.RewardUpdate
( FreeVars (..),
Pulser,
PulsingRewUpdate (..),
RewardAns (..),
RewardPulser (..),
RewardSnapShot (..),
RewardUpdate (..),
)
import Cardano.Ledger.Shelley.Rewards
( Histogram (..),
Likelihood (..),
LogWeight (..),
NonMyopic (..),
PerformanceEstimate (..),
Reward (..),
RewardType (..),
StakeShare (..),
)
import Cardano.Ledger.Shelley.Scripts (MultiSig (..), ScriptHash (..))
import Cardano.Ledger.Shelley.Tx
( Tx (..),
WitnessSetHKD,
prettyWitnessSetParts,
)
import Cardano.Ledger.Shelley.TxBody
( DCert (..),
DelegCert (..),
Delegation (..),
GenesisDelegCert (..),
MIRCert (..),
MIRPot (..),
MIRTarget (..),
PoolCert (..),
PoolMetadata (..),
PoolParams (..),
StakeCreds (..),
StakePoolRelay (..),
TxBody (..),
TxBodyRaw (..),
TxOut (..),
Wdrl (..),
WitVKey (..),
)
import Cardano.Ledger.Shelley.UTxO (UTxO (..))
import Cardano.Ledger.Slot
( BlockNo (..),
Duration (..),
EpochNo (..),
EpochSize (..),
SlotNo (..),
)
import Cardano.Ledger.TxIn (TxId (..), TxIn (..), viewTxIn)
import Cardano.Protocol.TPraos (IndividualPoolStake (..), PoolDistr (..))
import Cardano.Protocol.TPraos.BHeader
( BHBody (..),
BHeader (BHeader),
HashHeader (..),
LastAppliedBlock (..),
PrevHash (..),
)
import Cardano.Protocol.TPraos.OCert
( KESPeriod (..),
OCert (..),
OCertEnv (..),
OCertSignable (..),
)
import Cardano.Slotting.Slot (WithOrigin (..))
import Cardano.Slotting.Time (SystemStart (SystemStart))
import Codec.Binary.Bech32
import Control.Monad.Identity (Identity)
import Control.SetAlgebra (forwards)
import Control.State.Transition (STS (State))
import qualified Data.ByteString as Long (ByteString)
import qualified Data.ByteString.Lazy as Lazy (ByteString, toStrict)
import Data.IP (IPv4, IPv6)
import qualified Data.Map.Strict as Map (Map, toList)
import Data.MemoBytes (MemoBytes (..))
import Data.Proxy (Proxy (..))
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set, toList)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Natural (Natural)
import GHC.Records
import Prettyprinter
import Prettyprinter.Internal (Doc (Empty))
import Prettyprinter.Util (putDocW)
-- =====================================================================================================
-- HELPER FUNCTIONS
-- =====================================================================================================
-- ======================
-- Named pretty printers for some simpe types
ppString :: String -> Doc a
ppString = pretty
ppDouble :: Double -> Doc a
ppDouble = viaShow
ppInteger :: Integer -> Doc a
ppInteger = viaShow
ppRational :: Rational -> Doc a
ppRational = viaShow
ppFloat :: Float -> Doc a
ppFloat = viaShow
ppNatural :: Natural -> Doc a
ppNatural = viaShow
ppWord64 :: Word64 -> Doc a
ppWord64 = viaShow
ppWord32 :: Word32 -> Doc a
ppWord32 = viaShow
ppWord8 :: Word8 -> Doc a
ppWord8 = viaShow
ppWord16 :: Word16 -> Doc a
ppWord16 = viaShow
ppFixedPoint :: FixedPoint -> Doc a
ppFixedPoint = viaShow
ppPair :: (t1 -> PDoc) -> (t2 -> PDoc) -> (t1, t2) -> PDoc
ppPair pp1 pp2 (x, y) = ppSexp' mempty [pp1 x, pp2 y]
-- ppSignedDSIGN :: SignedDSIGN a b -> Doc ann
ppSignedDSIGN :: Show a => a -> PDoc
ppSignedDSIGN x = reAnnotate (Width 5 :) (viaShow x)
ppBool :: Bool -> Doc a
ppBool = viaShow
ppInt :: Int -> Doc a
ppInt = viaShow
-- =========================
-- operations for pretty printing
isEmpty :: Doc ann -> Bool
isEmpty Empty = True
isEmpty _ = False
putDoc :: Doc ann -> IO ()
putDoc = putDocW 80
newtype PrettyAnn = Width Int
type Ann = [PrettyAnn]
type PDoc = Doc Ann
text :: Text -> Doc ann
text = pretty
-- ======================
-- Byte Strings in Bech32 format
long_bech32 :: Long.ByteString -> Text
long_bech32 x =
case humanReadablePartFromText "*" of
Right human ->
case encode human (dataPartFromBytes x) of
Right ans -> ans
Left _ -> "bech32Error"
Left _ -> "bech32Error"
lazy_bech32 :: Lazy.ByteString -> Text
lazy_bech32 x =
case humanReadablePartFromText "*" of
Right human ->
case encode human (dataPartFromBytes (Lazy.toStrict x)) of
Right ans -> ans
Left _ -> "bech32Error"
Left _ -> "bech32Error"
ppLong :: Long.ByteString -> PDoc
ppLong x = text (long_bech32 x)
ppLazy :: Lazy.ByteString -> PDoc
ppLazy x = text (lazy_bech32 x)
instance PrettyA Long.ByteString where
prettyA = ppLong
instance PrettyA Lazy.ByteString where
prettyA = ppLazy
-- ================================
-- Combinators for common patterns of layout
-- | x == y
equate :: Doc a -> Doc a -> Doc a
equate x y = group (flatAlt (hang 2 (sep [x <+> text "=", y])) (hsep [x, text "=", y]))
-- | x -> y
arrow :: (Doc a, Doc a) -> Doc a
arrow (x, y) = group (flatAlt (hang 2 (sep [x <+> text "->", y])) (hsep [x, text "->", y]))
-- | ppSexp x [w,y,z] --> (x w y z)
ppSexp :: Text -> [PDoc] -> PDoc
ppSexp con = ppSexp' (text con)
ppSexp' :: PDoc -> [PDoc] -> PDoc
ppSexp' con fields =
group $
flatAlt
(hang 2 (encloseSep lparen rparen space docs))
(encloseSep lparen rparen space docs)
where
docs = if isEmpty con then fields else con : fields
-- | ppRecord name [("a",x),("b",y),("c",z)] --> name { a = x, b = y, c = z }
ppRecord :: Text -> [(Text, PDoc)] -> PDoc
ppRecord con = ppRecord' (text con)
ppRecord' :: PDoc -> [(Text, PDoc)] -> PDoc
ppRecord' con fields =
group $
flatAlt
(hang 1 (vcat [con, puncLeft lbrace (map (\(x, y) -> equate (text x) y) fields) comma rbrace]))
(con <> encloseSep (lbrace <> space) (space <> rbrace) (comma <> space) (map (\(x, y) -> equate (text x) y) fields))
-- | Vertical layout with commas aligned on the left hand side
puncLeft :: Doc ann -> [Doc ann] -> Doc ann -> Doc ann -> Doc ann
puncLeft open [] _ close = hsep [open, close]
puncLeft open [x] _ close = hsep [open, x, close]
puncLeft open (x : xs) coma close = align (sep ((open <+> x) : help xs))
where
help [] = mempty
help [y] = [hsep [coma, y, close]]
help (y : ys) = (coma <+> y) : help ys
ppSet :: (x -> Doc ann) -> Set x -> Doc ann
ppSet p xs = encloseSep lbrace rbrace comma (map p (toList xs))
ppList :: (x -> Doc ann) -> [x] -> Doc ann
ppList p xs =
group $
flatAlt
(puncLeft lbracket (map p xs) comma rbracket)
(encloseSep (lbracket <> space) (space <> rbracket) (comma <> space) (map p xs))
ppStrictSeq :: (a -> Doc ann) -> StrictSeq a -> Doc ann
ppStrictSeq p xs = ppList p (foldr (:) [] xs)
ppStrictMaybe :: (x -> Doc ann) -> StrictMaybe x -> Doc ann
ppStrictMaybe _ SNothing = text "?-"
ppStrictMaybe p (SJust x) = text "?" <> p x
ppMaybe :: (x -> Doc ann) -> Maybe x -> Doc ann
ppMaybe _ Nothing = text "?-"
ppMaybe p (Just x) = text "?" <> p x
ppMap' :: PDoc -> (k -> PDoc) -> (v -> PDoc) -> Map.Map k v -> PDoc
ppMap' name kf vf m =
let docs = fmap (\(k, v) -> arrow (kf k, vf v)) (Map.toList m)
vertical =
if isEmpty name
then hang 1 (puncLeft lbrace docs comma rbrace)
else hang 1 (vcat [name, puncLeft lbrace docs comma rbrace])
in group $
flatAlt
vertical
(name <> encloseSep (lbrace <> space) (space <> rbrace) (comma <> space) docs)
ppMap :: (k -> PDoc) -> (v -> PDoc) -> Map.Map k v -> PDoc
ppMap = ppMap' (text "Map")
class PrettyA t where
prettyA :: t -> PDoc
-- =====================================================================================================
-- END HELPER FUNCTIONS
-- ================================= ====================================================================
ppLastAppliedBlock :: LastAppliedBlock c -> PDoc
ppLastAppliedBlock (LastAppliedBlock blkNo slotNo hh) =
ppRecord
"LastAppliedBlock"
[ ("blockNo", ppBlockNo blkNo),
("slotNo", ppSlotNo slotNo),
("hash", ppHashHeader hh)
]
ppHashHeader :: HashHeader c -> PDoc
ppHashHeader (HashHeader x) = ppHash x
ppWithOrigin :: (t -> PDoc) -> WithOrigin t -> PDoc
ppWithOrigin _ Origin = ppString "Origin"
ppWithOrigin pp (At t) = ppSexp "At" [pp t]
instance PrettyA (LastAppliedBlock c) where
prettyA = ppLastAppliedBlock
instance PrettyA (HashHeader c) where
prettyA = ppHashHeader
instance PrettyA t => PrettyA (WithOrigin t) where
prettyA = ppWithOrigin prettyA
ppBHBody :: Crypto c => BHBody c -> PDoc
ppBHBody (BHBody bn sn prev vk vrfvk eta l size hash ocert protver) =
ppRecord
"BHBody"
[ ("BlockNo", ppBlockNo bn),
("SlotNo", ppSlotNo sn),
("Prev", ppPrevHash prev),
("VKey", ppVKey vk),
("VerKeyVRF", viaShow vrfvk), -- The next 3 are type families
("Eta", viaShow eta),
("L", viaShow l),
("size", ppNatural size),
("Hash", ppHash hash),
("OCert", ppOCert ocert),
("ProtVersion", ppProtVer protver)
]
ppPrevHash :: PrevHash c -> PDoc
ppPrevHash GenesisHash = ppString "GenesisHash"
ppPrevHash (BlockHash x) = ppSexp "BlockHashppHashHeader" [ppHashHeader x]
ppBHeader :: Crypto c => BHeader c -> PDoc
ppBHeader (BHeader bh sig) =
ppRecord
"BHeader"
[ ("Body", ppBHBody bh),
("Sig", viaShow sig)
]
ppBlock :: (PrettyA (Era.TxSeq era), PrettyA (h (E.Crypto era))) => Block h era -> PDoc
ppBlock (Block' bh seqx _) =
ppRecord
"Block"
[ ("Header", prettyA bh),
("TxSeq", prettyA seqx)
]
instance Crypto c => PrettyA (BHBody c) where
prettyA = ppBHBody
instance Crypto c => PrettyA (BHeader c) where
prettyA = ppBHeader
instance PrettyA (PrevHash c) where
prettyA = ppPrevHash
instance (Era era, PrettyA (Era.TxSeq era), PrettyA (h (E.Crypto era))) => PrettyA (Block h era) where
prettyA = ppBlock
-- =================================
-- Cardano.Ledger.Shelley.LedgerState.Delegation.Certificates
ppPoolDistr :: PoolDistr c -> PDoc
ppPoolDistr (PoolDistr mp) = ppSexp "PoolDistr" [ppMap ppKeyHash ppIndividualPoolStake mp]
ppIndividualPoolStake :: IndividualPoolStake c -> PDoc
ppIndividualPoolStake (IndividualPoolStake r1 h) =
ppRecord
"IndividualPoolStake"
[ ("stake", ppRational r1),
("stakeVrf", ppHash h)
]
instance PrettyA (PoolDistr c) where
prettyA = ppPoolDistr
instance PrettyA (IndividualPoolStake c) where
prettyA = ppIndividualPoolStake
-- ================================
-- Cardano.Ledger.Shelley.RewardUpdate
ppRewardUpdate :: RewardUpdate crypto -> PDoc
ppRewardUpdate (RewardUpdate dt dr rss df nonmyop) =
ppRecord
"RewardUpdate"
[ ("deltaT", ppDeltaCoin dt),
("deltaR", ppDeltaCoin dr),
("rs", ppMap' mempty ppCredential (ppSet ppReward) rss),
("deltaF", ppDeltaCoin df),
("nonMyopic", ppNonMyopic nonmyop)
]
ppRewardSnapShot :: RewardSnapShot crypto -> PDoc
ppRewardSnapShot (RewardSnapShot snaps a0 nopt ver non deltaR1 rR deltaT1 total pot) =
ppRecord
"RewardSnapShot"
[ ("snapshots", ppSnapShots snaps),
("a0", ppRational $ unboundRational a0),
("nOpt", ppNatural nopt),
("version", ppProtVer ver),
("nonmyopic", ppNonMyopic non),
("deltaR1", ppCoin deltaR1),
("R", ppCoin rR),
("deltaT1", ppCoin deltaT1),
("totalStake", ppCoin total),
("rewardPot", ppCoin pot)
]
ppFreeVars :: FreeVars crypto -> PDoc
ppFreeVars (FreeVars b1 del stake1 addrs total active asc1 blocks r1 slots d a0 nOpt mv) =
ppRecord
"FreeVars"
[ ("b", ppMap ppKeyHash ppNatural b1),
("delegs", ppMap ppCredential ppKeyHash del),
("stake", ppStake stake1),
("addrsRew", ppSet ppCredential addrs),
("totalStake", ppInteger total),
("activeStake", ppInteger active),
("asc", ppActiveSlotCoeff asc1),
("totalBlocks", ppNatural blocks),
("r", ppCoin r1),
("slotserEpoch", ppEpochSize slots),
("d", ppUnitInterval d),
("a0", ppRational $ unboundRational a0),
("nOpt", ppNatural nOpt),
("mv", ppNatural mv)
]
ppAns :: RewardAns crypto -> PDoc
ppAns (RewardAns x y) =
ppSexp'
mempty
[ ppMap ppCredential (ppSet ppReward) x,
ppMap ppKeyHash ppLikelihood y
]
ppRewardPulser :: Pulser crypto -> PDoc
ppRewardPulser (RSLP n free items ans) =
ppSexp
"RewardPulser"
[ ppInt n,
ppFreeVars free,
ppStrictSeq ppPoolParams items,
ppAns ans
]
ppPulsingRewUpdate :: PulsingRewUpdate crypto -> PDoc
ppPulsingRewUpdate (Pulsing snap pulser) =
ppSexp "Pulsing" [ppRewardSnapShot snap, ppRewardPulser pulser]
ppPulsingRewUpdate (Complete rewup) =
ppSexp "Complete" [ppRewardUpdate rewup]
instance PrettyA (RewardSnapShot crypto) where
prettyA = ppRewardSnapShot
instance PrettyA (FreeVars crypto) where
prettyA = ppFreeVars
instance PrettyA (Pulser crypto) where
prettyA = ppRewardPulser
instance PrettyA (PulsingRewUpdate crypto) where
prettyA = ppPulsingRewUpdate
instance PrettyA (RewardUpdate crypto) where
prettyA = ppRewardUpdate
-- =================================
-- Cardano.Ledger.Shelley.LedgerState
-- | Constraints needed to ensure that the ledger state can be pretty printed.
type CanPrettyPrintLedgerState era =
( PrettyA (Core.TxOut era),
PrettyA (Core.PParams era),
PrettyA (State (Core.EraRule "PPUP" era))
)
ppAccountState :: AccountState -> PDoc
ppAccountState (AccountState tr re) =
ppRecord
"AccountState"
[ ("treasury", ppCoin tr),
("reserves", ppCoin re)
]
ppDPState :: DPState crypto -> PDoc
ppDPState (DPState d p) = ppRecord "DPState" [("dstate", ppDState d), ("pstate", ppPState p)]
ppDState :: DState crypto -> PDoc
ppDState (DState r1 ds ptrs future gen irwd) =
ppRecord
"DState"
[ ("rewards", ppRewardAccounts r1),
("delegations", ppMap' mempty ppCredential ppKeyHash ds),
("ptrs", ppMap ppPtr ppCredential (forwards ptrs)),
("futuregendelegs", ppMap ppFutureGenDeleg ppGenDelegPair future),
("gendelegs", ppGenDelegs gen),
("instantaeousrewards", ppInstantaneousRewards irwd)
]
ppFutureGenDeleg :: FutureGenDeleg crypto -> PDoc
ppFutureGenDeleg (FutureGenDeleg sl kh) =
ppRecord
"FutureGenDeleg"
[ ("delegSlot", ppSlotNo sl),
("keyhash", ppKeyHash kh)
]
ppInstantaneousRewards :: InstantaneousRewards crypto -> PDoc
ppInstantaneousRewards (InstantaneousRewards res treas dR dT) =
ppRecord
"InstantaneousRewards"
[ ("reserves", ppMap' mempty ppCredential ppCoin res),
("treasury", ppMap' mempty ppCredential ppCoin treas),
("deltaReserves", ppDeltaCoin dR),
("deltaTreasury", ppDeltaCoin dT)
]
ppIx :: Ix -> PDoc
ppIx = viaShow
ppPPUPState :: PrettyA (PParamsDelta era) => PPUPState era -> PDoc
ppPPUPState (PPUPState p fp) =
ppRecord
"Proposed PPUPState"
[ ("proposals", ppProposedPPUpdates p),
("futureProposals", ppProposedPPUpdates fp)
]
ppPState :: PState crypto -> PDoc
ppPState (PState par fpar ret) =
ppRecord
"PState"
[ ("poolparams", ppMap' mempty ppKeyHash ppPoolParams par),
("futurepoolparams", ppMap' mempty ppKeyHash ppPoolParams fpar),
("retiring", ppMap' mempty ppKeyHash ppEpochNo ret)
]
ppRewardAccounts :: Map.Map (Credential 'Staking crypto) Coin -> PDoc
ppRewardAccounts = ppMap' (text "RewardAccounts") ppCredential ppCoin
ppRewardType :: RewardType -> PDoc
ppRewardType MemberReward = text "MemberReward"
ppRewardType LeaderReward = text "LeaderReward"
ppReward :: Reward crypto -> PDoc
ppReward (Reward rt pool amt) =
ppRecord
"Reward"
[ ("rewardType", ppRewardType rt),
("poolId", ppKeyHash pool),
("rewardAmount", ppCoin amt)
]
ppUTxOState ::
CanPrettyPrintLedgerState era =>
UTxOState era ->
PDoc
ppUTxOState (UTxOState u dep fee ppup) =
ppRecord
"UTxOState"
[ ("utxo", ppUTxO u),
("deposited", ppCoin dep),
("fees", ppCoin fee),
("ppups", prettyA ppup)
]
ppEpochState :: CanPrettyPrintLedgerState era => EpochState era -> PDoc
ppEpochState (EpochState acnt snap ls prev pp non) =
ppRecord
"EpochState"
[ ("accountState", ppAccountState acnt),
("snapShots", ppSnapShots snap),
("ledgerState", ppLedgerState ls),
("prevPParams", prettyA prev),
("currentPParams", prettyA pp),
("nonMyopic", ppNonMyopic non)
]
ppNewEpochState :: CanPrettyPrintLedgerState era => NewEpochState era -> PDoc
ppNewEpochState (NewEpochState enum prevB curB es rewup pool) =
ppRecord
"NewEpochState"
[ ("epochnum", ppEpochNo enum),
("prevBlock", ppBlocksMade prevB),
("currBlock", ppBlocksMade curB),
("epochState", ppEpochState es),
("rewUpdate", ppStrictMaybe ppPulsingRewUpdate rewup),
("poolDist", ppPoolDistr pool)
]
ppLedgerState ::
CanPrettyPrintLedgerState era =>
LedgerState era ->
PDoc
ppLedgerState (LedgerState u d) =
ppRecord
"LedgerState"
[ ("utxoState", ppUTxOState u),
("delegationState", ppDPState d)
]
instance PrettyA AccountState where
prettyA = ppAccountState
instance PrettyA (DPState crypto) where
prettyA = ppDPState
instance PrettyA (DState crypto) where
prettyA = ppDState
instance
( Era era,
CanPrettyPrintLedgerState era
) =>
PrettyA (EpochState era)
where
prettyA = ppEpochState
instance
( Era era,
CanPrettyPrintLedgerState era
) =>
PrettyA (NewEpochState era)
where
prettyA x = ppNewEpochState x
instance PrettyA (FutureGenDeleg crypto) where
prettyA = ppFutureGenDeleg
instance PrettyA (InstantaneousRewards crypto) where
prettyA = ppInstantaneousRewards
instance
( Era era,
CanPrettyPrintLedgerState era
) =>
PrettyA (LedgerState era)
where
prettyA = ppLedgerState
instance
PrettyA (PParamsDelta era) =>
PrettyA (PPUPState era)
where
prettyA = ppPPUPState
instance PrettyA (PState crypto) where
prettyA = ppPState
instance
( Era era,
CanPrettyPrintLedgerState era
) =>
PrettyA (UTxOState era)
where
prettyA = ppUTxOState
-- =================================
-- Cardano.Ledger.Shelley.Rewards
ppPerformanceEstimate :: PerformanceEstimate -> PDoc
ppPerformanceEstimate (PerformanceEstimate n) = ppSexp "PerformanceEstimate" [ppDouble n]
ppNonMyopic :: NonMyopic crypto -> PDoc
ppNonMyopic (NonMyopic m c) =
ppRecord
"NonMyopic"
[ ("likelihood", ppMap' "" ppKeyHash ppLikelihood m),
("rewardPot", ppCoin c)
]
ppStakeShare :: StakeShare -> PDoc
ppStakeShare (StakeShare n) = ppSexp "StakeShare" [ppRational n]
ppHistogram :: Histogram -> PDoc
ppHistogram (Histogram ss) = ppSexp "Histogram" [ppStrictSeq ppLogWeight ss]
ppLogWeight :: LogWeight -> PDoc
ppLogWeight (LogWeight n) = ppSexp "LogWeight" [ppFloat n]
ppLikelihood :: Likelihood -> PDoc
ppLikelihood (Likelihood ns) = ppSexp "Likelihood" [ppStrictSeq ppLogWeight ns]
instance PrettyA PerformanceEstimate where
prettyA = ppPerformanceEstimate
instance PrettyA StakeShare where
prettyA = ppStakeShare
instance PrettyA Histogram where
prettyA = ppHistogram
instance PrettyA LogWeight where
prettyA = ppLogWeight
instance PrettyA Likelihood where
prettyA = ppLikelihood
-- =================================
-- Cardano.Ledger.Shelley.EpochBoundary
ppStake :: Stake crypto -> PDoc
ppStake (Stake m) = ppMap' (text "Stake") ppCredential ppCoin m
ppBlocksMade :: BlocksMade crypto -> PDoc
ppBlocksMade (BlocksMade m) = ppMap' (text "BlocksMade") ppKeyHash ppNatural m
ppSnapShot :: SnapShot crypto -> PDoc
ppSnapShot (SnapShot st deleg params) =
ppRecord
"SnapShot"
[ ("stake", ppStake st),
("delegations", ppMap ppCredential ppKeyHash deleg),
("poolParams", ppMap ppKeyHash ppPoolParams params)
]
ppSnapShots :: SnapShots crypto -> PDoc
ppSnapShots (SnapShots mark set go fees) =
ppRecord
"SnapShots"
[ ("pstakeMark", ppSnapShot mark),
("pstakeSet", ppSnapShot set),
("pstakeGo", ppSnapShot go),
("fee", ppCoin fees)
]
instance PrettyA (Stake crypto) where
prettyA = ppStake
instance PrettyA (BlocksMade crypto) where
prettyA = ppBlocksMade
instance PrettyA (SnapShot crypto) where
prettyA = ppSnapShot
instance PrettyA (SnapShots crypto) where
prettyA = ppSnapShots
-- ============================
-- Cardano.Ledger.Shelley.UTxO
ppUTxO ::
PrettyA (Core.TxOut era) =>
UTxO era ->
PDoc
ppUTxO (UTxO m) = ppMap' (text "UTxO") ppTxIn prettyA m
instance
PrettyA (Core.TxOut era) =>
PrettyA (UTxO era)
where
prettyA = ppUTxO
-- ============================
-- Sheley.Spec.Ledger.Metadata
ppMetadatum :: Metadatum -> PDoc
ppMetadatum (Map m) =
let pairs = fmap (\(k, v) -> arrow (ppMetadatum k, ppMetadatum v)) m
in ppSexp
"Map"
[ group $
flatAlt
(hang 1 (puncLeft lbrace pairs comma rbrace))
(encloseSep (lbrace <> space) (space <> rbrace) (comma <> space) pairs)
]
ppMetadatum (List ds) = ppSexp "List" [ppList ppMetadatum ds]
ppMetadatum (I n) = ppSexp "I" [ppInteger n]
ppMetadatum (B bs) = ppSexp "B" [ppLong bs]
ppMetadatum (S txt) = ppSexp "S" [text txt]
ppMetadata :: Metadata era -> PDoc
ppMetadata (Metadata m) = ppMap' (text "Metadata") ppWord64 ppMetadatum m
instance PrettyA Metadatum where
prettyA = ppMetadatum
instance PrettyA (Metadata era) where
prettyA = ppMetadata
-- ============================
-- Cardano.Ledger.Shelley.Tx
ppTx ::
( PrettyA (Core.TxBody era),
PrettyA (Core.AuxiliaryData era),
PrettyA (Core.Witnesses era)
) =>
Tx era ->
PDoc
ppTx tx =
ppRecord
"Tx"
[ ("body", prettyA $ getField @"body" tx),
("witnessSet", prettyA $ getField @"wits" tx),
("metadata", ppStrictMaybe prettyA $ getField @"auxiliaryData" tx)
]
ppBootstrapWitness :: Crypto crypto => BootstrapWitness crypto -> PDoc
ppBootstrapWitness (BootstrapWitness key sig (ChainCode code) attr) =
ppRecord
"BootstrapWitness"
[ ("key", ppVKey key),
("signature", ppSignedDSIGN sig),
("chaincode", ppLong code),
("attributes", ppLong attr)
]
ppWitnessSetHKD :: (Era era, PrettyA (Core.Script era)) => WitnessSetHKD Identity era -> PDoc
ppWitnessSetHKD x =
let (addr, scr, boot) = prettyWitnessSetParts x
in ppRecord
"WitnessSet"
[ ("addrWits", ppSet ppWitVKey addr),
("scriptWits", ppMap ppScriptHash prettyA scr),
("bootWits", ppSet ppBootstrapWitness boot)
]
instance
( PrettyA (Core.TxBody era),
PrettyA (Core.AuxiliaryData era),
PrettyA (Core.Witnesses era),
Era era
) =>
PrettyA (Tx era)
where
prettyA = ppTx
instance Crypto crypto => PrettyA (BootstrapWitness crypto) where
prettyA = ppBootstrapWitness
instance (Era era, PrettyA (Core.Script era)) => PrettyA (WitnessSetHKD Identity era) where
prettyA = ppWitnessSetHKD
-- ============================
-- Cardano.Ledger.AuxiliaryData
ppSafeHash :: SafeHash crypto index -> PDoc
ppSafeHash x = ppHash (extractHash x)
ppAuxiliaryDataHash :: AuxiliaryDataHash c -> PDoc
ppAuxiliaryDataHash (AuxiliaryDataHash h) = ppSexp "AuxiliaryDataHash" [ppSafeHash h]
instance PrettyA (AuxiliaryDataHash c) where
prettyA = ppAuxiliaryDataHash
instance PrettyA (SafeHash c i) where
prettyA = ppSafeHash
-- ============================
-- Cardano.Ledger.Compactible
ppCompactForm :: (Compactible a) => (a -> PDoc) -> CompactForm a -> PDoc
ppCompactForm cf x = cf (fromCompact x)
instance (Compactible a, PrettyA a) => PrettyA (CompactForm a) where
prettyA = ppCompactForm prettyA
-- ============================
-- Cardano.Ledger.Shelley.TxBody
ppDelegation :: Delegation c -> PDoc
ppDelegation (Delegation orx ee) =
ppRecord "Delegation" [("delegator", ppCredential orx), ("delegatee", ppKeyHash ee)]
ppPoolMetadata :: PoolMetadata -> PDoc
ppPoolMetadata (PoolMetadata url hsh) =
ppRecord
"PoolMetadata"
[ ("url", ppUrl url),
("hash", text "#" <> reAnnotate (Width 5 :) (ppLong hsh))
]
ppStakePoolRelay :: StakePoolRelay -> PDoc
ppStakePoolRelay (SingleHostAddr port ip4 ip6) = ppSexp "SingleHostAddr" [ppStrictMaybe ppPort port, ppStrictMaybe ppIPv4 ip4, ppStrictMaybe ppIPv6 ip6]
ppStakePoolRelay (SingleHostName port dns) = ppSexp "SingleHostName" [ppStrictMaybe ppPort port, ppDnsName dns]
ppStakePoolRelay (MultiHostName dns) = ppSexp "MultiHostName" [ppDnsName dns]
ppPoolParams :: PoolParams c -> PDoc
ppPoolParams (PoolParams idx vrf pledge cost margin acnt owners relays md) =
ppRecord
"PoolParams"
[ ("Id", ppKeyHash idx),
("Vrf", ppHash vrf),
("Pledge", ppCoin pledge),
("Cost", ppCoin cost),
("Margin", ppUnitInterval margin),
("RAcnt", ppRewardAcnt acnt),
("Owners", ppSet ppKeyHash owners),
("Relays", ppStrictSeq ppStakePoolRelay relays),
("Metadata", ppStrictMaybe ppPoolMetadata md)
]
ppWdrl :: Wdrl c -> PDoc
ppWdrl (Wdrl m) = ppSexp "" [ppMap' (text "Wdr") ppRewardAcnt ppCoin m]
ppTxId :: TxId c -> PDoc
ppTxId (TxId x) = ppSexp "TxId" [ppSafeHash x]
ppTxIn :: TxIn c -> PDoc