[commit: ghc] ghc-7.4: Better failure with promoted kinds in TH (6e78b3b)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.4

http://hackage.haskell.org/trac/ghc/changeset/6e78b3bad832466c1277a914324a7880c6d5a41e

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

commit 6e78b3bad832466c1277a914324a7880c6d5a41e
Author: Jose Pedro Magalhaes <jpm at cs.uu.nl>
Date:   Fri Dec 16 12:46:16 2011 +0000

    Better failure with promoted kinds in TH
    
    Makes #5612 fail in a more civilized way, at least.

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

 compiler/typecheck/TcSplice.lhs |   48 +++++++++++++++++++++-----------------
 1 files changed, 26 insertions(+), 22 deletions(-)

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 491e24d..37fa817 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -32,6 +32,7 @@ import TcHsSyn
 import TcSimplify
 import TcUnify
 import Type
+import Kind
 import TcType
 import TcEnv
 import TcMType
@@ -1189,29 +1190,30 @@ reifyTyCon tc
   = do { let flavour = reifyFamFlavour tc
              tvs     = tyConTyVars tc
              kind    = tyConKind tc
-             kind'
-               | isLiftedTypeKind kind = Nothing
-               | otherwise             = Just $ reifyKind kind
+       ; kind' <- if isLiftedTypeKind kind then return Nothing
+                  else fmap Just (reifyKind kind)
 
        ; fam_envs <- tcGetFamInstEnvs
        ; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc)
+       ; tvs' <- reifyTyVars tvs
        ; return (TH.FamilyI
-                    (TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+                    (TH.FamilyD flavour (reifyName tc) tvs' kind')
                     instances) }
 
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc
        ; rhs' <- reifyType rhs
+       ; tvs' <- reifyTyVars tvs
        ; return (TH.TyConI
-                   (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs'))
+                   (TH.TySynD (reifyName tc) tvs' rhs'))
        }
 
   | otherwise
   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
         ; let tvs = tyConTyVars tc
         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
+        ; r_tvs <- reifyTyVars tvs
         ; let name = reifyName tc
-              r_tvs  = reifyTyVars tvs
               deriv = []        -- Don't know about deriving
               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
                    | otherwise     = TH.DataD    cxt name r_tvs cons        deriv
@@ -1246,7 +1248,8 @@ reifyDataCon tys dc
              return main_con
          else do
          { cxt <- reifyCxt theta'
-         ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
+         ; ex_tvs'' <- reifyTyVars ex_tvs'
+         ; return (TH.ForallC ex_tvs'' cxt main_con) } }
 
 ------------------------------
 reifyClass :: Class -> TcM TH.Info
@@ -1255,7 +1258,8 @@ reifyClass cls
         ; inst_envs <- tcGetInstEnvs
         ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
         ; ops <- mapM reify_op op_stuff
-        ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
+        ; tvs' <- reifyTyVars tvs
+        ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
         ; return (TH.ClassI dec insts ) }
   where
     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
@@ -1308,24 +1312,23 @@ reify_for_all :: TypeRep.Type -> TcM TH.Type
 reify_for_all ty
   = do { cxt' <- reifyCxt cxt;
        ; tau' <- reifyType tau
-       ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
+       ; tvs' <- reifyTyVars tvs
+       ; return (TH.ForallT tvs' cxt' tau') }
   where
     (tvs, cxt, tau) = tcSplitSigmaTy ty
 
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
 
-reifyKind :: Kind -> TH.Kind
+reifyKind :: Kind -> TcM TH.Kind
 reifyKind  ki
-  = let (kis, ki') = splitKindFunTys ki
-        kis_rep    = map reifyKind kis
-        ki'_rep    = reifyNonArrowKind ki'
-    in
-    foldr TH.ArrowK ki'_rep kis_rep
+  = do { let (kis, ki') = splitKindFunTys ki
+       ; ki'_rep <- reifyNonArrowKind ki'
+       ; kis_rep <- mapM reifyKind kis
+       ; return (foldr TH.ArrowK ki'_rep kis_rep) }
   where
-    reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
-                        | otherwise          = pprPanic "Exotic form of kind"
-                                                        (ppr k)
+    reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarK 
+                        | otherwise          = noTH (sLit "this kind") (ppr k)
 
 reifyCxt :: [PredType] -> TcM [TH.Pred]
 reifyCxt   = mapM reifyPred
@@ -1339,11 +1342,12 @@ reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
                    | otherwise
                    = panic "TcSplice.reifyFamFlavour: not a type family"
 
-reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
-reifyTyVars = map reifyTyVar
+reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
+reifyTyVars = mapM reifyTyVar
   where
-    reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
-                  | otherwise             = TH.KindedTV name (reifyKind kind)
+    reifyTyVar tv | isLiftedTypeKind kind = return (TH.PlainTV  name)
+                  | otherwise             = do kind' <- reifyKind kind
+                                               return (TH.KindedTV name kind')
       where
         kind = tyVarKind tv
         name = reifyName tv