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