{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ConstraintKinds #-}
module Basement.Monad
( PrimMonad(..)
, MonadFailure(..)
, unPrimMonad_
, unsafePrimCast
, unsafePrimToST
, unsafePrimToIO
, unsafePrimFromIO
, primTouch
) where
import qualified Prelude
import GHC.ST
import GHC.STRef
import GHC.IORef
import GHC.IO
import GHC.Prim
import Basement.Compat.Base (Exception, (.), ($), Applicative, Monad)
import Basement.Compat.Primitive
class (Prelude.Functor m, Applicative m, Prelude.Monad m) => PrimMonad m where
type PrimState m
type PrimVar m :: * -> *
primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primThrow :: Exception e => e -> m a
unPrimMonad :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
primVarNew :: a -> m (PrimVar m a)
primVarRead :: PrimVar m a -> m a
primVarWrite :: PrimVar m a -> a -> m ()
unPrimMonad_ :: PrimMonad m => m () -> State# (PrimState m) -> State# (PrimState m)
unPrimMonad_ :: m () -> State# (PrimState m) -> State# (PrimState m)
unPrimMonad_ m ()
p State# (PrimState m)
st =
case m () -> State# (PrimState m) -> (# State# (PrimState m), () #)
forall (m :: * -> *) a.
PrimMonad m =>
m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
unPrimMonad m ()
p State# (PrimState m)
st of
(# State# (PrimState m)
st', () #) -> State# (PrimState m)
st'
{-# INLINE unPrimMonad_ #-}
instance PrimMonad IO where
type PrimState IO = RealWorld
type PrimVar IO = IORef
primitive :: (State# (PrimState IO) -> (# State# (PrimState IO), a #)) -> IO a
primitive = (State# (PrimState IO) -> (# State# (PrimState IO), a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
{-# INLINE primitive #-}
primThrow :: e -> IO a
primThrow = e -> IO a
forall e a. Exception e => e -> IO a
throwIO
unPrimMonad :: IO a -> State# (PrimState IO) -> (# State# (PrimState IO), a #)
unPrimMonad (IO State# RealWorld -> (# State# RealWorld, a #)
p) = State# RealWorld -> (# State# RealWorld, a #)
State# (PrimState IO) -> (# State# (PrimState IO), a #)
p
{-# INLINE unPrimMonad #-}
primVarNew :: a -> IO (PrimVar IO a)
primVarNew = a -> IO (PrimVar IO a)
forall a. a -> IO (IORef a)
newIORef
primVarRead :: PrimVar IO a -> IO a
primVarRead = PrimVar IO a -> IO a
forall a. IORef a -> IO a
readIORef
primVarWrite :: PrimVar IO a -> a -> IO ()
primVarWrite = PrimVar IO a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef
instance PrimMonad (ST s) where
type PrimState (ST s) = s
type PrimVar (ST s) = STRef s
primitive :: (State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
-> ST s a
primitive = (State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
-> ST s a
forall s a. STRep s a -> ST s a
ST
{-# INLINE primitive #-}
primThrow :: e -> ST s a
primThrow = IO a -> ST s a
forall a s. IO a -> ST s a
unsafeIOToST (IO a -> ST s a) -> (e -> IO a) -> e -> ST s a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. e -> IO a
forall e a. Exception e => e -> IO a
throwIO
unPrimMonad :: ST s a
-> State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #)
unPrimMonad (ST STRep s a
p) = STRep s a
State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #)
p
{-# INLINE unPrimMonad #-}
primVarNew :: a -> ST s (PrimVar (ST s) a)
primVarNew = a -> ST s (PrimVar (ST s) a)
forall a s. a -> ST s (STRef s a)
newSTRef
primVarRead :: PrimVar (ST s) a -> ST s a
primVarRead = PrimVar (ST s) a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef
primVarWrite :: PrimVar (ST s) a -> a -> ST s ()
primVarWrite = PrimVar (ST s) a -> a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef
unsafePrimCast :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a
unsafePrimCast :: m1 a -> m2 a
unsafePrimCast m1 a
m = (State# (PrimState m2) -> (# State# (PrimState m2), a #)) -> m2 a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive ((State# (PrimState m1) -> (# State# (PrimState m1), a #))
-> State# (PrimState m2) -> (# State# (PrimState m2), a #)
unsafeCoerce# (m1 a -> State# (PrimState m1) -> (# State# (PrimState m1), a #)
forall (m :: * -> *) a.
PrimMonad m =>
m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
unPrimMonad m1 a
m))
{-# INLINE unsafePrimCast #-}
unsafePrimToST :: PrimMonad prim => prim a -> ST s a
unsafePrimToST :: prim a -> ST s a
unsafePrimToST = prim a -> ST s a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimMonad m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimCast
{-# INLINE unsafePrimToST #-}
unsafePrimToIO :: PrimMonad prim => prim a -> IO a
unsafePrimToIO :: prim a -> IO a
unsafePrimToIO = prim a -> IO a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimMonad m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimCast
{-# INLINE unsafePrimToIO #-}
unsafePrimFromIO :: PrimMonad prim => IO a -> prim a
unsafePrimFromIO :: IO a -> prim a
unsafePrimFromIO = IO a -> prim a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimMonad m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimCast
{-# INLINE unsafePrimFromIO #-}
primTouch :: PrimMonad m => a -> m ()
primTouch :: a -> m ()
primTouch a
x = IO () -> m ()
forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
unsafePrimFromIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (State# (PrimState IO) -> (# State# (PrimState IO), () #)) -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive ((State# (PrimState IO) -> (# State# (PrimState IO), () #))
-> IO ())
-> (State# (PrimState IO) -> (# State# (PrimState IO), () #))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \State# (PrimState IO)
s -> case a -> State# RealWorld -> State# RealWorld
forall k1. k1 -> State# RealWorld -> State# RealWorld
touch# a
x State# RealWorld
State# (PrimState IO)
s of { State# RealWorld
s2 -> (# State# RealWorld
State# (PrimState IO)
s2, () #) }
{-# INLINE primTouch #-}
class Monad m => MonadFailure m where
type Failure m
mFail :: Failure m -> m ()
instance MonadFailure Prelude.Maybe where
type Failure Prelude.Maybe = ()
mFail :: Failure Maybe -> Maybe ()
mFail Failure Maybe
_ = Maybe ()
forall k1. Maybe k1
Prelude.Nothing
instance MonadFailure (Prelude.Either a) where
type Failure (Prelude.Either a) = a
mFail :: Failure (Either a) -> Either a ()
mFail Failure (Either a)
a = a -> Either a ()
forall a b. a -> Either a b
Prelude.Left a
Failure (Either a)
a