2
2
{-# LANGUAGE RankNTypes #-}
3
3
{-# LANGUAGE ScopedTypeVariables #-}
4
4
5
- module Cardano.Mock.Chain
6
- ( Chain' (.. )
7
- , State
8
- , Chain
9
- , getTipState
10
- , successorBlock
11
- , pointOnChain
12
- , rollback
13
- , findFirstPointChain
14
- , pointIsAfter
15
- , findFirstPointByBlockNo
16
- , currentTipBlockNo
17
- ) where
18
-
19
- import Ouroboros.Consensus.Block
5
+ module Cardano.Mock.Chain (
6
+ Chain' (.. ),
7
+ State ,
8
+ Chain ,
9
+ getTipState ,
10
+ successorBlock ,
11
+ pointOnChain ,
12
+ rollback ,
13
+ findFirstPointChain ,
14
+ pointIsAfter ,
15
+ findFirstPointByBlockNo ,
16
+ currentTipBlockNo ,
17
+ ) where
18
+
19
+ import Ouroboros.Consensus.Block
20
20
import qualified Ouroboros.Consensus.Ledger.Extended as Consensus
21
-
22
21
import qualified Ouroboros.Network.AnchoredFragment as AF
23
- import Ouroboros.Network.Block
22
+ import Ouroboros.Network.Block
24
23
25
24
-- | This looks a lot like the 'Chain' defined in Ouroboros.Network.MockChain.Chain
26
25
-- but this version includes also the ledger states.
27
- data Chain' block st =
28
- Genesis st
26
+ data Chain' block st
27
+ = Genesis st
29
28
| Chain' block st :> (block , st )
30
29
deriving (Eq , Ord , Show , Functor )
31
30
@@ -39,44 +38,47 @@ getTipState :: Chain' blk st -> st
39
38
getTipState (Genesis st) = st
40
39
getTipState (_ :> (_, st)) = st
41
40
42
- successorBlock :: forall block . HasHeader block => Point block -> Chain block -> Maybe block
41
+ successorBlock :: forall block . HasHeader block => Point block -> Chain block -> Maybe block
43
42
successorBlock p c0 | headPoint c0 == p = Nothing
44
43
successorBlock p c0 =
45
- go c0
44
+ go c0
46
45
where
47
46
go :: Chain block -> Maybe block
48
- go (c :> (b',st') :> (b, _)) | blockPoint b' == p = Just b
49
- | otherwise = go (c :> (b',st'))
50
- go (Genesis _ :> (b, _)) | p == genesisPoint = Just b
47
+ go (c :> (b', st') :> (b, _))
48
+ | blockPoint b' == p = Just b
49
+ | otherwise = go (c :> (b', st'))
50
+ go (Genesis _ :> (b, _)) | p == genesisPoint = Just b
51
51
go _ = Nothing
52
52
53
53
pointOnChain :: HasHeader block => Point block -> Chain block -> Bool
54
- pointOnChain GenesisPoint _ = True
55
- pointOnChain (BlockPoint _ _) (Genesis _) = False
54
+ pointOnChain GenesisPoint _ = True
55
+ pointOnChain (BlockPoint _ _) (Genesis _) = False
56
56
pointOnChain p@ (BlockPoint pslot phash) (c :> (b, _))
57
- | pslot > blockSlot b = False
57
+ | pslot > blockSlot b = False
58
58
| phash == blockHash b = True
59
- | otherwise = pointOnChain p c
59
+ | otherwise = pointOnChain p c
60
60
61
61
headPoint :: HasHeader block => Chain block -> Point block
62
62
headPoint (Genesis _) = genesisPoint
63
- headPoint (_ :> (b, _)) = blockPoint b
64
-
65
- findFirstPointChain
66
- :: HasHeader block
67
- => [Point block ]
68
- -> Chain block
69
- -> Maybe (Point block )
70
- findFirstPointChain [] _ = Nothing
71
- findFirstPointChain (p: ps) c
72
- | pointOnChain p c = Just p
73
- | otherwise = findFirstPointChain ps c
63
+ headPoint (_ :> (b, _)) = blockPoint b
64
+
65
+ findFirstPointChain ::
66
+ HasHeader block =>
67
+ [Point block ] ->
68
+ Chain block ->
69
+ Maybe (Point block )
70
+ findFirstPointChain [] _ = Nothing
71
+ findFirstPointChain (p : ps) c
72
+ | pointOnChain p c = Just p
73
+ | otherwise = findFirstPointChain ps c
74
74
75
75
rollback :: HasHeader block => Chain block -> Point block -> Maybe (Chain block )
76
- rollback (c :> (b, st)) p | blockPoint b == p = Just (c :> (b, st))
77
- | otherwise = rollback c p
78
- rollback (Genesis st) p | p == genesisPoint = Just (Genesis st)
79
- | otherwise = Nothing
76
+ rollback (c :> (b, st)) p
77
+ | blockPoint b == p = Just (c :> (b, st))
78
+ | otherwise = rollback c p
79
+ rollback (Genesis st) p
80
+ | p == genesisPoint = Just (Genesis st)
81
+ | otherwise = Nothing
80
82
81
83
-- | Check whether the first point is after the second point on the chain.
82
84
-- Usually, this can simply be checked using the 'SlotNo's, but some blocks
@@ -85,16 +87,21 @@ rollback (Genesis st) p | p == genesisPoint = Just (Genesis st)
85
87
-- When the first point equals the second point, the answer will be 'False'.
86
88
--
87
89
-- PRECONDITION: both points are on the chain.
88
- pointIsAfter :: HasHeader block
89
- => Point block -> Point block -> Chain block -> Bool
90
+ pointIsAfter ::
91
+ HasHeader block =>
92
+ Point block ->
93
+ Point block ->
94
+ Chain block ->
95
+ Bool
90
96
pointIsAfter pt1 pt2 c =
91
- case pointSlot pt1 `compare` pointSlot pt2 of
92
- LT -> False
93
- GT -> True
94
- EQ | Just (_, afterPt2) <- AF. splitAfterPoint (toAnchoredFragment c) pt2
95
- -> AF. pointOnFragment pt1 afterPt2
96
- | otherwise
97
- -> False
97
+ case pointSlot pt1 `compare` pointSlot pt2 of
98
+ LT -> False
99
+ GT -> True
100
+ EQ
101
+ | Just (_, afterPt2) <- AF. splitAfterPoint (toAnchoredFragment c) pt2 ->
102
+ AF. pointOnFragment pt1 afterPt2
103
+ | otherwise ->
104
+ False
98
105
99
106
-- * Conversions to/from 'AnchoredFragment'
100
107
@@ -109,19 +116,18 @@ toOldestFirst :: Chain block -> [block]
109
116
toOldestFirst = reverse . toNewestFirst
110
117
111
118
-- | Produce the list of blocks, from most recent back to genesis
112
- --
113
119
toNewestFirst :: Chain block -> [block ]
114
120
toNewestFirst = foldChain (flip (:) ) []
115
121
116
122
foldChain :: (a -> b -> a ) -> a -> Chain b -> a
117
123
foldChain _blk gen (Genesis _st) = gen
118
- foldChain blk gen (c :> (b, _)) = blk (foldChain blk gen c) b
124
+ foldChain blk gen (c :> (b, _)) = blk (foldChain blk gen c) b
119
125
120
- findFirstPointByBlockNo
121
- :: HasHeader block
122
- => Chain block
123
- -> BlockNo
124
- -> Maybe (Point block )
126
+ findFirstPointByBlockNo ::
127
+ HasHeader block =>
128
+ Chain block ->
129
+ BlockNo ->
130
+ Maybe (Point block )
125
131
findFirstPointByBlockNo c blkNo = case c of
126
132
Genesis _ -> Nothing
127
133
(_ :> (b, _)) | blockNo b == blkNo -> Just $ blockPoint b
0 commit comments