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 {-# OPTIONS -fno-warn-tabs #-}
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and
14 -- detab the module (please do the detabbing in a separate patch). See
15 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
18 module HeaderInfo
( getImports
19 , mkPrelImports
-- used by the renamer too
20 , getOptionsFromFile
, getOptions
22 checkProcessArgsResult
) where
24 #include
"HsVersions.h"
28 import Parser
( parseHeader
)
42 import Bag
( emptyBag
, listToBag
, unitBag
)
48 import System
.IO.Unsafe
51 ------------------------------------------------------------------------------
53 -- | Parse the imports of a source file.
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 ([Located
(ImportDecl RdrName
)], [Located
(ImportDecl RdrName
)], Located ModuleName
)
63 -- ^ The source imports, normal imports, and the module name.
64 getImports dflags buf filename source_filename
= do
65 let loc
= mkRealSrcLoc
(mkFastString filename
) 1 1
66 case unP parseHeader
(mkPState dflags buf loc
) of
67 PFailed span err
-> parseError span err
68 POk pst rdr_module
-> do
69 let _ms
@(_warns
, errs
) = getMessages pst
70 -- don't log warnings: they'll be reported when we parse the file
71 -- for real. See #2500.
74 if errorsFound dflags ms
75 then throwIO
$ mkSrcErr errs
78 L _
(HsModule mb_mod _ imps _ _ _
) ->
80 main_loc
= srcLocSpan
(mkSrcLoc
(mkFastString source_filename
) 1 1)
81 mod = mb_mod `orElse` L main_loc mAIN_NAME
82 (src_idecls
, ord_idecls
) = partition (ideclSource
.unLoc
) imps
84 -- GHC.Prim doesn't exist physically, so don't go looking for it.
85 ordinary_imps
= filter ((/= moduleName gHC_PRIM
) . unLoc
. ideclName
. unLoc
)
88 implicit_prelude
= xopt Opt_ImplicitPrelude dflags
89 implicit_imports
= mkPrelImports
(unLoc
mod) main_loc implicit_prelude imps
91 return (src_idecls
, implicit_imports
++ ordinary_imps
, mod)
93 mkPrelImports
:: ModuleName
94 -> SrcSpan
-- Attribute the "import Prelude" to this location
95 -> Bool -> [LImportDecl RdrName
]
96 -> [LImportDecl RdrName
]
97 -- Consruct the implicit declaration "import Prelude" (or not)
99 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
100 -- because the former doesn't even look at Prelude.hi for instance
101 -- declarations, whereas the latter does.
102 mkPrelImports this_mod loc implicit_prelude import_decls
103 | this_mod
== pRELUDE_NAME
104 || explicit_prelude_import
105 ||
not implicit_prelude
107 |
otherwise = [preludeImportDecl
]
109 explicit_prelude_import
110 = notNull
[ () | L _
(ImportDecl
{ ideclName
= mod
111 , ideclPkgQual
= Nothing
})
113 , unLoc
mod == pRELUDE_NAME
]
115 preludeImportDecl
:: LImportDecl RdrName
117 = L loc
$ ImportDecl
{ ideclName
= L loc pRELUDE_NAME
,
118 ideclPkgQual
= Nothing
,
120 ideclSafe
= False, -- Not a safe import
121 ideclQualified
= False,
122 ideclImplicit
= True, -- Implicit!
124 ideclHiding
= Nothing
}
126 parseError
:: SrcSpan
-> Message
-> IO a
127 parseError span err
= throwOneError
$ mkPlainErrMsg span err
129 --------------------------------------------------------------
131 --------------------------------------------------------------
133 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
135 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
136 getOptionsFromFile
:: DynFlags
137 -> FilePath -- ^ Input file
138 -> IO [Located
String] -- ^ Parsed options, if any.
139 getOptionsFromFile dflags filename
141 (openBinaryFile filename ReadMode
)
144 opts
<- fmap getOptions
' $ lazyGetToks dflags filename handle
145 seqList opts
$ return opts
)
148 -- blockSize = 17 -- for testing :-)
151 lazyGetToks
:: DynFlags
-> FilePath -> Handle -> IO [Located Token
]
152 lazyGetToks dflags filename handle
= do
153 buf
<- hGetStringBufferBlock handle blockSize
154 unsafeInterleaveIO
$ lazyLexBuf handle
(pragState dflags buf loc
) False
156 loc
= mkRealSrcLoc
(mkFastString filename
) 1 1
158 lazyLexBuf
:: Handle -> PState
-> Bool -> IO [Located Token
]
159 lazyLexBuf handle state eof
= do
160 case unP
(lexer
return) state
of
162 -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
163 if atEnd
(buffer state
') && not eof
164 -- if this token reached the end of the buffer, and we haven't
165 -- necessarily read up to the end of the file, then the token might
166 -- be truncated, so read some more of the file and lex it again.
167 then getMore handle state
169 L _ ITeof
-> return [t
]
170 _other
-> do rest
<- lazyLexBuf handle state
' eof
172 _ |
not eof
-> getMore handle state
173 |
otherwise -> return [L
(RealSrcSpan
(last_loc state
)) ITeof
]
174 -- parser assumes an ITeof sentinel at the end
176 getMore
:: Handle -> PState
-> IO [Located Token
]
177 getMore handle state
= do
178 -- pprTrace "getMore" (text (show (buffer state))) (return ())
179 nextbuf
<- hGetStringBufferBlock handle blockSize
180 if (len nextbuf
== 0) then lazyLexBuf handle state
True else do
181 newbuf
<- appendStringBuffers
(buffer state
) nextbuf
182 unsafeInterleaveIO
$ lazyLexBuf handle state
{buffer
=newbuf
} False
185 getToks
:: DynFlags
-> FilePath -> StringBuffer
-> [Located Token
]
186 getToks dflags filename buf
= lexAll
(pragState dflags buf loc
)
188 loc
= mkRealSrcLoc
(mkFastString filename
) 1 1
190 lexAll state
= case unP
(lexer
return) state
of
191 POk _ t
@(L _ ITeof
) -> [t
]
192 POk state
' t
-> t
: lexAll state
'
193 _
-> [L
(RealSrcSpan
(last_loc state
)) ITeof
]
196 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
198 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
199 getOptions
:: DynFlags
200 -> StringBuffer
-- ^ Input Buffer
201 -> FilePath -- ^ Source filename. Used for location info.
202 -> [Located
String] -- ^ Parsed options.
203 getOptions dflags buf filename
204 = getOptions
' (getToks dflags filename buf
)
206 -- The token parser is written manually because Happy can't
207 -- return a partial result when it encounters a lexer error.
208 -- We want to extract options before the buffer is passed through
209 -- CPP, so we can't use the same trick as 'getImports'.
210 getOptions
' :: [Located Token
] -- Input buffer
211 -> [Located
String] -- Options.
215 getToken
(L _loc tok
) = tok
216 getLoc
(L loc _tok
) = loc
218 parseToks
(open
:close
:xs
)
219 | IToptions_prag str
<- getToken open
220 , ITclose_prag
<- getToken close
221 = map (L
(getLoc open
)) (words str
) ++
223 parseToks
(open
:close
:xs
)
224 | ITinclude_prag str
<- getToken open
225 , ITclose_prag
<- getToken close
226 = map (L
(getLoc open
)) ["-#include",removeSpaces str
] ++
228 parseToks
(open
:close
:xs
)
229 | ITdocOptions str
<- getToken open
230 , ITclose_prag
<- getToken close
231 = map (L
(getLoc open
)) ["-haddock-opts", removeSpaces str
]
234 | ITdocOptionsOld str
<- getToken open
235 = map (L
(getLoc open
)) ["-haddock-opts", removeSpaces str
]
238 | ITlanguage_prag
<- getToken open
241 | ITdocCommentNext _
<- getToken x
244 parseLanguage
(L loc
(ITconid fs
):rest
)
245 = checkExtension
(L loc fs
) :
247 (L _loc ITcomma
):more
-> parseLanguage more
248 (L _loc ITclose_prag
):more
-> parseToks more
249 (L loc _
):_
-> languagePragParseError loc
250 [] -> panic
"getOptions'.parseLanguage(1) went past eof token"
251 parseLanguage
(tok
:_
)
252 = languagePragParseError
(getLoc tok
)
254 = panic
"getOptions'.parseLanguage(2) went past eof token"
256 -----------------------------------------------------------------------------
258 -- | Complain about non-dynamic flags in OPTIONS pragmas.
260 -- Throws a 'SourceError' if the input list is non-empty claiming that the
261 -- input flags are unknown.
262 checkProcessArgsResult
:: MonadIO m
=> [Located
String] -> m
()
263 checkProcessArgsResult flags
264 = when (notNull flags
) $
265 liftIO
$ throwIO
$ mkSrcErr
$ listToBag
$ map mkMsg flags
266 where mkMsg
(L loc flag
)
267 = mkPlainErrMsg loc
$
268 (text
"unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
271 -----------------------------------------------------------------------------
273 checkExtension
:: Located FastString
-> Located
String
274 checkExtension
(L l ext
)
275 -- Checks if a given extension is valid, and if so returns
276 -- its corresponding flag. Otherwise it throws an exception.
277 = let ext
' = unpackFS ext
in
278 if ext
' `
elem` supportedLanguagesAndExtensions
279 then L l
("-X"++ext
')
280 else unsupportedExtnError l ext
'
282 languagePragParseError
:: SrcSpan
-> a
283 languagePragParseError loc
=
284 throw
$ mkSrcErr
$ unitBag
$
286 vcat
[ text
"Cannot parse LANGUAGE pragma"
287 , text
"Expecting comma-separated list of language options,"
288 , text
"each starting with a capital letter"
289 , nest
2 (text
"E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
291 unsupportedExtnError
:: SrcSpan
-> String -> a
292 unsupportedExtnError loc unsup
=
293 throw
$ mkSrcErr
$ unitBag
$
295 text
"Unsupported extension: " <> text unsup
$$
296 if null suggestions
then empty else text
"Perhaps you meant" <+> quotedListWithOr
(map text suggestions
)
298 suggestions
= fuzzyMatch unsup supportedLanguagesAndExtensions
301 optionsErrorMsgs
:: [String] -> [Located
String] -> FilePath -> Messages
302 optionsErrorMsgs unhandled_flags flags_lines _filename
303 = (emptyBag
, listToBag
(map mkMsg unhandled_flags_lines
))
304 where unhandled_flags_lines
= [ L l f | f
<- unhandled_flags
,
305 L l f
' <- flags_lines
, f
== f
' ]
306 mkMsg
(L flagSpan flag
) =
307 ErrUtils
.mkPlainErrMsg flagSpan
$
308 text
"unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag