[commit: ghc] ghc-kinds: Temporary commit: add dependencies on all hs-boot TyCons in rnTyClDecls (1684bce)
José Pedro Magalhães
jpm at cs.uu.nl
Mon Nov 14 15:55:09 CET 2011
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : ghc-kinds
http://hackage.haskell.org/trac/ghc/changeset/1684bceaa6a4fed6dab820c36b06336624fa144e
>---------------------------------------------------------------
commit 1684bceaa6a4fed6dab820c36b06336624fa144e
Author: Jose Pedro Magalhaes <jpm at cs.uu.nl>
Date: Mon Nov 14 14:00:29 2011 +0000
Temporary commit: add dependencies on all hs-boot TyCons in rnTyClDecls
>---------------------------------------------------------------
compiler/rename/RnExpr.lhs | 3 +-
compiler/rename/RnSource.lhs | 52 +++++++++++++++++++++---------------
compiler/typecheck/TcRnDriver.lhs | 12 ++++----
3 files changed, 38 insertions(+), 29 deletions(-)
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 7f86380..89d6b42 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -32,6 +32,7 @@ import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
+import HscTypes ( emptyModDetails )
import TcEnv ( thRnBrack )
import RnEnv
import RnTypes ( rnHsTypeFVs, rnSplice, rnIPName, checkTH,
@@ -625,7 +626,7 @@ rnBracket (DecBrL decls)
-- group alone in the call to rnSrcDecls below
; (tcg_env, group') <- setGblEnv new_gbl_env $
setStage thRnBrack $
- rnSrcDecls group
+ rnSrcDecls emptyModDetails group -- JPM
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index b6247d4..cdb359a 100755
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -33,6 +33,7 @@ import RnNames
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
import Kind ( liftedTypeKind )
+import TyCon ( tyConName )
import ForeignCall ( CCallTarget(..) )
import Module
@@ -48,9 +49,9 @@ import FastString
import Util ( filterOut )
import SrcLoc
import DynFlags
-import HscTypes ( HscEnv, hsc_dflags )
+import HscTypes ( HscEnv, hsc_dflags, ModDetails, md_types, typeEnvTyCons )
import ListSetOps ( findDupsEq )
-import Digraph ( SCC, flattenSCCs, stronglyConnCompFromEdgedVertices )
+import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad
import Maybes( orElse )
@@ -76,20 +77,20 @@ Checks the @(..)@ etc constraints in the export list.
\begin{code}
-- Brings the binders of the group into scope in the appropriate places;
-- does NOT assume that anything is in scope already
-rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+rnSrcDecls :: ModDetails -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-- Rename a HsGroup; used for normal source files *and* hs-boot files
-rnSrcDecls group@(HsGroup { hs_valds = val_decls,
- hs_tyclds = tycl_decls,
- hs_instds = inst_decls,
- hs_derivds = deriv_decls,
- hs_fixds = fix_decls,
- hs_warnds = warn_decls,
- hs_annds = ann_decls,
- hs_fords = foreign_decls,
- hs_defds = default_decls,
- hs_ruleds = rule_decls,
- hs_vects = vect_decls,
- hs_docs = docs })
+rnSrcDecls boot_details group@(HsGroup { hs_valds = val_decls,
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fixds = fix_decls,
+ hs_warnds = warn_decls,
+ hs_annds = ann_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_decls,
+ hs_ruleds = rule_decls,
+ hs_vects = vect_decls,
+ hs_docs = docs })
= do {
-- (A) Process the fixity declarations, creating a mapping from
-- FastStrings to FixItems.
@@ -137,7 +138,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
traceRn (text "Start rnTyClDecls") ;
- (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
+ (rn_tycl_decls, src_fvs1) <- rnTyClDecls boot_details tycl_decls ;
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
@@ -701,17 +702,24 @@ and then go over it again to rename the tyvars!
However, we can also do some scoping checks at the same time.
\begin{code}
-rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
+rnTyClDecls :: ModDetails -> [[LTyClDecl RdrName]]
+ -> RnM ([[LTyClDecl Name]], FreeVars)
-- Renamed the declarations and do depedency analysis on them
-rnTyClDecls tycl_ds
+rnTyClDecls boot_details tycl_ds
= do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds)
- ; let sccs :: [SCC (LTyClDecl Name)]
- sccs = depAnalTyClDecls ds_w_fvs
+ ; let boot_tycons = typeEnvTyCons (md_types boot_details)
+ add_boot_deps :: FreeVars -> FreeVars
+ add_boot_deps fvs = fvs `plusFV` mkFVs (map tyConName boot_tycons)
- all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
+ ds_w_fvs' = map (\(ds, fvs) -> (ds, add_boot_deps fvs)) ds_w_fvs
- ; return ([flattenSCCs sccs], all_fvs) }
+ sccs :: [SCC (LTyClDecl Name)]
+ sccs = depAnalTyClDecls ds_w_fvs'
+
+ all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
+
+ ; return (map flattenSCC sccs, all_fvs) }
-- JPM: This is wrong. We are calculating the SCCs but then ignore them and
-- merge into a single, big group. This is a quick fix to allow
-- mutually-recursive types across modules to work, given the new way of kind
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 48f3cf8..89f6a35 100755
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -324,7 +324,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
(mkFakeGroup ldecls) ;
setEnvs tc_envs $ do {
- (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
+ (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls emptyModDetails [ldecls] ; -- JPM
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
@@ -464,7 +464,7 @@ tc_rn_src_decls boot_details ds
-- If ds is [] we get ([], Nothing)
-- Deal with decls up to, but not including, the first splice
- (tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
+ (tcg_env, rn_decls) <- rnTopSrcDecls boot_details first_group ;
-- rnTopSrcDecls fails if there are any errors
(tcg_env, tcl_env) <- setGblEnv tcg_env $
@@ -522,7 +522,7 @@ tcRnHsBootDecls decls
hs_ruleds = rule_decls,
hs_vects = vect_decls,
hs_annds = _,
- hs_valds = val_binds }) <- rnTopSrcDecls first_group
+ hs_valds = val_binds }) <- rnTopSrcDecls emptyModDetails first_group -- JPM
; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
@@ -850,12 +850,12 @@ monad; it augments it and returns the new TcGblEnv.
\begin{code}
------------------------------------------------
-rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
+rnTopSrcDecls :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-- Fails if there are any errors
-rnTopSrcDecls group
+rnTopSrcDecls boot_details group
= do { -- Rename the source decls
traceTc "rn12" empty ;
- (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
+ (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls boot_details group ;
traceTc "rn13" empty ;
-- save the renamed syntax, if we want it
More information about the Cvs-ghc
mailing list