Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.6
http://hackage.haskell.org/trac/ghc/changeset/c4aa0165bb8eb4b65d8c1299fdff279e1f97bbb4 >--------------------------------------------------------------- commit c4aa0165bb8eb4b65d8c1299fdff279e1f97bbb4 Author: Simon Peyton Jones <[email protected]> Date: Mon Sep 10 13:13:24 2012 +0100 Two fixes to kind unification * Don't unify a kind signature-variable with non-tyvar kind * Don't allow a kind variable to appear in a type (Trac #7224) >--------------------------------------------------------------- compiler/typecheck/TcHsType.lhs | 9 +++++++-- compiler/typecheck/TcUnify.lhs | 20 ++++++++++++++------ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index dac7d15..d18e1bd 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -570,7 +570,12 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon ; thing <- tcLookup name ; traceTc "lk2" (ppr name <+> ppr thing) ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + ATyVar _ tv + | isKindVar tv + -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr tv) + <+> ptext (sLit "used as a type")) + | otherwise + -> return (mkTyVarTy tv, tyVarKind tv) AThing kind -> do { tc <- get_loopy_tc name ; inst_tycon (mkNakedTyConApp tc) kind } @@ -1350,7 +1355,7 @@ tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) -- The main worker tc_hs_kind :: HsKind Name -> TcM Kind -tc_hs_kind k@(HsTyVar _) = tc_kind_app k [] +tc_hs_kind (HsTyVar tc) = tc_kind_var_app tc [] tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k [] tc_hs_kind (HsParTy ki) = tc_lhs_kind ki diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 29f46f6..6f92ccb 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -1162,17 +1162,20 @@ uUnboundKVar kv1 k2@(TyVarTy kv2) uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 - ; kindOccurCheck kv1 k2' ; let k2'' = defaultKind k2' -- MetaKindVars must be bound only to simple kinds + ; kindUnifCheck kv1 k2'' ; writeMetaTyVar kv1 k2'' } ---------------- -kindOccurCheck :: TyVar -> Type -> TcM () -kindOccurCheck kv1 k2 -- k2 is zonked - = if elemVarSet kv1 (tyVarsOfType k2) - then failWithTc (kindOccurCheckErr kv1 k2) - else return () +kindUnifCheck :: TyVar -> Type -> TcM () +kindUnifCheck kv1 k2 -- k2 is zonked + | elemVarSet kv1 (tyVarsOfType k2) + = failWithTc (kindOccurCheckErr kv1 k2) + | isSigTyVar kv1 + = failWithTc (kindSigVarErr kv1 k2) + | otherwise + = return () mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 @@ -1204,4 +1207,9 @@ kindOccurCheckErr :: Var -> Type -> SDoc kindOccurCheckErr tyvar ty = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:")) 2 (sep [ppr tyvar, char '=', ppr ty]) + +kindSigVarErr :: Var -> Type -> SDoc +kindSigVarErr tv ty + = hang (ptext (sLit "Cannot unify the kind variable") <+> quotes (ppr tv)) + 2 (ptext (sLit "with the kind") <+> quotes (ppr ty)) \end{code} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
