1 \section{SST: the strict state transformer monad}
2 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
5 #include "HsVersions.h"
8 SYN_IE(SST), SST_R, SYN_IE(FSST), FSST_R,
10 runSST, sstToST, stToSST,
11 thenSST, thenSST_, returnSST, fixSST,
12 thenFSST, thenFSST_, returnFSST, failFSST,
13 recoverFSST, recoverSST, fixFSST,
16 newMutVarSST, readMutVarSST, writeMutVarSST
17 #if __GLASGOW_HASKELL__ >= 200
20 , MutableVar(..), _MutableArray
24 #if __GLASGOW_HASKELL__ == 201
26 #elif __GLASGOW_HASKELL__ >= 202
32 import PreludeGlaST ( MutableVar(..), _MutableArray(..), ST(..) )
35 CHK_Ubiq() -- debugging consistency check
39 data SST_R s r = SST_R r (State# s)
40 type SST s r = State# s -> SST_R s r
45 -- converting to/from ST
47 sstToST :: SST s r -> ST s r
48 stToSST :: ST s r -> SST s r
50 #if __GLASGOW_HASKELL__ >= 200 && __GLASGOW_HASKELL__ < 209
52 sstToST sst = ST $ \ (S# s) ->
53 case sst s of SST_R r s' -> (r, S# s')
55 stToSST (ST st) = \ s ->
56 case st (S# s) of (r, S# s') -> SST_R r s'
58 #elif __GLASGOW_HASKELL__ >= 209
60 sstToST sst = ST $ \ s ->
61 case sst s of SST_R r s' -> STret s' r
63 stToSST (ST st) = \ s ->
64 case st s of STret s' r -> SST_R r s'
68 = case sst s of SST_R r s' -> (r, S# s')
70 = case st (S# s) of (r, S# s') -> SST_R r s'
73 -- Type of runSST should be builtin ...
74 -- runSST :: forall r. (forall s. SST s r) -> r
76 #if __GLASGOW_HASKELL__ >= 200
77 # define REAL_WORLD RealWorld
78 # define MUT_ARRAY MutableArray
80 # define REAL_WORLD _RealWorld
81 # define MUT_ARRAY _MutableArray
84 runSST :: SST REAL_WORLD r -> r
85 runSST m = case m realWorld# of SST_R r s -> r
87 unsafeInterleaveSST :: SST s r -> SST s r
88 unsafeInterleaveSST m s = SST_R r s -- Duplicates the state!
92 returnSST :: r -> SST s r
93 thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
94 thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
95 fixSST :: (r -> SST s r) -> SST s r
96 {-# INLINE returnSST #-}
97 {-# INLINE thenSST #-}
98 {-# INLINE thenSST_ #-}
101 -- thenSST :: SST s r -> (r -> SST s r') -> SST s r'
102 -- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
105 -- thenSST_ :: SST s r -> SST s r' -> SST s r'
106 -- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
108 thenSST m k s = case m s of { SST_R r s' -> k r s' }
110 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
112 returnSST r s = SST_R r s
117 SST_R loop _ = result
121 \section{FSST: the failable strict state transformer monad}
122 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
126 = FSST_R_OK r (State# s)
127 | FSST_R_Fail err (State# s)
129 type FSST s r err = State# s -> FSST_R s r err
133 failFSST :: err -> FSST s r err
134 fixFSST :: (r -> FSST s r err) -> FSST s r err
135 recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
136 recoverSST :: (err -> SST s r) -> FSST s r err -> SST s r
137 returnFSST :: r -> FSST s r err
138 thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
139 thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
140 {-# INLINE failFSST #-}
141 {-# INLINE returnFSST #-}
142 {-# INLINE thenFSST #-}
143 {-# INLINE thenFSST_ #-}
145 thenFSST m k s = case m s of
146 FSST_R_OK r s' -> k r s'
147 FSST_R_Fail err s' -> FSST_R_Fail err s'
149 thenFSST_ m k s = case m s of
150 FSST_R_OK r s' -> k s'
151 FSST_R_Fail err s' -> FSST_R_Fail err s'
153 returnFSST r s = FSST_R_OK r s
155 failFSST err s = FSST_R_Fail err s
157 recoverFSST recovery_fn m s
159 FSST_R_OK r s' -> FSST_R_OK r s'
160 FSST_R_Fail err s' -> recovery_fn err s'
162 recoverSST recovery_fn m s
164 FSST_R_OK r s' -> SST_R r s'
165 FSST_R_Fail err s' -> recovery_fn err s'
170 FSST_R_OK loop _ = result
175 Here we implement mutable variables. ToDo: get rid of the array impl.
178 newMutVarSST :: a -> SST s (MutableVar s a)
179 readMutVarSST :: MutableVar s a -> SST s a
180 writeMutVarSST :: MutableVar s a -> a -> SST s ()
183 = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
184 SST_R (MUT_ARRAY vAR_IXS arr#) s2# }
186 vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
188 readMutVarSST (MUT_ARRAY _ var#) s#
189 = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
192 writeMutVarSST (MUT_ARRAY _ var#) val s#
193 = case writeArray# var# 0# val s# of { s2# ->