lens 4.17 → 4.17.1
raw patch · 33 files changed
+501/−220 lines, 33 filesdep ~call-stackdep ~hashabledep ~th-abstractionsetup-changed
Dependency ranges changed: call-stack, hashable, th-abstraction
Files
- .travis.yml +81/−95
- CHANGELOG.markdown +11/−0
- HLint.hs +2/−0
- Setup.lhs +8/−29
- examples/Plates.hs +9/−6
- examples/Pong.hs +31/−12
- examples/Turtle.hs +1/−1
- examples/lens-examples.cabal +24/−6
- include/lens-common.h +10/−0
- lens-properties/lens-properties.cabal +43/−0
- lens.cabal +50/−31
- src/Control/Lens/Cons.hs +2/−3
- src/Control/Lens/Each.hs +0/−1
- src/Control/Lens/Empty.hs +0/−1
- src/Control/Lens/Equality.hs +3/−1
- src/Control/Lens/Fold.hs +1/−1
- src/Control/Lens/Indexed.hs +0/−1
- src/Control/Lens/Internal/Bazaar.hs +0/−1
- src/Control/Lens/Internal/Context.hs +0/−2
- src/Control/Lens/Internal/Exception.hs +9/−2
- src/Control/Lens/Internal/Fold.hs +1/−1
- src/Control/Lens/Internal/Magma.hs +0/−1
- src/Control/Lens/Iso.hs +0/−1
- src/Control/Lens/Plated.hs +84/−2
- src/Control/Lens/Setter.hs +61/−7
- src/Control/Lens/Traversal.hs +46/−4
- src/Control/Lens/Tuple.hs +0/−1
- src/Control/Lens/Type.hs +11/−3
- src/Control/Lens/Wrapped.hs +8/−2
- src/Control/Lens/Zoom.hs +0/−1
- src/Data/Text/Lens.hs +0/−1
- src/Numeric/Lens.hs +1/−1
- tests/properties.hs +4/−2
.travis.yml view
@@ -1,11 +1,13 @@ # This Travis job script has been generated by a script via #-# runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project'+# haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' #-# For more information, see https://github.com/hvr/multi-ghc-travis+# For more information, see https://github.com/haskell-CI/haskell-ci #+# version: 0.2.1+# language: c-sudo: false+dist: xenial git: submodules: false # whether to recursively clone submodules@@ -24,120 +26,99 @@ - $HOME/.cabal/store before_cache:- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update'- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json- - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.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+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx -addons:- apt:- packages: &apt_packages- - ghc-ppa-tools- - freeglut3-dev- - alex-3.1.7- - happy-1.19.5+ - rm -rfv $CABALHOME/packages/head.hackage matrix: include:- - compiler: "ghc-8.6.1"- env: GHCHEAD=true- addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}}- - compiler: "ghc-8.4.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}+ - compiler: "ghc-8.6.4"+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4,freeglut3-dev], sources: [hvr-ghc]}}+ - compiler: "ghc-8.4.4"+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4,freeglut3-dev], sources: [hvr-ghc]}} - compiler: "ghc-8.2.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2,freeglut3-dev], sources: [hvr-ghc]}} - compiler: "ghc-8.0.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2,freeglut3-dev], sources: [hvr-ghc]}} - compiler: "ghc-7.10.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3,freeglut3-dev], sources: [hvr-ghc]}} - compiler: "ghc-7.8.4"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}}+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.8.4,freeglut3-dev], sources: [hvr-ghc]}} - compiler: "ghc-7.6.3"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}}+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.6.3,freeglut3-dev], sources: [hvr-ghc]}} - compiler: "ghc-7.4.2"- # env: TEST=--disable-tests BENCH=--disable-benchmarks- addons: {apt: {packages: [*apt_packages,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}}+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.4.2,freeglut3-dev], sources: [hvr-ghc]}} - compiler: "ghc-head" env: GHCHEAD=true- addons: {apt: {packages: [*apt_packages,cabal-install-head,ghc-head], sources: [hvr-ghc]}}+ addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head,freeglut3-dev], sources: [hvr-ghc]}} allow_failures: - compiler: "ghc-head"- - compiler: "ghc-8.6.1" before_install:- - HC=${CC}+ - HC=/opt/ghc/bin/${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+ - CABAL=/opt/ghc/bin/cabal+ - CABALHOME=$HOME/.cabal+ - export PATH="$CABALHOME/bin:$PATH" - 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+ - ${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}- - UNCONSTRAINED=${UNCONSTRAINED-true}- - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}+ - TEST=--enable-tests+ - BENCH=--enable-benchmarks - GHCHEAD=${GHCHEAD-false}- - travis_retry cabal update -v- - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"+ - travis_retry ${CABAL} update -v+ - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/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 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config- for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done+ sed -i 's/-- allow-newer: .*/allow-newer: *:base/' $CABALHOME/config+ for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" $CABALHOME/config; done - 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+ echo 'repository head.hackage' >> $CABALHOME/config+ echo ' url: http://head.hackage.haskell.org/' >> $CABALHOME/config+ echo ' secure: True' >> $CABALHOME/config+ echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> $CABALHOME/config+ echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> $CABALHOME/config+ echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> $CABALHOME/config+ echo ' key-threshold: 3' >> $CABALHOME.config - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'+ grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$' - cabal new-update head.hackage -v+ ${CABAL} new-update head.hackage -v fi- - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'- - "printf 'packages: \".\" \"./examples\" \"./lens-properties\"\\n' > cabal.project"+ - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'+ - if [ $HCNUMVER -eq 80604 ] ; then ${CABAL} new-install -w ${HC} -j2 hlint --constraint='hlint ==2.1.*' ; fi+ - rm -f cabal.project+ - touch cabal.project+ - "printf 'packages: \".\"\\n' >> cabal.project"+ - "printf 'packages: \"./examples\"\\n' >> cabal.project"+ - "printf 'packages: \"./lens-properties\"\\n' >> cabal.project"+ - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - touch cabal.project.local- - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(lens|lens-examples|lens-properties)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true- - 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+ - 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+ - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry+ - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"+ - rm "cabal.project.freeze"+ - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - rm -rf .ghc.environment.* "."/dist "./examples"/dist "./lens-properties"/dist - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) @@ -145,33 +126,38 @@ # any command which exits with a non-zero exit code causes the build to fail. script: # 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}/+ - ${CABAL} new-sdist all+ - mv dist-newstyle/sdist/*.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"+ - rm -f cabal.project+ - touch cabal.project+ - "printf 'packages: \"lens-*/*.cabal\"\\n' >> cabal.project"+ - "printf 'packages: \"lens-examples-*/*.cabal\"\\n' >> cabal.project"+ - "printf 'packages: \"lens-properties-*/*.cabal\"\\n' >> cabal.project"+ - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" - touch cabal.project.local- - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(lens|lens-examples|lens-properties)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true # 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} new-build -w ${HC} ${TEST} ${BENCH} all+ - if [ "x$TEST" = "x--enable-tests" ]; then ${CABAL} new-test -w ${HC} ${TEST} ${BENCH} all; fi + # hlint+ - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-* && hlint --cpp-ansi --cpp-define=HLINT src) ; fi+ - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-examples-* && hlint --cpp-ansi --cpp-define=HLINT .) ; fi+ - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-examples-* && hlint --cpp-ansi --cpp-define=HLINT .) ; fi+ - if [ $HCNUMVER -eq 80604 ] ; then (cd lens-properties-* && hlint --cpp-ansi --cpp-define=HLINT src) ; fi+ # cabal check- - (cd lens-* && cabal check)- - (cd lens-examples-* && cabal check)- - (cd lens-properties-* && 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)+ - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all -# REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"]+# REGENDATA ["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"] # EOF
CHANGELOG.markdown view
@@ -1,3 +1,14 @@+4.17.1 [2019.04.26]+-------------------+* Support `th-abstraction-0.3.0.0` or later.+* Only incur `semigroups` and `void` dependencies on old GHCs.+* Add `holes1Of`.+* Add `locally` (https://github.com/ekmett/lens/pull/829).+* Add `ilocally` (https://github.com/ekmett/lens/pull/836).+* Add a third `Prism` law.+* Add `gplate1`.+* Add `Wrapped`/`Rewrapped` instances for `Data.Monoid.Ap`.+ 4.17 [2018.07.03] ----------------- * Allow building with GHC 8.6.
HLint.hs view
@@ -5,6 +5,8 @@ ignore "Use >=>" ignore "Use const" ignore "Use module export list"+ignore "Use lambda-case"+ignore "Use tuple-section" -- Used hlint --find src/ in the lens repo to generate this: infixl 9 :>
Setup.lhs view
@@ -1,24 +1,17 @@ \begin{code} {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif --- haddock stuff-import Distribution.Package ( Package (..), packageName )-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Setup (Flag (..), HaddockFlags, haddockDistPref)-import Distribution.Simple.Utils (copyFiles)-import Distribution.Verbosity (normal)-import Distribution.Text ( display )-import System.FilePath ( (</>) )- #if MIN_VERSION_cabal_doctest(1,0,0) -import Distribution.Extra.Doctest ( doctestsUserHooks )+import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests" #else @@ -31,25 +24,11 @@ import Warning () #endif -doctestsUserHooks :: String -> UserHooks-doctestsUserHooks _ = simpleUserHooks--#endif--haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath-haddockOutputDir flags pkg = destDir where- baseDir = case haddockDistPref flags of- NoFlag -> "."- Flag x -> x- destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)+import Distribution.Simple main :: IO ()-main = defaultMainWithHooks duh- { postHaddock = \args flags pkg lbi -> do- copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]- postHaddock duh args flags pkg lbi- }- where- duh = doctestsUserHooks "doctests"+main = defaultMain++#endif \end{code}
examples/Plates.hs view
@@ -1,23 +1,26 @@-{-# LANGUAGE MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveGeneric, DeriveDataTypeable #-}+module Plates where++#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative+#endif import Control.Lens import GHC.Generics import Data.Data-import Data.Data.Lens data Expr = Var Int | Pos Expr String | Neg Expr | Add Expr Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) data Stmt = Seq [Stmt] | Sel [Expr] | Let String Expr deriving (Eq,Ord,Show,Read,Generic,Data,Typeable) instance Plated Expr where- plate f (Var x ) = pure (Var x)+ plate _ (Var x ) = pure (Var x) plate f (Pos x y) = Pos <$> f x <*> pure y plate f (Neg x ) = Neg <$> f x plate f (Add x y) = Add <$> f x <*> f y instance Plated Stmt where- plate f (Seq xs) = Seq <$> traverse f xs- plate f (Sel xs) = pure (Sel xs)- plate f (Let x y) = pure (Let x y)+ plate f (Seq xs) = Seq <$> traverse f xs+ plate _ (Sel xs) = pure (Sel xs)+ plate _ (Let x y) = pure (Let x y) exprs :: Traversal' Stmt Expr exprs f (Seq xs) = Seq <$> traverse (exprs f) xs
examples/Pong.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-}+{-# LANGUAGE CPP, TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- | -- Module : Main@@ -12,14 +12,17 @@ ----------------------------------------------------------------------------- module Main where -import Control.Applicative ((<$>), (<*>))-import Control.Lens+#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ((<$>))+#endif+import Control.Lens hiding ((:>), at) import Control.Monad.State (State, execState, get) import Control.Monad (when) -import Data.Set (Set, member, empty, insert, delete)+import Data.Set (Set, empty)+import Data.Stream.Infinite (Stream(..)) -import Graphics.Gloss+import Graphics.Gloss hiding (display) import qualified Graphics.Gloss.Data.Point.Arithmetic as Pt import Graphics.Gloss.Interface.Pure.Game @@ -27,9 +30,15 @@ -- Some global constants +gameSize :: Float gameSize = 300++windowWidth, windowHeight :: Int windowWidth = 800 windowHeight = 600++ballRadius, speedIncrease, losingAccuracy, winningAccuracy,+ initialSpeed, paddleWidth, paddleHeight, paddleSpeed :: Float ballRadius = 0.02 speedIncrease = 1.2 losingAccuracy = 0.9@@ -38,6 +47,8 @@ paddleWidth = 0.02 paddleHeight = 0.3 paddleSpeed = 1++textSize :: Float textSize = 0.001 -- Pure data type for representing the game state@@ -48,7 +59,7 @@ , _paddle1 :: Float , _paddle2 :: Float , _score :: (Int, Int)- , _vectors :: [Vector]+ , _vectors :: Stream Vector -- Since gloss doesn't cover this, we store the set of pressed keys , _keys :: Set Key@@ -58,11 +69,14 @@ makeLenses ''Pong -- Renamed tuple lenses for enhanced clarity with points/vectors+_x :: Field1 s t a b => Lens s t a b _x = _1++_y :: Field2 s t a b => Lens s t a b _y = _2 initial :: Pong-initial = Pong (0, 0) (0, 0) 0 0 (0, 0) [] empty+initial = Pong (0, 0) (0, 0) 0 0 (0, 0) (return (0, 0)) empty -- Calculate the y position at which the ball will next hit (on player2's side) hitPos :: Point -> Vector -> Float@@ -174,7 +188,7 @@ -- Retrieve a speed from the list, dropping it in the process nextSpeed :: State Pong Vector nextSpeed = do- v:vs <- use vectors+ v:>vs <- use vectors vectors .= vs return v @@ -192,7 +206,7 @@ ] where paddleX = 1 + paddleWidth/2- p `at` (x,y) = translate x y p; infixr 1 `at`+ po `at` (x,y) = translate x y po; infixr 1 `at` drawPaddle :: Picture drawPaddle = rectangleSolid paddleWidth paddleHeight@@ -211,8 +225,9 @@ -- The main program action +main :: IO () main = do- v:vs <- startingSpeeds+ v:>vs <- startingSpeeds let world = ballSpeed .~ v $ vectors .~ vs $ initial play display backColor fps world draw handle update @@ -223,12 +238,16 @@ -- Generate the random list of starting speeds -startingSpeeds :: IO [Vector]+startingSpeeds :: IO (Stream Vector) startingSpeeds = do rs <- randomRs (-initialSpeed, initialSpeed) <$> newStdGen- return . interleave $ filter ((> 0.2) . abs) rs+ return . listToStream . interleave $ filter ((> 0.2) . abs) rs where interleave :: [a] -> [(a,a)] interleave (x:y:xs) = (x,y) : interleave xs interleave _ = []++ -- Assumes the list is infinite.+ listToStream :: [a] -> Stream a+ listToStream = foldr (:>) (error "Finite list")
examples/Turtle.hs view
@@ -11,7 +11,7 @@ module Turtle where import Control.Lens-import Data.Default+import Data.Default.Class data Point = Point { __x, __y :: Double
examples/lens-examples.cabal view
@@ -2,7 +2,7 @@ category: Data, Lenses version: 0.1 license: BSD3-cabal-version: >= 1.8+cabal-version: >= 1.10 license-file: LICENSE author: Niklas Haas maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -22,8 +22,8 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2- , GHC == 8.4.3- , GHC == 8.6.1+ , GHC == 8.4.4+ , GHC == 8.6.4 source-repository head type: git@@ -32,15 +32,33 @@ flag pong default: True +library+ exposed-modules:+ Aeson+ Plates+ Turtle+ build-depends:+ aeson,+ base >= 4.5 && < 5,+ bytestring >= 0.9.1.10 && < 0.11,+ data-default-class,+ ghc-prim,+ lens+ default-language: Haskell2010+ ghc-options: -Wall+ executable lens-pong if !flag(pong) buildable: False build-depends: base >= 4.5 && < 5,- containers >= 0.4 && < 0.6,- gloss >= 1.12 && < 1.13,+ containers >= 0.4 && < 0.7,+ gloss >= 1.12 && < 1.14, lens, mtl >= 2.0.1 && < 2.3,- random >= 1.0 && < 1.2+ random >= 1.0 && < 1.2,+ streams >= 3.3 && < 4 main-is: Pong.hs+ default-language: Haskell2010+ ghc-options: -Wall
+ include/lens-common.h view
@@ -0,0 +1,10 @@+#ifndef LENS_COMMON_H+#define LENS_COMMON_H++#if __GLASGOW_HASKELL__ >= 806+# define KVS(kvs) kvs+#else+# define KVS(kvs)+#endif++#endif
+ lens-properties/lens-properties.cabal view
@@ -0,0 +1,43 @@+name: lens-properties+category: Data, Lenses+version: 4.11.1+license: BSD3+cabal-version: >= 1.8+license-file: LICENSE+author: Edward Kmett and Oliver Charles+maintainer: Edward Kmett <ekmett@gmail.com>+stability: provisional+homepage: http://github.com/ekmett/lens/+bug-reports: http://github.com/ekmett/lens/issues+copyright: Copyright (C) 2012-2015 Edward A. Kmett, Copyright (C) 2014 Oliver Charles+synopsis: QuickCheck properties for lens+description: QuickCheck properties for lens.+build-type: Simple+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.4+ , GHC == 8.6.4++extra-source-files:+ .hlint.yaml+ CHANGELOG.markdown++source-repository head+ type: git+ location: git://github.com/ekmett/lens.git++library+ build-depends:+ base >= 4.5 && < 5,+ lens >= 4 && < 5,+ QuickCheck >= 2.4 && < 2.14,+ transformers >= 0.2 && < 0.6++ exposed-modules:+ Control.Lens.Properties++ hs-source-dirs: src
lens.cabal view
@@ -1,8 +1,8 @@ name: lens category: Data, Lenses, Generics-version: 4.17+version: 4.17.1 license: BSD2-cabal-version: >= 1.8+cabal-version: 1.18 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -18,8 +18,8 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2- , GHC == 8.4.3- , GHC == 8.6.1+ , GHC == 8.4.4+ , GHC == 8.6.4 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types@@ -103,10 +103,11 @@ examples/lens-examples.cabal examples/*.hs examples/*.lhs- images/*.png+ include/*.h lens-properties/CHANGELOG.markdown lens-properties/LICENSE lens-properties/Setup.hs+ lens-properties/lens-properties.cabal travis/cabal-apt-install travis/config HLint.hs@@ -115,6 +116,8 @@ CHANGELOG.markdown README.markdown SUPPORT.markdown+extra-doc-files:+ images/*.png source-repository head type: git@@ -212,22 +215,24 @@ profunctors >= 5.2.1 && < 6, reflection >= 2.1 && < 3, semigroupoids >= 5 && < 6,- semigroups >= 0.8.4 && < 1, tagged >= 0.4.4 && < 1, template-haskell >= 2.4 && < 2.15,- th-abstraction >= 0.2.1 && < 0.3,+ th-abstraction >= 0.2.1 && < 0.4, text >= 0.11 && < 1.3, transformers >= 0.2 && < 0.6, transformers-compat >= 0.4 && < 1, unordered-containers >= 0.2.4 && < 0.3,- vector >= 0.9 && < 0.13,- void >= 0.5 && < 1+ vector >= 0.9 && < 0.13 if impl(ghc < 8.0)- build-depends: generic-deriving >= 1.10 && < 2+ build-depends:+ generic-deriving >= 1.10 && < 2,+ semigroups >= 0.8.4 && < 1 if impl(ghc < 7.9)- build-depends: nats >= 0.1 && < 1.2+ build-depends:+ nats >= 0.1 && < 1.2,+ void >= 0.5 && < 1 exposed-modules: Control.Exception.Lens@@ -345,6 +350,10 @@ hs-source-dirs: src + include-dirs: include++ default-language: Haskell2010+ -- Verify that Template Haskell expansion works test-suite templates type: exitcode-stdio-1.0@@ -352,6 +361,7 @@ other-modules: T799 ghc-options: -Wall -threaded hs-source-dirs: tests+ default-language: Haskell2010 if flag(dump-splices) ghc-options: -ddump-splices@@ -371,6 +381,8 @@ hs-source-dirs: tests lens-properties/src+ include-dirs: include+ default-language: Haskell2010 if !flag(test-properties) buildable: False else@@ -388,6 +400,7 @@ main-is: hunit.hs ghc-options: -w -threaded -rtsopts -with-rtsopts=-N hs-source-dirs: tests+ default-language: Haskell2010 if !flag(test-hunit) buildable: False@@ -408,6 +421,7 @@ main-is: doctests.hs ghc-options: -Wall -threaded hs-source-dirs: tests+ default-language: Haskell2010 x-doctest-options: --fast if flag(trustworthy) && impl(ghc>=7.2)@@ -438,10 +452,11 @@ -- Basic benchmarks for the uniplate-style combinators benchmark plated- type: exitcode-stdio-1.0- main-is: plated.hs- ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields- hs-source-dirs: benchmarks+ type: exitcode-stdio-1.0+ main-is: plated.hs+ ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields+ hs-source-dirs: benchmarks+ default-language: Haskell2010 build-depends: base, comonad,@@ -457,10 +472,11 @@ -- Benchmarking alongside variants benchmark alongside- type: exitcode-stdio-1.0- main-is: alongside.hs- ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields- hs-source-dirs: benchmarks+ type: exitcode-stdio-1.0+ main-is: alongside.hs+ ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields+ hs-source-dirs: benchmarks+ default-language: Haskell2010 build-depends: base, comonad >= 4,@@ -471,10 +487,11 @@ -- Benchmarking folds benchmark folds- type: exitcode-stdio-1.0- main-is: folds.hs- ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields- hs-source-dirs: benchmarks+ type: exitcode-stdio-1.0+ main-is: folds.hs+ ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields+ hs-source-dirs: benchmarks+ default-language: Haskell2010 build-depends: base, criterion,@@ -486,10 +503,11 @@ -- Benchmarking traversals benchmark traversals- type: exitcode-stdio-1.0- main-is: traversals.hs- ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields- hs-source-dirs: benchmarks+ type: exitcode-stdio-1.0+ main-is: traversals.hs+ ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields+ hs-source-dirs: benchmarks+ default-language: Haskell2010 build-depends: base, criterion,@@ -502,10 +520,11 @@ -- Benchmarking unsafe implementation strategies benchmark unsafe- type: exitcode-stdio-1.0- main-is: unsafe.hs- ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields- hs-source-dirs: benchmarks+ type: exitcode-stdio-1.0+ main-is: unsafe.hs+ ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields+ hs-source-dirs: benchmarks+ default-language: Haskell2010 build-depends: base, comonad >= 4,
src/Control/Lens/Cons.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} #ifdef TRUSTWORTHY@@ -125,7 +124,7 @@ {-# INLINE _Cons #-} instance Cons (ZipList a) (ZipList b) a b where- _Cons = withPrism listCons $ \listReview listPreview -> + _Cons = withPrism listCons $ \listReview listPreview -> prism (coerce' listReview) (coerce' listPreview) where listCons :: Prism [a] [b] (a, [a]) (b, [b])@@ -359,7 +358,7 @@ {-# INLINE _Snoc #-} instance Snoc (ZipList a) (ZipList b) a b where- _Snoc = withPrism listSnoc $ \listReview listPreview -> + _Snoc = withPrism listSnoc $ \listReview listPreview -> prism (coerce' listReview) (coerce' listPreview) where listSnoc :: Prism [a] [b] ([a], a) ([b], b)
src/Control/Lens/Each.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY
src/Control/Lens/Empty.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE DefaultSignatures #-} #ifdef TRUSTWORTHY
src/Control/Lens/Equality.hs view
@@ -42,6 +42,8 @@ -- $setup -- >>> import Control.Lens +#include "lens-common.h"+ ----------------------------------------------------------------------------- -- Equality -----------------------------------------------------------------------------@@ -73,7 +75,7 @@ -- | We can use 'Equality' to do substitution into anything. #if __GLASGOW_HASKELL__ >= 706-mapEq :: forall (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> *) . AnEquality s t a b -> f s -> f a+mapEq :: forall KVS(k1 k2) (s :: k1) (t :: k2) (a :: k1) (b :: k2) (f :: k1 -> *) . AnEquality s t a b -> f s -> f a #else mapEq :: AnEquality s t a b -> f s -> f a #endif
src/Control/Lens/Fold.hs view
@@ -339,7 +339,7 @@ go a = g a .> go (f a) {-# INLINE iterated #-} --- | Obtain an 'Fold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal').+-- | Obtain a 'Fold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). -- -- Note: This is /not/ a legal 'Traversal', unless you are very careful not to invalidate the predicate on the target. --
src/Control/Lens/Indexed.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #ifdef TRUSTWORTHY
src/Control/Lens/Internal/Bazaar.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-}
src/Control/Lens/Internal/Context.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-}
src/Control/Lens/Internal/Exception.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -190,7 +189,15 @@ showsPrec d _ = showParen (d > 10) $ showString "Handling ..." {-# INLINE showsPrec #-} -instance (Reifies s (SomeException -> Maybe a), Typeable (Handling a s m)) => Exception (Handling a s m) where+instance ( Reifies s (SomeException -> Maybe a)+ , Typeable a, Typeable s+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+ , Typeable m+#else+ , Typeable1 m+#endif+ )+ => Exception (Handling a (s :: *) m) where toException _ = SomeException HandlingException {-# INLINE toException #-} fromException = fmap Handling . reflect (Proxy :: Proxy s)
src/Control/Lens/Internal/Fold.hs view
@@ -192,7 +192,7 @@ -- Leftmost and Rightmost ------------------------------------------------------------------------------ --- | Used for 'Control.Lens.Fold.preview'.+-- | Used for 'Control.Lens.Fold.firstOf'. data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) instance Semigroup (Leftmost a) where
src/Control/Lens/Internal/Magma.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}
src/Control/Lens/Iso.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-}
src/Control/Lens/Plated.hs view
@@ -6,6 +6,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE PolyKinds #-} -- gplate1+#endif+ #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPING_PRAGMA@@ -28,6 +32,10 @@ #ifndef MIN_VERSION_free #define MIN_VERSION_free(x,y,z) 1 #endif++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Plated@@ -96,7 +104,9 @@ -- * Generics , gplate+ , gplate1 , GPlated+ , GPlated1 ) where @@ -317,7 +327,7 @@ -- -- Usually 'transform' is more appropriate, but 'rewrite' can give better -- compositionality. Given two single transformations @f@ and @g@, you can--- construct @\a -> f a `mplus` g a@ which performs both rewrites until a fixed point.+-- construct @\\a -> f a '<|>' g a@ which performs both rewrites until a fixed point. rewrite :: Plated a => (a -> Maybe a) -> a -> a rewrite = rewriteOf plate {-# INLINE rewrite #-}@@ -331,7 +341,7 @@ -- -- Usually 'transformOf' is more appropriate, but 'rewriteOf' can give better -- compositionality. Given two single transformations @f@ and @g@, you can--- construct @\a -> f a `mplus` g a@ which performs both rewrites until a fixed point.+-- construct @\\a -> f a '<|>' g a@ which performs both rewrites until a fixed point. -- -- @ -- 'rewriteOf' :: 'Control.Lens.Iso.Iso'' a a -> (a -> 'Maybe' a) -> a -> a@@ -766,3 +776,75 @@ instance GPlated a V1 where gplate' _ v = v `seq` error "GPlated/V1" {-# INLINE gplate' #-}++#if MIN_VERSION_base(4,9,0)+instance GPlated a (URec b) where+ gplate' _ = pure+ {-# INLINE gplate' #-}+#endif++-- | Implement 'plate' operation for a type using its 'Generic1' instance.+gplate1 :: (Generic1 f, GPlated1 f (Rep1 f)) => Traversal' (f a) (f a)+gplate1 f x = GHC.Generics.to1 <$> gplate1' f (GHC.Generics.from1 x)+{-# INLINE gplate1 #-}++class GPlated1 f g where+ gplate1' :: Traversal' (g a) (f a)++-- | recursive match+instance GPlated1 f g => GPlated1 f (M1 i c g) where+ gplate1' f (M1 x) = M1 <$> gplate1' f x+ {-# INLINE gplate1' #-}++-- | recursive match+instance (GPlated1 f g, GPlated1 f h) => GPlated1 f (g :+: h) where+ gplate1' f (L1 x) = L1 <$> gplate1' f x+ gplate1' f (R1 x) = R1 <$> gplate1' f x+ {-# INLINE gplate1' #-}++-- | recursive match+instance (GPlated1 f g, GPlated1 f h) => GPlated1 f (g :*: h) where+ gplate1' f (x :*: y) = (:*:) <$> gplate1' f x <*> gplate1' f y+ {-# INLINE gplate1' #-}++-- | ignored+instance GPlated1 f (K1 i a) where+ gplate1' _ = pure+ {-# INLINE gplate1' #-}++-- | ignored+instance GPlated1 f Par1 where+ gplate1' _ = pure+ {-# INLINE gplate1' #-}++-- | ignored+instance GPlated1 f U1 where+ gplate1' _ = pure+ {-# INLINE gplate1' #-}++-- | ignored+instance GPlated1 f V1 where+ gplate1' _ = pure+ {-# INLINE gplate1' #-}++-- | match+instance OVERLAPPING_PRAGMA GPlated1 f (Rec1 f) where+ gplate1' f (Rec1 x) = Rec1 <$> f x+ {-# INLINE gplate1' #-}++-- | ignored+instance GPlated1 f (Rec1 g) where+ gplate1' _ = pure+ {-# INLINE gplate1' #-}++-- | recursive match under outer 'Traversable' instance+instance (Traversable t, GPlated1 f g) => GPlated1 f (t :.: g) where+ gplate1' f (Comp1 x) = Comp1 <$> traverse (gplate1' f) x+ {-# INLINE gplate1' #-}++#if MIN_VERSION_base(4,9,0)+-- | ignored+instance GPlated1 f (URec a) where+ gplate1' _ = pure+ {-# INLINE gplate1' #-}+#endif
src/Control/Lens/Setter.hs view
@@ -62,6 +62,8 @@ , scribe , passing, ipassing , censoring, icensoring+ -- * Reader Combinators+ , locally, ilocally -- * Simplified State Setting , set' -- * Indexed Setters@@ -84,7 +86,8 @@ import Control.Lens.Internal.Setter import Control.Lens.Type import Control.Monad (liftM)-import Control.Monad.State.Class as State+import Control.Monad.Reader.Class as Reader+import Control.Monad.State.Class as State import Control.Monad.Writer.Class as Writer import Data.Functor.Contravariant import Data.Functor.Identity@@ -490,6 +493,11 @@ -- >>> Map.empty & at 3 ?~ x -- fromList [(3,x)] --+-- '?~' can be used type-changily:+--+-- >>> ('a', ('b', 'c')) & _2.both ?~ 'x'+-- ('a',(Just 'x',Just 'x'))+-- -- @ -- ('?~') :: 'Setter' s t a ('Maybe' b) -> b -> s -> t -- ('?~') :: 'Iso' s t a ('Maybe' b) -> b -> s -> t@@ -1076,14 +1084,14 @@ ----------------------------------------------------------------------------- -- Writer Operations-----------------------------------------------------------------------------+----------------------------------------------------------------------------- -- | Write to a fragment of a larger 'Writer' format. scribe :: (MonadWriter t m, Monoid s) => ASetter s t a b -> b -> m () scribe l b = tell (set l b mempty) {-# INLINE scribe #-} --- | This is a generalization of 'pass' that alows you to modify just a+-- | This is a generalization of 'pass' that allows you to modify just a -- portion of the resulting 'MonadWriter'. passing :: MonadWriter w m => Setter w w u v -> m (a, u -> v) -> m a passing l m = pass $ do@@ -1091,7 +1099,7 @@ return (a, over l uv) {-# INLINE passing #-} --- | This is a generalization of 'pass' that alows you to modify just a+-- | This is a generalization of 'pass' that allows you to modify just a -- portion of the resulting 'MonadWriter' with access to the index of an -- 'IndexedSetter'. ipassing :: MonadWriter w m => IndexedSetter i w w u v -> m (a, i -> u -> v) -> m a@@ -1100,13 +1108,13 @@ return (a, iover l uv) {-# INLINE ipassing #-} --- | This is a generalization of 'censor' that alows you to 'censor' just a+-- | This is a generalization of 'censor' that allows you to 'censor' just a -- portion of the resulting 'MonadWriter'. censoring :: MonadWriter w m => Setter w w u v -> (u -> v) -> m a -> m a censoring l uv = censor (over l uv) {-# INLINE censoring #-} --- | This is a generalization of 'censor' that alows you to 'censor' just a+-- | This is a generalization of 'censor' that allows you to 'censor' just a -- portion of the resulting 'MonadWriter', with access to the index of an -- 'IndexedSetter'. icensoring :: MonadWriter w m => IndexedSetter i w w u v -> (i -> u -> v) -> m a -> m a@@ -1114,8 +1122,54 @@ {-# INLINE icensoring #-} -----------------------------------------------------------------------------+-- Reader Operations+-----------------------------------------------------------------------------++-- | Modify the value of the 'Reader' environment associated with the target of a+-- 'Setter', 'Lens', or 'Traversal'.+--+-- @+-- 'locally' l 'id' a ≡ a+-- 'locally' l f '.' locally l g ≡ 'locally' l (f '.' g)+-- @+--+-- >>> (1,1) & locally _1 (+1) (uncurry (+))+-- 3+--+-- >>> "," & locally ($) ("Hello" <>) (<> " world!")+-- "Hello, world!"+--+-- @+-- locally :: MonadReader s m => 'Iso' s s a b -> (a -> b) -> m r -> m r+-- locally :: MonadReader s m => 'Lens' s s a b -> (a -> b) -> m r -> m r+-- locally :: MonadReader s m => 'Traversal' s s a b -> (a -> b) -> m r -> m r+-- locally :: MonadReader s m => 'Setter' s s a b -> (a -> b) -> m r -> m r+-- @+locally :: MonadReader s m => ASetter s s a b -> (a -> b) -> m r -> m r+locally l f = Reader.local (over l f)+{-# INLINE locally #-}++-- | This is a generalization of 'locally' that allows one to make indexed+-- 'local' changes to a 'Reader' environment associated with the target of a+-- 'Setter', 'Lens', or 'Traversal'.+--+-- @+-- 'locally' l f ≡ 'ilocally' l f . const+-- 'ilocally' l f ≡ 'locally' l f . 'Indexed'+-- @+--+-- @+-- ilocally :: MonadReader s m => 'IndexedLens' s s a b -> (i -> a -> b) -> m r -> m r+-- ilocally :: MonadReader s m => 'IndexedTraversal' s s a b -> (i -> a -> b) -> m r -> m r+-- ilocally :: MonadReader s m => 'IndexedSetter' s s a b -> (i -> a -> b) -> m r -> m r+-- @+ilocally :: MonadReader s m => AnIndexedSetter i s s a b -> (i -> a -> b) -> m r -> m r+ilocally l f = Reader.local (iover l f)+{-# INLINE ilocally #-}++----------------------------------------------------------------------------- -- Indexed Setters-----------------------------------------------------------------------------+----------------------------------------------------------------------------- -- | Map with index. This is an alias for 'imapOf'.
src/Control/Lens/Traversal.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-}@@ -75,7 +74,7 @@ -- * Parts and Holes , partsOf, partsOf' , unsafePartsOf, unsafePartsOf'- , holesOf+ , holesOf, holes1Of , singular, unsafeSingular -- * Common Traversals@@ -139,6 +138,7 @@ import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed+import Control.Lens.Internal.Fold import Control.Lens.Lens import Control.Lens.Setter (ASetter, AnIndexedSetter, isets, sets) import Control.Lens.Type@@ -149,21 +149,24 @@ #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (Foldable) #endif+import Data.Functor.Apply import Data.Functor.Compose import Data.Functor.Day.Curried import Data.Functor.Yoneda import Data.Int import Data.IntMap as IntMap+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Map (Map) import Data.Sequence (Seq, mapWithIndex) import Data.Vector as Vector (Vector, imap)-import Data.Monoid+import Data.Monoid (Monoid (..), Any (..), Endo (..)) import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Data.Reflection+import Data.Semigroup (Semigroup (..)) import Data.Semigroup.Traversable import Data.Semigroup.Bitraversable import Data.Traversable@@ -172,7 +175,8 @@ import Prelude hiding ((.),id) -- $setup--- >>> :set -XNoOverloadedStrings+-- >>> :set -XNoOverloadedStrings -XFlexibleContexts+-- >>> import Data.Char (toUpper) -- >>> import Control.Lens -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate,try,ErrorCall(..))@@ -181,6 +185,7 @@ -- >>> import Data.Void -- >>> import Data.List (sort) -- >>> import System.Timeout (timeout)+-- >>> import qualified Data.List.NonEmpty as NonEmpty -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force ------------------------------------------------------------------------------@@ -739,6 +744,36 @@ , cosieve (id :: p a a) x) {-# INLINABLE holeInOne #-} +-- | The non-empty version of 'holesOf'.+-- This extract a non-empty list of immediate children accroding to a given+-- 'Traversal1' as editable contexts.+--+-- >>> let head1 f s = runPretext (NonEmpty.head $ holes1Of traversed1 s) f+-- >>> ('a' :| "bc") ^. head1+-- 'a'+--+-- >>> ('a' :| "bc") & head1 %~ toUpper+-- 'A' :| "bc"+--+-- @+-- 'holes1Of' :: 'Iso'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s)+-- 'holes1Of' :: 'Lens'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s)+-- 'holes1Of' :: 'Traversal1'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s)+-- 'holes1Of' :: 'IndexedLens'' i s a -> s -> 'NonEmpty' ('Pretext'' ('Indexed' i) a s)+-- 'holes1Of' :: 'IndexedTraversal1'' i s a -> s -> 'NonEmpty' ('Pretext'' ('Indexed' i) a s)+-- @+holes1Of :: Conjoined p+ => Over p (Bazaar1 p a a) s t a a -> s -> NonEmpty (Pretext p a a t)+holes1Of f xs = flip getNonEmptyDList [] . fst $+ runHoles (runBazaar1 (f sell xs) (cotabulate holeInOne1)) id+{-# INLINE holes1Of #-}++holeInOne1 :: forall p a t. (Corepresentable p, Category p)+ => Corep p a -> Holes t (NonEmptyDList (Pretext p a a t)) a+holeInOne1 x = Holes $ \xt ->+ ( NonEmptyDList (fmap xt (cosieve sell x) :|)+ , cosieve (id :: p a a) x)+ -- We are very careful to share as much structure as possible among -- the results (in the common case where the traversal allows for such). -- Note in particular the recursive knot in the implementation of <*>@@ -754,6 +789,13 @@ let (qf, qv) = runHoles xs (xt . f) in (qf, f qv)++instance Semigroup m => Apply (Holes t m) where+ fs <.> xs = Holes $ \xt ->+ let+ (pf, pv) = runHoles fs (xt . ($ qv))+ (qf, qv) = runHoles xs (xt . pv)+ in (pf <> qf, pv qv) instance Monoid m => Applicative (Holes t m) where pure x = Holes $ \_ -> (mempty, x)
src/Control/Lens/Tuple.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}
src/Control/Lens/Type.hs view
@@ -375,7 +375,7 @@ -- around with 'Control.Lens.Review.re' to obtain a 'Getter' in the -- opposite direction. ----- There are two laws that a 'Prism' should satisfy:+-- There are three laws that a 'Prism' should satisfy: -- -- First, if I 'Control.Lens.Review.re' or 'Control.Lens.Review.review' a value with a 'Prism' and then 'Control.Lens.Fold.preview' or use ('Control.Lens.Fold.^?'), I will get it back: --@@ -385,9 +385,17 @@ -- -- Second, if you can extract a value @a@ using a 'Prism' @l@ from a value @s@, then the value @s@ is completely described by @l@ and @a@: ----- If @'Control.Lens.Fold.preview' l s ≡ 'Just' a@ then @'Control.Lens.Review.review' l a ≡ s@+-- @+-- 'Control.Lens.Fold.preview' l s ≡ 'Just' a ⟹ 'Control.Lens.Review.review' l a ≡ s+-- @ ----- These two laws imply that the 'Traversal' laws hold for every 'Prism' and that we 'Data.Traversable.traverse' at most 1 element:+-- Third, if you get non-match @t@, you can convert it result back to @s@:+--+-- @+-- 'Control.Lens.Combinators.matching' l s ≡ 'Left' t ⟹ 'Control.Lens.Combinators.matching' l t ≡ 'Left' s+-- @+--+-- The first two laws imply that the 'Traversal' laws hold for every 'Prism' and that we 'Data.Traversable.traverse' at most 1 element: -- -- @ -- 'Control.Lens.Fold.lengthOf' l x '<=' 1
src/Control/Lens/Wrapped.hs view
@@ -2,11 +2,9 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} @@ -334,6 +332,14 @@ instance Wrapped (Monoid.Alt f a) where type Unwrapped (Monoid.Alt f a) = f a _Wrapped' = iso Monoid.getAlt Monoid.Alt+ {-# INLINE _Wrapped' #-}+#endif++#if MIN_VERSION_base(4,12,0)+instance (t ~ Monoid.Ap g b) => Rewrapped (Monoid.Ap f a) t+instance Wrapped (Monoid.Ap f a) where+ type Unwrapped (Monoid.Ap f a) = f a+ _Wrapped' = iso Monoid.getAp Monoid.Ap {-# INLINE _Wrapped' #-} #endif
src/Control/Lens/Zoom.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
src/Data/Text/Lens.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE ViewPatterns #-}
src/Numeric/Lens.hs view
@@ -119,7 +119,7 @@ -- | A simpler variant of 'Numeric.readSigned' that supports any base, only -- recognizes an initial dash and doesn't know about parentheses readSigned' :: Real a => ReadS a -> ReadS a-readSigned' f ('-':xs) = f xs & mapped . _1 %~ negate+readSigned' f ('-':xs) = f xs <&> _1 %~ negate readSigned' f xs = f xs -- | @'binary' = 'base' 2@
tests/properties.hs view
@@ -42,6 +42,8 @@ import Numeric.Lens import Control.Lens.Properties (isIso, isLens, isPrism, isSetter, isTraversal) +#include "lens-common.h"+ -- an illegal lens bad :: Lens' (Int,Int) Int bad f (a,b) = (,) b <$> f a@@ -123,12 +125,12 @@ samplePolyEquality :: Equality Monad Identity Monad Identity samplePolyEquality f = f -lessSimplePoly :: forall (s :: k1) (t :: k2) (a :: k1) (b :: k2) .+lessSimplePoly :: forall KVS(k1 k2) (s :: k1) (t :: k2) (a :: k1) (b :: k2) . Equality a b a b lessSimplePoly f = f equalityAnEqualityPoly ::- forall (s :: k1) (t :: k2) (a :: k1) (b :: k2) .+ forall KVS(k1 k2) (s :: k1) (t :: k2) (a :: k1) (b :: k2) . Equality s t a b -> AnEquality s t a b equalityAnEqualityPoly f = f #else