+++ /dev/null
-\section{SST: the strict state transformer monad}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-module SST(
- SST, SST_R, FSST, FSST_R,
-
- runSST, sstToST, stToSST, ioToSST,
- thenSST, thenSST_, returnSST, fixSST,
- thenFSST, thenFSST_, returnFSST, failFSST,
- recoverFSST, recoverSST, fixFSST,
- unsafeInterleaveSST,
-
- newMutVarSST, readMutVarSST, writeMutVarSST,
- SSTRef
- ) where
-
-#include "HsVersions.h"
-
-import GlaExts
-import ST
-
-#if __GLASGOW_HASKELL__ < 301
-import STBase ( ST(..), STret(..), StateAndPtr#(..) )
-import ArrBase ( StateAndMutableArray#(..) )
-import IOBase ( IO(..), IOResult(..) )
-#elif __GLASGOW_HASKELL__ < 400
-import PrelST ( ST(..), STret(..), StateAndPtr#(..) )
-import PrelArr ( StateAndMutableArray#(..) )
-import PrelIOBase ( IO(..), IOResult(..) )
-#else
-import PrelST ( ST(..), STret(..) )
-import PrelArr ( MutableVar(..) )
-import PrelIOBase ( IO(..) )
-#endif
-
-\end{code}
-
-@SST@ is very like the standard @ST@ monad, but it comes with its
-friend @FSST@. Because we want the monadic bind operator to work
-for mixtures of @SST@ and @FSST@, we can't use @ST@ at all.
-
-For simplicity we don't even dress them up in newtypes.
-
-%************************************************************************
-%* *
-\subsection{The data types}
-%* *
-%************************************************************************
-
-\begin{code}
-type SST s r = State# s -> SST_R s r
-type FSST s r err = State# s -> FSST_R s r err
-
-data SST_R s r = SST_R r (State# s)
-
-data FSST_R s r err
- = FSST_R_OK r (State# s)
- | FSST_R_Fail err (State# s)
-\end{code}
-
-Converting to/from ST
-
-\begin{code}
-sstToST :: SST s r -> ST s r
-stToSST :: ST s r -> SST s r
-
-
-#if __GLASGOW_HASKELL__ < 400
-stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s'
-sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r)
-#else
-stToSST (ST st) = \ s -> case st s of (# s', r #) -> SST_R r s'
-sstToST sst = ST (\ s -> case sst s of SST_R r s' -> (# s', r #))
-#endif
-\end{code}
-
-...and IO
-
-\begin{code}
-ioToSST :: IO a -> SST RealWorld (Either IOError a)
-
-#if __GLASGOW_HASKELL__ < 400
-ioToSST (IO io)
- = \s -> case io s of
- IOok s' r -> SST_R (Right r) s'
- IOfail s' err -> SST_R (Left err) s'
-#else
-
--- We should probably be using ST and exceptions instead of SST here, now
--- that GHC has exceptions and ST is strict.
-
-ioToSST io
- = \s -> case catch (io >>= return . Right) (return . Left) of { IO m ->
- case m s of {
- (# s', r #) -> SST_R r s'
- } }
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @SST@ operations}
-%* *
-%************************************************************************
-
-\begin{code}
--- Type of runSST should be builtin ...
--- runSST :: forall r. (forall s. SST s r) -> r
-
-runSST :: SST RealWorld r -> r
-runSST m = case m realWorld# of SST_R r s -> r
-
-unsafeInterleaveSST :: SST s r -> SST s r
-unsafeInterleaveSST m s = SST_R r s -- Duplicates the state!
- where
- SST_R r _ = m s
-
-returnSST :: r -> SST s r
-fixSST :: (r -> SST s r) -> SST s r
-{-# INLINE returnSST #-}
-{-# INLINE thenSST #-}
-{-# INLINE thenSST_ #-}
-
-returnSST r s = SST_R r s
-
-fixSST m s = result
- where
- result = m loop s
- SST_R loop _ = result
-\end{code}
-
-OK, here comes the clever bind operator.
-
-\begin{code}
-thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b
-thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b
--- Hence:
--- thenSST :: SST s r -> (r -> SST s r') -> SST s r'
--- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err
-
--- Hence:
--- thenSST_ :: SST s r -> SST s r' -> SST s r'
--- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err
-
-thenSST m k s = case m s of { SST_R r s' -> k r s' }
-
-thenSST_ m k s = case m s of { SST_R r s' -> k s' }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{FSST: the failable strict state transformer monad}
-%* *
-%************************************************************************
-
-\begin{code}
-failFSST :: err -> FSST s r err
-fixFSST :: (r -> FSST s r err) -> FSST s r err
-recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err
-recoverSST :: (err -> SST s r) -> FSST s r err -> SST s r
-returnFSST :: r -> FSST s r err
-thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err
-thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err
-{-# INLINE failFSST #-}
-{-# INLINE returnFSST #-}
-{-# INLINE thenFSST #-}
-{-# INLINE thenFSST_ #-}
-
-thenFSST m k s = case m s of
- FSST_R_OK r s' -> k r s'
- FSST_R_Fail err s' -> FSST_R_Fail err s'
-
-thenFSST_ m k s = case m s of
- FSST_R_OK r s' -> k s'
- FSST_R_Fail err s' -> FSST_R_Fail err s'
-
-returnFSST r s = FSST_R_OK r s
-
-failFSST err s = FSST_R_Fail err s
-
-recoverFSST recovery_fn m s
- = case m s of
- FSST_R_OK r s' -> FSST_R_OK r s'
- FSST_R_Fail err s' -> recovery_fn err s'
-
-recoverSST recovery_fn m s
- = case m s of
- FSST_R_OK r s' -> SST_R r s'
- FSST_R_Fail err s' -> recovery_fn err s'
-
-fixFSST m s = result
- where
- result = m loop s
- FSST_R_OK loop _ = result
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Mutables}
-%* *
-%************************************************************************
-
-Here we implement mutable variables.
-
-\begin{code}
-#if __GLASGOW_HASKELL__ < 400
-type SSTRef s a = MutableArray s Int a
-#else
-type SSTRef s a = MutableVar s a
-#endif
-
-newMutVarSST :: a -> SST s (SSTRef s a)
-readMutVarSST :: SSTRef s a -> SST s a
-writeMutVarSST :: SSTRef s a -> a -> SST s ()
-
-#if __GLASGOW_HASKELL__ < 400
-
-newMutVarSST init s#
- = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
- SST_R (MutableArray vAR_IXS arr#) s2# }
- where
- vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
-
-readMutVarSST (MutableArray _ var#) s#
- = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
- SST_R r s2# }
-
-writeMutVarSST (MutableArray _ var#) val s#
- = case writeArray# var# 0# val s# of { s2# ->
- SST_R () s2# }
-
-#else
-
-newMutVarSST init s#
- = case (newMutVar# init s#) of { (# s2#, var# #) ->
- SST_R (MutableVar var#) s2# }
-
-readMutVarSST (MutableVar var#) s#
- = case readMutVar# var# s# of { (# s2#, r #) ->
- SST_R r s2# }
-
-writeMutVarSST (MutableVar var#) val s#
- = case writeMutVar# var# val s# of { s2# ->
- SST_R () s2# }
-
-#endif
-\end{code}
-
projects / ghc-hetmet.git / commitdiff