1 -----------------------------------------------------------------------------
3 -- | Parsing the top of a Haskell source file to get its module name,
4 -- imports and options.
6 -- (c) Simon Marlow 2005
9 -----------------------------------------------------------------------------
11 module HeaderInfo ( getImports
12 , mkPrelImports -- used by the renamer too
13 , getOptionsFromFile, getOptions
15 checkProcessArgsResult ) where
17 #include "HsVersions.h"
21 import Parser ( parseHeader )
35 import Bag ( emptyBag, listToBag, unitBag )
37 import MonadUtils ( MonadIO )
41 import System.IO.Unsafe
44 ------------------------------------------------------------------------------
46 -- | Parse the imports of a source file.
48 -- Throws a 'SourceError' if parsing fails.
49 getImports :: GhcMonad m =>
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.
68 if errorsFound dflags ms
69 then liftIO $ throwIO $ mkSrcErr errs
72 L _ (HsModule mb_mod _ imps _ _ _) ->
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
78 -- GHC.Prim doesn't exist physically, so don't go looking for it.
79 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
82 implicit_prelude = dopt Opt_ImplicitPrelude dflags
83 implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
85 return (src_idecls, implicit_imports ++ ordinary_imps, mod)
87 mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName]
88 -> [LImportDecl RdrName]
89 -- Consruct the implicit declaration "import Prelude" (or not)
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
99 | otherwise = [preludeImportDecl]
101 explicit_prelude_import
102 = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls,
103 unLoc mod == pRELUDE_NAME ]
105 preludeImportDecl :: LImportDecl RdrName
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 -}
115 loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
117 parseError :: GhcMonad m => SrcSpan -> Message -> m a
118 parseError span err = throwOneError $ mkPlainErrMsg span err
120 --------------------------------------------------------------
122 --------------------------------------------------------------
124 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
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
132 (openBinaryFile filename ReadMode)
135 opts <- fmap getOptions' $ lazyGetToks dflags filename handle
136 seqList opts $ return opts)
139 -- blockSize = 17 -- for testing :-)
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
147 loc = mkSrcLoc (mkFastString filename) 1 1
149 lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
150 lazyLexBuf handle state eof = do
151 case unP (lexer return) state of
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
160 L _ ITeof -> return [t]
161 _other -> do rest <- lazyLexBuf handle state' eof
163 _ | not eof -> getMore handle state
164 | otherwise -> return [L (last_loc state) ITeof]
165 -- parser assumes an ITeof sentinel at the end
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
176 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
177 getToks dflags filename buf = lexAll (pragState dflags buf loc)
179 loc = mkSrcLoc (mkFastString filename) 1 1
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]
187 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
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)
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.
206 getToken (L _loc tok) = tok
207 getLoc (L loc _tok) = loc
209 parseToks (open:close:xs)
210 | IToptions_prag str <- getToken open
211 , ITclose_prag <- getToken close
212 = map (L (getLoc open)) (words str) ++
214 parseToks (open:close:xs)
215 | ITinclude_prag str <- getToken open
216 , ITclose_prag <- getToken close
217 = map (L (getLoc open)) ["-#include",removeSpaces str] ++
219 parseToks (open:close:xs)
220 | ITdocOptions str <- getToken open
221 , ITclose_prag <- getToken close
222 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
225 | ITdocOptionsOld str <- getToken open
226 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
229 | ITlanguage_prag <- getToken open
232 | ITdocCommentNext _ <- getToken x
235 parseLanguage (L loc (ITconid fs):rest)
236 = checkExtension (L loc fs) :
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)
245 = panic "getOptions'.parseLanguage(2) went past eof token"
247 -----------------------------------------------------------------------------
249 -- | Complain about non-dynamic flags in OPTIONS pragmas.
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:" <+>
262 -----------------------------------------------------------------------------
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'
273 languagePragParseError :: SrcSpan -> a
274 languagePragParseError loc =
275 throw $ mkSrcErr $ unitBag $
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 #-}") ])
282 unsupportedExtnError :: SrcSpan -> String -> a
283 unsupportedExtnError loc unsup =
284 throw $ mkSrcErr $ unitBag $
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 supportedLanguagesAndExtensions
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