1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
-- |
-- 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_ 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
|
