[commit: ghc] master: More debug info for failures in typeKind and kindFunResult (02437a1)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/02437a144ea16116d60f045a2a56664aed7505e8/ghc

>---------------------------------------------------------------

commit 02437a144ea16116d60f045a2a56664aed7505e8
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri May 23 07:48:40 2014 +0100

    More debug info for failures in typeKind and kindFunResult


>---------------------------------------------------------------

02437a144ea16116d60f045a2a56664aed7505e8
 compiler/types/Kind.lhs | 25 ++++++++++++++++---------
 compiler/types/Type.lhs | 45 +++++++++++++++++++++++++--------------------
 2 files changed, 41 insertions(+), 29 deletions(-)

diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index 61239bc..b82556e 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -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,
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 7ddd45a..e65a1c7 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -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 =