d79c3eec02dd9a33329baa5b29a70d63257dfd31
[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 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
99 --
100 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
101 getOptionsFromFile :: DynFlags
102 -> FilePath -- ^ Input file
103 -> IO [Located String] -- ^ Parsed options, if any.
104 getOptionsFromFile dflags filename
105 = Exception.bracket
106 (openBinaryFile filename ReadMode)
107 (hClose)
108 (\handle ->
109 do buf <- hGetStringBufferBlock handle blockSize
110 loop handle buf)
111 where blockSize = 1024
112 loop handle buf
113 | len buf == 0 = return []
114 | otherwise
115 = case getOptions' dflags buf filename of
116 (Nothing, opts) -> return opts
117 (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
118 newBuf <- appendStringBuffers buf' nextBlock
119 if len newBuf == len buf
120 then return opts
121 else do opts' <- loop handle newBuf
122 return (opts++opts')
123
124 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
125 --
126 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
127 getOptions :: DynFlags
128 -> StringBuffer -- ^ Input Buffer
129 -> FilePath -- ^ Source filename. Used for location info.
130 -> [Located String] -- ^ Parsed options.
131 getOptions dflags buf filename
132 = case getOptions' dflags buf filename of
133 (_,opts) -> opts
134
135 -- The token parser is written manually because Happy can't
136 -- return a partial result when it encounters a lexer error.
137 -- We want to extract options before the buffer is passed through
138 -- CPP, so we can't use the same trick as 'getImports'.
139 getOptions' :: DynFlags
140 -> StringBuffer -- Input buffer
141 -> FilePath -- Source file. Used for msgs only.
142 -> ( Maybe StringBuffer -- Just => we can use more input
143 , [Located String] -- Options.
144 )
145 getOptions' dflags buf filename
146 = parseToks (lexAll (pragState dflags buf loc))
147 where loc = mkSrcLoc (mkFastString filename) 1 0
148
149 getToken (_buf,L _loc tok) = tok
150 getLoc (_buf,L loc _tok) = loc
151 getBuf (buf,_tok) = buf
152 combine opts (flag, opts') = (flag, opts++opts')
153 add opt (flag, opts) = (flag, opt:opts)
154
155 parseToks (open:close:xs)
156 | IToptions_prag str <- getToken open
157 , ITclose_prag <- getToken close
158 = map (L (getLoc open)) (words str) `combine`
159 parseToks xs
160 parseToks (open:close:xs)
161 | ITinclude_prag str <- getToken open
162 , ITclose_prag <- getToken close
163 = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
164 parseToks xs
165 parseToks (open:close:xs)
166 | ITdocOptions str <- getToken open
167 , ITclose_prag <- getToken close
168 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
169 `combine` parseToks xs
170 parseToks (open:xs)
171 | ITdocOptionsOld str <- getToken open
172 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
173 `combine` parseToks xs
174 parseToks (open:xs)
175 | ITlanguage_prag <- getToken open
176 = parseLanguage xs
177 -- The last token before EOF could have been truncated.
178 -- We ignore it to be on the safe side.
179 parseToks [tok,eof]
180 | ITeof <- getToken eof
181 = (Just (getBuf tok),[])
182 parseToks (eof:_)
183 | ITeof <- getToken eof
184 = (Just (getBuf eof),[])
185 parseToks _ = (Nothing,[])
186 parseLanguage ((_buf,L loc (ITconid fs)):rest)
187 = checkExtension (L loc fs) `add`
188 case rest of
189 (_,L _loc ITcomma):more -> parseLanguage more
190 (_,L _loc ITclose_prag):more -> parseToks more
191 (_,L loc _):_ -> languagePragParseError loc
192 [] -> panic "getOptions'.parseLanguage(1) went past eof token"
193 parseLanguage (tok:_)
194 = languagePragParseError (getLoc tok)
195 parseLanguage []
196 = panic "getOptions'.parseLanguage(2) went past eof token"
197 lexToken t = return t
198 lexAll state = case unP (lexer lexToken) state of
199 POk _ t@(L _ ITeof) -> [(buffer state,t)]
200 POk state' t -> (buffer state,t):lexAll state'
201 _ -> [(buffer state,L (last_loc state) ITeof)]
202
203 -----------------------------------------------------------------------------
204
205 -- | Complain about non-dynamic flags in OPTIONS pragmas.
206 --
207 -- Throws a 'SourceError' if the input list is non-empty claiming that the
208 -- input flags are unknown.
209 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
210 checkProcessArgsResult flags
211 = when (notNull flags) $
212 liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
213 where mkMsg (L loc flag)
214 = mkPlainErrMsg loc $
215 (text "unknown flag in {-# OPTIONS #-} pragma:" <+>
216 text flag)
217
218 -----------------------------------------------------------------------------
219
220 checkExtension :: Located FastString -> Located String
221 checkExtension (L l ext)
222 -- Checks if a given extension is valid, and if so returns
223 -- its corresponding flag. Otherwise it throws an exception.
224 = let ext' = unpackFS ext in
225 if ext' `elem` supportedLanguages
226 || ext' `elem` (map ("No"++) supportedLanguages)
227 then L l ("-X"++ext')
228 else unsupportedExtnError l ext'
229
230 languagePragParseError :: SrcSpan -> a
231 languagePragParseError loc =
232 throw $ mkSrcErr $ unitBag $
233 (mkPlainErrMsg loc $
234 text "cannot parse LANGUAGE pragma: comma-separated list expected")
235
236 unsupportedExtnError :: SrcSpan -> String -> a
237 unsupportedExtnError loc unsup =
238 throw $ mkSrcErr $ unitBag $
239 mkPlainErrMsg loc $
240 text "unsupported extension: " <> text unsup
241
242
243 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
244 optionsErrorMsgs unhandled_flags flags_lines _filename
245 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
246 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
247 L l f' <- flags_lines, f == f' ]
248 mkMsg (L flagSpan flag) =
249 ErrUtils.mkPlainErrMsg flagSpan $
250 text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag
251