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 #if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 601
50 -- already imported above
51 --import System.IO ( openBinaryFile )
53 import IOExts ( openFileEx, IOModeEx(..) )
56 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
57 openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
60 getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath
61 -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
62 getImports dflags buf filename source_filename = do
63 let loc = mkSrcLoc (mkFastString filename) 1 0
64 case unP parseHeader (mkPState buf loc dflags) of
65 PFailed span err -> parseError span err
66 POk pst rdr_module -> do
67 let ms = getMessages pst
68 printErrorsAndWarnings dflags ms
69 when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
71 L _ (HsModule mb_mod _ imps _ _ _ _) ->
73 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
74 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
75 (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
76 source_imps = map getImpMod src_idecls
77 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
78 (map getImpMod ord_idecls)
79 -- GHC.Prim doesn't exist physically, so don't go looking for it.
81 return (source_imps, ordinary_imps, mod)
83 parseError :: SrcSpan -> Message -> a
84 parseError span err = throwDyn $ mkPlainErrMsg span err
86 isSourceIdecl :: ImportDecl name -> Bool
87 isSourceIdecl (ImportDecl _ s _ _ _) = s
89 getImpMod :: ImportDecl name -> Located ModuleName
90 getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
92 --------------------------------------------------------------
94 --------------------------------------------------------------
97 getOptionsFromFile :: DynFlags
98 -> FilePath -- input file
99 -> IO [Located String] -- options, if any
100 getOptionsFromFile dflags filename
101 = Control.Exception.bracket
102 (openBinaryFile filename ReadMode)
105 do buf <- hGetStringBufferBlock handle blockSize
107 where blockSize = 1024
109 | len buf == 0 = return []
111 = case getOptions' dflags buf filename of
112 (Nothing, opts) -> return opts
113 (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
114 newBuf <- appendStringBuffers buf' nextBlock
115 if len newBuf == len buf
117 else do opts' <- loop handle newBuf
120 getOptions :: DynFlags -> StringBuffer -> FilePath -> [Located String]
121 getOptions dflags buf filename
122 = case getOptions' dflags buf filename of
125 -- The token parser is written manually because Happy can't
126 -- return a partial result when it encounters a lexer error.
127 -- We want to extract options before the buffer is passed through
128 -- CPP, so we can't use the same trick as 'getImports'.
129 getOptions' :: DynFlags
130 -> StringBuffer -- Input buffer
131 -> FilePath -- Source file. Used for msgs only.
132 -> ( Maybe StringBuffer -- Just => we can use more input
133 , [Located String] -- Options.
135 getOptions' dflags buf filename
136 = parseToks (lexAll (pragState dflags buf loc))
137 where loc = mkSrcLoc (mkFastString filename) 1 0
139 getToken (_buf,L _loc tok) = tok
140 getLoc (_buf,L loc _tok) = loc
141 getBuf (buf,_tok) = buf
142 combine opts (flag, opts') = (flag, opts++opts')
143 add opt (flag, opts) = (flag, opt:opts)
145 parseToks (open:close:xs)
146 | IToptions_prag str <- getToken open
147 , ITclose_prag <- getToken close
148 = map (L (getLoc open)) (words str) `combine`
150 parseToks (open:close:xs)
151 | ITinclude_prag str <- getToken open
152 , ITclose_prag <- getToken close
153 = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
155 parseToks (open:close:xs)
156 | ITdocOptions str <- getToken open
157 , ITclose_prag <- getToken close
158 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
159 `combine` parseToks xs
161 | ITdocOptionsOld str <- getToken open
162 = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
163 `combine` parseToks xs
165 | ITlanguage_prag <- getToken open
167 -- The last token before EOF could have been truncated.
168 -- We ignore it to be on the safe side.
170 | ITeof <- getToken eof
171 = (Just (getBuf tok),[])
173 | ITeof <- getToken eof
174 = (Just (getBuf eof),[])
175 parseToks _ = (Nothing,[])
176 parseLanguage ((_buf,L loc (ITconid fs)):rest)
177 = checkExtension (L loc fs) `add`
179 (_,L _loc ITcomma):more -> parseLanguage more
180 (_,L _loc ITclose_prag):more -> parseToks more
181 (_,L loc _):_ -> languagePragParseError loc
182 parseLanguage (tok:_)
183 = languagePragParseError (getLoc tok)
184 lexToken t = return t
185 lexAll state = case unP (lexer lexToken) state of
186 POk _ t@(L _ ITeof) -> [(buffer state,t)]
187 POk state' t -> (buffer state,t):lexAll state'
188 _ -> [(buffer state,L (last_loc state) ITeof)]
190 -----------------------------------------------------------------------------
191 -- Complain about non-dynamic flags in OPTIONS pragmas
193 checkProcessArgsResult :: [String] -> FilePath -> IO ()
194 checkProcessArgsResult flags filename
195 = do when (notNull flags) (throwDyn (ProgramError (
196 showSDoc (hang (text filename <> char ':')
197 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+>
198 hsep (map text flags)))
201 -----------------------------------------------------------------------------
203 checkExtension :: Located FastString -> Located String
204 checkExtension (L l ext)
205 -- Checks if a given extension is valid, and if so returns
206 -- its corresponding flag. Otherwise it throws an exception.
207 = let ext' = unpackFS ext in
208 if ext' `elem` supportedLanguages
209 || ext' `elem` (map ("No"++) supportedLanguages)
210 then L l ("-X"++ext')
211 else unsupportedExtnError l ext'
213 languagePragParseError :: SrcSpan -> a
214 languagePragParseError loc =
216 (showSDoc (mkLocMessage loc (
217 text "cannot parse LANGUAGE pragma: comma-separated list expected")))
219 unsupportedExtnError :: SrcSpan -> String -> a
220 unsupportedExtnError loc unsup =
221 pgmError (showSDoc (mkLocMessage loc (
222 text "unsupported extension: " <>
226 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
227 optionsErrorMsgs unhandled_flags flags_lines _filename
228 = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
229 where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
230 L l f' <- flags_lines, f == f' ]
231 mkMsg (L flagSpan flag) =
232 ErrUtils.mkPlainErrMsg flagSpan $
233 text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag