[project @ 2005-04-27 11:15:15 by simonmar]

Support for returning the renamed syntax from checkModule (untested).

ghc/compiler/hsSyn/HsDecls.lhs

@@ -11,11 +11,12 @@ module HsDecls (
 	HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, 
 	InstDecl(..), LInstDecl, NewOrData(..),
 	RuleDecl(..), LRuleDecl, RuleBndr(..),
-	DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..),
+	DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
 	ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
 	CImportSpec(..), FoType(..),
 	ConDecl(..), LConDecl,	
 	DeprecDecl(..),  LDeprecDecl,
+	HsGroup(..),  emptyGroup, appendGroups,
 	tcdName, tyClDeclNames, tyClDeclTyVars,
 	isClassDecl, isSynDecl, isDataDecl, 
 	countTyClDecls,
@@ -29,7 +30,7 @@ module HsDecls (
 import {-# SOURCE #-}	HsExpr( HsExpr, pprExpr )
 	-- Because Expr imports Decls via HsBracket
 
-import HsBinds		( HsBindGroup, HsBind, LHsBinds, 
+import HsBinds		( HsBindGroup(..), HsBind, LHsBinds, 
 			  Sig(..), LSig, LFixitySig, pprLHsBinds )
 import HsPat		( HsConDetails(..), hsConArgs )
 import HsImpExp		( pprHsVar )
@@ -37,7 +38,7 @@ import HsTypes
 import HscTypes		( DeprecTxt )
 import CoreSyn		( RuleName )
 import Kind		( Kind, pprKind )
-import BasicTypes	( Activation(..) )
+import BasicTypes	( Activation(..), RecFlag(..) )
 import ForeignCall	( CCallTarget(..), DNCallSpec, CCallConv, Safety,
 			  CExportSpec(..), CLabelString ) 
 
@@ -46,6 +47,7 @@ import FunDeps		( pprFundeps )
 import Class		( FunDep )
 import Outputable	
 import Util		( count )
+import Bag		( emptyBag )
 import SrcLoc		( Located(..), unLoc )
 import FastString
 \end{code}
@@ -106,6 +108,42 @@ data HsGroup id
 	hs_depds  :: [LDeprecDecl id],
 	hs_ruleds :: [LRuleDecl id]
   }
+
+emptyGroup = HsGroup { hs_valds = [],
+		       hs_tyclds = [], hs_instds = [],
+		       hs_fixds = [], hs_defds = [], hs_fords = [], 
+		       hs_depds = [] ,hs_ruleds = [] }
+
+appendGroups :: HsGroup a -> HsGroup a -> HsGroup a
+appendGroups 
+    HsGroup { 
+	hs_valds  = val_groups1,
+	hs_tyclds = tyclds1, 
+	hs_instds = instds1,
+	hs_fixds  = fixds1, 
+	hs_defds  = defds1,
+	hs_fords  = fords1, 
+	hs_depds  = depds1,
+	hs_ruleds = rulds1 }
+    HsGroup { 
+	hs_valds  = val_groups2,
+	hs_tyclds = tyclds2, 
+	hs_instds = instds2,
+	hs_fixds  = fixds2, 
+	hs_defds  = defds2,
+	hs_fords  = fords2, 
+	hs_depds  = depds2,
+	hs_ruleds = rulds2 }
+  = 
+    HsGroup { 
+	hs_valds  = val_groups1 ++ val_groups2,
+	hs_tyclds = tyclds1 ++ tyclds2, 
+	hs_instds = instds1 ++ instds2,
+	hs_fixds  = fixds1 ++ fixds2, 
+	hs_defds  = defds1 ++ defds2,
+	hs_fords  = fords1 ++ fords2, 
+	hs_depds  = depds1 ++ depds2,
+	hs_ruleds = rulds1 ++ rulds2 }
 \end{code}
 
 \begin{code}

ghc/compiler/main/GHC.hs

@@ -36,7 +36,7 @@ module GHC (
 	loadMsgs,
 	workingDirectoryChanged,
 	checkModule, CheckedModule(..),
-	TypecheckedSource, ParsedSource,
+	TypecheckedSource, ParsedSource, RenamedSource,
 
 	-- * Inspecting the module structure of the program
 	ModuleGraph, ModSummary(..),
@@ -105,6 +105,9 @@ module GHC (
 	-- ** Entities
 	TyThing(..), 
 
+	-- ** Syntax
+	module HsSyn, -- ToDo: remove extraneous bits
+
 	-- * Exceptions
 	GhcException(..), showGhcException,
 
@@ -116,10 +119,8 @@ module GHC (
 {-
  ToDo:
 
-  * return error messages rather than printing them.
   * inline bits of HscMain here to simplify layering: hscGetInfo,
     hscTcExpr, hscStmt.
-  * implement second argument to load.
   * we need to expose DynFlags, so should parseDynamicFlags really be
     part of this interface?
   * what StaticFlags should we expose, if any?
@@ -144,7 +145,7 @@ import IfaceSyn		( IfaceDecl )
 import Packages		( initPackages )
 import NameSet		( NameSet, nameSetToList )
 import RdrName		( GlobalRdrEnv )
-import HsSyn		( HsModule, LHsBinds )
+import HsSyn
 import Type		( Kind, Type, dropForAlls )
 import Id		( Id, idType, isImplicitId, isDeadBinder,
                           isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
@@ -632,12 +633,13 @@ ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
 
 data CheckedModule = 
   CheckedModule { parsedSource      :: ParsedSource,
-		-- ToDo: renamedSource
+		  renamedSource     :: Maybe RenamedSource,
 		  typecheckedSource :: Maybe TypecheckedSource,
 		  checkedModuleInfo :: Maybe ModuleInfo
 	        }
 
-type ParsedSource  = Located (HsModule RdrName)
+type ParsedSource      = Located (HsModule RdrName)
+type RenamedSource     = HsGroup Name
 type TypecheckedSource = LHsBinds Id
 
 -- | This is the way to get access to parsed and typechecked source code
@@ -675,15 +677,21 @@ checkModule session@(Session ref) mod msg_act = do
 	   case r of
 		HscFail -> 
 		   return Nothing
-		HscChecked parsed Nothing ->
-		   return (Just (CheckedModule parsed Nothing Nothing))
-		HscChecked parsed (Just (tc_binds, rdr_env, details)) -> do
+		HscChecked parsed renamed Nothing ->
+		   return (Just (CheckedModule {
+					parsedSource = parsed,
+					renamedSource = renamed,
+					typecheckedSource = Nothing,
+					checkedModuleInfo = Nothing }))
+		HscChecked parsed renamed
+			   (Just (tc_binds, rdr_env, details)) -> do
 		   let minf = ModuleInfo {
 				minf_details  = details,
 				minf_rdr_env  = Just rdr_env
 			      }
 		   return (Just (CheckedModule {
 					parsedSource = parsed,
+					renamedSource = renamed,
 					typecheckedSource = Just tc_binds,
 					checkedModuleInfo = Just minf }))
 
@@ -1574,9 +1582,6 @@ data ObjectCode
   = ByteCode
   | BinaryCode FilePath
 
-type TypecheckedCode = HsTypecheckedGroup
-type RenamedCode     = [HsGroup Name]
-
 -- ToDo: typechecks abstract syntax or renamed abstract syntax.  Issues:
 --   - typechecked syntax includes extra dictionary translation and
 --     AbsBinds which need to be translated back into something closer to

ghc/compiler/main/HscMain.lhs

@@ -44,7 +44,7 @@ import SrcLoc		( SrcLoc, noSrcLoc )
 import Var		( Id )
 import Module		( emptyModuleEnv )
 import RdrName		( GlobalRdrEnv, RdrName )
-import HsSyn		( HsModule, LHsBinds, LStmt, LHsType )
+import HsSyn		( HsModule, LHsBinds, LStmt, LHsType, HsGroup )
 import SrcLoc		( Located(..) )
 import StringBuffer	( hGetStringBuffer, stringToStringBuffer )
 import Parser
@@ -138,8 +138,9 @@ data HscResult
 
    -- In IDE mode: we just do the static/dynamic checks
    | HscChecked 
-	(Located (HsModule RdrName))
-	(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails))
+	(Located (HsModule RdrName))			-- parsed
+	(Maybe (HsGroup Name))				-- renamed
+	(Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) -- typechecked
 
    -- Concluded that it wasn't necessary
    | HscNoRecomp ModDetails  	         -- new details (HomeSymbolTable additions)
@@ -283,7 +284,7 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
  	    -------------------
 	  (tc_msgs, maybe_tc_result) 
 		<- {-# SCC "Typecheck-Rename" #-}
-		   tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module
+		   tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
 
 	; msg_act tc_msgs
 	; case maybe_tc_result of {
@@ -323,11 +324,13 @@ hscFileCheck hsc_env msg_act mod_summary = do {
  	    -------------------
 	  (tc_msgs, maybe_tc_result) 
 		<- _scc_ "Typecheck-Rename" 
-		   tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module
+		   tcRnModule hsc_env (ms_hsc_src mod_summary) 
+			True{-save renamed syntax-}
+			rdr_module
 
 	; msg_act tc_msgs
 	; case maybe_tc_result of {
-      	     Nothing -> return (HscChecked rdr_module Nothing);
+      	     Nothing -> return (HscChecked rdr_module Nothing Nothing);
       	     Just tc_result -> do
 		let md = ModDetails { 
 				md_types   = tcg_type_env tc_result,
@@ -337,9 +340,10 @@ hscFileCheck hsc_env msg_act mod_summary = do {
 				   -- rules are IdCoreRules, not the
 				   -- RuleDecls we get out of the typechecker
 		return (HscChecked rdr_module 
-					(Just (tcg_binds tc_result,
-					       tcg_rdr_env tc_result,
-					       md)))
+				   (tcg_rn_decls tc_result)
+				   (Just (tcg_binds tc_result,
+					  tcg_rdr_env tc_result,
+					  md)))
 	}}}}
 
 ------------------------------

ghc/compiler/parser/RdrHsSyn.lhs

@@ -252,16 +252,13 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
 \end{code}
 
 \begin{code}
-emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
-		       hs_tyclds = [], hs_instds = [],
-		       hs_fixds = [], hs_defds = [], hs_fords = [], 
-		       hs_depds = [] ,hs_ruleds = [] }
-
 findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-findSplice ds = addl emptyGroup ds
+findSplice ds = addl oneEmptyBindGroup ds
 
 mkGroup :: [LHsDecl a] -> HsGroup a
-mkGroup ds = addImpDecls emptyGroup ds
+mkGroup ds = addImpDecls oneEmptyBindGroup ds
+
+oneEmptyBindGroup = emptyGroup{ hs_valds = [HsBindGroup emptyBag [] Recursive] }
 
 addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
 -- The decls are imported, and should not have a splice

ghc/compiler/typecheck/TcRnDriver.lhs

@@ -27,7 +27,9 @@ import DynFlags		( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
 import StaticFlags	( opt_PprStyle_Debug )
 import Packages		( moduleToPackageConfig, mkPackageId, package,
 			  isHomeModule )
-import HsSyn		( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
+import HsSyn		( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
+			  SpliceDecl(..), HsBind(..),
+			  emptyGroup, appendGroups,
 			  nlHsApp, nlHsVar, pprLHsBinds )
 import RdrHsSyn		( findSplice )
 
@@ -153,11 +155,13 @@ import Maybe		( isJust )
 \begin{code}
 tcRnModule :: HscEnv 
 	   -> HscSource
+	   -> Bool 		-- True <=> save renamed syntax
 	   -> Located (HsModule RdrName)
 	   -> IO (Messages, Maybe TcGblEnv)
 
-tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies 
-				import_decls local_decls mod_deprec))
+tcRnModule hsc_env hsc_src save_rn_decls
+	 (L loc (HsModule maybe_mod export_ies 
+			  import_decls local_decls mod_deprec))
  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 
    let { this_mod = case maybe_mod of
@@ -191,7 +195,11 @@ tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies
 	updGblEnv ( \ gbl -> 
 		gbl { tcg_rdr_env  = rdr_env,
 		      tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
-		      tcg_imports  = tcg_imports gbl `plusImportAvails` imports }) 
+		      tcg_imports  = tcg_imports gbl `plusImportAvails` imports,
+		      tcg_rn_decls = if save_rn_decls then
+					Just emptyGroup
+				     else
+					Nothing })
 		$ do {
 
 	traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
@@ -624,10 +632,17 @@ rnTopSrcDecls group
 	(tcg_env, rn_decls) <- rnSrcDecls group ;
 	failIfErrsM ;
 
+		-- save the renamed syntax, if we want it
+	let { tcg_env'
+	        | Just grp <- tcg_rn_decls tcg_env
+	          = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
+	        | otherwise
+	           = tcg_env };
+
 		-- Dump trace of renaming part
 	rnDump (ppr rn_decls) ;
 
-	return (tcg_env, rn_decls)
+	return (tcg_env', rn_decls)
    }}
 
 ------------------------------------------------

ghc/compiler/typecheck/TcRnMonad.lhs

@@ -93,6 +93,7 @@ initTc hsc_env hsc_src mod do_this
 		tcg_exports  = emptyNameSet,
 		tcg_imports  = init_imports,
 		tcg_dus      = emptyDUs,
+		tcg_rn_decls = Nothing,
 		tcg_binds    = emptyLHsBinds,
 		tcg_deprecs  = NoDeprecs,
 		tcg_insts    = [],

ghc/compiler/typecheck/TcRnTypes.lhs

@@ -39,7 +39,7 @@ module TcRnTypes(
 #include "HsVersions.h"
 
 import HsSyn		( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
-			  ArithSeqInfo, DictBinds, LHsBinds )
+			  ArithSeqInfo, DictBinds, LHsBinds, HsGroup )
 import HscTypes		( FixityEnv,
 			  HscEnv, TypeEnv, TyThing, 
 			  GenAvailInfo(..), AvailInfo, HscSource(..),
@@ -193,9 +193,14 @@ data TcGblEnv
 		-- tcg_inst_uses; the reference is implicit rather than explicit,
 		-- so we have to zap a mutable variable.
 
-		-- The next fields accumulate the payload of the module
-		-- The binds, rules and foreign-decl fiels are collected
-		-- initially in un-zonked form and are finally zonked in tcRnSrcDecls
+		-- The next fields accumulate the payload of the
+		-- module The binds, rules and foreign-decl fiels are
+		-- collected initially in un-zonked form and are
+		-- finally zonked in tcRnSrcDecls
+
+	tcg_rn_decls :: Maybe (HsGroup Name),	-- renamed decls, maybe
+		-- Nothing <=> Don't retain renamed decls
+
 	tcg_binds   :: LHsBinds Id,		-- Value bindings in this module
 	tcg_deprecs :: Deprecations,		-- ...Deprecations 
 	tcg_insts   :: [DFunId],		-- ...Instances