Rename "language" varibles etc to "extension", and add --supported-extensions
[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 module HeaderInfo ( getImports
12 , mkPrelImports -- used by the renamer too
13 , getOptionsFromFile, getOptions
14 , optionsErrorMsgs,
15 checkProcessArgsResult ) where
16
17 #include "HsVersions.h"
18
19 import RdrName
20 import HscTypes
21 import Parser ( parseHeader )
22 import Lexer
23 import FastString
24 import HsSyn
25 import Module
26 import PrelNames
27 import StringBuffer
28 import SrcLoc
29 import DynFlags
30 import ErrUtils
31 import Util
32 import Outputable
33 import Pretty ()
34 import Maybes
35 import Bag ( emptyBag, listToBag, unitBag )
36
37 import MonadUtils ( MonadIO )
38 import Exception
39 import Control.Monad
40 import System.IO
41 import System.IO.Unsafe
42 import Data.List
43
44 ------------------------------------------------------------------------------
45
46 -- | Parse the imports of a source file.
47 --
48 -- Throws a 'SourceError' if parsing fails.
49 getImports :: GhcMonad m =>
50 DynFlags
51 -> StringBuffer -- ^ Parse this.
52 -> FilePath -- ^ Filename the buffer came from. Used for
53 -- reporting parse error locations.
54 -> FilePath -- ^ The original source filename (used for locations
55 -- in the function result)
56 -> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
57 -- ^ The source imports, normal imports, and the module name.
58 getImports dflags buf filename source_filename = do
59 let loc = mkSrcLoc (mkFastString filename) 1 1
60 case unP parseHeader (mkPState dflags buf loc) of
61 PFailed span err -> parseError span err
62 POk pst rdr_module -> do
63 let _ms@(_warns, errs) = getMessages pst
64 -- don't log warnings: they'll be reported when we parse the file
65 -- for real. See #2500.
66 ms = (emptyBag, errs)
67 -- logWarnings warns
68 if errorsFound dflags ms
69 then liftIO $ throwIO $ mkSrcErr errs
70 else
71 case rdr_module of
72 L _ (HsModule mb_mod _ imps _ _ _) ->
73 let
74 main_loc = mkSrcLoc (mkFastString source_filename) 1 1
75 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
76 (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
77
78 -- GHC.Prim doesn't exist physically, so don't go looking for it.
79 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
80 ord_idecls
81
82 implicit_prelude = dopt Opt_ImplicitPrelude dflags
83 implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
84 in
85 return (src_idecls, implicit_imports ++ ordinary_imps, mod)
86
87 mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName]
88 -> [LImportDecl RdrName]
89 -- Consruct the implicit declaration "import Prelude" (or not)
90 --
91 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
92 -- because the former doesn't even look at Prelude.hi for instance
93 -- declarations, whereas the latter does.
94 mkPrelImports this_mod implicit_prelude import_decls
95 | this_mod == pRELUDE_NAME
96 || explicit_prelude_import
97 || not implicit_prelude
98 = []
99 | otherwise = [preludeImportDecl]
100 where
101 explicit_prelude_import
102 = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls,
103 unLoc mod == pRELUDE_NAME ]
104
105 preludeImportDecl :: LImportDecl RdrName
106 preludeImportDecl
107 = L loc $
108 ImportDecl (L loc pRELUDE_NAME)
109 Nothing {- no specific package -}
110 False {- Not a boot interface -}
111 False {- Not qualified -}
112 Nothing {- No "as" -}
113 Nothing {- No import list -}
114
115 loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
116
117 parseError :: GhcMonad m => SrcSpan -> Message -> m a
118 parseError span err = throwOneError $ mkPlainErrMsg span err
119
120 --------------------------------------------------------------
121 -- Get options
122 --------------------------------------------------------------
123
124 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
125 --
126 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
127 getOptionsFromFile :: DynFlags
128 -> FilePath -- ^ Input file
129 -> IO [Located String] -- ^ Parsed options, if any.
130 getOptionsFromFile dflags filename
131 = Exception.bracket
132 (openBinaryFile filename ReadMode)
133 (hClose)
134 (\handle -> do
135 opts <- fmap getOptions' $ lazyGetToks dflags filename handle
136 seqList opts $ return opts)
137
138 blockSize :: Int
139 -- blockSize = 17 -- for testing :-)
140 blockSize = 1024
141
142 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
143 lazyGetToks dflags filename handle = do
144 buf <- hGetStringBufferBlock handle blockSize
145 unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
146 where
147 loc = mkSrcLoc (mkFastString filename) 1 1
148
149 lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
150 lazyLexBuf handle state eof = do
151 case unP (lexer return) state of
152 POk state' t -> do
153 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
154 if atEnd (buffer state') && not eof
155 -- if this token reached the end of the buffer, and we haven't
156 -- necessarily read up to the end of the file, then the token might
157 -- be truncated, so read some more of the file and lex it again.
158 then getMore handle state
159 else case t of
160 L _ ITeof -> return [t]
161 _other -> do rest <- lazyLexBuf handle state' eof
162 return (t : rest)
163 _ | not eof -> getMore handle state
164 | otherwise -> return [L (last_loc state) ITeof]
165 -- parser assumes an ITeof sentinel at the end
166
167 getMore :: Handle -> PState -> IO [Located Token]
168 getMore handle state = do
169 -- pprTrace "getMore" (text (show (buffer state))) (return ())
170 nextbuf <- hGetStringBufferBlock handle blockSize
171 if (len nextbuf == 0) then lazyLexBuf handle state True else do
172 newbuf <- appendStringBuffers (buffer state) nextbuf
173 unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
174
175
176 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
177 getToks dflags filename buf = lexAll (pragState dflags buf loc)
178 where
179 loc = mkSrcLoc (mkFastString filename) 1 1
180
181 lexAll state = case unP (lexer return) state of
182 POk _ t@(L _ ITeof) -> [t]
183 POk state' t -> t : lexAll state'
184 _ -> [L (last_loc state) ITeof]
185
186
187 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
188 --
189 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
190 getOptions :: DynFlags
191 -> StringBuffer -- ^ Input Buffer
192 -> FilePath -- ^ Source filename. Used for location info.
193 -> [Located String] -- ^ Parsed options.
194 getOptions dflags buf filename
195 = getOptions' (getToks dflags filename buf)
196
197 -- The token parser is written manually because Happy can't
198 -- return a partial result when it encounters a lexer error.
199 -- We want to extract options before the buffer is passed through
200 -- CPP, so we can't use the same trick as 'getImports'.
201 getOptions' :: [Located Token] -- Input buffer
202 -> [Located String] -- Options.
203 getOptions' toks
204 = parseToks toks
205 where
206 getToken (L _loc tok) = tok
207 getLoc (L loc _tok) = loc
208
209 parseToks (open:close:xs)
210 | IToptions_prag str <- getToken open
211 , ITclose_prag <- getToken close
212 = map (L (getLoc open)) (words str) ++
213 parseToks xs
214 parseToks (open:close:xs)
215 | ITinclude_prag str <- getToken open
216 , ITclose_prag <- getToken close
217 = map (L (getLoc open)) ["-#include",removeSpaces str] ++
218 parseToks xs
219 parseToks (open:close:xs)
220 | ITdocOptions str <- getToken open
221 , ITclose_prag <- getToken close
222 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
223 ++ parseToks xs
224 parseToks (open:xs)
225 | ITdocOptionsOld str <- getToken open
226 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
227 ++ parseToks xs
228 parseToks (open:xs)
229 | ITlanguage_prag <- getToken open
230 = parseLanguage xs
231 parseToks (x:xs)
232 | ITdocCommentNext _ <- getToken x
233 = parseToks xs
234 parseToks _ = []
235 parseLanguage (L loc (ITconid fs):rest)
236 = checkExtension (L loc fs) :
237 case rest of
238 (L _loc ITcomma):more -> parseLanguage more
239 (L _loc ITclose_prag):more -> parseToks more
240 (L loc _):_ -> languagePragParseError loc
241 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
242 parseLanguage (tok:_)
243 = languagePragParseError (getLoc tok)
244 parseLanguage []
245 = panic "getOptions'.parseLanguage(2) went past eof token"
246
247 -----------------------------------------------------------------------------
248
249 -- | Complain about non-dynamic flags in OPTIONS pragmas.
250 --
251 -- Throws a 'SourceError' if the input list is non-empty claiming that the
252 -- input flags are unknown.
253 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
254 checkProcessArgsResult flags
255 = when (notNull flags) $
256 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
257 where mkMsg (L loc flag)
258 = mkPlainErrMsg loc $
259 (text "unknown flag in {-# OPTIONS #-} pragma:" <+>
260 text flag)
261
262 -----------------------------------------------------------------------------
263
264 checkExtension :: Located FastString -> Located String
265 checkExtension (L l ext)
266 -- Checks if a given extension is valid, and if so returns
267 -- its corresponding flag. Otherwise it throws an exception.
268 = let ext' = unpackFS ext in
269 if ext' `elem` supportedExtensions
270 then L l ("-X"++ext')
271 else unsupportedExtnError l ext'
272
273 languagePragParseError :: SrcSpan -> a
274 languagePragParseError loc =
275 throw $ mkSrcErr $ unitBag $
276 (mkPlainErrMsg loc $
277 vcat [ text "Cannot parse LANGUAGE pragma"
278 , text "Expecting comma-separated list of language options,"
279 , text "each starting with a capital letter"
280 , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
281
282 unsupportedExtnError :: SrcSpan -> String -> a
283 unsupportedExtnError loc unsup =
284 throw $ mkSrcErr $ unitBag $
285 mkPlainErrMsg loc $
286 text "Unsupported extension: " <> text unsup $$
287 if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
288 where suggestions = fuzzyMatch unsup supportedExtensions
289
290
291 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
292 optionsErrorMsgs unhandled_flags flags_lines _filename
293 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
294 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
295 L l f' <- flags_lines, f == f' ]
296 mkMsg (L flagSpan flag) =
297 ErrUtils.mkPlainErrMsg flagSpan $
298 text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag
299