Commit 0fe0c58e authored by Richard Eisenberg's avatar Richard Eisenberg Committed by Simon Peyton Jones

Applied lunaris's patch to allow promoted types and rich kinds in Template Haskell

parent b002f1b0
This diff is collapsed.
This diff is collapsed.
......@@ -48,7 +48,7 @@ module TysWiredIn (
wordTyCon, wordDataCon, wordTyConName, wordTy,
-- * List
listTyCon, nilDataCon, consDataCon,
listTyCon, nilDataCon, consDataCon, consDataConName,
listTyCon_RDR, consDataCon_RDR, listTyConName,
mkListTy, mkPromotedListTy,
......
......@@ -1353,10 +1353,27 @@ reifyKind ki
= do { let (kis, ki') = splitKindFunTys ki
; ki'_rep <- reifyNonArrowKind ki'
; kis_rep <- mapM reifyKind kis
; return (foldr TH.ArrowK ki'_rep kis_rep) }
; return (foldr (TH.AppT . TH.AppT TH.ArrowT) ki'_rep kis_rep) }
where
reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarK
| otherwise = noTH (sLit "this kind") (ppr k)
reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT
| isConstraintKind k = return TH.ConstraintT
reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v))
reifyNonArrowKind (ForAllTy _ k) = reifyKind k
reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis
reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1
; k2' <- reifyKind k2
; return (TH.AppT k1' k2')
}
reifyNonArrowKind k = noTH (sLit "this kind") (ppr k)
reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind
reify_kc_app kc kis
= fmap (foldl TH.AppT r_kc) (mapM reifyKind kis)
where
r_kc | isPromotedTyCon kc &&
isTupleTyCon (promotedTyCon kc) = TH.TupleT (tyConArity kc)
| kc `hasKey` listTyConKey = TH.ListT
| otherwise = TH.ConT (reifyName kc)
reifyCxt :: [PredType] -> TcM [TH.Pred]
reifyCxt = mapM reifyPred
......@@ -1371,7 +1388,7 @@ reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
= panic "TcSplice.reifyFamFlavour: not a type family"
reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
reifyTyVars = mapM reifyTyVar
reifyTyVars = mapM reifyTyVar . filter isTypeVar
where
reifyTyVar tv | isLiftedTypeKind kind = return (TH.PlainTV name)
| otherwise = do kind' <- reifyKind kind
......@@ -1382,12 +1399,25 @@ reifyTyVars = mapM reifyTyVar
reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
reify_tc_app tc tys
= do { tys' <- reifyTypes tys
= do { tys' <- reifyTypes (removeKinds (tyConKind tc) tys)
; return (foldl TH.AppT r_tc tys') }
where
r_tc | isTupleTyCon tc = TH.TupleT (tyConArity tc)
| tc `hasKey` listTyConKey = TH.ListT
| otherwise = TH.ConT (reifyName tc)
arity = tyConArity tc
r_tc | isTupleTyCon tc = if isPromotedDataCon tc
then TH.PromotedTupleT arity
else TH.TupleT arity
| tc `hasKey` listTyConKey = TH.ListT
| tc `hasKey` nilDataConKey = TH.PromotedNilT
| tc `hasKey` consDataConKey = TH.PromotedConsT
| otherwise = TH.ConT (reifyName tc)
removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type]
removeKinds (FunTy k1 k2) (h:t)
| isSuperKind k1 = removeKinds k2 t
| otherwise = h : removeKinds k2 t
removeKinds (ForAllTy v k) (h:t)
| isSuperKind (varType v) = removeKinds k t
| otherwise = h : removeKinds k t
removeKinds _ tys = tys
reifyPred :: TypeRep.PredType -> TcM TH.Pred
reifyPred ty = case classifyPredType ty of
......
......@@ -71,6 +71,7 @@ module TyCon(
algTyConRhs,
newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
tupleTyConBoxity, tupleTyConSort, tupleTyConArity,
promotedDataCon, promotedTyCon,
-- ** Manipulating TyCons
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
......@@ -1201,6 +1202,16 @@ isPromotedTyCon :: TyCon -> Bool
isPromotedTyCon (PromotedTyCon {}) = True
isPromotedTyCon _ = False
-- | Retrieves the promoted DataCon if this is a PromotedDataTyCon;
-- Panics otherwise
promotedDataCon :: TyCon -> DataCon
promotedDataCon = dataCon
-- | Retrieves the promoted TypeCon if this is a PromotedTypeTyCon;
-- Panics otherwise
promotedTyCon :: TyCon -> TyCon
promotedTyCon = ty_con
-- | Identifies implicit tycons that, in particular, do not go into interface
-- files (because they are implicitly reconstructed when the interface is
-- read).
......
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