1-- |
2-- Module      : Basement.Monad
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : portable
7--
8-- Allow to run operation in ST and IO, without having to
9-- distinguinsh between the two. Most operations exposes
10-- the bare nuts and bolts of how IO and ST actually
11-- works, and relatively easy to shoot yourself in the foot
12--
13-- this is highly similar to the Control.Monad.Primitive
14-- in the primitive package
15--
16{-# LANGUAGE MagicHash #-}
17{-# LANGUAGE UnboxedTuples #-}
18{-# LANGUAGE ExistentialQuantification #-}
19{-# LANGUAGE ConstraintKinds #-}
20module Basement.Monad
21    ( PrimMonad(..)
22    , MonadFailure(..)
23    , unPrimMonad_
24    , unsafePrimCast
25    , unsafePrimToST
26    , unsafePrimToIO
27    , unsafePrimFromIO
28    , primTouch
29    ) where
30
31import qualified Prelude
32import           GHC.ST
33import           GHC.STRef
34import           GHC.IORef
35import           GHC.IO
36import           GHC.Prim
37import           Basement.Compat.Base (Exception, (.), ($), Applicative, Monad)
38
39-- | Primitive monad that can handle mutation.
40--
41-- For example: IO and ST.
42class (Prelude.Functor m, Applicative m, Prelude.Monad m) => PrimMonad m where
43    -- | type of state token associated with the PrimMonad m
44    type PrimState m
45    -- | type of variable associated with the PrimMonad m
46    type PrimVar m :: * -> *
47    -- | Unwrap the State# token to pass to a function a primitive function that returns an unboxed state and a value.
48    primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
49    -- | Throw Exception in the primitive monad
50    primThrow :: Exception e => e -> m a
51    -- | Run a Prim monad from a dedicated state#
52    unPrimMonad  :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
53
54    -- | Build a new variable in the Prim Monad
55    primVarNew :: a -> m (PrimVar m a)
56    -- | Read the variable in the Prim Monad
57    primVarRead :: PrimVar m a -> m a
58    -- | Write the variable in the Prim Monad
59    primVarWrite :: PrimVar m a -> a -> m ()
60
61-- | just like `unwrapPrimMonad` but throw away the result and return just the new State#
62unPrimMonad_ :: PrimMonad m => m () -> State# (PrimState m) -> State# (PrimState m)
63unPrimMonad_ p st =
64    case unPrimMonad p st of
65        (# st', () #) -> st'
66{-# INLINE unPrimMonad_ #-}
67
68instance PrimMonad IO where
69    type PrimState IO = RealWorld
70    type PrimVar IO = IORef
71    primitive = IO
72    {-# INLINE primitive #-}
73    primThrow = throwIO
74    unPrimMonad (IO p) = p
75    {-# INLINE unPrimMonad #-}
76    primVarNew = newIORef
77    primVarRead = readIORef
78    primVarWrite = writeIORef
79
80instance PrimMonad (ST s) where
81    type PrimState (ST s) = s
82    type PrimVar (ST s) = STRef s
83    primitive = ST
84    {-# INLINE primitive #-}
85    primThrow = unsafeIOToST . throwIO
86    unPrimMonad (ST p) = p
87    {-# INLINE unPrimMonad #-}
88    primVarNew = newSTRef
89    primVarRead = readSTRef
90    primVarWrite = writeSTRef
91
92-- | Convert a prim monad to another prim monad.
93--
94-- The net effect is that it coerce the state repr to another,
95-- so the runtime representation should be the same, otherwise
96-- hilary ensues.
97unsafePrimCast :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a
98unsafePrimCast m = primitive (unsafeCoerce# (unPrimMonad m))
99{-# INLINE unsafePrimCast #-}
100
101-- | Convert any prim monad to an ST monad
102unsafePrimToST :: PrimMonad prim => prim a -> ST s a
103unsafePrimToST = unsafePrimCast
104{-# INLINE unsafePrimToST #-}
105
106-- | Convert any prim monad to an IO monad
107unsafePrimToIO :: PrimMonad prim => prim a -> IO a
108unsafePrimToIO = unsafePrimCast
109{-# INLINE unsafePrimToIO #-}
110
111-- | Convert any IO monad to a prim monad
112unsafePrimFromIO :: PrimMonad prim => IO a -> prim a
113unsafePrimFromIO = unsafePrimCast
114{-# INLINE unsafePrimFromIO #-}
115
116-- | Touch primitive lifted to any prim monad
117primTouch :: PrimMonad m => a -> m ()
118primTouch x = unsafePrimFromIO $ primitive $ \s -> case touch# x s of { s2 -> (# s2, () #) }
119{-# INLINE primTouch #-}
120
121-- | Monad that can represent failure
122--
123-- Similar to MonadFail but with a parametrized Failure linked to the Monad
124class Monad m => MonadFailure m where
125    -- | The associated type with the MonadFailure, representing what
126    -- failure can be encoded in this monad
127    type Failure m
128
129    -- | Raise a Failure through a monad.
130    mFail :: Failure m -> m ()
131
132instance MonadFailure Prelude.Maybe where
133    type Failure Prelude.Maybe = ()
134    mFail _ = Prelude.Nothing
135instance MonadFailure (Prelude.Either a) where
136    type Failure (Prelude.Either a) = a
137    mFail a = Prelude.Left a
138