-- |
-- 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_ :: 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

-- | 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 :: 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 #-}

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

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

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

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

-- | 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
_ = 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