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