Commit 5479f1a0 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Template Haskell: support for kind annotations

parent f7ecb11b
This diff is collapsed.
......@@ -143,8 +143,8 @@ cvtTop (ClassD ctxt cl tvs fds decs)
-- no docs in TH ^^
}
where
isFamilyD (FamilyD _ _ _) = True
isFamilyD _ = False
isFamilyD (FamilyD _ _ _ _) = True
isFamilyD _ = False
cvtTop (InstanceD ctxt ty decs)
= do { let (ats, bind_sig_decs) = partition isFamInstD decs
......@@ -173,10 +173,10 @@ cvtTop (PragmaD prag)
; returnL $ Hs.SigD prag'
}
cvtTop (FamilyD flav tc tvs)
cvtTop (FamilyD flav tc tvs kind)
= do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' Nothing)
-- FIXME: kinds
; let kind' = fmap cvtKind kind
; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind')
}
where
cvtFamFlavour TypeFam = TypeFamily
......@@ -207,7 +207,7 @@ unTyClD :: LHsDecl a -> LTyClDecl a
unTyClD (L l (TyClD d)) = L l d
unTyClD _ = panic "Convert.unTyClD: internal error"
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name]
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
-> CvtM ( LHsContext RdrName
, Located RdrName
, [LHsTyVarBndr RdrName]
......@@ -235,7 +235,7 @@ cvt_tyinst_hdr cxt tc tys
where
collect (ForallT _ _ _)
= failWith $ text "Forall type not allowed as type parameter"
collect (VarT tv) = return [tv]
collect (VarT tv) = return [PlainTV tv]
collect (ConT _) = return []
collect (TupleT _) = return []
collect ArrowT = return []
......@@ -245,6 +245,8 @@ cvt_tyinst_hdr cxt tc tys
; tvs2 <- collect t2
; return $ tvs1 ++ tvs2
}
collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
collect (SigT ty _) = collect ty
---------------------------------------------------
-- Data types
......@@ -643,11 +645,18 @@ cvtPatFld (s,p)
-----------------------------------------------------------
-- Types and type variables
cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
cvtTvs tvs = mapM cvt_tv tvs
cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName)
cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tName nm
; returnL $ UserTyVar nm'
}
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; returnL $ KindedTyVar nm' (cvtKind ki)
}
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
......@@ -674,27 +683,42 @@ cvtPredTy ty
text (TH.pprint ty)) }
cvtType :: TH.Type -> CvtM (LHsType RdrName)
cvtType ty = do { (head_ty, tys') <- split_ty_app ty
; case head_ty of
TupleT n | length tys' == n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy Boxed tys')
| n == 1 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
| otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
| otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
ListT | [x'] <- tys' -> returnL (HsListTy x')
| otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
; cxt' <- cvtContext cxt
; ty' <- cvtType ty
; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
_ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
}
cvtType ty
= do { (head_ty, tys') <- split_ty_app ty
; case head_ty of
TupleT n
| length tys' == n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy Boxed tys')
| n == 1
-> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
| otherwise
-> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
ArrowT
| [x',y'] <- tys' -> returnL (HsFunTy x' y')
| otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
ListT
| [x'] <- tys' -> returnL (HsListTy x')
| otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
ForallT tvs cxt ty
| null tys'
-> do { tvs' <- cvtTvs tvs
; cxt' <- cvtContext cxt
; ty' <- cvtType ty
; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
}
SigT ty ki
-> do { ty' <- cvtType ty
; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
}
_ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
}
where
mk_apps head_ty [] = returnL head_ty
mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
......@@ -706,6 +730,10 @@ split_ty_app ty = go ty []
go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
go f as = return (f,as)
cvtKind :: TH.Kind -> Type.Kind
cvtKind StarK = liftedTypeKind
cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
-----------------------------------------------------------
......
......@@ -35,7 +35,6 @@ import Id
import TcRnMonad
import PrelNames
import Type
import TcType
import TcMType
import TysPrim
......
......@@ -911,9 +911,13 @@ reifyTyCon tc
| isOpenTyCon tc
= let flavour = reifyFamFlavour tc
tvs = tyConTyVars tc
kind = tyConKind tc
kind'
| isLiftedTypeKind kind = Nothing
| otherwise = Just $ reifyKind kind
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs))
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
......@@ -982,6 +986,18 @@ reifyType (PredTy {}) = panic "reifyType PredTy"
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
reifyKind :: Kind -> TH.Kind
reifyKind ki
= let (kis, ki') = splitKindFunTys ki
kis_rep = map reifyKind kis
ki'_rep = reifyNonArrowKind ki'
in
foldl TH.ArrowK ki'_rep kis_rep
where
reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
| otherwise = pprPanic "Exotic form of kind"
(ppr k)
reifyCxt :: [PredType] -> TcM [TH.Pred]
reifyCxt = mapM reifyPred
......@@ -994,8 +1010,14 @@ reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
| otherwise
= panic "TcSplice.reifyFamFlavour: not a type family"
reifyTyVars :: [TyVar] -> [TH.Name]
reifyTyVars = map reifyName
reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
reifyTyVars = map reifyTyVar
where
reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
| otherwise = TH.KindedTV name (reifyKind kind)
where
kind = tyVarKind tv
name = reifyName tv
reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
reify_tc_app tc tys = do { tys' <- reifyTypes tys
......
......@@ -98,7 +98,7 @@ module TcType (
unliftedTypeKind, liftedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
isSubArgTypeKind, isSubKind, defaultKind,
isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
kindVarRef, mkKindVar,
Type, PredType(..), ThetaType,
......
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