module Lens.Family.THCore (
defaultNameTransform
, LensTypeInfo
, ConstructorFieldInfo
, deriveLenses
) where
import Language.Haskell.TH
import Data.Char (toLower)
defaultNameTransform :: String -> Maybe String
defaultNameTransform ('_':c:rest) = Just $ toLower c : rest
defaultNameTransform _ = Nothing
type LensTypeInfo = (Name, [TyVarBndr])
type ConstructorFieldInfo = (Name, Strict, Type)
deriveLenses ::
(Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])
-> (String -> Maybe String)
-> Name -> Q [Dec]
deriveLenses sigDeriver nameTransform datatype = do
typeInfo <- extractLensTypeInfo datatype
let derive1 = deriveLens sigDeriver nameTransform typeInfo
constructorFields <- extractConstructorFields datatype
concat `fmap` mapM derive1 constructorFields
extractLensTypeInfo :: Name -> Q LensTypeInfo
extractLensTypeInfo datatype = do
let datatypeStr = nameBase datatype
i <- reify datatype
return $ case i of
TyConI (DataD _ n ts _ _) -> (n, ts)
TyConI (NewtypeD _ n ts _ _) -> (n, ts)
_ -> error $ "Can't derive Lens for: " ++ datatypeStr
++ ", type name required."
extractConstructorFields :: Name -> Q [ConstructorFieldInfo]
extractConstructorFields datatype = do
let datatypeStr = nameBase datatype
i <- reify datatype
return $ case i of
TyConI (DataD _ _ _ [RecC _ fs] _) -> fs
TyConI (NewtypeD _ _ _ (RecC _ fs) _) -> fs
TyConI (DataD _ _ _ [_] _) ->
error $ "Can't derive Lens without record selectors: " ++ datatypeStr
TyConI NewtypeD{} ->
error $ "Can't derive Lens without record selectors: " ++ datatypeStr
TyConI TySynD{} ->
error $ "Can't derive Lens for type synonym: " ++ datatypeStr
TyConI DataD{} ->
error $ "Can't derive Lens for tagged union: " ++ datatypeStr
_ ->
error $ "Can't derive Lens for: " ++ datatypeStr
++ ", type name required."
deriveLens :: (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])
-> (String -> Maybe String)
-> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]
deriveLens sigDeriver nameTransform ty field = do
let (fieldName, _fieldStrict, _fieldType) = field
(_tyName, _tyVars) = ty
case nameTransform (nameBase fieldName) of
Nothing -> return []
Just lensNameStr -> do
let lensName = mkName lensNameStr
sig <- sigDeriver lensName ty field
body <- deriveLensBody lensName fieldName
return $ sig ++ [body]
deriveLensBody :: Name -> Name -> Q Dec
deriveLensBody lensName fieldName = funD lensName [defLine]
where
a = mkName "a"
f = mkName "f"
defLine = clause pats (normalB body) []
pats = [varP f, varP a]
body = [| (\x -> $(record a fieldName [|x|]))
`fmap` $(appE (varE f) (appE (varE fieldName) (varE a)))
|]
record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)]