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