module Data.StarToStar.Iso.TH (me, tvar, decl_fix, decl_fix_kinds) where
import Language.Haskell.TH (varT)
import Language.Haskell.TH.Syntax
compose x y = InfixE (Just x) (VarE (mkName ".")) (Just y)
tvar = varT . mkName
me = tvar "me"
unTVB (PlainTV n) = VarT n
unTVB (KindedTV n k) = SigT (VarT n) k
unTVB_ (PlainTV n) = VarT n
unTVB_ (KindedTV n k) = VarT n
fix_module_name = mkName "Data.StarToStar"
fix_name = mkName (show fix_module_name ++ ".Fix")
iso_name = mkName (show fix_module_name ++ ".Iso.Iso")
decl_fix :: String -> [String] -> Q Type -> Q [Dec]
decl_fix n tvars = decl_fix_kinds n (map (PlainTV . mkName) tvars)
decl_fix_kinds :: String -> [TyVarBndr] -> Q Type -> Q [Dec]
decl_fix_kinds s tyvarbndrs inner_type = do
inner_type <- inner_type
let n = mkName s
unN = mkName ("un" ++ s)
this_type = foldl AppT (ConT n) (map unTVB tyvarbndrs)
this_type_ = foldl AppT (ConT n) (map unTVB_ tyvarbndrs)
tvbs = tyvarbndrs ++ [KindedTV (mkName "me") (StarK `ArrowK` StarK)]
syn_name = mkName (s ++ "_inner")
instance_type = ConT fix_name `AppT` this_type
instance_type_ = ConT fix_name `AppT` this_type_
return $
[let hole = mkName "a"
in NewtypeD [] n (tvbs ++ [PlainTV hole]) (NormalC n [(NotStrict, inner_type `AppT` VarT hole)]) [],
TySynD syn_name tvbs inner_type,
let x = mkName "x"
in FunD unN [Clause [ConP n [VarP x]] (NormalB (VarE x)) []],
InstanceD [] (ConT iso_name `AppT` instance_type)
[TySynInstD (mkName "Other") [instance_type_]
(foldl AppT (ConT syn_name) (map unTVB_ tyvarbndrs ++ [instance_type_])),
ValD (VarP (mkName "from")) (NormalB (compose (VarE unN) (VarE (mkName "fromFix")))) [],
ValD (VarP (mkName "to")) (NormalB (compose (VarE (mkName "toFix")) (ConE n))) []]]