summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/basicTypes/Module.lhs34
-rw-r--r--ghc/compiler/compMan/CompManager.lhs19
-rw-r--r--ghc/compiler/main/DriverMkDepend.hs8
-rw-r--r--ghc/compiler/main/DriverPipeline.hs14
-rw-r--r--ghc/compiler/main/Finder.lhs4
-rw-r--r--ghc/compiler/main/GetImports.hs153
-rw-r--r--ghc/compiler/main/HscMain.lhs18
-rw-r--r--ghc/compiler/parser/Parser.y.pp19
8 files changed, 129 insertions, 140 deletions
diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs
index 8d4888400a..70e02091e0 100644
--- a/ghc/compiler/basicTypes/Module.lhs
+++ b/ghc/compiler/basicTypes/Module.lhs
@@ -44,6 +44,7 @@ import Maybes ( expectJust )
import UniqFM
import UniqSet
import Binary
+import StringBuffer ( StringBuffer )
import FastString
\end{code}
@@ -57,19 +58,26 @@ import FastString
data ModLocation
= ModLocation {
ml_hs_file :: Maybe FilePath,
-
- ml_hspp_file :: Maybe FilePath, -- Path of preprocessed source
-
- ml_hi_file :: FilePath, -- Where the .hi file is, whether or not it exists
- -- Always of form foo.hi, even if there is an hi-boot
- -- file (we add the -boot suffix later)
-
- ml_obj_file :: FilePath -- Where the .o file is, whether or not it exists
- -- (might not exist either because the module
- -- hasn't been compiled yet, or because
- -- it is part of a package with a .a file)
- }
- deriving Show
+ -- the source file, if we have one. Package modules
+ -- probably don't have source files.
+
+ ml_hspp_file :: Maybe FilePath,
+ -- filename of preprocessed source, if we have
+ -- preprocessed it.
+ ml_hspp_buf :: Maybe StringBuffer,
+ -- the actual preprocessed source, maybe.
+
+ ml_hi_file :: FilePath,
+ -- Where the .hi file is, whether or not it exists
+ -- yet. Always of form foo.hi, even if there is an
+ -- hi-boot file (we add the -boot suffix later)
+
+ ml_obj_file :: FilePath
+ -- Where the .o file is, whether or not it exists yet.
+ -- (might not exist either because the module hasn't
+ -- been compiled yet, or because it is part of a
+ -- package with a .a file)
+ } deriving Show
instance Outputable ModLocation where
ppr = text . show
diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index db2caf0b3e..44c23efab6 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -71,6 +71,7 @@ import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
import ErrUtils ( showPass )
import SysTools ( cleanTempFilesExcept )
import BasicTypes ( SuccessFlag(..), succeeded, failed )
+import StringBuffer ( hGetStringBuffer )
import Util
import Outputable
import Panic
@@ -1146,7 +1147,13 @@ noModError dflags loc mod_nm err
summariseFile :: DynFlags -> FilePath -> IO ModSummary
summariseFile dflags file
= do hspp_fn <- preprocess dflags file
- (srcimps,imps,mod) <- getImportsFromFile hspp_fn
+
+ -- Read the file into a buffer. We're going to cache
+ -- this buffer in the ModLocation (ml_hspp_buf) so that it
+ -- doesn't have to be slurped again when hscMain parses the
+ -- file later.
+ buf <- hGetStringBuffer hspp_fn
+ (srcimps,imps,mod) <- getImports dflags buf hspp_fn
let -- GHC.Prim doesn't exist physically, so don't go looking for it.
the_imps = filter (/= gHC_PRIM) imps
@@ -1159,7 +1166,8 @@ summariseFile dflags file
Just src_fn -> getModificationTime src_fn
return (ModSummary { ms_mod = mod,
- ms_location = location{ml_hspp_file=Just hspp_fn},
+ ms_location = location{ ml_hspp_file = Just hspp_fn,
+ ml_hspp_buf = Just buf },
ms_srcimps = srcimps, ms_imps = the_imps,
ms_hs_date = src_timestamp })
@@ -1183,7 +1191,9 @@ summarise dflags mod location old_summary
_ -> do
hspp_fn <- preprocess dflags hs_fn
- (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
+
+ buf <- hGetStringBuffer hspp_fn
+ (srcimps,imps,mod_name) <- getImports dflags buf hspp_fn
let
-- GHC.Prim doesn't exist physically, so don't go looking for it.
the_imps = filter (/= gHC_PRIM) imps
@@ -1194,7 +1204,8 @@ summarise dflags mod location old_summary
<> text ": file name does not match module name"
<+> quotes (ppr mod))))
- return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn}
+ return (Just (ModSummary mod location{ ml_hspp_file = Just hspp_fn,
+ ml_hspp_buf = Just buf }
srcimps the_imps src_timestamp))
}
}
diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs
index dda568f165..f39346285a 100644
--- a/ghc/compiler/main/DriverMkDepend.hs
+++ b/ghc/compiler/main/DriverMkDepend.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.34 2004/11/26 16:20:52 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.35 2005/01/14 17:57:46 simonmar Exp $
--
-- GHC Driver
--
@@ -14,7 +14,7 @@ module DriverMkDepend (
#include "HsVersions.h"
import HscTypes ( IfacePackage(..) )
-import GetImports ( getImports )
+import GetImports ( getImportsFromFile )
import CmdLineOpts ( DynFlags )
import DriverState
import DriverUtil
@@ -123,8 +123,8 @@ beginMkDependHS = do
doMkDependHSPhase dflags basename suff input_fn
- = do src <- readFile input_fn
- let (import_sources, import_normals, mod_name) = getImports src
+ = do (import_sources, import_normals, mod_name)
+ <- getImportsFromFile dflags input_fn
let orig_fn = basename ++ '.':suff
location' <- mkHomeModLocation mod_name orig_fn
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index d98dc20d7c..0db881ae6b 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -44,6 +44,7 @@ import Config
import RdrName ( GlobalRdrEnv )
import Panic
import Util
+import StringBuffer ( hGetStringBuffer )
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
@@ -557,14 +558,16 @@ runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do
writeIORef v_Include_paths (current_dir : paths)
-- gather the imports and module name
- (_,_,mod_name) <-
+ (hspp_buf,mod_name) <-
if isExtCoreFilename ('.':suff)
then do
-- no explicit imports in ExtCore input.
m <- getCoreModuleName input_fn
- return ([], [], mkModule m)
- else
- getImportsFromFile input_fn
+ return (Nothing, mkModule m)
+ else do
+ buf <- hGetStringBuffer input_fn
+ (_,_,mod_name) <- getImports dflags buf input_fn
+ return (Just buf, mod_name)
-- build a ModLocation to pass to hscMain.
location' <- mkHomeModLocation mod_name (basename ++ '.':suff)
@@ -618,7 +621,8 @@ runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do
-- run the compiler!
result <- hscMain hsc_env printErrorsAndWarnings mod_name
- location{ ml_hspp_file=Just input_fn }
+ location{ ml_hspp_file = Just input_fn,
+ ml_hspp_buf = hspp_buf }
source_unchanged
False
Nothing -- no iface
diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs
index 033c503921..857ae120f5 100644
--- a/ghc/compiler/main/Finder.lhs
+++ b/ghc/compiler/main/Finder.lhs
@@ -280,7 +280,8 @@ mkPackageModLocation pkg_info hisuf mod path basename _ext = do
hiOnlyModLocation path basename hisuf
= do let full_basename = path++'/':basename
obj_fn <- mkObjPath full_basename basename
- return ModLocation{ ml_hspp_file = Nothing,
+ return ModLocation{ ml_hspp_file = Nothing,
+ ml_hspp_buf = Nothing,
ml_hs_file = Nothing,
ml_hi_file = full_basename ++ '.':hisuf,
-- Remove the .hi-boot suffix from
@@ -338,6 +339,7 @@ mkHomeModLocation' mod src_basename ext = do
hi_fn <- mkHiPath src_basename mod_basename
let loc = ModLocation{ ml_hspp_file = Nothing,
+ ml_hspp_buf = Nothing,
ml_hs_file = Just (src_basename ++ '.':ext),
ml_hi_file = hi_fn,
ml_obj_file = obj_fn }
diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs
index 249e1e14f1..e60cb25ddb 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
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 953791a07f..ec550fa69f 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -224,7 +224,7 @@ hscRecomp hsc_env msg_act have_object
; front_res <- if toCore then
hscCoreFrontEnd hsc_env msg_act hspp_file
else
- hscFileFrontEnd hsc_env msg_act hspp_file
+ hscFileFrontEnd hsc_env msg_act hspp_file (ml_hspp_buf location)
; case front_res of
Left flure -> return flure;
@@ -350,11 +350,11 @@ hscCoreFrontEnd hsc_env msg_act hspp_file = do {
}}}
-hscFileFrontEnd hsc_env msg_act hspp_file = do {
+hscFileFrontEnd hsc_env msg_act hspp_file hspp_buf = do {
-------------------
-- PARSE
-------------------
- ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file
+ ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
; case maybe_parsed of {
Left err -> do { msg_act (unitBag err, emptyBag) ;
@@ -388,7 +388,7 @@ hscFileCheck hsc_env msg_act hspp_file = do {
-------------------
-- PARSE
-------------------
- ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file
+ ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file Nothing
; case maybe_parsed of {
Left err -> do { msg_act (unitBag err, emptyBag) ;
@@ -488,11 +488,17 @@ hscCmmFile dflags filename = do
no_mod = panic "hscCmmFile: no_mod"
-myParseModule dflags src_filename
+myParseModule dflags src_filename maybe_src_buf
= do -------------------------- Parser ----------------
showPass dflags "Parser"
_scc_ "Parser" do
- buf <- hGetStringBuffer src_filename
+
+ -- sometimes we already have the buffer in memory, perhaps
+ -- because we needed to parse the imports out of it, or get the
+ -- module name.
+ buf <- case maybe_src_buf of
+ Just b -> return b
+ Nothing -> hGetStringBuffer src_filename
let loc = mkSrcLoc (mkFastString src_filename) 1 0
diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index c8a58251e7..9e0725fb27 100644
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -8,7 +8,8 @@
-- ---------------------------------------------------------------------------
{
-module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where
+module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType,
+ parseHeader ) where
#define INCLUDE #include
INCLUDE "HsVersions.h"
@@ -276,6 +277,7 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T
%name parseIdentifier identifier
%name parseIface iface
%name parseType ctype
+%partial parseHeader header
%tokentype { Located Token }
%%
@@ -318,6 +320,21 @@ cvtopdecls :: { [LHsDecl RdrName] }
: topdecls { cvTopDecls $1 }
-----------------------------------------------------------------------------
+-- Module declaration & imports only
+
+header :: { Located (HsModule RdrName) }
+ : 'module' modid maybemoddeprec maybeexports 'where' header_body
+ {% fileSrcSpan >>= \ loc ->
+ return (L loc (HsModule (Just $2) $4 $6 [] $3)) }
+ | missing_module_keyword importdecls
+ {% fileSrcSpan >>= \ loc ->
+ return (L loc (HsModule Nothing Nothing $2 [] Nothing)) }
+
+header_body :: { [LImportDecl RdrName] }
+ : '{' importdecls { $2 }
+ | vocurly importdecls { $2 }
+
+-----------------------------------------------------------------------------
-- Interfaces (.hi-boot files)
iface :: { ModIface }
View Lorry Controller Status