compiler/cmm/CmmTx.hs

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