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