module Type.Spine.TH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
toNameG :: Name -> Q Name
toNameG n = do
info <- reify n
let err = error "liftNameG expects a top-level named thing"
onDec dec = case dec of
FunD n _ -> n
ValD (VarP n) _ _ -> n
ValD (AsP n _) _ _ -> n
ValD {} -> err
DataD _ n _ _ _ -> n
NewtypeD _ n _ _ _ -> n
TySynD n _ _ -> n
ClassD _ n _ _ _ -> n
InstanceD {} -> err
SigD n _ -> n
ForeignD (ImportF _ _ _ n _) -> n
ForeignD (ExportF _ _ n _) -> n
InfixD _ n -> n
PragmaD {} -> err
FamilyD _ n _ _ -> n
DataInstD {} -> err
NewtypeInstD {} -> err
TySynInstD {} -> err
return $ case info of
ClassI dec _ -> onDec dec
ClassOpI n _ _ _ -> n
TyConI dec -> onDec dec
FamilyI dec _ -> onDec dec
PrimTyConI n _ _ -> n
DataConI n _ _ _ -> n
VarI {} -> err
TyVarI {} -> err
liftNameG_d :: Name -> Q Exp
liftNameG_d n = do
Name occ (NameG _ pkg mod) <- toNameG n
[| mkNameG_d $(stringE $ pkgString pkg) $(stringE $ modString mod) $(stringE $ occString occ) |]
tyConSignature :: Name -> Q ([Kind], Kind)
tyConSignature n = do
i <- reify n
let bad = fail $ "Type.Spine.TH.tyConSignature expects the name of a data/newtype/data family; got " ++ show i
case i of
DataConI _ tys n _ -> return (getArgTypes tys, PromotedT n)
where
getArgTypes (ForallT _ _ ty) = loop ty
getArgTypes ty = loop ty
loop (AppT (AppT ArrowT x) y) = promote x : loop y
where promote (VarT n) = VarT n
promote (ConT n)
| n == '[] = PromotedNilT
| n == '(:) = PromotedConsT
| otherwise = PromotedT n
promote (AppT ty1 ty2) = AppT (promote ty1) (promote ty2)
promote (TupleT i) = PromotedTupleT i
promote ty =
error $ "type-spine:tyConSignature: cannot promote " ++ show ty
loop _ = []
TyConI dec -> case dec of
DataD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarT)
NewtypeD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarT)
_ -> bad
FamilyI (FamilyD DataFam _ tvbs mk) _ -> return (map tvb_kind tvbs, maybe StarT (peel tvbs) mk)
where peel [] k = k
peel (_ : l) (AppT (AppT ArrowT _) r) = peel l r
peel _ _ = error "Type.Spine.TH: bad FamilyD kind"
PrimTyConI _ i _ -> return (replicate i StarT, StarT)
_ -> bad
tvb_kind :: TyVarBndr -> Kind
tvb_kind (PlainTV _) = StarT
tvb_kind (KindedTV _ k) = k