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