[commit: ghc] ghc-7.8: Better debug printing (37182fa)
git at git.haskell.org
git at git.haskell.org
Mon Jun 30 13:50:18 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-7.8
Link : http://ghc.haskell.org/trac/ghc/changeset/37182fa8e6a752b42b8acff5499a5f4cc3346c20/ghc
>---------------------------------------------------------------
commit 37182fa8e6a752b42b8acff5499a5f4cc3346c20
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Jun 12 16:35:37 2014 +0100
Better debug printing
(cherry picked from commit b60df0fa017eac8800a3848650dbad09acb6f1b8)
>---------------------------------------------------------------
37182fa8e6a752b42b8acff5499a5f4cc3346c20
compiler/basicTypes/OccName.lhs | 7 +++++--
compiler/rename/RnTypes.lhs | 13 +++++++++----
compiler/utils/UniqFM.lhs | 11 +++++++++--
3 files changed, 23 insertions(+), 8 deletions(-)
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index e870c46..370e9ee 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -86,7 +86,7 @@ module OccName (
lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,
- alterOccEnv,
+ alterOccEnv, pprOccEnv,
-- * The 'OccSet' type
OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,
@@ -416,7 +416,10 @@ filterOccEnv x (A y) = A $ filterUFM x y
alterOccEnv fn (A y) k = A $ alterUFM fn y k
instance Outputable a => Outputable (OccEnv a) where
- ppr (A x) = ppr x
+ ppr x = pprOccEnv ppr x
+
+pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc
+pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env
type OccSet = UniqSet OccName
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 23c54c3..bcb6231 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -360,8 +360,9 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
, let (_, kvs) = extractHsTyRdrTyVars kind
, kv <- kvs ]
- all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
- nub (kv_bndrs ++ kvs_from_tv_bndrs)
+ all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
+ all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs'
+
overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ]
-- These variables appear both as kind and type variables
-- in the same declaration; eg type family T (x :: *) (y :: x)
@@ -395,8 +396,12 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
- do { env <- getLocalRdrEnv
- ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env))
+ do { inner_rdr_env <- getLocalRdrEnv
+ ; traceRn (text "bhtv" <+> vcat
+ [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs
+ , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs'
+ , ppr $ map (getUnique . rdrNameOcc) all_kvs'
+ , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ])
; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
; return (res, fvs1 `plusFV` fvs2) } }
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index 52cd3dd..dd17a49 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -59,9 +59,10 @@ module UniqFM (
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM, keysUFM, splitUFM,
ufmToList,
- joinUFM
+ joinUFM, pprUniqFM
) where
+import FastString
import Unique ( Uniquable(..), Unique, getKey )
import Outputable
@@ -315,5 +316,11 @@ joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange,
\begin{code}
instance Outputable a => Outputable (UniqFM a) where
- ppr ufm = ppr (ufmToList ufm)
+ ppr ufm = pprUniqFM ppr ufm
+
+pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
+pprUniqFM ppr_elt ufm
+ = brackets $ fsep $ punctuate comma $
+ [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt
+ | (uq, elt) <- ufmToList ufm ]
\end{code}
More information about the ghc-commits
mailing list