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