[commit: ghc] wip/gadtpm: Fixes: removed closeOverKinds, Get Qs from signature, not so chatty (1e2783b)

[git at git.haskell.org]

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

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

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

commit 1e2783b4a95db11b3ce3dc59d0012b80961db74f
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Wed Feb 25 16:45:02 2015 +0100

    Fixes: removed closeOverKinds, Get Qs from signature, not so chatty


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

1e2783b4a95db11b3ce3dc59d0012b80961db74f
 compiler/basicTypes/Var.hs     |  3 ++-
 compiler/deSugar/Check.hs      | 22 +++++++++++-----------
 compiler/deSugar/DsBinds.hs    |  3 ++-
 compiler/typecheck/TcSMonad.hs |  8 ++++----
 4 files changed, 19 insertions(+), 17 deletions(-)

diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index d121793..4079a1e 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -205,7 +205,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
 -}
 
 instance Outputable Var where
-  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 ec852ff..306647b 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -136,8 +136,8 @@ 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:") <+> ppr 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,14 +551,14 @@ 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 "dataConUserType =") <+> ppr (dataConUserType con))
-  pprInTcRnIf (ptext (sLit "dataConSig      =") <+> ppr (dataConSig con))
+  -- pprInTcRnIf (ptext (sLit "Iferring type for pattern:") <+> ppr (PmConPat con args))
+  -- pprInTcRnIf (ptext (sLit "dataConUserType =") <+> ppr (dataConUserType con))
+  -- pprInTcRnIf (ptext (sLit "dataConSig      =") <+> ppr (dataConSig con))
   -- ----------------------------------------------------------------
   (tys, cs) <- inferTyPmPats args -- Infer argument types and respective constraints (Just like the paper)
 
   let (tvs, thetas', arg_tys', res_ty') = dataConSig con -- take apart the constructor
-      tkvs = varSetElemsKvsFirst (closeOverKinds (mkVarSet tvs)) -- as, bs and their kinds
+      tkvs = varSetElemsKvsFirst (mkVarSet tvs) -- as, bs and their kinds
   (subst, _tvs) <- -- create the substitution for both as and bs
     getSrcSpanDs >>= \loc -> genInstSkolTyVars loc tkvs
   let res_ty  = substTy  subst res_ty' -- result type
@@ -587,12 +587,12 @@ wt sig (_, vec)
       cs' <- zipWithM newEqPmM (map expandTypeSynonyms sig) tys -- The vector should match the signature type
       env_cs <- getDictsDs
       loc <- getSrcSpanDs
-      pprInTcRnIf (ptext (sLit "Checking in location:") <+> ppr loc)
-      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 (ptext (sLit "Checking in location:") <+> ppr loc)
+      -- 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)))
       let constraints = listToBag cs' `unionBags` cs `unionBags` env_cs
-      pprInTcRnIf (ptext (sLit "Constraints:") <+> ppr (mapBag varType constraints))
+      -- pprInTcRnIf (ptext (sLit "Constraints:") <+> ppr (mapBag varType constraints))
       isSatisfiable constraints
   | otherwise = pprPanic "wt: length mismatch:" (ppr sig $$ ppr vec)
 
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 3e91806..d4b0db4 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -136,7 +136,8 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_ev_binds = ev_binds, abs_binds = binds })
   | ABE { abe_wrap = wrap, abe_poly = global
         , abe_mono = local, abe_prags = prags } <- export
-  = do  { dflags <- getDynFlags
+  = addDictsDs (toTcTypeBag (listToBag dicts)) $
+     do { dflags <- getDynFlags
         ; bind_prs <- ds_lhs_binds binds
         ; let core_bind = Rec (fromOL bind_prs)
         ; ds_binds <- dsTcEvBinds_s ev_binds
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 3721f92..6e50c96 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))