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
|
{-# LANGUAGE BangPatterns, CPP, MagicHash, NoImplicitPrelude, RankNTypes,
TypeFamilies, UnboxedTuples, UnliftedFFITypes #-}
module StrictPrim
( StrictPrim
, PrimMonad (..)
, runStrictPrim
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import GHC.Base
newtype StrictPrim s a
= StrictPrim (State# s -> (# State# s, a #))
instance Applicative (StrictPrim s) where
{-# INLINE pure #-}
pure !x = StrictPrim ( \ !s -> (# s, x #))
{-# INLINE (*>) #-}
(!m) *> (!k) = do { _ <- m ; k }
{-# INLINE (<*>) #-}
(<*>) a b = do f <- a ; v <- b ; return $! (f $! v)
instance Functor (StrictPrim s) where
{-# INLINE fmap #-}
fmap !f (StrictPrim !m) = StrictPrim $ \ !s ->
case m s of
(# !new_s,!r #) -> (# new_s, f $! r #)
instance Monad (StrictPrim s) where
{-# INLINE (>>=) #-}
(StrictPrim !m) >>= (!k) =
StrictPrim ( \ !s ->
case m s of
(# new_s, r #) -> case k r of
StrictPrim k2 -> k2 new_s
)
instance PrimMonad (StrictPrim s) where
type PrimState (StrictPrim s) = s
{-# INLINE primitive #-}
primitive = StrictPrim
{-# INLINE runStrictPrim #-}
runStrictPrim :: (forall s. StrictPrim s a) -> a
runStrictPrim !st =
case st of
StrictPrim st_rep ->
case st_rep realWorld# of
(# _, !r #) -> r
class Monad m => PrimMonad m where
type PrimState m
primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
#if __GLASGOW_HASKELL__ < 709
-- Grab this from Prelude (part of Base) because Base depends on this code.
($!) :: (a -> b) -> a -> b
f $! x = let !vx = x in f vx
#endif
|
