{-# LANGUAGE Unsafe #-}
{-# LANGUAGE MagicHash, UnboxedTuples, RankNTypes #-}
{-# OPTIONS_HADDOCK hide #-}
module Control.Monad.ST.Lazy.Imp (
ST,
runST,
fixST,
strictToLazyST, lazyToStrictST,
RealWorld,
stToIO,
unsafeInterleaveST,
unsafeIOToST
) where
import Prelude
import Control.Monad.Fix
import qualified Control.Monad.ST.Safe as ST
import qualified Control.Monad.ST.Unsafe as ST
import qualified GHC.ST as GHC.ST
import GHC.Base
newtype ST s a = ST (State s -> (a, State s))
data State s = S# (State# s)
instance Functor (ST s) where
fmap f m = ST $ \ s ->
let
ST m_a = m
(r,new_s) = m_a s
in
(f r,new_s)
instance Monad (ST s) where
return a = ST $ \ s -> (a,s)
m >> k = m >>= \ _ -> k
fail s = error s
(ST m) >>= k
= ST $ \ s ->
let
(r,new_s) = m s
ST k_a = k r
in
k_a new_s
{-# NOINLINE runST #-}
runST :: (forall s. ST s a) -> a
runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
fixST :: (a -> ST s a) -> ST s a
fixST m = ST (\ s ->
let
ST m_r = m r
(r,s') = m_r s
in
(r,s'))
instance MonadFix (ST s) where
mfix = fixST
strictToLazyST :: ST.ST s a -> ST s a
strictToLazyST m = ST $ \s ->
let
pr = case s of { S# s# -> GHC.ST.liftST m s# }
r = case pr of { GHC.ST.STret _ v -> v }
s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }
in
(r, s')
lazyToStrictST :: ST s a -> ST.ST s a
lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
case (m (S# s)) of (a, S# s') -> (# s', a #)
stToIO :: ST RealWorld a -> IO a
stToIO = ST.stToIO . lazyToStrictST
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
unsafeIOToST :: IO a -> ST s a
unsafeIOToST = strictToLazyST . ST.unsafeIOToST