From: simonmar Date: Wed, 27 Apr 2005 11:15:16 +0000 (+0000) Subject: [project @ 2005-04-27 11:15:15 by simonmar] X-Git-Tag: Initial_conversion_from_CVS_complete~660 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1159c0c06db593588cfae24e47a80e71c51c6129;p=ghc-hetmet.git [project @ 2005-04-27 11:15:15 by simonmar] Support for returning the renamed syntax from checkModule (untested). --- diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 0737782..807a2bb 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/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} diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 6ce921d..a2487d8 100644 --- a/ghc/compiler/main/GHC.hs +++ b/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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 404c7ed..389731c 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/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))) }}}} ------------------------------ diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 200b621..1977a54 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/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 diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 045577b..f5bf84c 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/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) }} ------------------------------------------------ diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index ac5e59a..bab89d0 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/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 = [], diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 4bd633b..8edada3 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/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