compiler/cmm/CmmTx.hs

   1 module CmmTx where
   2
   3 data ChangeFlag = NoChange | SomeChange
   4
   5 type Tx a    = a -> TxRes a
   6 data TxRes a = TxRes ChangeFlag a
   7
   8 seqTx :: Tx a -> Tx a -> Tx a
   9 iterateTx :: Tx a -> Tx a
  10 runTx :: Tx a -> a -> a
  11
  12 noTx, aTx :: a -> TxRes a
  13 noTx x = TxRes NoChange   x
  14 aTx  x = TxRes SomeChange x
  15
  16 replaceTx :: a -> TxRes b -> TxRes a
  17 replaceTx a (TxRes change _) = TxRes change a
  18
  19 txVal :: TxRes a -> a
  20 txVal (TxRes _ a) = a
  21
  22 txHasChanged :: TxRes a -> Bool
  23 txHasChanged (TxRes NoChange   _) = False
  24 txHasChanged (TxRes SomeChange _) = True
  25
  26 plusTx :: (a -> b -> c) -> TxRes a -> TxRes b -> TxRes c
  27 plusTx f (TxRes c1 a) (TxRes c2 b) = TxRes (c1 `orChange` c2) (f a b)
  28
  29 mapTx :: Tx a -> Tx [a]
  30 mapTx _ []     = noTx []
  31 mapTx f (x:xs) = plusTx (:) (f x) (mapTx f xs)
  32
  33 runTx f = txVal . f
  34
  35 seqTx f1 f2 a =
  36     let TxRes c1 a1 = f1 a
  37         TxRes c2 a2 = f2 a1
  38     in  TxRes (c1 `orChange` c2) a2
  39
  40 iterateTx f a
  41   = case f a of
  42         TxRes NoChange   a' -> TxRes NoChange a'
  43         TxRes SomeChange a' -> let TxRes _ a'' = iterateTx f a'
  44                              in TxRes SomeChange a''
  45
  46 orChange :: ChangeFlag -> ChangeFlag -> ChangeFlag
  47 orChange NoChange   c = c
  48 orChange SomeChange _ = SomeChange
  49
  50
  51
  52 instance Functor TxRes where
  53   fmap f (TxRes ch a) = TxRes ch (f a)
  54
  55 instance Monad TxRes where
  56     return = TxRes NoChange
  57     (TxRes NoChange a) >>= k = k a
  58     (TxRes SomeChange a) >>= k = let (TxRes _ a') = k a in TxRes SomeChange a'