[project @ 2005-03-21 10:50:22 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / GetImports.hs

diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs
index b3a3416..c165b4a 100644 (file)
--- a/ghc/compiler/main/GetImports.hs
+++ b/ghc/compiler/main/GetImports.hs
@@ -1,77 +1,63 @@
 -----------------------------------------------------------------------------
--- $Id: GetImports.hs,v 1.2 2000/11/17 13:33:17 sewardj 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 ( getImports ) where
-
-import Module
+module GetImports ( getImportsFromFile, getImports ) where
+
+#include "HsVersions.h"
+
+import Parser          ( parseHeader )
+import Lexer           ( P(..), ParseResult(..), mkPState )
+import HsSyn           ( ImportDecl(..), HsModule(..) )
+import Module          ( Module, mkModule )
+import PrelNames        ( gHC_PRIM )
+import StringBuffer    ( StringBuffer, hGetStringBuffer )
+import SrcLoc          ( Located(..), mkSrcLoc, unLoc )
+import FastString      ( mkFastString )
+import DynFlags        ( DynFlags )
+import ErrUtils
+import Pretty
+import Panic
+import Bag             ( unitBag )
+
+import EXCEPTION       ( throwDyn )
+import IO
 import List
-import Char
-
-getImports :: String -> ([ModuleName], [ModuleName], ModuleName)
-getImports s
-   = f [{-accum source imports-}] [{-accum normal imports-}] 
-       (mkModuleName "Main") (words (clean s))
-     where
-        f si ni _  ("module" : me : ws) = f si ni (mkModuleName me) ws
-
-       f si ni me ("foreign" : "import" : ws) = f si ni me ws
-        f si ni me ("import" : "{-#" : "SOURCE" : "#-}" : "qualified" : m : ws) 
-           = f ((mkMN m):si) ni me ws
-        f si ni me ("import" : "{-#" : "SOURCE" : "#-}" : m : ws) 
-           = f ((mkMN m):si) ni me ws
-        f si ni me ("import" : "qualified" : m : ws) 
-           = f si ((mkMN m):ni) me ws
-        f si ni me ("import" : 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 = mkModuleName (takeWhile isModId str)
-        isModId c = isAlphaNum c || c `elem` "'_"
-
--- remove literals and comments from a string
-clean :: String -> String
-clean s
-   = keep s
-     where
-        -- running through text we want to keep
-        keep []                   = []
-        keep ('"':cs)             = dquote cs          -- "
-               -- try to eliminate single quotes when they're part of
-               -- an identifier...
-       keep (c:'\'':cs) | isAlphaNum c || c == '_' = keep (dropWhile (=='\'') cs)
-        keep ('\'':cs)            = squote cs
-        keep ('-':'-':cs)         = linecomment cs
-        keep ('{':'-':'#':' ':cs) = "{-# " ++ keep cs
-        keep ('{':'-':cs)         = runcomment cs      -- -}
-        keep (c:cs)               = c : keep cs
-
-        -- 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) = '\n':keep cs
-        linecomment (c:cs)    = linecomment cs
 
-        -- in a running comment
-        runcomment []           = []
-        runcomment ('-':'}':cs) = keep cs
-        runcomment (c:cs)       = runcomment cs
+-- 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 ([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 = filter (/= gHC_PRIM) (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 (ProgramError err_doc)
+  where err_doc = render (pprBagOfErrors (unitBag (mkPlainErrMsg span err)))
+
+isSourceIdecl (ImportDecl _ s _ _ _) = s
+
+getImpMod (ImportDecl (L _ mod) _ _ _ _) = mod