{-# 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_ :: forall (m :: * -> *).
PrimMonad m =>
m () -> State# (PrimState m) -> State# (PrimState m)
unPrimMonad_ m ()
p State# (PrimState m)
st =
case 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 :: forall a.
(State# (PrimState IO) -> (# State# (PrimState IO), a #)) -> IO a
primitive = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
{-# INLINE primitive #-}
primThrow :: forall e a. Exception e => e -> IO a
primThrow = forall e a. Exception e => e -> IO a
throwIO
unPrimMonad :: forall a.
IO a -> State# (PrimState IO) -> (# State# (PrimState IO), a #)
unPrimMonad (IO State# RealWorld -> (# State# RealWorld, a #)
p) = State# RealWorld -> (# State# RealWorld, a #)
p
{-# INLINE unPrimMonad #-}
primVarNew :: forall a. a -> IO (PrimVar IO a)
primVarNew = forall a. a -> IO (IORef a)
newIORef
primVarRead :: forall a. PrimVar IO a -> IO a
primVarRead = forall a. IORef a -> IO a
readIORef
primVarWrite :: forall a. PrimVar IO a -> a -> IO ()
primVarWrite = forall a. IORef a -> a -> IO ()
writeIORef
instance PrimMonad (ST s) where
type PrimState (ST s) = s
type PrimVar (ST s) = STRef s
primitive :: forall a.
(State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #))
-> ST s a
primitive = forall s a. STRep s a -> ST s a
ST
{-# INLINE primitive #-}
primThrow :: forall e a. Exception e => e -> ST s a
primThrow = forall a s. IO a -> ST s a
unsafeIOToST forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e a. Exception e => e -> IO a
throwIO
unPrimMonad :: forall a.
ST s a
-> State# (PrimState (ST s)) -> (# State# (PrimState (ST s)), a #)
unPrimMonad (ST STRep s a
p) = STRep s a
p
{-# INLINE unPrimMonad #-}
primVarNew :: forall a. a -> ST s (PrimVar (ST s) a)
primVarNew = forall a s. a -> ST s (STRef s a)
newSTRef
primVarRead :: forall a. PrimVar (ST s) a -> ST s a
primVarRead = forall s a. STRef s a -> ST s a
readSTRef
primVarWrite :: forall a. PrimVar (ST s) a -> a -> ST s ()
primVarWrite = forall s a. STRef s a -> a -> ST s ()
writeSTRef
unsafePrimCast :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a
unsafePrimCast :: forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimMonad m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimCast m1 a
m = forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# (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 :: forall (prim :: * -> *) a s. PrimMonad prim => prim a -> ST s a
unsafePrimToST = forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimMonad m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimCast
{-# INLINE unsafePrimToST #-}
unsafePrimToIO :: PrimMonad prim => prim a -> IO a
unsafePrimToIO :: forall (prim :: * -> *) a. PrimMonad prim => prim a -> IO a
unsafePrimToIO = forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimMonad m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimCast
{-# INLINE unsafePrimToIO #-}
unsafePrimFromIO :: PrimMonad prim => IO a -> prim a
unsafePrimFromIO :: forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
unsafePrimFromIO = forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimMonad m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimCast
{-# INLINE unsafePrimFromIO #-}
primTouch :: PrimMonad m => a -> m ()
primTouch :: forall (m :: * -> *) a. PrimMonad m => a -> m ()
primTouch a
x = forall (prim :: * -> *) a. PrimMonad prim => IO a -> prim a
unsafePrimFromIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive forall a b. (a -> b) -> a -> b
$ \State# (PrimState IO)
s -> case touch# :: forall a. a -> State# RealWorld -> State# RealWorld
touch# a
x State# (PrimState IO)
s of { State# RealWorld
s2 -> (# State# RealWorld
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
_ = forall a. Maybe a
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 = forall a b. a -> Either a b
Prelude.Left Failure (Either a)
a