{-# LANGUAGE Unsafe #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash, UnboxedTuples, RankNTypes #-}
{-# OPTIONS_HADDOCK not-home #-}
module Control.Monad.ST.Lazy.Imp (
ST,
runST,
fixST,
strictToLazyST, lazyToStrictST,
RealWorld,
stToIO,
unsafeInterleaveST,
unsafeIOToST
) where
import Control.Monad.Fix
import qualified Control.Monad.ST as ST
import qualified Control.Monad.ST.Unsafe as ST
import qualified GHC.ST
import GHC.Base
newtype ST s a = ST { forall s a. ST s a -> State s -> (a, State s)
unST :: State s -> (a, State s) }
data State s = S# (State# s)
noDup :: a -> a
noDup :: forall a. a -> a
noDup a
a = (State# RealWorld -> a) -> a
forall o. (State# RealWorld -> o) -> o
runRW# (\State# RealWorld
s ->
case State# RealWorld -> State# RealWorld
forall d. State# d -> State# d
noDuplicate# State# RealWorld
s of
State# RealWorld
_ -> a
a)
instance Functor (ST s) where
fmap :: forall a b. (a -> b) -> ST s a -> ST s b
fmap a -> b
f ST s a
m = (State s -> (b, State s)) -> ST s b
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (b, State s)) -> ST s b)
-> (State s -> (b, State s)) -> ST s b
forall a b. (a -> b) -> a -> b
$ \ State s
s ->
let
{-# NOINLINE res #-}
res :: (a, State s)
res = (a, State s) -> (a, State s)
forall a. a -> a
noDup (ST s a -> State s -> (a, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s a
m State s
s)
(a
r,State s
new_s) = (a, State s)
res
in
(a -> b
f a
r,State s
new_s)
a
x <$ :: forall a b. a -> ST s b -> ST s a
<$ ST s b
m = (State s -> (a, State s)) -> ST s a
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (a, State s)) -> ST s a)
-> (State s -> (a, State s)) -> ST s a
forall a b. (a -> b) -> a -> b
$ \ State s
s ->
let
{-# NOINLINE s' #-}
s' :: State s
s' = State s -> State s
forall a. a -> a
noDup ((b, State s) -> State s
forall a b. (a, b) -> b
snd (ST s b -> State s -> (b, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s b
m State s
s))
in (a
x, State s
s')
instance Applicative (ST s) where
pure :: forall a. a -> ST s a
pure a
a = (State s -> (a, State s)) -> ST s a
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (a, State s)) -> ST s a)
-> (State s -> (a, State s)) -> ST s a
forall a b. (a -> b) -> a -> b
$ \ State s
s -> (a
a,State s
s)
ST s (a -> b)
fm <*> :: forall a b. ST s (a -> b) -> ST s a -> ST s b
<*> ST s a
xm = (State s -> (b, State s)) -> ST s b
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (b, State s)) -> ST s b)
-> (State s -> (b, State s)) -> ST s b
forall a b. (a -> b) -> a -> b
$ \ State s
s ->
let
{-# NOINLINE res1 #-}
!res1 :: (a -> b, State s)
res1 = ST s (a -> b) -> State s -> (a -> b, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s (a -> b)
fm State s
s
!(a -> b
f, State s
s') = (a -> b, State s)
res1
{-# NOINLINE res2 #-}
res2 :: (a, State s)
res2 = (a, State s) -> (a, State s)
forall a. a -> a
noDup (ST s a -> State s -> (a, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s a
xm State s
s')
(a
x, State s
s'') = (a, State s)
res2
in (a -> b
f a
x, State s
s'')
liftA2 :: forall a b c. (a -> b -> c) -> ST s a -> ST s b -> ST s c
liftA2 a -> b -> c
f ST s a
m ST s b
n = (State s -> (c, State s)) -> ST s c
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (c, State s)) -> ST s c)
-> (State s -> (c, State s)) -> ST s c
forall a b. (a -> b) -> a -> b
$ \ State s
s ->
let
{-# NOINLINE res1 #-}
res1 :: (a, State s)
res1 = (a, State s) -> (a, State s)
forall a. a -> a
noDup (ST s a -> State s -> (a, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s a
m State s
s)
(a
x, State s
s') = (a, State s)
res1
{-# NOINLINE res2 #-}
res2 :: (b, State s)
res2 = (b, State s) -> (b, State s)
forall a. a -> a
noDup (ST s b -> State s -> (b, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s b
n State s
s')
(b
y, State s
s'') = (b, State s)
res2
in (a -> b -> c
f a
x b
y, State s
s'')
ST s a
m *> :: forall a b. ST s a -> ST s b -> ST s b
*> ST s b
n = (State s -> (b, State s)) -> ST s b
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (b, State s)) -> ST s b)
-> (State s -> (b, State s)) -> ST s b
forall a b. (a -> b) -> a -> b
$ \State s
s ->
let
{-# NOINLINE s' #-}
s' :: State s
s' = State s -> State s
forall a. a -> a
noDup ((a, State s) -> State s
forall a b. (a, b) -> b
snd (ST s a -> State s -> (a, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s a
m State s
s))
in ST s b -> State s -> (b, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s b
n State s
s'
ST s a
m <* :: forall a b. ST s a -> ST s b -> ST s a
<* ST s b
n = (State s -> (a, State s)) -> ST s a
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (a, State s)) -> ST s a)
-> (State s -> (a, State s)) -> ST s a
forall a b. (a -> b) -> a -> b
$ \State s
s ->
let
{-# NOINLINE res1 #-}
!res1 :: (a, State s)
res1 = ST s a -> State s -> (a, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s a
m State s
s
!(a
mr, State s
s') = (a, State s)
res1
{-# NOINLINE s'' #-}
s'' :: State s
s'' = State s -> State s
forall a. a -> a
noDup ((b, State s) -> State s
forall a b. (a, b) -> b
snd (ST s b -> State s -> (b, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s b
n State s
s'))
in (a
mr, State s
s'')
instance Monad (ST s) where
>> :: forall a b. ST s a -> ST s b -> ST s b
(>>) = ST s a -> ST s b -> ST s b
forall a b. ST s a -> ST s b -> ST s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
ST s a
m >>= :: forall a b. ST s a -> (a -> ST s b) -> ST s b
>>= a -> ST s b
k = (State s -> (b, State s)) -> ST s b
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (b, State s)) -> ST s b)
-> (State s -> (b, State s)) -> ST s b
forall a b. (a -> b) -> a -> b
$ \ State s
s ->
let
{-# NOINLINE res #-}
res :: (a, State s)
res = (a, State s) -> (a, State s)
forall a. a -> a
noDup (ST s a -> State s -> (a, State s)
forall s a. ST s a -> State s -> (a, State s)
unST ST s a
m State s
s)
(a
r,State s
new_s) = (a, State s)
res
in
ST s b -> State s -> (b, State s)
forall s a. ST s a -> State s -> (a, State s)
unST (a -> ST s b
k a
r) State s
new_s
runST :: (forall s. ST s a) -> a
runST :: forall a. (forall s. ST s a) -> a
runST (ST State RealWorld -> (a, State RealWorld)
st) = (State# RealWorld -> a) -> a
forall o. (State# RealWorld -> o) -> o
runRW# (\State# RealWorld
s -> case State RealWorld -> (a, State RealWorld)
st (State# RealWorld -> State RealWorld
forall s. State# s -> State s
S# State# RealWorld
s) of (a
r, State RealWorld
_) -> a
r)
fixST :: (a -> ST s a) -> ST s a
fixST :: forall a s. (a -> ST s a) -> ST s a
fixST a -> ST s a
m = (State s -> (a, State s)) -> ST s a
forall s a. (State s -> (a, State s)) -> ST s a
ST (\ State s
s ->
let
q :: (a, State s)
q@(a
r,State s
_s') = ST s a -> State s -> (a, State s)
forall s a. ST s a -> State s -> (a, State s)
unST (a -> ST s a
m a
r) State s
s
in (a, State s)
q)
instance MonadFix (ST s) where
mfix :: forall a. (a -> ST s a) -> ST s a
mfix = (a -> ST s a) -> ST s a
forall a s. (a -> ST s a) -> ST s a
fixST
strictToLazyST :: ST.ST s a -> ST s a
strictToLazyST :: forall s a. ST s a -> ST s a
strictToLazyST (GHC.ST.ST STRep s a
m) = (State s -> (a, State s)) -> ST s a
forall s a. (State s -> (a, State s)) -> ST s a
ST ((State s -> (a, State s)) -> ST s a)
-> (State s -> (a, State s)) -> ST s a
forall a b. (a -> b) -> a -> b
$ \(S# State# s
s) ->
case STRep s a
m State# s
s of
(# State# s
s', a
a #) -> (a
a, State# s -> State s
forall s. State# s -> State s
S# State# s
s')
lazyToStrictST :: ST s a -> ST.ST s a
lazyToStrictST :: forall s a. ST s a -> ST s a
lazyToStrictST (ST State s -> (a, State s)
m) = STRep s a -> ST s a
forall s a. STRep s a -> ST s a
GHC.ST.ST (STRep s a -> ST s a) -> STRep s a -> ST s a
forall a b. (a -> b) -> a -> b
$ \State# s
s ->
case (State s -> (a, State s)
m (State# s -> State s
forall s. State# s -> State s
S# State# s
s)) of (a
a, S# State# s
s') -> (# State# s
s', a
a #)
stToIO :: ST RealWorld a -> IO a
stToIO :: forall a. ST RealWorld a -> IO a
stToIO = ST RealWorld a -> IO a
forall a. ST RealWorld a -> IO a
ST.stToIO (ST RealWorld a -> IO a)
-> (ST RealWorld a -> ST RealWorld a) -> ST RealWorld a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST RealWorld a -> ST RealWorld a
forall s a. ST s a -> ST s a
lazyToStrictST
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST :: forall s a. ST s a -> ST s a
unsafeInterleaveST = ST s a -> ST s a
forall s a. ST s a -> ST s a
strictToLazyST (ST s a -> ST s a) -> (ST s a -> ST s a) -> ST s a -> ST s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s a -> ST s a
forall s a. ST s a -> ST s a
ST.unsafeInterleaveST (ST s a -> ST s a) -> (ST s a -> ST s a) -> ST s a -> ST s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST s a -> ST s a
forall s a. ST s a -> ST s a
lazyToStrictST
unsafeIOToST :: IO a -> ST s a
unsafeIOToST :: forall a s. IO a -> ST s a
unsafeIOToST = ST s a -> ST s a
forall s a. ST s a -> ST s a
strictToLazyST (ST s a -> ST s a) -> (IO a -> ST s a) -> IO a -> ST s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ST s a
forall a s. IO a -> ST s a
ST.unsafeIOToST