module Type.Spine.TH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
liftNameG :: Name -> Q Exp
liftNameG n = do
TyConI (DataD _ (Name occ (NameG _ pkg mod)) _ _ _) <- reify n
[| mkNameG_tc $(stringE $ pkgString pkg) $(stringE $ modString mod) $(stringE $ occString occ) |]
tyConSignature :: Name -> Q ([Kind], Kind)
tyConSignature n = do
let bad = fail "Type.Spine.TH.tyConSignature expects the name of a data/newtype/data family"
i <- reify n
case i of
TyConI dec -> case dec of
DataD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarK)
NewtypeD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarK)
FamilyD DataFam _ tvbs mk -> return (map tvb_kind tvbs, maybe StarK (peel tvbs) mk)
where peel [] k = k
peel (_ : l) (ArrowK _ r) = peel l r
peel _ _ = error "Type.Spine.TH: bad FamilyD kind"
_ -> bad
PrimTyConI _ i _ -> return (replicate i StarK, StarK)
_ -> bad
tvb_kind :: TyVarBndr -> Kind
tvb_kind (PlainTV _) = StarK
tvb_kind (KindedTV _ k) = k