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)
import Basement.Compat.AMP
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_ p st =
case unPrimMonad p st of
(# st', () #) -> st'
instance PrimMonad IO where
type PrimState IO = RealWorld
type PrimVar IO = IORef
primitive = IO
primThrow = throwIO
unPrimMonad (IO p) = p
primVarNew = newIORef
primVarRead = readIORef
primVarWrite = writeIORef
instance PrimMonad (ST s) where
type PrimState (ST s) = s
type PrimVar (ST s) = STRef s
primitive = ST
primThrow = unsafeIOToST . throwIO
unPrimMonad (ST p) = p
primVarNew = newSTRef
primVarRead = readSTRef
primVarWrite = writeSTRef
unsafePrimCast :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a
unsafePrimCast m = primitive (unsafeCoerce# (unPrimMonad m))
unsafePrimToST :: PrimMonad prim => prim a -> ST s a
unsafePrimToST = unsafePrimCast
unsafePrimToIO :: PrimMonad prim => prim a -> IO a
unsafePrimToIO = unsafePrimCast
unsafePrimFromIO :: PrimMonad prim => IO a -> prim a
unsafePrimFromIO = unsafePrimCast
primTouch :: PrimMonad m => a -> m ()
primTouch x = unsafePrimFromIO $ primitive $ \s -> case touch# x s of { s2 -> (# s2, () #) }
class AMPMonad m => MonadFailure m where
type Failure m
mFail :: Failure m -> m ()
instance MonadFailure Prelude.Maybe where
type Failure Prelude.Maybe = ()
mFail _ = Prelude.Nothing
instance MonadFailure (Prelude.Either a) where
type Failure (Prelude.Either a) = a
mFail a = Prelude.Left a