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