packages feed

lens 2.5 → 2.6

raw patch · 30 files changed

+745/−424 lines, 30 files

Files

.travis.yml view
@@ -1,15 +1,16 @@ language: haskell-# Use this before_install section when hackage is down. before_install:-  - mkdir -p ~/.cabal-  - cp config ~/.cabal/config-  - cabal update+  # Uncomment the next 3 lines whenever hackage is down.+  #  - mkdir -p ~/.cabal+  #  - cp config ~/.cabal/config+  #  - cabal update   - cabal install --only-dependencies --enable-tests --enable-benchmarks install:+  # we have to configure rather than install to get benchmarks   - cabal configure --enable-tests --enable-benchmarks   - cabal build script:-  - cabal test+  - cabal test --show-details=always   - cabal bench notifications:   irc: "irc.freenode.org#haskell-lens"
.vim.custom view
@@ -1,4 +1,5 @@ " Add the following to your .vimrc to automatically load this on startup+ " if filereadable(".vim.custom") "     so .vim.custom " endif@@ -10,12 +11,21 @@   call cursor(myline, mycolumn) endfunction +" enable syntax highlighting syntax on++" search for the tags file anywhere between here and / set tags=TAGS;/++" highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list +" f2 runs hasktags map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR> +" strip trailing whitespace before saving au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
CHANGELOG.markdown view
@@ -1,3 +1,13 @@+2.6+---+* Added build option `-f-inlining` to facilitate building with the various TH 2.8 versions used by GHC 7.6 and HEAD.+* Added build option `-f-template-haskell` for testing without template haskell. (Users should be able to assume TH is enabled; use this only for testing!)+* Added support for generating a `Traversal` rather than a `Lens` when multiple fields map to the same name or some constructors are missing a field.+* Removed `_` from the lens names in `System.FilePath.Lens`.+* Added `iwhere`, `withIndices`, `withIndicesOf`, `indices` and `indicesOf` to ease work with indexed traversals+* Added `assign` as an alias for `(.=)` in `Control.Lens.Setter`.+* Added `~:`, `=:`, `<~:` and `<=:` to `Data.List.Lens`+ 2.5 --- * Added `Control.Lens.Plated`, a port of Neil Mitchell's `uniplate` that can be used on any `Traversal`.
README.markdown view
@@ -7,7 +7,7 @@  An overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [Tutorial](https://github.com/ekmett/lens/wiki/Tutorial). -Documentation is available through [github](https://ekmett.github.com/lens) or [hackage](http://hackage.haskell.org/package/lens).+Documentation is available through [github](http://ekmett.github.com/lens) or [hackage](http://hackage.haskell.org/package/lens).  Plated ------
benchmarks/plated.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}@@ -8,9 +9,11 @@ import           Criterion.Main import           Data.Data import           Data.Data.Lens as Data+#ifdef BENCHMARK_UNIPLATE import qualified Data.Generics.Uniplate.Direct as Uni import           Data.Generics.Uniplate.Direct ((|*)) import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly+#endif import           GHC.Generics import           GHC.Generics.Lens as Generic @@ -41,7 +44,7 @@   plate _ t = pure t   {-# INLINE plate #-} --- | ndm's uniplate+#ifdef BENCHMARK_UNIPLATE instance Uni.Uniplate Expr where   uniplate (Neg a)   = Uni.plate Neg |* a   uniplate (Add a b) = Uni.plate Add |* a |* b@@ -51,6 +54,7 @@   uniplate (Val i)   = Uni.plate (Val i)   uniplate (Var s)   = Uni.plate (Var s)   {-# INLINE uniplate #-}+#endif  main :: IO () main = defaultMain@@ -61,8 +65,10 @@   , bench "universeOf Data.template"           $ nf (map (universeOf Data.template)) testsExpr   , bench "universeOf Data.uniplate"           $ nf (map (universeOf Data.uniplate)) testsExpr   , bench "universeOf (cloneTraversal plate)"  $ nf (map (universeOf (cloneTraversal plate))) testsExpr+#ifdef BENCHMARK_UNIPLATE   , bench "Direct.universe"                    $ nf (map Uni.universe) testsExpr   , bench "DataOnly.universe"                  $ nf (map UniDataOnly.universe) testsExpr+#endif   ]  testsExpr :: [Expr]
lens.cabal view
@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses-version:       2.5+version:       2.6 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -20,7 +20,11 @@   families of getters, folds, isomorphisms, traversals, setters and lenses and their   indexed variants.   .-  More information on the care and feeding of lenses, including a tutorial and motivation+  An overview, with a large number of examples can be found in the README.+  .+  <https://github.com/ekmett/lens#lens-lenses-folds-and-traversals>+  .+  More information on the care and feeding of lenses, including a brief tutorial and motivation   for their types can be found on the lens wiki.   .   <https://github.com/ekmett/lens/wiki>@@ -33,7 +37,7 @@   .   The core of this hierarchy looks like:   .-  <<https://github.com/ekmett/lens/wiki/images/Hierarchy-2.5.png>>+  <<https://github.com/ekmett/lens/wiki/images/Hierarchy-2.6.png>>   .   You can compose any two elements of the hierarchy above using (.) from the Prelude, and you can   use any element of the hierarchy as any type it links to above it.@@ -78,7 +82,7 @@   exotic functionality, (e.g. getters, setters, indexed folds, isomorphisms).  build-type:    Simple-tested-with:   GHC == 7.4.1+tested-with:   GHC == 7.4.1, GHC == 7.6.0, GHC == 7.7.20120822, GHC == 7.7.20120830 extra-source-files:   .travis.yml   .ghci@@ -96,6 +100,38 @@   type: git   location: git://github.com/ekmett/lens.git +-- Enable benchmarking against Neil Mitchell's uniplate library for comparative performance analysis. Defaults to being turned off to avoid+-- the extra dependency.+--+-- > cabal configure --enable-benchmarks -fbenchmark-uniplate && cabal build && cabal bench+flag benchmark-uniplate+  default: False+  manual: True++-- Enable template haskell. Disable this at your own risk and for testing only.+--+-- cabal configure -f-template-haskell is an /unsuppported/ configuration.+--+-- Clients of this library can and should expect this to be turned on.+flag template-haskell+  default: True+  manual: True++-- Generate inline pragmas when using template-haskell. This defaults to enabled, but you can+--+-- > cabal install lens -f-inlining +--+-- to shut it off to benchmark the relative performance impact, or as last ditch effort to address compile+-- errors resulting from the myriad versions of template-haskell that all purport to be 2.8.+flag inlining+  manual: True+  default: True++-- Some 7.6.1-rc1 users report their TH still uses old style inline pragmas. This lets them turn on inlining.+flag old-inline-pragmas+  default: False+  manual: True+ library   build-depends:     base                 >= 4.3      && < 5,@@ -106,7 +142,6 @@     containers           >= 0.4.2    && < 0.6,     hashable             == 1.1.*,     mtl                  >= 2.1.1    && < 2.2,-    template-haskell     >= 2.4      && < 2.9,     text                 >= 0.11     && < 0.12,     transformers         >= 0.3      && < 0.4,     unordered-containers >= 0.2      && < 0.3@@ -129,7 +164,6 @@     Control.Lens.Plated     Control.Lens.Representable     Control.Lens.Setter-    Control.Lens.TH     Control.Lens.Traversal     Control.Lens.Tuple     Control.Lens.Type@@ -155,8 +189,13 @@     Data.Text.Lazy.Lens     Data.Tree.Lens     Data.Typeable.Lens-    Language.Haskell.TH.Lens +  if flag(template-haskell)+    build-depends: template-haskell >= 2.4 && < 2.9+    exposed-modules: Control.Lens.TH Language.Haskell.TH.Lens+  else+    cpp-options: -DDISABLE_TEMPLATE_HASKELL+   -- platform   build-depends:   array >= 0.3.0.2 && < 0.5   exposed-modules: Data.Array.Lens@@ -167,10 +206,14 @@   build-depends:   parallel >= 3.1.0.1 && < 3.3   exposed-modules: Control.Parallel.Strategies.Lens Control.Seq.Lens -  if impl(ghc>7.6.0.20120810)-    cpp-options: -DNEW_INLINE_PRAGMAS+  if impl(ghc>=7.6.0.20120810)+    if flag(old-inline-pragmas)+      cpp-options: -DOLD_INLINE_PRAGMAS -  if (impl(ghc>=7.4))+  if !flag(inlining)+    cpp-options: -DOMIT_INLINING++  if impl(ghc>=7.4)     other-extensions: Trustworthy     build-depends: ghc-prim     exposed-modules: GHC.Generics.Lens@@ -223,7 +266,9 @@     deepseq,     ghc-prim,     lens,-    transformers,-    uniplate >= 1.6.7 && < 1.7+    transformers   ghc-options: -Wall -O2 -threaded   hs-source-dirs: benchmarks+  if flag(benchmark-uniplate)+    build-depends: uniplate >= 1.6.7 && < 1.7+    cpp-options: -DBENCHMARK_UNIPLATE
src/Control/Lens.hs view
@@ -41,7 +41,7 @@ -- -- <http://github.com/ekmett/lens/wiki> ----- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-2.5.png>>+-- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-2.6.png>> ---------------------------------------------------------------------------- module Control.Lens   ( module Control.Lens.Type@@ -59,7 +59,9 @@   , module Control.Lens.IndexedSetter   , module Control.Lens.Plated   , module Control.Lens.Representable+#ifndef DISABLE_TEMPLATE_HASKELL   , module Control.Lens.TH+#endif   , module Control.Lens.Tuple   , module Control.Lens.WithIndex   , module Control.Lens.Zoom@@ -78,7 +80,9 @@ import Control.Lens.Plated import Control.Lens.Representable import Control.Lens.Setter+#ifndef DISABLE_TEMPLATE_HASKELL import Control.Lens.TH+#endif import Control.Lens.Traversal import Control.Lens.Tuple import Control.Lens.Type
src/Control/Lens/Fold.hs view
@@ -107,9 +107,6 @@ -- there are no lens laws that apply. type Fold a c = forall f. (Gettable f, Applicative f) => (c -> f c) -> a -> f a -noEffect :: (Applicative f, Gettable f) => f a-noEffect = coerce $ pure ()-{-# INLINE noEffect #-}  -- | Obtain a 'Fold' by lifting an operation that returns a foldable result. --@@ -118,19 +115,9 @@ folding afc cgd = coerce . traverse_ cgd . afc {-# INLINE folding #-} ---- | A monoid in a monad as a monoid-newtype GA f a = GA { getGA :: f a }--instance (Gettable f, Applicative f) => Monoid (GA f a) where-  mempty = GA noEffect-  {-# INLINE mempty #-}-  GA fr `mappend` GA fs = GA (fr *> fs)-  {-# INLINE mappend #-}- -- | Obtain a 'Fold' from any 'Foldable'. folded :: Foldable f => Fold (f c) c-folded f = coerce . getGA . foldMap (GA . f)+folded f = coerce . getFolding . foldMap (Folding . f) {-# INLINE folded #-}  -- | Fold by repeating the input forever.
src/Control/Lens/Indexed.hs view
@@ -61,8 +61,6 @@ (<.)  :: Indexed i k => Index i b c -> (a -> b) -> k a c Index ibc <. ab = index $ \ia -> ibc (ab . ia) {-# INLINE (<.) #-}-{-# SPECIALIZE (<.) :: Index i b c -> (a -> b) -> a -> c #-}-{-# SPECIALIZE (<.) :: Index i b c -> (a -> b) -> Index i a c #-}  -- | Compose a non-indexed function with an 'Indexed' function. --@@ -70,14 +68,11 @@ (.>)  :: Indexed i k => (b -> c) -> Index i a b -> k a c bc .> Index iab = index (bc . iab) {-# INLINE (.>) #-}-{-# SPECIALIZE (.>) :: (b -> c) -> Index i a b -> a -> c #-}-{-# SPECIALIZE (.>) :: (b -> c) -> Index i a b -> Index i a c #-}  -- | Remap the index. reindex :: Indexed j k => (i -> j) -> Index i a b -> k a b reindex ij (Index iab) = index $ \ ja -> iab $ \i -> ja (ij i)-{-# SPECIALIZE reindex :: (i -> j) -> Index i a b -> a -> b #-}-{-# SPECIALIZE reindex :: (i -> j) -> Index i a b -> Index j a b #-}+{-# INLINE reindex #-}  -- | Composition of 'Indexed' functions --@@ -85,15 +80,11 @@ (<.>) :: Indexed (i, j) k => Index i b c -> Index j a b -> k a c f <.> g = icompose (,) f g {-# INLINE (<.>) #-}-{-# SPECIALIZE (<.>) :: Index i b c -> Index j a b -> a -> c #-}-{-# SPECIALIZE (<.>) :: Index i b c -> Index j a b -> Index (i,j) a c #-}  -- | Composition of 'Indexed' functions with a user supplied function for combining indexs icompose :: Indexed k r => (i -> j -> k) -> Index i b c -> Index j a b -> r a c icompose ijk (Index ibc) (Index jab) = index $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j) {-# INLINE icompose #-}-{-# SPECIALIZE icompose :: (i -> j -> k) -> Index i b c -> Index j a b -> a -> c #-}-{-# SPECIALIZE icompose :: (k ~ l) => (i -> j -> k) -> Index i b c -> Index j a b -> Index l a c #-}  -- | Transform an Traversal into an IndexedTraversal, a Fold into an IndexedFold, etc. --@@ -108,5 +99,3 @@ indexed l = index $ \icfd a -> case runIndexing (l (\c -> Indexing (\i -> IndexingResult (icfd i c) (i + 1))) a) 0 of   IndexingResult r _ -> r {-# INLINE indexed #-}-{-# SPECIALIZE indexed :: ((c -> Indexing f d) -> a -> Indexing f b) -> (c -> f d) -> (a -> f b) #-}-{-# SPECIALIZE indexed :: ((c -> Indexing f d) -> a -> Indexing f b) -> Index Int (c -> f d) (a -> f b) #-}
src/Control/Lens/IndexedFold.hs view
@@ -36,6 +36,10 @@   , ifoldlMOf   , itoListOf +  -- * Converting to Folds+  , withIndicesOf+  , indicesOf+   -- * Building Indexed Folds   , ifiltered   , itakingWhile@@ -49,6 +53,7 @@ import Control.Lens.Indexed import Control.Lens.IndexedGetter import Control.Lens.Internal+import Control.Lens.Type import Control.Monad import Data.Monoid @@ -354,9 +359,47 @@ itoListOf l = ifoldMapOf l (\i c -> [(i,c)]) {-# INLINE itoListOf #-} -noEffect :: (Applicative f, Gettable f) => f a-noEffect = coerce $ pure ()-{-# INLINE noEffect #-}+-------------------------------------------------------------------------------+-- Converting to Folds+-------------------------------------------------------------------------------++-- | Transform an indexed fold into a fold of both the indices and the values.+--+-- @+-- 'withIndices' :: 'IndexedFold' i a c             -> 'Fold' a (i, c)+-- 'withIndices' :: 'Simple' 'IndexedLens' i a c      -> 'Getter' a (i, c)+-- 'withIndices' :: 'Simple' 'IndexedTraversal' i a c -> 'Fold' a (i, c)+-- @+--+-- All 'Fold' operations are safe, and comply with the laws. However,+--+-- Passing this an 'IndexedTraversal' will still allow many+-- 'Traversal' combinators to type check on the result, but the result+-- can only be legally traversed by operations that do not edit the indices.+--+-- @+-- 'withIndices' :: 'IndexedTraversal' i a b c d -> 'Traversal' a b (i, c) (j, d)+-- @+--+-- Change made to the indices will be discarded.+withIndicesOf :: Functor f => Overloaded (Index i) f a b c d -> LensLike f a b (i, c) (j, d)+withIndicesOf l f = withIndex l (\i c -> snd <$> f (i,c))+{-# INLINE withIndicesOf #-}++-- | Transform an indexed fold into a fold of the indices.+--+-- @+-- 'indices' :: 'IndexedFold' i a c             -> 'Fold' a i+-- 'indices' :: 'Simple' 'IndexedLens' i a c      -> 'Getter' a i+-- 'indices' :: 'Simple' 'IndexedTraversal' i a c -> 'Fold' a i+-- @+indicesOf :: Gettable f => Overloaded (Index i) f a b c c -> LensLike f a b i j+indicesOf l f = withIndex l (const . coerce . f)+{-# INLINE indicesOf #-}++-------------------------------------------------------------------------------+-- Converting to Folds+-------------------------------------------------------------------------------  -- | Obtain an 'IndexedFold' by filtering a 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter', 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal'. ifiltered :: (Gettable f, Applicative f, Indexed i k) => (i -> c -> Bool) -> Index i (c -> f c) (a -> f a) -> k (c -> f c) (a -> f a)
src/Control/Lens/IndexedLens.hs view
@@ -172,15 +172,15 @@   contains :: k -> SimpleIndexedLens k m Bool  instance Contains Int IntSet where-  contains k = index $ \ f s -> (\b -> if b then IntSet.insert k s else IntSet.delete k s) <$> f k (IntSet.member k s) where+  contains k = index $ \ f s -> (\b -> if b then IntSet.insert k s else IntSet.delete k s) <$> f k (IntSet.member k s)   {-# INLINE contains #-}  instance Ord k => Contains k (Set k) where-  contains k = index $ \ f s -> (\b -> if b then Set.insert k s else Set.delete k s) <$> f k (Set.member k s) where+  contains k = index $ \ f s -> (\b -> if b then Set.insert k s else Set.delete k s) <$> f k (Set.member k s)   {-# INLINE contains #-}  instance (Eq k, Hashable k) => Contains k (HashSet k) where-  contains k = index $ \ f s -> (\b -> if b then HashSet.insert k s else HashSet.delete k s) <$> f k (HashSet.member k s) where+  contains k = index $ \ f s -> (\b -> if b then HashSet.insert k s else HashSet.delete k s) <$> f k (HashSet.member k s)   {-# INLINE contains #-}  ------------------------------------------------------------------------------
src/Control/Lens/IndexedTraversal.hs view
@@ -165,8 +165,6 @@  -- | Access the element of an 'IndexedTraversal' where the index matches a predicate. ----- Attempts to access beyond the range of the 'Traversal' will cause an error.--- -- >>> :m + Control.Lens -- >>> over (iwhereOf (indexed traverse) (>0)) reverse $ ["He","was","stressed","o_O"] -- ["He","saw","desserts","O_o"]
src/Control/Lens/Internal.hs view
@@ -43,7 +43,7 @@   , Effect(..)   , EffectRWS(..)   -- , EffectS(..)-  , Gettable(..), Accessor(..), Effective(..), ineffective+  , Gettable(..), Accessor(..), Effective(..), ineffective, noEffect, Folding(..)   , Settable(..), Mutator(..)   ) where @@ -261,7 +261,7 @@   ElementOf mf <*> ElementOf ma = ElementOf $ \i -> case mf i of     Found j ff -> case ma j of       Found _ _     -> NotFound "multiple results"-      Searching k a -> Found k (fmap ($a) ff)+      Searching k a -> Found k (fmap ($ a) ff)       NotFound e    -> NotFound e     Searching j f -> case ma j of       Found k as    -> Found k (fmap f as)@@ -425,17 +425,28 @@ instance Effective Identity r (Accessor r) where   effective = isomorphic (Accessor . runIdentity) (Identity . runAccessor)   {-# INLINE effective #-}-  {-# SPECIALIZE effective :: Identity r -> Accessor r a #-}-  {-# SPECIALIZE effective :: Isomorphism (Identity r) (Accessor r a) #-}  instance Effective m r f => Effective m (Dual r) (Backwards f) where   effective = isomorphic (Backwards . effective . liftM getDual) (liftM Dual . ineffective . forwards)  instance Monad m => Effective m r (Effect m r) where   effective = isomorphic Effect getEffect-  {-# SPECIALIZE effective :: Monad m => m r -> Effect m r a #-}-  {-# SPECIALIZE effective :: Monad m => Isomorphism (m r) (Effect m r a) #-}+  {-# INLINE effective #-} +-- | A 'Monoid' for a 'Gettable' 'Applicative'.+newtype Folding f a = Folding { getFolding :: f a }++instance (Gettable f, Applicative f) => Monoid (Folding f a) where+  mempty = Folding noEffect+  {-# INLINE mempty #-}+  Folding fr `mappend` Folding fs = Folding (fr *> fs)+  {-# INLINE mappend #-}++-- | The 'mempty' equivalent for a 'Gettable' 'Applicative' 'Functor'.+noEffect :: (Applicative f, Gettable f) => f a+noEffect = coerce $ pure ()+{-# INLINE noEffect #-}+ ----------------------------------------------------------------------------- -- Settables & Mutators -----------------------------------------------------------------------------@@ -511,3 +522,4 @@ bazaar _ (Buy b)    = pure b bazaar f (Trade k c) = f c <**> bazaar f k -}+
src/Control/Lens/Iso.hs view
@@ -77,8 +77,6 @@   (\cfd a -> db <$> cfd (ac a))   (\afb c -> bd <$> afb (ca c)) {-# INLINE isos #-}-{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> (c -> f d) -> a -> f b #-}-{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Isomorphism (c -> f d) (a -> f b) #-}  -- | Build a simple isomorphism from a pair of inverse functions --@@ -94,8 +92,6 @@ iso :: (Isomorphic k, Functor f) => (a -> b) -> (b -> a) -> k (b -> f b) (a -> f a) iso ab ba = isos ab ba ab ba {-# INLINE iso #-}-{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> (b -> f b) -> a -> f a #-}-{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> Isomorphism (b -> f b) (a -> f a) #-}  -- | Based on @ala@ from Conor McBride's work on Epigram. --
src/Control/Lens/Isomorphic.hs view
@@ -77,8 +77,6 @@ from :: Isomorphic k => Isomorphism a b -> k b a from (Isomorphism a b) = isomorphic b a {-# INLINE from #-}-{-# SPECIALIZE from :: Isomorphism a b -> b -> a #-}-{-# SPECIALIZE from :: Isomorphism a b -> Isomorphism b a #-}  -- | Convert from an 'Isomorphism' back to any 'Isomorphic' value. --@@ -87,5 +85,3 @@ via :: Isomorphic k => Isomorphism a b -> k a b via (Isomorphism a b) = isomorphic a b {-# INLINE via #-}-{-# SPECIALIZE via :: Isomorphism a b -> a -> b #-}-{-# SPECIALIZE via :: Isomorphism a b -> Isomorphism a b #-}
src/Control/Lens/Plated.hs view
@@ -769,11 +769,11 @@  -- | 'partsOf' turns a 'Traversal' into a lens that resembles an early version of the @uniplate@ (or @biplate@) type. ----- /Note:/ You should really, maintain the invariant of the number of children in the list.+-- /Note:/ You should really try to maintain the invariant of the number of children in the list. ----- Any extras will be lost.+-- Any extras will be lost. If you do not supply enough, then the remainder will come from the original structure. ----- If you do not supply enough, then the remainder will come from the original structure.+-- So technically, this is only a lens if you do not change the number of results it returns. -- -- @ -- 'partsOf' :: 'Simple' 'Control.Lens.Iso.Iso' a b       -> a -> 'Simple' 'Lens' a [b]
src/Control/Lens/Representable.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Lens.Representable@@ -65,22 +66,33 @@   , Path(..)   , paths   , tabulated-  -- * Traversal with representation-  , mapWithRep-  , foldMapWithRep-  , foldrWithRep-  , traverseWithRep-  , traverseWithRep_-  , forWithRep-  , mapMWithRep-  , mapMWithRep_-  , forMWithRep+  -- * Setting with Representation+  , rmap+  -- * Folding with Representation+  , rfoldMap+  , rfoldr+  -- * Traversing with Representation+  , rtraverse+  , rtraverse_+  , rfor+  , rmapM+  , rmapM_+  , rforM+  -- * Representable Setters, Folds and Traversals+  , rmapped+  , rfolded+  , rtraversed   ) where  import Control.Applicative import Control.Lens.Iso import Control.Lens.Type import Control.Lens.Getter+import Control.Lens.Indexed+import Control.Lens.IndexedSetter+import Control.Lens.IndexedFold+import Control.Lens.IndexedTraversal+import Control.Lens.Internal import Data.Foldable         as Foldable import Data.Functor.Identity import Data.Monoid@@ -104,11 +116,9 @@ -- As the covariant case is vastly more common, and both are often referred to -- as representable functors, we choose to call these functors 'Representable' -- here.- class Functor f => Representable f where   rep :: (Rep f -> a) -> f a - instance Representable Identity where   rep f = Identity (f (from identity)) @@ -127,7 +137,6 @@ -- instance 'Functor' Foo where --   'fmap' = 'fmapRep' -- @- fmapRep :: Representable f => (a -> b) -> f a -> f b fmapRep f m = rep $ \i -> f (m^.i) {-# INLINE fmapRep #-}@@ -207,7 +216,7 @@ -- | Sometimes you need to store a path lens into a container, but at least -- at this time, @ImpredicativePolymorphism@ in GHC is somewhat lacking. ----- This type provides a way to, say, store a @[]@ of polymorphic lenses.+-- This type provides a way to, say, store a @[]@ of paths. newtype Path f = Path { walk :: Rep f }  -- | A 'Representable' 'Functor' has a fixed shape. This fills each position@@ -218,7 +227,7 @@  -- | A version of 'rep' that is an isomorphism. Predicativity requires that -- we wrap the 'Rep' as a 'Key', however.-tabulated :: (Isomorphic k, Representable f) => k (Path f -> a) (f a)+tabulated :: Representable f => (Path f -> a) -> f a tabulated = isomorphic (\f -> rep (f . Path)) (\fa path -> view (walk path) fa) {-# INLINE tabulated #-} @@ -226,66 +235,79 @@ -- Traversal ----------------------------------------------------------------------------- - -- | Map over a 'Representable' functor with access to the 'Lens' for the -- current position ----- @'mapWithRep' f m = 'rep' '$' \i -> f i (m '^.' i)@-mapWithRep :: Representable f => (Rep f -> a -> b) -> f a -> f b-mapWithRep f m = rep $ \i -> f i (m^.i)-{-# INLINE mapWithRep #-}+-- @'rmap' f m = 'rep' '$' \i -> f i (m '^.' i)@+rmap :: Representable f => (Rep f -> a -> b) -> f a -> f b+rmap f m = rep $ \i -> f i (m^.i)+{-# INLINE rmap #-}  -- | Traverse a 'Representable' functor with access to the current path-traverseWithRep :: (Representable f, Traversable f, Applicative g)-                => (Rep f -> a -> g b) -> f a -> g (f b)-traverseWithRep f m = sequenceA (mapWithRep f m)-{-# INLINE traverseWithRep #-}+rtraverse :: (Representable f, Traversable f, Applicative g)+          => (Rep f -> a -> g b) -> f a -> g (f b)+rtraverse f m = sequenceA (rmap f m)+{-# INLINE rtraverse #-}  -- | Traverse a 'Representable' functor with access to the current path -- as a 'Lens', discarding the result-traverseWithRep_ :: (Representable f, Foldable f, Applicative g)-                 => (Rep f -> a -> g b) -> f a -> g ()-traverseWithRep_ f m = sequenceA_ (mapWithRep f m)-{-# INLINE traverseWithRep_ #-}+rtraverse_ :: (Representable f, Foldable f, Applicative g)+           => (Rep f -> a -> g b) -> f a -> g ()+rtraverse_ f m = sequenceA_ (rmap f m)+{-# INLINE rtraverse_ #-}  -- | Traverse a 'Representable' functor with access to the current path -- and a 'Lens' (and the arguments flipped)-forWithRep :: (Representable f, Traversable f, Applicative g)-                => f a -> (Rep f -> a -> g b) -> g (f b)-forWithRep m f = sequenceA (mapWithRep f m)-{-# INLINE forWithRep #-}+rfor :: (Representable f, Traversable f, Applicative g)+     => f a -> (Rep f -> a -> g b) -> g (f b)+rfor m f = sequenceA (rmap f m)+{-# INLINE rfor #-}  -- | 'mapM' over a 'Representable' functor with access to the current path -- as a 'Lens'-mapMWithRep :: (Representable f, Traversable f, Monad m)-                => (Rep f -> a -> m b) -> f a -> m (f b)-mapMWithRep f m = Traversable.sequence (mapWithRep f m)-{-# INLINE mapMWithRep #-}+rmapM :: (Representable f, Traversable f, Monad m)+      => (Rep f -> a -> m b) -> f a -> m (f b)+rmapM f m = Traversable.sequence (rmap f m)+{-# INLINE rmapM #-}  -- | 'mapM' over a 'Representable' functor with access to the current path -- as a 'Lens', discarding the result-mapMWithRep_ :: (Representable f, Foldable f, Monad m)-                 => (Rep f -> a -> m b) -> f a -> m ()-mapMWithRep_ f m = Foldable.sequence_ (mapWithRep f m)-{-# INLINE mapMWithRep_ #-}+rmapM_ :: (Representable f, Foldable f, Monad m)+       => (Rep f -> a -> m b) -> f a -> m ()+rmapM_ f m = Foldable.sequence_ (rmap f m)+{-# INLINE rmapM_ #-}  -- | 'mapM' over a 'Representable' functor with access to the current path -- as a 'Lens' (with the arguments flipped)-forMWithRep :: (Representable f, Traversable f, Monad m)-                => f a -> (Rep f -> a -> m b) -> m (f b)-forMWithRep m f = Traversable.sequence (mapWithRep f m)-{-# INLINE forMWithRep #-}+rforM :: (Representable f, Traversable f, Monad m)+      => f a -> (Rep f -> a -> m b) -> m (f b)+rforM m f = Traversable.sequence (rmap f m)+{-# INLINE rforM #-}  -- | Fold over a 'Representable' functor with access to the current path -- as a 'Lens', yielding a 'Monoid'-foldMapWithRep :: (Representable f, Foldable f, Monoid m)-               => (Rep f -> a -> m) -> f a -> m-foldMapWithRep f m = fold (mapWithRep f m)-{-# INLINE foldMapWithRep #-}+rfoldMap :: (Representable f, Foldable f, Monoid m)+         => (Rep f -> a -> m) -> f a -> m+rfoldMap f m = fold (rmap f m)+{-# INLINE rfoldMap #-}  -- | Fold over a 'Representable' functor with access to the current path -- as a 'Lens'.-foldrWithRep :: (Representable f, Foldable f) => (Rep f -> a -> b -> b) -> b -> f a -> b-foldrWithRep f b m = Foldable.foldr id b (mapWithRep f m)-{-# INLINE foldrWithRep #-}+rfoldr :: (Representable f, Foldable f) => (Rep f -> a -> b -> b) -> b -> f a -> b+rfoldr f b m = Foldable.foldr id b (rmap f m)+{-# INLINE rfoldr #-} +-- | An 'IndexedSetter' that walks an 'Representable' 'Functor' using a 'Path' for an index.+rmapped :: Representable f => IndexedSetter (Path f) (f a) (f b) a b+rmapped = index $ \f -> pure . rmap (\i -> untainted . f (Path i))+{-# INLINE rmapped #-}++-- | An 'IndexedFold' that walks an 'Foldable' 'Representable' 'Functor' using a 'Path' for an index.+rfolded :: (Representable f, Foldable f) => IndexedFold (Path f) (f a) a+rfolded = index $ \f -> coerce . getFolding . rfoldMap (\i -> Folding . f (Path i))+{-# INLINE rfolded #-}++-- | An 'IndexedTraversal' for a 'Traversable' 'Representable' 'Functor'.+rtraversed :: (Representable f, Traversable f) => IndexedTraversal (Path f) (f a) (f b) a b+rtraversed = index $ \ f -> sequenceA . rmap (f . Path)+{-# INLINE rtraversed #-}
src/Control/Lens/Setter.hs view
@@ -36,6 +36,7 @@   , (.~), (%~)   , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (&&~), (<.~)   -- * State Combinators+  , assign   , (.=), (%=)   , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (&&=), (<.=)   , (<~)@@ -271,10 +272,10 @@ -- If you do not need a copy of the intermediate result, then using @l '.~' d@ directly is a good idea. -- -- @--- ('\<.~') :: 'Setter' a b c d    -> d -> a -> (d, b)--- ('\<.~') :: 'Control.Lens.Iso.Iso' a b c d       -> d -> a -> (d, b)--- ('\<.~') :: 'Control.Lens.Type.Lens' a b c d      -> d -> a -> (d, b)--- ('\<.~') :: 'Control.Lens.Traversal.Traversal' a b c d -> d -> a -> (d, b)+-- ('<.~') :: 'Setter' a b c d    -> d -> a -> (d, b)+-- ('<.~') :: 'Control.Lens.Iso.Iso' a b c d       -> d -> a -> (d, b)+-- ('<.~') :: 'Control.Lens.Type.Lens' a b c d      -> d -> a -> (d, b)+-- ('<.~') :: 'Control.Lens.Traversal.Traversal' a b c d -> d -> a -> (d, b) -- @ (<.~) :: Setting a b c d -> d -> a -> (d, b) l <.~ d = \a -> (d, l .~ d $ a)@@ -392,10 +393,10 @@ -- (False,True) -- -- @--- (||~):: 'Setter' a b 'Bool' 'Bool' -> 'Bool' -> a -> b--- (||~):: 'Control.Lens.Iso.Iso' a b 'Bool' 'Bool' -> 'Bool' -> a -> b--- (||~):: 'Control.Lens.Type.Lens' a b 'Bool' 'Bool' -> 'Bool' -> a -> b--- (||~):: 'Control.Lens.Traversal.Traversal' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('||~') :: 'Setter' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('||~') :: 'Control.Lens.Iso.Iso' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('||~') :: 'Control.Lens.Type.Lens' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('||~') :: 'Control.Lens.Traversal.Traversal' a b 'Bool' 'Bool' -> 'Bool' -> a -> b -- @ (||~):: Setting a b Bool Bool -> Bool -> a -> b l ||~ n = over l (|| n)@@ -412,10 +413,10 @@ -- (False,False) -- -- @--- (&&~):: 'Setter' a b 'Bool' 'Bool' -> 'Bool' -> a -> b--- (&&~):: 'Control.Lens.Iso.Iso' a b 'Bool' 'Bool' -> 'Bool' -> a -> b--- (&&~):: 'Control.Lens.Type.Lens' a b 'Bool' 'Bool' -> 'Bool' -> a -> b--- (&&~):: 'Control.Lens.Traversal.Traversal' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('&&~') :: 'Setter' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('&&~') :: 'Control.Lens.Iso.Iso' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('&&~') :: 'Control.Lens.Type.Lens' a b 'Bool' 'Bool' -> 'Bool' -> a -> b+-- ('&&~') :: 'Control.Lens.Traversal.Traversal' a b 'Bool' 'Bool' -> 'Bool' -> a -> b -- @ (&&~) :: Setting a b Bool Bool -> Bool -> a -> b l &&~ n = over l (&& n)@@ -428,7 +429,24 @@ -- | Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' in our monadic -- state with a new value, irrespective of the old. --+-- This is an alias for ('.=').+-- -- @+-- 'assign' :: 'MonadState' a m => 'Control.Lens.Iso.Iso' a a c d             -> d -> m ()+-- 'assign' :: 'MonadState' a m => 'Control.Lens.Type.Lens' a a c d            -> d -> m ()+-- 'assign' :: 'MonadState' a m => 'Control.Lens.Traversal.Traversal' a a c d       -> d -> m ()+-- 'assign' :: 'MonadState' a m => 'Setter' a a c d          -> d -> m ()+-- @+assign :: MonadState a m => Setting a a c d -> d -> m ()+assign l b = State.modify (set l b)+{-# INLINE assign #-}++-- | Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' in our monadic+-- state with a new value, irrespective of the old.+--+-- This is an infix version of 'assign'.+--+-- @ -- ('.=') :: 'MonadState' a m => 'Control.Lens.Iso.Iso' a a c d             -> d -> m () -- ('.=') :: 'MonadState' a m => 'Control.Lens.Type.Lens' a a c d            -> d -> m () -- ('.=') :: 'MonadState' a m => 'Control.Lens.Traversal.Traversal' a a c d       -> d -> m ()@@ -476,10 +494,10 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by subtracting a value -- -- @--- (-=) :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Setter' a b -> b -> m ()--- (-=) :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a b -> b -> m ()--- (-=) :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a b -> b -> m ()--- (-=) :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a b -> b -> m ()+-- ('-=') :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Setter' a b -> b -> m ()+-- ('-=') :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a b -> b -> m ()+-- ('-=') :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a b -> b -> m ()+-- ('-=') :: ('MonadState' a m, 'Num' b) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a b -> b -> m () -- @ (-=) :: (MonadState a m, Num b) => SimpleSetting a b -> b -> m () l -= b = State.modify (l -~ b)@@ -550,10 +568,10 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by taking their logical '&&' with a value -- -- @--- (&&=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Setter' a 'Bool' -> 'Bool' -> m ()--- (&&=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a 'Bool' -> 'Bool' -> m ()--- (&&=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a 'Bool' -> 'Bool' -> m ()--- (&&=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a 'Bool' -> 'Bool' -> m ()+-- ('&&=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Setter' a 'Bool' -> 'Bool' -> m ()+-- ('&&=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a 'Bool' -> 'Bool' -> m ()+-- ('&&=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a 'Bool' -> 'Bool' -> m ()+-- ('&&=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a 'Bool' -> 'Bool' -> m () -- @ (&&=):: MonadState a m => SimpleSetting a Bool -> Bool -> m () l &&= b = State.modify (l &&~ b)@@ -562,10 +580,10 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Iso, 'Setter' or 'Control.Lens.Traversal.Traversal' by taking their logical '||' with a value -- -- @--- (||=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Setter' a 'Bool' -> 'Bool' -> m ()--- (||=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a 'Bool' -> 'Bool' -> m ()--- (||=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a 'Bool' -> 'Bool' -> m ()--- (||=):: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a 'Bool' -> 'Bool' -> m ()+-- ('||=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Setter' a 'Bool' -> 'Bool' -> m ()+-- ('||=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' a 'Bool' -> 'Bool' -> m ()+-- ('||=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' a 'Bool' -> 'Bool' -> m ()+-- ('||=') :: 'MonadState' a m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' a 'Bool' -> 'Bool' -> m () -- @ (||=) :: MonadState a m => SimpleSetting a Bool -> Bool -> m () l ||= b = State.modify (l ||~ b)
src/Control/Lens/TH.hs view
@@ -3,33 +3,40 @@ #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif++-- in case we're being loaded from ghci+#ifndef MIN_VERSION_template_haskell+#define MIN_VERSION_template_haskell(x,y,z) (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706)+#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Lens.TH--- Copyright   :  (C) 2012 Edward Kmett+-- Copyright   :  (C) 2012 Edward Kmett, Michael Sloan -- License     :  BSD-style (see the file LICENSE) -- Maintainer  :  Edward Kmett <ekmett@gmail.com> -- Stability   :  experimental -- Portability :  TemplateHaskell -------------------------------------------------------------------------------+----------------------------------------------------------------------------- module Control.Lens.TH-  ( LensRules(LensRules)-  , lensIso-  , lensField-  , lensClass-  , lensFlags-  , LensFlag(..)-  , simpleLenses, handleSingletons, singletonIso, singletonRequired, createClass, createInstance, classRequired+  (   -- * Constructing Lenses Automatically+    makeLenses, makeLensesFor   , makeClassy, makeClassyFor   , makeIso-  , makeLenses, makeLensesFor+  -- * Configuring Lenses   , makeLensesWith+  , defaultRules+  , LensRules(LensRules)   , lensRules   , classyRules   , isoRules-  , defaultRules+  , lensIso+  , lensField+  , lensClass+  , lensFlags+  , LensFlag(..)+  , simpleLenses, partialLenses, handleSingletons, singletonIso, singletonRequired, createClass, createInstance, classRequired   ) where  import Control.Applicative@@ -43,20 +50,24 @@ import Control.Lens.IndexedLens import Control.Monad import Data.Char (toLower)-import Data.Foldable+import Data.Either (lefts)+import Data.Foldable hiding (concat)+import Data.Function (on) import Data.List as List import Data.Map as Map hiding (toList,map,filter)-import Data.Maybe (isNothing,isJust)-import Data.Monoid+import Data.Maybe (isNothing,isJust, catMaybes)+import Data.Ord (comparing) import Data.Set as Set hiding (toList,map,filter) import Data.Set.Lens-import Data.Traversable+import Data.Traversable hiding (mapM) import Language.Haskell.TH import Language.Haskell.TH.Lens  -- | Flags for lens construction data LensFlag   = SimpleLenses+  | PartialLenses+  | BuildTraversals   | SingletonAndField   | SingletonIso   | HandleSingletons@@ -66,39 +77,54 @@   | ClassRequired   deriving (Eq,Ord,Show,Read) --- | Only Generate valid 'Simple' 'Lens' lenses+-- | Only Generate valid 'Simple' 'Lens' lenses. simpleLenses      :: Simple Lens LensRules Bool simpleLenses       = lensFlags.contains SimpleLenses --- | Handle singleton constructors specially-handleSingletons :: Simple Lens LensRules Bool-handleSingletons = lensFlags.contains HandleSingletons+-- | Enables the generation of partial lenses, generating runtime errors for+-- every constructor that does not have a valid definition for the lens. This+-- occurs when the constructor lacks the field, or has multiple fields mapped+-- to the same lens.+partialLenses     :: Simple Lens LensRules Bool+partialLenses      = lensFlags.contains PartialLenses --- | When building an singleton iso (or lens) for a record constructor, build both+-- | In the situations that a lens would be partial, when 'partialLenses' is+-- used, this flag instead causes traversals to be generated.  Only one can be+-- used, and if neither are, then compile-time errors are generated.+buildTraversals   :: Simple Lens LensRules Bool+buildTraversals    = lensFlags.contains BuildTraversals++-- | Handle singleton constructors specially.+handleSingletons  :: Simple Lens LensRules Bool+handleSingletons   = lensFlags.contains HandleSingletons++-- | When building a singleton 'Iso' (or 'Lens') for a record constructor, build both+-- the 'Iso' (or 'Lens') for the record and the one for the field. singletonAndField :: Simple Lens LensRules Bool singletonAndField  = lensFlags.contains SingletonAndField --- | Use Iso for singleton constructors-singletonIso :: Simple Lens LensRules Bool-singletonIso = lensFlags.contains SingletonIso+-- | Use 'Iso' for singleton constructors.+singletonIso      :: Simple Lens LensRules Bool+singletonIso       = lensFlags.contains SingletonIso  -- | Expect a single constructor, single field newtype or data type.-singletonRequired  :: Simple Lens LensRules Bool-singletonRequired   = lensFlags.contains SingletonRequired+singletonRequired :: Simple Lens LensRules Bool+singletonRequired  = lensFlags.contains SingletonRequired --- | Create the class if the constructor is simple and the 'lensClass' rule matches+-- | Create the class if the constructor is simple and the 'lensClass' rule matches. createClass       :: Simple Lens LensRules Bool createClass        = lensFlags.contains CreateClass --- | Create the instance if the constructor is simple and the 'lensClass' rule matches+-- | Create the instance if the constructor is simple and the 'lensClass' rule matches. createInstance    :: Simple Lens LensRules Bool createInstance     = lensFlags.contains CreateInstance --- | Die if the 'lensClass' fails to match+-- | Die if the 'lensClass' fails to match. classRequired     :: Simple Lens LensRules Bool classRequired      = lensFlags.contains ClassRequired --- | This configuration describes the options we'll be using to make isomorphisms or lenses++-- | This configuration describes the options we'll be using to make isomorphisms or lenses. data LensRules = LensRules   { _lensIso   :: String -> Maybe String   , _lensField :: String -> Maybe String@@ -106,37 +132,177 @@   , _lensFlags :: Set LensFlag   } --- | Lens to access the convention for naming top level isomorphisms in our lens rules+-- | Lens to access the convention for naming top level isomorphisms in our lens rules. -- -- Defaults to lowercasing the first letter of the constructor. lensIso :: Simple Lens LensRules (String -> Maybe String) lensIso f (LensRules i n c o) = (\i' -> LensRules i' n c o) <$> f i --- | Lens to access the convention for naming fields in our lens rules+-- | Lens to access the convention for naming fields in our lens rules. ----- Defaults to stripping the _ off of the field name and lowercasing the name and+-- Defaults to stripping the _ off of the field name, lowercasing the name, and -- rejecting the field if it doesn't start with an '_'. lensField :: Simple Lens LensRules (String -> Maybe String) lensField f (LensRules i n c o) = (\n' -> LensRules i n' c o) <$> f n --- | Retrieve options such as the name of the class and method to put in it to build a class around monomorphic data types.+-- | Retrieve options such as the name of the class and method to put in it to+-- build a class around monomorphic data types. lensClass :: Simple Lens LensRules (String -> Maybe (String, String)) lensClass f (LensRules i n c o) = (\c' -> LensRules i n c' o) <$> f c --- | Retrieve options such as the name of the class and method to put in it to build a class around monomorphic data types.+-- | Retrieve options such as the name of the class and method to put in it to+-- build a class around monomorphic data types. lensFlags :: Simple Lens LensRules (Set LensFlag) lensFlags f (LensRules i n c o) = LensRules i n c <$> f o  -- | Default lens rules defaultRules :: LensRules defaultRules = LensRules top field (const Nothing) $-    Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance]+    Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance, BuildTraversals]   where     top (c:cs) = Just (toLower c:cs)     top _      = Nothing     field ('_':c:cs) = Just (toLower c:cs)     field _          = Nothing +-- | Rules for making fairly simple partial lenses, ignoring the special cases+-- for isomorphisms and traversals, and not making any classes.+lensRules :: LensRules+lensRules+  = lensIso   .~ const Nothing+  $ lensClass .~ const Nothing+  $ handleSingletons .~ True+  $ partialLenses .~ False+  $ buildTraversals .~ True+  $ defaultRules++-- | Rules for making lenses and traversals that precompose another lens.+classyRules :: LensRules+classyRules+    = lensIso .~ const Nothing+    $ handleSingletons .~ False+    $ lensClass .~ classy+    $ classRequired .~ True+    $ partialLenses .~ False+    $ buildTraversals .~ True+    $ defaultRules+  where+    classy :: String -> Maybe (String, String)+    classy n@(a:as) = Just ("Has" ++ n, toLower a:as)+    classy _ = Nothing++-- | Rules for making an isomorphism from a data type+isoRules :: LensRules+isoRules+  = singletonRequired .~ True+  $ singletonAndField .~ True+  $ defaultRules++-- | Build lenses (and traversals) with a sensible default configuration.+--+-- > makeLenses = makeLensesWith lensRules+makeLenses :: Name -> Q [Dec]+makeLenses = makeLensesWith lensRules++-- | Make lenses and traversals for a type, and create a class when the type has no arguments.+--+-- /e.g./+--+-- @+-- data Foo = Foo { _fooX, _fooY :: 'Int' }+-- 'makeClassy' ''Foo+-- @+--+-- will create+--+-- @+-- class HasFoo t where+--   foo :: 'Simple' 'Lens' t Foo+-- instance HasFoo Foo where foo = 'id'+-- fooX, fooY :: HasFoo t => 'Simple' 'Lens' t 'Int'+-- @+--+-- > makeClassy = makeLensesWith classyRules+makeClassy :: Name -> Q [Dec]+makeClassy = makeLensesWith classyRules++-- | Make a top level isomorphism injecting /into/ the type.+--+-- The supplied name is required to be for a type with a single constructor that has a single argument+--+-- /e.g./+--+-- @+-- newtype List a = List [a]+-- makeIso ''List+-- @+--+-- will create+--+-- @+-- list :: Iso [a] [b] ('List' a) ('List' b)+-- @+--+-- > makeIso = makeLensesWith isoRules+makeIso :: Name -> Q [Dec]+makeIso = makeLensesWith isoRules++-- | Derive lenses and traversals, specifying explicit pairings of @(fieldName, lensName)@.+--+-- If you map multiple names to the same label, and it is present in the same constructor then this will generate a 'Traversal'.+--+-- /e.g./+--+-- > makeLensesFor [("_foo", "fooLens"), ("baz", "lbaz")] ''Foo+-- > makeLensesFor [("_barX", "bar"), ("_barY", "bar)] ''Bar+makeLensesFor :: [(String, String)] -> Name -> Q [Dec]+makeLensesFor fields = makeLensesWith+  $ lensField .~ (`Prelude.lookup` fields)+  $ lensRules++-- | Derive lenses and traversals, using a named wrapper class, and specifying+-- explicit pairings of @(fieldName, traversalName)@.+--+-- Example usage:+--+-- > makeClassyFor "HasFoo" "foo" [("_foo", "fooLens"), ("bar", "lbar")] ''Foo+makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec]+makeClassyFor clsName funName fields = makeLensesWith+  $ lensClass .~ const (Just (clsName,funName))+  $ lensField .~ (`Prelude.lookup` fields)+  $ classyRules++-- | Build lenses with a custom configuration.+makeLensesWith :: LensRules -> Name -> Q [Dec]+makeLensesWith cfg nm = do+    inf <- reify nm+    case inf of+      (TyConI decl) -> case deNewtype decl of+        (DataD ctx tyConName args cons _) -> case cons of+          [NormalC dataConName [(    _,ty)]]+            | cfg^.handleSingletons+             -> makeIsoLenses cfg ctx tyConName args dataConName Nothing ty++          [RecC    dataConName [(fld,_,ty)]]+            | cfg^.handleSingletons+             -> makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty++          _ | cfg^.singletonRequired+             -> fail "makeLensesWith: A single-constructor single-argument data type is required"++            | otherwise+             -> makeFieldLenses cfg ctx tyConName args cons++        _ -> fail "makeLensesWith: Unsupported data type"+      _ -> fail "makeLensesWith: Expected the name of a data type or newtype"+  where+    deNewtype (NewtypeD ctx tyConName args c d) = DataD ctx tyConName args [c] d+    deNewtype d = d++-----------------------------------------------------------------------------+-- Internal TH Implementation+-----------------------------------------------------------------------------+ -- | Given a set of names, build a map from those names to a set of fresh names based on them. freshMap :: Set Name -> Q (Map Name Name) freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n))@@ -220,12 +386,12 @@     let decl = SigD isoName $ quantified $ isoCon `apps`           if cfg^.simpleLenses then [aty,aty,cty,cty] else [aty,bty,cty,dty]     body <- makeBody isoName dataConName makeIsoFrom makeIsoTo-#if (MIN_VERSION_template_haskell(2,8,0)) && defined(NEW_INLINE_PRAGMAS)-    inlining <- pragInlD isoName Inline FunLike AllPhases+#ifndef INLINING+    return [decl, body] #else-    inlining <- pragInlD isoName $ inlineSpecNoPhase True False-#endif+    inlining <- inlinePragma isoName     return [decl, body, inlining]+#endif   accessorDecls <- case mkName <$> (maybeFieldName >>= view lensField cfg . nameBase) of     jfn@(Just lensName)       | (jfn /= maybeIsoName) && (isNothing maybeIsoName || cfg^.singletonAndField) -> do@@ -233,77 +399,53 @@                    if cfg^.simpleLenses then [cty,cty,aty,aty]                                         else [cty,dty,aty,bty]       body <- makeBody lensName dataConName makeIsoTo makeIsoFrom-#if (MIN_VERSION_template_haskell(2,8,0)) && defined(NEW_INLINE_PRAGMAS)-      inlining <- pragInlD lensName Inline FunLike AllPhases+#ifndef INLINING+      return [decl, body] #else-      inlining <- pragInlD lensName $ inlineSpecNoPhase True False-#endif+      inlining <- inlinePragma lensName       return [decl, body, inlining]+#endif     _ -> return []   return $ isoDecls ++ accessorDecls -data FieldDesc = FieldDesc-  { _fieldName                   :: Name-  , _fieldType                   :: Type-  , _fieldTypeVarsBoundElsewhere :: Set Name-  }--thd :: (a,b,c) -> c-thd (_,_,c) = c--fieldDescs :: Set Name -> [(Name,Strict,Type)] -> [FieldDesc]-fieldDescs acc ((nm,_,ty):rest) =-  FieldDesc nm ty (acc `Set.union` setOf typeVars (map thd rest)) :-  fieldDescs (acc `Set.union` setOf typeVars ty) rest-fieldDescs _ [] = []--conFieldDescs :: Con -> [FieldDesc]-conFieldDescs (RecC _ fields) = fieldDescs mempty fields-conFieldDescs _ = []--commonFieldDescs :: [Con] -> [FieldDesc]-commonFieldDescs = toList . Prelude.foldr walk Map.empty where-  walk con m = Prelude.foldr step m (conFieldDescs con)-  step d@(FieldDesc nm ty bds) m = case m^.at nm of-    Just (FieldDesc _ _ bds') -> at nm .~ Just (FieldDesc nm ty (bds `Set.union` bds')) $ m-    Nothing                   -> at nm .~ Just d                                        $ m--makeFieldLensBody :: Name -> Name -> [Con] -> Maybe Name -> Q Dec-makeFieldLensBody lensName fieldName cons maybeMethodName = case maybeMethodName of+makeFieldLensBody :: Bool -> Name -> [(Con, [Name])] -> Maybe Name -> Q Dec+makeFieldLensBody isTraversal lensName conList maybeMethodName = case maybeMethodName of     Just methodName -> do        go <- newName "go"        let expr = infixApp (varE methodName) (varE (mkName ".")) (varE go)-       funD lensName [ clause [] (normalB expr) [funD go (map clauses cons)] ]-    Nothing -> funD lensName (map clauses cons)+       funD lensName [ clause [] (normalB expr) [funD go clauses] ]+    Nothing -> funD lensName clauses   where-    clauses con = do-      let errorPats-            = [wildP, conP (con^.name) (replicate (lengthOf conFields con) wildP)]-          errorBody-            = normalB . appE (varE 'error) . litE . stringL-            $ show lensName ++ ": no matching field "-           ++ show fieldName ++ " in constructor "-           ++ show (con^.name)-          errorClause = clause errorPats errorBody []-      case con of-        (RecC conName fields) ->-          case List.findIndex (\(n,_,_) -> n == fieldName) fields of-            Just i -> do-              f     <- newName "f"-              x     <- newName "y"-              names <- for fields $ \(n,_,_) -> newName (nameBase n)-              let expr = appsE-                       [ return (VarE 'fmap)-                       , lamE [varP x] $ appsE $ conE conName : map varE (element i .~ x $ names)-                       , varE f `appE` varE (names^.element i)-                       ]-              clause [varP f, conP conName $ map varP names] (normalB expr) []-            Nothing -> errorClause-        _ -> errorClause+    clauses = map buildClause conList+    plainClause ps d = clause ps d []+    buildClause (con, fields) = do+      y <- newName "y"+      let allFields :: [Name]+          allFields = con^..conNamedFields._1+          conName = con^.name+          conWild = conP conName (replicate (length allFields) wildP) --- TODO: When there are constructors with missing fields, turn that field into a _traversal_ not a lens.--- TODO: When the supplied mapping function maps multiple different fields to the same name, try to unify them into a Traversal.--- TODO: Add support for precomposing a lens from a class onto all constructed lenses+      case isTraversal of+        True | List.null fields+          -> plainClause [wildP, y `asP` conWild] (normalB . appE (varE 'pure) $ varE y)+        False | length fields /= 1+          -> plainClause [wildP, conWild] . normalB . appE (varE 'error) . litE . stringL+           $ show lensName ++ ": expected a single matching field in " ++ show conName ++ ", found " ++ show (length fields)+        _ -> do+          vars <- for allFields $ \field ->+              if field `List.elem` fields+            then fmap Left $ (,) <$> newName (nameBase field) <*> newName (nameBase field ++ "'")+            else Right <$> newName (nameBase field)+          f     <- newName "f"+          let cpats = map (varP . either fst id) vars               -- Deconstruction+              cvals = map (varE . either snd id) vars               -- Reconstruction+              fpats = map (varP . snd)                 $ lefts vars -- Lambda patterns+              fvals = map (appE (varE f) . varE . fst) $ lefts vars -- Functor applications++              expr = uInfixE (lamE fpats . appsE $ conE conName : cvals) (varE '(<$>))+                   $ List.foldl1 (\l r -> uInfixE l (varE '(<*>)) r) fvals+          plainClause [varP f, conP conName cpats] (normalB expr)+ makeFieldLenses :: LensRules                 -> Cxt         -- ^ surrounding cxt driven by the data type context                 -> Name        -- ^ data/newtype constructor name@@ -312,15 +454,10 @@                 -> Q [Dec] makeFieldLenses cfg ctx tyConName tyArgs0 cons = do   let tyArgs = map plain tyArgs0-  x <- newName "x"-  let maybeLensClass = do+      maybeLensClass = do         guard $ tyArgs == []-        view lensClass cfg (nameBase tyConName)+        view lensClass cfg $ nameBase tyConName       maybeClassName = fmap (^._1.to mkName) maybeLensClass-      aty | isJust maybeClassName = VarT x-          | otherwise             = appArgs (ConT tyConName) tyArgs-      vs = setOf typeVars tyArgs-      fieldMap = commonFieldDescs cons   classDecls <- case maybeLensClass of     Nothing -> return []     Just (clsNameString, methodNameString) -> do@@ -335,134 +472,128 @@         ++ filter (\_ -> cfg^.createInstance)           [ instanceD (return []) (conT clsName `appT` conT tyConName)             [ funD methodName [clause [varP a] (normalB (varE a)) []]-#if (MIN_VERSION_template_haskell(2,8,0)) && defined(NEW_INLINE_PRAGMAS)-            , pragInlD methodName Inline FunLike AllPhases-#else-            , pragInlD methodName $ inlineSpecNoPhase True False+#ifdef INLINING+            , inlinePragma methodName #endif             ]]-  bodies <- for (toList fieldMap) $ \ (FieldDesc nm cty bds) ->-     case mkName <$> view lensField cfg (nameBase nm) of-       Nothing -> return []-       Just lensName -> do-         m <- freshMap $ Set.difference vs bds-         let bty = substTypeVars m aty-             dty = substTypeVars m cty-             s = setOf folded m-             relevantBndr b = s^.contains (b^.name)-             relevantCtx = not . Set.null . Set.intersection s . setOf typeVars-             tvs = tyArgs ++ filter relevantBndr (substTypeVars m tyArgs)-             ps = ctx ++ filter relevantCtx (substTypeVars m ctx)-             qs = case maybeClassName of-                Just n -> ClassP n [VarT x] : ps-                _      -> ps-             tvs' | isJust maybeClassName = PlainTV x : tvs-                  | otherwise             = tvs -         let decl = SigD lensName $ ForallT tvs' qs $-                    apps (ConT ''Lens) $-                    if cfg^.simpleLenses-                    then [aty,aty,cty,cty]-                    else [aty,bty,cty,dty]-         body <- makeFieldLensBody lensName nm cons $ fmap (mkName . view _2) maybeLensClass-#if (MIN_VERSION_template_haskell(2,8,0)) && defined(NEW_INLINE_PRAGMAS)-         inlining <- pragInlD lensName Inline FunLike AllPhases-#else-         inlining <- pragInlD lensName $ inlineSpecNoPhase True False-#endif-         return [decl, body, inlining]-  return $ classDecls ++ Prelude.concat bodies+  --TODO: there's probably a more efficient way to do this.+  lensFields <- map (\xs -> (fst $ head xs, map snd xs))+              . groupBy ((==) `on` fst) . sortBy (comparing fst) . concat+            <$> mapM (getLensFields $ view lensField cfg) cons --- | Build lenses with a custom configuration-makeLensesWith :: LensRules -> Name -> Q [Dec]-makeLensesWith cfg nm = reify nm >>= \inf -> case inf of-  TyConI dt -> case dt of-    NewtypeD ctx tyConName args (NormalC dataConName [(_,ty)])  _ | cfg^.handleSingletons ->-      makeIsoLenses cfg ctx tyConName args dataConName Nothing ty-    DataD ctx tyConName args [NormalC dataConName [(_,ty)]]  _    | cfg^.handleSingletons ->-      makeIsoLenses cfg ctx tyConName args dataConName Nothing ty-    NewtypeD ctx tyConName args (RecC dataConName [(fld,_,ty)]) _ | cfg^.handleSingletons ->-      makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty-    DataD ctx tyConName args [RecC dataConName [(fld,_,ty)]] _    | cfg^.handleSingletons ->-      makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty-    _ | cfg^.singletonRequired -> fail "makeLensesWith: A single-constructor single-argument data type is required"-    DataD ctx tyConName args dataCons _ ->-      makeFieldLenses cfg ctx tyConName args dataCons-    _ -> fail "Unsupported data type"-  _ -> fail "Expected the name of a data type or newtype"+  -- if not (cfg^.partialLenses) && not (cfg^.BuildTraversals)+  bodies <- for lensFields $ \(lensName, fields) -> do+    (tyArgs', cty) <- unifyTypes tyArgs $ map (view _3) fields+    let bds = setOf typeVars cty+    m <- freshMap $ Set.difference (setOf typeVars tyArgs') bds+    x <- newName "x"+    let aty | isJust maybeClassName = VarT x+            | otherwise             = appArgs (ConT tyConName) tyArgs'+        bty = substTypeVars m aty+        dty = substTypeVars m cty --- | Build lenses with a sensible default configuration------ > makeLenses = makeLensesWith lensRules-makeLenses :: Name -> Q [Dec]-makeLenses = makeLensesWith lensRules+        s = setOf folded m+        relevantBndr b = s^.contains (b^.name)+        relevantCtx = not . Set.null . Set.intersection s . setOf typeVars+        tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs')+        ps = ctx ++ filter relevantCtx (substTypeVars m ctx)+        qs = case maybeClassName of+           Just n -> ClassP n [VarT x] : ps+           _      -> ps+        tvs' | isJust maybeClassName = PlainTV x : tvs+             | otherwise             = tvs --- | Make a top level isomorphism injecting _into_ the type------ The supplied name is required to be for a type with a single constructor that has a single argument------ > makeIso = makeLensesWith isoRules-makeIso :: Name -> Q [Dec]-makeIso = makeLensesWith isoRules+        --TODO: Better way to write this?+        fieldMap = fromListWith (++) $ map (\(cn,fn,_) -> (cn, [fn])) fields+        conList = map (\c -> (c, Map.findWithDefault [] (view name c) fieldMap)) cons+        maybeMethodName = fmap (mkName . view _2) maybeLensClass --- | Rules for making an isomorphism from a data type-isoRules :: LensRules-isoRules-  = singletonRequired .~ True-  $ singletonAndField .~ True-  $ defaultRules+    isTraversal <- do+      let notSingular = filter ((/= 1) . length . snd) conList+      case (cfg^.buildTraversals, cfg^.partialLenses) of+        (True,  True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses."+        (False, True) -> return False+        (True,  False) | List.null notSingular -> return False+                       | otherwise -> return True+        (False, False) | List.null notSingular -> return False+                       | otherwise -> fail . unlines $+          [ "Cannot use 'makeLensesWith' with constructors that don't map just one field"+          , "to a lens, without using either the buildTraversals or partialLenses flags."+          , if length conList == 1+            then "The following constructor failed this criterion for the " ++ pprint lensName ++ " lens:"+            else "The following constructors failed this criterion for the " ++ pprint lensName ++ " lens:"+          ] ++ map (\(c, fs) -> pprint (view name c) ++ " { " ++ concat (intersperse ", " $ map pprint fs) ++ " }") conList --- | Make 'classy lenses' for a type------ > makeClassy = makeLensesWith classyRules-makeClassy :: Name -> Q [Dec]-makeClassy = makeLensesWith classyRules+    let decl = SigD lensName+             . ForallT tvs' qs+             . apps (if isTraversal then ConT ''Traversal else ConT ''Lens)+             $ if cfg^.simpleLenses then [aty,aty,cty,cty] else [aty,bty,cty,dty] --- | Rules for making lenses that precompose another lens.-classyRules :: LensRules-classyRules = lensIso .~ const Nothing-            $ handleSingletons .~ False-            $ lensClass .~ classy-            $ classRequired .~ True-            $ defaultRules+    body <- makeFieldLensBody isTraversal lensName conList maybeMethodName+#ifndef INLINING+    return [decl, body]+#else+    inlining <- inlinePragma lensName+    return [decl, body, inlining]+#endif+  return $ classDecls ++ Prelude.concat bodies -classy :: String -> Maybe (String, String)-classy n@(a:as) = Just ("Has" ++ n, toLower a:as)-classy _ = Nothing+-- | Gets @[(lens name, (constructor name, field name, type))]@ from a record constructor+getLensFields :: (String -> Maybe String) -> Con -> Q [(Name, (Name, Name, Type))]+getLensFields nameFunc (RecC cn fs)+  = return . catMaybes+  $ map (\(fn,_,t) -> (\ln -> (mkName ln, (cn,fn,t))) <$> nameFunc (nameBase fn)) fs+getLensFields _ _+  = warn "makeLensesWith: encountered a non-record constructor, for which no lenses will be generated."+  >> return [] --- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@.------ Example usage:+-- TODO: properly fill this out ----- > makeLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo-makeLensesFor :: [(String, String)] -> Name -> Q [Dec]-makeLensesFor fields = makeLensesWith-  $ lensField .~ (`Prelude.lookup` fields)-  $ lensRules+-- Ideally this would unify the different field types, and figure out which polymorphic variables+-- need to be the same.  For now it just leaves them the same and yields the first type.+-- (This leaves us open to inscrutable compile errors in the generated code)+unifyTypes :: [TyVarBndr] -> [Type] -> Q ([TyVarBndr], Type)+unifyTypes tvs tys = return (tvs, head tys) --- | Rules for making fairly simple lenses, ignoring the special cases for isomorphisms, and not making any classes.-lensRules :: LensRules-lensRules-  = lensIso   .~ const Nothing-  $ lensClass .~ const Nothing-  $ handleSingletons .~ True-  $ defaultRules+{-+fieldDescs :: Set Name -> [(Name,Strict,Type)] -> [FieldDesc]+fieldDescs acc ((nm,_,ty):rest) =+  FieldDesc nm ty (acc `Set.union` setOf typeVars (map thd rest)) :+  fieldDescs (acc `Set.union` setOf typeVars ty) rest+fieldDescs _ [] = []+-} --- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@--- using a wrapper class.------ Example usage:------ > makeClassyFor "HasFoo" "foo" [("_foo", "fooLens"), ("bar", "lbar")] ''Foo-makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec]-makeClassyFor clsName funName fields = makeLensesWith-  $ lensClass .~ const (Just (clsName,funName))-  $ lensField .~ (`Prelude.lookup` fields)-  $ classyRules+warn :: String -> Q ()+#if MIN_VERSION_template_haskell(2,8,0)+warn = reportWarning+#else+warn = report False+#endif  #if !(MIN_VERSION_template_haskell(2,7,0)) -- | The orphan instance for old versions is bad, but programing without 'Applicative' is worse. instance Applicative Q where   pure = return   (<*>) = ap+#endif++#ifdef INLINING++inlinePragma :: Name -> Q Dec+#if MIN_VERSION_template_haskell(2,8,0)++# ifdef OLD_INLINE_PRAGMAS+-- 7.6rc1?+inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase Inline False+# else+-- 7.7.20120830+inlinePragma methodName = pragInlD methodName Inline FunLike AllPhases+# endif++#else+-- GHC <7.6, TH <2.8.0+inlinePragma methodName = pragInlD methodName $ inlineSpecNoPhase True False+#endif+ #endif
src/Control/Lens/Type.hs view
@@ -122,8 +122,8 @@ -- @'Control.Lens.Setter.set' l c ('Control.Lens.Setter.set' l b a) = 'Control.Lens.Setter.set' l c a@ -- -- These laws are strong enough that the 4 type parameters of a 'Lens' cannot--- vary fully independently. For more on how they interact, read the "Why is--- it a Lens Family?" section of+-- vary fully independently. For more on how they interact, read the \"Why is+-- it a Lens Family?\" section of -- <http://comonad.com/reader/2012/mirrored-lenses/>. -- -- Every 'Lens' can be used directly as a 'Setter' or@@ -319,7 +319,7 @@  -- | Modify the target of a 'Lens' and return the result ----- When you do not need the result of the addition, ('Control.Lens.Setter.+~') is more flexible.+-- When you do not need the result of the addition, ('Control.Lens.Setter.%~') is more flexible. (<%~) :: LensLike ((,)d) a b c d -> (c -> d) -> a -> (d, b) l <%~ f = l $ \c -> let d = f c in (d, d) {-# INLINE (<%~) #-}
src/Control/Lens/WithIndex.hs view
@@ -35,6 +35,9 @@   , ifoldrM   , ifoldlM   , itoList+  -- * Converting to Folds+  , withIndices+  , indices   -- * Indexed Traversables   , TraversableWithIndex(..)   , itraversed@@ -44,12 +47,14 @@   , iforM   , imapAccumR   , imapAccumL+  , iwhere   ) where  import Control.Applicative import Control.Applicative.Backwards import Control.Monad (void, liftM) import Control.Monad.Trans.State.Lazy as Lazy+import Control.Lens.Fold import Control.Lens.Internal import Control.Lens.Indexed import Control.Lens.IndexedSetter@@ -150,7 +155,7 @@  -- | The 'IndexedFold' of a 'FoldableWithIndex' container. ifolded :: FoldableWithIndex i f => IndexedFold i (f a) a-ifolded = index $ \ f -> coerce . getGA . ifoldMap (\i -> GA . f i)+ifolded = index $ \ f -> coerce . getFolding . ifoldMap (\i -> Folding . f i) {-# INLINE ifolded #-}  -- | Obtain a 'Fold' by lifting an operation that returns a foldable result.@@ -279,10 +284,24 @@ -- -- @'toList' = 'map' 'fst' . 'itoList'@ itoList :: FoldableWithIndex i f => f a -> [(i,a)]-itoList = ifoldMap (\i c -> [(i,c)])+itoList = ifoldr (\i c -> ((i,c):)) [] {-# INLINE itoList #-}  -------------------------------------------------------------------------------+-- Converting to Folds+-------------------------------------------------------------------------------++-- | Fold a container with indices returning both the indices and the values.+withIndices :: FoldableWithIndex i f => Fold (f a) (i,a)+withIndices f = coerce . getFolding . ifoldMap (\i a -> Folding (f (i,a)))+{-# INLINE withIndices #-}++-- | Fold a container with indices returning only the indices.+indices :: FoldableWithIndex i f => Fold (f a) i+indices f = coerce . getFolding . ifoldMap (const . Folding . f)+{-# INLINE indices #-}++------------------------------------------------------------------------------- -- TraversableWithIndex ------------------------------------------------------------------------------- @@ -358,6 +377,15 @@ imapAccumL f s0 a = swap (Lazy.runState (forwards (itraverse (\i c -> Backwards (Lazy.state (\s -> swap (f i s c)))) a)) s0) {-# INLINE imapAccumL #-} +-- | Access the element of an indexed container where the index matches a predicate.+--+-- >>> :m + Control.Lens+-- >>> over (iwhere (>0)) Prelude.reverse $ ["He","was","stressed","o_O"]+-- ["He","saw","desserts","O_o"]+iwhere :: (TraversableWithIndex i t) => (i -> Bool) -> SimpleIndexedTraversal i (t a) a+iwhere p = index $ \f a -> itraverse (\i c -> if p i then f i c else pure c) a+{-# INLINE iwhere #-}+ ------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------@@ -401,16 +429,3 @@ skip :: a -> () skip _ = () {-# INLINE skip #-}---- | A monoid in a monad as a monoid-newtype GA f a = GA { getGA :: f a }--instance (Gettable f, Applicative f) => Monoid (GA f a) where-  mempty = GA noEffect-  {-# INLINE mempty #-}-  GA fr `mappend` GA fs = GA (fr *> fs)-  {-# INLINE mappend #-}--noEffect :: (Applicative f, Gettable f) => f a-noEffect = coerce $ pure ()-{-# INLINE noEffect #-}
src/Data/ByteString/Lazy/Lens.hs view
@@ -29,7 +29,6 @@ packedBytes :: Simple Iso [Word8] ByteString packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-}-{-# SPECIALIZE packedBytes :: Simple Lens [Word8] ByteString #-}  -- | Traverse the individual bytes in a 'ByteString' --@@ -51,7 +50,6 @@ packedChars :: Simple Iso String ByteString packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-}-{-# SPECIALIZE packedChars :: Simple Lens String ByteString #-}  -- | Traverse the individual bytes in a 'ByteString' as characters. --
src/Data/ByteString/Strict/Lens.hs view
@@ -28,7 +28,6 @@ packedBytes :: Simple Iso [Word8] ByteString packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-}-{-# SPECIALIZE packedBytes :: Simple Lens [Word8] ByteString #-}  -- | Traverse each 'Word8' in a 'ByteString' --@@ -50,7 +49,6 @@ packedChars :: Simple Iso String ByteString packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-}-{-# SPECIALIZE packedChars :: Simple Lens String ByteString #-}  -- | Traverse the individual bytes in a 'ByteString' as characters. --
src/Data/List/Lens.hs view
@@ -27,12 +27,18 @@   , traverseTail   , traverseInit   , traverseLast+  , (~:), (=:)+  , (<~:), (<=:)   ) where  import Control.Applicative import Control.Lens+import Control.Monad.State (MonadState, modify) import Data.List +infixr 4 ~:, <~:+infix 4 =:, <=:+ -- | A lens reading and writing to the head of a /non-empty/ list -- -- >>> [1,2,3]^._head@@ -149,3 +155,53 @@   [] -> pure []   as -> (++ [Prelude.last as]) <$> withIndex traverseList f (Prelude.init as) {-# INLINE traverseInit #-}++-- | Cons onto the list(s) referenced by a 'Setter'.+--+-- >>> 'h' ~: _1 $ ("ello","world")+-- ("hello","world")+--+-- @+-- ('~:') :: b -> 'Simple' 'Setter' a [b]    -> a -> a+-- ('~:') :: b -> 'Simple' 'Traversal' a [b] -> a -> a+-- ('~:') :: b -> 'Simple' 'Lens' a [b]      -> a -> a+-- ('~:') :: b -> 'Simple' 'Iso' a [b]       -> a -> a+-- @+(~:) :: c -> Setting a b [c] [c] -> a -> b+n ~: l = over l (n :)+{-# INLINE (~:) #-}++-- | Cons onto the list(s) referenced by a 'Setter' in your monad state+--+-- @+-- ('=:') :: 'MonadState' a m => c -> 'Simple' 'Setter' a [c]    -> m ()+-- ('=:') :: 'MonadState' a m => c -> 'Simple' 'Traversal' a [c] -> m ()+-- ('=:') :: 'MonadState' a m => c -> 'Simple' 'Lens' a [c]      -> m ()+-- ('=:') :: 'MonadState' a m => c -> 'Simple' 'Iso' a [c]       -> m ()+-- @+(=:) :: MonadState a m => c -> SimpleSetting a [c] -> m ()+n =: l = modify (n ~: l)+{-# INLINE (=:) #-}++-- | Cons onto the list(s) referenced by a 'Lens', returning the result.+--+-- >>> 'h' <~: _1 $ ("ello","world")+-- ("hello",("hello","world"))+--+-- @+-- ('\<~:') :: b -> 'Simple' 'Lens' a [b] -> a -> (b, a)+-- ('\<~:') :: b -> 'Simple' 'Iso' a [b]  -> a -> (b, a)+-- @+(<~:) :: c -> LensLike ((,)[c]) a b [c] [c] -> a -> ([c], b)+n <~: l = l <%~ (n :)+{-# INLINE (<~:) #-}++-- | Cons onto the list(s) referenced by a 'Lens' into your monad state, returning the result.+--+-- @+-- ('\<=:') :: 'MonadState' a m => 'Simple' 'Lens' a [c] -> c -> m ()+-- ('\<=:') :: 'MonadState' a m => 'Simple' 'Iso' a [c]  -> c -> m ()+-- @+(<=:) :: MonadState a m => c -> SimpleLensLike ((,)[c]) a [c] -> m [c]+n <=: l = l <%= (n :)+{-# INLINE (<=:) #-}
src/Data/Monoid/Lens.hs view
@@ -70,15 +70,11 @@ _dual :: Iso a b (Dual a) (Dual b) _dual = isos Dual getDual Dual getDual {-# INLINE _dual #-}-{-# SPECIALIZE _dual :: Functor f => Isomorphism (Dual a -> f (Dual b)) (a -> f b) #-}-{-# SPECIALIZE _dual :: Functor f => (Dual a -> f (Dual b)) -> a -> f b #-}  -- | Isomorphism for 'Endo' _endo :: Iso (a -> a) (b -> b) (Endo a) (Endo b) _endo = isos Endo appEndo Endo appEndo {-# INLINE _endo #-}-{-# SPECIALIZE _endo :: Functor f => Isomorphism (Endo a -> f (Endo b)) ((a -> a) -> f (b -> b)) #-}-{-# SPECIALIZE _endo :: Functor f => (Endo a -> f (Endo b)) -> (a -> a) -> f (b -> b) #-}  -- | Isomorphism for 'All' --@@ -92,8 +88,6 @@ _all :: Simple Iso Bool All _all = iso All getAll {-# INLINE _all #-}-{-# SPECIALIZE _all :: Functor f => Isomorphism (All -> f All) (Bool -> f Bool) #-}-{-# SPECIALIZE _all :: Functor f => (All -> f All) -> Bool -> f Bool #-}  -- | Isomorphism for 'Any' --@@ -107,8 +101,6 @@ _any :: Simple Iso Bool Any _any = iso Any getAny {-# INLINE _any #-}-{-# SPECIALIZE _any :: Functor f => Isomorphism (Any -> f Any) (Bool -> f Bool) #-}-{-# SPECIALIZE _any :: Functor f => (Any -> f Any) -> Bool -> f Bool #-}  -- | Isomorphism for 'Sum' --@@ -118,8 +110,6 @@ _sum :: Iso a b (Sum a) (Sum b) _sum = isos Sum getSum Sum getSum {-# INLINE _sum #-}-{-# SPECIALIZE _sum :: Functor f => Isomorphism (Sum a -> f (Sum b)) (a -> f b) #-}-{-# SPECIALIZE _sum :: Functor f => (Sum a -> f (Sum b)) -> a -> f b #-}  -- | Isomorphism for 'Product' --@@ -129,19 +119,13 @@ _product :: Iso a b (Product a) (Product b) _product = isos Product getProduct Product getProduct {-# INLINE _product #-}-{-# SPECIALIZE _product :: Functor f => Isomorphism (Product a -> f (Product b)) (a -> f b) #-}-{-# SPECIALIZE _product :: Functor f => (Product a -> f (Product b)) -> a -> f b #-}  -- | Isomorphism for 'First' _first :: Iso (Maybe a) (Maybe b) (First a) (First b) _first = isos First getFirst First getFirst {-# INLINE _first #-}-{-# SPECIALIZE _first :: Functor f => Isomorphism (First a -> f (First b)) (Maybe a -> f (Maybe b)) #-}-{-# SPECIALIZE _first :: Functor f => (First a -> f (First b)) -> Maybe a -> f (Maybe b) #-}  -- | Isomorphism for 'Last' _last :: Iso (Maybe a) (Maybe b) (Last a) (Last b) _last = isos Last getLast Last getLast {-# INLINE _last #-}-{-# SPECIALIZE _last :: Functor f => Isomorphism (Last a -> f (Last b)) (Maybe a -> f (Maybe b)) #-}-{-# SPECIALIZE _last :: Functor f => (Last a -> f (Last b)) -> Maybe a -> f (Maybe b) #-}
src/Data/Text/Lazy/Lens.hs view
@@ -27,7 +27,6 @@ packed :: Simple Iso String Text packed = iso pack unpack {-# INLINE packed #-}-{-# SPECIALIZE packed :: Simple Lens String Text #-}  -- | Traverse the individual characters in a 'Text'. --
src/Data/Text/Lens.hs view
@@ -37,13 +37,11 @@ instance IsText Strict.Text where   packed = Strict.packed   {-# INLINE packed #-}-  {-# SPECIALIZE packed :: Simple Lens String Strict.Text #-}   text = Strict.text   {-# INLINE text #-}  instance IsText Lazy.Text where   packed = Lazy.packed   {-# INLINE packed #-}-  {-# SPECIALIZE packed :: Simple Lens String Lazy.Text #-}   text = Lazy.text   {-# INLINE text #-}
src/Data/Text/Strict/Lens.hs view
@@ -26,7 +26,6 @@ packed :: Simple Iso String Text packed = iso pack unpack {-# INLINE packed #-}-{-# SPECIALIZE packed :: Simple Lens String Text #-}  -- | Traverse the individual characters in strict 'Text'. --
src/Language/Haskell/TH/Lens.hs view
@@ -22,6 +22,7 @@   , typeVars      -- :: HasTypeVars t => Simple Traversal t Name   , substTypeVars -- :: HasTypeVars t => Map Name Name -> t -> t   , conFields+  , conNamedFields   ) where  import Control.Applicative@@ -117,8 +118,13 @@  -- | Provides a 'Traversal' of the types of each field of a constructor. conFields :: Simple Traversal Con StrictType-conFields f (NormalC n tys)     = NormalC n <$> traverse f tys-conFields f (RecC n tys)        = RecC n <$> traverse sans_var tys+conFields f (NormalC n fs)      = NormalC n <$> traverse f fs+conFields f (RecC n fs)         = RecC n <$> traverse sans_var fs   where sans_var (fn,s,t) = (\(s', t') -> (fn,s',t')) <$> f (s, t) conFields f (InfixC l n r)      = InfixC <$> f l <*> pure n <*> f r conFields f (ForallC bds ctx c) = ForallC bds ctx <$> conFields f c++-- | 'Traversal' of the types of the /named/ fields of a constructor.+conNamedFields :: Simple Traversal Con VarStrictType+conNamedFields f (RecC n fs) = RecC n <$> traverse f fs+conNamedFields _ c = pure c
src/System/FilePath/Lens.hs view
@@ -11,7 +11,7 @@ module System.FilePath.Lens   ( (</>~), (<</>~), (<.>~), (<<.>~)   , (</>=), (<</>=), (<.>=), (<<.>=)-  , _basename, _directory, _extension, _filename+  , basename, directory, extension, filename   ) where  import Control.Applicative ((<$>))@@ -124,37 +124,37 @@  -- | A lens reading and writing to the basename. ----- >>> _basename .~ "filename" $ "path/name.png"+-- >>> basename .~ "filename" $ "path/name.png" -- "path/filename.png"-_basename :: Simple Lens FilePath FilePath-_basename f p = (<.> takeExtension p) . (takeDirectory p </>) <$> f (takeBaseName p)-{-# INLINE _basename #-}+basename :: Simple Lens FilePath FilePath+basename f p = (<.> takeExtension p) . (takeDirectory p </>) <$> f (takeBaseName p)+{-# INLINE basename #-}   -- | A lens reading and writing to the directory. ----- >>> "long/path/name.txt" ^. _directory+-- >>> "long/path/name.txt" ^. directory -- "long/path"-_directory :: Simple Lens FilePath FilePath-_directory f p = (</> takeFileName p) <$> f (takeDirectory p)-{-# INLINE _directory #-}+directory :: Simple Lens FilePath FilePath+directory f p = (</> takeFileName p) <$> f (takeDirectory p)+{-# INLINE directory #-}   -- | A lens reading and writing to the extension. ----- >>> _extension .~ ".png" $ "path/name.txt"+-- >>> extension .~ ".png" $ "path/name.txt" -- "path/name.png"-_extension :: Simple Lens FilePath FilePath-_extension f p = (n <.>) <$> f e+extension :: Simple Lens FilePath FilePath+extension f p = (n <.>) <$> f e  where   (n, e) = splitExtension p-{-# INLINE _extension #-}+{-# INLINE extension #-}   -- | A lens reading and writing to the full filename. ----- >>> _filename .~ "name.txt" $ "path/name.png"+-- >>> filename .~ "name.txt" $ "path/name.png" -- "path/name.txt"-_filename :: Simple Lens FilePath FilePath-_filename f p = (takeDirectory p </>) <$> f (takeFileName p)-{-# INLINE _filename #-}+filename :: Simple Lens FilePath FilePath+filename f p = (takeDirectory p </>) <$> f (takeFileName p)+{-# INLINE filename #-}