-
Notifications
You must be signed in to change notification settings - Fork 86
/
TestLedgerState.hs
93 lines (67 loc) · 3.07 KB
/
TestLedgerState.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
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Util.TestLedgerState (
LedgerTables (..)
, SimpleLedgerState (..)
) where
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Ouroboros.Consensus.Ledger.Basics
{-------------------------------------------------------------------------------
Simple ledger state
-------------------------------------------------------------------------------}
newtype SimpleLedgerState k v (mk :: MapKind) = SimpleLedgerState {
lsSimple :: mk k v
}
deriving instance (Eq (mk k v)) => Eq (SimpleLedgerState k v mk)
deriving stock instance Show (mk k v) => Show (SimpleLedgerState k v mk)
instance (ToCBOR k, FromCBOR k, ToCBOR v, FromCBOR v)
=> SufficientSerializationForAnyBackingStore (SimpleLedgerState k v) where
codecLedgerTables = SimpleLedgerTables $ CodecMK toCBOR toCBOR fromCBOR fromCBOR
{-------------------------------------------------------------------------------
Simple ledger tables
-------------------------------------------------------------------------------}
instance (Ord k, Eq v, Show k, Show v) => TableStuff (SimpleLedgerState k v) where
newtype LedgerTables (SimpleLedgerState k v) mk = SimpleLedgerTables {
ltSimple :: mk k v
} deriving Generic
projectLedgerTables SimpleLedgerState{lsSimple} =
SimpleLedgerTables lsSimple
withLedgerTables st SimpleLedgerTables{ltSimple} =
st { lsSimple = ltSimple }
pureLedgerTables f =
SimpleLedgerTables { ltSimple = f }
mapLedgerTables f SimpleLedgerTables{ltSimple} =
SimpleLedgerTables $ f ltSimple
traverseLedgerTables f SimpleLedgerTables{ltSimple} =
SimpleLedgerTables <$> f ltSimple
zipLedgerTables f l r =
SimpleLedgerTables (f (ltSimple l) (ltSimple r))
zipLedgerTablesA f l r =
SimpleLedgerTables <$> f (ltSimple l) (ltSimple r)
zipLedgerTables2 f l m r =
SimpleLedgerTables $ f (ltSimple l) (ltSimple m) (ltSimple r)
zipLedgerTables2A f l c r =
SimpleLedgerTables <$> f (ltSimple l) (ltSimple c) (ltSimple r)
foldLedgerTables f SimpleLedgerTables{ltSimple} =
f ltSimple
foldLedgerTables2 f l r =
f (ltSimple l) (ltSimple r)
namesLedgerTables =
SimpleLedgerTables { ltSimple = NameMK "ltSimple" }
deriving stock instance (Eq (mk k v))
=> Eq (LedgerTables (SimpleLedgerState k v) mk)
deriving stock instance (Show (mk k v))
=> Show (LedgerTables (SimpleLedgerState k v) mk)
deriving newtype instance NoThunks (mk k v)
=> NoThunks (LedgerTables (SimpleLedgerState k v) mk)
instance (Show k, Show v) => ShowLedgerState (LedgerTables (SimpleLedgerState k v)) where
showsLedgerState _ = shows