d534fab1d5338c69b75d86089195dd20959f6f65
[ghc.git] / compiler / main / HeaderInfo.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ViewPatterns #-}
3 {-# LANGUAGE TypeFamilies #-}
4
5 -----------------------------------------------------------------------------
6 --
7 -- | Parsing the top of a Haskell source file to get its module name,
8 -- imports and options.
9 --
10 -- (c) Simon Marlow 2005
11 -- (c) Lemmih 2006
12 --
13 -----------------------------------------------------------------------------
14
15 module HeaderInfo ( getImports
16 , mkPrelImports -- used by the renamer too
17 , getOptionsFromFile, getOptions
18 , optionsErrorMsgs,
19 checkProcessArgsResult ) where
20
21 #include "HsVersions.h"
22
23 import GhcPrelude
24
25 import HscTypes
26 import Parser ( parseHeader )
27 import Lexer
28 import FastString
29 import GHC.Hs
30 import Module
31 import PrelNames
32 import StringBuffer
33 import SrcLoc
34 import DynFlags
35 import ErrUtils
36 import Util
37 import Outputable
38 import Maybes
39 import Bag ( emptyBag, listToBag, unitBag )
40 import MonadUtils
41 import Exception
42 import BasicTypes
43 import qualified GHC.LanguageExtensions as LangExt
44
45 import Control.Monad
46 import System.IO
47 import System.IO.Unsafe
48 import Data.List
49
50 ------------------------------------------------------------------------------
51
52 -- | Parse the imports of a source file.
53 --
54 -- Throws a 'SourceError' if parsing fails.
55 getImports :: DynFlags
56 -> StringBuffer -- ^ Parse this.
57 -> FilePath -- ^ Filename the buffer came from. Used for
58 -- reporting parse error locations.
59 -> FilePath -- ^ The original source filename (used for locations
60 -- in the function result)
61 -> IO (Either
62 ErrorMessages
63 ([(Maybe FastString, Located ModuleName)],
64 [(Maybe FastString, Located ModuleName)],
65 Located ModuleName))
66 -- ^ The source imports, normal imports, and the module name.
67 getImports dflags buf filename source_filename = do
68 let loc = mkRealSrcLoc (mkFastString filename) 1 1
69 case unP parseHeader (mkPState dflags buf loc) of
70 PFailed pst ->
71 -- assuming we're not logging warnings here as per below
72 return $ Left $ getErrorMessages pst dflags
73 POk pst rdr_module -> fmap Right $ do
74 let _ms@(_warns, errs) = getMessages pst dflags
75 -- don't log warnings: they'll be reported when we parse the file
76 -- for real. See #2500.
77 ms = (emptyBag, errs)
78 -- logWarnings warns
79 if errorsFound dflags ms
80 then throwIO $ mkSrcErr errs
81 else
82 let hsmod = unLoc rdr_module
83 mb_mod = hsmodName hsmod
84 imps = hsmodImports hsmod
85 main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
86 1 1)
87 mod = mb_mod `orElse` cL main_loc mAIN_NAME
88 (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
89
90 -- GHC.Prim doesn't exist physically, so don't go looking for it.
91 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
92 . ideclName . unLoc)
93 ord_idecls
94
95 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
96 implicit_imports = mkPrelImports (unLoc mod) main_loc
97 implicit_prelude imps
98 convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
99 , ideclName i)
100 in
101 return (map convImport src_idecls,
102 map convImport (implicit_imports ++ ordinary_imps),
103 mod)
104
105 mkPrelImports :: ModuleName
106 -> SrcSpan -- Attribute the "import Prelude" to this location
107 -> Bool -> [LImportDecl GhcPs]
108 -> [LImportDecl GhcPs]
109 -- Construct the implicit declaration "import Prelude" (or not)
110 --
111 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
112 -- because the former doesn't even look at Prelude.hi for instance
113 -- declarations, whereas the latter does.
114 mkPrelImports this_mod loc implicit_prelude import_decls
115 | this_mod == pRELUDE_NAME
116 || explicit_prelude_import
117 || not implicit_prelude
118 = []
119 | otherwise = [preludeImportDecl]
120 where
121 explicit_prelude_import
122 = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
123 , ideclPkgQual = Nothing }))
124 <- import_decls
125 , unLoc mod == pRELUDE_NAME ]
126
127 preludeImportDecl :: LImportDecl GhcPs
128 preludeImportDecl
129 = cL loc $ ImportDecl { ideclExt = noExtField,
130 ideclSourceSrc = NoSourceText,
131 ideclName = cL loc pRELUDE_NAME,
132 ideclPkgQual = Nothing,
133 ideclSource = False,
134 ideclSafe = False, -- Not a safe import
135 ideclQualified = NotQualified,
136 ideclImplicit = True, -- Implicit!
137 ideclAs = Nothing,
138 ideclHiding = Nothing }
139
140 --------------------------------------------------------------
141 -- Get options
142 --------------------------------------------------------------
143
144 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
145 --
146 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
147 getOptionsFromFile :: DynFlags
148 -> FilePath -- ^ Input file
149 -> IO [Located String] -- ^ Parsed options, if any.
150 getOptionsFromFile dflags filename
151 = Exception.bracket
152 (openBinaryFile filename ReadMode)
153 (hClose)
154 (\handle -> do
155 opts <- fmap (getOptions' dflags)
156 (lazyGetToks dflags' filename handle)
157 seqList opts $ return opts)
158 where -- We don't need to get haddock doc tokens when we're just
159 -- getting the options from pragmas, and lazily lexing them
160 -- correctly is a little tricky: If there is "\n" or "\n-"
161 -- left at the end of a buffer then the haddock doc may
162 -- continue past the end of the buffer, despite the fact that
163 -- we already have an apparently-complete token.
164 -- We therefore just turn Opt_Haddock off when doing the lazy
165 -- lex.
166 dflags' = gopt_unset dflags Opt_Haddock
167
168 blockSize :: Int
169 -- blockSize = 17 -- for testing :-)
170 blockSize = 1024
171
172 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
173 lazyGetToks dflags filename handle = do
174 buf <- hGetStringBufferBlock handle blockSize
175 unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
176 where
177 loc = mkRealSrcLoc (mkFastString filename) 1 1
178
179 lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
180 lazyLexBuf handle state eof size = do
181 case unP (lexer False return) state of
182 POk state' t -> do
183 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
184 if atEnd (buffer state') && not eof
185 -- if this token reached the end of the buffer, and we haven't
186 -- necessarily read up to the end of the file, then the token might
187 -- be truncated, so read some more of the file and lex it again.
188 then getMore handle state size
189 else case unLoc t of
190 ITeof -> return [t]
191 _other -> do rest <- lazyLexBuf handle state' eof size
192 return (t : rest)
193 _ | not eof -> getMore handle state size
194 | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
195 -- parser assumes an ITeof sentinel at the end
196
197 getMore :: Handle -> PState -> Int -> IO [Located Token]
198 getMore handle state size = do
199 -- pprTrace "getMore" (text (show (buffer state))) (return ())
200 let new_size = size * 2
201 -- double the buffer size each time we read a new block. This
202 -- counteracts the quadratic slowdown we otherwise get for very
203 -- large module names (#5981)
204 nextbuf <- hGetStringBufferBlock handle new_size
205 if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
206 newbuf <- appendStringBuffers (buffer state) nextbuf
207 unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
208
209
210 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
211 getToks dflags filename buf = lexAll (pragState dflags buf loc)
212 where
213 loc = mkRealSrcLoc (mkFastString filename) 1 1
214
215 lexAll state = case unP (lexer False return) state of
216 POk _ t@(dL->L _ ITeof) -> [t]
217 POk state' t -> t : lexAll state'
218 _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
219
220
221 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
222 --
223 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
224 getOptions :: DynFlags
225 -> StringBuffer -- ^ Input Buffer
226 -> FilePath -- ^ Source filename. Used for location info.
227 -> [Located String] -- ^ Parsed options.
228 getOptions dflags buf filename
229 = getOptions' dflags (getToks dflags filename buf)
230
231 -- The token parser is written manually because Happy can't
232 -- return a partial result when it encounters a lexer error.
233 -- We want to extract options before the buffer is passed through
234 -- CPP, so we can't use the same trick as 'getImports'.
235 getOptions' :: DynFlags
236 -> [Located Token] -- Input buffer
237 -> [Located String] -- Options.
238 getOptions' dflags toks
239 = parseToks toks
240 where
241 parseToks (open:close:xs)
242 | IToptions_prag str <- unLoc open
243 , ITclose_prag <- unLoc close
244 = case toArgs str of
245 Left _err -> optionsParseError str dflags $ -- #15053
246 combineSrcSpans (getLoc open) (getLoc close)
247 Right args -> map (cL (getLoc open)) args ++ parseToks xs
248 parseToks (open:close:xs)
249 | ITinclude_prag str <- unLoc open
250 , ITclose_prag <- unLoc close
251 = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
252 parseToks xs
253 parseToks (open:close:xs)
254 | ITdocOptions str <- unLoc open
255 , ITclose_prag <- unLoc close
256 = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
257 ++ parseToks xs
258 parseToks (open:xs)
259 | ITlanguage_prag <- unLoc open
260 = parseLanguage xs
261 parseToks (comment:xs) -- Skip over comments
262 | isComment (unLoc comment)
263 = parseToks xs
264 parseToks _ = []
265 parseLanguage ((dL->L loc (ITconid fs)):rest)
266 = checkExtension dflags (cL loc fs) :
267 case rest of
268 (dL->L _loc ITcomma):more -> parseLanguage more
269 (dL->L _loc ITclose_prag):more -> parseToks more
270 (dL->L loc _):_ -> languagePragParseError dflags loc
271 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
272 parseLanguage (tok:_)
273 = languagePragParseError dflags (getLoc tok)
274 parseLanguage []
275 = panic "getOptions'.parseLanguage(2) went past eof token"
276
277 isComment :: Token -> Bool
278 isComment c =
279 case c of
280 (ITlineComment {}) -> True
281 (ITblockComment {}) -> True
282 (ITdocCommentNext {}) -> True
283 (ITdocCommentPrev {}) -> True
284 (ITdocCommentNamed {}) -> True
285 (ITdocSection {}) -> True
286 _ -> False
287
288 -----------------------------------------------------------------------------
289
290 -- | Complain about non-dynamic flags in OPTIONS pragmas.
291 --
292 -- Throws a 'SourceError' if the input list is non-empty claiming that the
293 -- input flags are unknown.
294 checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
295 checkProcessArgsResult dflags flags
296 = when (notNull flags) $
297 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
298 where mkMsg (dL->L loc flag)
299 = mkPlainErrMsg dflags loc $
300 (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
301 text flag)
302
303 -----------------------------------------------------------------------------
304
305 checkExtension :: DynFlags -> Located FastString -> Located String
306 checkExtension dflags (dL->L l ext)
307 -- Checks if a given extension is valid, and if so returns
308 -- its corresponding flag. Otherwise it throws an exception.
309 = let ext' = unpackFS ext in
310 if ext' `elem` supportedLanguagesAndExtensions
311 then cL l ("-X"++ext')
312 else unsupportedExtnError dflags l ext'
313
314 languagePragParseError :: DynFlags -> SrcSpan -> a
315 languagePragParseError dflags loc =
316 throwErr dflags loc $
317 vcat [ text "Cannot parse LANGUAGE pragma"
318 , text "Expecting comma-separated list of language options,"
319 , text "each starting with a capital letter"
320 , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
321
322 unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
323 unsupportedExtnError dflags loc unsup =
324 throwErr dflags loc $
325 text "Unsupported extension: " <> text unsup $$
326 if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
327 where
328 suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
329
330
331 optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
332 optionsErrorMsgs dflags unhandled_flags flags_lines _filename
333 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
334 where unhandled_flags_lines :: [Located String]
335 unhandled_flags_lines = [ cL l f
336 | f <- unhandled_flags
337 , (dL->L l f') <- flags_lines
338 , f == f' ]
339 mkMsg (dL->L flagSpan flag) =
340 ErrUtils.mkPlainErrMsg dflags flagSpan $
341 text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
342
343 optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053
344 optionsParseError str dflags loc =
345 throwErr dflags loc $
346 vcat [ text "Error while parsing OPTIONS_GHC pragma."
347 , text "Expecting whitespace-separated list of GHC options."
348 , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
349 , text ("Input was: " ++ show str) ]
350
351 throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053
352 throwErr dflags loc doc =
353 throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc