Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/f8aac1d94e42ceff5f8c2ccf46f80f47f7107d74 >--------------------------------------------------------------- commit f8aac1d94e42ceff5f8c2ccf46f80f47f7107d74 Author: Jose Pedro Magalhaes <[email protected]> Date: Fri Nov 11 11:03:48 2011 +0000 Better kind error messages from TcCanonical >--------------------------------------------------------------- compiler/typecheck/TcCanonical.lhs | 31 +++++++++++++++++++++---------- compiler/typecheck/TcSMonad.lhs | 6 ++++-- 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 8cec0b5..dac7d88 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -475,14 +475,13 @@ canEq fl eqv ty1 (TyConApp fn tys) = do { untch <- getUntouchables ; canEqLeaf untch fl eqv (classify ty1) (FunCls fn tys) } -canEq fl eqv ty1@(TyConApp tc1 tys1) ty2@(TyConApp tc2 tys2) +canEq fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 , tc1 == tc2 , length tys1 == length tys2 = -- Generate equalities for each of the corresponding arguments - do { let (kis1, tys1') = span isKind tys1 - (kis2, tys2') = span isKind tys2 - ; zipWithM_ (unifyKindTcS ty1 ty2) kis1 kis2 + do { let (kis1, tys1') = span isKind tys1 + (_kis2, tys2') = span isKind tys2 ; let kicos = map mkReflCo kis1 ; argeqvs <- if isWanted fl then @@ -780,8 +779,14 @@ canEqLeafOriented :: CtFlavor -> EqVar canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2 -- cv : F tys1 = ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) ) do { are_compat <- compatKindTcS k1 k2 -- make sure that the kind are compatible - ; unless are_compat (unifyKindTcS (unClassify cls1) s2 k1 k2) - ; (xis1,cos1,ccs1) <- flattenMany fl tys1 -- Flatten type function arguments + ; can_unify <- if not are_compat + then unifyKindTcS (unClassify cls1) s2 k1 k2 + else return False + -- If the kinds cannot be unified or are not compatible, don't fail + -- right away; instead, emit a frozen error + ; if (not are_compat && not can_unify) then canEqFailure fl eqv else + do { + (xis1,cos1,ccs1) <- flattenMany fl tys1 -- Flatten type function arguments -- cos1 :: xis1 ~ tys1 ; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS -- co2 :: xi2 ~ s2 @@ -810,7 +815,7 @@ canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2 -- cv : F tys1 , cc_fun = fn , cc_tyargs = xis1 , cc_rhs = xi2 } - ; return $ ccs `extendCCans` final_cc } + ; return $ ccs `extendCCans` final_cc } } where k1 = typeKind (unClassify cls1) k2 = typeKind s2 @@ -828,8 +833,14 @@ canEqLeafTyVarLeft :: CtFlavor -> EqVar -> TcTyVar -> TcType -> TcS CanonicalCts -- Establish invariants of CTyEqCans canEqLeafTyVarLeft fl eqv tv s2 -- cv : tv ~ s2 = do { are_compat <- compatKindTcS k1 k2 - ; unless are_compat (unifyKindTcS (mkTyVarTy tv) s2 k1 k2) - ; (xi2, co, ccs2) <- flatten fl s2 -- Flatten RHS co : xi2 ~ s2 + ; can_unify <- if not are_compat + then unifyKindTcS (mkTyVarTy tv) s2 k1 k2 + else return False + -- If the kinds cannot be unified or are not compatible, don't fail + -- right away; instead, emit a frozen error + ; if (not are_compat && not can_unify) then canEqFailure fl eqv else + do { + (xi2, co, ccs2) <- flatten fl s2 -- Flatten RHS co : xi2 ~ s2 ; mxi2' <- canOccursCheck fl tv xi2 -- Do an occurs check, and return a possibly -- unfolded version of the RHS, if we had to -- unfold any type synonyms to get rid of tv. @@ -849,7 +860,7 @@ canEqLeafTyVarLeft fl eqv tv s2 -- cv : tv ~ s2 ; return $ ccs2 `extendCCans` CTyEqCan { cc_id = eqv_new , cc_flavor = fl , cc_tyvar = tv - , cc_rhs = xi2' } } } } + , cc_rhs = xi2' } } } } } where k1 = tyVarKind tv k2 = typeKind s2 diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 3114ba4..553d461 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -214,9 +214,11 @@ isSubKindTcS k1 k2 = wrapTcS (TcM.isSubKindTcM k1 k2) unifyKindTcS :: Type -> Type -- Context -> Kind -> Kind -- Corresponding kinds - -> TcS () + -> TcS Bool unifyKindTcS ty1 ty2 ki1 ki2 - = wrapTcS (TcM.addErrCtxtM ctxt (TcM.unifyKindEq ki1 ki2)) + = wrapTcS $ TcM.addErrCtxtM ctxt $ do + (_errs, mb_r) <- TcM.tryTc (TcM.unifyKindEq ki1 ki2) + return (maybe False (const True) mb_r) where ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2 deCanonicalise :: CanonicalCt -> FlavoredEvVar _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
