#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
#endif
module Control.Lens.TH
(
makeLenses
, makeLensesBy
, makeLensesFor
) where
import Data.Char (toLower)
import Control.Applicative
import Language.Haskell.TH
makeLenses :: Name -> Q [Dec]
makeLenses = makeLensesBy defaultNameTransform
makeLensesFor :: [(String, String)] -> Name -> Q [Dec]
makeLensesFor fields = makeLensesBy (`Prelude.lookup` fields)
makeLensesBy ::
(String -> Maybe String)
-> Name -> Q [Dec]
makeLensesBy nameTransform datatype = do
typeInfo <- extractLensTypeInfo datatype
let derive1 = deriveLens nameTransform typeInfo
constructorFields <- extractConstructorFields datatype
Prelude.concat <$> Prelude.mapM derive1 constructorFields
defaultNameTransform :: String -> Maybe String
defaultNameTransform ('_':c:rest) = Just $ toLower c : rest
defaultNameTransform _ = Nothing
type LensTypeInfo = (Name, [TyVarBndr])
type ConstructorFieldInfo = (Name, Strict, Type)
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 :: (String -> Maybe String)
-> LensTypeInfo
-> ConstructorFieldInfo
-> Q [Dec]
deriveLens nameTransform ty field = case nameTransform (nameBase fieldName) of
Nothing -> return []
Just lensNameStr -> do
body <- deriveLensBody (mkName lensNameStr) fieldName
return [body]
where
(fieldName, _fieldStrict, _fieldType) = field
(_tyName, _tyVars) = ty
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)]