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(..) )
28 import PrelST ( ST(..), STret(..), StateAndPtr#(..) )
29 import PrelArr ( StateAndMutableArray#(..) )
30 import PrelIOBase ( IO(..), IOResult(..) )
35 @SST@ is very like the standard @ST@ monad, but it comes with its
36 friend @FSST@. Because we want the monadic bind operator to work
37 for mixtures of @SST@ and @FSST@, we can't use @ST@ at all.
39 For simplicity we don't even dress them up in newtypes.
41 %************************************************************************
43 \subsection{The data types}
45 %************************************************************************
48 type SST s r = State# s -> SST_R s r
49 type FSST s r err = State# s -> FSST_R s r err
51 data SST_R s r = SST_R r (State# s)
54 = FSST_R_OK r (State# s)
55 | FSST_R_Fail err (State# s)
61 sstToST :: SST s r -> ST s r
62 stToSST :: ST s r -> SST s r
64 sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
66 stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s'
72 ioToSST :: IO a -> SST RealWorld (Either IOError a)
75 IOok s' r -> SST_R (Right r) s'
76 IOfail s' err -> SST_R (Left err) s'
79 %************************************************************************
81 \subsection{The @SST@ operations}
83 %************************************************************************
86 -- Type of runSST should be builtin ...
87 -- runSST :: forall r. (forall s. SST s r) -> r
89 runSST :: SST RealWorld r -> r
90 runSST m = case m realWorld# of SST_R r s -> r
92 unsafeInterleaveSST :: SST s r -> SST s r
93 unsafeInterleaveSST m s = SST_R r s -- Duplicates the state!
97 returnSST :: r -> SST s r
98 fixSST :: (r -> SST s r) -> SST s r
99 {-# INLINE returnSST #-}
100 {-# INLINE thenSST #-}
101 {-# INLINE thenSST_ #-}
103 returnSST r s = SST_R r s
108 SST_R loop _ = result
111 OK, here comes the clever bind operator.
114 thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
115 thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
117 -- thenSST :: SST s r -> (r -> SST s r') -> SST s r'
118 -- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
121 -- thenSST_ :: SST s r -> SST s r' -> SST s r'
122 -- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
124 thenSST m k s = case m s of { SST_R r s' -> k r s' }
126 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
130 %************************************************************************
132 \subsection{FSST: the failable strict state transformer monad}
134 %************************************************************************
137 failFSST :: err -> FSST s r err
138 fixFSST :: (r -> FSST s r err) -> FSST s r err
139 recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
140 recoverSST :: (err -> SST s r) -> FSST s r err -> SST s r
141 returnFSST :: r -> FSST s r err
142 thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
143 thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
144 {-# INLINE failFSST #-}
145 {-# INLINE returnFSST #-}
146 {-# INLINE thenFSST #-}
147 {-# INLINE thenFSST_ #-}
149 thenFSST m k s = case m s of
150 FSST_R_OK r s' -> k r s'
151 FSST_R_Fail err s' -> FSST_R_Fail err s'
153 thenFSST_ m k s = case m s of
154 FSST_R_OK r s' -> k s'
155 FSST_R_Fail err s' -> FSST_R_Fail err s'
157 returnFSST r s = FSST_R_OK r s
159 failFSST err s = FSST_R_Fail err s
161 recoverFSST recovery_fn m s
163 FSST_R_OK r s' -> FSST_R_OK r s'
164 FSST_R_Fail err s' -> recovery_fn err s'
166 recoverSST recovery_fn m s
168 FSST_R_OK r s' -> SST_R r s'
169 FSST_R_Fail err s' -> recovery_fn err s'
174 FSST_R_OK loop _ = result
177 %************************************************************************
179 \subsection{Mutables}
181 %************************************************************************
183 Here we implement mutable variables. ToDo: get rid of the array impl.
186 type SSTRef s a = MutableArray s Int a
188 newMutVarSST :: a -> SST s (SSTRef s a)
189 readMutVarSST :: SSTRef s a -> SST s a
190 writeMutVarSST :: SSTRef s a -> a -> SST s ()
193 = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
194 SST_R (MutableArray vAR_IXS arr#) s2# }
196 vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
198 readMutVarSST (MutableArray _ var#) s#
199 = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
202 writeMutVarSST (MutableArray _ var#) val s#
203 = case writeArray# var# 0# val s# of { s2# ->