Commit 1159c0c0 authored by simonmar's avatar simonmar

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

Support for returning the renamed syntax from checkModule (untested).
parent eec59c80
......@@ -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}
......
......@@ -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
......
......@@ -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)))
}}}}
------------------------------
......
......@@ -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
......
......@@ -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)
}}
------------------------------------------------
......
......@@ -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 = [],
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment