summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorryanglscott <>2018-01-28 16:52:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-01-28 16:52:00 (GMT)
commit472b7e182698d3f8d6452affc0d8b69983e4e874 (patch)
tree9c1d58799183d6ff922a73c30ada513329c6ed71
parentf292f3333980da3a0b7eead10626219a0c0545a3 (diff)
version 4.164.16
-rw-r--r--.travis.yml156
-rw-r--r--CHANGELOG.markdown35
-rw-r--r--README.markdown2
-rw-r--r--cabal.project2
-rw-r--r--examples/lens-examples.cabal8
-rw-r--r--lens-properties/CHANGELOG.markdown4
-rw-r--r--lens.cabal11
-rw-r--r--src/Control/Lens/Combinators.hs12
-rw-r--r--src/Control/Lens/Fold.hs44
-rw-r--r--src/Control/Lens/Internal/Fold.hs35
-rw-r--r--src/Control/Lens/Internal/Indexed.hs24
-rw-r--r--src/Control/Lens/Internal/Zoom.hs4
-rw-r--r--src/Control/Lens/Iso.hs6
-rw-r--r--src/Control/Lens/Reified.hs3
-rw-r--r--src/Control/Lens/Traversal.hs12
-rw-r--r--src/Control/Lens/Unsound.hs93
-rw-r--r--src/Language/Haskell/TH/Lens.hs17
-rw-r--r--src/Numeric/Natural/Lens.hs93
18 files changed, 496 insertions, 65 deletions
diff --git a/.travis.yml b/.travis.yml
index e2ca257..82b53e3 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,6 +1,6 @@
# This Travis job script has been generated by a script via
#
-# make_travis_yml_2.hs 'lens.cabal'
+# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-installed' 'cabal.project'
#
# For more information, see https://github.com/hvr/multi-ghc-travis
#
@@ -10,6 +10,14 @@ sudo: false
git:
submodules: false # whether to recursively clone submodules
+notifications:
+ irc:
+ channels:
+ - "irc.freenode.org#haskell-lens"
+ skip_join: true
+ template:
+ - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
+
cache:
directories:
- $HOME/.cabal/packages
@@ -24,70 +32,134 @@ before_cache:
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
+ - rm -rfv $HOME/.cabal/packages/head.hackage
+
addons:
apt:
packages: &apt_packages
- ghc-ppa-tools
+ - freeglut3-dev
- alex-3.1.7
- happy-1.19.5
matrix:
include:
- - compiler: "ghc-8.2.1"
- # env: TEST=--disable-tests BENCH=--disable-benchmarks
- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}}
- - compiler: "ghc-8.0.2"
+ - compiler: "ghc-7.4.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}
- - compiler: "ghc-7.10.3"
+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}
+ - compiler: "ghc-7.6.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}
+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}
- compiler: "ghc-7.8.4"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.8.4], sources: [hvr-ghc]}}
- - compiler: "ghc-7.6.3"
+ - compiler: "ghc-7.10.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.6.3], sources: [hvr-ghc]}}
- - compiler: "ghc-7.4.2"
+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.10.3], sources: [hvr-ghc]}}
+ - compiler: "ghc-8.0.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
- addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-7.4.2], sources: [hvr-ghc]}}
+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}
+ - compiler: "ghc-8.2.2"
+ # env: TEST=--disable-tests BENCH=--disable-benchmarks
+ addons: {apt: {packages: [*apt_packages,cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}
+ - compiler: "ghc-8.4.1"
+ env: GHCHEAD=true
+ addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}
+ - compiler: "ghc-head"
+ env: GHCHEAD=true
+ addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}}
+
+ allow_failures:
+ - compiler: "ghc-8.4.1"
+ - compiler: "ghc-head"
before_install:
- - HC=${CC}
- - unset CC
- - export HAPPYVER=1.19.5
- - export ALEXVER=3.1.7
- - export HLINTVER=2.0.9
- - mkdir ~/.hlint
- - curl -L https://github.com/ndmitchell/hlint/releases/download/v$HLINTVER/hlint-$HLINTVER-x86_64-linux.tar.gz | tar -xz --strip-components=1 -C ~/.hlint
- - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:~/.hlint:~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH
+ - HC=${CC}
+ - HCPKG=${HC/ghc/ghc-pkg}
+ - unset CC
+ - export HAPPYVER=1.19.5
+ - export ALEXVER=3.1.7
+ - export HLINTVER=2.0.9
+ - mkdir ~/.hlint
+ - curl -L https://github.com/ndmitchell/hlint/releases/download/v$HLINTVER/hlint-$HLINTVER-x86_64-linux.tar.gz | tar -xz --strip-components=1 -C ~/.hlint
+ - ROOTDIR=$(pwd)
+ - mkdir -p $HOME/.local/bin
+ - "PATH=~/.hlint:/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH"
+ - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
+ - echo $HCNUMVER
install:
- - cabal --version
- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
- - BENCH=${BENCH---enable-benchmarks}
- - TEST=${TEST---enable-tests}
- - travis_retry cabal update -v
- - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- - rm -fv cabal.project.local
- - rm -f cabal.project.freeze
- - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j
+ - cabal --version
+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - BENCH=${BENCH---enable-benchmarks}
+ - TEST=${TEST---enable-tests}
+ - HADDOCK=${HADDOCK-true}
+ - INSTALLED=${INSTALLED-true}
+ - GHCHEAD=${GHCHEAD-false}
+ - travis_retry cabal update -v
+ - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
+ - rm -fv cabal.project cabal.project.local
+ # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage
+ - |
+ if $GHCHEAD; then
+ sed -i.bak 's/-- allow-newer:.*/allow-newer: *:base, *:template-haskell, *:ghc, *:Cabal/' ${HOME}/.cabal/config
+
+ echo 'repository head.hackage' >> ${HOME}/.cabal/config
+ echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config
+ echo ' secure: True' >> ${HOME}/.cabal/config
+ echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config
+ echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config
+ echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config
+ echo ' key-threshold: 3' >> ${HOME}/.cabal.config
+
+ cabal new-update head.hackage -v
+ fi
+ - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
+ - "printf 'packages: \".\" \"./examples\" \"./lens-properties\"\\n' > cabal.project"
+ - cat cabal.project
+ - if [ -f "./configure.ac" ]; then
+ (cd "." && autoreconf -i);
+ fi
+ - if [ -f "./examples/configure.ac" ]; then
+ (cd "./examples" && autoreconf -i);
+ fi
+ - if [ -f "./lens-properties/configure.ac" ]; then
+ (cd "./lens-properties" && autoreconf -i);
+ fi
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
+ - rm -rf "."/.ghc.environment.* "./examples"/.ghc.environment.* "./lens-properties"/.ghc.environment.* "."/dist "./examples"/dist "./lens-properties"/dist
+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
# Here starts the actual work to be performed for the package under test;
# any command which exits with a non-zero exit code causes the build to fail.
script:
- - if [ -f configure.ac ]; then autoreconf -i; fi
- - rm -rf .ghc.environment.* dist/
- # build tests and benchmarks, run tests
- - cabal new-build -w ${HC} ${TEST} ${BENCH}
- - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH}; fi
- - hlint src --cpp-define=HLINT --cpp-ansi
+ # test that source-distributions can be generated
+ - (cd "." && cabal sdist)
+ - (cd "./examples" && cabal sdist)
+ - (cd "./lens-properties" && cabal sdist)
+ - mv "."/dist/lens-*.tar.gz "./examples"/dist/lens-examples-*.tar.gz "./lens-properties"/dist/lens-properties-*.tar.gz ${DISTDIR}/
+ - cd ${DISTDIR} || false
+ - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
+ - "printf 'packages: lens-*/*.cabal lens-examples-*/*.cabal lens-properties-*/*.cabal\\n' > cabal.project"
+ - cat cabal.project
-notifications:
- irc:
- channels:
- - "irc.freenode.org#haskell-lens"
- skip_join: true
- template:
- - "\x0313lens\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"
+
+ # build & run tests, build benchmarks
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} all
+ - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
+
+ # cabal check
+ - (cd lens-* && cabal check)
+ - (cd lens-examples-* && cabal check)
+ - (cd lens-properties-* && cabal check)
+
+ # haddock
+ - rm -rf ./dist-newstyle
+ - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
+
+ # hlint
+ - (cd lens-* && hlint src --cpp-define=HLINT --cpp-ansi)
+
+# REGENDATA ["-o",".travis.yml","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-installed","cabal.project"]
# EOF
diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
index 7a1308e..adb7522 100644
--- a/CHANGELOG.markdown
+++ b/CHANGELOG.markdown
@@ -1,3 +1,38 @@
+4.16 [2018.01.28]
+-----------------
+* The `Semigroup` instances for `Traversed` and `Sequenced` are now more
+ constrained (going from `Apply` to `Applicative` and `Monad`, respectively).
+ In GHC 8.4, `Semigroup` is a superclass of `Monoid`, therefore we'd need to
+ have `Apply` constraint in the `Monoid` instances. We opted to weaken our
+ ability to use `Apply` than to lose compatibility with third-party packages
+ that don't supply instances for `Apply`.
+
+ In practice this changes the (specialised) type signature of `traverseOf_`
+ ```diff+
+ - traverseOf_ :: Apply f => Fold1 s a -> (a -> f r) -> s -> f ()
+ + traverseOf_ :: Applicative f => Fold1 s a -> (a -> f r) -> s -> f ()
+ ```
+ and similarly for `forOf_` and `sequenceOf_`.
+
+ As part of this change, new combinators `traverse1Of_`, `for1Of_` and
+ `sequence1Of_` were added for `Apply`-only effects.
+
+ Similar instance context changes were made for `Folding` and `Effect`,
+ but these changes aren't publicly visible.
+
+* Add `Control.Lens.Unsound`, which exports unsound functionality for forming
+ products of lenses and sums of prisms.
+
+* Add `Numeric.Natural.Lens`, which export convenient isomorphisms for
+ natural numbers.
+
+* Add `Strict` instances for strict and lazy `ST`.
+
+* Adapt `Language.Haskell.TH.Lens` for `template-haskell-2.13` (bundled
+ with GHC 8.4).
+
+* Add `Semigroup` and `Monoid` instances for `Indexing`.
+
4.15.4
----
* `makeFields` and `declareFields` are now smarter with respect to type
diff --git a/README.markdown b/README.markdown
index 40d335c..bb74f12 100644
--- a/README.markdown
+++ b/README.markdown
@@ -1,7 +1,7 @@
Lens: Lenses, Folds, and Traversals
==================================
-[![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/lens) [![Build Status](https://secure.travis-ci.org/ekmett/lens.svg)](http://travis-ci.org/ekmett/lens)
+[![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/lens) [![Build Status](https://secure.travis-ci.org/ekmett/lens.svg)](http://travis-ci.org/ekmett/lens) [![Hackage Deps](https://img.shields.io/hackage-deps/v/lens.svg)](http://packdeps.haskellers.com/reverse/lens)
This package provides families of [lenses](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Type.hs), [isomorphisms](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Iso.hs), [folds](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Fold.hs), [traversals](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Traversal.hs), [getters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Getter.hs) and [setters](https://github.com/ekmett/lens/blob/master/src/Control/Lens/Setter.hs).
diff --git a/cabal.project b/cabal.project
index e6fdbad..b91f16f 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1 +1,3 @@
packages: .
+ ./examples
+ ./lens-properties
diff --git a/examples/lens-examples.cabal b/examples/lens-examples.cabal
index 82fae33..6c9427b 100644
--- a/examples/lens-examples.cabal
+++ b/examples/lens-examples.cabal
@@ -11,10 +11,12 @@ homepage: http://github.com/ekmett/lens/
bug-reports: http://github.com/ekmett/lens/issues
copyright: Copyright (C) 2012 Edward A. Kmett
synopsis: Lenses, Folds and Traversals
-description: Pong Example
+description: Lenses, Folds and Traversals
+ .
+ Pong Example
build-type: Simple
-tested-with: GHC == 7.4.1
+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1
source-repository head
type: git
@@ -28,7 +30,7 @@ executable lens-pong
buildable: False
build-depends:
- base,
+ base >= 4.5 && < 5,
containers >= 0.4 && < 0.6,
gloss >= 1.7 && < 1.12,
lens,
diff --git a/lens-properties/CHANGELOG.markdown b/lens-properties/CHANGELOG.markdown
index 5296bdc..9d7cfda 100644
--- a/lens-properties/CHANGELOG.markdown
+++ b/lens-properties/CHANGELOG.markdown
@@ -1,3 +1,7 @@
+4.11.1
+------
+* Update version bounds.
+
4.0
---
diff --git a/lens.cabal b/lens.cabal
index 9318723..ee48523 100644
--- a/lens.cabal
+++ b/lens.cabal
@@ -1,6 +1,6 @@
name: lens
category: Data, Lenses, Generics
-version: 4.15.4
+version: 4.16
license: BSD2
cabal-version: >= 1.8
license-file: LICENSE
@@ -12,7 +12,7 @@ bug-reports: http://github.com/ekmett/lens/issues
copyright: Copyright (C) 2012-2016 Edward A. Kmett
build-type: Custom
-- build-tools: cpphs
-tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1
+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1
synopsis: Lenses, Folds and Traversals
description:
This package comes \"Batteries Included\" with many useful lenses for the types
@@ -195,7 +195,7 @@ library
containers >= 0.4.0 && < 0.6,
distributive >= 0.3 && < 1,
filepath >= 1.2.0.0 && < 1.5,
- free >= 4 && < 5,
+ free >= 4 && < 6,
ghc-prim,
hashable >= 1.1.2.3 && < 1.3,
kan-extensions >= 5 && < 6,
@@ -219,6 +219,9 @@ library
if impl(ghc < 8.0)
build-depends: generic-deriving >= 1.10 && < 2
+ if impl(ghc < 7.9)
+ build-depends: nats >= 0.1 && < 1.2
+
exposed-modules:
Control.Exception.Lens
Control.Lens
@@ -268,6 +271,7 @@ library
Control.Lens.Traversal
Control.Lens.Tuple
Control.Lens.Type
+ Control.Lens.Unsound
Control.Lens.Wrapped
Control.Lens.Zoom
Control.Monad.Error.Lens
@@ -300,6 +304,7 @@ library
System.IO.Error.Lens
Language.Haskell.TH.Lens
Numeric.Lens
+ Numeric.Natural.Lens
other-modules:
Paths_lens
diff --git a/src/Control/Lens/Combinators.hs b/src/Control/Lens/Combinators.hs
index e99c9ae..c95d48a 100644
--- a/src/Control/Lens/Combinators.hs
+++ b/src/Control/Lens/Combinators.hs
@@ -1,3 +1,4 @@
+{-# Language CPP #-}
--------------------------------------------------------------------------------
-- |
-- Module : Control.Lens.Combinators
@@ -18,8 +19,7 @@ module Control.Lens.Combinators
) where
import Control.Lens hiding
- ( -- output from scripts/operators
- (<|)
+ ( (<|)
, (|>)
, (^..)
, (^?)
@@ -91,6 +91,8 @@ import Control.Lens hiding
, (%%@=)
, (<%@=)
, (<<%@=)
+ , (.@=)
+ , (.@~)
, (^#)
, ( #~ )
, ( #%~ )
@@ -109,6 +111,8 @@ import Control.Lens hiding
, (?~)
, (<.~)
, (<?~)
+ , (<<?~)
+ , (<<?=)
, (+~)
, (*~)
, (-~)
@@ -137,4 +141,8 @@ import Control.Lens hiding
, (<>=)
, (%@~)
, (%@=)
+#if __GLASGOW_HASKELL__ >= 710
+ , (:>)
+ , (:<)
+#endif
)
diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs
index 0a0d393..3e4b398 100644
--- a/src/Control/Lens/Fold.hs
+++ b/src/Control/Lens/Fold.hs
@@ -83,6 +83,7 @@ module Control.Lens.Fold
, andOf, orOf
, productOf, sumOf
, traverseOf_, forOf_, sequenceAOf_
+ , traverse1Of_, for1Of_, sequence1Of_
, mapMOf_, forMOf_, sequenceOf_
, asumOf, msumOf
, concatMapOf, concatOf
@@ -193,6 +194,7 @@ import Data.List.NonEmpty (NonEmpty(..))
-- >>> import Control.Exception (evaluate)
-- >>> import Data.Maybe (fromMaybe)
-- >>> import System.Timeout (timeout)
+-- >>> import qualified Data.Map as Map
-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g
-- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force
@@ -951,6 +953,48 @@ sequenceAOf_ :: Functor f => Getting (Traversed a f) s (f a) -> s -> f ()
sequenceAOf_ l = void . getTraversed #. foldMapOf l Traversed
{-# INLINE sequenceAOf_ #-}
+-- | Traverse over all of the targets of a 'Fold1', computing an 'Apply' based answer.
+--
+-- As long as you have 'Applicative' or 'Functor' effect you are better using 'traverseOf_'.
+-- The 'traverse1Of_' is useful only when you have genuine 'Apply' effect.
+--
+-- >>> traverse1Of_ both1 (\ks -> Map.fromList [ (k, ()) | k <- ks ]) ("abc", "bcd")
+-- fromList [('b',()),('c',())]
+--
+-- @
+-- 'traverse1Of_' :: 'Apply' f => 'Fold1' s a -> (a -> f r) -> s -> f ()
+-- @
+--
+-- @since 4.16
+traverse1Of_ :: Functor f => Getting (TraversedF r f) s a -> (a -> f r) -> s -> f ()
+traverse1Of_ l f = void . getTraversedF #. foldMapOf l (TraversedF #. f)
+{-# INLINE traverse1Of_ #-}
+
+-- | See 'forOf_' and 'traverse1Of_'.
+--
+-- >>> for1Of_ both1 ("abc", "bcd") (\ks -> Map.fromList [ (k, ()) | k <- ks ])
+-- fromList [('b',()),('c',())]
+--
+-- @
+-- 'for1Of_' :: 'Apply' f => 'Fold1' s a -> s -> (a -> f r) -> f ()
+-- @
+--
+-- @since 4.16
+for1Of_ :: Functor f => Getting (TraversedF r f) s a -> s -> (a -> f r) -> f ()
+for1Of_ = flip . traverse1Of_
+{-# INLINE for1Of_ #-}
+
+-- | See 'sequenceAOf_' and 'traverse1Of_'.
+--
+-- @
+-- 'sequence1Of_' :: 'Apply' f => 'Fold1' s (f a) -> s -> f ()
+-- @
+--
+-- @since 4.16
+sequence1Of_ :: Functor f => Getting (TraversedF a f) s (f a) -> s -> f ()
+sequence1Of_ l = void . getTraversedF #. foldMapOf l TraversedF
+{-# INLINE sequence1Of_ #-}
+
-- | Map each target of a 'Fold' on a structure to a monadic action, evaluate these actions from left to right, and ignore the results.
--
-- >>> mapMOf_ both putStrLn ("hello","world")
diff --git a/src/Control/Lens/Internal/Fold.hs b/src/Control/Lens/Internal/Fold.hs
index c0a47cb..cbe9e41 100644
--- a/src/Control/Lens/Internal/Fold.hs
+++ b/src/Control/Lens/Internal/Fold.hs
@@ -21,6 +21,7 @@ module Control.Lens.Internal.Fold
-- * Monoids for folding
Folding(..)
, Traversed(..)
+ , TraversedF(..)
, Sequenced(..)
, Max(..), getMax
, Min(..), getMin
@@ -53,8 +54,8 @@ import qualified Data.List.NonEmpty as NonEmpty
-- | A 'Monoid' for a 'Contravariant' 'Applicative'.
newtype Folding f a = Folding { getFolding :: f a }
-instance (Contravariant f, Apply f) => Semigroup (Folding f a) where
- Folding fr <> Folding fs = Folding (fr .> fs)
+instance (Contravariant f, Applicative f) => Semigroup (Folding f a) where
+ Folding fr <> Folding fs = Folding (fr *> fs)
{-# INLINE (<>) #-}
instance (Contravariant f, Applicative f) => Monoid (Folding f a) where
@@ -72,8 +73,9 @@ instance (Contravariant f, Applicative f) => Monoid (Folding f a) where
-- The argument 'a' of the result should not be used!
newtype Traversed a f = Traversed { getTraversed :: f a }
-instance Apply f => Semigroup (Traversed a f) where
- Traversed ma <> Traversed mb = Traversed (ma .> mb)
+-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
+instance Applicative f => Semigroup (Traversed a f) where
+ Traversed ma <> Traversed mb = Traversed (ma *> mb)
{-# INLINE (<>) #-}
instance Applicative f => Monoid (Traversed a f) where
@@ -83,16 +85,37 @@ instance Applicative f => Monoid (Traversed a f) where
{-# INLINE mappend #-}
------------------------------------------------------------------------------
+-- TraversedF
+------------------------------------------------------------------------------
+
+-- | Used internally by 'Control.Lens.Fold.traverse1Of_' and the like.
+--
+-- @since 4.16
+newtype TraversedF a f = TraversedF { getTraversedF :: f a }
+
+instance Apply f => Semigroup (TraversedF a f) where
+ TraversedF ma <> TraversedF mb = TraversedF (ma .> mb)
+ {-# INLINE (<>) #-}
+
+instance (Apply f, Applicative f) => Monoid (TraversedF a f) where
+ mempty = TraversedF (pure (error "TraversedF: value used"))
+ {-# INLINE mempty #-}
+ TraversedF ma `mappend` TraversedF mb = TraversedF (ma *> mb)
+ {-# INLINE mappend #-}
+
+------------------------------------------------------------------------------
-- Sequenced
------------------------------------------------------------------------------
-- | Used internally by 'Control.Lens.Traversal.mapM_' and the like.
--
-- The argument 'a' of the result should not be used!
+--
+-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
newtype Sequenced a m = Sequenced { getSequenced :: m a }
-instance Apply m => Semigroup (Sequenced a m) where
- Sequenced ma <> Sequenced mb = Sequenced (ma .> mb)
+instance Monad m => Semigroup (Sequenced a m) where
+ Sequenced ma <> Sequenced mb = Sequenced (ma >> mb)
{-# INLINE (<>) #-}
instance Monad m => Monoid (Sequenced a m) where
diff --git a/src/Control/Lens/Internal/Indexed.hs b/src/Control/Lens/Internal/Indexed.hs
index f9058b9..b424823 100644
--- a/src/Control/Lens/Internal/Indexed.hs
+++ b/src/Control/Lens/Internal/Indexed.hs
@@ -50,10 +50,12 @@ import Data.Distributive
import Data.Functor.Bind
import Data.Functor.Contravariant
import Data.Int
+import Data.Monoid
import Data.Profunctor.Closed
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
+import qualified Data.Semigroup as Semi
import Data.Traversable
import Prelude hiding ((.),id)
#ifndef SAFE
@@ -276,6 +278,28 @@ instance Contravariant f => Contravariant (Indexing f) where
(j, ff) -> (j, contramap f ff)
{-# INLINE contramap #-}
+instance Semi.Semigroup (f a) => Semi.Semigroup (Indexing f a) where
+ Indexing mx <> Indexing my = Indexing $ \i -> case mx i of
+ (j, x) -> case my j of
+ ~(k, y) -> (k, x Semi.<> y)
+ {-# INLINE (<>) #-}
+
+-- |
+--
+-- >>> "cat" ^@.. (folded <> folded)
+-- [(0,'c'),(1,'a'),(2,'t'),(0,'c'),(1,'a'),(2,'t')]
+--
+-- >>> "cat" ^@.. indexing (folded <> folded)
+-- [(0,'c'),(1,'a'),(2,'t'),(3,'c'),(4,'a'),(5,'t')]
+instance Monoid (f a) => Monoid (Indexing f a) where
+ mempty = Indexing $ \i -> (i, mempty)
+ {-# INLINE mempty #-}
+
+ mappend (Indexing mx) (Indexing my) = Indexing $ \i -> case mx i of
+ (j, x) -> case my j of
+ ~(k, y) -> (k, mappend x y)
+ {-# INLINE mappend #-}
+
-- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or
-- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc.
--
diff --git a/src/Control/Lens/Internal/Zoom.hs b/src/Control/Lens/Internal/Zoom.hs
index 7f16d80..913fb7a 100644
--- a/src/Control/Lens/Internal/Zoom.hs
+++ b/src/Control/Lens/Internal/Zoom.hs
@@ -287,8 +287,8 @@ instance Contravariant (Effect m r) where
contramap _ (Effect m) = Effect m
{-# INLINE contramap #-}
-instance (Apply m, Semigroup r) => Semigroup (Effect m r a) where
- Effect ma <> Effect mb = Effect (liftF2 (<>) ma mb)
+instance (Monad m, Semigroup r) => Semigroup (Effect m r a) where
+ Effect ma <> Effect mb = Effect (liftM2 (<>) ma mb)
{-# INLINE (<>) #-}
instance (Monad m, Monoid r) => Monoid (Effect m r a) where
diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs
index ddf991d..157b6db 100644
--- a/src/Control/Lens/Iso.hs
+++ b/src/Control/Lens/Iso.hs
@@ -104,6 +104,8 @@ import Control.Monad.Writer.Lazy as Lazy
import Control.Monad.Writer.Strict as Strict
import Control.Monad.RWS.Lazy as Lazy
import Control.Monad.RWS.Strict as Strict
+import Control.Monad.ST.Lazy as Lazy
+import Control.Monad.ST as Strict
import Data.Bifunctor
import Data.ByteString as StrictB hiding (reverse)
import Data.ByteString.Lazy as LazyB hiding (reverse)
@@ -451,6 +453,10 @@ instance Strict (Lazy.RWST r w s m a) (Strict.RWST r w s m a) where
strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST)
{-# INLINE strict #-}
+instance Strict (Lazy.ST s a) (Strict.ST s a) where
+ strict = iso Lazy.lazyToStrictST Lazy.strictToLazyST
+ {-# INLINE strict #-}
+
-- | An 'Iso' between the strict variant of a structure and its lazy
-- counterpart.
--
diff --git a/src/Control/Lens/Reified.hs b/src/Control/Lens/Reified.hs
index c5c0dc8..a3d04ce 100644
--- a/src/Control/Lens/Reified.hs
+++ b/src/Control/Lens/Reified.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -37,7 +38,9 @@ import Data.Profunctor.Closed
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
+#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
+#endif
-- $setup
-- >>> import Control.Lens
diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs
index dd8f761..e1244b9 100644
--- a/src/Control/Lens/Traversal.hs
+++ b/src/Control/Lens/Traversal.hs
@@ -230,11 +230,11 @@ type AnIndexedTraversal1' i s a = AnIndexedTraversal1 i s s a a
--
-- * a 'Traversal' if @f@ is 'Applicative',
--
--- * a 'Getter' if @f@ is only a 'Functor' and 'Contravariant',
+-- * a 'Getter' if @f@ is only a 'Functor' and 'Data.Functor.Contravariant.Contravariant',
--
--- * a 'Lens' if @p@ is only a 'Functor',
+-- * a 'Lens' if @f@ is only a 'Functor',
--
--- * a 'Fold' if @f@ is 'Functor', 'Contravariant' and 'Applicative'.
+-- * a 'Fold' if @f@ is 'Applicative' and 'Data.Functor.Contravariant.Contravariant'.
type Traversing p f s t a b = Over p (BazaarT p f a b) s t a b
type Traversing1 p f s t a b = Over p (BazaarT1 p f a b) s t a b
@@ -606,7 +606,7 @@ iunsafePartsOf' l = conjoined
-- Given a context you can use 'Control.Comonad.Store.Class.pos' to see the values, 'Control.Comonad.Store.Class.peek' at what the structure would be like with an edited result, or simply 'extract' the original structure.
--
-- @
--- propChildren l x = childrenOf l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holesOf' l x)
+-- propChildren l x = 'toListOf' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holesOf' l x)
-- propId l x = 'all' ('==' x) ['extract' w | w <- 'holesOf' l x]
-- @
--
@@ -1274,9 +1274,9 @@ infixl 5 `failing`
deepOf :: (Conjoined p, Applicative f) => LensLike f s t s t -> Traversing p f s t a b -> Over p f s t a b
deepOf r l = failing l (r . deepOf r l)
--- | "Fuse" a 'Traversal' by reassociating all of the '\<*\>' operations to the
+-- | "Fuse" a 'Traversal' by reassociating all of the '<*>' operations to the
-- left and fusing all of the 'fmap' calls into one. This is particularly
--- useful when constructing a 'Traversal' using operations from GHC.Generics.
+-- useful when constructing a 'Traversal' using operations from "GHC.Generics".
--
-- Given a pair of 'Traversal's 'foo' and 'bar',
--
diff --git a/src/Control/Lens/Unsound.hs b/src/Control/Lens/Unsound.hs
new file mode 100644
index 0000000..1994d2f
--- /dev/null
+++ b/src/Control/Lens/Unsound.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+
+#ifndef MIN_VERSION_mtl
+#define MIN_VERSION_mtl(x,y,z) 1
+#endif
+
+#if __GLASGOW_HASKELL__ < 708
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+{-# LANGUAGE RankNTypes #-}
+
+-------------------------------------------------------------------------------
+-- |
+-- Module : Control.Lens.Unsound
+-- Copyright : (C) 2012-16 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : provisional
+-- Portability : Rank2Types
+--
+-- One commonly asked question is: can we combine two lenses,
+-- @`Lens'` a b@ and @`Lens'` a c@ into @`Lens'` a (b, c)@.
+-- This is fair thing to ask, but such operation is unsound in general.
+-- See `lensProduct`.
+--
+-------------------------------------------------------------------------------
+module Control.Lens.Unsound
+ (
+ lensProduct
+ , prismSum
+ ) where
+
+import Control.Applicative
+import Control.Lens
+import Prelude
+
+-- | A lens product. There is no law-abiding way to do this in general.
+-- Result is only a valid 'Lens' if the input lenses project disjoint parts of
+-- the structure @s@. Otherwise "you get what you put in" law
+--
+-- @
+-- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l v s) ≡ v
+-- @
+--
+-- is violated by
+--
+-- >>> let badLens :: Lens' (Int, Char) (Int, Int); badLens = lensProduct _1 _1
+-- >>> view badLens (set badLens (1,2) (3,'x'))
+-- (2,2)
+--
+-- but we should get @(1,2)@.
+--
+-- Are you looking for 'Control.Lens.Lens.alongside'?
+--
+lensProduct :: ALens' s a -> ALens' s b -> Lens' s (a, b)
+lensProduct l1 l2 f s =
+ f (s ^# l1, s ^# l2) <&> \(a, b) -> s & l1 #~ a & l2 #~ b
+
+-- | A dual of `lensProduct`: a prism sum.
+--
+-- The law
+--
+-- @
+-- 'Control.Lens.Fold.preview' l ('Control.Lens.Review.review' l b) ≡ 'Just' b
+-- @
+--
+-- breaks with
+--
+-- >>> let badPrism :: Prism' (Maybe Char) (Either Char Char); badPrism = prismSum _Just _Just
+-- >>> preview badPrism (review badPrism (Right 'x'))
+-- Just (Left 'x')
+--
+-- We put in 'Right' value, but get back 'Left'.
+--
+-- Are you looking for 'Control.Lens.Prism.without'?
+--
+prismSum :: APrism s t a b
+ -> APrism s t c d
+ -> Prism s t (Either a c) (Either b d)
+prismSum k =
+ withPrism k $ \bt seta k' ->
+ withPrism k' $ \dt setb ->
+ prism (either bt dt) $ \s ->
+ f (Left <$> seta s) (Right <$> setb s)
+ where
+ f a@(Right _) _ = a
+ f (Left _) b = b
diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs
index a38dd07..a9bfdbc 100644
--- a/src/Language/Haskell/TH/Lens.hs
+++ b/src/Language/Haskell/TH/Lens.hs
@@ -229,9 +229,11 @@ module Language.Haskell.TH.Lens
#endif
-- ** FunDep Prisms TODO make a lens
, _FunDep
+#if !(MIN_VERSION_template_haskell(2,13,0))
-- ** FamFlavour Prisms
, _TypeFam
, _DataFam
+#endif
-- ** FixityDirection Prisms
, _InfixL
, _InfixR
@@ -275,6 +277,9 @@ module Language.Haskell.TH.Lens
#if MIN_VERSION_template_haskell(2,11,0)
, _UnboundVarE
#endif
+#if MIN_VERSION_template_haskell(2,13,0)
+ , _LabelE
+#endif
-- ** Body Prisms
, _GuardedB
, _NormalB
@@ -1689,6 +1694,7 @@ _FunDep
reviewer (x, y) = FunDep x y
remitter (FunDep x y) = (x, y)
+#if !(MIN_VERSION_template_haskell(2,13,0))
_TypeFam :: Prism' FamFlavour ()
_TypeFam
= prism' reviewer remitter
@@ -1704,6 +1710,7 @@ _DataFam
reviewer () = DataFam
remitter DataFam = Just ()
remitter _ = Nothing
+#endif
#if MIN_VERSION_template_haskell(2,9,0)
tySynEqnPatterns :: Lens' TySynEqn [Type]
@@ -1961,6 +1968,16 @@ _UnboundVarE
remitter _ = Nothing
#endif
+#if MIN_VERSION_template_haskell(2,13,0)
+_LabelE :: Prism' Exp String
+_LabelE
+ = prism' reviewer remitter
+ where
+ reviewer = LabelE
+ remitter (LabelE x) = Just x
+ remitter _ = Nothing
+#endif
+
_GuardedB :: Prism' Body [(Guard, Exp)]
_GuardedB
= prism' reviewer remitter
diff --git a/src/Numeric/Natural/Lens.hs b/src/Numeric/Natural/Lens.hs
new file mode 100644
index 0000000..aa3d089
--- /dev/null
+++ b/src/Numeric/Natural/Lens.hs
@@ -0,0 +1,93 @@
+{-# language CPP #-}
+{-# language RankNTypes #-}
+{-# language PatternGuards #-}
+#if __GLASGOW_HASKELL__ >= 710
+{-# language ViewPatterns #-}
+{-# language PatternSynonyms #-}
+#endif
+--------------------------------------------------------------------------------
+-- |
+-- Module : Numeric.Natural.Lens
+-- Copyright : (C) 2017 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : provisional
+-- Portability : portable
+--
+-- Useful tools for Gödel numbering.
+-------------------------------------------------------------------------------
+module Numeric.Natural.Lens
+ ( _Pair
+ , _Sum
+ , _Naturals
+#if __GLASGOW_HASKELL__ >= 710
+ , pattern Pair
+ , pattern Sum
+ , pattern Naturals
+#endif
+ ) where
+
+import Control.Lens
+import Numeric.Natural
+
+-- | The natural numbers are isomorphic to the product of the natural numbers with itself.
+--
+-- @N = N*N@
+_Pair :: Iso' Natural (Natural, Natural)
+_Pair = iso hither (uncurry yon) where
+ yon 0 0 = 0
+ yon m n = case quotRem m 2 of
+ (q,r) -> r + 2 * yon n q -- rotation
+
+ hither 0 = (0,0)
+ hither n = case quotRem n 2 of
+ (p,r) -> case hither p of
+ (x,y) -> (r+2*y,x) -- rotation
+
+-- | The natural numbers are isomorphic to disjoint sums of natural numbers embedded as
+-- evens or odds.
+--
+-- @N = 2*N@
+_Sum :: Iso' Natural (Either Natural Natural)
+_Sum = iso hither yon where
+ hither p = case quotRem p 2 of
+ (q,0) -> Left q
+ (q,1) -> Right q
+ _ -> error "_Sum: impossible"
+ yon (Left q) = 2*q
+ yon (Right q) = 2*q+1
+
+-- | The natural numbers are isomorphic to lists of natural numbers
+_Naturals :: Iso' Natural [Natural]
+_Naturals = iso hither yon where
+ hither 0 = []
+ hither n | (h, t) <- (n-1)^._Pair = h : hither t
+ yon [] = 0
+ yon (x:xs) = 1 + review _Pair (x, yon xs)
+
+#if __GLASGOW_HASKELL__ >= 710
+
+-- |
+-- interleaves the bits of two natural numbers
+pattern Pair :: Natural -> Natural -> Natural
+pattern Pair x y <- (view _Pair -> (x,y)) where
+ Pair x y = review _Pair (x,y)
+
+-- |
+-- @
+-- Sum (Left q) = 2*q
+-- Sum (Right q) = 2*q+1
+-- @
+pattern Sum :: Either Natural Natural -> Natural
+pattern Sum s <- (view _Sum -> s) where
+ Sum s = review _Sum s
+
+-- |
+-- @
+-- Naturals [] = 0
+-- Naturals (h:t) = 1 + Pair h (Naturals t)
+-- @
+pattern Naturals :: [Natural] -> Natural
+pattern Naturals xs <- (view _Naturals -> xs) where
+ Naturals xs = review _Naturals xs
+#endif