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'