module Control.Lens.Overload where
import Language.Haskell.TH
import Language.Haskell.TH.Lens
import Data.Proxy
import Control.Lens
import GHC.TypeLits
class Has (s :: Symbol) a where
type Field s a :: *
theField :: Proxy s -> Lens' a (Field s a)
declareHas :: DecsQ -> DecsQ
declareHas decs = declareLenses decs >>= \r -> case r of
(d@(DataD _ dName _ _ _):sfs) -> return $ d : pairs (gen dName) sfs
where
pairs f (x:y:_:zs) = f x y : pairs f zs
pairs _ [] = []
gen dName (SigD n (ForallT _ _ (AppT _ t))) (FunD _ cs) = InstanceD []
(ConT ''Has `AppT` LitT (StrTyLit $ nameBase n) `AppT` ConT dName) [
TySynInstD ''Field $ TySynEqn [LitT (StrTyLit $ nameBase n), ConT dName] t
, FunD 'theField $ map (clausePattern %~ (WildP:)) cs
, PragmaD $ InlineP 'theField Inline FunLike AllPhases
]
makeField :: String -> DecsQ
makeField s = do
let tvA = mkName "a"
return [SigD (mkName s) $ ForallT [PlainTV tvA] [ClassP ''Has [LitT (StrTyLit s), VarT tvA]]
$ ConT ''Lens' `AppT` VarT tvA `AppT` (ConT ''Field `AppT` LitT (StrTyLit s) `AppT` VarT tvA)
, ValD (VarP $ mkName s)
(NormalB $ VarE 'theField `AppE` (ConE 'Proxy `SigE` (ConT ''Proxy `AppT` LitT (StrTyLit s)))) []]