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 , getOptionsFromFile, getOptions
14 checkProcessArgsResult ) where
16 #include "HsVersions.h"
19 import Parser ( parseHeader )
22 import HsSyn ( ImportDecl(..), HsModule(..) )
23 import Module ( ModuleName, moduleName )
24 import PrelNames ( gHC_PRIM, mAIN_NAME )
25 import StringBuffer ( StringBuffer(..), hGetStringBufferBlock
26 , appendStringBuffers )
34 import Bag ( emptyBag, listToBag, unitBag )
36 import MonadUtils ( MonadIO )
42 ------------------------------------------------------------------------------
44 -- | Parse the imports of a source file.
46 -- Throws a 'SourceError' if parsing fails.
47 getImports :: GhcMonad m =>
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
63 if errorsFound dflags ms
64 then liftIO $ throwIO $ mkSrcErr errs
67 L _ (HsModule mb_mod _ imps _ _ _ _) ->
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.
78 return (source_imps, ordinary_imps, mod)
80 parseError :: GhcMonad m => SrcSpan -> Message -> m a
81 parseError span err = throwOneError $ mkPlainErrMsg span err
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
88 isSourceIdecl :: ImportDecl name -> Bool
89 isSourceIdecl (ImportDecl _ _ s _ _ _) = s
91 getImpMod :: ImportDecl name -> Located ModuleName
92 getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod
94 --------------------------------------------------------------
96 --------------------------------------------------------------
98 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
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
106 (openBinaryFile filename ReadMode)
109 do buf <- hGetStringBufferBlock handle blockSize
111 where blockSize = 1024
113 | len buf == 0 = return []
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
121 else do opts' <- loop handle newBuf
124 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
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
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.
145 getOptions' dflags buf filename
146 = parseToks (lexAll (pragState dflags buf loc))
147 where loc = mkSrcLoc (mkFastString filename) 1 0
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)
155 parseToks (open:close:xs)
156 | IToptions_prag str <- getToken open
157 , ITclose_prag <- getToken close
158 = map (L (getLoc open)) (words str) `combine`
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`
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
171 | ITdocOptionsOld str <- getToken open
172 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
173 `combine` parseToks xs
175 | ITlanguage_prag <- getToken open
177 -- The last token before EOF could have been truncated.
178 -- We ignore it to be on the safe side.
180 | ITeof <- getToken eof
181 = (Just (getBuf tok),[])
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`
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)
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)]
203 -----------------------------------------------------------------------------
205 -- | Complain about non-dynamic flags in OPTIONS pragmas.
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:" <+>
218 -----------------------------------------------------------------------------
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'
230 languagePragParseError :: SrcSpan -> a
231 languagePragParseError loc =
232 throw $ mkSrcErr $ unitBag $
234 text "cannot parse LANGUAGE pragma: comma-separated list expected")
236 unsupportedExtnError :: SrcSpan -> String -> a
237 unsupportedExtnError loc unsup =
238 throw $ mkSrcErr $ unitBag $
240 text "unsupported extension: " <> text unsup
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