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
|
{-# LANGUAGE MagicHash, UnboxedTuples, TypeFamilies #-}
-- |
-- Module : Control.Monad.Primitive
-- Copyright : (c) Roman Leshchinskiy 2009
-- License : BSD-style
--
-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au>
-- Portability : non-portable
--
-- Primitive state-transformer monads
--
module Control.Monad.Primitive (
PrimMonad(..), RealWorld, primitive_,
primToPrim, primToIO, primToST,
unsafePrimToPrim, unsafePrimToIO, unsafePrimToST,
unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,
touch
) where
import GHC.Prim ( State#, RealWorld, touch# )
import GHC.Base ( unsafeCoerce#, realWorld# )
#if MIN_VERSION_base(4,2,0)
import GHC.IO ( IO(..) )
#else
import GHC.IOBase ( IO(..) )
#endif
import GHC.ST ( ST(..) )
-- | Class of primitive state-transformer monads
class Monad m => PrimMonad m where
-- | State token type
type PrimState m
-- | Execute a primitive operation
primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
-- | Expose the internal structure of the monad
internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
-- | Execute a primitive operation with no result
primitive_ :: PrimMonad m
=> (State# (PrimState m) -> State# (PrimState m)) -> m ()
{-# INLINE primitive_ #-}
primitive_ f = primitive (\s# -> (# f s#, () #))
instance PrimMonad IO where
type PrimState IO = RealWorld
primitive = IO
internal (IO p) = p
{-# INLINE primitive #-}
{-# INLINE internal #-}
instance PrimMonad (ST s) where
type PrimState (ST s) = s
primitive = ST
internal (ST p) = p
{-# INLINE primitive #-}
{-# INLINE internal #-}
-- | Convert a 'PrimMonad' to another monad with the same state token.
primToPrim :: (PrimMonad m1, PrimMonad m2, PrimState m1 ~ PrimState m2)
=> m1 a -> m2 a
{-# INLINE primToPrim #-}
primToPrim m = primitive (internal m)
-- | Convert a 'PrimMonad' with a 'RealWorld' state token to 'IO'
primToIO :: (PrimMonad m, PrimState m ~ RealWorld) => m a -> IO a
{-# INLINE primToIO #-}
primToIO = primToPrim
-- | Convert a 'PrimMonad' to 'ST'
primToST :: PrimMonad m => m a -> ST (PrimState m) a
{-# INLINE primToST #-}
primToST = primToPrim
-- | Convert a 'PrimMonad' to another monad with a possibly different state
-- token. This operation is highly unsafe!
unsafePrimToPrim :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a
{-# INLINE unsafePrimToPrim #-}
unsafePrimToPrim m = primitive (unsafeCoerce# (internal m))
-- | Convert any 'PrimMonad' to 'ST' with an arbitrary state token. This
-- operation is highly unsafe!
unsafePrimToST :: PrimMonad m => m a -> ST s a
{-# INLINE unsafePrimToST #-}
unsafePrimToST = unsafePrimToPrim
-- | Convert any 'PrimMonad' to 'IO'. This operation is highly unsafe!
unsafePrimToIO :: PrimMonad m => m a -> IO a
{-# INLINE unsafePrimToIO #-}
unsafePrimToIO = unsafePrimToPrim
unsafeInlinePrim :: PrimMonad m => m a -> a
{-# INLINE unsafeInlinePrim #-}
unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m)
unsafeInlineIO :: IO a -> a
{-# INLINE unsafeInlineIO #-}
unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r
unsafeInlineST :: ST s a -> a
{-# INLINE unsafeInlineST #-}
unsafeInlineST = unsafeInlinePrim
touch :: PrimMonad m => a -> m ()
{-# INLINE touch #-}
touch x = unsafePrimToPrim
$ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ())
|
