From 19c346326289b3c935ab973bd969cd33702cb832 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 14 Jul 2000 13:38:55 +0000
Subject: [PATCH] [project @ 2000-07-14 13:38:55 by simonpj] Fix typeKind
---
ghc/compiler/types/Type.lhs | 11 +++++++----
1 file changed, 7 insertions(+), 4 deletions(-)
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 109c8e4e5448..f20ef3d48f37 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -782,13 +782,16 @@ typeKind (AppTy fun arg) = funResultTy (typeKind fun)
typeKind (FunTy arg res) = fix_up (typeKind res)
where
- fix_up kind = case splitTyConApp_maybe kind of
- Just (tycon, [_]) | tycon == typeCon -> boxedTypeKind
- other -> kind
+ fix_up (TyConApp tycon _) | tycon == typeCon
+ || tycon == openKindCon = boxedTypeKind
+ fix_up (NoteTy _ kind) = fix_up kind
+ fix_up kind = kind
-- The basic story is
-- typeKind (FunTy arg res) = typeKind res
-- But a function is boxed regardless of its result type
- -- Hencd the strange fix-up
+ -- Hence the strange fix-up.
+ -- Note that 'res', being the result of a FunTy, can't have
+ -- a strange kind like (*->*).
typeKind (ForAllTy tv ty) = typeKind ty
\end{code}
--
GitLab