Always enable the external interpreter
[ghc.git] / compiler / main / HeaderInfo.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ViewPatterns #-}
3 {-# LANGUAGE TypeFamilies #-}
4
5 -----------------------------------------------------------------------------
6 --
7 -- | Parsing the top of a Haskell source file to get its module name,
8 -- imports and options.
9 --
10 -- (c) Simon Marlow 2005
11 -- (c) Lemmih 2006
12 --
13 -----------------------------------------------------------------------------
14
15 module HeaderInfo ( getImports
16 , mkPrelImports -- used by the renamer too
17 , getOptionsFromFile, getOptions
18 , optionsErrorMsgs,
19 checkProcessArgsResult ) where
20
21 #include "HsVersions.h"
22
23 import GhcPrelude
24
25 import GHC.Platform
26 import HscTypes
27 import Parser ( parseHeader )
28 import Lexer
29 import FastString
30 import GHC.Hs
31 import Module
32 import PrelNames
33 import StringBuffer
34 import SrcLoc
35 import DynFlags
36 import ErrUtils
37 import Util
38 import Outputable
39 import Maybes
40 import Bag ( emptyBag, listToBag, unitBag )
41 import MonadUtils
42 import Exception
43 import BasicTypes
44 import qualified GHC.LanguageExtensions as LangExt
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 (Either
63 ErrorMessages
64 ([(Maybe FastString, Located ModuleName)],
65 [(Maybe FastString, Located ModuleName)],
66 Located ModuleName))
67 -- ^ The source imports, normal imports, and the module name.
68 getImports dflags buf filename source_filename = do
69 let loc = mkRealSrcLoc (mkFastString filename) 1 1
70 case unP parseHeader (mkPState dflags buf loc) of
71 PFailed pst ->
72 -- assuming we're not logging warnings here as per below
73 return $ Left $ getErrorMessages pst dflags
74 POk pst rdr_module -> fmap Right $ do
75 let _ms@(_warns, errs) = getMessages pst dflags
76 -- don't log warnings: they'll be reported when we parse the file
77 -- for real. See #2500.
78 ms = (emptyBag, errs)
79 -- logWarnings warns
80 if errorsFound dflags ms
81 then throwIO $ mkSrcErr errs
82 else
83 let hsmod = unLoc rdr_module
84 mb_mod = hsmodName hsmod
85 imps = hsmodImports hsmod
86 main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
87 1 1)
88 mod = mb_mod `orElse` cL main_loc mAIN_NAME
89 (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
90
91 -- GHC.Prim doesn't exist physically, so don't go looking for it.
92 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
93 . ideclName . unLoc)
94 ord_idecls
95
96 implicit_prelude = xopt LangExt.ImplicitPrelude dflags
97 implicit_imports = mkPrelImports (unLoc mod) main_loc
98 implicit_prelude imps
99 convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
100 , ideclName i)
101 in
102 return (map convImport src_idecls,
103 map convImport (implicit_imports ++ ordinary_imps),
104 mod)
105
106 mkPrelImports :: ModuleName
107 -> SrcSpan -- Attribute the "import Prelude" to this location
108 -> Bool -> [LImportDecl GhcPs]
109 -> [LImportDecl GhcPs]
110 -- Construct the implicit declaration "import Prelude" (or not)
111 --
112 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
113 -- because the former doesn't even look at Prelude.hi for instance
114 -- declarations, whereas the latter does.
115 mkPrelImports this_mod loc implicit_prelude import_decls
116 | this_mod == pRELUDE_NAME
117 || explicit_prelude_import
118 || not implicit_prelude
119 = []
120 | otherwise = [preludeImportDecl]
121 where
122 explicit_prelude_import
123 = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
124 , ideclPkgQual = Nothing }))
125 <- import_decls
126 , unLoc mod == pRELUDE_NAME ]
127
128 preludeImportDecl :: LImportDecl GhcPs
129 preludeImportDecl
130 = cL loc $ ImportDecl { ideclExt = noExtField,
131 ideclSourceSrc = NoSourceText,
132 ideclName = cL loc pRELUDE_NAME,
133 ideclPkgQual = Nothing,
134 ideclSource = False,
135 ideclSafe = False, -- Not a safe import
136 ideclQualified = NotQualified,
137 ideclImplicit = True, -- Implicit!
138 ideclAs = Nothing,
139 ideclHiding = Nothing }
140
141 --------------------------------------------------------------
142 -- Get options
143 --------------------------------------------------------------
144
145 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
146 --
147 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
148 getOptionsFromFile :: DynFlags
149 -> FilePath -- ^ Input file
150 -> IO [Located String] -- ^ Parsed options, if any.
151 getOptionsFromFile dflags filename
152 = Exception.bracket
153 (openBinaryFile filename ReadMode)
154 (hClose)
155 (\handle -> do
156 opts <- fmap (getOptions' dflags)
157 (lazyGetToks dflags' filename handle)
158 seqList opts $ return opts)
159 where -- We don't need to get haddock doc tokens when we're just
160 -- getting the options from pragmas, and lazily lexing them
161 -- correctly is a little tricky: If there is "\n" or "\n-"
162 -- left at the end of a buffer then the haddock doc may
163 -- continue past the end of the buffer, despite the fact that
164 -- we already have an apparently-complete token.
165 -- We therefore just turn Opt_Haddock off when doing the lazy
166 -- lex.
167 dflags' = gopt_unset dflags Opt_Haddock
168
169 blockSize :: Int
170 -- blockSize = 17 -- for testing :-)
171 blockSize = 1024
172
173 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
174 lazyGetToks dflags filename handle = do
175 buf <- hGetStringBufferBlock handle blockSize
176 unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
177 where
178 loc = mkRealSrcLoc (mkFastString filename) 1 1
179
180 lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
181 lazyLexBuf handle state eof size = do
182 case unP (lexer False return) state of
183 POk state' t -> do
184 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
185 if atEnd (buffer state') && not eof
186 -- if this token reached the end of the buffer, and we haven't
187 -- necessarily read up to the end of the file, then the token might
188 -- be truncated, so read some more of the file and lex it again.
189 then getMore handle state size
190 else case unLoc t of
191 ITeof -> return [t]
192 _other -> do rest <- lazyLexBuf handle state' eof size
193 return (t : rest)
194 _ | not eof -> getMore handle state size
195 | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
196 -- parser assumes an ITeof sentinel at the end
197
198 getMore :: Handle -> PState -> Int -> IO [Located Token]
199 getMore handle state size = do
200 -- pprTrace "getMore" (text (show (buffer state))) (return ())
201 let new_size = size * 2
202 -- double the buffer size each time we read a new block. This
203 -- counteracts the quadratic slowdown we otherwise get for very
204 -- large module names (#5981)
205 nextbuf <- hGetStringBufferBlock handle new_size
206 if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
207 newbuf <- appendStringBuffers (buffer state) nextbuf
208 unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
209
210
211 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
212 getToks dflags filename buf = lexAll (pragState dflags buf loc)
213 where
214 loc = mkRealSrcLoc (mkFastString filename) 1 1
215
216 lexAll state = case unP (lexer False return) state of
217 POk _ t@(dL->L _ ITeof) -> [t]
218 POk state' t -> t : lexAll state'
219 _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
220
221
222 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
223 --
224 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
225 getOptions :: DynFlags
226 -> StringBuffer -- ^ Input Buffer
227 -> FilePath -- ^ Source filename. Used for location info.
228 -> [Located String] -- ^ Parsed options.
229 getOptions dflags buf filename
230 = getOptions' dflags (getToks dflags filename buf)
231
232 -- The token parser is written manually because Happy can't
233 -- return a partial result when it encounters a lexer error.
234 -- We want to extract options before the buffer is passed through
235 -- CPP, so we can't use the same trick as 'getImports'.
236 getOptions' :: DynFlags
237 -> [Located Token] -- Input buffer
238 -> [Located String] -- Options.
239 getOptions' dflags toks
240 = parseToks toks
241 where
242 parseToks (open:close:xs)
243 | IToptions_prag str <- unLoc open
244 , ITclose_prag <- unLoc close
245 = case toArgs str of
246 Left _err -> optionsParseError str dflags $ -- #15053
247 combineSrcSpans (getLoc open) (getLoc close)
248 Right args -> map (cL (getLoc open)) args ++ parseToks xs
249 parseToks (open:close:xs)
250 | ITinclude_prag str <- unLoc open
251 , ITclose_prag <- unLoc close
252 = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
253 parseToks xs
254 parseToks (open:close:xs)
255 | ITdocOptions str <- unLoc open
256 , ITclose_prag <- unLoc close
257 = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
258 ++ parseToks xs
259 parseToks (open:xs)
260 | ITlanguage_prag <- unLoc open
261 = parseLanguage xs
262 parseToks (comment:xs) -- Skip over comments
263 | isComment (unLoc comment)
264 = parseToks xs
265 parseToks _ = []
266 parseLanguage ((dL->L loc (ITconid fs)):rest)
267 = checkExtension dflags (cL loc fs) :
268 case rest of
269 (dL->L _loc ITcomma):more -> parseLanguage more
270 (dL->L _loc ITclose_prag):more -> parseToks more
271 (dL->L loc _):_ -> languagePragParseError dflags loc
272 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
273 parseLanguage (tok:_)
274 = languagePragParseError dflags (getLoc tok)
275 parseLanguage []
276 = panic "getOptions'.parseLanguage(2) went past eof token"
277
278 isComment :: Token -> Bool
279 isComment c =
280 case c of
281 (ITlineComment {}) -> True
282 (ITblockComment {}) -> True
283 (ITdocCommentNext {}) -> True
284 (ITdocCommentPrev {}) -> True
285 (ITdocCommentNamed {}) -> True
286 (ITdocSection {}) -> True
287 _ -> False
288
289 -----------------------------------------------------------------------------
290
291 -- | Complain about non-dynamic flags in OPTIONS pragmas.
292 --
293 -- Throws a 'SourceError' if the input list is non-empty claiming that the
294 -- input flags are unknown.
295 checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
296 checkProcessArgsResult dflags flags
297 = when (notNull flags) $
298 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
299 where mkMsg (dL->L loc flag)
300 = mkPlainErrMsg dflags loc $
301 (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
302 text flag)
303
304 -----------------------------------------------------------------------------
305
306 checkExtension :: DynFlags -> Located FastString -> Located String
307 checkExtension dflags (dL->L l ext)
308 -- Checks if a given extension is valid, and if so returns
309 -- its corresponding flag. Otherwise it throws an exception.
310 = if ext' `elem` supported
311 then cL l ("-X"++ext')
312 else unsupportedExtnError dflags l ext'
313 where
314 ext' = unpackFS ext
315 supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags
316
317 languagePragParseError :: DynFlags -> SrcSpan -> a
318 languagePragParseError dflags loc =
319 throwErr dflags loc $
320 vcat [ text "Cannot parse LANGUAGE pragma"
321 , text "Expecting comma-separated list of language options,"
322 , text "each starting with a capital letter"
323 , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
324
325 unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
326 unsupportedExtnError dflags loc unsup =
327 throwErr dflags loc $
328 text "Unsupported extension: " <> text unsup $$
329 if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
330 where
331 supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags
332 suggestions = fuzzyMatch unsup supported
333
334
335 optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
336 optionsErrorMsgs dflags unhandled_flags flags_lines _filename
337 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
338 where unhandled_flags_lines :: [Located String]
339 unhandled_flags_lines = [ cL l f
340 | f <- unhandled_flags
341 , (dL->L l f') <- flags_lines
342 , f == f' ]
343 mkMsg (dL->L flagSpan flag) =
344 ErrUtils.mkPlainErrMsg dflags flagSpan $
345 text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
346
347 optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053
348 optionsParseError str dflags loc =
349 throwErr dflags loc $
350 vcat [ text "Error while parsing OPTIONS_GHC pragma."
351 , text "Expecting whitespace-separated list of GHC options."
352 , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
353 , text ("Input was: " ++ show str) ]
354
355 throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053
356 throwErr dflags loc doc =
357 throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc