stellar-veritas/bundled/Basement/Monad.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- |
-- 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 #-}
{-# LANGUAGE TypeFamilies #-}
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_ p st =
    case unPrimMonad p st of
        (# st', () #) -> st'
{-# INLINE unPrimMonad_ #-}

instance PrimMonad IO where
    type PrimState IO = RealWorld
    type PrimVar IO = IORef
    primitive = IO
    {-# INLINE primitive #-}
    primThrow = throwIO
    unPrimMonad (IO p) = p
    {-# INLINE unPrimMonad #-}
    primVarNew = newIORef
    primVarRead = readIORef
    primVarWrite = writeIORef

instance PrimMonad (ST s) where
    type PrimState (ST s) = s
    type PrimVar (ST s) = STRef s
    primitive = ST
    {-# INLINE primitive #-}
    primThrow = unsafeIOToST . throwIO
    unPrimMonad (ST p) = p
    {-# INLINE unPrimMonad #-}
    primVarNew = newSTRef
    primVarRead = readSTRef
    primVarWrite = 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 m = primitive (unsafeCoerce# (unPrimMonad m))
{-# INLINE unsafePrimCast #-}

-- | Convert any prim monad to an ST monad
unsafePrimToST :: PrimMonad prim => prim a -> ST s a
unsafePrimToST = unsafePrimCast
{-# INLINE unsafePrimToST #-}

-- | Convert any prim monad to an IO monad
unsafePrimToIO :: PrimMonad prim => prim a -> IO a
unsafePrimToIO = unsafePrimCast
{-# INLINE unsafePrimToIO #-}

-- | Convert any IO monad to a prim monad
unsafePrimFromIO :: PrimMonad prim => IO a -> prim a
unsafePrimFromIO = unsafePrimCast
{-# INLINE unsafePrimFromIO #-}

-- | Touch primitive lifted to any prim monad
primTouch :: PrimMonad m => a -> m ()
primTouch x = unsafePrimFromIO $ primitive $ \s -> case touch# x s of { s2 -> (# 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 _ = Prelude.Nothing
instance MonadFailure (Prelude.Either a) where
    type Failure (Prelude.Either a) = a
    mFail a = Prelude.Left a