-- |
-- Module      : Basement.Monad
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : portable
--
-- Allow to run operation in ST and IO, without having to
-- distinguinsh between the two. Most operations exposes
-- the bare nuts and bolts of how IO and ST actually
-- works, and relatively easy to shoot yourself in the foot
--
-- this is highly similar to the Control.Monad.Primitive
-- in the primitive package
--
{-# 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

-- | Primitive monad that can handle mutation.
--
-- For example: IO and ST.
class (Prelude.Functor m, Applicative m, Prelude.Monad m) => PrimMonad m where
    -- | type of state token associated with the PrimMonad m
    type PrimState m
    -- | type of variable associated with the PrimMonad m
    type PrimVar m :: * -> *
    -- | Unwrap the State# token to pass to a function a primitive function that returns an unboxed state and a value.
    primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
    -- | Throw Exception in the primitive monad
    primThrow :: Exception e => e -> m a
    -- | Run a Prim monad from a dedicated state#
    unPrimMonad  :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)

    -- | Build a new variable in the Prim Monad
    primVarNew :: a -> m (PrimVar m a)
    -- | Read the variable in the Prim Monad
    primVarRead :: PrimVar m a -> m a
    -- | Write the variable in the Prim Monad
    primVarWrite :: PrimVar m a -> a -> m ()

-- | just like `unwrapPrimMonad` but throw away the result and return just the new State#
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

-- | Convert a prim monad to another prim monad.
--
-- The net effect is that it coerce the state repr to another,
-- so the runtime representation should be the same, otherwise
-- hilary ensues.
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 #-}

-- | Convert any prim monad to an ST monad
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 #-}

-- | Convert any prim monad to an IO monad
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 #-}

-- | Convert any IO monad to a prim monad
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 #-}

-- | Touch primitive lifted to any prim monad
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 #-}

-- | Monad that can represent failure
--
-- Similar to MonadFail but with a parametrized Failure linked to the Monad
class Monad m => MonadFailure m where
    -- | The associated type with the MonadFailure, representing what
    -- failure can be encoded in this monad
    type Failure m

    -- | Raise a Failure through a monad.
    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