Commit 02437a14 authored by Simon Peyton Jones's avatar Simon Peyton Jones

More debug info for failures in typeKind and kindFunResult

parent d41aa765
......@@ -63,6 +63,7 @@ import PrelNames
import Outputable
import Maybes( orElse )
import Util
import FastString
\end{code}
%************************************************************************
......@@ -97,14 +98,19 @@ during type inference. Hence cmpTc treats them as equal.
\begin{code}
-- | Essentially 'funResultTy' on kinds handling pi-types too
kindFunResult :: Kind -> KindOrType -> Kind
kindFunResult (FunTy _ res) _ = res
kindFunResult (ForAllTy kv res) arg = substKiWith [kv] [arg] res
kindFunResult k _ = pprPanic "kindFunResult" (ppr k)
kindAppResult :: Kind -> [Type] -> Kind
kindAppResult k [] = k
kindAppResult k (a:as) = kindAppResult (kindFunResult k a) as
kindFunResult :: SDoc -> Kind -> KindOrType -> Kind
kindFunResult _ (FunTy _ res) _ = res
kindFunResult _ (ForAllTy kv res) arg = substKiWith [kv] [arg] res
#ifdef DEBUG
kindFunResult doc k _ = pprPanic "kindFunResult" (ppr k $$ doc)
#else
-- Without DEUBG, doc becomes an unsed arg, and will be optimised away
kindFunResult _ _ _ = panic "kindFunResult"
#endif
kindAppResult :: SDoc -> Kind -> [Type] -> Kind
kindAppResult _ k [] = k
kindAppResult doc k (a:as) = kindAppResult doc (kindFunResult doc k a) as
-- | Essentially 'splitFunTys' on kinds
splitKindFunTys :: Kind -> ([Kind],Kind)
......@@ -128,7 +134,8 @@ splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
-- Actually this function works fine on data types too,
-- but they'd always return '*', so we never need to ask
synTyConResKind :: TyCon -> Kind
synTyConResKind tycon = kindAppResult (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon))
synTyConResKind tycon = kindAppResult (ptext (sLit "synTyConResKind") <+> ppr tycon)
(tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon))
-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
isOpenTypeKind, isUnliftedTypeKind,
......
......@@ -1636,26 +1636,31 @@ type SimpleKind = Kind
\begin{code}
typeKind :: Type -> Kind
typeKind (TyConApp tc tys)
| isPromotedTyCon tc
= ASSERT( tyConArity tc == length tys ) superKind
| otherwise
= kindAppResult (tyConKind tc) tys
typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg]
typeKind (LitTy l) = typeLiteralKind l
typeKind (ForAllTy _ ty) = typeKind ty
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind _ty@(FunTy _arg res)
-- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
-- not unliftedTypKind (#)
-- The only things that can be after a function arrow are
-- (a) types (of kind openTypeKind or its sub-kinds)
-- (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
| isSuperKind k = k
| otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind
where
k = typeKind res
typeKind orig_ty = go orig_ty
where
go ty@(TyConApp tc tys)
| isPromotedTyCon tc
= ASSERT( tyConArity tc == length tys ) superKind
| otherwise
= kindAppResult (ptext (sLit "typeKind 1") <+> ppr ty $$ ppr orig_ty)
(tyConKind tc) tys
go ty@(AppTy fun arg) = kindAppResult (ptext (sLit "typeKind 2") <+> ppr ty $$ ppr orig_ty)
(go fun) [arg]
go (LitTy l) = typeLiteralKind l
go (ForAllTy _ ty) = go ty
go (TyVarTy tyvar) = tyVarKind tyvar
go _ty@(FunTy _arg res)
-- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
-- not unliftedTypKind (#)
-- The only things that can be after a function arrow are
-- (a) types (of kind openTypeKind or its sub-kinds)
-- (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
| isSuperKind k = k
| otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind
where
k = go res
typeLiteralKind :: TyLit -> Kind
typeLiteralKind l =
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment