Support for returning the renamed syntax from checkModule (untested).
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,
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 )
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 )
import Class ( FunDep )
import Outputable
import Util ( count )
+import Bag ( emptyBag )
import SrcLoc ( Located(..), unLoc )
import FastString
\end{code}
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}
loadMsgs,
workingDirectoryChanged,
checkModule, CheckedModule(..),
- TypecheckedSource, ParsedSource,
+ TypecheckedSource, ParsedSource, RenamedSource,
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..),
-- ** Entities
TyThing(..),
+ -- ** Syntax
+ module HsSyn, -- ToDo: remove extraneous bits
+
-- * Exceptions
GhcException(..), showGhcException,
{-
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?
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,
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
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 }))
= 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
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
-- 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)
-------------------
(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 {
-------------------
(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,
-- 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)))
}}}}
------------------------------
\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
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 )
\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
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)) ;
(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)
}}
------------------------------------------------
tcg_exports = emptyNameSet,
tcg_imports = init_imports,
tcg_dus = emptyDUs,
+ tcg_rn_decls = Nothing,
tcg_binds = emptyLHsBinds,
tcg_deprecs = NoDeprecs,
tcg_insts = [],
#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(..),
-- 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
projects / ghc-hetmet.git / commitdiff