| ... |
... |
@@ -35,97 +35,90 @@ details |
|
35
|
35
|
import Data.List (intercalate)
|
|
36
|
36
|
import Data.Map qualified as Map
|
|
37
|
37
|
import Data.Maybe
|
|
38
|
|
-
|
|
39
|
38
|
import Data.Semigroup qualified as S
|
|
40
|
|
-import GHC.Driver.Errors.Types (PsMessage)
|
|
41
|
|
-import GHC.Parser.Lexer qualified as Lexer
|
|
|
39
|
+
|
|
|
40
|
+import GHC.Base
|
|
|
41
|
+import GHC.Parser.Lexer (P (..), PState (..), ParseResult (..))
|
|
42
|
42
|
import GHC.Parser.PreProcess.Eval
|
|
43
|
43
|
import GHC.Parser.PreProcess.ParsePP
|
|
44
|
44
|
import GHC.Parser.PreProcess.Parser qualified as Parser
|
|
45
|
45
|
import GHC.Parser.PreProcess.ParserM
|
|
46
|
46
|
import GHC.Parser.PreProcess.State
|
|
47
|
47
|
import GHC.Prelude
|
|
48
|
|
-import GHC.Types.Error (MsgEnvelope)
|
|
49
|
48
|
import GHC.Types.SrcLoc
|
|
50
|
49
|
import GHC.Utils.Outputable
|
|
51
|
50
|
import GHC.Utils.Panic (panic)
|
|
52
|
51
|
|
|
53
|
52
|
-- ---------------------------------------------------------------------
|
|
54
|
53
|
|
|
55
|
|
--- We evaluate to an Int, which we convert to a bool
|
|
|
54
|
+-- We evaluate to an Int, which we convert to a bool
|
|
56
|
55
|
cppCond :: SrcSpan -> String -> PP Bool
|
|
57
|
56
|
cppCond loc str = do
|
|
58
|
|
- s <- getPpState
|
|
|
57
|
+ r <- runPM $ cppCond' loc str
|
|
|
58
|
+ return $ fromMaybe False r
|
|
|
59
|
+
|
|
|
60
|
+cppCond' :: SrcSpan -> String -> PPM Bool
|
|
|
61
|
+cppCond' loc str = do
|
|
|
62
|
+ s <- liftPM getPpState
|
|
59
|
63
|
expanded <- expand loc (pp_defines s) str
|
|
60
|
|
- case expanded of
|
|
|
64
|
+ v <- case Parser.parseExpr expanded of
|
|
61
|
65
|
Left err -> do
|
|
62
|
|
- Lexer.addError err
|
|
63
|
|
- return False
|
|
64
|
|
- Right expanded -> do
|
|
65
|
|
- v <- case Parser.parseExpr expanded of
|
|
66
|
|
- Left err -> do
|
|
67
|
|
- let detail =
|
|
68
|
|
- if str == expanded || expanded == ""
|
|
69
|
|
- then
|
|
70
|
|
- [ text str
|
|
71
|
|
- ]
|
|
72
|
|
- else
|
|
73
|
|
- [ text expanded
|
|
74
|
|
- , text "expanded from:"
|
|
75
|
|
- , text str
|
|
76
|
|
- ]
|
|
77
|
|
- addGhcCPPError'
|
|
78
|
|
- loc
|
|
79
|
|
- "Error evaluating CPP condition:"
|
|
80
|
|
- ( text err
|
|
81
|
|
- <+> text "of"
|
|
82
|
|
- $+$ vcat detail
|
|
83
|
|
- )
|
|
84
|
|
- return 0
|
|
85
|
|
- Right tree -> return (eval tree)
|
|
86
|
|
- return (toBool v)
|
|
|
66
|
+ let detail =
|
|
|
67
|
+ if str == expanded || expanded == ""
|
|
|
68
|
+ then
|
|
|
69
|
+ [text str]
|
|
|
70
|
+ else
|
|
|
71
|
+ [ text expanded
|
|
|
72
|
+ , text "expanded from:"
|
|
|
73
|
+ , text str
|
|
|
74
|
+ ]
|
|
|
75
|
+ liftPM $
|
|
|
76
|
+ addGhcCPPError'
|
|
|
77
|
+ loc
|
|
|
78
|
+ "Error evaluating CPP condition:"
|
|
|
79
|
+ ( text err
|
|
|
80
|
+ <+> text "of"
|
|
|
81
|
+ $+$ vcat detail
|
|
|
82
|
+ )
|
|
|
83
|
+ return 0
|
|
|
84
|
+ Right tree -> return (eval tree)
|
|
|
85
|
+ return (toBool v)
|
|
87
|
86
|
|
|
88
|
87
|
-- ---------------------------------------------------------------------
|
|
89
|
88
|
|
|
90
|
|
-expand :: SrcSpan -> MacroDefines -> String -> PP (Either (MsgEnvelope PsMessage) String)
|
|
|
89
|
+expand :: SrcSpan -> MacroDefines -> String -> PPM String
|
|
91
|
90
|
expand loc s str = do
|
|
92
|
91
|
case cppLex False str of
|
|
93
|
92
|
Left err -> do
|
|
94
|
|
- return
|
|
95
|
|
- ( Left $
|
|
96
|
|
- mkGhcCPPError'
|
|
97
|
|
- loc
|
|
98
|
|
- "Error evaluating CPP condition:"
|
|
99
|
|
- (text err <+> text "of" $+$ text str)
|
|
100
|
|
- )
|
|
|
93
|
+ liftPM $
|
|
|
94
|
+ addGhcCPPError'
|
|
|
95
|
+ loc
|
|
|
96
|
+ "Error evaluating CPP condition:"
|
|
|
97
|
+ (text err <+> text "of" $+$ text str)
|
|
|
98
|
+ failPM
|
|
101
|
99
|
Right tks -> do
|
|
102
|
|
- expandedToks <- expandToks loc maxExpansions s tks
|
|
103
|
|
- case expandedToks of
|
|
104
|
|
- Left err -> return (Left err)
|
|
105
|
|
- Right toks -> return $ Right $ combineToks $ map t_str toks
|
|
|
100
|
+ toks <- expandToks loc maxExpansions s tks
|
|
|
101
|
+ return $ combineToks $ map t_str toks
|
|
106
|
102
|
|
|
107
|
103
|
maxExpansions :: Int
|
|
108
|
104
|
maxExpansions = 15
|
|
109
|
105
|
|
|
110
|
|
-expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) [Token])
|
|
|
106
|
+expandToks :: SrcSpan -> Int -> MacroDefines -> [Token] -> PPM [Token]
|
|
111
|
107
|
expandToks loc 0 _ ts = do
|
|
112
|
|
- return $
|
|
113
|
|
- Left $
|
|
114
|
|
- mkGhcCPPError'
|
|
115
|
|
- loc
|
|
116
|
|
- "CPP macro expansion limit hit:"
|
|
117
|
|
- (text (combineToks $ map t_str ts))
|
|
|
108
|
+ liftPM $
|
|
|
109
|
+ addGhcCPPError'
|
|
|
110
|
+ loc
|
|
|
111
|
+ "CPP macro expansion limit hit:"
|
|
|
112
|
+ (text (combineToks $ map t_str ts))
|
|
|
113
|
+ failPM
|
|
118
|
114
|
expandToks loc cnt s ts = do
|
|
119
|
|
- expansion <- doExpandToks loc False s ts
|
|
120
|
|
- case expansion of
|
|
121
|
|
- Left err -> return (Left err)
|
|
122
|
|
- Right (!expansionDone, !r) ->
|
|
123
|
|
- if expansionDone
|
|
124
|
|
- then expandToks loc (cnt - 1) s r
|
|
125
|
|
- else return (Right r)
|
|
126
|
|
-
|
|
127
|
|
-doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PP (Either (MsgEnvelope PsMessage) (Bool, [Token]))
|
|
128
|
|
-doExpandToks _loc ed _ [] = return $ Right (ed, [])
|
|
|
115
|
+ (!expansionDone, !r) <- doExpandToks loc False s ts
|
|
|
116
|
+ if expansionDone
|
|
|
117
|
+ then expandToks loc (cnt - 1) s r
|
|
|
118
|
+ else return r
|
|
|
119
|
+
|
|
|
120
|
+doExpandToks :: SrcSpan -> Bool -> MacroDefines -> [Token] -> PPM (Bool, [Token])
|
|
|
121
|
+doExpandToks _loc ed _ [] = return (ed, [])
|
|
129
|
122
|
doExpandToks loc ed s (TIdentifierLParen n : ts) =
|
|
130
|
123
|
-- TIdentifierLParen has no meaning here (only in a #define), so
|
|
131
|
124
|
-- restore it to its constituent tokens
|
| ... |
... |
@@ -136,26 +129,26 @@ doExpandToks loc _ s (TIdentifier "defined" : ts) = do |
|
136
|
129
|
case expandedArgs of
|
|
137
|
130
|
(Just [[TIdentifier macro_name]], rest0) ->
|
|
138
|
131
|
case Map.lookup macro_name s of
|
|
139
|
|
- Nothing -> return $ Right (True, TInteger "0" : rest0)
|
|
140
|
|
- Just _ -> return $ Right (True, TInteger "1" : rest0)
|
|
|
132
|
+ Nothing -> return (True, TInteger "0" : rest0)
|
|
|
133
|
+ Just _ -> return (True, TInteger "1" : rest0)
|
|
141
|
134
|
(Nothing, TIdentifier macro_name : ts0) ->
|
|
142
|
135
|
case Map.lookup macro_name s of
|
|
143
|
|
- Nothing -> return $ Right (True, TInteger "0" : ts0)
|
|
144
|
|
- Just _ -> return $ Right (True, TInteger "1" : ts0)
|
|
|
136
|
+ Nothing -> return (True, TInteger "0" : ts0)
|
|
|
137
|
+ Just _ -> return (True, TInteger "1" : ts0)
|
|
145
|
138
|
(Nothing, _) -> do
|
|
146
|
|
- return $
|
|
147
|
|
- Left $
|
|
148
|
|
- mkGhcCPPError'
|
|
149
|
|
- loc
|
|
150
|
|
- "CPP defined: expected an identifier, got:"
|
|
151
|
|
- (text (concatMap t_str ts))
|
|
|
139
|
+ liftPM $
|
|
|
140
|
+ addGhcCPPError'
|
|
|
141
|
+ loc
|
|
|
142
|
+ "CPP defined: expected an identifier, got:"
|
|
|
143
|
+ (text (concatMap t_str ts))
|
|
|
144
|
+ failPM -- TODO:AZ make part of addGhcCPPError'?
|
|
152
|
145
|
(Just args, _) -> do
|
|
153
|
|
- return $
|
|
154
|
|
- Left $
|
|
155
|
|
- mkGhcCPPError'
|
|
156
|
|
- loc
|
|
157
|
|
- "CPP defined: expected a single arg, got:"
|
|
158
|
|
- (text (intercalate "," (map (concatMap t_str) args)))
|
|
|
146
|
+ liftPM $
|
|
|
147
|
+ addGhcCPPError'
|
|
|
148
|
+ loc
|
|
|
149
|
+ "CPP defined: expected a single arg, got:"
|
|
|
150
|
+ (text (intercalate "," (map (concatMap t_str) args)))
|
|
|
151
|
+ failPM -- TODO:AZ make part of addGhcCPPError'?
|
|
159
|
152
|
doExpandToks loc ed s (TIdentifier n : ts) = do
|
|
160
|
153
|
(args, rest0) <- getExpandArgs loc ts
|
|
161
|
154
|
let
|
| ... |
... |
@@ -168,15 +161,11 @@ doExpandToks loc ed s (TIdentifier n : ts) = do |
|
168
|
161
|
(ed0, r, rest1) = case m_args of
|
|
169
|
162
|
Nothing -> (True, rhs, ts)
|
|
170
|
163
|
Just _ -> (True, replace_args args m_args rhs, rest0)
|
|
171
|
|
- expansion <- doExpandToks loc ed' s ts'
|
|
172
|
|
- case expansion of
|
|
173
|
|
- Left err -> return $ Left err
|
|
174
|
|
- Right (ed'', rest) -> return $ Right (ed'', expanded ++ rest)
|
|
|
164
|
+ (ed'', rest) <- doExpandToks loc ed' s ts'
|
|
|
165
|
+ return (ed'', expanded ++ rest)
|
|
175
|
166
|
doExpandToks loc ed s (t : ts) = do
|
|
176
|
|
- expansion <- doExpandToks loc ed s ts
|
|
177
|
|
- case expansion of
|
|
178
|
|
- Left err -> return (Left err)
|
|
179
|
|
- Right (ed', r) -> return $ Right (ed', t : r)
|
|
|
167
|
+ (ed', r) <- doExpandToks loc ed s ts
|
|
|
168
|
+ return (ed', t : r)
|
|
180
|
169
|
|
|
181
|
170
|
{-
|
|
182
|
171
|
Note: ['defined' unary operator]
|
| ... |
... |
@@ -248,14 +237,15 @@ inner parentheses do not separate arguments. |
|
248
|
237
|
{- | Look for possible arguments to a macro expansion.
|
|
249
|
238
|
The only thing we look for are commas, open parens, and close parens.
|
|
250
|
239
|
-}
|
|
251
|
|
-getExpandArgs :: SrcSpan -> [Token] -> PP (Maybe [[Token]], [Token])
|
|
|
240
|
+getExpandArgs :: SrcSpan -> [Token] -> PPM (Maybe [[Token]], [Token])
|
|
252
|
241
|
getExpandArgs loc ts =
|
|
253
|
242
|
case pArgs ts of
|
|
254
|
243
|
Left err -> do
|
|
255
|
|
- addGhcCPPError'
|
|
256
|
|
- loc
|
|
257
|
|
- "CPP: cannot expand macro arguments:"
|
|
258
|
|
- (text err <+> text "in" $+$ text (concatMap t_str ts))
|
|
|
244
|
+ liftPM $
|
|
|
245
|
+ addGhcCPPError'
|
|
|
246
|
+ loc
|
|
|
247
|
+ "CPP: cannot expand macro arguments:"
|
|
|
248
|
+ (text err <+> text "in" $+$ text (concatMap t_str ts))
|
|
259
|
249
|
return (Nothing, ts)
|
|
260
|
250
|
Right r -> return r
|
|
261
|
251
|
|
| ... |
... |
@@ -336,6 +326,65 @@ isOther (TOpenParen _) = False |
|
336
|
326
|
isOther (TCloseParen _) = False
|
|
337
|
327
|
isOther _ = True
|
|
338
|
328
|
|
|
|
329
|
+-- ---------------------------------------------------------------------
|
|
|
330
|
+
|
|
|
331
|
+-- | Wrapper around P Monad to include a Maybe result
|
|
|
332
|
+type PPM = PM PpState
|
|
|
333
|
+-- See Note [PPM Monad]
|
|
|
334
|
+
|
|
|
335
|
+newtype PM p a = PM {unPM :: PState p -> ParseResult p (Maybe a)}
|
|
|
336
|
+
|
|
|
337
|
+instance Functor (PM p) where
|
|
|
338
|
+ fmap = liftM
|
|
|
339
|
+
|
|
|
340
|
+instance Applicative (PM p) where
|
|
|
341
|
+ pure = returnP
|
|
|
342
|
+ (<*>) = ap
|
|
|
343
|
+
|
|
|
344
|
+instance Monad (PM p) where
|
|
|
345
|
+ (>>=) = thenP
|
|
|
346
|
+
|
|
|
347
|
+returnP :: a -> PM p a
|
|
|
348
|
+returnP a = a `seq` (PM $ \s -> POk s (Just a))
|
|
|
349
|
+
|
|
|
350
|
+failPM :: PM p a
|
|
|
351
|
+failPM = PM $ \s -> POk s Nothing
|
|
|
352
|
+
|
|
|
353
|
+thenP :: PM p a -> (a -> PM p b) -> PM p b
|
|
|
354
|
+(PM m) `thenP` k = PM $ \s ->
|
|
|
355
|
+ case m s of
|
|
|
356
|
+ POk s1 Nothing -> POk s1 Nothing
|
|
|
357
|
+ POk s1 (Just a) -> (unPM (k a)) s1
|
|
|
358
|
+ PFailed s1 -> PFailed s1
|
|
|
359
|
+
|
|
|
360
|
+runPM :: PM p a -> P p (Maybe a)
|
|
|
361
|
+runPM m = P $ \s -> (unPM m) s
|
|
|
362
|
+
|
|
|
363
|
+liftPM :: P p a -> PM p a
|
|
|
364
|
+liftPM m = PM $ \s -> case (unP m) s of
|
|
|
365
|
+ POk s1 a -> POk s1 (Just a)
|
|
|
366
|
+ PFailed s1 -> PFailed s1
|
|
|
367
|
+
|
|
|
368
|
+{-
|
|
|
369
|
+Note [PPM Monad]
|
|
|
370
|
+~~~~~~~~~~~~~~~~
|
|
|
371
|
+
|
|
|
372
|
+The PPM monad is a combination of the Lexer P monad and the Maybe
|
|
|
373
|
+monad.
|
|
|
374
|
+
|
|
|
375
|
+It is used when processing GHC_CPP macro conditionals, where we may
|
|
|
376
|
+find an error processing the condition, such as a CPP parse error,
|
|
|
377
|
+undefined macro, or similar.
|
|
|
378
|
+
|
|
|
379
|
+In this case we do not want to fail the overall GHC Parse, and simply
|
|
|
380
|
+reporting the error and continuing is not enough, as the CPP
|
|
|
381
|
+processing needs to be aware that there was a failure in the
|
|
|
382
|
+processing, and not continue. In particular, this prevents reporting
|
|
|
383
|
+additional CPP errors after the originating cause, and simplifies the
|
|
|
384
|
+coding to not have to match on returned Maybe results
|
|
|
385
|
+-}
|
|
|
386
|
+
|
|
|
387
|
+
|
|
339
|
388
|
-- ---------------------------------------------------------------------
|
|
340
|
389
|
|
|
341
|
390
|
m1 :: Either String [Token]
|