Commit e3289425 authored by dreixel's avatar dreixel
Browse files

Better failure with promoted kinds in TH

Makes #5612 fail in a more civilized way, at least.
parent e8c93ad1
......@@ -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
......
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