module Composite.TH where
import Composite.Record (Record, rlens)
import Control.Lens (_1, _head, each, over, toListOf)
import Data.Char (toLower)
import Data.Monoid ((<>))
import Data.Proxy (Proxy(Proxy))
import Data.Vinyl.Lens (RElem)
import Data.Vinyl.TypeLevel (RIndex)
import Language.Haskell.TH (Q, Body(NormalB), Dec(SigD, ValD), Exp(VarE), Name, Pat(VarP), Type(AppT, ConT), TyVarBndr, mkName, nameBase)
import Language.Haskell.TH.Lens (_TySynD)
withProxies :: Q [Dec] -> Q [Dec]
withProxies qDecs = do
decs <- qDecs
proxyDecs <- traverse proxyDecForName (toListOf (each . _TySynD . _1) decs)
pure $ decs <> concat proxyDecs
where
proxyDecForName tySynName = do
let tySynType = pure $ ConT tySynName
proxyName = mkName . over _head toLower . nameBase $ tySynName
proxyType <- [t|Proxy $tySynType|]
proxyVal <- [|Proxy|]
pure
[ SigD proxyName proxyType
, ValD (VarP proxyName) (NormalB proxyVal) []
]
withLensesAndProxies :: Q [Dec] -> Q [Dec]
withLensesAndProxies qDecs = do
decs <- qDecs
proxyDecs <- traverse proxyDecForName $ toListOf (each . _TySynD . _1) decs
lensDecs <- traverse lensDecForName $ toListOf (each . _TySynD) decs
pure $ decs <> concat proxyDecs <> concat lensDecs
where
proxyNameForTypeName = mkName . (++ "_") . over _head toLower . nameBase
proxyDecForName :: Name -> Q [Dec]
proxyDecForName tySynName = do
let tySynType = pure $ ConT tySynName
proxyName = proxyNameForTypeName tySynName
proxyType <- [t|Proxy $tySynType|]
proxyVal <- [|Proxy|]
pure
[ SigD proxyName proxyType
, ValD (VarP proxyName) (NormalB proxyVal) []
]
lensDecForName :: (Name, [TyVarBndr], Type) -> Q [Dec]
lensDecForName (tySynName, _, AppT (AppT (ConT (nameBase -> ":->")) _) valTy) = do
let tySynType = pure $ ConT tySynName
proxyName = proxyNameForTypeName tySynName
proxyVal = VarE proxyName
lensName = mkName . over _head toLower . nameBase $ tySynName
lensType <- [t|forall f rs. (Functor f, RElem $tySynType rs (RIndex $tySynType rs)) => ($(pure valTy) -> f $(pure valTy)) -> Record rs -> f (Record rs)|]
rlensVal <- [|rlens $(pure proxyVal)|]
pure
[ SigD lensName lensType
, ValD (VarP lensName) (NormalB rlensVal) [] ]
lensDecForName (tySynName, _, _) =
fail $ "Can only make lenses and proxies for type synonyms like type FField = \"field\" :-> Type, but " <> nameBase tySynName <> " has some other form of type"