ghc/compiler/utils/SST.lhs

   1 \section{SST: the strict state transformer monad}
   2 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   3
   4 \begin{code}
   5 #include "HsVersions.h"
   6
   7 module SST(
   8         SST(..), SST_R, FSST(..), FSST_R,
   9
  10         _runSST, sstToST, stToSST,
  11         thenSST, thenSST_, returnSST, fixSST,
  12         thenFSST, thenFSST_, returnFSST, failFSST,
  13         recoverFSST, recoverSST, fixFSST,
  14
  15         MutableVar(..), _MutableArray,
  16         newMutVarSST, readMutVarSST, writeMutVarSST
  17   ) where
  18
  19 import PreludeGlaST( MutableVar(..), _MutableArray(..), ST(..) )
  20
  21 CHK_Ubiq() -- debugging consistency check
  22 \end{code}
  23
  24 \begin{code}
  25 data SST_R s r = SST_R r (State# s)
  26 type SST   s r = State# s -> SST_R s r
  27 \end{code}
  28
  29 \begin{code}
  30 -- converting to/from ST
  31
  32 sstToST :: SST s r -> ST s r
  33 stToSST :: ST s r -> SST s r
  34
  35 sstToST sst (S# s)
  36   = case sst s of SST_R r s' -> (r, S# s')
  37 stToSST st s
  38   = case st (S# s) of (r, S# s') -> SST_R r s'
  39
  40
  41 -- Type of runSST should be builtin ...
  42 -- runSST :: forall r. (forall s. SST s r) -> r
  43
  44 _runSST :: SST _RealWorld r -> r
  45 _runSST m = case m realWorld# of SST_R r s -> r
  46
  47
  48 thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
  49 {-# INLINE thenSST #-}
  50 -- Hence:
  51 --      thenSST :: SST s r -> (r -> SST  s r')     -> SST  s r'
  52 -- and  thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
  53
  54 thenSST m k s = case m s of { SST_R r s' -> k r s' }
  55
  56 thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
  57 {-# INLINE thenSST_ #-}
  58 -- Hence:
  59 --      thenSST_ :: SST s r -> SST  s r'     -> SST  s r'
  60 -- and  thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
  61
  62 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
  63
  64 returnSST :: r -> SST s r
  65 {-# INLINE returnSST #-}
  66 returnSST r s = SST_R r s
  67
  68 fixSST :: (r -> SST s r) -> SST s r
  69 fixSST m s = result
  70            where
  71              result       = m loop s
  72              SST_R loop _ = result
  73 \end{code}
  74
  75
  76 \section{FSST: the failable strict state transformer monad}
  77 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  78
  79 \begin{code}
  80 data FSST_R s r err = FSST_R_OK   r   (State# s)
  81                     | FSST_R_Fail err (State# s)
  82
  83 type FSST   s r err = State# s -> FSST_R s r err
  84 \end{code}
  85
  86 \begin{code}
  87 thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
  88 {-# INLINE thenFSST #-}
  89 thenFSST m k s = case m s of
  90                    FSST_R_OK r s'     -> k r s'
  91                    FSST_R_Fail err s' -> FSST_R_Fail err s'
  92
  93 thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
  94 {-# INLINE thenFSST_ #-}
  95 thenFSST_ m k s = case m s of
  96                     FSST_R_OK r s'     -> k s'
  97                     FSST_R_Fail err s' -> FSST_R_Fail err s'
  98
  99 returnFSST :: r -> FSST s r err
 100 {-# INLINE returnFSST #-}
 101 returnFSST r s = FSST_R_OK r s
 102
 103 failFSST    :: err -> FSST s r err
 104 {-# INLINE failFSST #-}
 105 failFSST err s = FSST_R_Fail err s
 106
 107 recoverFSST :: (err -> FSST s r err)
 108             -> FSST s r err
 109             -> FSST s r err
 110 recoverFSST recovery_fn m s
 111   = case m s of
 112         FSST_R_OK r s'     -> FSST_R_OK r s'
 113         FSST_R_Fail err s' -> recovery_fn err s'
 114
 115 recoverSST :: (err -> SST s r)
 116             -> FSST s r err
 117             -> SST s r
 118 recoverSST recovery_fn m s
 119   = case m s of
 120         FSST_R_OK r s'     -> SST_R r s'
 121         FSST_R_Fail err s' -> recovery_fn err s'
 122
 123 fixFSST :: (r -> FSST s r err) -> FSST s r err
 124 fixFSST m s = result
 125             where
 126               result           = m loop s
 127               FSST_R_OK loop _ = result
 128 \end{code}
 129
 130 Mutables
 131 ~~~~~~~~
 132 Here we implement mutable variables.  ToDo: get rid of the array impl.
 133
 134 \begin{code}
 135 newMutVarSST :: a -> SST s (MutableVar s a)
 136 newMutVarSST init s#
 137   = case (newArray# 1# init s#)     of { StateAndMutableArray# s2# arr# ->
 138     SST_R (_MutableArray vAR_IXS arr#) s2# }
 139   where
 140     vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
 141
 142 readMutVarSST :: MutableVar s a -> SST s a
 143 readMutVarSST (_MutableArray _ var#) s#
 144   = case readArray# var# 0# s#  of { StateAndPtr# s2# r ->
 145     SST_R r s2# }
 146
 147 writeMutVarSST :: MutableVar s a -> a -> SST s ()
 148 writeMutVarSST (_MutableArray _ var#) val s#
 149   = case writeArray# var# 0# val s# of { s2# ->
 150     SST_R () s2# }
 151 \end{code}
 152