1 \section{SST: the strict state transformer monad}
2 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
6 SST, SST_R, FSST, FSST_R,
8 runSST, sstToST, stToSST, ioToSST,
9 thenSST, thenSST_, returnSST, fixSST,
10 thenFSST, thenFSST_, returnFSST, failFSST,
11 recoverFSST, recoverSST, fixFSST,
14 newMutVarSST, readMutVarSST, writeMutVarSST,
18 #include "HsVersions.h"
23 #if __GLASGOW_HASKELL__ < 301
24 import STBase ( ST(..), STret(..), StateAndPtr#(..) )
25 import ArrBase ( StateAndMutableArray#(..) )
26 import IOBase ( IO(..), IOResult(..) )
27 #elif __GLASGOW_HASKELL__ < 400
28 import PrelST ( ST(..), STret(..), StateAndPtr#(..) )
29 import PrelArr ( StateAndMutableArray#(..) )
30 import PrelIOBase ( IO(..), IOResult(..) )
32 import PrelST ( ST(..), STret(..) )
33 import PrelArr ( MutableVar(..) )
34 import PrelIOBase ( IO(..) )
39 @SST@ is very like the standard @ST@ monad, but it comes with its
40 friend @FSST@. Because we want the monadic bind operator to work
41 for mixtures of @SST@ and @FSST@, we can't use @ST@ at all.
43 For simplicity we don't even dress them up in newtypes.
45 %************************************************************************
47 \subsection{The data types}
49 %************************************************************************
52 type SST s r = State# s -> SST_R s r
53 type FSST s r err = State# s -> FSST_R s r err
55 data SST_R s r = SST_R r (State# s)
58 = FSST_R_OK r (State# s)
59 | FSST_R_Fail err (State# s)
65 sstToST :: SST s r -> ST s r
66 stToSST :: ST s r -> SST s r
69 #if __GLASGOW_HASKELL__ < 400
70 stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s'
71 sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
73 stToSST (ST st) = \ s -> case st s of (# s', r #) -> SST_R r s'
74 sstToST sst = ST (\ s -> case sst s of SST_R r s' -> (# s', r #))
81 ioToSST :: IO a -> SST RealWorld (Either IOError a)
83 #if __GLASGOW_HASKELL__ < 400
86 IOok s' r -> SST_R (Right r) s'
87 IOfail s' err -> SST_R (Left err) s'
90 -- We should probably be using ST and exceptions instead of SST here, now
91 -- that GHC has exceptions and ST is strict.
94 = \s -> case catch (io >>= return . Right) (return . Left) of { IO m ->
96 (# s', r #) -> SST_R r s'
102 %************************************************************************
104 \subsection{The @SST@ operations}
106 %************************************************************************
109 -- Type of runSST should be builtin ...
110 -- runSST :: forall r. (forall s. SST s r) -> r
112 runSST :: SST RealWorld r -> r
113 runSST m = case m realWorld# of SST_R r s -> r
115 unsafeInterleaveSST :: SST s r -> SST s r
116 unsafeInterleaveSST m s = SST_R r s -- Duplicates the state!
120 returnSST :: r -> SST s r
121 fixSST :: (r -> SST s r) -> SST s r
122 {-# INLINE returnSST #-}
123 {-# INLINE thenSST #-}
124 {-# INLINE thenSST_ #-}
126 returnSST r s = SST_R r s
131 SST_R loop _ = result
134 OK, here comes the clever bind operator.
137 thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
138 thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
140 -- thenSST :: SST s r -> (r -> SST s r') -> SST s r'
141 -- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
144 -- thenSST_ :: SST s r -> SST s r' -> SST s r'
145 -- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
147 thenSST m k s = case m s of { SST_R r s' -> k r s' }
149 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
153 %************************************************************************
155 \subsection{FSST: the failable strict state transformer monad}
157 %************************************************************************
160 failFSST :: err -> FSST s r err
161 fixFSST :: (r -> FSST s r err) -> FSST s r err
162 recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
163 recoverSST :: (err -> SST s r) -> FSST s r err -> SST s r
164 returnFSST :: r -> FSST s r err
165 thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
166 thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
167 {-# INLINE failFSST #-}
168 {-# INLINE returnFSST #-}
169 {-# INLINE thenFSST #-}
170 {-# INLINE thenFSST_ #-}
172 thenFSST m k s = case m s of
173 FSST_R_OK r s' -> k r s'
174 FSST_R_Fail err s' -> FSST_R_Fail err s'
176 thenFSST_ m k s = case m s of
177 FSST_R_OK r s' -> k s'
178 FSST_R_Fail err s' -> FSST_R_Fail err s'
180 returnFSST r s = FSST_R_OK r s
182 failFSST err s = FSST_R_Fail err s
184 recoverFSST recovery_fn m s
186 FSST_R_OK r s' -> FSST_R_OK r s'
187 FSST_R_Fail err s' -> recovery_fn err s'
189 recoverSST recovery_fn m s
191 FSST_R_OK r s' -> SST_R r s'
192 FSST_R_Fail err s' -> recovery_fn err s'
197 FSST_R_OK loop _ = result
200 %************************************************************************
202 \subsection{Mutables}
204 %************************************************************************
206 Here we implement mutable variables.
209 #if __GLASGOW_HASKELL__ < 400
210 type SSTRef s a = MutableArray s Int a
212 type SSTRef s a = MutableVar s a
215 newMutVarSST :: a -> SST s (SSTRef s a)
216 readMutVarSST :: SSTRef s a -> SST s a
217 writeMutVarSST :: SSTRef s a -> a -> SST s ()
219 #if __GLASGOW_HASKELL__ < 400
222 = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
223 SST_R (MutableArray vAR_IXS arr#) s2# }
225 vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
227 readMutVarSST (MutableArray _ var#) s#
228 = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
231 writeMutVarSST (MutableArray _ var#) val s#
232 = case writeArray# var# 0# val s# of { s2# ->
238 = case (newMutVar# init s#) of { (# s2#, var# #) ->
239 SST_R (MutableVar var#) s2# }
241 readMutVarSST (MutableVar var#) s#
242 = case readMutVar# var# s# of { (# s2#, r #) ->
245 writeMutVarSST (MutableVar var#) val s#
246 = case writeMutVar# var# val s# of { s2# ->