X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGetImports.hs;fp=ghc%2Fcompiler%2Fmain%2FGetImports.hs;h=e60cb25ddb6b5995aff2f6d88f5fa8228fc6ea43;hb=c464eda3010831d8e5fb97c950aef953a1217db6;hp=249e1e14f111cb2c604df47c79f696932c430d8f;hpb=c7333e5dcef5345b1ac1a7e382aeda8bdbfa9c16;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs index 249e1e1..e60cb25 100644 --- a/ghc/compiler/main/GetImports.hs +++ b/ghc/compiler/main/GetImports.hs @@ -1,120 +1,61 @@ ----------------------------------------------------------------------------- --- $Id: GetImports.hs,v 1.11 2004/11/26 16:20:57 simonmar Exp $ -- --- GHC Driver program +-- Parsing the top of a Haskell source file to get its module name +-- and imports. -- --- (c) Simon Marlow 2000 +-- (c) Simon Marlow 2005 -- ----------------------------------------------------------------------------- module GetImports ( getImportsFromFile, getImports ) where -import Module - +#include "HsVersions.h" + +import Parser ( parseHeader ) +import Lexer ( P(..), ParseResult(..), mkPState ) +import HsSyn ( ImportDecl(..), HsModule(..) ) +import Module ( Module, mkModule ) +import StringBuffer ( StringBuffer, hGetStringBuffer ) +import SrcLoc ( Located(..), mkSrcLoc, unLoc ) +import FastString ( mkFastString ) +import CmdLineOpts ( DynFlags ) +import ErrUtils +import Pretty +import Panic +import Bag ( unitBag ) + +import EXCEPTION ( throwDyn ) import IO import List -import Char -- 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 :: String -> IO ([Module], [Module], Module) -getImportsFromFile filename - = do hdl <- openFile filename ReadMode - modsrc <- hGetContents hdl - let (srcimps,imps,mod_name) = getImports modsrc - length srcimps `seq` length imps `seq` return () - hClose hdl - return (srcimps,imps,mod_name) - -getImports :: String -> ([Module], [Module], Module) -getImports s - = case f [{-accum source imports-}] [{-accum normal imports-}] - Nothing (clean s) of - (si, ni, Nothing) -> (si, ni, mkModule "Main") - (si, ni, Just me) -> (si, ni, me) - where - -- Only pick up the name following 'module' the first time. - -- Otherwise, we would be fooled by 'module Me ( module Wrong )' - -- and conclude that the module name is Wrong instead of Me. - f si ni old_me ("eludom" : me : ws) - = case old_me of - Nothing -> f si ni (Just (mkMN me)) ws - Just _ -> f si ni old_me ws - - f si ni me ("ngierof" : "tropmi" : ws) = f si ni me ws - f si ni me ("tropmi" : "#-{" : "ECRUOS" : "}-#" : "deifilauq" : m : ws) - = f ((mkMN m):si) ni me ws - f si ni me ("tropmi" : "#-{" : "ECRUOS" : "}-#" : m : ws) - = f ((mkMN m):si) ni me ws - - -- skip other contents of pragma comments - f si ni me ("#-{" : ws) - = f si ni me (drop 1 (dropWhile (/= "}-#") ws)) - - f si ni me ("tropmi" : "deifilauq" : m : ws) - = f si ((mkMN m):ni) me ws - f si ni me ("tropmi" : m : ws) - = f si ((mkMN m):ni) me ws - f si ni me (w:ws) = f si ni me ws - f si ni me [] = (nub si, nub ni, me) - - mkMN str = mkModule (takeWhile isModId (reverse str)) - isModId c = isAlphaNum c || c `elem` "'._" - - --- remove literals and comments from a string, producing a --- list of reversed words. -clean :: String -> [String] -clean s - = keep "" s - where - -- running through text we want to keep - keep acc [] = cons acc [] - keep acc (c:cs) | isSpace c = cons acc (keep "" cs) - - keep acc ('"':cs) = cons acc (dquote cs) -- " - - -- don't be fooled by single quotes which are part of an identifier - keep acc (c:'\'':cs) - | isAlphaNum c || c == '_' = keep ('\'':c:acc) (c:cs) - - keep acc ('\'':cs) = cons acc (squote cs) - keep acc ('-':'-':cs) = cons acc (linecomment cs) - keep acc ('{':'-':'#':' ':cs) = cons acc (cons "#-{" (keep "" cs)) - keep acc ('{':'-':cs) = cons acc (runcomment (0::Int) cs) -- -} - keep acc ('{':cs) = cons acc (keep "" cs) - keep acc (';':cs) = cons acc (keep "" cs) - -- treat ';' and '{' as word separators so that stuff - -- like "{import A;" and ";;;;import B;" are handled correctly. - keep acc (c:cs) = keep (c:acc) cs - - cons [] xs = xs - cons x xs = x : xs - - -- in a double-quoted string - dquote [] = [] - dquote ('\\':'\"':cs) = dquote cs -- " - dquote ('\\':'\\':cs) = dquote cs - dquote ('\"':cs) = keep "" cs -- " - dquote (c:cs) = dquote cs - - -- in a single-quoted string - squote [] = [] - squote ('\\':'\'':cs) = squote cs - squote ('\\':'\\':cs) = squote cs - squote ('\'':cs) = keep "" cs - squote (c:cs) = squote cs - - -- in a line comment - linecomment [] = [] - linecomment ('\n':cs) = keep "" cs - linecomment (c:cs) = linecomment cs - - -- in a running comment - runcomment _ [] = [] - runcomment n ('{':'-':cs) = runcomment (n+1) cs -- catches both nested comments and pragmas. - runcomment n ('-':'}':cs) - | n == 0 = keep "" cs - | otherwise = runcomment (n-1) cs - runcomment n (c:cs) = runcomment n cs +getImportsFromFile :: DynFlags -> FilePath -> IO ([Module], [Module], Module) +getImportsFromFile dflags filename = do + buf <- hGetStringBuffer filename + getImports dflags buf filename + +getImports :: DynFlags -> StringBuffer -> FilePath -> IO ([Module], [Module], 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 (L _ m) <- mod = m + | otherwise = mkModule "Main" + (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) + source_imps = map getImpMod src_idecls + ordinary_imps = map getImpMod ord_idecls + in + return (source_imps, ordinary_imps, mod_name) + +parseError span err = throwDyn (ProgramError err_doc) + where err_doc = render (pprBagOfErrors (unitBag (mkPlainErrMsg span err))) + +isSourceIdecl (ImportDecl _ s _ _ _) = s + +getImpMod (ImportDecl (L _ mod) _ _ _ _) = mod