diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,70 +1,94 @@ -language: haskell +# This file has been generated -- see https://github.com/hvr/multi-ghc-travis +language: c +sudo: false -env: - - GHCVER=7.4.2 - - GHCVER=7.6.3 - - GHCVER=7.8.4 - - GHCVER=7.10.1 - - GHCVER=head - # - > - # GHCVER=7.4.2 - # MODE="-fsafe" +cache: + directories: + - $HOME/.cabsnap + - $HOME/.cabal/packages +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar + matrix: - allow_failures: - - env: GHCVER=head + include: + - env: CABALVER=1.16 GHCVER=7.4.2 + compiler: ": #GHC 7.4.2" + addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} + - env: CABALVER=1.16 GHCVER=7.6.3 + compiler: ": #GHC 7.6.3" + addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} + - env: CABALVER=1.18 GHCVER=7.8.4 + compiler: ": #GHC 7.8.4" + addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} + - env: CABALVER=1.22 GHCVER=7.10.1 + compiler: ": #GHC 7.10.1" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} before_install: - # If $GHCVER is the one travis has, don't bother reinstalling it. - # We can also have faster builds by installing some libraries with - # `apt`. If it isn't, install the GHC we want from hvr's PPA along - # with cabal-1.18. - - | - if [ $GHCVER = `ghc --numeric-version` ]; then - # Try installing some of the build-deps with apt-get for speed. - travis/cabal-apt-install --enable-tests $MODE - export CABAL=cabal - else - # Install the GHC we want from hvr's PPA - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy - export CABAL=cabal-1.18 - export PATH=/opt/ghc/$GHCVER/bin:$PATH - fi - # Uncomment whenever hackage is down. - # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && $CABAL update - - $CABAL update - - # Update happy when building with GHC head - - | - if [ $GHCVER = "head" ] || [ $GHCVER = "7.8.4" ] || [ $GHCVER = "7.10.1" ]; then - $CABAL install --constraint=transformers\ installed happy alex - export PATH=$HOME/.cabal/bin:$PATH - fi + - unset CC + - export HAPPYVER=1.19.5 + - export ALEXVER=3.1.4 + - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH install: - - $CABAL install --dependencies-only --enable-tests - - $CABAL configure --enable-tests $MODE +# build reflection HEAD until reflection 2.1 is on hackage + - git clone https://github.com/ekmett/reflection.git -script: - - $CABAL build - - $CABAL test --show-details=always - - scripts/stats + - cabal --version + - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; + then + zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > + $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; + fi + - travis_retry cabal update + - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config" + - cabal install --only-dependencies --enable-tests --dry -v lens.cabal reflection/ > installplan.txt + - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt - # tests that a source-distribution can be generated - - cabal sdist +# check whether current requested install-plan matches cached package-db snapshot + - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; + then + echo "cabal build-cache HIT"; + rm -rfv .ghc; + cp -a $HOME/.cabsnap/ghc $HOME/.ghc; + cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; + else + echo "cabal build-cache MISS"; + rm -rf $HOME/.cabsnap; + mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; + cabal install --only-dependencies --enable-tests lens.cabal reflection/; + if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi; + fi - # check that the generated source-distribution can be built & installed - - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; - cd dist/; - if [ -f "$SRC_TGZ" ]; then - cabal install --force-reinstalls "$SRC_TGZ"; - else - echo "expected '$SRC_TGZ' not found"; - exit 1; - fi +# snapshot package-db on cache miss + - if [ ! -d $HOME/.cabsnap ]; + then + echo "snapshotting package-db to build-cache"; + mkdir $HOME/.cabsnap; + cp -a $HOME/.ghc $HOME/.cabsnap/ghc; + cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; + fi +# NB: we don't want reflection/ to be included in the cache + - cabal install reflection/ + +# 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: + - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging + - cabal build # this builds all libraries and executables (including tests) + - cabal test + - cabal sdist # tests that a source-distribution can be generated + +# Check that the resulting source distribution can be built & installed. +# If there are no other `.tar.gz` files in `dist`, this can be even simpler: +# `cabal install --force-reinstalls dist/*-*.tar.gz` + - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && + (cd dist && cabal install --force-reinstalls "$SRC_TGZ") + notifications: irc: channels: @@ -72,3 +96,4 @@ skip_join: true template: - "\x0313lens\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" +# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,14 @@ +4.13 +---- +* Pattern synonyms +* Moved `foldMapBy` and `foldBy` into `reflection` 2.1 +* Added `traverseByOf`, `sequenceByOf`. +* Reexported `traverseBy` and `sequenceBy` from `reflection` 2.1. +* Modified the signatures of `alaf` and `auf` to work with a `Functor` rather than a `Profunctor` and rather drastically generalized them. +* Removed `Control.Lens.Internal.Getter.coerce` in favor of the upstream `phantom` combinator in `contravariant` 1.3+ +* Renamed `coerced` to `phantasm` to get it out of the way. +* Added `Wrapped` instance for `Down` + 4.12.3 ------ * Move `Review` and `AReview` to `Control.Lens.Type` fixing a bug in `makePrisms` diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ Lens: Lenses, Folds, and Traversals ================================== -[![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) 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/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses, Generics -version: 4.12.3 +version: 4.13 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -12,7 +12,7 @@ copyright: Copyright (C) 2012-2015 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.1 +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1, GHC == 7.10.2 synopsis: Lenses, Folds and Traversals description: This package comes \"Batteries Included\" with many useful lenses for the types @@ -187,7 +187,7 @@ bifunctors >= 5 && < 6, bytestring >= 0.9.1.10 && < 0.11, comonad >= 4 && < 5, - contravariant >= 0.3 && < 2, + contravariant >= 1.3 && < 2, containers >= 0.4.0 && < 0.6, distributive >= 0.3 && < 1, filepath >= 1.2.0.0 && < 1.5, @@ -199,7 +199,7 @@ mtl >= 2.0.1 && < 2.3, parallel >= 3.1.0.1 && < 3.3, profunctors >= 5 && < 6, - reflection >= 2 && < 3, + reflection >= 2.1 && < 3, semigroupoids >= 5 && < 6, semigroups >= 0.8.4 && < 1, tagged >= 0.4.4 && < 1, diff --git a/src/Control/Exception/Lens.hs b/src/Control/Exception/Lens.hs --- a/src/Control/Exception/Lens.hs +++ b/src/Control/Exception/Lens.hs @@ -4,10 +4,16 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} + #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif + #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif @@ -53,55 +59,113 @@ , mappedException, mappedException' -- * Exceptions , exception +#if __GLASGOW_HASKELL__ >= 710 + , pattern Exception +#endif -- * Exception Handlers , Handleable(..) -- ** IOExceptions , AsIOException(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern IOException_ +#endif -- ** Arithmetic Exceptions , AsArithException(..) - , _Overflow - , _Underflow - , _LossOfPrecision - , _DivideByZero - , _Denormal + , _Overflow, _Underflow, _LossOfPrecision, _DivideByZero, _Denormal #if MIN_VERSION_base(4,6,0) , _RatioZeroDenominator #endif +#if __GLASGOW_HASKELL__ >= 710 + , pattern ArithException_ + , pattern Overflow_ + , pattern Underflow_ + , pattern LossOfPrecision_ + , pattern DivideByZero_ + , pattern Denormal_ + , pattern RatioZeroDenominator_ +#endif -- ** Array Exceptions , AsArrayException(..) , _IndexOutOfBounds , _UndefinedElement +#if __GLASGOW_HASKELL__ >= 710 + , pattern ArrayException_ + , pattern IndexOutOfBounds_ + , pattern UndefinedElement_ +#endif -- ** Assertion Failed , AsAssertionFailed(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern AssertionFailed_ +#endif -- ** Async Exceptions , AsAsyncException(..) , _StackOverflow , _HeapOverflow , _ThreadKilled , _UserInterrupt +#if __GLASGOW_HASKELL__ >= 710 + , pattern AsyncException_ + , pattern StackOverflow_ + , pattern HeapOverflow_ + , pattern ThreadKilled_ + , pattern UserInterrupt_ +#endif -- ** Non-Termination , AsNonTermination(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern NonTermination_ +#endif -- ** Nested Atomically , AsNestedAtomically(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern NestedAtomically_ +#endif -- ** Blocked Indefinitely -- *** on MVar , AsBlockedIndefinitelyOnMVar(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern BlockedIndefinitelyOnMVar_ +#endif -- *** on STM , AsBlockedIndefinitelyOnSTM(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern BlockedIndefinitelyOnSTM_ +#endif -- ** Deadlock , AsDeadlock(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern Deadlock_ +#endif -- ** No Such Method , AsNoMethodError(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern NoMethodError_ +#endif -- ** Pattern Match Failure , AsPatternMatchFail(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern PatternMatchFail_ +#endif -- ** Record , AsRecConError(..) , AsRecSelError(..) , AsRecUpdError(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern RecConError_ + , pattern RecSelError_ + , pattern RecUpdError_ +#endif -- ** Error Call , AsErrorCall(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern ErrorCall_ +#endif -- * Handling Exceptions , AsHandlingException(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern HandlingException_ +#endif ) where import Control.Applicative @@ -117,6 +181,9 @@ ( const, either, flip, id , (.) , Maybe(..), Either(..), String +#if __GLASGOW_HASKELL__ >= 710 + , Bool(..) +#endif ) #ifdef HLINT @@ -142,6 +209,11 @@ exception = prism' toException fromException {-# INLINE exception #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern Exception e <- (preview exception -> Just e) where + Exception e = review exception e +#endif + ------------------------------------------------------------------------------ -- Catching ------------------------------------------------------------------------------ @@ -385,6 +457,11 @@ _IOException = exception {-# INLINE _IOException #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern IOException_ a <- (preview _IOException -> Just a) where + IOException_ a = review _IOException a +#endif + ---------------------------------------------------------------------------- -- ArithException ---------------------------------------------------------------------------- @@ -395,6 +472,11 @@ -- '_ArithException' :: 'Prism'' 'SomeException' 'ArithException' _ArithException :: Prism' t ArithException +#if __GLASGOW_HASKELL__ >= 710 +pattern ArithException_ a <- (preview _ArithException -> Just a) where + ArithException_ a = review _ArithException a +#endif + instance AsArithException ArithException where _ArithException = id {-# INLINE _ArithException #-} @@ -419,6 +501,11 @@ seta t = Left (pure t) {-# INLINE _Overflow #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern Overflow_ <- (has _Overflow -> True) where + Overflow_ = review _Overflow () +#endif + -- | Handle arithmetic '_Underflow'. -- -- @ @@ -435,6 +522,11 @@ seta t = Left (pure t) {-# INLINE _Underflow #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern Underflow_ <- (has _Underflow -> True) where + Underflow_ = review _Underflow () +#endif + -- | Handle arithmetic loss of precision. -- -- @ @@ -451,6 +543,11 @@ seta t = Left (pure t) {-# INLINE _LossOfPrecision #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern LossOfPrecision_ <- (has _LossOfPrecision -> True) where + LossOfPrecision_ = review _LossOfPrecision () +#endif + -- | Handle division by zero. -- -- @ @@ -467,6 +564,11 @@ seta t = Left (pure t) {-# INLINE _DivideByZero #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern DivideByZero_ <- (has _DivideByZero -> True) where + DivideByZero_ = review _DivideByZero () +#endif + -- | Handle exceptional _Denormalized floating pure. -- -- @ @@ -483,6 +585,11 @@ seta t = Left (pure t) {-# INLINE _Denormal #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern Denormal_ <- (has _Denormal -> True) where + Denormal_ = review _Denormal () +#endif + #if MIN_VERSION_base(4,6,0) -- | Added in @base@ 4.6 in response to this libraries discussion: -- @@ -502,8 +609,13 @@ seta t = Left (pure t) {-# INLINE _RatioZeroDenominator #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern RatioZeroDenominator_ <- (has _RatioZeroDenominator -> True) where + RatioZeroDenominator_ = review _RatioZeroDenominator () #endif +#endif + ---------------------------------------------------------------------------- -- ArrayException ---------------------------------------------------------------------------- @@ -526,6 +638,11 @@ _ArrayException = exception {-# INLINE _ArrayException #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern ArrayException_ e <- (preview _ArrayException -> Just e) where + ArrayException_ e = review _ArrayException e +#endif + -- | An attempt was made to index an array outside its declared bounds. -- -- @ @@ -542,6 +659,11 @@ seta t = Left (pure t) {-# INLINE _IndexOutOfBounds #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern IndexOutOfBounds_ e <- (preview _IndexOutOfBounds -> Just e) where + IndexOutOfBounds_ e = review _IndexOutOfBounds e +#endif + -- | An attempt was made to evaluate an element of an array that had not been initialized. -- -- @ @@ -558,6 +680,11 @@ seta t = Left (pure t) {-# INLINE _UndefinedElement #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern UndefinedElement_ e <- (preview _UndefinedElement -> Just e) where + UndefinedElement_ e = review _UndefinedElement e +#endif + ---------------------------------------------------------------------------- -- AssertionFailed ---------------------------------------------------------------------------- @@ -583,6 +710,11 @@ _AssertionFailed = exception._Wrapping AssertionFailed {-# INLINE _AssertionFailed #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern AssertionFailed_ e <- (preview _AssertionFailed -> Just e) where + AssertionFailed_ e = review _AssertionFailed e +#endif + ---------------------------------------------------------------------------- -- AsyncException ---------------------------------------------------------------------------- @@ -605,6 +737,11 @@ _AsyncException = exception {-# INLINE _AsyncException #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern AsyncException_ e <- (preview _AsyncException -> Just e) where + AsyncException_ e = review _AsyncException e +#endif + -- | The current thread's stack exceeded its limit. Since an 'Exception' has -- been raised, the thread's stack will certainly be below its limit again, -- but the programmer should take remedial action immediately. @@ -619,6 +756,11 @@ seta t = Left (pure t) {-# INLINE _StackOverflow #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern StackOverflow_ <- (has _StackOverflow -> True) where + StackOverflow_ = review _StackOverflow () +#endif + -- | The program's heap is reaching its limit, and the program should take action -- to reduce the amount of live data it has. -- @@ -638,6 +780,11 @@ seta t = Left (pure t) {-# INLINE _HeapOverflow #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern HeapOverflow_ <- (has _HeapOverflow -> True) where + HeapOverflow_ = review _HeapOverflow () +#endif + -- | This 'Exception' is raised by another thread calling -- 'Control.Concurrent.killThread', or by the system if it needs to terminate -- the thread for some reason. @@ -652,6 +799,11 @@ seta t = Left (pure t) {-# INLINE _ThreadKilled #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern ThreadKilled_ <- (has _ThreadKilled -> True) where + ThreadKilled_ = review _ThreadKilled () +#endif + -- | This 'Exception' is raised by default in the main thread of the program when -- the user requests to terminate the program via the usual mechanism(s) -- (/e.g./ Control-C in the console). @@ -666,6 +818,11 @@ seta t = Left (pure t) {-# INLINE _UserInterrupt #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern UserInterrupt_ <- (has _UserInterrupt -> True) where + UserInterrupt_ = review _UserInterrupt () +#endif + ---------------------------------------------------------------------------- -- AsyncException ---------------------------------------------------------------------------- @@ -690,6 +847,11 @@ _NonTermination = exception.trivial NonTermination {-# INLINE _NonTermination #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern NonTermination_ <- (has _NonTermination -> True) where + NonTermination_ = review _NonTermination () +#endif + ---------------------------------------------------------------------------- -- NestedAtomically ---------------------------------------------------------------------------- @@ -713,6 +875,11 @@ _NestedAtomically = exception.trivial NestedAtomically {-# INLINE _NestedAtomically #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern NestedAtomically_ <- (has _NestedAtomically -> True) where + NestedAtomically_ = review _NestedAtomically () +#endif + ---------------------------------------------------------------------------- -- BlockedIndefinitelyOnMVar ---------------------------------------------------------------------------- @@ -737,6 +904,11 @@ _BlockedIndefinitelyOnMVar = exception.trivial BlockedIndefinitelyOnMVar {-# INLINE _BlockedIndefinitelyOnMVar #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern BlockedIndefinitelyOnMVar_ <- (has _BlockedIndefinitelyOnMVar -> True) where + BlockedIndefinitelyOnMVar_ = review _BlockedIndefinitelyOnMVar () +#endif + ---------------------------------------------------------------------------- -- BlockedIndefinitelyOnSTM ---------------------------------------------------------------------------- @@ -761,6 +933,11 @@ _BlockedIndefinitelyOnSTM = exception.trivial BlockedIndefinitelyOnSTM {-# INLINE _BlockedIndefinitelyOnSTM #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern BlockedIndefinitelyOnSTM_ <- (has _BlockedIndefinitelyOnSTM -> True) where + BlockedIndefinitelyOnSTM_ = review _BlockedIndefinitelyOnSTM () +#endif + ---------------------------------------------------------------------------- -- Deadlock ---------------------------------------------------------------------------- @@ -784,6 +961,11 @@ _Deadlock = exception.trivial Deadlock {-# INLINE _Deadlock #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern Deadlock_ <- (has _Deadlock -> True) where + Deadlock_ = review _Deadlock () +#endif + ---------------------------------------------------------------------------- -- NoMethodError ---------------------------------------------------------------------------- @@ -807,6 +989,11 @@ _NoMethodError = exception._Wrapping NoMethodError {-# INLINE _NoMethodError #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern NoMethodError_ e <- (preview _NoMethodError -> Just e) where + NoMethodError_ e = review _NoMethodError e +#endif + ---------------------------------------------------------------------------- -- PatternMatchFail ---------------------------------------------------------------------------- @@ -829,6 +1016,11 @@ _PatternMatchFail = exception._Wrapping PatternMatchFail {-# INLINE _PatternMatchFail #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern PatternMatchFail_ e <- (preview _PatternMatchFail -> Just e) where + PatternMatchFail_ e = review _PatternMatchFail e +#endif + ---------------------------------------------------------------------------- -- RecConError ---------------------------------------------------------------------------- @@ -852,6 +1044,11 @@ _RecConError = exception._Wrapping RecConError {-# INLINE _RecConError #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern RecConError_ e <- (preview _RecConError -> Just e) where + RecConError_ e = review _RecConError e +#endif + ---------------------------------------------------------------------------- -- RecSelError ---------------------------------------------------------------------------- @@ -871,6 +1068,11 @@ _RecSelError = exception._Wrapping RecSelError {-# INLINE _RecSelError #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern RecSelError_ e <- (preview _RecSelError -> Just e) where + RecSelError_ e = review _RecSelError e +#endif + ---------------------------------------------------------------------------- -- RecUpdError ---------------------------------------------------------------------------- @@ -890,6 +1092,11 @@ _RecUpdError = exception._Wrapping RecUpdError {-# INLINE _RecUpdError #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern RecUpdError_ e <- (preview _RecUpdError -> Just e) where + RecUpdError_ e = review _RecUpdError e +#endif + ---------------------------------------------------------------------------- -- ErrorCall ---------------------------------------------------------------------------- @@ -912,6 +1119,11 @@ _ErrorCall = exception._Wrapping ErrorCall {-# INLINE _ErrorCall #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern ErrorCall_ e <- (preview _ErrorCall -> Just e) where + ErrorCall_ e = review _ErrorCall e +#endif + ------------------------------------------------------------------------------ -- HandlingException ------------------------------------------------------------------------------ @@ -934,6 +1146,11 @@ instance AsHandlingException SomeException where _HandlingException = exception.trivial HandlingException {-# INLINE _HandlingException #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern HandlingException_ <- (has _HandlingException -> True) where + HandlingException_ = review _HandlingException () +#endif ------------------------------------------------------------------------------ -- Helper Functions diff --git a/src/Control/Lens/Cons.hs b/src/Control/Lens/Cons.hs --- a/src/Control/Lens/Cons.hs +++ b/src/Control/Lens/Cons.hs @@ -7,6 +7,10 @@ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Cons @@ -25,12 +29,19 @@ , cons , uncons , _head, _tail +#if __GLASGOW_HASKELL__ >= 710 + , pattern (:>) +#endif -- * Snoc , Snoc(..) , (|>) , snoc , unsnoc , _init, _last +#if __GLASGOW_HASKELL__ >= 710 + , pattern (:<) +#endif + ) where import Control.Lens.Equality (simply) @@ -45,7 +56,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Monoid import qualified Data.Sequence as Seq -import Data.Sequence hiding ((<|), (|>)) +import Data.Sequence hiding ((<|), (|>), (:<), (:>)) import qualified Data.Text as StrictT import qualified Data.Text.Lazy as LazyT import Data.Vector (Vector) @@ -72,6 +83,19 @@ infixr 5 <|, `cons` infixl 5 |>, `snoc` +#if __GLASGOW_HASKELL__ >= 710 + +pattern (:<) a s <- (preview _Cons -> Just (a,s)) where + (:<) a s = _Cons # (a,s) + +infixr 5 :< +infixl 5 :> + +pattern (:>) s a <- (preview _Snoc -> Just (s,a)) where + (:>) a s = _Snoc # (a,s) + +#endif + ------------------------------------------------------------------------------ -- Cons ------------------------------------------------------------------------------ @@ -105,7 +129,7 @@ instance Cons (Seq a) (Seq b) a b where _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of - a :< as -> Right (a, as) + a Seq.:< as -> Right (a, as) EmptyL -> Left mempty {-# INLINE _Cons #-} @@ -336,7 +360,7 @@ instance Snoc (Seq a) (Seq b) a b where _Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of - as :> a -> Right (as, a) + as Seq.:> a -> Right (as, a) EmptyR -> Left mempty {-# INLINE _Snoc #-} diff --git a/src/Control/Lens/Empty.hs b/src/Control/Lens/Empty.hs --- a/src/Control/Lens/Empty.hs +++ b/src/Control/Lens/Empty.hs @@ -1,10 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE DefaultSignatures #-} + #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif + ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Empty @@ -18,9 +24,15 @@ module Control.Lens.Empty ( AsEmpty(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern Empty +#endif ) where import Control.Lens.Iso +#if __GLASGOW_HASKELL__ >= 710 +import Control.Lens.Fold +#endif import Control.Lens.Prism import Control.Lens.Review import Data.ByteString as StrictB @@ -55,6 +67,11 @@ default _Empty :: (Monoid a, Eq a) => Prism' a () _Empty = only mempty {-# INLINE _Empty #-} +#endif + +#if __GLASGOW_HASKELL__ >= 710 +pattern Empty <- (has _Empty -> True) where + Empty = review _Empty () #endif {- Default Monoid instances -} diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs --- a/src/Control/Lens/Fold.hs +++ b/src/Control/Lens/Fold.hs @@ -8,6 +8,10 @@ #define MIN_VERSION_profunctors(x,y,z) 1 #endif +#ifndef MIN_VERSION_reflection +#define MIN_VERSION_reflection(x,y,z) 1 +#endif + #if __GLASGOW_HASKELL__ < 708 || !(MIN_VERSION_profunctors(4,4,0)) {-# LANGUAGE Trustworthy #-} #endif @@ -160,6 +164,7 @@ import Data.Foldable import Data.Functor.Apply import Data.Functor.Compose +import Data.Functor.Contravariant import Data.Int (Int64) import Data.List (intercalate) import Data.Maybe @@ -168,6 +173,9 @@ import Data.Profunctor.Rep import Data.Profunctor.Sieve import Data.Profunctor.Unsafe +#if MIN_VERSION_reflection(2,1,0) +import Data.Reflection +#endif import Data.Traversable import Prelude hiding (foldr) @@ -206,11 +214,11 @@ -- >>> [1,2,3,4]^..folding tail -- [2,3,4] folding :: Foldable f => (s -> f a) -> Fold s a -folding sfa agb = coerce . traverse_ agb . sfa +folding sfa agb = phantom . traverse_ agb . sfa {-# INLINE folding #-} ifolding :: (Foldable f, Indexable i p, Contravariant g, Applicative g) => (s -> f (i, a)) -> Over p g s t a b -ifolding sfa f = coerce . traverse_ (coerce . uncurry (indexed f)) . sfa +ifolding sfa f = phantom . traverse_ (phantom . uncurry (indexed f)) . sfa {-# INLINE ifolding #-} -- | Obtain a 'Fold' by lifting 'foldr' like function. @@ -218,12 +226,12 @@ -- >>> [1,2,3,4]^..foldring foldr -- [1,2,3,4] foldring :: (Contravariant f, Applicative f) => ((a -> f a -> f a) -> f a -> s -> f a) -> LensLike f s t a b -foldring fr f = coerce . fr (\a fa -> f a *> fa) noEffect +foldring fr f = phantom . fr (\a fa -> f a *> fa) noEffect {-# INLINE foldring #-} -- | Obtain 'FoldWithIndex' by lifting 'ifoldr' like function. ifoldring :: (Indexable i p, Contravariant f, Applicative f) => ((i -> a -> f a -> f a) -> f a -> s -> f a) -> Over p f s t a b -ifoldring ifr f = coerce . ifr (\i a fa -> indexed f i a *> fa) noEffect +ifoldring ifr f = phantom . ifr (\i a fa -> indexed f i a *> fa) noEffect {-# INLINE ifoldring #-} -- | Obtain a 'Fold' from any 'Foldable' indexed by ordinal position. @@ -497,7 +505,7 @@ -- @ -- 'foldMapOf' :: 'Getting' r s a -> (a -> r) -> s -> r -- @ -foldMapOf :: Profunctor p => Accessing p r s a -> p a r -> s -> r +foldMapOf :: Getting r s a -> (a -> r) -> s -> r foldMapOf l f = getConst #. l (Const #. f) {-# INLINE foldMapOf #-} @@ -549,8 +557,8 @@ -- @ -- 'foldrOf' :: 'Getting' ('Endo' r) s a -> (a -> r -> r) -> r -> s -> r -- @ -foldrOf :: Profunctor p => Accessing p (Endo r) s a -> p a (r -> r) -> r -> s -> r -foldrOf l f z = flip appEndo z `rmap` foldMapOf l (Endo #. f) +foldrOf :: Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r +foldrOf l f z = flip appEndo z . foldMapOf l (Endo #. f) {-# INLINE foldrOf #-} -- | Left-associative fold of the parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. @@ -692,7 +700,7 @@ -- 'anyOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -anyOf :: Profunctor p => Accessing p Any s a -> p a Bool -> s -> Bool +anyOf :: Getting Any s a -> (a -> Bool) -> s -> Bool anyOf l f = getAny #. foldMapOf l (Any #. f) {-# INLINE anyOf #-} @@ -719,7 +727,7 @@ -- 'allOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -allOf :: Profunctor p => Accessing p All s a -> p a Bool -> s -> Bool +allOf :: Getting All s a -> (a -> Bool) -> s -> Bool allOf l f = getAll #. foldMapOf l (All #. f) {-# INLINE allOf #-} @@ -742,7 +750,7 @@ -- 'noneOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'noneOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -noneOf :: Profunctor p => Accessing p Any s a -> p a Bool -> s -> Bool +noneOf :: Getting Any s a -> (a -> Bool) -> s -> Bool noneOf l f = not . anyOf l f {-# INLINE noneOf #-} @@ -842,7 +850,7 @@ -- 'traverseOf_' :: 'Applicative' f => 'Traversal'' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Prism'' s a -> (a -> f r) -> s -> f () -- @ -traverseOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> p a (f r) -> s -> f () +traverseOf_ :: Functor f => Getting (Traversed r f) s a -> (a -> f r) -> s -> f () traverseOf_ l f = void . getTraversed #. foldMapOf l (Traversed #. f) {-# INLINE traverseOf_ #-} @@ -875,7 +883,7 @@ -- 'forOf_' :: 'Applicative' f => 'Traversal'' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Prism'' s a -> s -> (a -> f r) -> f () -- @ -forOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> s -> p a (f r) -> f () +forOf_ :: Functor f => Getting (Traversed r f) s a -> s -> (a -> f r) -> f () forOf_ = flip . traverseOf_ {-# INLINE forOf_ #-} @@ -919,7 +927,7 @@ -- 'mapMOf_' :: 'Monad' m => 'Traversal'' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Prism'' s a -> (a -> m r) -> s -> m () -- @ -mapMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> p a (m r) -> s -> m () +mapMOf_ :: Monad m => Getting (Sequenced r m) s a -> (a -> m r) -> s -> m () mapMOf_ l f = liftM skip . getSequenced #. foldMapOf l (Sequenced #. f) {-# INLINE mapMOf_ #-} @@ -941,7 +949,7 @@ -- 'forMOf_' :: 'Monad' m => 'Traversal'' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Prism'' s a -> s -> (a -> m r) -> m () -- @ -forMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> s -> p a (m r) -> m () +forMOf_ :: Monad m => Getting (Sequenced r m) s a -> s -> (a -> m r) -> m () forMOf_ = flip . mapMOf_ {-# INLINE forMOf_ #-} @@ -1076,7 +1084,7 @@ -- 'concatMapOf' :: 'Iso'' s a -> (a -> [r]) -> s -> [r] -- 'concatMapOf' :: 'Traversal'' s a -> (a -> [r]) -> s -> [r] -- @ -concatMapOf :: Profunctor p => Accessing p [r] s a -> p a [r] -> s -> [r] +concatMapOf :: Getting [r] s a -> (a -> [r]) -> s -> [r] concatMapOf l ces = getConst #. l (Const #. ces) {-# INLINE concatMapOf #-} @@ -1466,8 +1474,8 @@ -- 'findOf' :: 'Getting' ('Endo' ('Maybe' a)) s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' l p = 'foldrOf' l (\a y -> if p a then 'Just' a else y) 'Nothing' -- @ -findOf :: Conjoined p => Accessing p (Endo (Maybe a)) s a -> p a Bool -> s -> Maybe a -findOf l p = foldrOf l (cotabulate $ \wa y -> if cosieve p wa then Just (extract wa) else y) Nothing +findOf :: Getting (Endo (Maybe a)) s a -> (a -> Bool) -> s -> Maybe a +findOf l f = foldrOf l (\a y -> if f a then Just a else y) Nothing {-# INLINE findOf #-} -- | The 'findMOf' function takes a 'Lens' (or 'Getter', 'Iso', 'Fold', or 'Traversal'), @@ -1506,8 +1514,8 @@ -- 'findMOf' :: Monad m => 'Getting' ('Endo' (m ('Maybe' a))) s a -> (a -> m 'Bool') -> s -> m ('Maybe' a) -- 'findMOf' l p = 'foldrOf' l (\a y -> p a >>= \x -> if x then return ('Just' a) else y) $ return 'Nothing' -- @ -findMOf :: (Monad m, Conjoined p) => Accessing p (Endo (m (Maybe a))) s a -> p a (m Bool) -> s -> m (Maybe a) -findMOf l p = foldrOf l (cotabulate $ \wa y -> cosieve p wa >>= \r -> if r then return (Just (extract wa)) else y) $ return Nothing +findMOf :: Monad m => Getting (Endo (m (Maybe a))) s a -> (a -> m Bool) -> s -> m (Maybe a) +findMOf l f = foldrOf l (\a y -> f a >>= \r -> if r then return (Just a) else y) $ return Nothing {-# INLINE findMOf #-} -- | A variant of 'foldrOf' that has no base case and thus may only be applied @@ -1738,7 +1746,7 @@ -- 'pre' :: 'Prism'' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- @ pre :: Getting (First a) s a -> IndexPreservingGetter s (Maybe a) -pre l = dimap (getFirst . getConst #. l (Const #. First #. Just)) coerce +pre l = dimap (getFirst . getConst #. l (Const #. First #. Just)) phantom {-# INLINE pre #-} -- | This converts an 'IndexedFold' to an 'IndexPreservingGetter' that returns the first index @@ -1751,7 +1759,7 @@ -- 'ipre' :: 'IndexedLens'' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) -- @ ipre :: IndexedGetting i (First (i, a)) s a -> IndexPreservingGetter s (Maybe (i, a)) -ipre l = dimap (getFirst . getConst #. l (Indexed $ \i a -> Const (First (Just (i, a))))) coerce +ipre l = dimap (getFirst . getConst #. l (Indexed $ \i a -> Const (First (Just (i, a))))) phantom {-# INLINE ipre #-} ------------------------------------------------------------------------------ @@ -2000,7 +2008,7 @@ -- @ -- ifoldMapOf :: IndexedGetting i m s a -> (i -> a -> m) -> s -> m -ifoldMapOf l = foldMapOf l .# Indexed +ifoldMapOf l f = getConst #. l (Const #. Indexed f) {-# INLINE ifoldMapOf #-} -- | Right-associative fold of parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with @@ -2019,7 +2027,7 @@ -- 'ifoldrOf' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- @ ifoldrOf :: IndexedGetting i (Endo r) s a -> (i -> a -> r -> r) -> r -> s -> r -ifoldrOf l = foldrOf l .# Indexed +ifoldrOf l f z = flip appEndo z . getConst #. l (Const #. Endo #. Indexed f) {-# INLINE ifoldrOf #-} -- | Left-associative fold of the parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with @@ -2057,7 +2065,7 @@ -- 'ianyOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ ianyOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool -ianyOf l = anyOf l .# Indexed +ianyOf l f = getAny #. getConst #. l (Const #. Any #. Indexed f) {-# INLINE ianyOf #-} -- | Return whether or not all elements viewed through an 'IndexedFold' or 'IndexedTraversal' @@ -2076,7 +2084,7 @@ -- 'iallOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ iallOf :: IndexedGetting i All s a -> (i -> a -> Bool) -> s -> Bool -iallOf l = allOf l .# Indexed +iallOf l f = getAll #. getConst #. l (Const #. All #. Indexed f) {-# INLINE iallOf #-} -- | Return whether or not none of the elements viewed through an 'IndexedFold' or 'IndexedTraversal' @@ -2095,7 +2103,7 @@ -- 'inoneOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ inoneOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool -inoneOf l = noneOf l .# Indexed +inoneOf l f = not . ianyOf l f {-# INLINE inoneOf #-} -- | Traverse the targets of an 'IndexedFold' or 'IndexedTraversal' with access to the @i@, discarding the results. @@ -2113,7 +2121,7 @@ -- 'itraverseOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> (i -> a -> f r) -> s -> f () -- @ itraverseOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> (i -> a -> f r) -> s -> f () -itraverseOf_ l = traverseOf_ l .# Indexed +itraverseOf_ l f = void . getTraversed #. getConst #. l (Const #. Traversed #. Indexed f) {-# INLINE itraverseOf_ #-} -- | Traverse the targets of an 'IndexedFold' or 'IndexedTraversal' with access to the index, discarding the results @@ -2155,7 +2163,7 @@ -- 'imapMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m r) -> s -> m () -- @ imapMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> (i -> a -> m r) -> s -> m () -imapMOf_ l = mapMOf_ l .# Indexed +imapMOf_ l f = liftM skip . getSequenced #. getConst #. l (Const #. Sequenced #. Indexed f) {-# INLINE imapMOf_ #-} -- | Run monadic actions for each target of an 'IndexedFold' or 'IndexedTraversal' with access to the index, @@ -2218,7 +2226,7 @@ -- 'ifindOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a -- @ ifindOf :: IndexedGetting i (Endo (Maybe a)) s a -> (i -> a -> Bool) -> s -> Maybe a -ifindOf l = findOf l .# Indexed +ifindOf l f = ifoldrOf l (\i a y -> if f i a then Just a else y) Nothing {-# INLINE ifindOf #-} -- | The 'ifindMOf' function takes an 'IndexedFold' or 'IndexedTraversal', a monadic predicate that is also @@ -2238,7 +2246,7 @@ -- 'ifindMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) -- @ ifindMOf :: Monad m => IndexedGetting i (Endo (m (Maybe a))) s a -> (i -> a -> m Bool) -> s -> m (Maybe a) -ifindMOf l = findMOf l .# Indexed +ifindMOf l f = ifoldrOf l (\i a y -> f i a >>= \r -> if r then return (Just a) else y) $ return Nothing {-# INLINE ifindMOf #-} -- | /Strictly/ fold right over the elements of a structure with an index. @@ -2499,19 +2507,6 @@ -- Folds with Reified Monoid ------------------------------------------------------------------------------ --- | Fold a value using its 'Foldable' instance using --- explicitly provided 'Monoid' operations. This is like 'fold' --- where the 'Monoid' instance can be manually specified. --- --- @ --- 'foldBy' 'mappend' 'mempty' ≡ 'fold' --- @ --- --- >>> foldBy (++) [] ["hello","world"] --- "helloworld" -foldBy :: Foldable t => (a -> a -> a) -> a -> t a -> a -foldBy f z = reifyFold f z (foldMap M) - -- | Fold a value using a specified 'Fold' and 'Monoid' operations. -- This is like 'foldBy' where the 'Foldable' instance can be -- manually specified. @@ -2531,20 +2526,7 @@ -- >>> foldByOf both (++) [] ("hello","world") -- "helloworld" foldByOf :: Fold s a -> (a -> a -> a) -> a -> s -> a -foldByOf l f z = reifyFold f z (foldMapOf l M) - --- | Fold a value using its 'Foldable' instance using --- explicitly provided 'Monoid' operations. This is like 'foldMap' --- where the 'Monoid' instance can be manually specified. --- --- @ --- 'foldMapBy' 'mappend' 'mempty' ≡ 'foldMap' --- @ --- --- >>> foldMapBy (+) 0 length ["hello","world"] --- 10 -foldMapBy :: Foldable t => (r -> r -> r) -> r -> (a -> r) -> t a -> r -foldMapBy f z g = reifyFold f z (foldMap (M #. g)) +foldByOf l f z = reifyMonoid f z (foldMapOf l ReflectedMonoid) -- | Fold a value using a specified 'Fold' and 'Monoid' operations. -- This is like 'foldMapBy' where the 'Foldable' instance can be @@ -2565,4 +2547,4 @@ -- >>> foldMapByOf both (+) 0 length ("hello","world") -- 10 foldMapByOf :: Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r -foldMapByOf l f z g = reifyFold f z (foldMapOf l (M #. g)) +foldMapByOf l f z g = reifyMonoid f z (foldMapOf l (ReflectedMonoid #. g)) diff --git a/src/Control/Lens/Getter.hs b/src/Control/Lens/Getter.hs --- a/src/Control/Lens/Getter.hs +++ b/src/Control/Lens/Getter.hs @@ -73,12 +73,11 @@ , ilistening, ilistenings -- * Implementation Details , Contravariant(..) - , coerce, coerced + , getting , Const(..) ) where import Control.Applicative -import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad.Reader.Class as Reader @@ -281,7 +280,7 @@ -- @ -- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r -- @ -views :: (Profunctor p, MonadReader s m) => Over' p (Const r) s a -> p a r -> m r +views :: MonadReader s m => LensLike' (Const r) s a -> (a -> r) -> m r views l f = Reader.asks (getConst #. l (Const #. f)) {-# INLINE views #-} @@ -360,7 +359,7 @@ -- @ -- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r -- @ -uses :: (Profunctor p, MonadState s m) => Over' p (Const r) s a -> p a r -> m r +uses :: MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r uses l f = State.gets (views l f) {-# INLINE uses #-} @@ -456,7 +455,7 @@ -- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf' -- @ iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r -iviews l = views l .# Indexed +iviews l f = asks (getConst #. l (Const #. Indexed f)) {-# INLINE iviews #-} -- | Use the index and value of an 'IndexedGetter' into the current state as a pair. @@ -471,7 +470,7 @@ -- -- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r -iuses l = uses l .# Indexed +iuses l f = gets (getConst #. l (Const #. Indexed f)) {-# INLINE iuses #-} -- | View the index and value of an 'IndexedGetter' or 'IndexedLens'. @@ -494,5 +493,5 @@ -- | Coerce a 'Getter'-compatible 'LensLike' to a 'LensLike''. This -- is useful when using a 'Traversal' that is not simple as a 'Getter' or a -- 'Fold'. -coerced :: (Functor f, Contravariant f) => LensLike f s t a b -> LensLike' f s a -coerced l f = coerce . l (coerce . f) +getting :: (Functor f, Contravariant f) => LensLike f s t a b -> LensLike' f s a +getting l f = phantom . l (phantom . f) diff --git a/src/Control/Lens/Indexed.hs b/src/Control/Lens/Indexed.hs --- a/src/Control/Lens/Indexed.hs +++ b/src/Control/Lens/Indexed.hs @@ -76,6 +76,9 @@ -- * Indexed Folds with Reified Monoid , ifoldMapBy , ifoldMapByOf + -- * Indexed Traversals with Reified Applicative + , itraverseBy + , itraverseByOf ) where import Control.Applicative @@ -100,6 +103,7 @@ import qualified Data.Array as Array import Data.Foldable import Data.Functor.Compose +import Data.Functor.Contravariant import Data.Functor.Product import Data.Functor.Reverse import Data.Hashable @@ -110,6 +114,7 @@ import Data.Map as Map import Data.Monoid hiding (Product) import Data.Profunctor.Unsafe +import Data.Reflection import Data.Sequence hiding ((:<), index) #if !(MIN_VERSION_containers(0,5,0)) import Data.Traversable (sequenceA) @@ -267,7 +272,7 @@ -- >>> Data.Map.fromList [(2, "hello"), (1, "world")]^..ifolded.asIndex -- [1,2] ifolded :: IndexedFold i (f a) a - ifolded = conjoined folded $ \f -> coerce . getFolding . ifoldMap (\i -> Folding #. indexed f i) + ifolded = conjoined folded $ \f -> phantom . getFolding . ifoldMap (\i -> Folding #. indexed f i) {-# INLINE ifolded #-} -- | Right-associative fold of an indexed container with access to the index @i@. @@ -858,7 +863,13 @@ ------------------------------------------------------------------------------- ifoldMapBy :: FoldableWithIndex i t => (r -> r -> r) -> r -> (i -> a -> r) -> t a -> r -ifoldMapBy f z g = reifyFold f z (ifoldMap (\i a -> M (g i a))) +ifoldMapBy f z g = reifyMonoid f z (ifoldMap (\i a -> ReflectedMonoid (g i a))) -ifoldMapByOf :: (forall s. IndexedGetting i (M r s) t a) -> (r -> r -> r) -> r -> (i -> a -> r) -> t -> r -ifoldMapByOf l f z g = reifyFold f z (ifoldMapOf l (\i a -> M (g i a))) +ifoldMapByOf :: IndexedFold i t a -> (r -> r -> r) -> r -> (i -> a -> r) -> t -> r +ifoldMapByOf l f z g = reifyMonoid f z (ifoldMapOf l (\i a -> ReflectedMonoid (g i a))) + +itraverseBy :: TraversableWithIndex i t => (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (i -> a -> f b) -> t a -> f (t b) +itraverseBy pur app f = reifyApplicative pur app (itraverse (\i a -> ReflectedApplicative (f i a))) + +itraverseByOf :: IndexedTraversal i s t a b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (i -> a -> f b) -> s -> f t +itraverseByOf l pur app f = reifyApplicative pur app (itraverseOf l (\i a -> ReflectedApplicative (f i a))) diff --git a/src/Control/Lens/Internal/FieldTH.hs b/src/Control/Lens/Internal/FieldTH.hs --- a/src/Control/Lens/Internal/FieldTH.hs +++ b/src/Control/Lens/Internal/FieldTH.hs @@ -419,7 +419,7 @@ fxs = [ appE (varE f) (varE x) | x <- xs ] body = foldl (\a b -> appsE [varE apValName, a, b]) - (appE (varE coerceValName) (head fxs)) + (appE (varE phantomValName) (head fxs)) (tail fxs) -- clause f (Con x1..xn) = coerce (f x1) <*> ... <*> f xn diff --git a/src/Control/Lens/Internal/Fold.hs b/src/Control/Lens/Internal/Fold.hs --- a/src/Control/Lens/Internal/Fold.hs +++ b/src/Control/Lens/Internal/Fold.hs @@ -26,8 +26,7 @@ , Min(..), getMin , Leftmost(..), getLeftmost , Rightmost(..), getRightmost - , ReifiedMonoid(..), M(..) - , reifyFold + , ReifiedMonoid(..) ) where import Control.Applicative @@ -213,24 +212,3 @@ getRightmost RPure = Nothing getRightmost (RLeaf a) = Just a getRightmost (RStep x) = getRightmost x - ------------------------------------------------------------------------------- --- Folding with Reified Monoid ------------------------------------------------------------------------------- - -data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a } - -instance Reifies s (ReifiedMonoid a) => Monoid (M a s) where - mappend (M x) (M y) = reflectResult (\m -> M (reifiedMappend m x y)) - mempty = reflectResult (\m -> M (reifiedMempty m )) - -reflectResult :: Reifies s a => (a -> f s) -> f s -reflectResult f = let r = f (reflect r) in r - -newtype M a s = M a - -unM :: M a s -> proxy s -> a -unM (M a) _ = a - -reifyFold :: (a -> a -> a) -> a -> (forall s. Reifies s (ReifiedMonoid a) => t -> M a s) -> t -> a -reifyFold f z m xs = reify (ReifiedMonoid f z) (unM (m xs)) diff --git a/src/Control/Lens/Internal/Getter.hs b/src/Control/Lens/Internal/Getter.hs --- a/src/Control/Lens/Internal/Getter.hs +++ b/src/Control/Lens/Internal/Getter.hs @@ -13,9 +13,7 @@ -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Getter - ( - coerce - , noEffect + ( noEffect , AlongsideLeft(..) , AlongsideRight(..) ) where @@ -29,23 +27,11 @@ import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Traversable -import Data.Void import Prelude --- | A 'Functor' you can 'coerce' ignores its argument, which it carries --- solely as a phantom type parameter. --- --- By the 'Functor' and 'Contravariant' laws, an instance of both will --- necessarily satisfy: --- --- @'id' = 'fmap' f = 'coerce' = 'contramap' g@ -coerce :: (Contravariant f, Functor f) => f a -> f b -coerce a = absurd <$> contramap absurd a -{-# INLINE coerce #-} - -- | The 'mempty' equivalent for a 'Contravariant' 'Applicative' 'Functor'. noEffect :: (Contravariant f, Applicative f) => f a -noEffect = coerce $ pure () +noEffect = phantom $ pure () {-# INLINE noEffect #-} newtype AlongsideLeft f b a = AlongsideLeft { getAlongsideLeft :: f (a, b) } diff --git a/src/Control/Lens/Internal/Indexed.hs b/src/Control/Lens/Internal/Indexed.hs --- a/src/Control/Lens/Internal/Indexed.hs +++ b/src/Control/Lens/Internal/Indexed.hs @@ -48,7 +48,6 @@ import Control.Category import Control.Comonad import Control.Lens.Internal.Instances () -import qualified Control.Lens.Internal.Getter as Getter import Control.Monad import Control.Monad.Fix import Data.Distributive @@ -355,5 +354,5 @@ -- | When composed with an 'IndexedFold' or 'IndexedTraversal' this yields an -- ('Indexed') 'Fold' of the indices. asIndex :: (Indexable i p, Contravariant f, Functor f) => p i (f i) -> Indexed i s (f s) -asIndex f = Indexed $ \i _ -> Getter.coerce (indexed f i i) +asIndex f = Indexed $ \i _ -> phantom (indexed f i i) {-# INLINE asIndex #-} diff --git a/src/Control/Lens/Internal/TH.hs b/src/Control/Lens/Internal/TH.hs --- a/src/Control/Lens/Internal/TH.hs +++ b/src/Control/Lens/Internal/TH.hs @@ -30,6 +30,7 @@ ---------------------------------------------------------------------------- module Control.Lens.Internal.TH where +import Data.Functor.Contravariant import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Data.Map as Map @@ -161,8 +162,12 @@ untoValName :: Name untoValName = mkLensName_v "Control.Lens.Review" "unto" -coerceValName :: Name -coerceValName = mkLensName_v "Control.Lens.Internal.Getter" "coerce" +phantomValName :: Name +phantomValName = mkLensName_v "Control.Lens.Internal.TH" "phantom2" + +phantom2 :: (Functor f, Contravariant f) => f a -> f b +phantom2 = phantom +{-# INLINE phantom2 #-} composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs --- a/src/Control/Lens/Iso.hs +++ b/src/Control/Lens/Iso.hs @@ -2,7 +2,13 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif + #ifndef MIN_VERSION_bytestring #define MIN_VERSION_bytestring(x,y,z) 1 #endif @@ -48,10 +54,24 @@ , curried, uncurried , flipped , Swapped(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern Swapped +#endif , Strict(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern Strict + , pattern Lazy +#endif , lazy - , Reversing(..), reversed + , Reversing(..) + , reversed +#if __GLASGOW_HASKELL__ >= 710 + , pattern Reversed +#endif , involuted +#if __GLASGOW_HASKELL__ >= 710 + , pattern List +#endif -- ** Uncommon Isomorphisms , magma , imagma @@ -65,11 +85,17 @@ , rmapping -- * Bifunctors , bimapping +#if __GLASGOW_HASKELL__ >= 710 + -- * Coercions + , coerced +#endif ) where import Control.Lens.Equality (simple) +import Control.Lens.Getter import Control.Lens.Fold import Control.Lens.Internal.Context +import Control.Lens.Internal.Coerce import Control.Lens.Internal.Indexed import Control.Lens.Internal.Iso as Iso import Control.Lens.Internal.Magma @@ -84,7 +110,11 @@ import Control.Monad.RWS.Strict as Strict import Data.ByteString as StrictB hiding (reverse) import Data.ByteString.Lazy as LazyB hiding (reverse) -import Data.Functor.Contravariant + +#if __GLASGOW_HASKELL__ >= 708 +import Data.Coerce +#endif + import Data.Functor.Identity import Data.Text as StrictT hiding (reverse) import Data.Text.Lazy as LazyT hiding (reverse) @@ -93,6 +123,10 @@ import Data.Profunctor import Data.Profunctor.Unsafe +#if __GLASGOW_HASKELL__ >= 710 +import qualified GHC.Exts as Exts +#endif + #ifdef HLINT {-# ANN module "HLint: ignore Use on" #-} #endif @@ -167,8 +201,14 @@ -- -- >>> au (_Wrapping Sum) foldMap [1,2,3,4] -- 10 -au :: AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a -au k = withIso k $ \ sa bt f e -> sa (f bt e) +-- +-- You may want to think of this combinator as having the following, simpler type: +-- +-- @ +-- au :: AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a +-- @ +au :: Functor f => AnIso s t a b -> ((b -> t) -> f s) -> f a +au k = withIso k $ \ sa bt f -> fmap sa (f bt) {-# INLINE au #-} -- | Based on @ala'@ from Conor McBride's work on Epigram. @@ -177,13 +217,19 @@ -- -- For a version you pass the name of the @newtype@ constructor to, see 'Control.Lens.Wrapped.alaf'. -- --- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator --- is 'au' with an extra function argument. --- -- >>> auf (_Unwrapping Sum) (foldMapOf both) Prelude.length ("hello","world") -- 10 -auf :: Profunctor p => AnIso s t a b -> (p r a -> e -> b) -> p r s -> e -> t -auf k = withIso k $ \ sa bt f g e -> bt (f (rmap sa g) e) +-- +-- Mnemonically, the German /auf/ plays a similar role to /à la/, and the combinator +-- is 'au' with an extra function argument: +-- +-- @ +-- 'auf' :: 'Iso' s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t +-- @ +-- +-- but the signature is general. +auf :: (Functor f, Functor g) => Optic (Costar f) g s t a b -> (f a -> g b) -> f s -> g t +auf = coerce {-# INLINE auf #-} -- | The opposite of working 'Control.Lens.Setter.over' a 'Setter' is working 'under' an isomorphism. @@ -367,6 +413,20 @@ class Strict lazy strict | lazy -> strict, strict -> lazy where strict :: Iso' lazy strict +#if __GLASGOW_HASKELL__ >= 710 +pattern Strict a <- (view strict -> a) where + Strict a = review strict a + +pattern Lazy a <- (view lazy -> a) where + Lazy a = review lazy a + +pattern Swapped a <- (view swapped -> a) where + Swapped a = review swapped a + +pattern Reversed a <- (view reversed -> a) where + Reversed a = review reversed a +#endif + instance Strict LazyB.ByteString StrictB.ByteString where #if MIN_VERSION_bytestring(0,10,0) strict = iso LazyB.toStrict LazyB.fromStrict @@ -428,6 +488,11 @@ involuted a = iso a a {-# INLINE involuted #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern List a <- (Exts.toList -> a) where + List a = Exts.fromList a +#endif + ------------------------------------------------------------------------------ -- Magma ------------------------------------------------------------------------------ @@ -509,3 +574,13 @@ bimapping f g = withIso f $ \ sa bt -> withIso g $ \s'a' b't' -> iso (bimap sa s'a') (bimap bt b't') {-# INLINE bimapping #-} + +#if __GLASGOW_HASKELL__ >= 710 +-- | Data types that are representationally equal are isomorphic. +-- +-- This is only available on GHC 7.10+ +-- +-- @since 4.13 +coerced :: forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b +coerced l = rmap (fmap coerce') l .# coerce +#endif diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs --- a/src/Control/Lens/Lens.hs +++ b/src/Control/Lens/Lens.hs @@ -290,7 +290,7 @@ -- ('%%~') :: 'Lens' s t a b -> (a -> (r, b)) -> s -> (r, t) -- ('%%~') :: 'Monoid' m => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> (m, b)) -> s -> (m, t) -- @ -(%%~) :: Optical p q f s t a b -> p a (f b) -> q s (f t) +(%%~) :: LensLike f s t a b -> (a -> f b) -> s -> f t (%%~) = id {-# INLINE (%%~) #-} @@ -552,8 +552,8 @@ -- ('<%~') :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> (b, t) -- ('<%~') :: 'Monoid' b => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> (b, t) -- @ -(<%~) :: Profunctor p => Optical p q ((,) b) s t a b -> p a b -> q s (b, t) -l <%~ f = l $ rmap (\t -> (t, t)) f +(<%~) :: LensLike ((,) b) s t a b -> (a -> b) -> s -> (b, t) +l <%~ f = l $ (\t -> (t, t)) . f {-# INLINE (<%~) #-} -- | Increment the target of a numerically valued 'Lens' and return the result. @@ -564,7 +564,7 @@ -- ('<+~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<+~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<+~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<+~) :: Num a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <+~ a = l <%~ (+ a) {-# INLINE (<+~) #-} @@ -576,7 +576,7 @@ -- ('<-~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<-~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<-~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<-~) :: Num a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <-~ a = l <%~ subtract a {-# INLINE (<-~) #-} @@ -589,7 +589,7 @@ -- ('<*~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<*~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<*~) :: Num a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<*~) :: Num a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <*~ a = l <%~ (* a) {-# INLINE (<*~) #-} @@ -601,7 +601,7 @@ -- (' 'Lens'' s a -> a -> s -> (a, s) -- (' 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -( Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +( LensLike ((,)a) s t a a -> a -> s -> (a, t) l 'Lens'' s a -> e -> s -> (a, s) -- ('<^~') :: ('Num' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> s -> (a, s) -- @ -(<^~) :: (Num a, Integral e) => Optical (->) q ((,)a) s t a a -> e -> q s (a, t) +(<^~) :: (Num a, Integral e) => LensLike ((,)a) s t a a -> e -> s -> (a, t) l <^~ e = l <%~ (^ e) {-# INLINE (<^~) #-} @@ -627,7 +627,7 @@ -- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) -- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> s -> (a, s) -- @ -(<^^~) :: (Fractional a, Integral e) => Optical (->) q ((,)a) s t a a -> e -> q s (a, t) +(<^^~) :: (Fractional a, Integral e) => LensLike ((,)a) s t a a -> e -> s -> (a, t) l <^^~ e = l <%~ (^^ e) {-# INLINE (<^^~) #-} @@ -640,7 +640,7 @@ -- ('<**~') :: 'Floating' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<**~') :: 'Floating' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ -(<**~) :: Floating a => Optical (->) q ((,)a) s t a a -> a -> q s (a, t) +(<**~) :: Floating a => LensLike ((,)a) s t a a -> a -> s -> (a, t) l <**~ a = l <%~ (** a) {-# INLINE (<**~) #-} @@ -652,7 +652,7 @@ -- ('<||~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<||~') :: 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @ -(<||~) :: Optical (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t) +(<||~) :: LensLike ((,)Bool) s t Bool Bool -> Bool -> s -> (Bool, t) l <||~ b = l <%~ (|| b) {-# INLINE (<||~) #-} @@ -664,7 +664,7 @@ -- ('<&&~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<&&~') :: 'Control.Lens.Iso.Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @ -(<&&~) :: Optical (->) q ((,)Bool) s t Bool Bool -> Bool -> q s (Bool, t) +(<&&~) :: LensLike ((,)Bool) s t Bool Bool -> Bool -> s -> (Bool, t) l <&&~ b = l <%~ (&& b) {-# INLINE (<&&~) #-} @@ -677,7 +677,7 @@ -- ('<<%~') :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> (a, t) -- ('<<%~') :: 'Monoid' a => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> (a, t) -- @ -(<<%~) :: Strong p => Optical p q ((,)a) s t a b -> p a b -> q s (a, t) +(<<%~) :: LensLike ((,)a) s t a b -> (a -> b) -> s -> (a, t) (<<%~) l = l . lmap (\a -> (a, a)) . second' {-# INLINE (<<%~) #-} @@ -690,7 +690,7 @@ -- ('<<.~') :: 'Control.Lens.Iso.Iso' s t a b -> b -> s -> (a, t) -- ('<<.~') :: 'Monoid' a => 'Control.Lens.Traversal.Traversal' s t a b -> b -> s -> (a, t) -- @ -(<<.~) :: Optical (->) q ((,)a) s t a b -> b -> q s (a, t) +(<<.~) :: LensLike ((,)a) s t a b -> b -> s -> (a, t) l <<.~ b = l $ \a -> (a, b) {-# INLINE (<<.~) #-} @@ -708,7 +708,7 @@ -- ('<<+~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<+~') :: 'Num' a => 'Iso'' s a -> a -> s -> (a, s) -- @ -(<<+~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +(<<+~) :: Num a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<+~ b = l $ \a -> (a, a + b) {-# INLINE (<<+~) #-} @@ -726,7 +726,7 @@ -- ('<<-~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<-~') :: 'Num' a => 'Iso'' s a -> a -> s -> (a, s) -- @ -(<<-~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +(<<-~) :: Num a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<-~ b = l $ \a -> (a, a - b) {-# INLINE (<<-~) #-} @@ -744,7 +744,7 @@ -- ('<<*~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<*~') :: 'Num' a => 'Iso'' s a -> a -> s -> (a, s) -- @ -(<<*~) :: Num a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +(<<*~) :: Num a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<*~ b = l $ \a -> (a, a * b) {-# INLINE (<<*~) #-} @@ -762,7 +762,7 @@ -- ('< 'Lens'' s a -> a -> s -> (a, s) -- ('< 'Iso'' s a -> a -> s -> (a, s) -- @ -(< Optical' (->) q ((,) a) s a -> a -> q s (a, s) +(< LensLike' ((,) a) s a -> a -> s -> (a, s) l < (a, a / b) {-# INLINE (< 'Lens'' s a -> e -> s -> (a, s) -- ('<<^~') :: ('Num' a, 'Integral' e) => 'Iso'' s a -> e -> s -> (a, s) -- @ -(<<^~) :: (Num a, Integral e) => Optical' (->) q ((,) a) s a -> e -> q s (a, s) +(<<^~) :: (Num a, Integral e) => LensLike' ((,) a) s a -> e -> s -> (a, s) l <<^~ e = l $ \a -> (a, a ^ e) {-# INLINE (<<^~) #-} @@ -786,7 +786,7 @@ -- ('<<^^~') :: ('Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) -- ('<<^^~') :: ('Fractional' a, 'Integral' e) => 'Iso'' s a -> e -> S -> (a, s) -- @ -(<<^^~) :: (Fractional a, Integral e) => Optical' (->) q ((,) a) s a -> e -> q s (a, s) +(<<^^~) :: (Fractional a, Integral e) => LensLike' ((,) a) s a -> e -> s -> (a, s) l <<^^~ e = l $ \a -> (a, a ^^ e) {-# INLINE (<<^^~) #-} @@ -804,7 +804,7 @@ -- ('<<**~') :: 'Floating' a => 'Lens'' s a -> a -> s -> (a, s) -- ('<<**~') :: 'Floating' a => 'Iso'' s a -> a -> s -> (a, s) -- @ -(<<**~) :: Floating a => Optical' (->) q ((,) a) s a -> a -> q s (a, s) +(<<**~) :: Floating a => LensLike' ((,) a) s a -> a -> s -> (a, s) l <<**~ e = l $ \a -> (a, a ** e) {-# INLINE (<<**~) #-} @@ -822,7 +822,7 @@ -- ('<<||~') :: 'Lens'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- ('<<||~') :: 'Iso'' s 'Bool' -> 'Bool' -> s -> ('Bool', s) -- @ -(<<||~) :: Optical' (->) q ((,) Bool) s Bool -> Bool -> q s (Bool, s) +(<<||~) :: LensLike' ((,) Bool) s Bool -> Bool -> s -> (Bool, s) l <<||~ b = l $ \a -> (a, b || a) {-# INLINE (<<||~) #-} @@ -840,7 +840,7 @@ -- ('<<&&~') :: 'Lens'' s Bool -> Bool -> s -> (Bool, s) -- ('<<&&~') :: 'Iso'' s Bool -> Bool -> s -> (Bool, s) -- @ -(<<&&~) :: Optical' (->) q ((,) Bool) s Bool -> Bool -> q s (Bool, s) +(<<&&~) :: LensLike' ((,) Bool) s Bool -> Bool -> s -> (Bool, s) l <<&&~ b = l $ \a -> (a, b && a) {-# INLINE (<<&&~) #-} @@ -858,7 +858,7 @@ -- ('<<<>~') :: 'Monoid' r => 'Lens'' s r -> r -> s -> (r, s) -- ('<<<>~') :: 'Monoid' r => 'Iso'' s r -> r -> s -> (r, s) -- @ -(<<<>~) :: Monoid r => Optical' (->) q ((,) r) s r -> r -> q s (r, s) +(<<<>~) :: Monoid r => LensLike' ((,) r) s r -> r -> s -> (r, s) l <<<>~ b = l $ \a -> (a, a `mappend` b) {-# INLINE (<<<>~) #-} @@ -879,8 +879,8 @@ -- ('<%=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> a) -> m a -- ('<%=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a -- @ -(<%=) :: (Profunctor p, MonadState s m) => Over p ((,)b) s s a b -> p a b -> m b -l <%= f = l %%= rmap (\b -> (b, b)) f +(<%=) :: MonadState s m => LensLike ((,)b) s s a b -> (a -> b) -> m b +l <%= f = l %%= (\b -> (b, b)) . f {-# INLINE (<%=) #-} @@ -1015,7 +1015,7 @@ -- @ -- ('<<%=') :: 'MonadState' s m => 'Lens'' s a -> (a -> a) -> m a -- ('<<%=') :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> a) -> m a --- ('<<%=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a +-- ('<<%=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> a) -> m a -- @ -- -- @('<<%=') :: 'MonadState' s m => 'LensLike' ((,)a) s s a b -> (a -> b) -> m a@ @@ -1190,7 +1190,7 @@ -- return the result. -- -- When you do not need the result of the operation, ('Control.Lens.Setter.<>~') is more flexible. -(<<>~) :: Monoid m => Optical (->) q ((,)m) s t m m -> m -> q s (m, t) +(<<>~) :: Monoid m => LensLike ((,)m) s t m m -> m -> s -> (m, t) l <<>~ m = l <%~ (`mappend` m) {-# INLINE (<<>~) #-} @@ -1240,7 +1240,7 @@ -- ('<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (b, t) -- ('<%@~') :: 'Monoid' b => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (b, t) -- @ -(<%@~) :: Optical (Indexed i) q ((,) b) s t a b -> (i -> a -> b) -> q s (b, t) +(<%@~) :: Over (Indexed i) ((,) b) s t a b -> (i -> a -> b) -> s -> (b, t) l <%@~ f = l (Indexed $ \i a -> let b = f i a in (b, b)) {-# INLINE (<%@~) #-} @@ -1252,7 +1252,7 @@ -- ('<<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (a, t) -- ('<<%@~') :: 'Monoid' a => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (a, t) -- @ -(<<%@~) :: Optical (Indexed i) q ((,) a) s t a b -> (i -> a -> b) -> q s (a, t) +(<<%@~) :: Over (Indexed i) ((,) a) s t a b -> (i -> a -> b) -> s -> (a, t) l <<%@~ f = l $ Indexed $ \i a -> second' (f i) (a,a) {-# INLINE (<<%@~) #-} diff --git a/src/Control/Lens/Plated.hs b/src/Control/Lens/Plated.hs --- a/src/Control/Lens/Plated.hs +++ b/src/Control/Lens/Plated.hs @@ -357,10 +357,10 @@ -- | Rewrite recursively over part of a larger structure using a specified 'Setter'. -- -- @ --- 'rewriteOnOf' :: 'Plated' a => 'Control.Lens.Iso.Iso'' s a -> 'Control.Lens.Iso.Iso'' a a -> (a -> 'Maybe' a) -> s -> s --- 'rewriteOnOf' :: 'Plated' a => 'Lens'' s a -> 'Lens'' a a -> (a -> 'Maybe' a) -> s -> s --- 'rewriteOnOf' :: 'Plated' a => 'Traversal'' s a -> 'Traversal'' a a -> (a -> 'Maybe' a) -> s -> s --- 'rewriteOnOf' :: 'Plated' a => 'Setter'' s a -> 'Setter'' a a -> (a -> 'Maybe' a) -> s -> s +-- 'rewriteOnOf' :: 'Control.Lens.Iso.Iso'' s a -> 'Control.Lens.Iso.Iso'' a a -> (a -> 'Maybe' a) -> s -> s +-- 'rewriteOnOf' :: 'Lens'' s a -> 'Lens'' a a -> (a -> 'Maybe' a) -> s -> s +-- 'rewriteOnOf' :: 'Traversal'' s a -> 'Traversal'' a a -> (a -> 'Maybe' a) -> s -> s +-- 'rewriteOnOf' :: 'Setter'' s a -> 'Setter'' a a -> (a -> 'Maybe' a) -> s -> s -- @ rewriteOnOf :: ASetter s t a a -> ASetter' a a -> (a -> Maybe a) -> s -> t rewriteOnOf b l = over b . rewriteOf l diff --git a/src/Control/Lens/Reified.hs b/src/Control/Lens/Reified.hs --- a/src/Control/Lens/Reified.hs +++ b/src/Control/Lens/Reified.hs @@ -28,6 +28,7 @@ import Data.Distributive import Data.Foldable import Data.Functor.Compose +import Data.Functor.Contravariant import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Identity @@ -189,10 +190,10 @@ instance Strong ReifiedGetter where first' l = Getter $ \f (s,c) -> - coerce $ runGetter l (dimap (flip (,) c) coerce f) s + phantom $ runGetter l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = Getter $ \f (c,s) -> - coerce $ runGetter l (dimap ((,) c) coerce f) s + phantom $ runGetter l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Choice ReifiedGetter where @@ -258,10 +259,10 @@ instance Strong (ReifiedIndexedGetter i) where first' l = IndexedGetter $ \f (s,c) -> - coerce $ runIndexedGetter l (dimap (flip (,) c) coerce f) s + phantom $ runIndexedGetter l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = IndexedGetter $ \f (c,s) -> - coerce $ runIndexedGetter l (dimap ((,) c) coerce f) s + phantom $ runIndexedGetter l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Functor (ReifiedIndexedGetter i s) where @@ -272,7 +273,7 @@ IndexedGetter mf <.> IndexedGetter ma = IndexedGetter $ \k s -> case iview mf s of (i, f) -> case iview ma s of - (j, a) -> coerce $ indexed k (i <> j) (f a) + (j, a) -> phantom $ indexed k (i <> j) (f a) {-# INLINE (<.>) #-} ------------------------------------------------------------------------------ @@ -306,10 +307,10 @@ instance Strong ReifiedFold where first' l = Fold $ \f (s,c) -> - coerce $ runFold l (dimap (flip (,) c) coerce f) s + phantom $ runFold l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = Fold $ \f (c,s) -> - coerce $ runFold l (dimap ((,) c) coerce f) s + phantom $ runFold l (dimap ((,) c) phantom f) s {-# INLINE second' #-} instance Choice ReifiedFold where @@ -460,15 +461,15 @@ instance Representable (ReifiedIndexedFold i) where type Rep (ReifiedIndexedFold i) = Compose [] ((,) i) - tabulate k = IndexedFold $ \f -> coerce . traverse_ (coerce . uncurry (indexed f)) . getCompose . k + tabulate k = IndexedFold $ \f -> phantom . traverse_ (phantom . uncurry (indexed f)) . getCompose . k {-# INLINE tabulate #-} instance Strong (ReifiedIndexedFold i) where first' l = IndexedFold $ \f (s,c) -> - coerce $ runIndexedFold l (dimap (flip (,) c) coerce f) s + phantom $ runIndexedFold l (dimap (flip (,) c) phantom f) s {-# INLINE first' #-} second' l = IndexedFold $ \f (c,s) -> - coerce $ runIndexedFold l (dimap ((,) c) coerce f) s + phantom $ runIndexedFold l (dimap ((,) c) phantom f) s {-# INLINE second' #-} ------------------------------------------------------------------------------ diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs --- a/src/Control/Lens/Setter.hs +++ b/src/Control/Lens/Setter.hs @@ -57,7 +57,7 @@ , (.~), (%~) , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (<>~), (&&~), (<.~), (?~), (=), (&&=), (<.=), (?=), ( (a -> b) -> s -> t -- 'over' :: 'ASetter' s t a b -> (a -> b) -> s -> t -- @ -over :: Profunctor p => Setting p s t a b -> p a b -> s -> t +over :: ASetter s t a b -> (a -> b) -> s -> t over l f = runIdentity #. l (Identity #. f) {-# INLINE over #-} @@ -447,7 +447,7 @@ -- ('%~') :: 'Lens' s t a b -> (a -> b) -> s -> t -- ('%~') :: 'Traversal' s t a b -> (a -> b) -> s -> t -- @ -(%~) :: Profunctor p => Setting p s t a b -> p a b -> s -> t +(%~) :: ASetter s t a b -> (a -> b) -> s -> t (%~) = over {-# INLINE (%~) #-} @@ -794,10 +794,15 @@ -- @ -- ('%=') :: 'MonadState' s m => 'ASetter' s s a b -> (a -> b) -> m () -- @ -(%=) :: (Profunctor p, MonadState s m) => Setting p s s a b -> p a b -> m () +(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () l %= f = State.modify (l %~ f) {-# INLINE (%=) #-} +-- | This is an alias for ('%='). +modifying :: MonadState s m => ASetter s s a b -> (a -> b) -> m () +modifying l f = State.modify (over l f) +{-# INLINE modifying #-} + -- | Replace the target of a 'Lens' or all of the targets of a 'Setter' or 'Traversal' in our monadic -- state with 'Just' a new value, irrespective of the old. -- @@ -1129,7 +1134,7 @@ -- 'iover' :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ iover :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t -iover l = over l .# Indexed +iover l f = runIdentity #. l (Identity #. Indexed f) {-# INLINE iover #-} -- | Set with index. Equivalent to 'iover' with the current value ignored. @@ -1165,8 +1170,8 @@ -- 'iover' '.' 'isets' ≡ 'id' -- @ -- --- Another way to view 'sets' is that it takes a \"semantic editor combinator\" --- and transforms it into a 'Setter'. +-- Another way to view 'isets' is that it takes a \"semantic editor combinator\" +-- which has been modified to carry an index and transforms it into a 'IndexedSetter'. isets :: ((i -> a -> b) -> s -> t) -> IndexedSetter i s t a b isets f = sets (f . indexed) {-# INLINE isets #-} @@ -1190,7 +1195,7 @@ -- ('%@~') :: 'IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ (%@~) :: AnIndexedSetter i s t a b -> (i -> a -> b) -> s -> t -l %@~ f = l %~ Indexed f +(%@~) = iover {-# INLINE (%@~) #-} -- | Replace every target of an 'IndexedSetter', 'IndexedLens' or 'IndexedTraversal' @@ -1212,7 +1217,7 @@ -- ('.@~') :: 'IndexedTraversal' i s t a b -> (i -> b) -> s -> t -- @ (.@~) :: AnIndexedSetter i s t a b -> (i -> b) -> s -> t -l .@~ f = l %~ Indexed (const . f) +l .@~ f = runIdentity #. l (Identity #. Indexed (const . f)) {-# INLINE (.@~) #-} -- | Adjust every target in the current state of an 'IndexedSetter', 'IndexedLens' or 'IndexedTraversal' @@ -1233,6 +1238,11 @@ l %@= f = State.modify (l %@~ f) {-# INLINE (%@=) #-} +-- | This is an alias for ('%@='). +imodifying :: MonadState s m => AnIndexedSetter i s s a b -> (i -> a -> b) -> m () +imodifying l f = State.modify (iover l f) +{-# INLINE imodifying #-} + -- | Replace every target in the current state of an 'IndexedSetter', 'IndexedLens' or 'IndexedTraversal' -- with access to the index. -- @@ -1291,7 +1301,7 @@ ------------------------------------------------------------------------------ -- | 'mapOf' is a deprecated alias for 'over'. -mapOf :: Profunctor p => Setting p s t a b -> p a b -> s -> t +mapOf :: ASetter s t a b -> (a -> b) -> s -> t mapOf = over {-# INLINE mapOf #-} {-# DEPRECATED mapOf "Use `over`" #-} diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs --- a/src/Control/Lens/Traversal.hs +++ b/src/Control/Lens/Traversal.hs @@ -113,6 +113,12 @@ , imapAccumROf , imapAccumLOf + -- * Reflection + , traverseBy + , traverseByOf + , sequenceBy + , sequenceByOf + -- * Implementation Details , Bazaar(..), Bazaar' , Bazaar1(..), Bazaar1' @@ -128,7 +134,7 @@ import Control.Category import Control.Comonad import Control.Lens.Fold -import Control.Lens.Getter (Getting, IndexedGetting, coerced) +import Control.Lens.Getter (Getting, IndexedGetting, getting) import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed @@ -154,6 +160,7 @@ import Data.Profunctor.Rep import Data.Profunctor.Sieve import Data.Profunctor.Unsafe +import Data.Reflection import Data.Semigroup.Traversable import Data.Tagged import Data.Traversable @@ -267,7 +274,7 @@ -- 'traverseOf' :: 'Functor' f => 'Lens' s t a b -> (a -> f b) -> s -> f t -- 'traverseOf' :: 'Applicative' f => 'Traversal' s t a b -> (a -> f b) -> s -> f t -- @ -traverseOf :: Over p f s t a b -> p a (f b) -> s -> f t +traverseOf :: LensLike f s t a b -> (a -> f b) -> s -> f t traverseOf = id {-# INLINE traverseOf #-} @@ -296,7 +303,7 @@ -- 'forOf' :: 'Functor' f => 'Lens' s t a b -> s -> (a -> f b) -> f t -- 'forOf' :: 'Applicative' f => 'Traversal' s t a b -> s -> (a -> f b) -> f t -- @ -forOf :: Over p f s t a b -> s -> p a (f b) -> f t +forOf :: LensLike f s t a b -> s -> (a -> f b) -> f t forOf = flip {-# INLINE forOf #-} @@ -336,7 +343,7 @@ -- 'mapMOf' :: 'Monad' m => 'Lens' s t a b -> (a -> m b) -> s -> m t -- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t -- @ -mapMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t +mapMOf :: LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t mapMOf l cmd = unwrapMonad #. l (WrapMonad #. cmd) {-# INLINE mapMOf #-} @@ -356,7 +363,7 @@ -- 'forMOf' :: 'Monad' m => 'Lens' s t a b -> s -> (a -> m b) -> m t -- 'forMOf' :: 'Monad' m => 'Traversal' s t a b -> s -> (a -> m b) -> m t -- @ -forMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> s -> p a (m b) -> m t +forMOf :: LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t forMOf l a cmd = unwrapMonad (l (WrapMonad #. cmd) a) {-# INLINE forMOf #-} @@ -418,7 +425,7 @@ -- @ -- 'mapAccumROf' :: 'LensLike' ('Backwards' ('State' acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ -mapAccumROf :: Conjoined p => Over p (Backwards (State acc)) s t a b -> p acc (a -> (acc, b)) -> acc -> s -> (acc, t) +mapAccumROf :: LensLike (Backwards (State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) mapAccumROf = mapAccumLOf . backwards {-# INLINE mapAccumROf #-} @@ -441,9 +448,9 @@ -- 'mapAccumLOf' l f acc0 s = 'swap' ('runState' (l (\a -> 'state' (\acc -> 'swap' (f acc a))) s) acc0) -- @ -- -mapAccumLOf :: Conjoined p => Over p (State acc) s t a b -> p acc (a -> (acc, b)) -> acc -> s -> (acc, t) +mapAccumLOf :: LensLike (State acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) mapAccumLOf l f acc0 s = swap (runState (l g s) acc0) where - g = cotabulate $ \wa -> state $ \acc -> swap (cosieve f (acc <$ wa) (extract wa)) + g a = state $ \acc -> swap (f acc a) -- This would be much cleaner if the argument order for the function was swapped. {-# INLINE mapAccumLOf #-} @@ -693,7 +700,7 @@ ------------------------------------------------------------------------------ ins :: Bizarre (->) w => w a b t -> [a] -ins = toListOf (coerced bazaar) +ins = toListOf (getting bazaar) {-# INLINE ins #-} wins :: (Bizarre p w, Corepresentable p, Comonad (Corep p)) => w a b t -> [a] @@ -862,7 +869,7 @@ -- former can execute at full speed, while the latter needs to round trip through -- the 'Bazaar'. -- --- >>> let foo l a = (view (coerced (cloneTraversal l)) a, set (cloneTraversal l) 10 a) +-- >>> let foo l a = (view (getting (cloneTraversal l)) a, set (cloneTraversal l) 10 a) -- >>> foo both ("hello","world") -- ("helloworld",(10,10)) -- @@ -954,8 +961,8 @@ -- 'imapMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> (i -> a -> m b) -> s -> m t -- 'imapMOf' :: 'Bind' m => 'IndexedTraversal1' i s t a b -> (i -> a -> m b) -> s -> m t -- @ -imapMOf :: (Indexed i a (WrappedMonad m b) -> s -> WrappedMonad m t) -> (i -> a -> m b) -> s -> m t -imapMOf l = mapMOf l .# Indexed +imapMOf :: Over (Indexed i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t +imapMOf l cmd = unwrapMonad #. l (WrapMonad #. Indexed cmd) {-# INLINE imapMOf #-} -- | Map each element of a structure targeted by a 'Lens' to a monadic action, @@ -988,7 +995,7 @@ -- 'imapAccumROf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ imapAccumROf :: Over (Indexed i) (Backwards (State acc)) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -imapAccumROf l = mapAccumROf l .# Indexed +imapAccumROf = imapAccumLOf . backwards {-# INLINE imapAccumROf #-} -- | Generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'IndexedTraversal' with access to the index. @@ -1004,7 +1011,8 @@ -- 'imapAccumLOf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ imapAccumLOf :: Over (Indexed i) (State acc) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -imapAccumLOf l = mapAccumLOf l .# Indexed +imapAccumLOf l f acc0 s = swap (runState (l (Indexed g) s) acc0) where + g i a = state $ \acc -> swap (f i acc a) {-# INLINE imapAccumLOf #-} ------------------------------------------------------------------------------ @@ -1171,8 +1179,8 @@ -- @ -- 'failover' :: Alternative m => Traversal s t a b -> (a -> b) -> s -> m t -- @ -failover :: (Profunctor p, Alternative m) => Over p ((,) Any) s t a b -> p a b -> s -> m t -failover l pafb s = case l ((,) (Any True) `rmap` pafb) s of +failover :: Alternative m => LensLike ((,) Any) s t a b -> (a -> b) -> s -> m t +failover l afb s = case l ((,) (Any True) . afb) s of (Any True, t) -> pure t (Any False, _) -> Applicative.empty {-# INLINE failover #-} @@ -1183,7 +1191,9 @@ -- 'ifailover' :: Alternative m => IndexedTraversal i s t a b -> (i -> a -> b) -> s -> m t -- @ ifailover :: Alternative m => Over (Indexed i) ((,) Any) s t a b -> (i -> a -> b) -> s -> m t -ifailover l f = failover l (Indexed f) +ifailover l iafb s = case l ((,) (Any True) `rmap` Indexed iafb) s of + (Any True, t) -> pure t + (Any False, _) -> Applicative.empty {-# INLINE ifailover #-} -- | Try the first 'Traversal' (or 'Fold'), falling back on the second 'Traversal' (or 'Fold') if it returns no entries. @@ -1290,3 +1300,23 @@ {-# INLINE yap #-} {-# INLINE confusing #-} + +-- | Traverse a container using a specified 'Applicative'. +-- +-- This is like 'traverseBy' where the 'Traversable' instance can be specified by any 'Traversal' +-- +-- @ +-- 'traverseByOf' 'traverse' ≡ 'traverseBy' +-- @ +traverseByOf :: Traversal s t a b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (a -> f b) -> s -> f t +traverseByOf l pur app f = reifyApplicative pur app (l (ReflectedApplicative #. f)) + +-- | Sequence a container using a specified 'Applicative'. +-- +-- This is like 'traverseBy' where the 'Traversable' instance can be specified by any 'Traversal' +-- +-- @ +-- 'sequenceByOf' 'traverse' ≡ 'sequenceBy' +-- @ +sequenceByOf :: Traversal s t (f b) b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> s -> f t +sequenceByOf l pur app = reifyApplicative pur app (l ReflectedApplicative) diff --git a/src/Control/Lens/Type.hs b/src/Control/Lens/Type.hs --- a/src/Control/Lens/Type.hs +++ b/src/Control/Lens/Type.hs @@ -545,7 +545,7 @@ type Optic p f s t a b = p a (f b) -> p s (f t) -- | @ --- type 'Optic'' p q f s a = 'Simple' ('Optic' p q f) s a +-- type 'Optic'' p f s a = 'Simple' ('Optic' p f) s a -- @ type Optic' p f s a = Optic p f s s a a diff --git a/src/Control/Lens/Wrapped.hs b/src/Control/Lens/Wrapped.hs --- a/src/Control/Lens/Wrapped.hs +++ b/src/Control/Lens/Wrapped.hs @@ -6,12 +6,20 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 + +#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif + #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif + +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif + {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} #ifndef MIN_VERSION_base @@ -62,8 +70,14 @@ -- * Operations , op , ala, alaf +#if __GLASGOW_HASKELL__ >= 710 + -- * Pattern Synonyms + , pattern Wrapped + , pattern Unwrapped +#endif ) where + import Control.Applicative import Control.Arrow import Control.Applicative.Backwards @@ -71,6 +85,9 @@ import Control.Exception import Control.Lens.Getter import Control.Lens.Iso +#if __GLASGOW_HASKELL__ >= 710 +import Control.Lens.Review +#endif import Control.Monad.Trans.Cont import Control.Monad.Trans.Error import Control.Monad.Trans.Identity @@ -108,6 +125,12 @@ import Data.Vector.Unboxed as Unboxed import Data.Vector.Storable as Storable +#if MIN_VERSION_base(4,6,0) +import Data.Ord (Down(Down)) +#else +import GHC.Exts (Down(Down)) +#endif + #ifdef HLINT {-# ANN module "HLint: ignore Use uncurry" #-} #endif @@ -123,6 +146,16 @@ -- | An isomorphism between @s@ and @a@. _Wrapped' :: Iso' s (Unwrapped s) +#if __GLASGOW_HASKELL__ >= 710 + +pattern Wrapped a <- (view _Wrapped -> a) where + Wrapped a = review _Wrapped a + +pattern Unwrapped a <- (view _Unwrapped -> a) where + Unwrapped a = review _Unwrapped a + +#endif + -- This can be used to help inference between the wrappers class Wrapped s => Rewrapped (s :: *) (t :: *) @@ -131,6 +164,7 @@ _Unwrapped' :: Wrapped s => Iso' (Unwrapped s) s _Unwrapped' = from _Wrapped' +{-# INLINE _Unwrapped' #-} -- | Work under a newtype wrapper. -- @@ -249,6 +283,11 @@ _Wrapped' = iso getArrowMonad ArrowMonad {-# INLINE _Wrapped' #-} +instance t ~ Down a => Rewrapped (Down a) t +instance Wrapped (Down a) where + type Unwrapped (Down a) = a + _Wrapped' = iso (\(Down a) -> a) Down + -- * transformers instance (t ~ Backwards g b) => Rewrapped (Backwards f a) t @@ -679,7 +718,15 @@ -- -- >>> ala Product foldMap [1,2,3,4] -- 24 -ala :: Rewrapping s t => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> e -> s) -> e -> Unwrapped s +-- +-- +-- You may want to think of this combinator as having the following, simpler, type. +-- +-- @ +-- ala :: Rewrapping s t => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> e -> s) -> e -> Unwrapped s +-- @ + +ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s) ala = au . _Wrapping {-# INLINE ala #-} @@ -687,8 +734,12 @@ -- -- As with '_Wrapping', the user supplied function for the newtype is /ignored/. -- +-- @ +-- alaf :: Rewrapping s t => (Unwrapped s -> s) -> ((r -> t) -> e -> s) -> (r -> Unwrapped t) -> e -> Unwrapped s +-- @ +-- -- >>> alaf Sum foldMap Prelude.length ["hello","world"] -- 10 -alaf :: (Profunctor p, Rewrapping s t) => (Unwrapped s -> s) -> (p r t -> e -> s) -> p r (Unwrapped t) -> e -> Unwrapped s +alaf :: (Functor f, Functor g, Rewrapping s t) => (Unwrapped s -> s) -> (f t -> g s) -> f (Unwrapped t) -> g (Unwrapped s) alaf = auf . _Unwrapping {-# INLINE alaf #-} diff --git a/src/Data/ByteString/Lazy/Lens.hs b/src/Data/ByteString/Lazy/Lens.hs --- a/src/Data/ByteString/Lazy/Lens.hs +++ b/src/Data/ByteString/Lazy/Lens.hs @@ -1,4 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} + +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lazy.Lens @@ -13,6 +20,10 @@ module Data.ByteString.Lazy.Lens ( packedBytes, unpackedBytes, bytes , packedChars, unpackedChars, chars +#if __GLASGOW_HASKELL__ >= 710 + , pattern Bytes + , pattern Chars +#endif ) where import Control.Lens @@ -127,3 +138,11 @@ chars :: IndexedTraversal' Int64 ByteString Char chars = traversedLazy8 {-# INLINE chars #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Bytes b <- (view unpackedBytes -> b) where + Bytes b = review unpackedBytes b + +pattern Chars b <- (view unpackedChars -> b) where + Chars b = review unpackedChars b +#endif diff --git a/src/Data/ByteString/Lens.hs b/src/Data/ByteString/Lens.hs --- a/src/Data/ByteString/Lens.hs +++ b/src/Data/ByteString/Lens.hs @@ -1,4 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lens @@ -13,6 +18,10 @@ ( IsByteString(..) , unpackedBytes , unpackedChars +#if __GLASGOW_HASKELL__ >= 710 + , pattern Bytes + , pattern Chars +#endif ) where import Control.Lens @@ -100,6 +109,14 @@ unpackedBytes :: IsByteString t => Iso' t [Word8] unpackedBytes = from packedBytes {-# INLINE unpackedBytes #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Bytes b <- (view unpackedBytes -> b) where + Bytes b = review unpackedBytes b + +pattern Chars b <- (view unpackedChars -> b) where + Chars b = review unpackedChars b +#endif -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of characters into a strict (or lazy) 'ByteString' -- diff --git a/src/Data/ByteString/Strict/Lens.hs b/src/Data/ByteString/Strict/Lens.hs --- a/src/Data/ByteString/Strict/Lens.hs +++ b/src/Data/ByteString/Strict/Lens.hs @@ -1,5 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Strict.Lens @@ -13,6 +18,10 @@ module Data.ByteString.Strict.Lens ( packedBytes, unpackedBytes, bytes , packedChars, unpackedChars, chars +#if __GLASGOW_HASKELL__ >= 710 + , pattern Bytes + , pattern Chars +#endif ) where import Control.Lens @@ -126,3 +135,12 @@ chars :: IndexedTraversal' Int ByteString Char chars = traversedStrictTree8 {-# INLINE chars #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Bytes b <- (view unpackedBytes -> b) where + Bytes b = review unpackedBytes b + +pattern Chars b <- (view unpackedChars -> b) where + Chars b = review unpackedChars b +#endif + diff --git a/src/Data/Complex/Lens.hs b/src/Data/Complex/Lens.hs --- a/src/Data/Complex/Lens.hs +++ b/src/Data/Complex/Lens.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +#endif #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 @@ -24,6 +28,13 @@ , _magnitude , _phase , _conjugate +#if __GLASGOW_HASKELL__ >= 710 + -- * Pattern Synonyms + , pattern Polar + , pattern Real + , pattern Imaginary + , pattern Conjugate +#endif ) where import Control.Lens @@ -77,6 +88,14 @@ _polar = iso polar (uncurry mkPolar) {-# INLINE _polar #-} +#if __GLASGOW_HASKELL__ >= 710 +pattern Polar m theta <- (view _polar -> (m, theta)) where + Polar m theta = review _polar (m, theta) + +pattern Real r = r :+ 0 +pattern Imaginary i = 0 :+ i +#endif + -- | Access the 'magnitude' of a 'Complex' number. -- -- >>> (10.0 :+ 20.0) & _magnitude *~ 2 @@ -128,3 +147,8 @@ _conjugate :: RealFloat a => Iso' (Complex a) (Complex a) _conjugate = involuted conjugate {-# INLINE _conjugate #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Conjugate a <- (conjugate -> a) where + Conjugate a = conjugate a +#endif diff --git a/src/Data/Dynamic/Lens.hs b/src/Data/Dynamic/Lens.hs --- a/src/Data/Dynamic/Lens.hs +++ b/src/Data/Dynamic/Lens.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} + +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic.Lens @@ -12,6 +18,9 @@ ---------------------------------------------------------------------------- module Data.Dynamic.Lens ( AsDynamic(..) +#if __GLASGOW_HASKELL__ >= 710 + , pattern Dynamic +#endif ) where import Control.Exception @@ -40,3 +49,8 @@ instance AsDynamic SomeException where _Dynamic = exception.prism' toDyn fromDynamic {-# INLINE _Dynamic #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Dynamic a <- (preview _Dynamic -> Just a) where + Dynamic a = review _Dynamic a +#endif diff --git a/src/Data/Sequence/Lens.hs b/src/Data/Sequence/Lens.hs --- a/src/Data/Sequence/Lens.hs +++ b/src/Data/Sequence/Lens.hs @@ -43,12 +43,12 @@ -- >>> EmptyL ^. from viewL -- fromList [] -- --- >>> review viewL $ a :< fromList [b,c] +-- >>> review viewL $ a Seq.:< fromList [b,c] -- fromList [a,b,c] viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b) viewL = iso viewl $ \ xs -> case xs of EmptyL -> mempty - a :< as -> a Seq.<| as + a Seq.:< as -> a Seq.<| as {-# INLINE viewL #-} -- | A 'Seq' is isomorphic to a 'ViewR' @@ -64,12 +64,12 @@ -- >>> EmptyR ^. from viewR -- fromList [] -- --- >>> review viewR $ fromList [a,b] :> c +-- >>> review viewR $ fromList [a,b] Seq.:> c -- fromList [a,b,c] viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b) viewR = iso viewr $ \xs -> case xs of EmptyR -> mempty - as :> a -> as Seq.|> a + as Seq.:> a -> as Seq.|> a {-# INLINE viewR #-} -- | Traverse the first @n@ elements of a 'Seq' diff --git a/src/Data/Text/Lazy/Lens.hs b/src/Data/Text/Lazy/Lens.hs --- a/src/Data/Text/Lazy/Lens.hs +++ b/src/Data/Text/Lazy/Lens.hs @@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lazy.Lens @@ -17,6 +21,9 @@ , text , builder , utf8 +#if __GLASGOW_HASKELL__ >= 710 + , pattern Text +#endif ) where import Control.Lens.Type @@ -24,6 +31,9 @@ import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Prism +#if __GLASGOW_HASKELL__ >= 710 +import Control.Lens.Review +#endif import Control.Lens.Setter import Control.Lens.Traversal import Data.ByteString.Lazy as ByteString @@ -137,3 +147,8 @@ utf8 :: Prism' ByteString Text utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') {-# INLINE utf8 #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Text a <- (view _Text -> a) where + Text a = review _Text a +#endif diff --git a/src/Data/Text/Lens.hs b/src/Data/Text/Lens.hs --- a/src/Data/Text/Lens.hs +++ b/src/Data/Text/Lens.hs @@ -2,6 +2,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} + +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Lens @@ -16,9 +21,16 @@ ( IsText(..) , unpacked , _Text +#if __GLASGOW_HASKELL__ >= 710 + , pattern Text +#endif ) where import Control.Lens.Type +#if __GLASGOW_HASKELL__ >= 710 +import Control.Lens.Getter +import Control.Lens.Review +#endif import Control.Lens.Iso import Control.Lens.Traversal import Data.Text as Strict @@ -93,6 +105,11 @@ _Text :: IsText t => Iso' t String _Text = from packed {-# INLINE _Text #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Text a <- (view _Text -> a) where + Text a = review _Text a +#endif instance IsText Strict.Text where packed = Strict.packed diff --git a/src/Data/Text/Strict/Lens.hs b/src/Data/Text/Strict/Lens.hs --- a/src/Data/Text/Strict/Lens.hs +++ b/src/Data/Text/Strict/Lens.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Text.Strict.Lens @@ -16,6 +20,9 @@ , text , utf8 , _Text +#if __GLASGOW_HASKELL__ >= 710 + , pattern Text +#endif ) where import Control.Lens.Type @@ -23,6 +30,9 @@ import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Prism +#if __GLASGOW_HASKELL__ >= 710 +import Control.Lens.Review +#endif import Control.Lens.Setter import Control.Lens.Traversal import Data.ByteString (ByteString) @@ -130,3 +140,8 @@ utf8 :: Prism' ByteString Text utf8 = prism' encodeUtf8 (preview _Right . decodeUtf8') {-# INLINE utf8 #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern Text a <- (view _Text -> a) where + Text a = review _Text a +#endif diff --git a/src/Numeric/Lens.hs b/src/Numeric/Lens.hs --- a/src/Numeric/Lens.hs +++ b/src/Numeric/Lens.hs @@ -1,4 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif -------------------------------------------------------------------------------- -- | -- Module : Numeric.Lens @@ -23,6 +28,9 @@ , dividing , exponentiating , negated +#if __GLASGOW_HASKELL__ >= 710 + , pattern Integral +#endif ) where import Control.Lens @@ -44,6 +52,11 @@ if toInteger a == i then Right a else Left i + +#if __GLASGOW_HASKELL__ >= 710 +pattern Integral a <- (preview integral -> Just a) where + Integral a = review integral a +#endif -- | A prism that shows and reads integers in base-2 through base-36 -- diff --git a/src/System/Exit/Lens.hs b/src/System/Exit/Lens.hs --- a/src/System/Exit/Lens.hs +++ b/src/System/Exit/Lens.hs @@ -2,6 +2,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif + #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif @@ -21,6 +26,10 @@ ( AsExitCode(..) , _ExitFailure , _ExitSuccess +#if __GLASGOW_HASKELL__ >= 710 + , pattern ExitFailure_ + , pattern ExitSuccess_ +#endif ) where import Control.Exception @@ -33,19 +42,14 @@ #endif -- | Exit codes that a program can return with: -class AsExitCode p f t where - -- | - -- @ - -- '_ExitCode' :: 'Equality'' 'ExitCode' 'ExitCode' - -- '_ExitCode' :: 'Prism'' 'SomeException' 'ExitCode' - -- @ - _ExitCode :: Optic' p f t ExitCode +class AsExitCode t where + _ExitCode :: Prism' t ExitCode -instance AsExitCode p f ExitCode where +instance AsExitCode ExitCode where _ExitCode = id {-# INLINE _ExitCode #-} -instance (Choice p, Applicative f) => AsExitCode p f SomeException where +instance AsExitCode SomeException where _ExitCode = exception {-# INLINE _ExitCode #-} @@ -55,20 +59,29 @@ -- '_ExitSuccess' :: 'Prism'' 'ExitCode' () -- '_ExitSuccess' :: 'Prism'' 'SomeException' () -- @ -_ExitSuccess :: (AsExitCode p f t, Choice p, Applicative f) => Optic' p f t () +_ExitSuccess :: AsExitCode t => Prism' t () _ExitSuccess = _ExitCode . dimap seta (either id id) . right' . rmap (ExitSuccess <$) where seta ExitSuccess = Right () seta t = Left (pure t) {-# INLINE _ExitSuccess #-} + -- | indicates program failure with an exit code. The exact interpretation of the code is operating-system dependent. In particular, some values may be prohibited (e.g. 0 on a POSIX-compliant system). -- -- @ -- '_ExitFailure' :: 'Prism'' 'ExitCode' 'Int' -- '_ExitFailure' :: 'Prism'' 'SomeException' 'Int' -- @ -_ExitFailure :: (AsExitCode p f t, Choice p, Applicative f) => Optic' p f t Int +_ExitFailure :: AsExitCode t => Prism' t Int _ExitFailure = _ExitCode . dimap seta (either id id) . right' . rmap (fmap ExitFailure) where seta (ExitFailure i) = Right i seta t = Left (pure t) {-# INLINE _ExitFailure #-} + +#if __GLASGOW_HASKELL__ >= 710 +pattern ExitSuccess_ <- (has _ExitSuccess -> True) where + ExitSuccess_ = review _ExitSuccess () + +pattern ExitFailure_ a <- (preview _ExitFailure -> Just a) where + ExitFailure_ a = review _ExitFailure a +#endif