blob: d9733b8593c9f1422baaa05a88824de07f45cb8c (
plain)
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
|
module CmmTx where
data ChangeFlag = NoChange | SomeChange
type Tx a = a -> TxRes a
data TxRes a = TxRes ChangeFlag a
seqTx :: Tx a -> Tx a -> Tx a
iterateTx :: Tx a -> Tx a
runTx :: Tx a -> a -> a
noTx, aTx :: a -> TxRes a
noTx x = TxRes NoChange x
aTx x = TxRes SomeChange x
replaceTx :: a -> TxRes b -> TxRes a
replaceTx a (TxRes change _) = TxRes change a
txVal :: TxRes a -> a
txVal (TxRes _ a) = a
txHasChanged :: TxRes a -> Bool
txHasChanged (TxRes NoChange _) = False
txHasChanged (TxRes SomeChange _) = True
plusTx :: (a -> b -> c) -> TxRes a -> TxRes b -> TxRes c
plusTx f (TxRes c1 a) (TxRes c2 b) = TxRes (c1 `orChange` c2) (f a b)
mapTx :: Tx a -> Tx [a]
mapTx _ [] = noTx []
mapTx f (x:xs) = plusTx (:) (f x) (mapTx f xs)
runTx f = txVal . f
seqTx f1 f2 a =
let TxRes c1 a1 = f1 a
TxRes c2 a2 = f2 a1
in TxRes (c1 `orChange` c2) a2
iterateTx f a
= case f a of
TxRes NoChange a' -> TxRes NoChange a'
TxRes SomeChange a' -> let TxRes _ a'' = iterateTx f a'
in TxRes SomeChange a''
orChange :: ChangeFlag -> ChangeFlag -> ChangeFlag
orChange NoChange c = c
orChange SomeChange _ = SomeChange
instance Functor TxRes where
fmap f (TxRes ch a) = TxRes ch (f a)
instance Monad TxRes where
return = TxRes NoChange
(TxRes NoChange a) >>= k = k a
(TxRes SomeChange a) >>= k = let (TxRes _ a') = k a in TxRes SomeChange a'
|