[commit: ghc] wip/gadtpm: Make pmcheck more chatty about types and kinds (eb04a09)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/eb04a09efaefe7ada566d5af99f077fbc3bc2f39/ghc

>---------------------------------------------------------------

commit eb04a09efaefe7ada566d5af99f077fbc3bc2f39
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Thu Feb 26 01:28:12 2015 +0100

    Make pmcheck more chatty about types and kinds


>---------------------------------------------------------------

eb04a09efaefe7ada566d5af99f077fbc3bc2f39
 compiler/basicTypes/Var.hs     |  4 ++--
 compiler/deSugar/Check.hs      | 12 ++++++++----
 compiler/typecheck/TcSMonad.hs |  8 ++++----
 3 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index 4079a1e..3971b84 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -205,8 +205,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
 -}
 
 instance Outputable Var where
-  ppr var = ppr (varName var) <> getPprStyle (ppr_debug var)
-  -- ppr var = parens $ ppr (varName var) <> ptext (sLit "_") <> ppr (varUnique var) <> getPprStyle (ppr_debug var) <+> dcolon <+> ppr (varType var)
+  -- ppr var = ppr (varName var) <> getPprStyle (ppr_debug var)
+  ppr var = parens $ ppr (varName var) <> ptext (sLit "_") <> ppr (varUnique var) <> getPprStyle (ppr_debug var) <+> dcolon <+> ppr (varType var)
 
 ppr_debug :: Var -> PprStyle -> SDoc
 ppr_debug (TyVar {}) sty
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 306647b..c846e42 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -136,8 +136,9 @@ checkpm :: [Type] -> [EquationInfo] -> DsM (Maybe PmResult)
 checkpm tys eq_info
   | null eq_info = return (Just ([],[],[])) -- If we have an empty match, do not reason at all
   | otherwise = do
-      -- loc <- getSrcSpanDs
-      -- pprInTcRnIf (ptext (sLit "Checking match at") <+> ppr loc <+> ptext (sLit "with signature:") <+> ppr tys)
+      loc <- getSrcSpanDs
+      pprInTcRnIf (ptext (sLit "Checking match at") <+> ppr loc <+>
+        ptext (sLit "with signature:") <+> sep (punctuate comma (map pprTyWithKind tys)))
       uncovered0 <- initial_uncovered tys
       let allvanilla = all isVanillaEqn eq_info
       -- Need to pass this to process_vector, so that tc can be avoided
@@ -551,7 +552,7 @@ inferTyPmPat (PmLitPat ty _) = return (ty, emptyBag)
 inferTyPmPat (PmLitCon ty _) = return (ty, emptyBag)
 inferTyPmPat (PmConPat con args) = do
   -- ----------------------------------------------------------------
-  -- pprInTcRnIf (ptext (sLit "Iferring type for pattern:") <+> ppr (PmConPat con args))
+  -- pprInTcRnIf (ptext (sLit "For pattern:") <+> ppr (PmConPat con args))
   -- pprInTcRnIf (ptext (sLit "dataConUserType =") <+> ppr (dataConUserType con))
   -- pprInTcRnIf (ptext (sLit "dataConSig      =") <+> ppr (dataConSig con))
   -- ----------------------------------------------------------------
@@ -591,8 +592,11 @@ wt sig (_, vec)
       -- pprInTcRnIf (ptext (sLit "Checking vector") <+> ppr vec <+> ptext (sLit "with inferred type:") <+>
       --                     sep (punctuate comma (map pprTyWithKind tys)))
       -- pprInTcRnIf (ptext (sLit "With given signature:") <+> sep (punctuate comma (map pprTyWithKind sig)))
+      pprInTcRnIf (ppr loc <+> ptext (sLit "vector:") <+> ppr vec)
+      pprInTcRnIf (ptext (sLit "with inferred type:") <+> sep (punctuate comma (map pprTyWithKind tys)))
       let constraints = listToBag cs' `unionBags` cs `unionBags` env_cs
-      -- pprInTcRnIf (ptext (sLit "Constraints:") <+> ppr (mapBag varType constraints))
+      pprInTcRnIf (ptext (sLit "And constraints:") <+> ppr (mapBag varType constraints))
+
       isSatisfiable constraints
   | otherwise = pprPanic "wt: length mismatch:" (ppr sig $$ ppr vec)
 
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 6e50c96..3721f92 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -962,10 +962,10 @@ checkInsoluble :: TcS Bool
 -- True if there are any insoluble constraints
 checkInsoluble
   = do { icans <- getInertCans
-       -- ; let insols = inert_insols icans
-       -- ; if isEmptyBag insols
-       --     then return ()
-       --     else wrapTcS $ pprInTcRnIf (ptext (sLit "insolubles:") $$ ppr insols) -- just to see
+       ; let insols = inert_insols icans
+       ; if isEmptyBag insols
+           then return ()
+           else wrapTcS $ pprInTcRnIf (ptext (sLit "insolubles:") $$ ppr insols) -- just to see
        ; return (not (isEmptyBag (inert_insols icans))) }
 
 lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))