module Control.Lens.TH.SharedFields
( generateField
, generateFields ) where
import Data.Char
import Language.Haskell.TH
generateField :: String -> Q [Dec]
generateField = return . return . make
generateFields :: [String] -> Q [Dec]
generateFields = return . map make
make :: String -> Dec
make name =
ClassD
[]
(mkName $ "Has" ++ name)
[PlainTV s, PlainTV a]
[FunDep [s] [a]]
[SigD (mkName $ functionName name) methodType]
where
s = mkName "s"
a = mkName "a"
f = mkName "f"
vs = VarT s
va = VarT a
vf = VarT f
methodType =
ForallT
[PlainTV f]
[AppT (ConT ''Functor) vf]
((va `arrow` AppT vf va) `arrow` (vs `arrow` AppT vf vs))
arrow :: Type -> Type -> Type
arrow x y = AppT (AppT ArrowT x) y
functionName :: String -> String
functionName (x:xs) = toLower x : xs
functionName _ = error "invalid class name"