[commit: ghc] wip/gadtpm: Cleanup 1: Remove redundant debugging prints (8364107)
git at git.haskell.org
git at git.haskell.org
Wed Mar 4 11:38:59 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/gadtpm
Link : http://ghc.haskell.org/trac/ghc/changeset/836410748b31ed382ca07758220b78df02528f46/ghc
>---------------------------------------------------------------
commit 836410748b31ed382ca07758220b78df02528f46
Author: George Karachalias <george.karachalias at gmail.com>
Date: Sat Feb 28 17:53:03 2015 +0100
Cleanup 1: Remove redundant debugging prints
>---------------------------------------------------------------
836410748b31ed382ca07758220b78df02528f46
compiler/basicTypes/Var.hs | 3 +-
compiler/deSugar/Check.hs | 64 ++----------------------------------------
compiler/typecheck/TcSMonad.hs | 4 ---
3 files changed, 3 insertions(+), 68 deletions(-)
diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index 3971b84..4cac5d5 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -205,8 +205,7 @@ 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_debug :: Var -> PprStyle -> SDoc
ppr_debug (TyVar {}) sty
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 83016b2..2235d66 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -138,8 +138,6 @@ 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:") <+> 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
@@ -541,45 +539,6 @@ isSatisfiable evs
Just sat -> return sat
Nothing -> pprPanic "isSatisfiable" (vcat $ pprErrMsgBagWithLoc errs) }
-{-
--- -----------------------------------------------------------------------
--- | Infer types
--- INVARIANTS:
--- 1) ALL PmLit and PmLitCon have the EXACT type (inherit it carefully while checking uncovered).
--- 2) ALL PmVarPat have fresh type, with the correct super kind
-inferTyPmPat :: PmPat Id -> PmM (Type, Bag EvVar) -- infer a type and a set of constraints
-inferTyPmPat (PmGuardPat _) = panic "inferTyPmPat: PmGuardPat"
-inferTyPmPat (PmVarPat ty _) = return (ty, emptyBag) -- instTypePmM ty >>= \ty' -> return (ty', emptyBag)
-inferTyPmPat (PmLitPat ty _) = return (ty, emptyBag)
-inferTyPmPat (PmLitCon ty _) = return (ty, emptyBag)
-inferTyPmPat (PmConPat con args) = do
- -- ----------------------------------------------------------------
- -- pprInTcRnIf (ptext (sLit "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
- (subst, _tvs) <- -- create the substitution for both as and bs
- getSrcSpanDs >>= \loc -> genInstSkolTyVars loc tvs
- let res_ty = substTy subst res_ty' -- result type
- arg_tys = substTys subst arg_tys'
- thetas <- mapM (nameType "varcon") $ substTheta subst thetas'
-
- arg_thetas <- foldM (\acc (ty1, ty2) -> do
- eq_theta <- newEqPmM ty1 ty2
- return (eq_theta `consBag` acc))
- cs (tys `zip` arg_tys) -- All thetas from the argument patterns and tau_i ~ t_i for all arguments
- return (res_ty, listToBag thetas `unionBags` arg_thetas)
-
-inferTyPmPats :: [PmPat Id] -> PmM ([Type], Bag EvVar)
-inferTyPmPats pats = do
- tys_cs <- mapM inferTyPmPat pats
- let (tys, cs) = unzip tys_cs
- return (tys, unionManyBags cs)
--}
-
checkTyPmPat :: PmPat Id -> Type -> PmM (Bag EvVar) -- check a type and a set of constraints
checkTyPmPat (PmGuardPat _) _ = panic "checkTyPmPat: PmGuardPat"
checkTyPmPat (PmVarPat {}) _ = return emptyBag
@@ -600,15 +559,12 @@ checkTyPmPat pat@(PmConPat con args) res_ty = do
| otherwise
-> ASSERT( res_tc == data_tc ) Just res_tc_tys
- pprInTcRnIf (text "checkTyPmPat con" <+> vcat [ ppr con, ppr univ_tvs, ppr dc_res_ty, ppr res_ty, ppr mb_tc_args ])
loc <- getSrcSpanDs
(subst, res_eq) <- case mb_tc_args of
Nothing -> -- The context type doesn't have a type constructor at the head.
-- so generate an equality. But this doesn't really work if there
-- are kind variables involved
- do when (any isKindVar univ_tvs)
- (pprInTcRnIf (text "checkTyPmPat: Danger! Kind variables" <+> ppr pat))
- (subst, _) <- genInstSkolTyVars loc univ_tvs
+ do (subst, _) <- genInstSkolTyVars loc univ_tvs
res_eq <- newEqPmM (substTy subst dc_res_ty) res_ty
return (subst, unitBag res_eq)
Just tys -> return (zipTopTvSubst univ_tvs tys, emptyBag)
@@ -637,26 +593,10 @@ genInstSkolTyVars loc tvs = genInstSkolTyVarsX loc emptyTvSubst tvs
wt :: [Type] -> OutVec -> PmM Bool
wt sig (_, vec)
| length sig == length vec = do
--- (tys, cs) <- inferTyPmPats vec
--- cs' <- zipWithM newEqPmM (map expandTypeSynonyms sig) tys -- The vector should match the signature type
cs <- checkTyPmPats vec sig
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 (ppr loc <+> ptext (sLit "vector:") <+> ppr vec)
--- pprInTcRnIf (ptext (sLit "with type:") <+> sep (punctuate comma (map pprTyWithKind ys)))
- let constraints = cs `unionBags` env_cs
- pprInTcRnIf (ptext (sLit "And constraints:")
- <+> vcat [ text "cs:" <+> ppr (mapBag varType cs)
- , text "env_cs:" <+> ppr (mapBag varType env_cs) ])
-
- is_sat <- isSatisfiable constraints
- pprInTcRnIf (ptext (sLit "Satisfiable:") <+> ppr is_sat)
- return is_sat
-
+ isSatisfiable (cs `unionBags` env_cs)
| otherwise = pprPanic "wt: length mismatch:" (ppr sig $$ ppr vec)
{-
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 3721f92..5b98482 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -962,10 +962,6 @@ 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
; return (not (isEmptyBag (inert_insols icans))) }
lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))
More information about the ghc-commits
mailing list