Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/e328942561be162dd5f42b4ef630249ed34f1ef9 >--------------------------------------------------------------- commit e328942561be162dd5f42b4ef630249ed34f1ef9 Author: Jose Pedro Magalhaes <[email protected]> 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 7c37fc0..ed8b1c4 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 @@ -1188,29 +1189,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 @@ -1245,7 +1247,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 @@ -1254,7 +1257,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 @@ -1307,24 +1311,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 @@ -1338,11 +1341,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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
