blob: b13321d4912c43a92867e25ac8cd19c3a978bdb8 (
plain)
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
|
-----------------------------------------------------------------------------
-- A Parser monad with access to the 'DynFlags'.
--
-- The 'P' monad only has access to the subset of 'DynFlags'
-- required for parsing Haskell.
-- The parser for C-- requires access to a lot more of the 'DynFlags',
-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
-----------------------------------------------------------------------------
module GHC.Cmm.Parser.Monad (
PD(..)
, liftP
, failMsgPD
, getPDConfig
, getProfile
, getPlatform
, getHomeUnitId
, PDConfig(..)
) where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Profile
import Control.Monad
import GHC.Parser.Lexer
import GHC.Parser.Errors.Types
import GHC.Types.Error ( MsgEnvelope )
import GHC.Types.SrcLoc
import GHC.Unit.Types
import GHC.Unit.Home
data PDConfig = PDConfig
{ pdProfile :: !Profile
, pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@)
}
newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }
instance Functor PD where
fmap = liftM
instance Applicative PD where
pure = returnPD
(<*>) = ap
instance Monad PD where
(>>=) = thenPD
liftP :: P a -> PD a
liftP (P f) = PD $ \_ _ s -> f s
failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a
failMsgPD = liftP . failMsgP
returnPD :: a -> PD a
returnPD = liftP . return
thenPD :: PD a -> (a -> PD b) -> PD b
(PD m) `thenPD` k = PD $ \d hu s ->
case m d hu s of
POk s1 a -> unPD (k a) d hu s1
PFailed s1 -> PFailed s1
getPDConfig :: PD PDConfig
getPDConfig = PD $ \pdc _ s -> POk s pdc
getProfile :: PD Profile
getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc)
getPlatform :: PD Platform
getPlatform = profilePlatform <$> getProfile
-- | Return the UnitId of the home-unit. This is used to create labels.
getHomeUnitId :: PD UnitId
getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu)
|
