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