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