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