lens-family-th 0.2.0.1 → 0.3.0.0
raw patch · 4 files changed
+122/−21 lines, 4 files
Files
- Lens/Family/TH.hs +26/−9
- Lens/Family/THCore.hs +67/−0
- Lens/Family2/TH.hs +26/−9
- lens-family-th.cabal +3/−3
Lens/Family/TH.hs view
@@ -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 []-
Lens/Family/THCore.hs view
@@ -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) |]
Lens/Family2/TH.hs view
@@ -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 []-
lens-family-th.cabal view
@@ -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