Merge branch 'master' of http://darcs.haskell.org/ghc
[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 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 :: SrcSpan -> MsgDoc -> IO a
127 parseError span err = throwOneError $ mkPlainErrMsg 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' $ lazyGetToks dflags' filename handle
145 seqList opts $ return opts)
146 where -- We don't need to get haddock doc tokens when we're just
147 -- getting the options from pragmas, and lazily lexing them
148 -- correctly is a little tricky: If there is "\n" or "\n-"
149 -- left at the end of a buffer then the haddock doc may
150 -- continue past the end of the buffer, despite the fact that
151 -- we already have an apparently-complete token.
152 -- We therefore just turn Opt_Haddock off when doing the lazy
153 -- lex.
154 dflags' = dopt_unset dflags Opt_Haddock
155
156 blockSize :: Int
157 -- blockSize = 17 -- for testing :-)
158 blockSize = 1024
159
160 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
161 lazyGetToks dflags filename handle = do
162 buf <- hGetStringBufferBlock handle blockSize
163 unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
164 where
165 loc = mkRealSrcLoc (mkFastString filename) 1 1
166
167 lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
168 lazyLexBuf handle state eof = do
169 case unP (lexer return) state of
170 POk state' t -> do
171 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
172 if atEnd (buffer state') && not eof
173 -- if this token reached the end of the buffer, and we haven't
174 -- necessarily read up to the end of the file, then the token might
175 -- be truncated, so read some more of the file and lex it again.
176 then getMore handle state
177 else case t of
178 L _ ITeof -> return [t]
179 _other -> do rest <- lazyLexBuf handle state' eof
180 return (t : rest)
181 _ | not eof -> getMore handle state
182 | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
183 -- parser assumes an ITeof sentinel at the end
184
185 getMore :: Handle -> PState -> IO [Located Token]
186 getMore handle state = do
187 -- pprTrace "getMore" (text (show (buffer state))) (return ())
188 nextbuf <- hGetStringBufferBlock handle blockSize
189 if (len nextbuf == 0) then lazyLexBuf handle state True else do
190 newbuf <- appendStringBuffers (buffer state) nextbuf
191 unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
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' (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' :: [Located Token] -- Input buffer
220 -> [Located String] -- Options.
221 getOptions' toks
222 = parseToks toks
223 where
224 getToken (L _loc tok) = tok
225 getLoc (L loc _tok) = loc
226
227 parseToks (open:close:xs)
228 | IToptions_prag str <- getToken open
229 , ITclose_prag <- getToken close
230 = map (L (getLoc open)) (words str) ++
231 parseToks xs
232 parseToks (open:close:xs)
233 | ITinclude_prag str <- getToken open
234 , ITclose_prag <- getToken close
235 = map (L (getLoc open)) ["-#include",removeSpaces str] ++
236 parseToks xs
237 parseToks (open:close:xs)
238 | ITdocOptions str <- getToken open
239 , ITclose_prag <- getToken close
240 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
241 ++ parseToks xs
242 parseToks (open:xs)
243 | ITdocOptionsOld str <- getToken open
244 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
245 ++ parseToks xs
246 parseToks (open:xs)
247 | ITlanguage_prag <- getToken open
248 = parseLanguage xs
249 parseToks _ = []
250 parseLanguage (L loc (ITconid fs):rest)
251 = checkExtension (L loc fs) :
252 case rest of
253 (L _loc ITcomma):more -> parseLanguage more
254 (L _loc ITclose_prag):more -> parseToks more
255 (L loc _):_ -> languagePragParseError loc
256 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
257 parseLanguage (tok:_)
258 = languagePragParseError (getLoc tok)
259 parseLanguage []
260 = panic "getOptions'.parseLanguage(2) went past eof token"
261
262 -----------------------------------------------------------------------------
263
264 -- | Complain about non-dynamic flags in OPTIONS pragmas.
265 --
266 -- Throws a 'SourceError' if the input list is non-empty claiming that the
267 -- input flags are unknown.
268 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
269 checkProcessArgsResult flags
270 = when (notNull flags) $
271 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
272 where mkMsg (L loc flag)
273 = mkPlainErrMsg loc $
274 (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
275 text flag)
276
277 -----------------------------------------------------------------------------
278
279 checkExtension :: Located FastString -> Located String
280 checkExtension (L l ext)
281 -- Checks if a given extension is valid, and if so returns
282 -- its corresponding flag. Otherwise it throws an exception.
283 = let ext' = unpackFS ext in
284 if ext' `elem` supportedLanguagesAndExtensions
285 then L l ("-X"++ext')
286 else unsupportedExtnError l ext'
287
288 languagePragParseError :: SrcSpan -> a
289 languagePragParseError loc =
290 throw $ mkSrcErr $ unitBag $
291 (mkPlainErrMsg loc $
292 vcat [ text "Cannot parse LANGUAGE pragma"
293 , text "Expecting comma-separated list of language options,"
294 , text "each starting with a capital letter"
295 , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
296
297 unsupportedExtnError :: SrcSpan -> String -> a
298 unsupportedExtnError loc unsup =
299 throw $ mkSrcErr $ unitBag $
300 mkPlainErrMsg loc $
301 text "Unsupported extension: " <> text unsup $$
302 if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
303 where
304 suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
305
306
307 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
308 optionsErrorMsgs unhandled_flags flags_lines _filename
309 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
310 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
311 L l f' <- flags_lines, f == f' ]
312 mkMsg (L flagSpan flag) =
313 ErrUtils.mkPlainErrMsg flagSpan $
314 text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
315