packages feed

lens-family-th 0.5.0.0 → 0.5.0.1

raw patch · 12 files changed

+547/−387 lines, 12 filesdep +hspecdep +lens-familydep +lens-family-thdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec, lens-family, lens-family-th

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

− Lens/Family/TH.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | Derive lenses for "Lens.Family".--- --- Example usage:--- --- --- > {-# LANGUAGE TemplateHaskell #-}--- > --- > import Lens.Family--- > import Lens.Family.TH--- > --- > data Foo a = Foo { _bar :: Int, _baz :: a }--- >            deriving (Show, Read, Eq, Ord)--- > $(makeLenses ''Foo)--- -module Lens.Family.TH (-    makeLenses-  , makeLensesBy-  , makeLensesFor--  , makeTraversals--  , mkLenses-  , mkLensesBy-  , mkLensesFor-  ) where--import Language.Haskell.TH-import Lens.Family.THCore----- | Derive lenses for the record selectors in --- a single-constructor data declaration,--- or for the record selector in a newtype declaration.--- Lenses will only be generated for record fields which--- are prefixed with an underscore.--- --- Example usage:--- --- > $(makeLenses ''Foo)-makeLenses :: Name -> Q [Dec]-makeLenses = makeLensesBy defaultNameTransform--{-# DEPRECATED mkLenses "Use makeLenses instead." #-}-mkLenses :: Name -> Q [Dec]-mkLenses = makeLenses----- | Derive lenses with the provided name transformation--- and filtering function. Produce @Just lensName@ to generate a lens--- of the resultant name, or @Nothing@ to not generate a lens--- for the input record name.--- --- Example usage:--- --- > $(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 = makeLensesBy----- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@.--- --- Example usage:--- --- > $(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 = makeLensesFor----- TODO-deriveLensSig :: Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]-deriveLensSig _ _ _ = return []
− Lens/Family/THCore.hs 
@@ -1,219 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}---- | The shared functionality behind Lens.Family.TH and Lens.Family2.TH.-module Lens.Family.THCore (-   defaultNameTransform-  , 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,--- then the underscore will simply be removed (and the new first character--- lowercased if necessary).-defaultNameTransform :: String -> Maybe String-defaultNameTransform ('_':c:rest) = Just $ toLower c : rest-defaultNameTransform _ = Nothing----- | Information about the larger type the lens will operate on.-type LensTypeInfo = (Name, [TyVarBndr])---- | Information about the smaller type the lens will operate on.-type ConstructorFieldInfo = (Name, Strict, Type)----- | The true workhorse of lens derivation. This macro is parameterized--- by a macro that derives signatures, as well as a function that--- filters and transforms names. Producing Nothing means that--- a lens should not be generated for the provided name.-deriveLenses ::-     (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])-     -- ^ the signature deriver-  -> (String -> Maybe String)-     -- ^ the name transformer-  -> 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."----- Derive a lens for the given record selector--- using the given name transformation function.-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  -- just to clarify what's here-  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]----- Given a record field name,--- produces a single function declaration:--- lensName f a = (\x -> a { field = x }) `fmap` f (field a)-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)]---- | Derive traversals for each constructor in--- a data or newtype declaration,--- Traversals will be named by prefixing the--- constructor name with an underscore.------ Example usage:------ > $(makeTraversals ''Foo)-makeTraversals :: Name -> Q [Dec]-makeTraversals = deriveTraversals (\s -> Just ('_':s))--deriveTraversals :: (String -> Maybe String) -> Name -> Q [Dec]-deriveTraversals nameTransform name = do-  typeInfo <- extractLensTypeInfo name-  constructors <- extractConstructorInfo name-  let derive1 = deriveTraversal nameTransform typeInfo constructors-  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    _ _ _ _ fs _) -> fs-    TyConI (NewtypeD _ _ _ _ f  _) -> [f]-    _ -> error $ "Can't derive traversal for: " ++ datatypeStr---deriveTraversal :: (String -> Maybe String) -> LensTypeInfo -> [Con] -> Con -> Q [Dec]-deriveTraversal nameTransform ty cs con = do-  let (tyName, _tyVars) = ty-      (conN, nArgs) = getConInfo con-  case nameTransform (nameBase conN) of-    Nothing       -> return []-    Just lensNameStr -> do-      let lensName = mkName lensNameStr-      sig  <- return [] -- TODO-      body <- deriveTraversalBody lensName conN nArgs cs-      return $ sig ++ [body]---deconstructReconstruct :: Con -> String -> (Pat, Exp)-deconstructReconstruct c nameBase = (pat, expr) where-  pat = ConP conN (map VarP argNames)-  expr = foldl AppE (ConE conN) (map VarE argNames)-  (conN, nArgs) = getConInfo c-  argNames = mkArgNames nArgs nameBase--getConInfo :: Con -> (Name, Int)-getConInfo con = case con of-  NormalC n tys -> (n, length tys)-  RecC n tys -> (n, length tys)-  InfixC t1 n t2 -> (n, 2)-  ForallC _ _ c-    -> error $ "Traversal derivation not supported: "-       ++ "forall'd constructor: " ++ nameBase (fst $ getConInfo c)--deriveTraversalBody :: Name -> Name -> Int -> [Con] -> Q Dec-deriveTraversalBody lensName constructorName nArgs cs =-  funD lensName (defLine:fallbacks) where-    argNames = mkArgNames nArgs "x"-    newArgNames = mkArgNames nArgs "x'"-    argTup = argTupFrom argNames-    newArgPat = TildeP $ argPatFrom newArgNames-    newArgVars = argVarsFrom newArgNames-    t = mkName "t"-    k = mkName "k"-    constructorUncurried =-      constructorUncurriedFrom constructorName newArgPat newArgVars-    kApplied = AppE (VarE k) argTup-    defLine = clause defPats (normalB defBody) []-    defPats = [varP k, conP constructorName (map varP argNames)]-    defBody = [| $(return constructorUncurried)-                 `fmap` $(return kApplied)-               |]-    fallbacks = map fallbackFor $ filter (\c -> fst (getConInfo c) /= constructorName) cs-    fallbackFor con = clause fallbackPats (normalB fallbackBody) [] where-      (conPat, conApp) = deconstructReconstruct con "a"-      fallbackPats = [wildP, pure conPat]-      fallbackBody = [| pure $(pure conApp) |]--constructorUncurriedFrom :: Name -> Pat -> [Exp] -> Exp-constructorUncurriedFrom conN pat = LamE [pat] . mkBody where-  mkBody = foldl AppE (ConE conN)--unitPat :: Pat-unitPat = TupP []--unitExp :: Exp-unitExp = TupE []--argPatFrom :: [Name] -> Pat-argPatFrom [] = unitPat-argPatFrom [x] = VarP x-argPatFrom xs = TupP (map VarP xs)--argTupFrom :: [Name] -> Exp-argTupFrom [] = unitExp-argTupFrom [x] = VarE x-argTupFrom xs = TupE (map VarE xs)--argVarsFrom :: [Name] -> [Exp]-argVarsFrom = map VarE--mkArgNames :: Int -> String -> [Name]-mkArgNames nArgs base = take nArgs . map toName $ [1 :: Int ..] where-  toName 1 = mkName base-  toName n = mkName (base ++ show n)
− Lens/Family2/TH.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE TemplateHaskell, Rank2Types #-}---- | Derive lenses for "Lens.Family2".--- --- Example usage:--- --- --- > {-# LANGUAGE TemplateHaskell, Rank2Types #-}--- > --- > import Lens.Family2--- > import Lens.Family2.TH--- > --- > data Foo a = Foo { _bar :: Int, _baz :: a }--- >            deriving (Show, Read, Eq, Ord)--- > $(makeLenses ''Foo)--- -module Lens.Family2.TH (-    makeLenses-  , makeLensesBy-  , makeLensesFor--  , makeTraversals--  , mkLenses-  , mkLensesBy-  , mkLensesFor-  ) where--import Language.Haskell.TH-import Lens.Family.THCore----- | Derive lenses for the record selectors in --- a single-constructor data declaration,--- or for the record selector in a newtype declaration.--- Lenses will only be generated for record fields which--- are prefixed with an underscore.--- --- Example usage:--- --- > $(makeLenses ''Foo)-makeLenses :: Name -> Q [Dec]-makeLenses = makeLensesBy defaultNameTransform--{-# DEPRECATED mkLenses "Use makeLenses instead." #-}-mkLenses :: Name -> Q [Dec]-mkLenses = makeLenses----- | Derive lenses with the provided name transformation--- and filtering function. Produce @Just lensName@ to generate a lens--- of the resultant name, or @Nothing@ to not generate a lens--- for the input record name.--- --- Example usage:--- --- > $(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 = makeLensesBy----- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@.--- --- Example usage:--- --- > $(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 = makeLensesFor----- TODO-deriveLensSig :: Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]-deriveLensSig _ _ _ = return []
+ README.md view
@@ -0,0 +1,58 @@+lens-family-th+==============++![build status](https://api.travis-ci.org/DanBurton/lens-family-th.svg?branch=master)++Template Haskell to generate lenses for lens-family and lens-family-core.++Usage:++    {-# LANGUAGE TemplateHaskell, Rank2Types #-}++    import Lens.Family2+    import Lens.Family2.TH++    data Foo a = Foo { _bar :: Int, _baz :: a }+             deriving (Show, Read, Eq, Ord)+    $(makeLenses ''Foo)++This will create lenses `bar` and `baz`.++You can instead create these lenses by hand+as explained by documentation at [Lens.Family.Unchecked](http://hackage.haskell.org/packages/archive/lens-family-core/latest/doc/html/Lens-Family-Unchecked.html).++`makeLenses` merely generates the following definition+for each field, making use of Haskell's record update syntax:++    lensName f a = (\x -> a { fieldName = x }) `fmap` f (fieldName a)++`makeLenses` will refuse to create lenses for data declarations+with more than 1 constructor.++----++For data types with multiple constructors,+you can use `makeTraversals`. For example:++    {-# LANGUAGE TemplateHaskell, Rank2Types #-}++    import Lens.Family2+    import Lens.Family2.TH++    data T a c d = A a | B | CD c d Int+    $(makeTraversals ''T)+    +Will create traversals `_A`, `_B`, and `_C` in this fashion:++    _A k (A a) = fmap (\a -> A a) (k a)+    _A _  B    = pure B+    _A _ (C c d i) = pure (C c d i)++    _B _ (A a) = pure (A a)+    _B k B = fmap (\() -> B) (k ())+    _B _ (C c d i) = pure (C c d i)+    +    _C _ (A a) = pure (A a)+    _C _ B = pure B+    _C k (C c d i) = fmap (\(c',d',i') -> C c' d' i') (k (c,d,i))+
+ examples/test.lhs view
@@ -0,0 +1,23 @@+To see the results of these ghci interactions on your own machine, run:++    [bash]+    BlogLiterately -g examples/test.lhs > test.html && firefox test.html++> {-# LANGUAGE TemplateHaskell #-}++> import Lens.Family2+> import Lens.Family2.TH++> data Pair a b = Pair { _pairL :: a, _pairR :: b }+>               deriving (Eq, Show, Read, Ord)+> $(makeLenses ''Pair)++    [ghci]+    let p = Pair '1' 1 :: Pair Char Int+    p ^. pairL+    p ^. pairR+    :m +Data.Char+    (pairL %~ digitToInt) p+    (pairR %~ intToDigit) p+    (pairL .~ "foo") p+    (pairR .~ "bar") p
+ examples/traversal-test.lhs view
@@ -0,0 +1,23 @@+To verify the results of these ghci interactions on your own machine, run:++    [bash]+    BlogLiterately -g examples/traversal-test.lhs > test.html && firefox test.html++(Make sure you have the lens-family package installed.)++> {-# LANGUAGE TemplateHaskell #-}++> import Lens.Family2+> import Lens.Family2.TH++> data Opt b c d = A | B b | CD c d Int+>                deriving (Eq, Show, Read, Ord)+> $(makeTraversals ''Opt)++    [ghci]+    _B %~ (+1) $ A+      A+    _B %~ (+1) $ B 3+      B 4+    _B %~ (+1) $ CD 3 4 5+      CD 3 4 5
lens-family-th.cabal view
@@ -1,5 +1,5 @@ name:                lens-family-th-version:             0.5.0.0+version:             0.5.0.1 synopsis:            Generate lens-family style lenses  description:@@ -14,21 +14,37 @@ license:             BSD3 license-file:        LICENSE author:              Dan Burton-copyright:           (c) Dan Burton 2012-2016+copyright:           (c) Dan Burton 2012-2017  homepage:            http://github.com/DanBurton/lens-family-th#readme bug-reports:         http://github.com/DanBurton/lens-family-th/issues maintainer:          danburton.email@gmail.com - category:            Data build-type:          Simple cabal-version:       >=1.8 +extra-source-files:  README.md+                   , stack.yaml+                   , examples/*.lhs+ library-  exposed-modules:     Lens.Family.TH, Lens.Family2.TH, Lens.Family.THCore-  build-depends:       base ==4.9.*, template-haskell == 2.11.*+  hs-source-dirs:    src+  exposed-modules:   Lens.Family.TH+                   , Lens.Family2.TH+                   , Lens.Family.THCore+  build-depends:     base >= 4.9 && < 4.11+                   , template-haskell >= 2.11 && < 2.13 +test-suite lens-family-th-test+  type:              exitcode-stdio-1.0+  hs-source-dirs:    test+  main-is:           Test.hs+  build-depends:     base+                   , hspec+                   , lens-family+                   , lens-family-th+                   , template-haskell  source-repository head   type:      git@@ -37,4 +53,4 @@ source-repository this   type:      git   location:  git://github.com/DanBurton/lens-family-th.git-  tag:       lens-family-th-0.5.0.0+  tag:       lens-family-th-0.5.0.1
+ src/Lens/Family/TH.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Derive lenses for "Lens.Family".+-- +-- Example usage:+-- +-- +-- > {-# LANGUAGE TemplateHaskell #-}+-- > +-- > import Lens.Family+-- > import Lens.Family.TH+-- > +-- > data Foo a = Foo { _bar :: Int, _baz :: a }+-- >            deriving (Show, Read, Eq, Ord)+-- > $(makeLenses ''Foo)+-- +module Lens.Family.TH (+    makeLenses+  , makeLensesBy+  , makeLensesFor++  , makeTraversals++  , mkLenses+  , mkLensesBy+  , mkLensesFor+  ) where++import Language.Haskell.TH+import Lens.Family.THCore+++-- | Derive lenses for the record selectors in +-- a single-constructor data declaration,+-- or for the record selector in a newtype declaration.+-- Lenses will only be generated for record fields which+-- are prefixed with an underscore.+-- +-- Example usage:+-- +-- > $(makeLenses ''Foo)+makeLenses :: Name -> Q [Dec]+makeLenses = makeLensesBy defaultNameTransform++{-# DEPRECATED mkLenses "Use makeLenses instead." #-}+mkLenses :: Name -> Q [Dec]+mkLenses = makeLenses+++-- | Derive lenses with the provided name transformation+-- and filtering function. Produce @Just lensName@ to generate a lens+-- of the resultant name, or @Nothing@ to not generate a lens+-- for the input record name.+-- +-- Example usage:+-- +-- > $(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 = makeLensesBy+++-- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@.+-- +-- Example usage:+-- +-- > $(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 = makeLensesFor+++-- TODO+deriveLensSig :: Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]+deriveLensSig _ _ _ = return []
+ src/Lens/Family/THCore.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE TemplateHaskell #-}++-- | The shared functionality behind Lens.Family.TH and Lens.Family2.TH.+module Lens.Family.THCore (+   defaultNameTransform+  , 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,+-- then the underscore will simply be removed (and the new first character+-- lowercased if necessary).+defaultNameTransform :: String -> Maybe String+defaultNameTransform ('_':c:rest) = Just $ toLower c : rest+defaultNameTransform _ = Nothing+++-- | Information about the larger type the lens will operate on.+type LensTypeInfo = (Name, [TyVarBndr])++-- | Information about the smaller type the lens will operate on.+type ConstructorFieldInfo = (Name, Strict, Type)+++-- | The true workhorse of lens derivation. This macro is parameterized+-- by a macro that derives signatures, as well as a function that+-- filters and transforms names. Producing Nothing means that+-- a lens should not be generated for the provided name.+deriveLenses ::+     (Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec])+     -- ^ the signature deriver+  -> (String -> Maybe String)+     -- ^ the name transformer+  -> 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."+++-- Derive a lens for the given record selector+-- using the given name transformation function.+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  -- just to clarify what's here+  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]+++-- Given a record field name,+-- produces a single function declaration:+-- lensName f a = (\x -> a { field = x }) `fmap` f (field a)+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)]++-- | Derive traversals for each constructor in+-- a data or newtype declaration,+-- Traversals will be named by prefixing the+-- constructor name with an underscore.+--+-- Example usage:+--+-- > $(makeTraversals ''Foo)+makeTraversals :: Name -> Q [Dec]+makeTraversals = deriveTraversals (\s -> Just ('_':s))++deriveTraversals :: (String -> Maybe String) -> Name -> Q [Dec]+deriveTraversals nameTransform name = do+  typeInfo <- extractLensTypeInfo name+  constructors <- extractConstructorInfo name+  let derive1 = deriveTraversal nameTransform typeInfo constructors+  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    _ _ _ _ fs _) -> fs+    TyConI (NewtypeD _ _ _ _ f  _) -> [f]+    _ -> error $ "Can't derive traversal for: " ++ datatypeStr+++deriveTraversal :: (String -> Maybe String) -> LensTypeInfo -> [Con] -> Con -> Q [Dec]+deriveTraversal nameTransform ty cs con = do+  let (tyName, _tyVars) = ty+      (conN, nArgs) = getConInfo con+  case nameTransform (nameBase conN) of+    Nothing       -> return []+    Just lensNameStr -> do+      let lensName = mkName lensNameStr+      sig  <- return [] -- TODO+      body <- deriveTraversalBody lensName conN nArgs cs+      return $ sig ++ [body]+++deconstructReconstruct :: Con -> String -> (Pat, Exp)+deconstructReconstruct c nameBase = (pat, expr) where+  pat = ConP conN (map VarP argNames)+  expr = foldl AppE (ConE conN) (map VarE argNames)+  (conN, nArgs) = getConInfo c+  argNames = mkArgNames nArgs nameBase++getConInfo :: Con -> (Name, Int)+getConInfo con = case con of+  NormalC n tys -> (n, length tys)+  RecC n tys -> (n, length tys)+  InfixC t1 n t2 -> (n, 2)+  ForallC _ _ c+    -> error $ "Traversal derivation not supported: "+       ++ "forall'd constructor: " ++ nameBase (fst $ getConInfo c)++deriveTraversalBody :: Name -> Name -> Int -> [Con] -> Q Dec+deriveTraversalBody lensName constructorName nArgs cs =+  funD lensName (defLine:fallbacks) where+    argNames = mkArgNames nArgs "x"+    newArgNames = mkArgNames nArgs "x'"+    argTup = argTupFrom argNames+    newArgPat = TildeP $ argPatFrom newArgNames+    newArgVars = argVarsFrom newArgNames+    t = mkName "t"+    k = mkName "k"+    constructorUncurried =+      constructorUncurriedFrom constructorName newArgPat newArgVars+    kApplied = AppE (VarE k) argTup+    defLine = clause defPats (normalB defBody) []+    defPats = [varP k, conP constructorName (map varP argNames)]+    defBody = [| $(return constructorUncurried)+                 `fmap` $(return kApplied)+               |]+    fallbacks = map fallbackFor $ filter (\c -> fst (getConInfo c) /= constructorName) cs+    fallbackFor con = clause fallbackPats (normalB fallbackBody) [] where+      (conPat, conApp) = deconstructReconstruct con "a"+      fallbackPats = [wildP, pure conPat]+      fallbackBody = [| pure $(pure conApp) |]++constructorUncurriedFrom :: Name -> Pat -> [Exp] -> Exp+constructorUncurriedFrom conN pat = LamE [pat] . mkBody where+  mkBody = foldl AppE (ConE conN)++unitPat :: Pat+unitPat = TupP []++unitExp :: Exp+unitExp = TupE []++argPatFrom :: [Name] -> Pat+argPatFrom [] = unitPat+argPatFrom [x] = VarP x+argPatFrom xs = TupP (map VarP xs)++argTupFrom :: [Name] -> Exp+argTupFrom [] = unitExp+argTupFrom [x] = VarE x+argTupFrom xs = TupE (map VarE xs)++argVarsFrom :: [Name] -> [Exp]+argVarsFrom = map VarE++mkArgNames :: Int -> String -> [Name]+mkArgNames nArgs base = take nArgs . map toName $ [1 :: Int ..] where+  toName 1 = mkName base+  toName n = mkName (base ++ show n)
+ src/Lens/Family2/TH.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TemplateHaskell, Rank2Types #-}++-- | Derive lenses for "Lens.Family2".+-- +-- Example usage:+-- +-- +-- > {-# LANGUAGE TemplateHaskell, Rank2Types #-}+-- > +-- > import Lens.Family2+-- > import Lens.Family2.TH+-- > +-- > data Foo a = Foo { _bar :: Int, _baz :: a }+-- >            deriving (Show, Read, Eq, Ord)+-- > $(makeLenses ''Foo)+-- +module Lens.Family2.TH (+    makeLenses+  , makeLensesBy+  , makeLensesFor++  , makeTraversals++  , mkLenses+  , mkLensesBy+  , mkLensesFor+  ) where++import Language.Haskell.TH+import Lens.Family.THCore+++-- | Derive lenses for the record selectors in +-- a single-constructor data declaration,+-- or for the record selector in a newtype declaration.+-- Lenses will only be generated for record fields which+-- are prefixed with an underscore.+-- +-- Example usage:+-- +-- > $(makeLenses ''Foo)+makeLenses :: Name -> Q [Dec]+makeLenses = makeLensesBy defaultNameTransform++{-# DEPRECATED mkLenses "Use makeLenses instead." #-}+mkLenses :: Name -> Q [Dec]+mkLenses = makeLenses+++-- | Derive lenses with the provided name transformation+-- and filtering function. Produce @Just lensName@ to generate a lens+-- of the resultant name, or @Nothing@ to not generate a lens+-- for the input record name.+-- +-- Example usage:+-- +-- > $(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 = makeLensesBy+++-- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@.+-- +-- Example usage:+-- +-- > $(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 = makeLensesFor+++-- TODO+deriveLensSig :: Name -> LensTypeInfo -> ConstructorFieldInfo -> Q [Dec]+deriveLensSig _ _ _ = return []
+ stack.yaml view
@@ -0,0 +1,4 @@+# http://docs.haskellstack.org/en/stable/yaml_configuration/+resolver: nightly-2017-07-31+packages:+- '.'
+ test/Test.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}++import qualified Data.Char as Char+import Lens.Family2 ((^.), (%~), (.~))+import qualified Lens.Family2.TH as LFTH++import Test.Hspec (hspec, describe, it, shouldBe)++data Pair a b = Pair { _pairL :: a, _pairR :: b }+              deriving (Eq, Show, Read, Ord)+$(LFTH.makeLenses ''Pair)++data Opt b c d = A | B b | CD c d Int+               deriving (Eq, Show, Read, Ord)+$(LFTH.makeTraversals ''Opt)++type OptInts = Opt Int Int Int++p :: Pair Char Int+p = Pair '1' 1++main = hspec $ do+  describe "makeLenses" $ do+    it "makes lenses that function with lens-family operators" $ do+      (p ^. pairL) `shouldBe` '1'+      (p ^. pairR) `shouldBe` (1 :: Int)+      ((pairL %~ Char.digitToInt) p) `shouldBe` (Pair 1 1 :: Pair Int Int)+      ((pairR %~ Char.intToDigit) p) `shouldBe` Pair '1' '1'+      ((pairL .~ "foo") p) `shouldBe` Pair "foo" (1 :: Int)+      ((pairR .~ "bar") p) `shouldBe` Pair '1' "bar"+  describe "makeTraversals" $ do+    it "makes traversals that function with lens-family operators" $ do+      (_B %~ (+ (1 :: Int)) $ (A :: OptInts)) `shouldBe` (A :: OptInts)+      (_B %~ (+ (1 :: Int)) $ (B 3 :: OptInts)) `shouldBe` (B 4 :: OptInts)+      (_B %~ (+ (1 :: Int)) $ (CD 3 4 5 :: OptInts))+        `shouldBe`  (CD 3 4 5 :: OptInts)