1 {-# OPTIONS -fno-warn-incomplete-patterns #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
8 -----------------------------------------------------------------------------
10 -- Parsing the top of a Haskell source file to get its module name,
11 -- imports and options.
13 -- (c) Simon Marlow 2005
16 -----------------------------------------------------------------------------
18 module HeaderInfo ( getImports
19 , getOptionsFromFile, getOptions
21 checkProcessArgsResult ) where
23 #include "HsVersions.h"
25 import Parser ( parseHeader )
28 import HsSyn ( ImportDecl(..), HsModule(..) )
29 import Module ( ModuleName, moduleName )
30 import PrelNames ( gHC_PRIM, mAIN_NAME )
31 import StringBuffer ( StringBuffer(..), hGetStringBufferBlock
32 , appendStringBuffers )
41 import Bag ( emptyBag, listToBag )
43 import Control.Exception
49 getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath
50 -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
51 getImports dflags buf filename source_filename = do
52 let loc = mkSrcLoc (mkFastString filename) 1 0
53 case unP parseHeader (mkPState buf loc dflags) of
54 PFailed span err -> parseError span err
55 POk pst rdr_module -> do
56 let ms = getMessages pst
57 printErrorsAndWarnings dflags ms
58 when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
60 L _ (HsModule mb_mod _ imps _ _ _ _) ->
62 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
63 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
64 (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
65 source_imps = map getImpMod src_idecls
66 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
67 (map getImpMod ord_idecls)
68 -- GHC.Prim doesn't exist physically, so don't go looking for it.
70 return (source_imps, ordinary_imps, mod)
72 parseError :: SrcSpan -> Message -> a
73 parseError span err = throwDyn $ mkPlainErrMsg span err
75 isSourceIdecl :: ImportDecl name -> Bool
76 isSourceIdecl (ImportDecl _ s _ _ _) = s
78 getImpMod :: ImportDecl name -> Located ModuleName
79 getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
81 --------------------------------------------------------------
83 --------------------------------------------------------------
86 getOptionsFromFile :: DynFlags
87 -> FilePath -- input file
88 -> IO [Located String] -- options, if any
89 getOptionsFromFile dflags filename
90 = Control.Exception.bracket
91 (openBinaryFile filename ReadMode)
94 do buf <- hGetStringBufferBlock handle blockSize
96 where blockSize = 1024
98 | len buf == 0 = return []
100 = case getOptions' dflags buf filename of
101 (Nothing, opts) -> return opts
102 (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
103 newBuf <- appendStringBuffers buf' nextBlock
104 if len newBuf == len buf
106 else do opts' <- loop handle newBuf
109 getOptions :: DynFlags -> StringBuffer -> FilePath -> [Located String]
110 getOptions dflags buf filename
111 = case getOptions' dflags buf filename of
114 -- The token parser is written manually because Happy can't
115 -- return a partial result when it encounters a lexer error.
116 -- We want to extract options before the buffer is passed through
117 -- CPP, so we can't use the same trick as 'getImports'.
118 getOptions' :: DynFlags
119 -> StringBuffer -- Input buffer
120 -> FilePath -- Source file. Used for msgs only.
121 -> ( Maybe StringBuffer -- Just => we can use more input
122 , [Located String] -- Options.
124 getOptions' dflags buf filename
125 = parseToks (lexAll (pragState dflags buf loc))
126 where loc = mkSrcLoc (mkFastString filename) 1 0
128 getToken (_buf,L _loc tok) = tok
129 getLoc (_buf,L loc _tok) = loc
130 getBuf (buf,_tok) = buf
131 combine opts (flag, opts') = (flag, opts++opts')
132 add opt (flag, opts) = (flag, opt:opts)
134 parseToks (open:close:xs)
135 | IToptions_prag str <- getToken open
136 , ITclose_prag <- getToken close
137 = map (L (getLoc open)) (words str) `combine`
139 parseToks (open:close:xs)
140 | ITinclude_prag str <- getToken open
141 , ITclose_prag <- getToken close
142 = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
144 parseToks (open:close:xs)
145 | ITdocOptions str <- getToken open
146 , ITclose_prag <- getToken close
147 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
148 `combine` parseToks xs
150 | ITdocOptionsOld str <- getToken open
151 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
152 `combine` parseToks xs
154 | ITlanguage_prag <- getToken open
156 -- The last token before EOF could have been truncated.
157 -- We ignore it to be on the safe side.
159 | ITeof <- getToken eof
160 = (Just (getBuf tok),[])
162 | ITeof <- getToken eof
163 = (Just (getBuf eof),[])
164 parseToks _ = (Nothing,[])
165 parseLanguage ((_buf,L loc (ITconid fs)):rest)
166 = checkExtension (L loc fs) `add`
168 (_,L _loc ITcomma):more -> parseLanguage more
169 (_,L _loc ITclose_prag):more -> parseToks more
170 (_,L loc _):_ -> languagePragParseError loc
171 parseLanguage (tok:_)
172 = languagePragParseError (getLoc tok)
173 lexToken t = return t
174 lexAll state = case unP (lexer lexToken) state of
175 POk _ t@(L _ ITeof) -> [(buffer state,t)]
176 POk state' t -> (buffer state,t):lexAll state'
177 _ -> [(buffer state,L (last_loc state) ITeof)]
179 -----------------------------------------------------------------------------
180 -- Complain about non-dynamic flags in OPTIONS pragmas
182 checkProcessArgsResult :: [String] -> FilePath -> IO ()
183 checkProcessArgsResult flags filename
184 = do when (notNull flags) (throwDyn (ProgramError (
185 showSDoc (hang (text filename <> char ':')
186 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+>
187 hsep (map text flags)))
190 -----------------------------------------------------------------------------
192 checkExtension :: Located FastString -> Located String
193 checkExtension (L l ext)
194 -- Checks if a given extension is valid, and if so returns
195 -- its corresponding flag. Otherwise it throws an exception.
196 = let ext' = unpackFS ext in
197 if ext' `elem` supportedLanguages
198 || ext' `elem` (map ("No"++) supportedLanguages)
199 then L l ("-X"++ext')
200 else unsupportedExtnError l ext'
202 languagePragParseError :: SrcSpan -> a
203 languagePragParseError loc =
205 (showSDoc (mkLocMessage loc (
206 text "cannot parse LANGUAGE pragma: comma-separated list expected")))
208 unsupportedExtnError :: SrcSpan -> String -> a
209 unsupportedExtnError loc unsup =
210 pgmError (showSDoc (mkLocMessage loc (
211 text "unsupported extension: " <>
215 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
216 optionsErrorMsgs unhandled_flags flags_lines _filename
217 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
218 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
219 L l f' <- flags_lines, f == f' ]
220 mkMsg (L flagSpan flag) =
221 ErrUtils.mkPlainErrMsg flagSpan $
222 text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag