Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/a3513618340df1f24b42ca39e95c7bf8e74f340f >--------------------------------------------------------------- commit a3513618340df1f24b42ca39e95c7bf8e74f340f Author: Simon Peyton Jones <simo...@microsoft.com> Date: Fri Oct 19 01:06:41 2012 +0100 Comments and debug tracing only >--------------------------------------------------------------- compiler/coreSyn/CoreLint.lhs | 3 ++- compiler/typecheck/Inst.lhs | 26 ++++++++++++++------------ compiler/typecheck/TcCanonical.lhs | 2 +- compiler/types/Kind.lhs | 2 +- 4 files changed, 18 insertions(+), 15 deletions(-) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 250efdd..afd7e05 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -886,7 +886,8 @@ lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) -- Using subst_l is ok, because subst_l and subst_r -- must agree on kind equalities - ; unless (k `isSubKind` ktv_kind) (bad_ax (ptext (sLit "check_ki2"))) + ; unless (k `isSubKind` ktv_kind) + (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) ; return (Type.extendTvSubst subst_l ktv t1, Type.extendTvSubst subst_r ktv t2) } \end{code} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index dac8fd1..04ea870 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -212,19 +212,21 @@ instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper -- Instantiates the TcTheta, puts all constraints thereby generated -- into the LIE, and returns a HsWrapper to enclose the call site. -instCallConstraints _ [] = return idHsWrapper - -instCallConstraints origin (pred : preds) - | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut - = do { traceTc "instCallConstraints" $ ppr (mkEqPred ty1 ty2) - ; co <- unifyType ty1 ty2 - ; co_fn <- instCallConstraints origin preds - ; return (co_fn <.> WpEvApp (EvCoercion co)) } - +instCallConstraints orig preds + | null preds + = return idHsWrapper | otherwise - = do { ev_var <- emitWanted origin pred - ; co_fn <- instCallConstraints origin preds - ; return (co_fn <.> WpEvApp (EvId ev_var)) } + = do { traceTc "instCallConstraints" (pprTheta preds) + ; evs <- mapM go preds + ; return (mkWpEvApps evs) } + where + go pred + | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut + = do { co <- unifyType ty1 ty2 + ; return (EvCoercion co) } + | otherwise + = do { ev_var <- emitWanted orig pred + ; return (EvId ev_var) } ---------------- instStupidTheta :: CtOrigin -> TcThetaType -> TcM () diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 4a8813d..3309e12 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1110,7 +1110,7 @@ canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 ; (xi2, co2) <- flatten loc FMFullFlatten flav ty2 -- Fancy higher-dimensional coercion between equalities! - -- SPJ asks why? Why not just co : F xis1 ~ F tys1? + -- SPJ asks why? Why not just co : F xis1 ~ F tys1? ; let fam_head = mkTyConApp fn xis1 xco = mkHdEqPred ty2 (mkTcTyConAppCo fn cos1) co2 -- xco :: (F xis1 ~ xi2) ~ (F tys1 ~ ty2) diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 7318891..50d382f 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -167,7 +167,7 @@ okArrowResultKind _ = False -- Subkinding -- The tc variants are used during type-checking, where we don't want the -- Constraint kind to be a subkind of anything --- After type-checking (in core), Constraint is a subkind of argTypeKind +-- After type-checking (in core), Constraint is a subkind of openTypeKind isSubOpenTypeKind :: Kind -> Bool -- ^ True of any sub-kind of OpenTypeKind isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
