diff --git a/Lens/Family/TH.hs b/Lens/Family/TH.hs --- a/Lens/Family/TH.hs +++ b/Lens/Family/TH.hs @@ -12,10 +12,16 @@ -- > -- > data Foo a = Foo { _bar :: Int, _baz :: a } -- > deriving (Show, Read, Eq, Ord) --- > $(mkLenses ''Foo) +-- > $(makeLenses ''Foo) -- module Lens.Family.TH ( - mkLenses + makeLenses + , makeLensesBy + , makeLensesFor + + , makeTraversals + + , mkLenses , mkLensesBy , mkLensesFor ) where @@ -32,9 +38,13 @@ -- -- Example usage: -- --- $(mkLenses ''Foo) +-- $(makeLenses ''Foo) +makeLenses :: Name -> Q [Dec] +makeLenses = makeLensesBy defaultNameTransform + +{-# DEPRECATED mkLenses "Use makeLenses instead." #-} mkLenses :: Name -> Q [Dec] -mkLenses = mkLensesBy defaultNameTransform +mkLenses = makeLenses -- | Derive lenses with the provided name transformation @@ -44,21 +54,28 @@ -- -- Example usage: -- --- > $(mkLensesBy (\n -> Just (n ++ "L")) ''Foo) +-- > $(makeLensesBy (\n -> Just (n ++ "L")) ''Foo) +makeLensesBy :: (String -> Maybe String) -> Name -> Q [Dec] +makeLensesBy = deriveLenses deriveLensSig + +{-# DEPRECATED mkLensesBy "Use makeLensesBy instead." #-} mkLensesBy :: (String -> Maybe String) -> Name -> Q [Dec] -mkLensesBy = deriveLenses deriveLensSig +mkLensesBy = makeLensesBy -- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@. -- -- Example usage: -- --- > $(mkLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo) +-- > $(makeLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo) +makeLensesFor :: [(String, String)] -> Name -> Q [Dec] +makeLensesFor fields = makeLensesBy (`lookup` fields) + +{-# DEPRECATED mkLensesFor "Use makeLensesFor instead." #-} mkLensesFor :: [(String, String)] -> Name -> Q [Dec] -mkLensesFor fields = mkLensesBy (`lookup` fields) +mkLensesFor = makeLensesFor -- TODO deriveLensSig :: Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec] deriveLensSig _ _ _ = return [] - diff --git a/Lens/Family/THCore.hs b/Lens/Family/THCore.hs --- a/Lens/Family/THCore.hs +++ b/Lens/Family/THCore.hs @@ -6,9 +6,11 @@ , LensTypeInfo , ConstructorFieldInfo , deriveLenses + , makeTraversals ) where import Language.Haskell.TH +import Control.Applicative (pure) import Data.Char (toLower) -- | By default, if the field name begins with an underscore, @@ -105,4 +107,69 @@ `fmap` $(appE (varE f) (appE (varE fieldName) (varE a))) |] record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)] + +makeTraversals :: Name -> Q [Dec] +makeTraversals = deriveTraversals (\s -> Just ('_':s)) + +deriveTraversals :: (String -> Maybe String) -> Name -> Q [Dec] +deriveTraversals nameTransform name = do + typeInfo <- extractLensTypeInfo name + let derive1 = deriveTraversal nameTransform typeInfo + constructors <- extractConstructorInfo name + concat `fmap` mapM derive1 constructors + + +extractConstructorInfo :: Name -> Q [Con] +extractConstructorInfo datatype = do + let datatypeStr = nameBase datatype + i <- reify datatype + return $ case i of + TyConI (DataD _ _ _ [] _) + -> error $ "Traversal derivation not yet supported: " + ++ "empty constructor in: " ++ datatypeStr + TyConI (DataD _ _ _ fs _) -> fs + TyConI (NewtypeD _ _ _ f _) -> [f] + _ -> error $ "Can't derive traversal for: " ++ datatypeStr + + +deriveTraversal :: (String -> Maybe String) -> LensTypeInfo -> Con -> Q [Dec] +deriveTraversal nameTransform ty con = do + let (tyName, _tyVars) = ty -- just to clarify what's here + (cName, cTys) = case con of + NormalC n tys -> (n, tys) + RecC n tys -> (n, map (\(_n, s, t) -> (s, t)) tys) + InfixC _ n _ + -> error $ "Traversal derivation not yet supported: " + ++ "infix constructor: " ++ nameBase n + ForallC _ _ _ + -> error $ "Traversal derivation not supported: " + ++ "forall'd constructor in: " ++ nameBase tyName + cTy <- case cTys of + [t] -> return t + -- TODO: this should be pretty easy to implement + _ -> error $ "Traversal derivation not yet supported: " + ++ "product constructor: " ++ nameBase cName + case nameTransform (nameBase cName) of + Nothing -> return [] + Just lensNameStr -> do + let lensName = mkName lensNameStr + sig <- return [] -- TODO + body <- deriveTraversalBody lensName cName + return $ sig ++ [body] + + +deriveTraversalBody :: Name -> Name -> Q Dec +deriveTraversalBody lensName constructorName = + funD lensName [defLine, fallback] where + x = mkName "x" + t = mkName "t" + k = mkName "k" + defLine = clause defPats (normalB defBody) [] + defPats = [varP k, conP constructorName [varP x]] + defBody = [| $(conE constructorName) + `fmap` $(appE (varE k) (varE x)) + |] + fallback = clause fallbackPats (normalB fallbackBody) [] + fallbackPats = [wildP, varP t] + fallbackBody = [| pure $(varE t) |] diff --git a/Lens/Family2/TH.hs b/Lens/Family2/TH.hs --- a/Lens/Family2/TH.hs +++ b/Lens/Family2/TH.hs @@ -12,10 +12,16 @@ -- > -- > data Foo a = Foo { _bar :: Int, _baz :: a } -- > deriving (Show, Read, Eq, Ord) --- > $(mkLenses ''Foo) +-- > $(makeLenses ''Foo) -- module Lens.Family2.TH ( - mkLenses + makeLenses + , makeLensesBy + , makeLensesFor + + , makeTraversals + + , mkLenses , mkLensesBy , mkLensesFor ) where @@ -32,9 +38,13 @@ -- -- Example usage: -- --- $(mkLenses ''Foo) +-- $(makeLenses ''Foo) +makeLenses :: Name -> Q [Dec] +makeLenses = makeLensesBy defaultNameTransform + +{-# DEPRECATED mkLenses "Use makeLenses instead." #-} mkLenses :: Name -> Q [Dec] -mkLenses = mkLensesBy defaultNameTransform +mkLenses = makeLenses -- | Derive lenses with the provided name transformation @@ -44,21 +54,28 @@ -- -- Example usage: -- --- > $(mkLensesBy (\n -> Just (n ++ "L")) ''Foo) +-- > $(makeLensesBy (\n -> Just (n ++ "L")) ''Foo) +makeLensesBy :: (String -> Maybe String) -> Name -> Q [Dec] +makeLensesBy = deriveLenses deriveLensSig + +{-# DEPRECATED mkLensesBy "Use makeLensesBy instead." #-} mkLensesBy :: (String -> Maybe String) -> Name -> Q [Dec] -mkLensesBy = deriveLenses deriveLensSig +mkLensesBy = makeLensesBy -- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@. -- -- Example usage: -- --- > $(mkLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo) +-- > $(makeLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo) +makeLensesFor :: [(String, String)] -> Name -> Q [Dec] +makeLensesFor fields = makeLensesBy (`lookup` fields) + +{-# DEPRECATED mkLensesFor "Use makeLensesFor instead." #-} mkLensesFor :: [(String, String)] -> Name -> Q [Dec] -mkLensesFor fields = mkLensesBy (`lookup` fields) +mkLensesFor = makeLensesFor -- TODO deriveLensSig :: Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec] deriveLensSig _ _ _ = return [] - diff --git a/lens-family-th.cabal b/lens-family-th.cabal --- a/lens-family-th.cabal +++ b/lens-family-th.cabal @@ -1,5 +1,5 @@ name: lens-family-th -version: 0.2.0.1 +version: 0.3.0.0 synopsis: Generate lens-family style lenses description: @@ -14,7 +14,7 @@ license: BSD3 license-file: LICENSE author: Dan Burton -copyright: (c) Dan Burton 2012-2013 +copyright: (c) Dan Burton 2012-2014 homepage: http://github.com/DanBurton/lens-family-th#readme bug-reports: http://github.com/DanBurton/lens-family-th/issues @@ -37,4 +37,4 @@ source-repository this type: git location: git://github.com/DanBurton/lens-family-th.git - tag: lens-family-th-0.2.0.1 + tag: lens-family-th-0.3.0.0