Ian, can you please merge to 7.4? Thanks, Pedro
2011/12/16 José Pedro Magalhães <[email protected]> > 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 >
_______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
