Use -fwarn-tabs when validating
[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 -> Message -> 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
147 blockSize :: Int
148 -- blockSize = 17 -- for testing :-)
149 blockSize = 1024
150
151 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
152 lazyGetToks dflags filename handle = do
153 buf <- hGetStringBufferBlock handle blockSize
154 unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
155 where
156 loc = mkRealSrcLoc (mkFastString filename) 1 1
157
158 lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
159 lazyLexBuf handle state eof = do
160 case unP (lexer return) state of
161 POk state' t -> do
162 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
163 if atEnd (buffer state') && not eof
164 -- if this token reached the end of the buffer, and we haven't
165 -- necessarily read up to the end of the file, then the token might
166 -- be truncated, so read some more of the file and lex it again.
167 then getMore handle state
168 else case t of
169 L _ ITeof -> return [t]
170 _other -> do rest <- lazyLexBuf handle state' eof
171 return (t : rest)
172 _ | not eof -> getMore handle state
173 | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
174 -- parser assumes an ITeof sentinel at the end
175
176 getMore :: Handle -> PState -> IO [Located Token]
177 getMore handle state = do
178 -- pprTrace "getMore" (text (show (buffer state))) (return ())
179 nextbuf <- hGetStringBufferBlock handle blockSize
180 if (len nextbuf == 0) then lazyLexBuf handle state True else do
181 newbuf <- appendStringBuffers (buffer state) nextbuf
182 unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
183
184
185 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
186 getToks dflags filename buf = lexAll (pragState dflags buf loc)
187 where
188 loc = mkRealSrcLoc (mkFastString filename) 1 1
189
190 lexAll state = case unP (lexer return) state of
191 POk _ t@(L _ ITeof) -> [t]
192 POk state' t -> t : lexAll state'
193 _ -> [L (RealSrcSpan (last_loc state)) ITeof]
194
195
196 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
197 --
198 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
199 getOptions :: DynFlags
200 -> StringBuffer -- ^ Input Buffer
201 -> FilePath -- ^ Source filename. Used for location info.
202 -> [Located String] -- ^ Parsed options.
203 getOptions dflags buf filename
204 = getOptions' (getToks dflags filename buf)
205
206 -- The token parser is written manually because Happy can't
207 -- return a partial result when it encounters a lexer error.
208 -- We want to extract options before the buffer is passed through
209 -- CPP, so we can't use the same trick as 'getImports'.
210 getOptions' :: [Located Token] -- Input buffer
211 -> [Located String] -- Options.
212 getOptions' toks
213 = parseToks toks
214 where
215 getToken (L _loc tok) = tok
216 getLoc (L loc _tok) = loc
217
218 parseToks (open:close:xs)
219 | IToptions_prag str <- getToken open
220 , ITclose_prag <- getToken close
221 = map (L (getLoc open)) (words str) ++
222 parseToks xs
223 parseToks (open:close:xs)
224 | ITinclude_prag str <- getToken open
225 , ITclose_prag <- getToken close
226 = map (L (getLoc open)) ["-#include",removeSpaces str] ++
227 parseToks xs
228 parseToks (open:close:xs)
229 | ITdocOptions str <- getToken open
230 , ITclose_prag <- getToken close
231 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
232 ++ parseToks xs
233 parseToks (open:xs)
234 | ITdocOptionsOld str <- getToken open
235 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
236 ++ parseToks xs
237 parseToks (open:xs)
238 | ITlanguage_prag <- getToken open
239 = parseLanguage xs
240 parseToks (x:xs)
241 | ITdocCommentNext _ <- getToken x
242 = parseToks xs
243 parseToks _ = []
244 parseLanguage (L loc (ITconid fs):rest)
245 = checkExtension (L loc fs) :
246 case rest of
247 (L _loc ITcomma):more -> parseLanguage more
248 (L _loc ITclose_prag):more -> parseToks more
249 (L loc _):_ -> languagePragParseError loc
250 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
251 parseLanguage (tok:_)
252 = languagePragParseError (getLoc tok)
253 parseLanguage []
254 = panic "getOptions'.parseLanguage(2) went past eof token"
255
256 -----------------------------------------------------------------------------
257
258 -- | Complain about non-dynamic flags in OPTIONS pragmas.
259 --
260 -- Throws a 'SourceError' if the input list is non-empty claiming that the
261 -- input flags are unknown.
262 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
263 checkProcessArgsResult flags
264 = when (notNull flags) $
265 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
266 where mkMsg (L loc flag)
267 = mkPlainErrMsg loc $
268 (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
269 text flag)
270
271 -----------------------------------------------------------------------------
272
273 checkExtension :: Located FastString -> Located String
274 checkExtension (L l ext)
275 -- Checks if a given extension is valid, and if so returns
276 -- its corresponding flag. Otherwise it throws an exception.
277 = let ext' = unpackFS ext in
278 if ext' `elem` supportedLanguagesAndExtensions
279 then L l ("-X"++ext')
280 else unsupportedExtnError l ext'
281
282 languagePragParseError :: SrcSpan -> a
283 languagePragParseError loc =
284 throw $ mkSrcErr $ unitBag $
285 (mkPlainErrMsg loc $
286 vcat [ text "Cannot parse LANGUAGE pragma"
287 , text "Expecting comma-separated list of language options,"
288 , text "each starting with a capital letter"
289 , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
290
291 unsupportedExtnError :: SrcSpan -> String -> a
292 unsupportedExtnError loc unsup =
293 throw $ mkSrcErr $ unitBag $
294 mkPlainErrMsg loc $
295 text "Unsupported extension: " <> text unsup $$
296 if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
297 where
298 suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
299
300
301 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
302 optionsErrorMsgs unhandled_flags flags_lines _filename
303 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
304 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
305 L l f' <- flags_lines, f == f' ]
306 mkMsg (L flagSpan flag) =
307 ErrUtils.mkPlainErrMsg flagSpan $
308 text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
309