diff options
Diffstat (limited to 'compiler/main/HeaderInfo.hs')
| -rw-r--r-- | compiler/main/HeaderInfo.hs | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs new file mode 100644 index 0000000000..913ac33a33 --- /dev/null +++ b/compiler/main/HeaderInfo.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- +-- Parsing the top of a Haskell source file to get its module name, +-- imports and options. +-- +-- (c) Simon Marlow 2005 +-- (c) Lemmih 2006 +-- +----------------------------------------------------------------------------- + +module HeaderInfo ( getImportsFromFile, getImports + , getOptionsFromFile, getOptions + , optionsErrorMsgs ) where + +#include "HsVersions.h" + +import Parser ( parseHeader ) +import Lexer ( P(..), ParseResult(..), mkPState, pragState + , lexer, Token(..), PState(..) ) +import FastString +import HsSyn ( ImportDecl(..), HsModule(..) ) +import Module ( Module, mkModule ) +import PrelNames ( gHC_PRIM ) +import StringBuffer ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock + , appendStringBuffers ) +import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan ) +import FastString ( mkFastString ) +import DynFlags ( DynFlags ) +import ErrUtils +import Util +import Outputable +import Pretty () +import Panic +import Bag ( unitBag, emptyBag, listToBag ) + +import Distribution.Compiler + +import TRACE + +import EXCEPTION ( throwDyn ) +import IO +import List + +#if __GLASGOW_HASKELL__ >= 601 +import System.IO ( openBinaryFile ) +#else +import IOExts ( openFileEx, IOModeEx(..) ) +#endif + +#if __GLASGOW_HASKELL__ < 601 +openBinaryFile fp mode = openFileEx fp (BinaryMode mode) +#endif + +-- getImportsFromFile is careful to close the file afterwards, otherwise +-- we can end up with a large number of open handles before the garbage +-- collector gets around to closing them. +getImportsFromFile :: DynFlags -> FilePath + -> IO ([Located Module], [Located Module], Located Module) +getImportsFromFile dflags filename = do + buf <- hGetStringBuffer filename + getImports dflags buf filename + +getImports :: DynFlags -> StringBuffer -> FilePath + -> IO ([Located Module], [Located Module], Located Module) +getImports dflags buf filename = do + let loc = mkSrcLoc (mkFastString filename) 1 0 + case unP parseHeader (mkPState buf loc dflags) of + PFailed span err -> parseError span err + POk _ rdr_module -> + case rdr_module of + L _ (HsModule mod _ imps _ _) -> + let + mod_name | Just located_mod <- mod = located_mod + | otherwise = L noSrcSpan (mkModule "Main") + (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) + source_imps = map getImpMod src_idecls + ordinary_imps = filter ((/= gHC_PRIM) . unLoc) + (map getImpMod ord_idecls) + -- GHC.Prim doesn't exist physically, so don't go looking for it. + in + return (source_imps, ordinary_imps, mod_name) + +parseError span err = throwDyn $ mkPlainErrMsg span err + +isSourceIdecl (ImportDecl _ s _ _ _) = s + +getImpMod (ImportDecl located_mod _ _ _ _) = located_mod + +-------------------------------------------------------------- +-- Get options +-------------------------------------------------------------- + + +getOptionsFromFile :: FilePath -- input file + -> IO [Located String] -- options, if any +getOptionsFromFile filename + = bracket (openBinaryFile filename ReadMode) + (hClose) + (\handle -> + do buf <- hGetStringBufferBlock handle blockSize + loop handle buf) + where blockSize = 1024 + loop handle buf + | len buf == 0 = return [] + | otherwise + = case getOptions' buf filename of + (Nothing, opts) -> return opts + (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize + newBuf <- appendStringBuffers buf' nextBlock + if len newBuf == len buf + then return opts + else do opts' <- loop handle newBuf + return (opts++opts') + +getOptions :: StringBuffer -> FilePath -> [Located String] +getOptions buf filename + = case getOptions' buf filename of + (_,opts) -> opts + +-- The token parser is written manually because Happy can't +-- return a partial result when it encounters a lexer error. +-- We want to extract options before the buffer is passed through +-- CPP, so we can't use the same trick as 'getImports'. +getOptions' :: StringBuffer -- Input buffer + -> FilePath -- Source file. Used for msgs only. + -> ( Maybe StringBuffer -- Just => we can use more input + , [Located String] -- Options. + ) +getOptions' buf filename + = parseToks (lexAll (pragState buf loc)) + where loc = mkSrcLoc (mkFastString filename) 1 0 + + getToken (buf,L _loc tok) = tok + getLoc (buf,L loc _tok) = loc + getBuf (buf,_tok) = buf + combine opts (flag, opts') = (flag, opts++opts') + add opt (flag, opts) = (flag, opt:opts) + + parseToks (open:close:xs) + | IToptions_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) (words str) `combine` + parseToks xs + parseToks (open:close:xs) + | ITinclude_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) ["-#include",removeSpaces str] `combine` + parseToks xs + parseToks (open:xs) + | ITlanguage_prag <- getToken open + = parseLanguage xs + -- The last token before EOF could have been truncated. + -- We ignore it to be on the safe side. + parseToks [tok,eof] + | ITeof <- getToken eof + = (Just (getBuf tok),[]) + parseToks (eof:_) + | ITeof <- getToken eof + = (Just (getBuf eof),[]) + parseToks _ = (Nothing,[]) + parseLanguage ((_buf,L loc (ITconid fs)):rest) + = checkExtension (L loc fs) `add` + case rest of + (_,L loc ITcomma):more -> parseLanguage more + (_,L loc ITclose_prag):more -> parseToks more + (_,L loc _):_ -> languagePragParseError loc + parseLanguage (tok:_) + = languagePragParseError (getLoc tok) + lexToken t = return t + lexAll state = case unP (lexer lexToken) state of + POk state' t@(L _ ITeof) -> [(buffer state,t)] + POk state' t -> (buffer state,t):lexAll state' + _ -> [(buffer state,L (last_loc state) ITeof)] + +checkExtension :: Located FastString -> Located String +checkExtension (L l ext) + = case reads (unpackFS ext) of + [] -> languagePragParseError l + (okExt,""):_ -> case extensionsToGHCFlag [okExt] of + ([],[opt]) -> L l opt + _ -> unsupportedExtnError l okExt + +languagePragParseError loc = + pgmError (showSDoc (mkLocMessage loc ( + text "cannot parse LANGUAGE pragma"))) + +unsupportedExtnError loc unsup = + pgmError (showSDoc (mkLocMessage loc ( + text "unsupported extension: " <> + (text.show) unsup))) + + +optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs unhandled_flags flags_lines filename + = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) + where unhandled_flags_lines = [ L l f | f <- unhandled_flags, + L l f' <- flags_lines, f == f' ] + mkMsg (L flagSpan flag) = + ErrUtils.mkPlainErrMsg flagSpan $ + text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag + |