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,
15 newMutVarSST, readMutVarSST, writeMutVarSST
16 #if __GLASGOW_HASKELL__ >= 200
19 , MutableVar(..), _MutableArray
23 #if __GLASGOW_HASKELL__ >= 200
26 import PreludeGlaST ( MutableVar(..), _MutableArray(..), ST(..) )
29 CHK_Ubiq() -- debugging consistency check
33 data SST_R s r = SST_R r (State# s)
34 type SST s r = State# s -> SST_R s r
39 -- converting to/from ST
41 sstToST :: SST s r -> ST s r
42 stToSST :: ST s r -> SST s r
44 #if __GLASGOW_HASKELL__ >= 200
46 sstToST sst = ST $ \ (S# s) ->
47 case sst s of SST_R r s' -> (r, S# s')
49 stToSST (ST st) = \ s ->
50 case st (S# s) of (r, S# s') -> SST_R r s'
54 = case sst s of SST_R r s' -> (r, S# s')
56 = case st (S# s) of (r, S# s') -> SST_R r s'
59 -- Type of runSST should be builtin ...
60 -- runSST :: forall r. (forall s. SST s r) -> r
62 #if __GLASGOW_HASKELL__ >= 200
63 # define REAL_WORLD RealWorld
64 # define MUT_ARRAY MutableArray
66 # define REAL_WORLD _RealWorld
67 # define MUT_ARRAY _MutableArray
70 runSST :: SST REAL_WORLD r -> r
71 runSST m = case m realWorld# of SST_R r s -> r
73 returnSST :: r -> SST s r
74 thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
75 thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
76 fixSST :: (r -> SST s r) -> SST s r
77 {-# INLINE returnSST #-}
78 {-# INLINE thenSST #-}
79 {-# INLINE thenSST_ #-}
82 -- thenSST :: SST s r -> (r -> SST s r') -> SST s r'
83 -- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
86 -- thenSST_ :: SST s r -> SST s r' -> SST s r'
87 -- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
89 thenSST m k s = case m s of { SST_R r s' -> k r s' }
91 thenSST_ m k s = case m s of { SST_R r s' -> k s' }
93 returnSST r s = SST_R r s
102 \section{FSST: the failable strict state transformer monad}
103 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
107 = FSST_R_OK r (State# s)
108 | FSST_R_Fail err (State# s)
110 type FSST s r err = State# s -> FSST_R s r err
114 failFSST :: err -> FSST s r err
115 fixFSST :: (r -> FSST s r err) -> FSST s r err
116 recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
117 recoverSST :: (err -> SST s r) -> FSST s r err -> SST s r
118 returnFSST :: r -> FSST s r err
119 thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
120 thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
121 {-# INLINE failFSST #-}
122 {-# INLINE returnFSST #-}
123 {-# INLINE thenFSST #-}
124 {-# INLINE thenFSST_ #-}
126 thenFSST m k s = case m s of
127 FSST_R_OK r s' -> k r s'
128 FSST_R_Fail err s' -> FSST_R_Fail err s'
130 thenFSST_ m k s = case m s of
131 FSST_R_OK r s' -> k s'
132 FSST_R_Fail err s' -> FSST_R_Fail err s'
134 returnFSST r s = FSST_R_OK r s
136 failFSST err s = FSST_R_Fail err s
138 recoverFSST recovery_fn m s
140 FSST_R_OK r s' -> FSST_R_OK r s'
141 FSST_R_Fail err s' -> recovery_fn err s'
143 recoverSST recovery_fn m s
145 FSST_R_OK r s' -> SST_R r s'
146 FSST_R_Fail err s' -> recovery_fn err s'
151 FSST_R_OK loop _ = result
156 Here we implement mutable variables. ToDo: get rid of the array impl.
159 newMutVarSST :: a -> SST s (MutableVar s a)
160 readMutVarSST :: MutableVar s a -> SST s a
161 writeMutVarSST :: MutableVar s a -> a -> SST s ()
164 = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
165 SST_R (MUT_ARRAY vAR_IXS arr#) s2# }
167 vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
169 readMutVarSST (MUT_ARRAY _ var#) s#
170 = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
173 writeMutVarSST (MUT_ARRAY _ var#) val s#
174 = case writeArray# var# 0# val s# of { s2# ->