never executed always true always false
1
2 {-# LANGUAGE TypeFamilies #-}
3
4 -----------------------------------------------------------------------------
5 --
6 -- | Parsing the top of a Haskell source file to get its module name,
7 -- imports and options.
8 --
9 -- (c) Simon Marlow 2005
10 -- (c) Lemmih 2006
11 --
12 -----------------------------------------------------------------------------
13
14 module GHC.Parser.Header
15 ( getImports
16 , mkPrelImports -- used by the renamer too
17 , getOptionsFromFile
18 , getOptions
19 , toArgs
20 , checkProcessArgsResult
21 )
22 where
23
24 import GHC.Prelude
25
26 import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions!
27
28 import GHC.Parser.Errors.Types
29 import GHC.Parser ( parseHeader )
30 import GHC.Parser.Lexer
31
32 import GHC.Hs
33 import GHC.Unit.Module
34 import GHC.Builtin.Names
35
36 import GHC.Types.Error
37 import GHC.Types.SrcLoc
38 import GHC.Types.SourceError
39 import GHC.Types.SourceText
40 import GHC.Types.PkgQual
41
42 import GHC.Utils.Misc
43 import GHC.Utils.Panic
44 import GHC.Utils.Monad
45 import GHC.Utils.Error
46 import GHC.Utils.Exception as Exception
47
48 import GHC.Data.StringBuffer
49 import GHC.Data.Maybe
50 import GHC.Data.FastString
51 import qualified GHC.Data.Strict as Strict
52
53 import Control.Monad
54 import System.IO
55 import System.IO.Unsafe
56 import Data.List (partition)
57 import Data.Char (isSpace)
58 import Text.ParserCombinators.ReadP (readP_to_S, gather)
59 import Text.ParserCombinators.ReadPrec (readPrec_to_P)
60 import Text.Read (readPrec)
61
62 ------------------------------------------------------------------------------
63
64 -- | Parse the imports of a source file.
65 --
66 -- Throws a 'SourceError' if parsing fails.
67 getImports :: ParserOpts -- ^ Parser options
68 -> Bool -- ^ Implicit Prelude?
69 -> StringBuffer -- ^ Parse this.
70 -> FilePath -- ^ Filename the buffer came from. Used for
71 -- reporting parse error locations.
72 -> FilePath -- ^ The original source filename (used for locations
73 -- in the function result)
74 -> IO (Either
75 (Messages PsMessage)
76 ([(RawPkgQual, Located ModuleName)],
77 [(RawPkgQual, Located ModuleName)],
78 Bool, -- Is GHC.Prim imported or not
79 Located ModuleName))
80 -- ^ The source imports and normal imports (with optional package
81 -- names from -XPackageImports), and the module name.
82 getImports popts implicit_prelude buf filename source_filename = do
83 let loc = mkRealSrcLoc (mkFastString filename) 1 1
84 case unP parseHeader (initParserState popts buf loc) of
85 PFailed pst ->
86 -- assuming we're not logging warnings here as per below
87 return $ Left $ getPsErrorMessages pst
88 POk pst rdr_module -> fmap Right $ do
89 let (_warns, errs) = getPsMessages pst
90 -- don't log warnings: they'll be reported when we parse the file
91 -- for real. See #2500.
92 if not (isEmptyMessages errs)
93 then throwErrors (GhcPsMessage <$> errs)
94 else
95 let hsmod = unLoc rdr_module
96 mb_mod = hsmodName hsmod
97 imps = hsmodImports hsmod
98 main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
99 1 1)
100 mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME
101 (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
102
103 -- GHC.Prim doesn't exist physically, so don't go looking for it.
104 (ordinary_imps, ghc_prim_import)
105 = partition ((/= moduleName gHC_PRIM) . unLoc
106 . ideclName . unLoc)
107 ord_idecls
108
109 implicit_imports = mkPrelImports (unLoc mod) main_loc
110 implicit_prelude imps
111 convImport (L _ i) = (ideclPkgQual i, reLoc $ ideclName i)
112 in
113 return (map convImport src_idecls
114 , map convImport (implicit_imports ++ ordinary_imps)
115 , not (null ghc_prim_import)
116 , reLoc mod)
117
118 mkPrelImports :: ModuleName
119 -> SrcSpan -- Attribute the "import Prelude" to this location
120 -> Bool -> [LImportDecl GhcPs]
121 -> [LImportDecl GhcPs]
122 -- Construct the implicit declaration "import Prelude" (or not)
123 --
124 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
125 -- because the former doesn't even look at Prelude.hi for instance
126 -- declarations, whereas the latter does.
127 mkPrelImports this_mod loc implicit_prelude import_decls
128 | this_mod == pRELUDE_NAME
129 || explicit_prelude_import
130 || not implicit_prelude
131 = []
132 | otherwise = [preludeImportDecl]
133 where
134 explicit_prelude_import = any is_prelude_import import_decls
135
136 is_prelude_import (L _ decl) =
137 unLoc (ideclName decl) == pRELUDE_NAME
138 -- allow explicit "base" package qualifier (#19082, #17045)
139 && case ideclPkgQual decl of
140 NoRawPkgQual -> True
141 RawPkgQual b -> sl_fs b == unitIdFS baseUnitId
142
143
144 loc' = noAnnSrcSpan loc
145 preludeImportDecl :: LImportDecl GhcPs
146 preludeImportDecl
147 = L loc' $ ImportDecl { ideclExt = noAnn,
148 ideclSourceSrc = NoSourceText,
149 ideclName = L loc' pRELUDE_NAME,
150 ideclPkgQual = NoRawPkgQual,
151 ideclSource = NotBoot,
152 ideclSafe = False, -- Not a safe import
153 ideclQualified = NotQualified,
154 ideclImplicit = True, -- Implicit!
155 ideclAs = Nothing,
156 ideclHiding = Nothing }
157
158 --------------------------------------------------------------
159 -- Get options
160 --------------------------------------------------------------
161
162 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
163 --
164 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
165 getOptionsFromFile :: ParserOpts
166 -> FilePath -- ^ Input file
167 -> IO [Located String] -- ^ Parsed options, if any.
168 getOptionsFromFile opts filename
169 = Exception.bracket
170 (openBinaryFile filename ReadMode)
171 (hClose)
172 (\handle -> do
173 opts <- fmap (getOptions' opts)
174 (lazyGetToks opts' filename handle)
175 seqList opts $ return opts)
176 where -- We don't need to get haddock doc tokens when we're just
177 -- getting the options from pragmas, and lazily lexing them
178 -- correctly is a little tricky: If there is "\n" or "\n-"
179 -- left at the end of a buffer then the haddock doc may
180 -- continue past the end of the buffer, despite the fact that
181 -- we already have an apparently-complete token.
182 -- We therefore just turn Opt_Haddock off when doing the lazy
183 -- lex.
184 opts' = disableHaddock opts
185
186 blockSize :: Int
187 -- blockSize = 17 -- for testing :-)
188 blockSize = 1024
189
190 lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token]
191 lazyGetToks popts filename handle = do
192 buf <- hGetStringBufferBlock handle blockSize
193 let prag_state = initPragState popts buf loc
194 unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize
195 where
196 loc = mkRealSrcLoc (mkFastString filename) 1 1
197
198 lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
199 lazyLexBuf handle state eof size =
200 case unP (lexer False return) state of
201 POk state' t -> do
202 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
203 if atEnd (buffer state') && not eof
204 -- if this token reached the end of the buffer, and we haven't
205 -- necessarily read up to the end of the file, then the token might
206 -- be truncated, so read some more of the file and lex it again.
207 then getMore handle state size
208 else case unLoc t of
209 ITeof -> return [t]
210 _other -> do rest <- lazyLexBuf handle state' eof size
211 return (t : rest)
212 _ | not eof -> getMore handle state size
213 | otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof]
214 -- parser assumes an ITeof sentinel at the end
215
216 getMore :: Handle -> PState -> Int -> IO [Located Token]
217 getMore handle state size = do
218 -- pprTrace "getMore" (text (show (buffer state))) (return ())
219 let new_size = size * 2
220 -- double the buffer size each time we read a new block. This
221 -- counteracts the quadratic slowdown we otherwise get for very
222 -- large module names (#5981)
223 nextbuf <- hGetStringBufferBlock handle new_size
224 if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
225 newbuf <- appendStringBuffers (buffer state) nextbuf
226 unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
227
228
229 getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
230 getToks popts filename buf = lexAll pstate
231 where
232 pstate = initPragState popts buf loc
233 loc = mkRealSrcLoc (mkFastString filename) 1 1
234
235 lexAll state = case unP (lexer False return) state of
236 POk _ t@(L _ ITeof) -> [t]
237 POk state' t -> t : lexAll state'
238 _ -> [L (mkSrcSpanPs (last_loc state)) ITeof]
239
240
241 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
242 --
243 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
244 getOptions :: ParserOpts
245 -> StringBuffer -- ^ Input Buffer
246 -> FilePath -- ^ Source filename. Used for location info.
247 -> [Located String] -- ^ Parsed options.
248 getOptions opts buf filename
249 = getOptions' opts (getToks opts filename buf)
250
251 -- The token parser is written manually because Happy can't
252 -- return a partial result when it encounters a lexer error.
253 -- We want to extract options before the buffer is passed through
254 -- CPP, so we can't use the same trick as 'getImports'.
255 getOptions' :: ParserOpts
256 -> [Located Token] -- Input buffer
257 -> [Located String] -- Options.
258 getOptions' opts toks
259 = parseToks toks
260 where
261 parseToks (open:close:xs)
262 | IToptions_prag str <- unLoc open
263 , ITclose_prag <- unLoc close
264 = case toArgs starting_loc str of
265 Left _err -> optionsParseError str $ -- #15053
266 combineSrcSpans (getLoc open) (getLoc close)
267 Right args -> args ++ parseToks xs
268 where
269 src_span = getLoc open
270 real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span)
271 starting_loc = realSrcSpanStart real_src_span
272 parseToks (open:close:xs)
273 | ITinclude_prag str <- unLoc open
274 , ITclose_prag <- unLoc close
275 = map (L (getLoc open)) ["-#include",removeSpaces str] ++
276 parseToks xs
277 parseToks (open:close:xs)
278 | ITdocOptions str _ <- unLoc open
279 , ITclose_prag <- unLoc close
280 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
281 ++ parseToks xs
282 parseToks (open:xs)
283 | ITlanguage_prag <- unLoc open
284 = parseLanguage xs
285 parseToks (comment:xs) -- Skip over comments
286 | isComment (unLoc comment)
287 = parseToks xs
288 parseToks _ = []
289 parseLanguage ((L loc (ITconid fs)):rest)
290 = checkExtension opts (L loc fs) :
291 case rest of
292 (L _loc ITcomma):more -> parseLanguage more
293 (L _loc ITclose_prag):more -> parseToks more
294 (L loc _):_ -> languagePragParseError loc
295 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
296 parseLanguage (tok:_)
297 = languagePragParseError (getLoc tok)
298 parseLanguage []
299 = panic "getOptions'.parseLanguage(2) went past eof token"
300
301 isComment :: Token -> Bool
302 isComment c =
303 case c of
304 (ITlineComment {}) -> True
305 (ITblockComment {}) -> True
306 (ITdocCommentNext {}) -> True
307 (ITdocCommentPrev {}) -> True
308 (ITdocCommentNamed {}) -> True
309 (ITdocSection {}) -> True
310 _ -> False
311
312 toArgs :: RealSrcLoc
313 -> String -> Either String -- Error
314 [Located String] -- Args
315 toArgs starting_loc orig_str
316 = let (after_spaces_loc, after_spaces_str) = consume_spaces starting_loc orig_str in
317 case after_spaces_str of
318 '[':after_bracket ->
319 let after_bracket_loc = advanceSrcLoc after_spaces_loc '['
320 (after_bracket_spaces_loc, after_bracket_spaces_str)
321 = consume_spaces after_bracket_loc after_bracket in
322 case after_bracket_spaces_str of
323 ']':rest | all isSpace rest -> Right []
324 _ -> readAsList after_bracket_spaces_loc after_bracket_spaces_str
325
326 _ -> toArgs' after_spaces_loc after_spaces_str
327 where
328 consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String)
329 consume_spaces loc [] = (loc, [])
330 consume_spaces loc (c:cs)
331 | isSpace c = consume_spaces (advanceSrcLoc loc c) cs
332 | otherwise = (loc, c:cs)
333
334 break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String
335 -> (String, RealSrcLoc, String) -- location is start of second string
336 break_with_loc p = go []
337 where
338 go reversed_acc loc [] = (reverse reversed_acc, loc, [])
339 go reversed_acc loc (c:cs)
340 | p c = (reverse reversed_acc, loc, c:cs)
341 | otherwise = go (c:reversed_acc) (advanceSrcLoc loc c) cs
342
343 advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc
344 advance_src_loc_many = foldl' advanceSrcLoc
345
346 locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a
347 locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x
348
349 toArgs' :: RealSrcLoc -> String -> Either String [Located String]
350 -- Remove outer quotes:
351 -- > toArgs' "\"foo\" \"bar baz\""
352 -- Right ["foo", "bar baz"]
353 --
354 -- Keep inner quotes:
355 -- > toArgs' "-DFOO=\"bar baz\""
356 -- Right ["-DFOO=\"bar baz\""]
357 toArgs' loc s =
358 let (after_spaces_loc, after_spaces_str) = consume_spaces loc s in
359 case after_spaces_str of
360 [] -> Right []
361 '"' : _ -> do
362 -- readAsString removes outer quotes
363 (arg, new_loc, rest) <- readAsString after_spaces_loc after_spaces_str
364 check_for_space rest
365 (locate after_spaces_loc new_loc arg:)
366 `fmap` toArgs' new_loc rest
367 _ -> case break_with_loc (isSpace <||> (== '"')) after_spaces_loc after_spaces_str of
368 (argPart1, loc2, s''@('"':_)) -> do
369 (argPart2, loc3, rest) <- readAsString loc2 s''
370 check_for_space rest
371 -- show argPart2 to keep inner quotes
372 (locate after_spaces_loc loc3 (argPart1 ++ show argPart2):)
373 `fmap` toArgs' loc3 rest
374 (arg, loc2, s'') -> (locate after_spaces_loc loc2 arg:)
375 `fmap` toArgs' loc2 s''
376
377 check_for_space :: String -> Either String ()
378 check_for_space [] = Right ()
379 check_for_space (c:_)
380 | isSpace c = Right ()
381 | otherwise = Left ("Whitespace expected after string in " ++ show orig_str)
382
383 reads_with_consumed :: Read a => String
384 -> [((String, a), String)]
385 -- ((consumed string, parsed result), remainder of input)
386 reads_with_consumed = readP_to_S (gather (readPrec_to_P readPrec 0))
387
388 readAsString :: RealSrcLoc
389 -> String
390 -> Either String (String, RealSrcLoc, String)
391 readAsString loc s = case reads_with_consumed s of
392 [((consumed, arg), rest)] ->
393 Right (arg, advance_src_loc_many loc consumed, rest)
394 _ ->
395 Left ("Couldn't read " ++ show s ++ " as String")
396
397 -- input has had the '[' stripped off
398 readAsList :: RealSrcLoc -> String -> Either String [Located String]
399 readAsList loc s = do
400 let (after_spaces_loc, after_spaces_str) = consume_spaces loc s
401 (arg, after_arg_loc, after_arg_str) <- readAsString after_spaces_loc after_spaces_str
402 let (after_arg_spaces_loc, after_arg_spaces_str)
403 = consume_spaces after_arg_loc after_arg_str
404 (locate after_spaces_loc after_arg_loc arg :) <$>
405 case after_arg_spaces_str of
406 ',':after_comma -> readAsList (advanceSrcLoc after_arg_spaces_loc ',') after_comma
407 ']':after_bracket
408 | all isSpace after_bracket
409 -> Right []
410 _ -> Left ("Couldn't read " ++ show ('[' : s) ++ " as [String]")
411 -- reinsert missing '[' for clarity.
412
413 -----------------------------------------------------------------------------
414
415 -- | Complain about non-dynamic flags in OPTIONS pragmas.
416 --
417 -- Throws a 'SourceError' if the input list is non-empty claiming that the
418 -- input flags are unknown.
419 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
420 checkProcessArgsResult flags
421 = when (notNull flags) $
422 liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags
423 where mkMsg (L loc flag)
424 = mkPlainErrorMsgEnvelope loc $
425 GhcPsMessage $ PsHeaderMessage $ PsErrUnknownOptionsPragma flag
426
427 -----------------------------------------------------------------------------
428
429 checkExtension :: ParserOpts -> Located FastString -> Located String
430 checkExtension opts (L l ext)
431 -- Checks if a given extension is valid, and if so returns
432 -- its corresponding flag. Otherwise it throws an exception.
433 = if ext' `elem` (pSupportedExts opts)
434 then L l ("-X"++ext')
435 else unsupportedExtnError opts l ext'
436 where
437 ext' = unpackFS ext
438
439 languagePragParseError :: SrcSpan -> a
440 languagePragParseError loc =
441 throwErr loc $ PsErrParseLanguagePragma
442
443 unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a
444 unsupportedExtnError opts loc unsup =
445 throwErr loc $ PsErrUnsupportedExt unsup (pSupportedExts opts)
446
447 optionsParseError :: String -> SrcSpan -> a -- #15053
448 optionsParseError str loc =
449 throwErr loc $ PsErrParseOptionsPragma str
450
451 throwErr :: SrcSpan -> PsHeaderMessage -> a -- #15053
452 throwErr loc ps_msg =
453 let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage (PsHeaderMessage ps_msg)
454 in throw $ mkSrcErr $ singleMessage msg