+++ /dev/null
------------------------------------------------------------------------------
---
--- 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
-
projects / ghc-hetmet.git / blobdiff