SafeHaskell: Disable certain ghc extensions in Safe.
[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 import MonadUtils
37 import Exception
38
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 :: DynFlags
50 -> StringBuffer -- ^ Parse this.
51 -> FilePath -- ^ Filename the buffer came from. Used for
52 -- reporting parse error locations.
53 -> FilePath -- ^ The original source filename (used for locations
54 -- in the function result)
55 -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
56 -- ^ The source imports, normal imports, and the module name.
57 getImports dflags buf filename source_filename = do
58 let loc = mkRealSrcLoc (mkFastString filename) 1 1
59 case unP parseHeader (mkPState dflags buf loc) of
60 PFailed span err -> parseError span err
61 POk pst rdr_module -> do
62 let _ms@(_warns, errs) = getMessages pst
63 -- don't log warnings: they'll be reported when we parse the file
64 -- for real. See #2500.
65 ms = (emptyBag, errs)
66 -- logWarnings warns
67 if errorsFound dflags ms
68 then throwIO $ mkSrcErr errs
69 else
70 case rdr_module of
71 L _ (HsModule mb_mod _ imps _ _ _) ->
72 let
73 main_loc = mkSrcLoc (mkFastString source_filename) 1 1
74 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
75 (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
76
77 -- GHC.Prim doesn't exist physically, so don't go looking for it.
78 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
79 ord_idecls
80
81 implicit_prelude = xopt Opt_ImplicitPrelude dflags
82 implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
83 in
84 return (src_idecls, implicit_imports ++ ordinary_imps, mod)
85
86 mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName]
87 -> [LImportDecl RdrName]
88 -- Consruct the implicit declaration "import Prelude" (or not)
89 --
90 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
91 -- because the former doesn't even look at Prelude.hi for instance
92 -- declarations, whereas the latter does.
93 mkPrelImports this_mod implicit_prelude import_decls
94 | this_mod == pRELUDE_NAME
95 || explicit_prelude_import
96 || not implicit_prelude
97 = []
98 | otherwise = [preludeImportDecl]
99 where
100 explicit_prelude_import
101 = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _ _) <- import_decls,
102 unLoc mod == pRELUDE_NAME ]
103
104 preludeImportDecl :: LImportDecl RdrName
105 preludeImportDecl
106 = L loc $
107 ImportDecl (L loc pRELUDE_NAME)
108 Nothing {- No specific package -}
109 False {- Not a boot interface -}
110 False {- Not a safe import -}
111 False {- Not qualified -}
112 Nothing {- No "as" -}
113 Nothing {- No import list -}
114
115 loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
116
117 parseError :: SrcSpan -> Message -> IO 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 = mkRealSrcLoc (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 (RealSrcSpan (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 = mkRealSrcLoc (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 (RealSrcSpan (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_GHC #-} 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` supportedLanguagesAndExtensions
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
289 suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
290
291
292 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
293 optionsErrorMsgs unhandled_flags flags_lines _filename
294 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
295 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
296 L l f' <- flags_lines, f == f' ]
297 mkMsg (L flagSpan flag) =
298 ErrUtils.mkPlainErrMsg flagSpan $
299 text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
300