Remove warning supression klugde in main/HeaderInfo
[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 , getOptionsFromFile, getOptions
13 , optionsErrorMsgs,
14 checkProcessArgsResult ) where
15
16 #include "HsVersions.h"
17
18 import HscTypes
19 import Parser ( parseHeader )
20 import Lexer
21 import FastString
22 import HsSyn ( ImportDecl(..), HsModule(..) )
23 import Module ( ModuleName, moduleName )
24 import PrelNames ( gHC_PRIM, mAIN_NAME )
25 import StringBuffer ( StringBuffer(..), hGetStringBufferBlock
26 , appendStringBuffers )
27 import SrcLoc
28 import DynFlags
29 import ErrUtils
30 import Util
31 import Outputable
32 import Pretty ()
33 import Maybes
34 import Bag ( emptyBag, listToBag, unitBag )
35
36 import MonadUtils ( MonadIO )
37 import Exception
38 import Control.Monad
39 import System.IO
40 import Data.List
41
42 ------------------------------------------------------------------------------
43
44 -- | Parse the imports of a source file.
45 --
46 -- Throws a 'SourceError' if parsing fails.
47 getImports :: GhcMonad m =>
48 DynFlags
49 -> StringBuffer -- ^ Parse this.
50 -> FilePath -- ^ Filename the buffer came from. Used for
51 -- reporting parse error locations.
52 -> FilePath -- ^ The original source filename (used for locations
53 -- in the function result)
54 -> m ([Located ModuleName], [Located ModuleName], Located ModuleName)
55 -- ^ The source imports, normal imports, and the module name.
56 getImports dflags buf filename source_filename = do
57 let loc = mkSrcLoc (mkFastString filename) 1 0
58 case unP parseHeader (mkPState buf loc dflags) of
59 PFailed span err -> parseError span err
60 POk pst rdr_module -> do
61 let ms@(warns, errs) = getMessages pst
62 logWarnings warns
63 if errorsFound dflags ms
64 then liftIO $ throwIO $ mkSrcErr errs
65 else
66 case rdr_module of
67 L _ (HsModule mb_mod _ imps _ _ _ _) ->
68 let
69 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
70 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
71 imps' = filter isHomeImp (map unLoc imps)
72 (src_idecls, ord_idecls) = partition isSourceIdecl imps'
73 source_imps = map getImpMod src_idecls
74 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
75 (map getImpMod ord_idecls)
76 -- GHC.Prim doesn't exist physically, so don't go looking for it.
77 in
78 return (source_imps, ordinary_imps, mod)
79
80 parseError :: GhcMonad m => SrcSpan -> Message -> m a
81 parseError span err = throwOneError $ mkPlainErrMsg span err
82
83 -- we aren't interested in package imports here, filter them out
84 isHomeImp :: ImportDecl name -> Bool
85 isHomeImp (ImportDecl _ (Just p) _ _ _ _) = p == fsLit "this"
86 isHomeImp (ImportDecl _ Nothing _ _ _ _) = True
87
88 isSourceIdecl :: ImportDecl name -> Bool
89 isSourceIdecl (ImportDecl _ _ s _ _ _) = s
90
91 getImpMod :: ImportDecl name -> Located ModuleName
92 getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod
93
94 --------------------------------------------------------------
95 -- Get options
96 --------------------------------------------------------------
97
98
99 getOptionsFromFile :: DynFlags
100 -> FilePath -- input file
101 -> IO [Located String] -- options, if any
102 getOptionsFromFile dflags filename
103 = Exception.bracket
104 (openBinaryFile filename ReadMode)
105 (hClose)
106 (\handle ->
107 do buf <- hGetStringBufferBlock handle blockSize
108 loop handle buf)
109 where blockSize = 1024
110 loop handle buf
111 | len buf == 0 = return []
112 | otherwise
113 = case getOptions' dflags buf filename of
114 (Nothing, opts) -> return opts
115 (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
116 newBuf <- appendStringBuffers buf' nextBlock
117 if len newBuf == len buf
118 then return opts
119 else do opts' <- loop handle newBuf
120 return (opts++opts')
121
122 getOptions :: DynFlags -> StringBuffer -> FilePath -> [Located String]
123 getOptions dflags buf filename
124 = case getOptions' dflags buf filename of
125 (_,opts) -> opts
126
127 -- The token parser is written manually because Happy can't
128 -- return a partial result when it encounters a lexer error.
129 -- We want to extract options before the buffer is passed through
130 -- CPP, so we can't use the same trick as 'getImports'.
131 getOptions' :: DynFlags
132 -> StringBuffer -- Input buffer
133 -> FilePath -- Source file. Used for msgs only.
134 -> ( Maybe StringBuffer -- Just => we can use more input
135 , [Located String] -- Options.
136 )
137 getOptions' dflags buf filename
138 = parseToks (lexAll (pragState dflags buf loc))
139 where loc = mkSrcLoc (mkFastString filename) 1 0
140
141 getToken (_buf,L _loc tok) = tok
142 getLoc (_buf,L loc _tok) = loc
143 getBuf (buf,_tok) = buf
144 combine opts (flag, opts') = (flag, opts++opts')
145 add opt (flag, opts) = (flag, opt:opts)
146
147 parseToks (open:close:xs)
148 | IToptions_prag str <- getToken open
149 , ITclose_prag <- getToken close
150 = map (L (getLoc open)) (words str) `combine`
151 parseToks xs
152 parseToks (open:close:xs)
153 | ITinclude_prag str <- getToken open
154 , ITclose_prag <- getToken close
155 = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
156 parseToks xs
157 parseToks (open:close:xs)
158 | ITdocOptions str <- getToken open
159 , ITclose_prag <- getToken close
160 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
161 `combine` parseToks xs
162 parseToks (open:xs)
163 | ITdocOptionsOld str <- getToken open
164 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
165 `combine` parseToks xs
166 parseToks (open:xs)
167 | ITlanguage_prag <- getToken open
168 = parseLanguage xs
169 -- The last token before EOF could have been truncated.
170 -- We ignore it to be on the safe side.
171 parseToks [tok,eof]
172 | ITeof <- getToken eof
173 = (Just (getBuf tok),[])
174 parseToks (eof:_)
175 | ITeof <- getToken eof
176 = (Just (getBuf eof),[])
177 parseToks _ = (Nothing,[])
178 parseLanguage ((_buf,L loc (ITconid fs)):rest)
179 = checkExtension (L loc fs) `add`
180 case rest of
181 (_,L _loc ITcomma):more -> parseLanguage more
182 (_,L _loc ITclose_prag):more -> parseToks more
183 (_,L loc _):_ -> languagePragParseError loc
184 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
185 parseLanguage (tok:_)
186 = languagePragParseError (getLoc tok)
187 parseLanguage []
188 = panic "getOptions'.parseLanguage(2) went past eof token"
189 lexToken t = return t
190 lexAll state = case unP (lexer lexToken) state of
191 POk _ t@(L _ ITeof) -> [(buffer state,t)]
192 POk state' t -> (buffer state,t):lexAll state'
193 _ -> [(buffer state,L (last_loc state) ITeof)]
194
195 -----------------------------------------------------------------------------
196 -- Complain about non-dynamic flags in OPTIONS pragmas
197
198 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
199 checkProcessArgsResult flags
200 = when (notNull flags) $
201 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
202 where mkMsg (L loc flag)
203 = mkPlainErrMsg loc $
204 (text "unknown flag in {-# OPTIONS #-} pragma:" <+>
205 text flag)
206
207 -----------------------------------------------------------------------------
208
209 checkExtension :: Located FastString -> Located String
210 checkExtension (L l ext)
211 -- Checks if a given extension is valid, and if so returns
212 -- its corresponding flag. Otherwise it throws an exception.
213 = let ext' = unpackFS ext in
214 if ext' `elem` supportedLanguages
215 || ext' `elem` (map ("No"++) supportedLanguages)
216 then L l ("-X"++ext')
217 else unsupportedExtnError l ext'
218
219 languagePragParseError :: SrcSpan -> a
220 languagePragParseError loc =
221 throw $ mkSrcErr $ unitBag $
222 (mkPlainErrMsg loc $
223 text "cannot parse LANGUAGE pragma: comma-separated list expected")
224
225 unsupportedExtnError :: SrcSpan -> String -> a
226 unsupportedExtnError loc unsup =
227 throw $ mkSrcErr $ unitBag $
228 mkPlainErrMsg loc $
229 text "unsupported extension: " <> text unsup
230
231
232 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
233 optionsErrorMsgs unhandled_flags flags_lines _filename
234 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
235 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
236 L l f' <- flags_lines, f == f' ]
237 mkMsg (L flagSpan flag) =
238 ErrUtils.mkPlainErrMsg flagSpan $
239 text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag
240