Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-kinds
http://hackage.haskell.org/trac/ghc/changeset/1832ea0411d303001b9bbb863e60871c3e9e2d8c >--------------------------------------------------------------- commit 1832ea0411d303001b9bbb863e60871c3e9e2d8c Author: Julien Cretin <g...@ia0.eu> Date: Tue Aug 30 14:25:53 2011 +0200 fix kind intantiation in coercions (core lint) >--------------------------------------------------------------- compiler/coreSyn/CoreLint.lhs | 20 ++++++++++++++++---- compiler/types/Coercion.lhs | 2 +- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 0bd3675..a1c3340 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -619,7 +619,7 @@ lintKind kind@(TyConApp tc kis) -- T k1 .. kn | not (getUnique tc `elem` (funTyConKey : kindKeys)) = let tc_kind = tyConKind tc in case isPromotableKind tc_kind of - Just n | n == length kis -> return () + Just n | n == length kis -> mapM_ lintKind kis _ -> addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))) lintKind kind = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))) @@ -636,9 +636,21 @@ lintCoercion (Refl ty) ; return (ty', ty') } lintCoercion co@(TyConAppCo tc cos) - = do { (ss,ts) <- mapAndUnzipM lintCoercion cos - ; check_co_app co (tyConKind tc) ss - ; return (mkTyConApp tc ss, mkTyConApp tc ts) } + = do { let ki = tyConKind tc + (kvs, _) = splitForAllTys ki + (cokis, cotys) = splitAt (length kvs) cos + -- we need to verify that kind instantiations are Refl + ; kis <- mapM lintKindCoercion cokis + ; (ss,ts) <- mapAndUnzipM lintCoercion cotys + ; check_co_app co ki (kis ++ ss) + ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) } + where + lintKindCoercion :: Coercion -> LintM Kind + lintKindCoercion (Refl k) = do + k' <- applySubstTy k + lintKind k' + return k' + lintKindCoercion _ = panic "lintCoercion lintKindCoercion" lintCoercion co@(AppCo co1 co2) = do { (s1,t1) <- lintCoercion co1 diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 621168f..d4ab60c 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -912,7 +912,7 @@ ty_co_subst subst ty -- A type variable from a non-cloned forall -- won't be in the substitution go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2) - go (TyConApp tc tys) = mkTyConAppCo tc (map go tys) + go (TyConApp tc tys) = mkTyConAppCo tc (map go tys) -- IA0: tys contains kind instantiations which should not be lifted go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2) go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) where _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
