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 <[email protected]> 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
