diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,19 +1,18 @@ language: haskell before_install: - # Uncomment the next 3 lines whenever hackage is down. - # - mkdir -p ~/.cabal - # - cp config ~/.cabal/config - # - cabal update + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update - # adding the hunit test suite causes us to have to reinstall regex-posix and regex-base - - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstall + # Try installing some of the build-deps with apt-get for speed. + - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode + install: - # we have to configure rather than install in order to get benchmarks - - cabal configure --enable-tests --enable-benchmarks -fdump-splices + - cabal configure $mode - cabal build + script: - - cabal test --show-details=always - - cabal bench + - $script + notifications: irc: channels: @@ -21,3 +20,9 @@ skip_join: true template: - "\x0313lens\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + +env: + - mode="--enable-tests" script="cabal test" + # - mode="--enable-tests -fsafe" script="cabal test" + # - mode="--enable-tests -fdump-splices" script="cabal test --show-details=always" + # - mode="--enable-benchmarks -fdump-splices" script="cabal bench" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,37 @@ +[3.7](https://github.com/ekmett/lens/issues?milestone=11&page=1&state=closed) +----- +* Renamed `Projection` to `Prism`. +* Implemented a complete redesign of the way `Iso` and `Prism` are handled internally. Any `Iso` can now be used as a `Prism`. +* The `isos` combinator is no longer required. `iso` can now be used to construct an `Iso`. +* Changes to the signature of `from` and `under` were necessitated by the new design. +* Added `Control.Lens.Wrapped` providing a canonical isomorphism for newtypes. +* Repurposed `ala` to be closer to the original design in `newtype`, but added `au` and `alaf`. +* Added `_magnitude`, `_phase` and `_conjugate` to `Data.Complex.Lens`. Renamed other lenses for consistency: `_realPart`, `_imagPart`, `_polar`. +* Promoted `_left` and `_right` to prisms and moved them to `Control.Lens.Prism`. +* Generalized `view` and `views` to subsume the old functionality of `peruse` and `peruses`. +* Generalized `review` and `reviews` to both return a `MonadReader` and to work on a `Projection`. +* Added `view'`/`views'` and `use'`/`uses'` for `Simple` access to the environment/state. +* Added `set'`, a `Simple` version of `set`. +* Added `reuse` : `use` :: `review` : `view` and `reuses` : `uses` :: `reviews` : `views` for working a `Projection` from the current `MonadState`. +* Removed many isomorphisms for various newtypes. `_const`, `identity`, `_sum`, etc. Use `wrapping Const`, `wrapping Identity`, etc. +* Removed `Data.Monoid.Lens` now that its newtypes are instances of `Wrapped`, exporting the (`<>=`)-variants from `Control.Lens.*`. +* Renamed `via` to `cloneIso` for consistency. +* Moved `Indexed(..)` to `Control.Lens.Classes`. +* Renamed `index` to `indexing` to reduce conflicts with third-party libraries. +* Added `curried` and `uncurried` to `Control.Lens.Iso`. +* Added `Strict(strict)` for ad hoc overloading of conversions between strict and lazy variants of `ByteString` and `Text`. +* Bug fixes for `tugTo` and `jerkTo`. +* These no longer traverse in the wrong direction: `scanl1Of`, `scanr1Of`, `mapAccumLOf`, and `mapAccumROf`. +* Added `anon` to `Control.Lens.Iso`. +* Generalized the types of the `Control.Lens.Zipper` combinators to work with other MonadPlus instances. +* Added `withins` to `Control.Lens.Zipper` now that they can work better with []. +* Added `singular` and `unsafeSingular` to `Control.Lens.Traversal` to assert a `Traversal` is a `Lens`, a `Fold` is a `Getter` or a `MonadicFold` is an `Action`. +* Generalized `sequenceAOf_`'s type to match `sequenceA_`. +* Renamed `up`/`down`/`left`/`right` to `upward`/`downward`/`leftward`/`rightward` to reduce conflicts -- in particular with `Control.Arrow`. +* Readded `leftmost` and `rightmost` due to the verbosity of `farthest leftward`/`farthest rightward`. +* Added `preview`/`previews`/`firstOf` and deprecated `headOf`. +* Added `iview`/`iviews`/`iuse`/`iuses` to `Control.Lens.IndexedGetter`. + 3.6.0.4 [maintenance release] ------- * Added support for `test-framework` 0.8 @@ -15,8 +49,8 @@ ------- * Added explicit dependency on containers and unordered-containers to the doctest suite -3.6 ------ +[3.6](https://github.com/ekmett/lens/issues?milestone=9&state=closed) +--- * Added `upon` (along with variants of it) to `Data.Data.Lens`, which can be used to generate a `Traversal` from a field accessor or any function that returns, unmodified, a single field that would be visited by `template`. * Added some missing `examples/` files to the distribution. @@ -42,7 +76,7 @@ ----- * Improved SafeHaskell inference. -3.5 +[3.5](https://github.com/ekmett/lens/issues?milestone=8&state=closed) --- * Fixed a potential SafeHaskell issue where a user could use `undefined` to derive `unsafeCoerce`. You now have to import an explicitly Unsafe module and create an instance of `Trustworthy` for your type to cause this behavior, so if you do, its on your head, not mine. :) @@ -50,7 +84,7 @@ * Moved a lot of internals around. Most notably, `Gettable`, `Settable` and `Effective` have moved to `Control.Lens.Classes`. * Exposed `partsOf'` and `unsafePartsOf'` in `Control.Lens.Traversal` to reduce reliance on `BazaarT` in `Control.Lens.Zipper` -3.4 +[3.4](https://github.com/ekmett/lens/issues?milestone=7&state=closed) --- * Renamed `(%)` to `(&)` and `(^%)` to `(^&)`. This avoids the conflict with `Data.Ratio`, which was our highest priority conflict with a third party library. * Switched to a more liberal type for `ignored` @@ -130,13 +164,13 @@ ----- * Added `Control.Lens.Type.simple`. -3.0 +[3.0](https://github.com/ekmett/lens/issues?milestone=6&state=closed) --- * Added `Control.Lens.Zipper`. * Added `<<~`, a version of `<~` that supports chaining assignment. * Added `:->`, `:=>`, and `:<->` as type operator aliases for `Simple Lens`, `Simple Traversal`, and `Simple Iso` respectively. -2.9 +[2.9](https://github.com/ekmett/lens/issues?milestone=5&state=closed) --- * Added `<<%~`, `<<.~`, `<<%=` and `<<.=` for accessing the old values targeted by a `Lens` (or a summary of those targeted by a `Traversal`) * Renamed `|>` to `%`, as `%~` is the lensed version of `%`, and moved it to `Control.Lens.Getter` along with a version `^%` with tighter @@ -151,7 +185,7 @@ it will default to the old behavior. * Added `performs` to `Control.Lens.Action` to mirror `views` in `Control.Lens.Getter`. -2.8 +[2.8](https://github.com/ekmett/lens/issues?milestone=4&state=closed) --- * Restored compatibility with GHC 7.2. This required a major version bump due to making some MPTC-based default signatures conditional. @@ -159,7 +193,7 @@ ------- * Added the missing `Control.Lens.Combinators` to exported-modules! Its absence was causing it not to be included on hackage. -2.7 +[2.7](https://github.com/ekmett/lens/issues?milestone=3&state=closed) --- * Generalized the signature of `Getting`, `Acting` and `IndexedGetting` to help out with the common user code scenario of needing to read and then write to change types. @@ -176,7 +210,7 @@ ----- * Fixed bugs in `Traversal` code-generation. -2.6 +[2.6](https://github.com/ekmett/lens/issues?milestone=2&state=closed) --- * Added build option `-f-inlining` to facilitate building with the various TH 2.8 versions used by GHC 7.6 and HEAD. * Added build option `-f-template-haskell` for testing without template haskell. (Users should be able to assume TH is enabled; use this only for testing!) @@ -186,7 +220,7 @@ * Added `assign` as an alias for `(.=)` in `Control.Lens.Setter`. * Added `~:`, `=:`, `<~:` and `<=:` to `Data.List.Lens` -2.5 +[2.5](https://github.com/ekmett/lens/issues?milestone=1&state=closed) --- * Added `Control.Lens.Plated`, a port of Neil Mitchell's `uniplate` that can be used on any `Traversal`. * Added `Data.Data.Lens` with smart traversals that know how to avoid traversing parts of a structure that can't contain a given type. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -5,9 +5,9 @@ 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). -An overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [Overview](https://github.com/ekmett/lens/wiki/Overview). +The [FAQ](https://github.com/ekmett/lens/wiki/FAQ), which provides links to a large number of different resources for learning about lenses and an overview of the [derivation](https://github.com/ekmett/lens/wiki/Derivation) of these types can be found on the [Lens Wiki](https://github.com/ekmett/lens/wiki) along with a brief [overview](https://github.com/ekmett/lens/wiki/Overview) and some [examples](https://github.com/ekmett/lens/wiki/Examples). -Documentation is available through [github](http://ekmett.github.com/lens/frames.html) or [hackage](http://hackage.haskell.org/package/lens). +Documentation is available through [github](http://ekmett.github.com/lens/frames.html) (for HEAD) or [hackage](http://hackage.haskell.org/package/lens) for the current and preceding releases. Field Guide ----------- @@ -86,8 +86,6 @@ You can let the library automatically derive lenses for fields of your data type ```haskell -import Control.Lens - data Foo a = Foo { _bar :: Int, _baz :: Int, _quux :: a } makeLenses ''Foo ``` @@ -332,6 +330,13 @@ Logically and target(s) + <>~ + <<>~ + <>= + <<>= + mappend to the target monoidal value(s) + + headOf,^? Return Just the first target or Nothing @@ -365,35 +370,19 @@ Data.Bits.Lens - |~ - <|~ - |= - <|= + .|.~ + <.|.~ + .|.= + <.|.= Bitwise or target(s) - &~ - <&~ - &= - <&= + .&.~ + <.&.~ + .&.= + <.&.= Bitwise and target(s) -Data.List.Lens - - ++~ - <++~ - ++= - <++= - Append to target list(s) - -Data.Monoid.Lens - - <>~ - <<>~ - <>= - <<>= - mappend to the target monoidal value(s) - System.FilePath.Lens </>~ @@ -411,6 +400,7 @@ + Contact Information ------------------- diff --git a/benchmarks/plated.hs b/benchmarks/plated.hs --- a/benchmarks/plated.hs +++ b/benchmarks/plated.hs @@ -14,7 +14,11 @@ import Data.Generics.Uniplate.Direct ((|*)) import qualified Data.Generics.Uniplate.DataOnly as UniDataOnly #endif +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import GHC.Generics +#else +import Generics.Deriving +#endif import GHC.Generics.Lens as Generic data Expr = Val !Int diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses -version: 3.6.0.4 +version: 3.7 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -37,10 +37,10 @@ . The core of this hierarchy looks like: . - <> + <> . You can compose any two elements of the hierarchy above using (.) from the Prelude, and you can - use any element of the hierarchy as any type it links to above it. + use any element of the hierarchy as any type it linked to above it. . The result is their lowest upper bound in the hierarchy (or an error if that bound doesn't exist). . @@ -82,7 +82,7 @@ exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). build-type: Simple -tested-with: GHC == 7.4.1, GHC == 7.6.1 +tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1 extra-source-files: .travis.yml .ghci @@ -138,9 +138,28 @@ default: False manual: True +-- You can disable the hunit test suite with -f-test-hunit +flag test-hunit + default: True + manual: True + +flag test-properties + default: True + manual: True + +-- Disallow unsafeCoerce +flag safe + default: False + manual: True + +-- Assert that we are trustworthy when we can +flag trustworthy + default: True + manual: False + library build-depends: - base >= 4.4 && < 5, + base >= 4.3 && < 5, bytestring >= 0.9.1.10 && < 0.11, comonad == 3.0.*, comonad-transformers == 3.0.*, @@ -172,10 +191,9 @@ Control.Lens.Internal Control.Lens.Internal.Zipper Control.Lens.Iso - Control.Lens.Isomorphic Control.Lens.Loupe Control.Lens.Plated - Control.Lens.Projection + Control.Lens.Prism Control.Lens.Representable Control.Lens.Setter Control.Lens.Simple @@ -183,6 +201,7 @@ Control.Lens.Tuple Control.Lens.Type Control.Lens.WithIndex + Control.Lens.Wrapped Control.Lens.Zipper Control.Lens.Zoom Data.Bits.Lens @@ -196,7 +215,6 @@ Data.IntSet.Lens Data.List.Lens Data.List.Split.Lens - Data.Monoid.Lens Data.Sequence.Lens Data.Set.Lens Data.Text.Lens @@ -206,6 +224,7 @@ Data.Typeable.Lens Data.Vector.Lens Data.Vector.Generic.Lens + GHC.Generics.Lens other-modules: Control.Lens.Internal.Combinators @@ -214,8 +233,17 @@ build-depends: template-haskell >= 2.4 && < 2.9 exposed-modules: Control.Lens.TH Language.Haskell.TH.Lens else - cpp-options: -DDISABLE_TEMPLATE_HASKELL + cpp-options: -DDISABLE_TEMPLATE_HASKELL=1 + if flag(safe) + cpp-options: -DSAFE=1 + + if flag(trustworthy) && impl(ghc>=7.2) + cpp-options: -DTRUSTWORTHY=1 + + if impl(ghc<7.4) + ghc-options: -fno-spec-constr-count + -- platform build-depends: array >= 0.3.0.2 && < 0.5 exposed-modules: Data.Array.Lens @@ -228,15 +256,17 @@ if impl(ghc>=7.6.0.20120810) if flag(old-inline-pragmas) - cpp-options: -DOLD_INLINE_PRAGMAS + cpp-options: -DOLD_INLINE_PRAGMAS=1 if !flag(inlining) - cpp-options: -DOMIT_INLINING + cpp-options: -DOMIT_INLINING=1 - if impl(ghc>=7.4) + if impl(ghc>=7.2) other-extensions: Trustworthy build-depends: ghc-prim - exposed-modules: GHC.Generics.Lens + cpp-options: -DDEFAULT_SIGNATURES=1 + else + build-depends: generic-deriving ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields hs-source-dirs: src @@ -266,6 +296,8 @@ transformers ghc-options: -w -threaded hs-source-dirs: tests + if !flag(test-properties) + buildable: False test-suite hunit type: exitcode-stdio-1.0 @@ -276,11 +308,13 @@ HUnit == 1.2.*, lens, mtl, - test-framework >= 0.6 && < 0.9, + test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, - test-framework-th >= 0.2 && < 0.4 + test-framework-th >= 0.2 && < 0.4 ghc-options: -w -threaded hs-source-dirs: tests + if !flag(test-hunit) + buildable: False -- Verify the results of the examples test-suite doctests @@ -295,8 +329,11 @@ filepath, mtl, parallel, + simple-reflect >= 0.3.1 && < 0.4, + split, text, - unordered-containers + unordered-containers, + vector ghc-options: -Wall -threaded if impl(ghc<7.6.1) ghc-options: -Werror @@ -311,16 +348,19 @@ comonad, criterion, deepseq, - ghc-prim, lens, transformers + if impl(ghc>=7.2) + build-depends: ghc-prim + else + build-depends: generic-deriving ghc-options: -Wall -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks if flag(benchmark-uniplate) build-depends: uniplate >= 1.6.7 && < 1.7 cpp-options: -DBENCHMARK_UNIPLATE --- Basic benchmarks for the uniplate-style combinators +-- Benchmarking alongside variants benchmark alongside type: exitcode-stdio-1.0 main-is: alongside.hs @@ -330,13 +370,12 @@ comonads-fd, criterion, deepseq, - ghc-prim, lens, transformers ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields hs-source-dirs: benchmarks --- Basic benchmarks for the uniplate-style combinators +-- Benchmarking unsafe implementation strategies benchmark unsafe type: exitcode-stdio-1.0 main-is: unsafe.hs 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 @@ -1,4 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Exception.Lens @@ -24,6 +26,6 @@ -- exception :: ('Applicative' f, 'Exception' a, 'Exception' b) -- => (a -> f b) -> 'SomeException' -> f 'SomeException' -- @ -exception :: (Exception a, Exception b) => Projection SomeException SomeException a b -exception = projection SomeException fromException +exception :: Exception a => Simple Prism SomeException a +exception = prism toException $ \ e -> maybe (Left e) Right $ fromException e {-# INLINE exception #-} diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -3,9 +3,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE FlexibleContexts #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens @@ -44,32 +41,33 @@ -- -- -- --- <> +-- <> ---------------------------------------------------------------------------- module Control.Lens - ( module Control.Lens.Type - , module Control.Lens.Traversal - , module Control.Lens.Getter - , module Control.Lens.Setter - , module Control.Lens.Action + ( module Control.Lens.Action , module Control.Lens.Combinators , module Control.Lens.Fold - , module Control.Lens.Iso + , module Control.Lens.Getter , module Control.Lens.Indexed , module Control.Lens.IndexedFold , module Control.Lens.IndexedGetter , module Control.Lens.IndexedLens - , module Control.Lens.IndexedTraversal , module Control.Lens.IndexedSetter + , module Control.Lens.IndexedTraversal + , module Control.Lens.Iso , module Control.Lens.Loupe , module Control.Lens.Plated - , module Control.Lens.Projection + , module Control.Lens.Prism , module Control.Lens.Representable + , module Control.Lens.Setter #ifndef DISABLE_TEMPLATE_HASKELL , module Control.Lens.TH #endif + , module Control.Lens.Traversal , module Control.Lens.Tuple + , module Control.Lens.Type , module Control.Lens.WithIndex + , module Control.Lens.Wrapped , module Control.Lens.Zipper , module Control.Lens.Zoom ) where @@ -87,7 +85,7 @@ import Control.Lens.Iso import Control.Lens.Loupe import Control.Lens.Plated -import Control.Lens.Projection +import Control.Lens.Prism import Control.Lens.Representable import Control.Lens.Setter #ifndef DISABLE_TEMPLATE_HASKELL @@ -97,5 +95,6 @@ import Control.Lens.Tuple import Control.Lens.Type import Control.Lens.WithIndex +import Control.Lens.Wrapped import Control.Lens.Zipper import Control.Lens.Zoom diff --git a/src/Control/Lens/Action.hs b/src/Control/Lens/Action.hs --- a/src/Control/Lens/Action.hs +++ b/src/Control/Lens/Action.hs @@ -22,7 +22,7 @@ , liftAct , (^!) - -- * Folds with Effecs + -- * Folds with Effects , MonadicFold -- * Implementation Details @@ -87,7 +87,7 @@ -- | A self-running 'Action', analogous to 'Control.Monad.join'. -- --- @'acts' = 'act' 'id'@ +-- @'acts' ≡ 'act' 'id'@ -- -- >>> (1,"hello")^!_2.acts.to succ -- "ifmmp" diff --git a/src/Control/Lens/Classes.hs b/src/Control/Lens/Classes.hs --- a/src/Control/Lens/Classes.hs +++ b/src/Control/Lens/Classes.hs @@ -1,10 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#if defined(TRUSTWORTHY) && !defined(SAFE) {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -24,20 +26,35 @@ , noEffect -- * Actions , Effective(..) - , ineffective -- * Setters , Settable(..) + -- * Isomorphisms + , Isomorphic(..) + -- * Prisms + , Prismatic(..) + -- * Indexable + , Indexable(..) ) where import Control.Applicative -import Control.Applicative.Backwards -import Control.Lens.Isomorphic +import Control.Applicative.Backwards (Backwards(..)) +import Control.Category import Control.Monad (liftM) -import Data.Functor.Compose -import Data.Functor.Identity -import Data.Monoid -import Unsafe.Coerce +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid (Dual(..)) +import Prelude hiding ((.),id) +#ifndef SAFE +import Unsafe.Coerce (unsafeCoerce) +#endif +#ifndef SAFE +#define UNSAFELY(x) unsafeCoerce +#else +#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x)) +#endif + + ------------------------------------------------------------------------------- -- Gettables & Accessors ------------------------------------------------------------------------------- @@ -81,15 +98,12 @@ -- -- That said, the monad is possibly rather unrelated to any 'Applicative' structure. class (Monad m, Gettable f) => Effective m r f | f -> m r where - effective :: Isomorphic k => k (m r) (f a) - --- | A convenient antonym that is used internally. -ineffective :: Effective m r f => Isomorphic k => k (f a) (m r) -ineffective = from effective -{-# INLINE ineffective #-} + effective :: m r -> f a + ineffective :: f a -> m r instance Effective m r f => Effective m (Dual r) (Backwards f) where - effective = isomorphic (Backwards . effective . liftM getDual) (liftM Dual . ineffective . forwards) + effective = Backwards . effective . liftM getDual + ineffective = liftM Dual . ineffective . forwards ----------------------------------------------------------------------------- -- Settable @@ -100,17 +114,17 @@ untainted :: f a -> a untainted# :: (a -> f b) -> a -> b - untainted# f = untainted . f + untainted# g = g `seq` \x -> untainted (g x) tainted# :: (a -> b) -> a -> f b - tainted# f = pure . f + tainted# g = g `seq` \x -> pure (g x) -- | so you can pass our a 'Control.Lens.Setter.Setter' into combinators from other lens libraries instance Settable Identity where untainted = runIdentity - untainted# = unsafeCoerce + untainted# = UNSAFELY(runIdentity) {-# INLINE untainted #-} - tainted# = unsafeCoerce + tainted# = UNSAFELY(Identity) {-# INLINE tainted# #-} -- | 'Control.Lens.Fold.backwards' @@ -121,3 +135,58 @@ instance (Settable f, Settable g) => Settable (Compose f g) where untainted = untainted . untainted . getCompose {-# INLINE untainted #-} + +----------------------------------------------------------------------------- +-- Isomorphisms +----------------------------------------------------------------------------- + +-- | Used to provide overloading of isomorphism application +-- +-- An instance of 'Isomorphic' is a 'Category' with a canonical mapping to it from the +-- category of isomorphisms over Haskell types. +class Category k => Isomorphic k where + -- | Build a simple isomorphism from a pair of inverse functions + -- + -- @ + -- 'view' ('iso' f g) ≡ f + -- 'view' ('from' ('iso' f g)) ≡ g + -- 'set' ('iso' f g) h ≡ g '.' h '.' f + -- 'set' ('from' ('iso' f g)) h ≡ f '.' h '.' g + -- @ + iso :: Functor f => (s -> a) -> (b -> t) -> k (a -> f b) (s -> f t) + +instance Isomorphic (->) where + iso sa bt afb s = bt <$> afb (sa s) + {-# INLINE iso #-} + +----------------------------------------------------------------------------- +-- Prisms +----------------------------------------------------------------------------- + +-- | Used to provide overloading of prisms. +-- +-- An instance of 'Prismatic' is a 'Category' with a canonical mapping to it from the category +-- of embedding-projection pairs over Haskell types. +class Isomorphic k => Prismatic k where + -- | Build a 'Control.Lens.Prism.Prism'. + -- + -- @'Either' t a@ is used instead of @'Maybe' a@ to permit the types of @s@ and @t@ to differ. + prism :: Applicative f => (b -> t) -> (s -> Either t a) -> k (a -> f b) (s -> f t) + +instance Prismatic (->) where + prism bt seta afb = either pure (fmap bt . afb) . seta + {-# INLINE prism #-} + +---------------------------------------------------------------------------- +-- Indexed Internals +----------------------------------------------------------------------------- + +-- | This class permits overloading of function application for things that +-- also admit a notion of a key or index. +class Indexable i k where + -- | Build a function from an 'Indexed' function + indexed :: ((i -> a) -> b) -> k a b + +instance Indexable i (->) where + indexed f = f . const + {-# INLINE indexed #-} diff --git a/src/Control/Lens/Combinators.hs b/src/Control/Lens/Combinators.hs --- a/src/Control/Lens/Combinators.hs +++ b/src/Control/Lens/Combinators.hs @@ -12,9 +12,10 @@ ( (<$!>), (<$!), (<&>) ) where -import Data.Functor +import Data.Functor ((<$>)) -infixr 4 <$!>, <$!, <&> +infixl 4 <$!>, <$! +infixl 1 <&> -- | A strict version of ('Data.Functor.<$>') for monads. -- 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 @@ -4,7 +4,6 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold @@ -41,6 +40,8 @@ , (^..) , (^?) , (^?!) + , preview + , previews -- ** Building Folds --, folds , folding @@ -67,8 +68,8 @@ , concatMapOf, concatOf , elemOf, notElemOf , lengthOf - , nullOf - , headOf, lastOf + , nullOf, notNullOf + , firstOf, lastOf , maximumOf, minimumOf , maximumByOf, minimumByOf , findOf @@ -77,6 +78,8 @@ , foldrMOf, foldlMOf -- * Storing Folds , ReifiedFold(..) + -- * Deprecated + , headOf ) where import Control.Applicative as Applicative @@ -87,6 +90,7 @@ import Control.Lens.Internal.Combinators import Control.Lens.Type import Control.Monad +import Control.Monad.Reader import Data.Foldable as Foldable import Data.Maybe import Data.Monoid @@ -119,11 +123,23 @@ -- | Obtain a 'Fold' by lifting an operation that returns a foldable result. -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. +-- +-- >>> [1,2,3,4]^..folding tail +-- [2,3,4] folding :: (Foldable f, Applicative g, Gettable g) => (s -> f a) -> LensLike g s t a b folding sfa agb = coerce . traverse_ agb . sfa {-# INLINE folding #-} -- | Obtain a 'Fold' from any 'Foldable'. +-- +-- >>> Just 3^..folded +-- [3] +-- +-- >>> Nothing^..folded +-- [] +-- +-- >>> [(1,2),(3,4)]^..folded.both +-- [1,2,3,4] folded :: Foldable f => Fold (f a) a folded f = coerce . getFolding . foldMap (folding# f) {-# INLINE folded #-} @@ -131,6 +147,9 @@ -- | Fold by repeating the input forever. -- -- @'repeat' ≡ 'toListOf' 'repeated'@ +-- +-- >>> 5^..taking 20 repeated +-- [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5] repeated :: Fold a a repeated f a = as where as = f a *> as {-# INLINE repeated #-} @@ -138,6 +157,9 @@ -- | A fold that replicates its input @n@ times. -- -- @'replicate' n ≡ 'toListOf' ('replicated' n)@ +-- +-- >>> 5^..replicated 20 +-- [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5] replicated :: Int -> Fold a a replicated n0 f a = go n0 where m = f a @@ -147,8 +169,8 @@ -- | Transform a fold into a fold that loops over its elements over and over. -- --- >>> take 6 $ toListOf (cycled traverse) [1,2,3] --- [1,2,3,1,2,3] +-- >>> [1,2,3]^..taking 7 (cycled traverse) +-- [1,2,3,1,2,3,1] cycled :: (Applicative f, Gettable f) => LensLike f s t a b -> LensLike f s t a b cycled l f a = as where as = l f a *> as {-# INLINE cycled #-} @@ -156,6 +178,9 @@ -- | Build a fold that unfolds its values from a seed. -- -- @'Prelude.unfoldr' ≡ 'toListOf' . 'unfolded'@ +-- +-- >>> 10^..unfolded (\b -> if b == 0 then Nothing else Just (b, b-1)) +-- [10,9,8,7,6,5,4,3,2,1] unfolded :: (b -> Maybe (a, b)) -> Fold b a unfolded f g b0 = go b0 where go b = case f b of @@ -190,7 +215,7 @@ -- | This allows you to traverse the elements of a 'Control.Lens.Traversal.Traversal' or 'Fold' in the opposite order. -- This will demote an 'Control.Lens.IndexedTraversal.IndexedTraversal' or 'Control.Lens.IndexedFold.IndexedFold' to a regular 'Control.Lens.Traversal.Traversal' or 'Fold', --- repectively; to preserve the indices, use 'Control.Lens.IndexedFold.ibackwards' instead. +-- respectively; to preserve the indices, use 'Control.Lens.IndexedFold.ibackwards' instead. -- -- Note: 'backwards' should have no impact on a 'Getter', 'Control.Lens.Setter.Setter', 'Lens' or 'Control.Lens.Iso.Iso'. -- @@ -226,7 +251,7 @@ => (a -> Bool) -> Getting (Endo (f s, f s)) s s a a -> LensLike f s s a a -droppingWhile p l f = fst . foldrOf l (\a r -> let s = f a *> snd r in if p a then (fst r, s) else (s, s)) (noEffect, noEffect) +droppingWhile p l f = fst . foldrOf l (\a r -> let s = f a *> snd r in (if p a then fst r else s, s)) (noEffect, noEffect) {-# INLINE droppingWhile #-} -------------------------- @@ -244,6 +269,7 @@ -- 'foldMapOf' :: 'Simple' 'Lens' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Monoid' r => 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> r) -> s -> r -- @ foldMapOf :: Getting r s t a b -> (a -> r) -> s -> r foldMapOf l f = runAccessor# (l (accessor# f)) @@ -260,6 +286,7 @@ -- 'foldOf' :: 'Simple' 'Lens' s m -> s -> m -- 'foldOf' :: 'Simple' 'Control.Lens.Iso.Iso' s m -> s -> m -- 'foldOf' :: 'Monoid' m => 'Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m +-- 'foldOf' :: 'Monoid' m => 'Simple' 'Control.Lens.Prism.Prism' s m -> s -> m -- @ foldOf :: Getting a s t a b -> s -> a foldOf l = runAccessor# (l Accessor) @@ -276,6 +303,7 @@ -- 'foldrOf' :: 'Simple' 'Lens' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> r -> r) -> r -> s -> r -- @ foldrOf :: Getting (Endo r) s t a b -> (a -> r -> r) -> r -> s -> r foldrOf l f z t = appEndo (foldMapOf l (endo# f) t) z @@ -292,6 +320,7 @@ -- 'foldlOf' :: 'Simple' 'Lens' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (r -> a -> r) -> r -> s -> r -- @ foldlOf :: Getting (Dual (Endo r)) s t a b -> (r -> a -> r) -> r -> s -> r foldlOf l f z t = appEndo (getDual (foldMapOf l (dual# (endo# (flip f))) t)) z @@ -313,6 +342,7 @@ -- 'toListOf' :: 'Simple' 'Lens' s a -> s -> [a] -- 'toListOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> [a] -- 'toListOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> [a] +-- 'toListOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> [a] -- @ toListOf :: Getting (Endo [a]) s t a b -> s -> [a] toListOf l = foldrOf l (:) [] @@ -340,9 +370,10 @@ -- ('^..') :: s -> 'Simple' 'Lens' s a -> [a] -- ('^..') :: s -> 'Simple' 'Control.Lens.Iso.Iso' s a -> [a] -- ('^..') :: s -> 'Simple' 'Control.Lens.Traversal.Traversal' s a -> [a] +-- ('^..') :: s -> 'Simple' 'Control.Lens.Prism.Prism' s a -> [a] -- @ -(^..) :: s -> Getting [a] s t a b -> [a] -s ^.. l = foldMapOf l return s +(^..) :: s -> Getting (Endo [a]) s t a b -> [a] +s ^.. l = toListOf l s {-# INLINE (^..) #-} -- | Returns 'True' if every target of a 'Fold' is 'True'. @@ -360,6 +391,7 @@ -- 'andOf' :: 'Simple' 'Lens' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool' +-- 'andOf' :: 'Simple' 'Control.Lens.Prism.Prism' s 'Bool' -> s -> 'Bool' -- @ andOf :: Getting All s t Bool b -> s -> Bool andOf l = getAll# (foldMapOf l All) @@ -380,6 +412,7 @@ -- 'orOf' :: 'Simple' 'Lens' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s 'Bool' -> s -> 'Bool' +-- 'orOf' :: 'Simple' 'Control.Lens.Prism.Prism' s 'Bool' -> s -> 'Bool' -- @ orOf :: Getting Any s t Bool b -> s -> Bool orOf l = getAny# (foldMapOf l Any) @@ -401,6 +434,7 @@ -- 'anyOf' :: 'Simple' 'Lens' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'anyOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ anyOf :: Getting Any s t a b -> (a -> Bool) -> s -> Bool anyOf l f = getAny# $ foldMapOf l (any# f) @@ -421,6 +455,7 @@ -- 'allOf' :: 'Simple' 'Lens' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'allOf' :: 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ allOf :: Getting All s t a b -> (a -> Bool) -> s -> Bool allOf l f = getAll# $ foldMapOf l (all# f) @@ -441,6 +476,7 @@ -- 'productOf' :: 'Simple' 'Lens' s a -> s -> a -- 'productOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> a -- 'productOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a +-- 'productOf' :: 'Num' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> a -- @ productOf :: Getting (Product a) s t a b -> s -> a productOf l = getProduct# $ foldMapOf l Product @@ -471,6 +507,7 @@ -- 'sumOf' :: 'Simple' 'Lens' s a -> s -> a -- 'sumOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> a +-- 'sumOf' :: 'Num' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> a -- @ sumOf :: Getting (Sum a) s t a b -> s -> a sumOf l = getSum# $ foldMapOf l Sum @@ -502,6 +539,7 @@ -- 'traverseOf_' :: 'Functor' f => 'Simple' 'Lens' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Functor' f => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> f r) -> s -> f () +-- 'traverseOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> f r) -> s -> f () -- @ traverseOf_ :: Functor f => Getting (Traversed f) s t a b -> (a -> f r) -> s -> f () traverseOf_ l f = getTraversed# (foldMapOf l (traversed# (void . f))) @@ -524,6 +562,7 @@ -- 'forOf_' :: 'Functor' f => 'Simple' 'Lens' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Functor' f => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> (a -> f r) -> f () +-- 'forOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> (a -> f r) -> f () -- @ forOf_ :: Functor f => Getting (Traversed f) s t a b -> s -> (a -> f r) -> f () forOf_ = flip . traverseOf_ @@ -534,13 +573,14 @@ -- @'sequenceA_' ≡ 'sequenceAOf_' 'folded'@ -- -- @ --- 'sequenceAOf_' :: 'Functor' f => 'Getter' s (f ()) -> s -> f () --- 'sequenceAOf_' :: 'Applicative' f => 'Fold' s (f ()) -> s -> f () --- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Lens' s (f ()) -> s -> f () --- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Iso' s (f ()) -> s -> f () --- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s (f ()) -> s -> f () +-- 'sequenceAOf_' :: 'Functor' f => 'Getter' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Applicative' f => 'Fold' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Lens' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Functor' f => 'Simple' 'Iso' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Applicative' f => 'Simple' 'Control.Lens.Prism.Prism' s (f a) -> s -> f () -- @ -sequenceAOf_ :: Functor f => Getting (Traversed f) s t (f ()) b -> s -> f () +sequenceAOf_ :: Functor f => Getting (Traversed f) s t (f a) b -> s -> f () sequenceAOf_ l = getTraversed# (foldMapOf l (traversed# void)) {-# INLINE sequenceAOf_ #-} @@ -554,6 +594,7 @@ -- 'mapMOf_' :: 'Monad' m => 'Simple' 'Lens' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m r) -> s -> m () +-- 'mapMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Prism.Prism' s a -> (a -> m r) -> s -> m () -- @ mapMOf_ :: Monad m => Getting (Sequenced m) s t a b -> (a -> m r) -> s -> m () mapMOf_ l f = getSequenced# (foldMapOf l (sequenced# (liftM skip . f))) @@ -573,6 +614,7 @@ -- 'forMOf_' :: 'Monad' m => 'Simple' 'Lens' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> (a -> m r) -> m () +-- 'forMOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> (a -> m r) -> m () -- @ forMOf_ :: Monad m => Getting (Sequenced m) s t a b -> s -> (a -> m r) -> m () forMOf_ = flip . mapMOf_ @@ -588,6 +630,7 @@ -- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Lens' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Iso.Iso' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Traversal.Traversal' s (m a) -> s -> m () +-- 'sequenceOf_' :: 'Monad' m => 'Simple' 'Control.Lens.Prism.Prism' s (m a) -> s -> m () -- @ sequenceOf_ :: Monad m => Getting (Sequenced m) s t (m a) b -> s -> m () sequenceOf_ l = getSequenced# (foldMapOf l (sequenced# (liftM skip))) @@ -603,6 +646,7 @@ -- 'asumOf' :: 'Alternative' f => 'Simple' 'Lens' s a -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> f a -- 'asumOf' :: 'Alternative' f => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> f a -- @ asumOf :: Alternative f => Getting (Endo (f a)) s t (f a) b -> s -> f a asumOf l = foldrOf l (<|>) Applicative.empty @@ -618,6 +662,7 @@ -- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Lens' s a -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> m a -- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Simple' 'Control.Lens.Prism.Prism' s a -> s -> m a -- @ msumOf :: MonadPlus m => Getting (Endo (m a)) s t (m a) b -> s -> m a msumOf l = foldrOf l mplus mzero @@ -636,6 +681,7 @@ -- 'elemOf' :: 'Eq' a => 'Simple' 'Lens' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> a -> s -> 'Bool' +-- 'elemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> a -> s -> 'Bool' -- @ elemOf :: Eq a => Getting Any s t a b -> a -> s -> Bool elemOf l = anyOf l . (==) @@ -651,6 +697,7 @@ -- 'notElemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Simple' 'Lens' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> a -> s -> 'Bool' +-- 'notElemOf' :: 'Eq' a => 'Simple' 'Control.Lens.Prism.Prism' s a -> a -> s -> 'Bool' -- @ notElemOf :: Eq a => Getting All s t a b -> a -> s -> Bool notElemOf l = allOf l . (/=) @@ -713,21 +760,11 @@ lengthOf l = getSum# (foldMapOf l (\_ -> Sum 1)) {-# INLINE lengthOf #-} --- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result --- from a 'Getter' or 'Lens'. See also ('^?'). --- --- @'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'headOf' 'folded'@ --- --- @ --- 'headOf' :: 'Getter' s a -> s -> 'Maybe' a --- 'headOf' :: 'Fold' s a -> s -> 'Maybe' a --- 'headOf' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a --- 'headOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Maybe' a --- 'headOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a --- @ +-- | A deprecated alias for 'firstOf' headOf :: Getting (First a) s t a b -> s -> Maybe a headOf l = getFirst# (foldMapOf l (first# Just)) {-# INLINE headOf #-} +{-# DEPRECATED headOf "`headOf' will be removed in 3.8. (Use `preview' or `firstOf')" #-} -- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. @@ -735,7 +772,7 @@ -- When using a 'Control.Lens.Traversal.Traversal' as a partial 'Control.Lens.Type.Lens', or a 'Fold' as a partial 'Getter' this can be a convenient -- way to extract the optional value. -- --- @('^?') ≡ 'flip' 'headOf'@ +-- @('^?') ≡ 'flip' 'preview'@ -- -- @ -- ('^?') :: s -> 'Getter' s a -> 'Maybe' a @@ -761,10 +798,24 @@ a ^?! l = fromMaybe (error "(^?!): empty Fold") $ getFirst (foldMapOf l (first# Just) a) {-# INLINE (^?!) #-} --- | Perform a safe 'last' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result +-- | Retrieve the 'First' entry of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. -- -- @ +-- 'firstOf' :: 'Getter' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Fold' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a +-- @ +firstOf :: Getting (First a) s t a b -> s -> Maybe a +firstOf l = getFirst# (foldMapOf l (first# Just)) +{-# INLINE firstOf #-} + +-- | Retrieve the 'Last' entry of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result +-- from a 'Getter' or 'Lens'. +-- +-- @ -- 'lastOf' :: 'Getter' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Fold' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a @@ -800,7 +851,33 @@ nullOf l = getAll# (foldMapOf l (\_ -> All False)) {-# INLINE nullOf #-} + -- | +-- Returns 'True' if this 'Fold' or 'Control.Lens.Traversal.Traversal' has any targets in the given container. +-- +-- Note: 'notNullOf' on a valid 'Control.Lens.Iso.Iso', 'Lens' or 'Getter' should always return 'True' +-- +-- @'null' ≡ 'notNullOf' 'folded'@ +-- +-- This may be rather inefficient compared to the @'not' . 'null'@ check of many containers. +-- +-- >>> notNullOf _1 (1,2) +-- True +-- +-- @'notNullOf' ('folded' '.' '_1' '.' 'folded') :: 'Foldable' f => f (g a, b) -> 'Bool'@ +-- +-- @ +-- 'notNullOf' :: 'Getter' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Fold' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Simple' 'Lens' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Bool' +-- @ +notNullOf :: Getting Any s t a b -> s -> Bool +notNullOf l = getAny# (foldMapOf l (\_ -> Any True)) +{-# INLINE notNullOf #-} + +-- | -- Obtain the maximum element (if any) targeted by a 'Fold' or 'Control.Lens.Traversal.Traversal' -- -- Note: maximumOf on a valid 'Control.Lens.Iso.Iso', 'Lens' or 'Getter' will always return 'Just' a value. @@ -916,7 +993,7 @@ mf x (Just y) = Just (f x y) {-# INLINE foldr1Of #-} --- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and strutures such +-- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and structures such -- that the lens views at least one element of the structure. -- -- @ @@ -1009,3 +1086,61 @@ -- | Useful for storing folds in containers. newtype ReifiedFold s a = ReifyFold { reflectFold :: Fold s a } + +-- * Previewing + +-- | Retrieve the first value targeted by a 'Fold' or 'Control.Lens.Traversal.Traversal' (or 'Just' the result +-- from a 'Getter' or 'Lens'). See also ('^?'). +-- +-- @'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'preview' 'folded'@ +-- +-- This is usually applied in the reader monad @(->) s@. +-- +-- @ +-- 'preview' :: 'Getter' s a -> s -> 'Maybe' a +-- 'preview' :: 'Fold' s a -> s -> 'Maybe' a +-- 'preview' :: 'Simple' 'Lens' s a -> s -> 'Maybe' a +-- 'preview' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> s -> 'Maybe' a +-- 'preview' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Maybe' a +-- @ +-- +-- However, it may be useful to think of its full generality when working with +-- a monad transformer stack: +-- +-- @ +-- 'preview' :: MonadReader s m => 'Getter' s a -> m ('Maybe' a) +-- 'preview' :: MonadReader s m => 'Fold' s a -> m ('Maybe' a) +-- 'preview' :: MonadReader s m => 'Simple' 'Lens' s a -> m ('Maybe' a) +-- 'preview' :: MonadReader s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> m ('Maybe' a) +-- 'preview' :: MonadReader s m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> m ('Maybe' a) +-- @ +preview :: MonadReader s m => Getting (First a) s t a b -> m (Maybe a) +preview l = asks (getFirst# (foldMapOf l (first# Just))) +{-# INLINE preview #-} + +-- | Retrieve a function of the first value targeted by a 'Fold' or +-- 'Control.Lens.Traversal.Traversal' (or 'Just' the result from a 'Getter' or 'Lens'). +-- +-- This is usually applied in the reader monad @(->) s@. +-- +-- @ +-- 'previews' :: 'Getter' s a -> (a -> r) -> s -> 'Maybe' a +-- 'previews' :: 'Fold' s a -> (a -> r) -> s -> 'Maybe' a +-- 'previews' :: 'Simple' 'Lens' s a -> (a -> r) -> s -> 'Maybe' a +-- 'previews' :: 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> s -> 'Maybe' a +-- 'previews' :: 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> s -> 'Maybe' a +-- @ +-- +-- However, it may be useful to think of its full generality when working with +-- a monad transformer stack: +-- +-- @ +-- 'previews' :: MonadReader s m => 'Getter' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: MonadReader s m => 'Fold' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: MonadReader s m => 'Simple' 'Lens' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: MonadReader s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: MonadReader s m => 'Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m ('Maybe' r) +-- @ +previews :: MonadReader s m => Getting (First r) s t a b -> (a -> r) -> m (Maybe r) +previews l f = asks (getFirst# (foldMapOf l (first# (Just . f)))) +{-# INLINE previews #-} 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 @@ -2,10 +2,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} --- {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- @@ -57,9 +55,11 @@ , views , use , uses - , peruse - , peruses - + -- * Simple Getter Operations + , view' + , views' + , use' + , uses' -- * Storing Getters , ReifiedGetter(..) , Gettable @@ -69,11 +69,16 @@ import Control.Lens.Classes import Control.Lens.Internal import Control.Lens.Internal.Combinators -import Control.Monad.Reader.Class as Reader -import Control.Monad.State.Class as State +import Control.Monad.Reader.Class as Reader +import Control.Monad.State as State -- $setup -- >>> import Control.Lens +-- >>> import Data.List.Lens +-- >>> import Debug.SimpleReflect.Expr +-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) +-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f +-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g infixl 8 ^., ^& infixl 1 & @@ -89,17 +94,35 @@ -- for inference. Here it is supplied for notational convenience and given a precedence that allows it -- to be nested inside uses of ('$'). -- +-- >>> a & f +-- f a +-- -- >>> "hello" & length & succ -- 6 +-- +-- This combinator is commonly used when applying multiple lens operations in sequence. +-- +-- >>> ("hello","world") & _1.element 0 .~ 'j' & _1.element 4 .~ 'y' +-- ("jelly","world") +-- +-- This reads somewhat similar to: +-- +-- >>> flip execState ("hello","world") $ do _1.element 0 .= 'j'; _1.element 4 .= 'y' +-- ("jelly","world") +-- + (&) :: a -> (a -> b) -> b a & f = f a {-# INLINE (&) #-} -- | A version of ('&') with much tighter precedence that can be interleaved with ('^.') -- +-- >>> a ^& f +-- f a +-- -- >>> "hello" ^& length -- 5 --- >>> import Data.List.Lens +-- -- >>> ("hello","world")^._1^&reverse^?!_head -- 'o' (^&) :: a -> (a -> b) -> b @@ -122,10 +145,12 @@ -- | Build a 'Getter' from an arbitrary Haskell function. -- --- @'to' f . 'to' g = 'to' (g . f)@ +-- @'to' f . 'to' g ≡ 'to' (g . f)@ -- --- @a '^.' 'to' f = f a@ +-- @a '^.' 'to' f ≡ f a@ -- +-- >>> a ^.to f +-- f a -- -- >>> ("hello","world")^.to snd -- "world" @@ -141,6 +166,12 @@ -- | +-- When you see this in a type signature it indicates that you can +-- pass the function a 'Control.Lens.Type.Lens', 'Getter', +-- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold', +-- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of +-- the indexed variants, and it will just \"do the right thing\". +-- -- Most 'Getter' combinators are able to be used with both a 'Getter' or a -- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be -- monomorphic in what we are going to extract with 'Const'. To be compatible @@ -152,6 +183,7 @@ -- you can pass a 'Control.Lens.Fold.Fold' (or -- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a -- 'Getter' or 'Control.Lens.Type.Lens'. +-- type Getting r s t a b = (a -> Accessor r b) -> s -> Accessor r t ------------------------------------------------------------------------------- @@ -163,8 +195,11 @@ -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- at a monoidal values. -- --- @'view' . 'to' = 'id'@ +-- @'view' . 'to' ≡ 'id'@ -- +-- >>> view (to f) a +-- f a +-- -- >>> view _2 (1,"hello") -- "hello" -- @@ -175,8 +210,8 @@ -- "world" -- -- --- It may be useful to think of 'view' as having one of these more restrictive --- signatures: +-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', +-- It may be useful to think of it as having one of these more restrictive signatures: -- -- @ -- 'view' :: 'Getter' s a -> s -> a @@ -185,8 +220,18 @@ -- 'view' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> s -> a -- 'view' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m -- @ -view :: Getting a s t a b -> s -> a -view l = runAccessor# (l Accessor) +-- +-- In a more general setting, such as when working with a monad transformer stack you can use: +-- +-- @ +-- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a +-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a +-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a +-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a +-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a +-- @ +view :: MonadReader s m => Getting a s t a b -> m a +view l = Reader.asks (runAccessor# (l Accessor)) {-# INLINE view #-} -- | View the value of a 'Getter', 'Control.Lens.Iso.Iso', @@ -197,11 +242,17 @@ -- It may be useful to think of 'views' as having these more restrictive -- signatures: -- --- @'views' l f = 'view' (l '.' 'to' f)@ +-- @'views' l f ≡ 'view' (l '.' 'to' f)@ -- +-- >>> views (to f) g a +-- g (f a) +-- -- >>> views _2 length (1,"hello") -- 5 -- +-- As @views@ is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', +-- It may be useful to think of it as having one of these more restrictive signatures: +-- -- @ -- 'views' :: 'Getter' s a -> (a -> r) -> s -> r -- 'views' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m @@ -209,8 +260,18 @@ -- 'views' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> s -> r -- 'views' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m) -> s -> m -- @ -views :: Getting r s t a b -> (a -> r) -> s -> r -views l f = runAccessor# (l (accessor# f)) +-- +-- In a more general setting, such as when working with a monad transformer stack you can use: +-- +-- @ +-- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a +-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a +-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a +-- 'view' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a +-- 'view' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a +-- @ +views :: MonadReader s m => Getting r s t a b -> (a -> r) -> m r +views l f = Reader.asks (runAccessor# (l (accessor# f))) {-# INLINE views #-} -- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or @@ -220,8 +281,11 @@ -- -- This is the same operation as 'view', only infix. -- --- @'to' f '^$' x = f x@ +-- @'to' f '^$' x ≡ f x@ -- +-- >>> to f ^$ x +-- f x +-- -- >>> _2 ^$ (1, "hello") -- "hello" -- @@ -245,6 +309,9 @@ -- The fixity and semantics are such that subsequent field accesses can be -- performed with ('Prelude..') -- +-- >>> (a,b)^._2 +-- b +-- -- >>> ("hello","world")^._2 -- "world" -- @@ -273,6 +340,12 @@ -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- to a monoidal value. -- +-- >>> evalState (use _1) (a,b) +-- a +-- +-- >>> evalState (use _1) ("hello","world") +-- "hello" +-- -- @ -- 'use' :: 'MonadState' s m => 'Getter' s a -> m a -- 'use' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r -> m r @@ -290,6 +363,9 @@ -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that -- points to a monoidal value. -- +-- >>> evalState (uses _1 length) ("hello","world") +-- 5 +-- -- @ -- 'uses' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r -- 'uses' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r @@ -301,43 +377,153 @@ uses l f = State.gets (views l f) {-# INLINE uses #-} -------------------------------------------------------------------------------- --- MonadReader -------------------------------------------------------------------------------- +------------------------------------------------------------------------------ +-- Accessing State, Simplified +------------------------------------------------------------------------------ + -- | --- Query the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or +-- This is a type restricted version of 'use' that expects a 'Simple' 'Getter'. +-- +-- Use the target of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', or -- 'Getter' in the current state, or use a summary of a -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points -- to a monoidal value. -- +-- This use of this combinator may aid type-inference when working with lenses or traversals that +-- have non-defaultable typeclass constraints on their arguments. +-- +-- >>> evalState (use' _1) (a,b) +-- a +-- +-- +-- >>> evalState (use' _1) ("hello","world") +-- "hello" +-- -- @ --- 'peruse' :: 'MonadReader' s m => 'Getter' s a -> m a --- 'peruse' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a --- 'peruse' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a --- 'peruse' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a --- 'peruse' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a +-- 'use'' :: 'MonadState' s m => 'Getter' s a -> m a +-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s r -> m r +-- 'use'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a +-- 'use'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a +-- 'use'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s r -> m r -- @ -peruse :: MonadReader s m => Getting a s t a b -> m a -peruse l = Reader.asks (^.l) -{-# INLINE peruse #-} +use' :: MonadState s m => Getting a s s a a -> m a +use' l = State.gets (view' l) +{-# INLINE use' #-} -- | +-- This is a type restricted version of 'uses' that expects a 'Simple' 'Getter'. +-- -- Use the target of a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' or -- 'Getter' in the current state, or use a summary of a +-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that +-- points to a monoidal value. +-- +-- >>> evalState (uses' _1 length) ("hello","world") +-- 5 +-- +-- @ +-- 'uses'' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r +-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r +-- 'uses'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> m r +-- 'uses'' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m r +-- 'uses'' :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r +-- @ +uses' :: MonadState s m => Getting r s s a a -> (a -> r) -> m r +uses' l f = State.gets (views' l f) +{-# INLINE uses' #-} + +------------------------------------------------------------------------------ +-- Viewing, Simplified +------------------------------------------------------------------------------ + +-- | This is a type restricted version of 'view' that expects a 'Simple' 'Getter'. +-- +-- View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or +-- 'Control.Lens.Type.Lens' or the result of folding over all the results of a -- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points --- to a monoidal value. +-- at a monoidal values. -- +-- @'view'' . 'to' ≡ 'id'@ +-- +-- >>> view' (to f) a +-- f a +-- +-- >>> view' _2 (1,"hello") +-- "hello" +-- +-- >>> view' (to succ) 5 +-- 6 +-- +-- >>> view' (_2._1) ("hello",("world","!!!")) +-- "world" +-- +-- As 'view'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', +-- It may be useful to think of it as having one of these more restrictive signatures: +-- -- @ --- 'peruses' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m r --- 'peruses' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r --- 'peruses' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m r --- 'peruses' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> m r --- 'peruses' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r +-- 'view'' :: 'Getter' s a -> s -> a +-- 'view'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s m -> s -> m +-- 'view'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> s -> a +-- 'view'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> s -> a +-- 'view'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s m -> s -> m -- @ -peruses :: MonadReader s m => Getting r s t a b -> (a -> r) -> m r -peruses l f = Reader.asks (views l f) -{-# INLINE peruses #-} +-- +-- In a more general setting, such as when working with a monad transformer stack you can use: +-- +-- @ +-- 'view'' :: 'MonadReader' s m => 'Getter' s a -> m a +-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a +-- 'view'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> m a +-- 'view'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> m a +-- 'view'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> m a +-- @ +view' :: MonadReader s m => Getting a s s a a -> m a +view' l = Reader.asks (runAccessor# (l Accessor)) +{-# INLINE view' #-} + +-- | This is a type restricted version of 'views' that expects a 'Simple' 'Getter'. +-- +-- View the value of a 'Getter', 'Control.Lens.Iso.Iso', +-- 'Control.Lens.Type.Lens' or the result of folding over the result of mapping +-- the targets of a 'Control.Lens.Fold.Fold' or +-- 'Control.Lens.Traversal.Traversal'. +-- +-- It may be useful to think of 'perviews' as having these more restrictive +-- signatures: +-- +-- @'views'' l f ≡ 'view'' (l '.' 'to' f)@ +-- +-- >>> views' _2 length (1,"hello") +-- 5 +-- +-- As 'views'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', +-- It may be useful to think of it as having one of these more restrictive signatures: +-- +-- @ +-- 'views'' :: 'Getter' s a -> (a -> r) -> s -> r +-- 'views'' :: 'Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m +-- 'views'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> s -> r +-- 'views'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> s -> r +-- 'views'' :: 'Monoid' m => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> m) -> s -> m +-- @ +-- +-- In a more general setting, such as when working with a monad transformer stack you can use: +-- +-- @ +-- 'views'' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m r +-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r +-- 'views'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> r) -> m r +-- 'views'' :: 'MonadReader' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> r) -> m r +-- 'views'' :: ('MonadReader' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> (a -> r) -> m r +-- @ +views' :: MonadReader s m => Getting r s s a a -> (a -> r) -> m r +views' l f = Reader.asks (runAccessor# (l (accessor# f))) +{-# INLINE views' #-} + +------------------------------------------------------------------------------ +-- Reified Getters +------------------------------------------------------------------------------ -- | Useful for storing getters in containers. newtype ReifiedGetter s a = ReifyGetter { reflectGetter :: Getter s a } 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 @@ -16,88 +16,64 @@ -- Combinators for working with 'Indexed' functions. ---------------------------------------------------------------------------- module Control.Lens.Indexed - ( + ( Indexable(..) -- * Indexed Functions - Indexed(..) - , Indexable - , Index(..) + , Indexed(..) , (<.>), (<.), (.>) , icompose - , reindex - , indexed + , reindexed + -- * Indexing existing lenses, traversals, etc. + , indexing ) where +import Control.Lens.Classes import Control.Lens.Internal infixr 9 <.>, <., .> --- | Permit overloading of function application for things that also admit a notion of a key or index. - --- | Provides overloading for 'Indexed' functions. -class Indexed i k where - -- | Build a function from an 'Indexed' function - index :: ((i -> a) -> b) -> k a b - --- | Type alias for passing around polymorphic 'Indexed' functions that can be called 'withIndex' or --- directly as a function -type Indexable i a b = forall k. Indexed i k => k a b - -instance Indexed i (->) where - index f = f . const - {-# INLINE index #-} - --- | A function with access to a index. This constructor may be useful when you need to store --- a 'Indexable' in a container to avoid @ImpredicativeTypes@. -newtype Index i a b = Index { withIndex :: (i -> a) -> b } - --- | Using an equality witness to avoid potential overlapping instances --- and aid dispatch. -instance i ~ j => Indexed i (Index j) where - index = Index - {-# INLINE index #-} - -- | Compose an 'Indexed' function with a non-indexed function. -- --- Mnemonically, the @<@ points to the index we want to preserve. -(<.) :: Indexed i k => Index i b c -> (a -> b) -> k a c -Index ibc <. ab = index $ \ia -> ibc (ab . ia) +-- Mnemonically, the @<@ points to the indexing we want to preserve. +(<.) :: Indexable i k => Indexed i b c -> (a -> b) -> k a c +Indexed ibc <. ab = indexed $ \ia -> ibc (ab . ia) {-# INLINE (<.) #-} -- | Compose a non-indexed function with an 'Indexed' function. -- --- Mnemonically, the @>@ points to the index we want to preserve. -(.>) :: Indexed i k => (b -> c) -> Index i a b -> k a c -bc .> Index iab = index (bc . iab) +-- Mnemonically, the @>@ points to the indexing we want to preserve. +(.>) :: Indexable i k => (b -> c) -> Indexed i a b -> k a c +bc .> Indexed iab = indexed (bc . iab) {-# INLINE (.>) #-} -- | Remap the index. -reindex :: Indexed j k => (i -> j) -> Index i a b -> k a b -reindex ij (Index iab) = index $ \ ja -> iab $ \i -> ja (ij i) -{-# INLINE reindex #-} +reindexed :: Indexable j k => (i -> j) -> Indexed i a b -> k a b +reindexed ij (Indexed iab) = indexed $ \ ja -> iab $ \i -> ja (ij i) +{-# INLINE reindexed #-} -- | Composition of 'Indexed' functions -- -- Mnemonically, the @\<@ and @\>@ points to the fact that we want to preserve the indices. -(<.>) :: Indexed (i, j) k => Index i b c -> Index j a b -> k a c +(<.>) :: Indexable (i, j) k => Indexed i b c -> Indexed j a b -> k a c f <.> g = icompose (,) f g {-# INLINE (<.>) #-} --- | Composition of 'Indexed' functions with a user supplied function for combining indexs -icompose :: Indexed k r => (i -> j -> k) -> Index i b c -> Index j a b -> r a c -icompose ijk (Index ibc) (Index jab) = index $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j) +-- | Composition of 'Indexed' functions with a user supplied function for combining indices +icompose :: Indexable k r => (i -> j -> k) -> Indexed i b c -> Indexed j a b -> r a c +icompose ijk (Indexed ibc) (Indexed jab) = indexed $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j) {-# INLINE icompose #-} --- | Transform an 'Traversal' into an 'Control.Lens.IndexedTraversal.IndexedTraversal', a 'Fold' into an 'Control.Lens.IndexedFold.IndexedFold', etc. +-- | Transform an 'Traversal' into an 'Control.Lens.IndexedTraversal.IndexedTraversal' or +-- a 'Fold' into an 'Control.Lens.IndexedFold.IndexedFold', etc. -- -- @ --- 'indexed' :: 'Control.Lens.Traversal.Traversal' s t a b -> 'Control.Lens.IndexedTraversal.IndexedTraversal' 'Int' s t a b --- 'indexed' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b --- 'indexed' :: 'Control.Lens.Fold.Fold' s t -> 'Control.Lens.IndexedFold.IndexedFold' 'Int' s t --- 'indexed' :: 'Control.Lens.Iso.Iso' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b --- 'indexed' :: 'Control.Lens.Getter.Getter' s t -> 'Control.Lens.IndexedGetter.IndexedGetter' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Traversal.Traversal' s t a b -> 'Control.Lens.IndexedTraversal.IndexedTraversal' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Prism.Prism' s t a b -> 'Control.Lens.IndexedLens.IndexedTraversal' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Iso.Iso' s t a b -> 'Control.Lens.IndexedLens.IndexedLens' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Fold.Fold' s t -> 'Control.Lens.IndexedFold.IndexedFold' 'Int' s t +-- 'indexing' :: 'Control.Lens.Getter.Getter' s t -> 'Control.Lens.IndexedGetter.IndexedGetter' 'Int' s t a b -- @ -indexed :: Indexed Int k => ((a -> Indexing f b) -> s -> Indexing f t) -> k (a -> f b) (s -> f t) -indexed l = index $ \iafb s -> case runIndexing (l (\a -> Indexing (\i -> (iafb i a, i + 1))) s) 0 of +indexing :: Indexable Int k => ((a -> Indexing f b) -> s -> Indexing f t) -> k (a -> f b) (s -> f t) +indexing l = indexed $ \iafb s -> case runIndexing (l (\a -> Indexing (\i -> i `seq` (iafb i a, i + 1))) s) 0 of (r, _) -> r -{-# INLINE indexed #-} - +{-# INLINE indexing #-} diff --git a/src/Control/Lens/IndexedFold.hs b/src/Control/Lens/IndexedFold.hs --- a/src/Control/Lens/IndexedFold.hs +++ b/src/Control/Lens/IndexedFold.hs @@ -67,11 +67,12 @@ ------------------------------------------------------------------------------ -- | Every 'IndexedFold' is a valid 'Control.Lens.Fold.Fold'. -type IndexedFold i s a = forall k f. (Indexed i k, Applicative f, Gettable f) => k (a -> f a) (s -> f s) +type IndexedFold i s a = forall k f. + (Indexable i k, Applicative f, Gettable f) => k (a -> f a) (s -> f s) -- | -- Fold an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' by mapping indices and values to an arbitrary 'Monoid' with access --- to the index @i@. +-- to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.foldMapOf' is more flexible in what it accepts. -- @@ -89,7 +90,7 @@ -- | -- Right-associative fold of parts of a structure that are viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with --- access to the index @i@. +-- access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.foldrOf' is more flexible in what it accepts. -- @@ -107,7 +108,7 @@ -- | -- Left-associative fold of the parts of a structure that are viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with --- access to the index @i@. +-- access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf' is more flexible in what it accepts. -- @@ -125,7 +126,7 @@ -- | -- Return whether or not any element viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' --- satisfy a predicate, with access to the index @i@. +-- satisfy a predicate, with access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.anyOf' is more flexible in what it accepts. -- @@ -143,7 +144,7 @@ -- | -- Return whether or not all elements viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' --- satisfy a predicate, with access to the index @i@. +-- satisfy a predicate, with access to the @i@. -- -- When you don't need access to the index then 'Control.Lens.Fold.allOf' is more flexible in what it accepts. -- @@ -160,7 +161,7 @@ {-# INLINE iallOf #-} -- | --- Traverse the targets of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index @i@, discarding the results. +-- Traverse the targets of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the @i@, discarding the results. -- -- When you don't need access to the index then 'Control.Lens.Fold.traverseOf_' is more flexible in what it accepts. -- @@ -360,8 +361,8 @@ -- 'itoListOf' :: 'Control.Lens.IndexedLens.SimpleIndexedLens' i s a -> s -> [(i,a)] -- 'itoListOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> s -> [(i,a)] -- @ -itoListOf :: IndexedGetting i [(i,a)] s t a b -> s -> [(i,a)] -itoListOf l = ifoldMapOf l (\i a -> [(i,a)]) +itoListOf :: IndexedGetting i (Endo [(i,a)]) s t a b -> s -> [(i,a)] +itoListOf l = ifoldrOf l (\i a -> ((i,a):)) [] {-# INLINE itoListOf #-} ------------------------------------------------------------------------------- @@ -387,7 +388,7 @@ -- @ -- -- Change made to the indices will be discarded. -withIndicesOf :: Functor f => Overloaded (Index i) f s t a b -> LensLike f s t (i, a) (j, b) +withIndicesOf :: Functor f => Overloaded (Indexed i) f s t a b -> LensLike f s t (i, a) (j, b) withIndicesOf l f = withIndex l (\i c -> snd <$> f (i,c)) {-# INLINE withIndicesOf #-} @@ -398,7 +399,7 @@ -- 'indicesOf' :: 'SimpleIndexedLens' i s a -> 'Getter' s i -- 'indicesOf' :: 'SimpleIndexedTraversal' i s a -> 'Fold' s i -- @ -indicesOf :: Gettable f => Overloaded (Index i) f s t a a -> LensLike f s t i j +indicesOf :: Gettable f => Overloaded (Indexed i) f s t a a -> LensLike f s t i j indicesOf l f = withIndex l (const . coerce . f) {-# INLINE indicesOf #-} @@ -411,31 +412,47 @@ -- When passed an 'Control.Lens.IndexedTraversal.IndexedTraversal', sadly the result is /not/ a legal 'Control.Lens.IndexedTraversal.IndexedTraversal'. -- -- See 'filtered' for a related counter-example. -ifiltering :: (Applicative f, Indexed i k) => (i -> a -> Bool) -> Index i (a -> f a) (s -> f t) -> k (a -> f a) (s -> f t) -ifiltering p l = index $ \ f -> withIndex l $ \ i c -> if p i c then f i c else pure c +ifiltering :: (Applicative f, Indexable i k) + => (i -> a -> Bool) + -> Indexed i (a -> f a) (s -> f t) + -> k (a -> f a) (s -> f t) +ifiltering p l = indexed $ \ f -> + withIndex l $ \ i c -> if p i c then f i c else pure c {-# INLINE ifiltering #-} --- | Reverse the order of the elements of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal'. --- This has no effect on an 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter', or 'Control.Lens.IndexedSetter.IndexedSetter'. -ibackwards :: Indexed i k => Index i (a -> (Backwards f) b) (s -> (Backwards f) t) -> k (a -> f b) (s -> f t) -ibackwards l = index $ \ f -> fmap forwards . withIndex l $ \ i -> backwards# (f i) +-- | Reverse the order of the elements of an 'IndexedFold' or +-- 'Control.Lens.IndexedTraversal.IndexedTraversal'. +-- This has no effect on an 'Control.Lens.IndexedLens.IndexedLens', +-- 'IndexedGetter', or 'Control.Lens.IndexedSetter.IndexedSetter'. +ibackwards :: Indexable i k + => Indexed i (a -> (Backwards f) b) (s -> (Backwards f) t) + -> k (a -> f b) (s -> f t) +ibackwards l = indexed $ \ f -> + fmap forwards . withIndex l $ \ i -> backwards# (f i) {-# INLINE ibackwards #-} --- | Obtain an 'IndexedFold' by taking elements from another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' while a predicate holds. -itakingWhile :: (Gettable f, Applicative f, Indexed i k) - => (i -> a -> Bool) - -> IndexedGetting i (Endo (f s)) s s a a - -> k (a -> f a) (s -> f s) -itakingWhile p l = index $ \ f -> ifoldrOf l (\i a r -> if p i a then f i a *> r else noEffect) noEffect +-- | Obtain an 'IndexedFold' by taking elements from another +-- 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', +-- 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' +-- while a predicate holds. +itakingWhile :: (Gettable f, Applicative f, Indexable i k) + => (i -> a -> Bool) + -> IndexedGetting i (Endo (f s)) s s a a + -> k (a -> f a) (s -> f s) +itakingWhile p l = indexed $ \ f -> + ifoldrOf l (\i a r -> if p i a then f i a *> r else noEffect) noEffect {-# INLINE itakingWhile #-} -- | Obtain an 'IndexedFold' by dropping elements from another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' while a predicate holds. -idroppingWhile :: (Gettable f, Applicative f, Indexed i k) +idroppingWhile :: (Gettable f, Applicative f, Indexable i k) => (i -> a -> Bool) -> IndexedGetting i (Endo (f s, f s)) s s a a -> k (a -> f a) (s -> f s) -idroppingWhile p l = index $ \ f -> fst . ifoldrOf l (\i a r -> let s = f i a *> snd r in if p i a then (fst r, s) else (s, s)) (noEffect, noEffect) +idroppingWhile p l = indexed $ \ f -> + fst . ifoldrOf l + (\i a r -> let s = f i a *> snd r in if p i a then (fst r, s) else (s, s)) + (noEffect, noEffect) {-# INLINE idroppingWhile #-} ------------------------------------------------------------------------------ @@ -443,4 +460,5 @@ ------------------------------------------------------------------------------ -- | Useful for storage. -newtype ReifiedIndexedFold i s a = ReifyIndexedFold { reflectIndexedFold :: IndexedFold i s a } +newtype ReifiedIndexedFold i s a = + ReifyIndexedFold { reflectIndexedFold :: IndexedFold i s a } diff --git a/src/Control/Lens/IndexedGetter.hs b/src/Control/Lens/IndexedGetter.hs --- a/src/Control/Lens/IndexedGetter.hs +++ b/src/Control/Lens/IndexedGetter.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | @@ -12,25 +13,63 @@ ---------------------------------------------------------------------------- module Control.Lens.IndexedGetter ( - -- * Indexed Folds + -- * Indexed Getters IndexedGetter , IndexedGetting , ReifiedIndexedGetter(..) + -- * Indexed Getter Combinators + , iview, iviews + , iuse, iuses ) where import Control.Lens.Indexed import Control.Lens.Internal +import Control.Lens.Internal.Combinators import Control.Lens.Classes +import Control.Monad.Reader +import Control.Monad.State ------------------------------------------------------------------------------ -- Indexed Getters ------------------------------------------------------------------------------ -- | Every 'IndexedGetter' is a valid 'Control.Lens.IndexedFold.IndexedFold' and 'Getter'. -type IndexedGetter i s a = forall k f. (Indexed i k, Gettable f) => k (a -> f a) (s -> f s) +type IndexedGetter i s a = forall k f. (Indexable i k, Gettable f) => k (a -> f a) (s -> f s) -- | Used to consume an 'Control.Lens.IndexedFold.IndexedFold'. -type IndexedGetting i m s t a b = Index i (a -> Accessor m b) (s -> Accessor m t) +type IndexedGetting i m s t a b = Indexed i (a -> Accessor m b) (s -> Accessor m t) -- | Useful for storage. newtype ReifiedIndexedGetter i s a = ReifyIndexedGetter { reflectIndexedGetter :: IndexedGetter i s a } + +-- | View the index and value of an 'IndexedGetter' into the current environment as a pair. +-- +-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of +-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. +iview :: MonadReader s m => IndexedGetting i (i,a) s t a b -> m (i,a) +iview l = asks (runAccessor# (withIndex l (\i -> accessor# ((,) i)))) +{-# INLINE iview #-} + +-- | View a function of the index and value of an 'IndexedGetter' into the current environment +-- +-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. +-- +-- @'iviews' ≡ 'Control.Lens.IndexedFold.ifoldMapOf'@ +iviews :: MonadReader s m => IndexedGetting i r s t a b -> (i -> a -> r) -> m r +iviews l f = asks (runAccessor# (withIndex l (\i -> accessor# (f i)))) +{-# INLINE iviews #-} + +-- | Use the index and value of an 'IndexedGetter' into the current state as a pair. +-- +-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of +-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. +iuse :: MonadState s m => IndexedGetting i (i,a) s t a b -> m (i,a) +iuse l = gets (runAccessor# (withIndex l (\i -> accessor# ((,) i)))) +{-# INLINE iuse #-} + +-- | Use a function of the index and value of an 'IndexedGetter' into the current state. +-- +-- 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 t a b -> (i -> a -> r) -> m r +iuses l f = gets (runAccessor# (withIndex l (\i -> accessor# (f i)))) +{-# INLINE iuses #-} diff --git a/src/Control/Lens/IndexedLens.hs b/src/Control/Lens/IndexedLens.hs --- a/src/Control/Lens/IndexedLens.hs +++ b/src/Control/Lens/IndexedLens.hs @@ -1,11 +1,13 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif @@ -27,10 +29,6 @@ ( -- * Indexed Lenses IndexedLens - -- * Common Indexed Lenses - , At(..) - , Contains(..) - , resultAt -- * Indexed Lens Combinators , (%%@~) , (<%@~) @@ -38,24 +36,25 @@ , (<%@=) -- * Storing Indexed Lenses , ReifiedIndexedLens(..) + -- * Common Indexed Lenses + , Contains(..) + , resultAt -- * Simple , SimpleIndexedLens , SimpleReifiedIndexedLens ) where -import Control.Applicative -import Control.Lens.Indexed +import Control.Lens.Classes +import Control.Lens.Combinators +import Control.Lens.Internal import Control.Lens.Type import Control.Monad.State.Class as State import Data.Hashable -import Data.HashMap.Lazy as HashMap -import Data.IntMap as IntMap -import Data.Map as Map - import Data.HashSet as HashSet import Data.IntSet as IntSet import Data.Set as Set + -- $setup -- >>> import Control.Lens @@ -63,7 +62,7 @@ infix 4 %%@=, <%@= -- | Every 'IndexedLens' is a valid 'Lens' and a valid 'Control.Lens.IndexedTraversal.IndexedTraversal'. -type IndexedLens i s t a b = forall f k. (Indexed i k, Functor f) => k (a -> f b) (s -> f t) +type IndexedLens i s t a b = forall f k. (Indexable i k, Functor f) => k (a -> f b) (s -> f t) -- | @type 'SimpleIndexedLens' i = 'Simple' ('IndexedLens' i)@ type SimpleIndexedLens i s a = IndexedLens i s s a a @@ -72,7 +71,7 @@ -- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' and return a monoidal summary -- along with the answer. -- --- @l '<%~' f = l '<%@~' 'const' f@ +-- @l '<%~' f ≡ l '<%@~' 'const' f@ -- -- When you do not need access to the index then ('<%~') is more liberal in what it can accept. -- @@ -82,7 +81,7 @@ -- ('<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (b, t) -- ('<%@~') :: 'Monoid' b => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (b, t) -- @ -(<%@~) :: Overloaded (Index i) ((,)b) s t a b -> (i -> a -> b) -> s -> (b, t) +(<%@~) :: Overloaded (Indexed i) ((,)b) s t a b -> (i -> a -> b) -> s -> (b, t) l <%@~ f = withIndex l $ \i a -> let b = f i a in (b, b) {-# INLINE (<%@~) #-} @@ -90,7 +89,7 @@ -- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' and return a monoidal summary -- of the supplementary results and the answer. -- --- @('%%@~') = 'withIndex'@ +-- @('%%@~') ≡ 'withIndex'@ -- -- @ -- ('%%@~') :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t @@ -104,7 +103,7 @@ -- ('%%@~') :: 'IndexedLens' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- ('%%@~') :: 'Monoid' r => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> (r, b)) -> s -> (r, t) -- @ -(%%@~) :: Overloaded (Index i) f s t a b -> (i -> a -> f b) -> s -> f t +(%%@~) :: Overloaded (Indexed i) f s t a b -> (i -> a -> f b) -> s -> f t (%%@~) = withIndex {-# INLINE (%%@~) #-} @@ -112,13 +111,13 @@ -- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' within the current state, and -- return a monoidal summary of the supplementary results. -- --- @l '%%@=' f = 'state' (l '%%@~' f)@ +-- @l '%%@=' f ≡ 'state' (l '%%@~' f)@ -- -- @ -- ('%%@=') :: 'MonadState' s m 'IndexedLens' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- ('%%@=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- @ -(%%@=) :: MonadState s m => Overloaded (Index i) ((,)r) s s a b -> (i -> a -> (r, b)) -> m r +(%%@=) :: MonadState s m => Overloaded (Indexed i) ((,)r) s s a b -> (i -> a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,0) l %%@= f = State.state (l %%@~ f) #else @@ -137,37 +136,19 @@ -- ('<%@=') :: 'MonadState' s m 'IndexedLens' i s s a b -> (i -> a -> b) -> m b -- ('<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m b -- @ -(<%@=) :: MonadState s m => Overloaded (Index i) ((,)b) s s a b -> (i -> a -> b) -> m b +(<%@=) :: MonadState s m => Overloaded (Indexed i) ((,)b) s s a b -> (i -> a -> b) -> m b l <%@= f = l %%@= \ i a -> let b = f i a in (b, b) {-# INLINE (<%@=) #-} --- | Provides an 'IndexedLens' that can be used to read, write or delete the value associated with a key in a map-like container. -class At k m | m -> k where - -- | - -- >>> Map.fromList [(1,"hello")] ^.at 1 - -- Just "hello" - -- - -- >>> at 1 ?~ "hello" $ Map.empty - -- fromList [(1,"hello")] - at :: k -> SimpleIndexedLens k (m v) (Maybe v) - -instance At Int IntMap where - at k = index $ \ f m -> (`go` m) <$> f k (IntMap.lookup k m) where - go Nothing = IntMap.delete k - go (Just v') = IntMap.insert k v' - {-# INLINE at #-} +------------------------------------------------------------------------------ +-- Reifying Indexed Lenses +------------------------------------------------------------------------------ -instance Ord k => At k (Map k) where - at k = index $ \ f m -> (`go` m) <$> f k (Map.lookup k m) where - go Nothing = Map.delete k - go (Just v') = Map.insert k v' - {-# INLINE at #-} +-- | Useful for storage. +newtype ReifiedIndexedLens i s t a b = ReifyIndexedLens { reflectIndexedLens :: IndexedLens i s t a b } -instance (Eq k, Hashable k) => At k (HashMap k) where - at k = index $ \ f m -> (`go` m) <$> f k (HashMap.lookup k m) where - go Nothing = HashMap.delete k - go (Just v') = HashMap.insert k v' - {-# INLINE at #-} +-- | @type 'SimpleIndexedLens' i = 'Simple' ('ReifiedIndexedLens' i)@ +type SimpleReifiedIndexedLens i s a = ReifiedIndexedLens i s s a a -- | Provides an 'IndexedLens' that can be used to read, write or delete a member of a set-like container class Contains k m | m -> k where @@ -177,15 +158,18 @@ contains :: k -> SimpleIndexedLens k m Bool instance Contains Int IntSet where - contains k = index $ \ f s -> (\b -> if b then IntSet.insert k s else IntSet.delete k s) <$> f k (IntSet.member k s) + contains k = indexed $ \ f s -> f k (IntSet.member k s) <&> \b -> + if b then IntSet.insert k s else IntSet.delete k s {-# INLINE contains #-} instance Ord k => Contains k (Set k) where - contains k = index $ \ f s -> (\b -> if b then Set.insert k s else Set.delete k s) <$> f k (Set.member k s) + contains k = indexed $ \ f s -> f k (Set.member k s) <&> \b -> + if b then Set.insert k s else Set.delete k s {-# INLINE contains #-} instance (Eq k, Hashable k) => Contains k (HashSet k) where - contains k = index $ \ f s -> (\b -> if b then HashSet.insert k s else HashSet.delete k s) <$> f k (HashSet.member k s) + contains k = indexed $ \ f s -> f k (HashSet.member k s) <&> \b -> + if b then HashSet.insert k s else HashSet.delete k s {-# INLINE contains #-} -- | This lens can be used to change the result of a function but only where @@ -194,15 +178,5 @@ -- >>> let f = (+1) & resultAt 3 .~ 8 in (f 2, f 3) -- (3,8) resultAt :: Eq e => e -> SimpleIndexedLens e (e -> a) a -resultAt e = index $ \ g f -> (\a' e' -> if e == e' then a' else f e') <$> g e (f e) +resultAt e = indexed $ \ g f -> g e (f e) <&> \a' e' -> if e == e' then a' else f e' {-# INLINE resultAt #-} - ------------------------------------------------------------------------------- --- Reifying Indexed Lenses ------------------------------------------------------------------------------- - --- | Useful for storage. -newtype ReifiedIndexedLens i s t a b = ReifyIndexedLens { reflectIndexedLens :: IndexedLens i s t a b } - --- | @type 'SimpleIndexedLens' i = 'Simple' ('ReifiedIndexedLens' i)@ -type SimpleReifiedIndexedLens i s a = ReifiedIndexedLens i s s a a diff --git a/src/Control/Lens/IndexedSetter.hs b/src/Control/Lens/IndexedSetter.hs --- a/src/Control/Lens/IndexedSetter.hs +++ b/src/Control/Lens/IndexedSetter.hs @@ -42,7 +42,8 @@ -- | Every 'IndexedSetter' is a valid 'Setter' -- -- The 'Control.Lens.Setter.Setter' laws are still required to hold. -type IndexedSetter i s t a b = forall f k. (Indexed i k, Settable f) => k (a -> f b) (s -> f t) +type IndexedSetter i s t a b = forall f k. + (Indexable i k, Settable f) => k (a -> f b) (s -> f t) -- | -- @type 'SimpleIndexedSetter' i = 'Simple' ('IndexedSetter' i)@ @@ -59,7 +60,7 @@ -- 'imapOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- 'imapOf' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ -imapOf :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t +imapOf :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t imapOf l f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE imapOf #-} @@ -74,7 +75,7 @@ -- 'iover' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- 'iover' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ -iover :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t +iover :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t iover l f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE iover #-} @@ -97,7 +98,7 @@ -- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. isets :: ((i -> a -> b) -> s -> t) -> IndexedSetter i s t a b -isets f = index $ \ g -> tainted# (f (\i -> untainted# (g i))) +isets f = indexed $ \ g -> tainted# (f (\i -> untainted# (g i))) {-# INLINE isets #-} -- | Adjust every target of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal' @@ -114,7 +115,7 @@ -- ('%@~') :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> b) -> s -> t -- ('%@~') :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ -(%@~) :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t +(%@~) :: Overloaded (Indexed i) Mutator s t a b -> (i -> a -> b) -> s -> t l %@~ f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE (%@~) #-} @@ -130,7 +131,7 @@ -- ('%@=') :: 'MonadState' s m => 'Control.Lens.IndexedLens.IndexedLens' i s s a b -> (i -> a -> b) -> m () -- ('%@=') :: 'MonadState' s m => 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> m () -- @ -(%@=) :: MonadState s m => Overloaded (Index i) Mutator s s a b -> (i -> a -> b) -> m () +(%@=) :: MonadState s m => Overloaded (Indexed i) Mutator s s a b -> (i -> a -> b) -> m () l %@= f = State.modify (l %@~ f) {-# INLINE (%@=) #-} @@ -139,7 +140,8 @@ ------------------------------------------------------------------------------ -- | Useful for storage. -newtype ReifiedIndexedSetter i s t a b = ReifyIndexedSetter { reflectIndexedSetter :: IndexedSetter i s t a b } +newtype ReifiedIndexedSetter i s t a b = + ReifyIndexedSetter { reflectIndexedSetter :: IndexedSetter i s t a b } -- | @type 'SimpleIndexedSetter' i = 'Simple' ('ReifiedIndexedSetter' i)@ type SimpleReifiedIndexedSetter i s a = ReifiedIndexedSetter i s s a a diff --git a/src/Control/Lens/IndexedTraversal.hs b/src/Control/Lens/IndexedTraversal.hs --- a/src/Control/Lens/IndexedTraversal.hs +++ b/src/Control/Lens/IndexedTraversal.hs @@ -1,19 +1,21 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 #endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.IndexedTraversal @@ -30,10 +32,10 @@ IndexedTraversal -- * Common Indexed Traversals - , _at , iwhereOf , value , ignored + , At(..) , TraverseMin(..) , TraverseMax(..) , traversed @@ -60,14 +62,17 @@ import Control.Applicative import Control.Applicative.Backwards +import Control.Lens.Combinators import Control.Lens.Indexed import Control.Lens.IndexedLens import Control.Lens.Internal import Control.Lens.Type import Control.Monad.Trans.State.Lazy as Lazy -import Data.Traversable +import Data.Hashable +import Data.HashMap.Lazy as HashMap import Data.IntMap as IntMap import Data.Map as Map +import Data.Traversable -- $setup -- >>> import Control.Lens @@ -76,12 +81,14 @@ -- Indexed Traversals ------------------------------------------------------------------------------ --- | Every indexed traversal is a valid 'Control.Lens.Traversal.Traversal' or 'Control.Lens.IndexedFold.IndexedFold'. +-- | Every indexed traversal is a valid 'Control.Lens.Traversal.Traversal' or +-- 'Control.Lens.IndexedFold.IndexedFold'. -- --- The 'Indexed' constraint is used to allow an 'IndexedTraversal' to be used directly as a 'Control.Lens.Traversal.Traversal'. +-- The 'Indexed' constraint is used to allow an 'IndexedTraversal' to be used +-- directly as a 'Control.Lens.Traversal.Traversal'. -- -- The 'Control.Lens.Traversal.Traversal' laws are still required to hold. -type IndexedTraversal i s t a b = forall f k. (Indexed i k, Applicative f) => k (a -> f b) (s -> f t) +type IndexedTraversal i s t a b = forall f k. (Indexable i k, Applicative f) => k (a -> f b) (s -> f t) -- | @type 'SimpleIndexedTraversal' i = 'Simple' ('IndexedTraversal' i)@ type SimpleIndexedTraversal i s a = IndexedTraversal i s s a a @@ -100,7 +107,7 @@ -- 'itraverseOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t -- 'itraverseOf' :: 'IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t -- @ -itraverseOf :: Overloaded (Index i) f s t a b -> (i -> a -> f b) -> s -> f t +itraverseOf :: Overloaded (Indexed i) f s t a b -> (i -> a -> f b) -> s -> f t itraverseOf = withIndex {-# INLINE itraverseOf #-} @@ -116,7 +123,7 @@ -- 'iforOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> s -> (i -> a -> f b) -> f t -- 'iforOf' :: 'IndexedTraversal' i s t a b -> s -> (i -> a -> f b) -> f t -- @ -iforOf :: Overloaded (Index i) f s t a b -> s -> (i -> a -> f b) -> f t +iforOf :: Overloaded (Indexed i) f s t a b -> s -> (i -> a -> f b) -> f t iforOf = flip . withIndex {-# INLINE iforOf #-} @@ -132,7 +139,7 @@ -- 'imapMOf' :: 'Monad' m => 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> a -> m b) -> s -> m t -- 'imapMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> (i -> a -> m b) -> s -> m t -- @ -imapMOf :: Overloaded (Index i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t +imapMOf :: Overloaded (Indexed i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t imapMOf l f = unwrapMonad . withIndex l (\i -> WrapMonad . f i) {-# INLINE imapMOf #-} @@ -149,7 +156,7 @@ -- 'iforMOf' :: 'Monad' m => 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> s -> (i -> a -> m b) -> m t -- 'iforMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> s -> (i -> a -> m b) -> m t -- @ -iforMOf :: Overloaded (Index i) (WrappedMonad m) s t a b -> s -> (i -> a -> m b) -> m t +iforMOf :: Overloaded (Indexed i) (WrappedMonad m) s t a b -> s -> (i -> a -> m b) -> m t iforMOf = flip . imapMOf {-# INLINE iforMOf #-} @@ -163,7 +170,7 @@ -- 'imapAccumROf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- 'imapAccumROf' :: 'IndexedTraversal' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- @ -imapAccumROf :: Overloaded (Index i) (Lazy.State s) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) +imapAccumROf :: Overloaded (Indexed i) (Lazy.State s) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) imapAccumROf l f s0 a = swap (Lazy.runState (withIndex l (\i c -> Lazy.state (\s -> swap (f i s c))) a) s0) {-# INLINE imapAccumROf #-} @@ -177,7 +184,7 @@ -- 'imapAccumLOf' :: 'Control.Lens.IndexedLens.IndexedLens' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- 'imapAccumLOf' :: 'IndexedTraversal' i s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) -- @ -imapAccumLOf :: Overloaded (Index i) (Backwards (Lazy.State s)) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) +imapAccumLOf :: Overloaded (Indexed i) (Backwards (Lazy.State s)) s t a b -> (i -> s -> a -> (s, b)) -> s -> s -> (s, t) imapAccumLOf l f s0 a = swap (Lazy.runState (forwards (withIndex l (\i c -> Backwards (Lazy.state (\s -> swap (f i s c)))) a)) s0) {-# INLINE imapAccumLOf #-} @@ -201,25 +208,19 @@ -- 'iwhereOf' :: 'SimpleIndexedTraversal' i s a -> (i -> 'Bool') -> 'SimpleIndexedTraversal' i s a -- 'iwhereOf' :: 'SimpleIndexedSetter' i s a -> (i -> 'Bool') -> 'SimpleIndexedSetter' i s a -- @ -iwhereOf :: (Indexed i k, Applicative f) => Overloaded (Index i) f s t a a -> (i -> Bool) -> Overloaded k f s t a a -iwhereOf l p = index $ \f s -> withIndex l (\i a -> if p i then f i a else pure a) s +iwhereOf :: (Indexable i k, Applicative f) => Overloaded (Indexed i) f s t a a -> (i -> Bool) -> Overloaded k f s t a a +iwhereOf l p = indexed $ \f s -> withIndex l (\i a -> if p i then f i a else pure a) s {-# INLINE iwhereOf #-} --- | This simple indexed traversal lets you 'traverse' the value at a given key in a map. --- --- @'_at' k = 'at' k '<.' 'traverse'@ -_at :: At k m => k -> SimpleIndexedTraversal k (m v) v -_at k = at k <. traverse -{-# INLINE _at #-} - -- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b -traversed = indexed traverse +traversed = indexing traverse +{-# INLINE traversed #-} -- | This provides a 'Traversal' that checks a predicate on a key before -- allowing you to traverse into a value. value :: (k -> Bool) -> SimpleIndexedTraversal k (k, v) v -value p = index $ \ f kv@(k,v) -> if p k then (,) k <$> f k v else pure kv +value p = indexed $ \ f kv@(k,v) -> if p k then (,) k <$> f k v else pure kv {-# INLINE value #-} -- | This is the trivial empty traversal. @@ -227,28 +228,88 @@ -- @'ignored' :: 'IndexedTraversal' i s s a b@ -- -- @'ignored' ≡ 'const' 'pure'@ -ignored :: forall k f i s a b. (Indexed i k, Applicative f) => Overloaded k f s s a b -ignored = index $ \ (_ :: i -> a -> f b) s -> pure s :: f s +ignored :: forall k f i s a b. (Indexable i k, Applicative f) => Overloaded k f s s a b +ignored = indexed $ \ (_ :: i -> a -> f b) s -> pure s :: f s {-# INLINE ignored #-} +-- | 'At' provides a lens that can be used to read, +-- write or delete the value associated with a key in a map-like +-- container on an ad hoc basis. +class At k m | m -> k where + -- | + -- >>> Map.fromList [(1,"hello")] ^.at 1 + -- Just "hello" + -- + -- >>> at 1 ?~ "hello" $ Map.empty + -- fromList [(1,"hello")] + -- + -- Note: 'Map'-like containers form a reasonable instance, but not 'Array'-like ones, where + -- you cannot satisfy the 'Lens' laws. + at :: k -> SimpleIndexedLens k (m v) (Maybe v) + + -- | This simple indexed traversal lets you 'traverse' the value at a given key in a map. + -- + -- *NB:* _setting_ the value of this lens will only set the value in the lens + -- if it is already present. + -- + -- @'_at' k ≡ 'at' k '<.' 'traverse'@ + _at :: k -> SimpleIndexedTraversal k (m v) v + _at k = at k <. traverse + +instance At Int IntMap where + at k = indexed $ \f m -> + let mv = IntMap.lookup k m + go Nothing = maybe m (const (IntMap.delete k m)) mv + go (Just v') = IntMap.insert k v' m + in go <$> f k mv where + {-# INLINE at #-} + _at k = indexed $ \f m -> case IntMap.lookup k m of + Just v -> f k v <&> \v' -> IntMap.insert k v' m + Nothing -> pure m + {-# INLINE _at #-} + +instance Ord k => At k (Map k) where + at k = indexed $ \f m -> + let mv = Map.lookup k m + go Nothing = maybe m (const (Map.delete k m)) mv + go (Just v') = Map.insert k v' m + in go <$> f k mv + {-# INLINE at #-} + _at k = indexed $ \f m -> case Map.lookup k m of + Just v -> f k v <&> \v' -> Map.insert k v' m + Nothing -> pure m + {-# INLINE _at #-} + +instance (Eq k, Hashable k) => At k (HashMap k) where + at k = indexed $ \f m -> + let mv = HashMap.lookup k m + go Nothing = maybe m (const (HashMap.delete k m)) mv + go (Just v') = HashMap.insert k v' m + in go <$> f k mv + {-# INLINE at #-} + _at k = indexed $ \f m -> case HashMap.lookup k m of + Just v -> f k v <&> \v' -> HashMap.insert k v' m + Nothing -> pure m + {-# INLINE _at #-} + -- | Allows 'IndexedTraversal' the value at the smallest index. class Ord k => TraverseMin k m | m -> k where -- | 'IndexedTraversal' of the element with the smallest index. traverseMin :: SimpleIndexedTraversal k (m v) v instance TraverseMin Int IntMap where - traverseMin = index $ \f m -> case IntMap.minViewWithKey m of + traverseMin = indexed $ \f m -> case IntMap.minViewWithKey m of #if MIN_VERSION_containers(0,5,0) - Just ((k,a), _) -> (\v -> IntMap.updateMin (const (Just v)) m) <$> f k a + Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMin (const (Just v)) m #else - Just ((k,a), _) -> (\v -> IntMap.updateMin (const v) m) <$> f k a + Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMin (const v) m #endif Nothing -> pure m {-# INLINE traverseMin #-} instance Ord k => TraverseMin k (Map k) where - traverseMin = index $ \f m -> case Map.minViewWithKey m of - Just ((k, a), _) -> (\v -> Map.updateMin (const (Just v)) m) <$> f k a + traverseMin = indexed $ \f m -> case Map.minViewWithKey m of + Just ((k, a), _) -> f k a <&> \v -> Map.updateMin (const (Just v)) m Nothing -> pure m {-# INLINE traverseMin #-} @@ -258,22 +319,23 @@ traverseMax :: SimpleIndexedTraversal k (m v) v instance TraverseMax Int IntMap where - traverseMax = index $ \f m -> case IntMap.maxViewWithKey m of + traverseMax = indexed $ \f m -> case IntMap.maxViewWithKey m of #if MIN_VERSION_containers(0,5,0) - Just ((k,a), _) -> (\v -> IntMap.updateMax (const (Just v)) m) <$> f k a + Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMax (const (Just v)) m #else - Just ((k,a), _) -> (\v -> IntMap.updateMax (const v) m) <$> f k a + Just ((k,a), _) -> f k a <&> \v -> IntMap.updateMax (const v) m #endif Nothing -> pure m {-# INLINE traverseMax #-} instance Ord k => TraverseMax k (Map k) where - traverseMax = index $ \f m -> case Map.maxViewWithKey m of - Just ((k, a), _) -> (\v -> Map.updateMax (const (Just v)) m) <$> f k a + traverseMax = indexed $ \f m -> case Map.maxViewWithKey m of + Just ((k, a), _) -> f k a <&> \v -> Map.updateMax (const (Just v)) m Nothing -> pure m {-# INLINE traverseMax #-} --- | Traverse the /nth/ element 'elementOf' a 'Traversal', 'Lens' or 'Control.Lens.Iso.Iso' if it exists. +-- | Traverse the /nth/ element 'elementOf' a 'Traversal', 'Lens' or +-- 'Control.Lens.Iso.Iso' if it exists. -- -- >>> [[1],[3,4]] & elementOf (traverse.traverse) 1 .~ 5 -- [[1],[5,4]] @@ -291,8 +353,11 @@ -- 'elementOf' :: 'Simple' 'Traversal' s a -> Int -> 'SimpleIndexedTraversal' 'Int' s a -- 'elementOf' :: 'Fold' s a -> Int -> 'IndexedFold' 'Int' s a -- @ -elementOf :: (Applicative f, Indexed Int k) => LensLike (Indexing f) s t a a -> Int -> Overloaded k f s t a a -elementOf l = elementsOf l . (==) +elementOf :: (Applicative f, Indexable Int k) + => LensLike (Indexing f) s t a a + -> Int + -> Overloaded k f s t a a +elementOf l p = elementsOf l (p ==) {-# INLINE elementOf #-} -- | Traverse the /nth/ element of a 'Traversable' container. @@ -308,9 +373,13 @@ -- 'elementsOf' :: 'Simple' 'Traversal' s a -> ('Int' -> 'Bool') -> 'SimpleIndexedTraversal' 'Int' s a -- 'elementsOf' :: 'Fold' s a -> ('Int' -> 'Bool') -> 'IndexedFold' 'Int' s a -- @ -elementsOf :: (Applicative f, Indexed Int k) => LensLike (Indexing f) s t a a -> (Int -> Bool) -> Overloaded k f s t a a -elementsOf l p = index $ \iafb s -> case runIndexing (l (\a -> Indexing (\i -> (if p i then iafb i a else pure a, i + 1))) s) 0 of - (r, _) -> r +elementsOf :: (Applicative f, Indexable Int k) + => LensLike (Indexing f) s t a a + -> (Int -> Bool) + -> Overloaded k f s t a a +elementsOf l p = indexed $ \iafb s -> + case runIndexing (l (\a -> Indexing (\i -> i `seq` (if p i then iafb i a else pure a, i + 1))) s) 0 of + (r, _) -> r {-# INLINE elementsOf #-} -- | Traverse elements of a 'Traversable' container where their ordinal positions matches a predicate. @@ -325,7 +394,8 @@ ------------------------------------------------------------------------------ -- | Useful for storage. -newtype ReifiedIndexedTraversal i s t a b = ReifyIndexedTraversal { reflectIndexedTraversal :: IndexedTraversal i s t a b } +newtype ReifiedIndexedTraversal i s t a b = + ReifyIndexedTraversal { reflectIndexedTraversal :: IndexedTraversal i s t a b } -- | @type 'SimpleIndexedTraversal' i = 'Simple' ('ReifiedIndexedTraversal' i)@ type SimpleReifiedIndexedTraversal i s a = ReifiedIndexedTraversal i s s a a diff --git a/src/Control/Lens/Internal.hs b/src/Control/Lens/Internal.hs --- a/src/Control/Lens/Internal.hs +++ b/src/Control/Lens/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} @@ -6,9 +7,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MagicHash #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -50,21 +50,33 @@ , Max(..), getMax , Min(..), getMin , Indexing(..) + -- * Overloadings + , Prismoid(..) + , Isoid(..) + , Indexed(..) + , CoA, CoB ) where import Control.Applicative import Control.Category import Control.Comonad import Control.Comonad.Store.Class -import Control.Lens.Isomorphic import Control.Lens.Classes import Control.Monad import Prelude hiding ((.),id) import Data.Functor.Compose import Data.Functor.Identity import Data.Monoid +#ifndef SAFE import Unsafe.Coerce +#endif +#ifndef SAFE +#define UNSAFELY(x) unsafeCoerce +#else +#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x)) +#endif + ----------------------------------------------------------------------------- -- Functors ----------------------------------------------------------------------------- @@ -316,8 +328,10 @@ coerce (Effect m) = Effect m instance Monad m => Effective m r (Effect m r) where - effective = isomorphic Effect getEffect + effective = Effect {-# INLINE effective #-} + ineffective = getEffect + {-# INLINE ineffective #-} -- | Wrap a monadic effect with a phantom type argument. Used when magnifying RWST. newtype EffectRWS w st m s a = EffectRWS { getEffectRWS :: st -> m (s,st,w) } @@ -372,8 +386,10 @@ coerce (Accessor m) = Accessor m instance Effective Identity r (Accessor r) where - effective = isomorphic (Accessor . runIdentity) (Identity . runAccessor) + effective = Accessor . runIdentity {-# INLINE effective #-} + ineffective = Identity . runAccessor + {-# INLINE ineffective #-} -- | A 'Monoid' for a 'Gettable' 'Applicative'. newtype Folding f a = Folding { getFolding :: f a } @@ -396,16 +412,19 @@ instance Functor Mutator where fmap f (Mutator a) = Mutator (f a) + {-# INLINE fmap #-} instance Applicative Mutator where pure = Mutator + {-# INLINE pure #-} Mutator f <*> Mutator a = Mutator (f a) + {-# INLINE (<*>) #-} instance Settable Mutator where untainted = runMutator - untainted# = unsafeCoerce + untainted# = UNSAFELY(runMutator) {-# INLINE untainted #-} - tainted# = unsafeCoerce + tainted# = UNSAFELY(Mutator) {-# INLINE tainted# #-} -- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Gettable' instance @@ -453,3 +472,79 @@ sellT i = BazaarT (\k -> k i) {-# INLINE sellT #-} +------------------------------------------------------------------------------ +-- Prism Internals +------------------------------------------------------------------------------ + +type family ArgOf (f_b :: *) :: * +type instance ArgOf (f b) = b + +-- | Extract @a@ from the type @a -> f b@ +type family CoA x :: * + +-- | Extract @b@ from the type @a -> f b@ +type family CoB x :: * +type instance CoA (a -> f_b) = a +type instance CoB (a -> f_b) = ArgOf f_b + +-- | This data type is used to capture all of the information provided by the +-- 'Prismatic' -- class, so you can turn a 'Prism' around into a 'Getter' or +-- otherwise muck around with its internals. +-- +-- If you see a function that expects a 'Prismoid' or 'APrism', it is probably +-- just expecting a 'Prism'. +data Prismoid ab st where + Prismoid :: Prismoid x x + Prism :: (CoB x -> CoB y) -> (CoA y -> Either (CoB y) (CoA x)) -> Prismoid x y + +instance Category Prismoid where + id = Prismoid + x . Prismoid = x + Prismoid . x = x + Prism ty xeys . Prism bt seta = Prism (ty.bt) $ \x -> + case xeys x of + Left y -> Left y + Right s -> case seta s of + Left t -> Left (ty t) + Right a -> Right a + +instance Isomorphic Prismoid where + iso sa bt = Prism bt (Right . sa) + {-# INLINE iso #-} + +instance Prismatic Prismoid where + prism = Prism + {-# INLINE prism #-} + +------------------------------------------------------------------------------ +-- Isomorphism Internals +------------------------------------------------------------------------------ + +-- | Reify all of the information given to you by being 'Isomorphic'. +data Isoid ab st where + Isoid :: Isoid ab ab + Iso :: (CoA y -> CoA x) -> (CoB x -> CoB y) -> Isoid x y + +instance Category Isoid where + id = Isoid + Isoid . x = x + x . Isoid = x + Iso xs ty . Iso sa bt = Iso (sa.xs) (ty.bt) + +instance Isomorphic Isoid where + iso = Iso + {-# INLINE iso #-} + +------------------------------------------------------------------------------ +-- Indexed Internals +------------------------------------------------------------------------------ + +-- | A function with access to a index. This constructor may be useful when you need to store +-- a 'Indexable' in a container to avoid @ImpredicativeTypes@. +newtype Indexed i a b = Indexed { withIndex :: (i -> a) -> b } + +-- | Using an equality witness to avoid potential overlapping instances +-- and aid dispatch. +instance i ~ j => Indexable i (Indexed j) where + indexed = Indexed + {-# INLINE indexed #-} diff --git a/src/Control/Lens/Internal/Combinators.hs b/src/Control/Lens/Internal/Combinators.hs --- a/src/Control/Lens/Internal/Combinators.hs +++ b/src/Control/Lens/Internal/Combinators.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#if defined(TRUSTWORTHY) && !defined(SAFE) {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -58,166 +58,174 @@ import Control.Applicative.Backwards import Control.Lens.Internal import Data.Monoid +#ifndef SAFE import Unsafe.Coerce +#endif +#ifndef SAFE +#define UNSAFELY(x) unsafeCoerce +#else +#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x)) +#endif + const# :: (a -> b) -> a -> Const b r -const# = unsafeCoerce +const# = UNSAFELY(Const) getConst# :: (a -> Const b r) -> a -> b -getConst# = unsafeCoerce +getConst# = UNSAFELY(getConst) zipList# :: (a -> [b]) -> a -> ZipList b -zipList# = unsafeCoerce +zipList# = UNSAFELY(ZipList) getZipList# :: (a -> ZipList b) -> a -> [b] -getZipList# = unsafeCoerce +getZipList# = UNSAFELY(getZipList) wrapMonad# :: (a -> m b) -> a -> WrappedMonad m b -wrapMonad# = unsafeCoerce +wrapMonad# = UNSAFELY(WrapMonad) unwrapMonad# :: (a -> WrappedMonad m b) -> a -> m b -unwrapMonad# = unsafeCoerce +unwrapMonad# = UNSAFELY(unwrapMonad) last# :: (a -> Maybe b) -> a -> Last b -last# = unsafeCoerce +last# = UNSAFELY(Last) getLast# :: (a -> Last b) -> a -> Maybe b -getLast# = unsafeCoerce +getLast# = UNSAFELY(getLast) first# :: (a -> Maybe b) -> a -> First b -first# = unsafeCoerce +first# = UNSAFELY(First) getFirst# :: (a -> First b) -> a -> Maybe b -getFirst# = unsafeCoerce +getFirst# = UNSAFELY(getFirst) product# :: (a -> b) -> a -> Product b -product# = unsafeCoerce +product# = UNSAFELY(Product) getProduct# :: (a -> Product b) -> a -> b -getProduct# = unsafeCoerce +getProduct# = UNSAFELY(getProduct) sum# :: (a -> b) -> a -> Sum b -sum# = unsafeCoerce +sum# = UNSAFELY(Sum) getSum# :: (a -> Sum b) -> a -> b -getSum# = unsafeCoerce +getSum# = UNSAFELY(getSum) any# :: (a -> Bool) -> a -> Any -any# = unsafeCoerce +any# = UNSAFELY(Any) getAny# :: (a -> Any) -> a -> Bool -getAny# = unsafeCoerce +getAny# = UNSAFELY(getAny) all# :: (a -> Bool) -> a -> All -all# = unsafeCoerce +all# = UNSAFELY(All) getAll# :: (a -> All) -> a -> Bool -getAll# = unsafeCoerce +getAll# = UNSAFELY(getAll) dual# :: (a -> b) -> a -> Dual b -dual# = unsafeCoerce +dual# = UNSAFELY(Dual) getDual# :: (a -> Dual b) -> a -> b -getDual# = unsafeCoerce +getDual# = UNSAFELY(getDual) endo# :: (a -> b -> b) -> a -> Endo b -endo# = unsafeCoerce +endo# = UNSAFELY(Endo) appEndo# :: (a -> Endo b) -> a -> b -> b -appEndo# = unsafeCoerce +appEndo# = UNSAFELY(appEndo) may# :: (a -> Maybe b) -> a -> May b -may# = unsafeCoerce +may# = UNSAFELY(May) getMay# :: (a -> May b) -> a -> Maybe b -getMay# = unsafeCoerce +getMay# = UNSAFELY(getMay) folding# :: (a -> f b) -> a -> Folding f b -folding# = unsafeCoerce +folding# = UNSAFELY(Folding) getFolding# :: (a -> Folding f b) -> a -> f b -getFolding# = unsafeCoerce +getFolding# = UNSAFELY(getFolding) effect# :: (a -> m r) -> a -> Effect m r b -effect# = unsafeCoerce +effect# = UNSAFELY(Effect) getEffect# :: (a -> Effect m r b) -> a -> m r -getEffect# = unsafeCoerce +getEffect# = UNSAFELY(getEffect) effectRWS# :: (a -> st -> m (s, st, w)) -> a -> EffectRWS w st m s b -effectRWS# = unsafeCoerce +effectRWS# = UNSAFELY(EffectRWS) getEffectRWS# :: (a -> EffectRWS w st m s b) -> a -> st -> m (s, st, w) -getEffectRWS# = unsafeCoerce +getEffectRWS# = UNSAFELY(getEffectRWS) accessor# :: (a -> r) -> a -> Accessor r b -accessor# = unsafeCoerce +accessor# = UNSAFELY(Accessor) runAccessor# :: (a -> Accessor r b) -> a -> r -runAccessor# = unsafeCoerce +runAccessor# = UNSAFELY(runAccessor) err# :: (a -> Either e b) -> a -> Err e b -err# = unsafeCoerce +err# = UNSAFELY(Err) getErr# :: (a -> Err e b) -> a -> Either e b -getErr# = unsafeCoerce +getErr# = UNSAFELY(getErr) traversed# :: (a -> f ()) -> a -> Traversed f -traversed# = unsafeCoerce +traversed# = UNSAFELY(Traversed) getTraversed# :: (a -> Traversed f) -> a -> f () -getTraversed# = unsafeCoerce +getTraversed# = UNSAFELY(getTraversed) sequenced# :: (a -> f ()) -> a -> Sequenced f -sequenced# = unsafeCoerce +sequenced# = UNSAFELY(Sequenced) getSequenced# :: (a -> Sequenced f) -> a -> f () -getSequenced# = unsafeCoerce +getSequenced# = UNSAFELY(getSequenced) focusing# :: (a -> m (s, b)) -> a -> Focusing m s b -focusing# = unsafeCoerce +focusing# = UNSAFELY(Focusing) unfocusing# :: (a -> Focusing m s b) -> a -> m (s, b) -unfocusing# = unsafeCoerce +unfocusing# = UNSAFELY(unfocusing) focusingWith# :: (a -> m (s, b, w)) -> a -> FocusingWith w m s b -focusingWith# = unsafeCoerce +focusingWith# = UNSAFELY(FocusingWith) unfocusingWith# :: (a -> FocusingWith w m s b) -> a -> m (s, b, w) -unfocusingWith# = unsafeCoerce +unfocusingWith# = UNSAFELY(unfocusingWith) focusingPlus# :: (a -> k (s, w) b) -> a -> FocusingPlus w k s b -focusingPlus# = unsafeCoerce +focusingPlus# = UNSAFELY(FocusingPlus) unfocusingPlus# :: (a -> FocusingPlus w k s b) -> a -> k (s, w) b -unfocusingPlus# = unsafeCoerce +unfocusingPlus# = UNSAFELY(unfocusingPlus) focusingOn# :: (a -> k (f s) b) -> a -> FocusingOn f k s b -focusingOn# = unsafeCoerce +focusingOn# = UNSAFELY(FocusingOn) unfocusingOn# :: (a -> FocusingOn f k s b) -> a -> k (f s) b -unfocusingOn# = unsafeCoerce +unfocusingOn# = UNSAFELY(unfocusingOn) focusingMay# :: (a -> k (May s) b) -> a -> FocusingMay k s b -focusingMay# = unsafeCoerce +focusingMay# = UNSAFELY(FocusingMay) unfocusingMay# :: (a -> FocusingMay k s b) -> a -> k (May s) b -unfocusingMay# = unsafeCoerce +unfocusingMay# = UNSAFELY(unfocusingMay) focusingErr# :: (a -> k (Err e s) b) -> a -> FocusingErr e k s b -focusingErr# = unsafeCoerce +focusingErr# = UNSAFELY(FocusingErr) unfocusingErr# :: (a -> FocusingErr e k s b) -> a -> k (Err e s) b -unfocusingErr# = unsafeCoerce +unfocusingErr# = UNSAFELY(unfocusingErr) mutator# :: (a -> b) -> a -> Mutator b -mutator# = unsafeCoerce +mutator# = UNSAFELY(Mutator) runMutator# :: (a -> Mutator b) -> a -> b -runMutator# = unsafeCoerce +runMutator# = UNSAFELY(runMutator) backwards# :: (a -> f b) -> a -> Backwards f b -backwards# = unsafeCoerce +backwards# = UNSAFELY(Backwards) forwards# :: (a -> Backwards f b) -> a -> f b -forwards# = unsafeCoerce +forwards# = UNSAFELY(forwards) diff --git a/src/Control/Lens/Internal/Zipper.hs b/src/Control/Lens/Internal/Zipper.hs --- a/src/Control/Lens/Internal/Zipper.hs +++ b/src/Control/Lens/Internal/Zipper.hs @@ -16,30 +16,29 @@ -- Portability : non-portable -- -- This module provides internal types and functions used in the implementation --- of Control.Lens.Zipper. You shouldn't need to import it directly, and the --- exported types can be used to break Zipper invariants. +-- of @Control.Lens.Zipper@. You shouldn't need to import it directly, and the +-- exported types can be used to break 'Zipper' invariants. -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Zipper where import Control.Applicative -import Control.Applicative.Backwards import Control.Category -import Control.Comonad -import Control.Comonad.Store.Class -import Control.Monad ((>=>)) -import Control.Lens.Fold -import Control.Lens.Indexed +import Control.Monad +import Control.Lens.Classes +import Control.Lens.Getter import Control.Lens.IndexedLens import Control.Lens.Internal +import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type -import Data.Foldable -import Data.List.NonEmpty as NonEmpty import Data.Maybe -import Data.Monoid import Prelude hiding ((.),id) +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Char + ----------------------------------------------------------------------------- -- * Zippers ----------------------------------------------------------------------------- @@ -48,12 +47,12 @@ -- -- Every 'Zipper' starts with 'Top'. -- --- /e.g./ @'Top' ':>' a@ is the trivial zipper. +-- /e.g./ @'Top' ':>' a@ is the type of the trivial 'Zipper'. data Top infixl 9 :> --- | This is the type of a 'Zipper'. It visually resembes a 'breadcrumb trail' as +-- | This is the type of a 'Zipper'. It visually resembles a \"breadcrumb trail\" as -- used in website navigation. Each breadcrumb in the trail represents a level you -- can move up to. -- @@ -63,63 +62,172 @@ -- -- to represent a zipper from @('String','Double')@ down to 'Char' that has an intermediate -- crumb for the 'String' containing the 'Char'. -data p :> a = Zipper (Coil p a) {-# UNPACK #-} !(Level a) +-- +-- You can construct a zipper into *any* data structure with 'zipper'. +-- +-- >>> :t zipper (Just "hello") +-- zipper (Just "hello") :: Top :> Maybe [Char] +-- +-- You can repackage up the contents of a zipper with 'rezip'. +-- +-- >>> rezip $ zipper 42 +-- 42 +-- +-- The combinators in this module provide lot of things you can do to the zipper while you +-- have it open. +-- +-- Note that a value of type @h ':>' s ':>' a@ doesn't actually contain a value +-- of type @h ':>' s@ -- as we descend into a level, the previous level is +-- unpacked and stored in 'Coil' form. Only one value of type @_ ':>' _@ exists +-- at any particular time for any particular 'Zipper'. +data h :> a = Zipper (Coil h a) -- The 'Coil' storing the previous levels of the 'Zipper'. + {-# UNPACK #-} !Int -- Number of items to the left. + [a] -- Items to the left (stored reversed). + a -- Focused item. + [a] -- Items to the right. --- | This represents the type a zipper will have when it is fully 'Zipped' back up. +-- | This is an alias for '(:>)'. Provided mostly for convenience +type Zipper = (:>) + +-- | This represents the type a 'Zipper' will have when it is fully 'Zipped' back up. type family Zipped h a type instance Zipped Top a = a -type instance Zipped (h :> b) a = Zipped h b +type instance Zipped (h :> s) a = Zipped h s --- | 'Coil' is used internally in the definition of a 'Zipper'. +-- | A 'Coil' is a linked list of the levels above the current one. The length +-- of a 'Coil' is known at compile time. +-- +-- This is part of the internal structure of a zipper. You shouldn't need to manipulate this directly. data Coil :: * -> * -> * where Coil :: Coil Top a - Snoc :: Coil h b -> - {-# UNPACK #-} !Int -> - SimpleLensLike (Bazaar a a) b a -> - [b] -> (NonEmpty a -> b) -> [b] -> - Coil (h :> b) a + Snoc :: Coil h s -- Previous 'Coil'. + -> SimpleLensLike (Bazaar a a) s a -- The 'Traversal' used to descend into this level (used to build a 'Tape'). + -- The Zipper above us, unpacked: + -> {-# UNPACK #-} !Int -- Number of items to the left. + -> [s] -- Previous level's items to the left (stored reverse). + -> ([a] -> s) -- Function to rebuild the previous level's focused item from the entire current level. + -- (Since the current level always has a focus, the list must be nonempty.) + -> [s] -- Previous level's items to the right. + -> Coil (h :> s) a --- | This 'Lens' views the current target of the 'zipper'. +-- | This 'Lens' views the current target of the 'Zipper'. +-- +-- A 'Tape' that can be used to get to the current location is available as the index of this 'Lens'. focus :: SimpleIndexedLens (Tape (h :> a)) (h :> a) a -focus = index $ \f (Zipper h (Level n l a r)) -> (\a' -> Zipper h (Level n l a' r)) <$> f (Tape (peel h) n) a +focus = indexed $ \f (Zipper h n l a r) -> (\a' -> Zipper h n l a' r) <$> f (Tape (peel h) n) a {-# INLINE focus #-} --- | Construct a 'zipper' that can explore anything. +-- | Construct a 'Zipper' that can explore anything, and start it at the top. zipper :: a -> Top :> a -zipper a = Zipper Coil (Level 0 [] a []) +zipper a = Zipper Coil 0 [] a [] {-# INLINE zipper #-} --- | Return the index into the current 'Traversal' within the current level of the zipper. +-- | Return the index into the current 'Traversal' within the current level of the 'Zipper'. -- -- @'jerkTo' ('tooth' l) l = Just'@ -tooth :: (a :> b) -> Int -tooth (Zipper _ (Level n _ _ _)) = n +-- +-- Mnemonically, zippers have a number of 'teeth' within each level. This is which 'tooth' you are currently at. +tooth :: (h :> a) -> Int +tooth (Zipper _ n _ _ _) = n {-# INLINE tooth #-} --- | Move the 'zipper' 'up', closing the current level and focusing on the parent element. -up :: (a :> b :> c) -> a :> b -up (Zipper (Snoc h n _ ls k rs) w) = Zipper h (Level n ls (k (rezipLevel w)) rs) -{-# INLINE up #-} +-- | Move the 'Zipper' 'upward', closing the current level and focusing on the parent element. +-- +-- NB: Attempts to move upward from the 'Top' of the 'Zipper' will fail to typecheck. +-- +-- >>> :t zipper ("hello","world") & downward _1 & fromWithin traverse & upward +-- zipper ("hello","world") & downward _1 & fromWithin traverse & upward +-- :: (Top :> ([Char], [Char])) :> [Char] +upward :: (h :> s :> a) -> h :> s +upward (Zipper (Snoc h _ un uls k urs) _ ls x rs) = Zipper h un uls ux urs + where ux = k (reverseList ls ++ x : rs) +{-# INLINE upward #-} --- | Pull the 'zipper' 'left' within the current 'Traversal'. -left :: (a :> b) -> Maybe (a :> b) -left (Zipper h w) = Zipper h <$> leftLevel w -{-# INLINE left #-} +-- | Jerk the 'Zipper' one 'tooth' to the 'rightward' within the current 'Lens' or 'Traversal'. +-- +-- Attempts to move past the start of the current 'Traversal' (or trivially, the current 'Lens') +-- will return 'Nothing'. +-- +-- >>> isNothing $ zipper "hello" & rightward +-- True +-- +-- >>> zipper "hello" & fromWithin traverse & rightward <&> view focus +-- 'e' +-- +-- >>> zipper "hello" & fromWithin traverse & rightward <&> focus .~ 'u' <&> rezip +-- "hullo" +-- +-- >>> rezip $ zipper (1,2) & fromWithin both & tug rightward & focus .~ 3 +-- (1,3) +rightward :: MonadPlus m => (h :> a) -> m (h :> a) +rightward (Zipper _ _ _ _ [] ) = mzero +rightward (Zipper h n ls a (r:rs)) = return (Zipper h (n + 1) (a:ls) r rs) +{-# INLINE rightward #-} --- | Pull the entry one entry to the 'right' -right :: (a :> b) -> Maybe (a :> b) -right (Zipper h w) = Zipper h <$> rightLevel w -{-# INLINE right #-} +-- | Jerk the 'zipper' 'leftward' one 'tooth' within the current 'Lens' or 'Traversal'. +-- +-- Attempts to move past the end of the current 'Traversal' (or trivially, the current 'Lens') +-- will return 'Nothing'. +-- +-- >>> isNothing $ zipper "hello" & leftward +-- True --- | This allows you to safely 'tug left' or 'tug right' on a 'zipper'. +-- >>> isNothing $ zipper "hello" & within traverse >>= leftward +-- True -- +-- >>> zipper "hello" & within traverse <&> tug leftward +-- Just 'h' +-- +-- >>> zipper "hello" & fromWithin traverse & tug rightward & tug leftward & view focus +-- 'h' +leftward :: MonadPlus m => (h :> a) -> m (h :> a) +leftward (Zipper _ _ [] _ _ ) = mzero +leftward (Zipper h n (l:ls) a rs) = return (Zipper h (n - 1) ls l (a:rs)) +{-# INLINE leftward #-} + +-- | Move to the leftmost position of the current 'Traversal'. +-- +-- This is just a convenient alias for @'farthest' 'leftward'@. +-- +-- >>> zipper "hello" & fromWithin traverse & rightmost & focus .~ 'a' & rezip +-- "hella" +leftmost :: (a :> b) -> a :> b +leftmost = farthest leftward + +-- | Move to the rightmost position of the current 'Traversal'. +-- +-- This is just a convenient alias for @'farthest' 'rightward'@. +-- +-- >>> zipper "hello" & fromWithin traverse & rightmost & focus .~ 'y' & leftmost & focus .~ 'j' & rezip +-- "jelly" +rightmost :: (a :> b) -> a :> b +rightmost = farthest rightward + +-- | This allows you to safely 'tug leftward' or 'tug rightward' on a 'zipper'. This +-- will attempt the move, and stay where it was if it fails. +-- -- The more general signature allows its use in other circumstances, however. +-- +-- @'tug' f x ≡ 'fromMaybe' a (f a)@ +-- +-- >>> fmap rezip $ zipper "hello" & within traverse <&> tug leftward <&> focus .~ 'j' +-- "jello" +-- +-- >>> fmap rezip $ zipper "hello" & within traverse <&> tug rightward <&> focus .~ 'u' +-- "hullo" tug :: (a -> Maybe a) -> a -> a tug f a = fromMaybe a (f a) {-# INLINE tug #-} --- | This allows you to safely 'tug left' or 'tug right' on a 'zipper', moving multiple steps in a given direction, --- stopping at the last place you couldn't move from. +-- | This allows you to safely @'tug' 'leftward'@ or @'tug' 'rightward'@ multiple times on a 'zipper', +-- moving multiple steps in a given direction and stopping at the last place you +-- couldn't move from. This lets you safely move a zipper, because it will stop at either end. +-- +-- >>> fmap rezip $ zipper "stale" & within traverse <&> tugs rightward 2 <&> focus .~ 'y' +-- "style" +-- +-- >>> rezip $ zipper "want" & fromWithin traverse & tugs rightward 2 & focus .~ 'r' & tugs leftward 100 & focus .~ 'c' +-- "cart" tugs :: (a -> Maybe a) -> Int -> a -> a tugs f n0 | n0 < 0 = error "tugs: negative tug count" @@ -129,19 +237,33 @@ go n a = maybe a (go (n - 1)) (f a) {-# INLINE tugs #-} --- | Move in a direction as far as you can go, then stop. +-- | Move in a direction as far as you can go, then stop there. +-- +-- This repeatedly applies a function until it returns Nothing, and then returns the last answer. +-- +-- >>> fmap rezip $ zipper ("hello","world") & downward _1 & within traverse <&> rightmost <&> focus .~ 'a' +-- ("hella","world") +-- +-- >>> rezip $ zipper ("hello","there") & fromWithin (both.traverse) & rightmost & focus .~ 'm' +-- ("hello","therm") farthest :: (a -> Maybe a) -> a -> a farthest f = go where go a = maybe a go (f a) {-# INLINE farthest #-} --- | This allows for you to repeatedly pull a 'zipper' in a given direction, failing if it falls of the end. -jerks :: (a -> Maybe a) -> Int -> a -> Maybe a +-- | This allows for you to repeatedly pull a 'zipper' in a given direction, failing if it falls off the end. +-- +-- >>> isNothing $ zipper "hello" & within traverse >>= jerks rightward 10 +-- True +-- +-- >>> fmap rezip $ zipper "silly" & within traverse >>= jerks rightward 3 <&> focus .~ 'k' +-- "silky" +jerks :: Monad m => (a -> m a) -> Int -> a -> m a jerks f n0 - | n0 < 0 = error "jerks: negative jerk count" + | n0 < 0 = fail "jerks: negative jerk count" | otherwise = go n0 where - go 0 a = Just a + go 0 a = return a go n a = f a >>= go (n - 1) {-# INLINE jerks #-} @@ -150,69 +272,117 @@ -- @'teeth' z '>=' 1@ -- -- /NB:/ If the current 'Traversal' targets an infinite number of elements then this may not terminate. -teeth :: (a :> b) -> Int -teeth (Zipper _ w) = levelWidth w +-- +-- >>> zipper ("hello","world") & teeth +-- 1 +-- +-- >>> zipper ("hello","world") & fromWithin both & teeth +-- 2 +-- +-- >>> zipper ("hello","world") & downward _1 & teeth +-- 1 +-- +-- >>> zipper ("hello","world") & downward _1 & fromWithin traverse & teeth +-- 5 +-- +-- >>> zipper ("hello","world") & fromWithin (_1.traverse) & teeth +-- 5 +-- +-- >>> zipper ("hello","world") & fromWithin (both.traverse) & teeth +-- 10 +teeth :: (h :> a) -> Int +teeth (Zipper _ n _ _ rs) = n + 1 + length rs {-# INLINE teeth #-} --- | Move the 'zipper' horizontally to the element in the @n@th position in the current level, absolutely indexed, starting with the @'farthest' 'left'@ as @0@. +-- | Move the 'Zipper' horizontally to the element in the @n@th position in the +-- current level, absolutely indexed, starting with the 'farthest' 'leftward' as @0@. -- -- This returns 'Nothing' if the target element doesn't exist. -- --- @'jerkTo' n ≡ 'jerks' 'right' n . 'farthest' 'left'@ -jerkTo :: Int -> (a :> b) -> Maybe (a :> b) +-- @'jerkTo' n ≡ 'jerks' 'rightward' n . 'farthest' 'leftward'@ +-- +-- >>> isNothing $ zipper "not working." & jerkTo 20 +-- True + +-- >>> isNothing $ zipper "not working." & fromWithin traverse & jerkTo 20 +-- True +-- +-- >>> fmap rezip $ zipper "not working" & within traverse >>= jerkTo 2 <&> focus .~ 'w' +-- Just "now working" +jerkTo :: MonadPlus m => Int -> (h :> a) -> m (h :> a) jerkTo n z = case compare k n of - LT -> jerks left (n - k) z - EQ -> Just z - GT -> jerks right (k - n) z + LT -> jerks rightward (n - k) z + EQ -> return z + GT -> jerks leftward (k - n) z where k = tooth z {-# INLINE jerkTo #-} --- | Move the 'zipper' horizontally to the element in the @n@th position of the current level, absolutely indexed, starting with the @'farthest' 'left'@ as @0@. +-- | Move the 'Zipper' horizontally to the element in the @n@th position of the +-- current level, absolutely indexed, starting with the 'farthest' 'leftward' as @0@. -- -- If the element at that position doesn't exist, then this will clamp to the range @0 <= n < 'teeth'@. -- --- @'tugTo' n ≡ 'tugs' 'right' n . 'farthest' 'left'@ -tugTo :: Int -> (a :> b) -> a :> b +-- @'tugTo' n ≡ 'tugs' 'rightward' n . 'farthest' 'leftward'@ +-- +-- >>> rezip $ zipper "not working." & fromWithin traverse & tugTo 100 & focus .~ '!' & tugTo 1 & focus .~ 'u' +-- "nut working!" +tugTo :: Int -> (h :> a) -> h :> a tugTo n z = case compare k n of - LT -> tugs left (n - k) z + LT -> tugs rightward (n - k) z EQ -> z - GT -> tugs right (k - n) z + GT -> tugs leftward (k - n) z where k = tooth z {-# INLINE tugTo #-} -- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know --- there is precisely one target. +-- there is precisely one target that can never fail. -- -- @ --- 'down' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c --- 'down' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c +-- 'downward' :: 'Simple' 'Lens' s a -> (h :> s) -> h :> s :> a +-- 'downward' :: 'Simple' 'Iso' s a -> (h :> s) -> h :> s :> a -- @ -down :: SimpleLensLike (Context c c) b c -> (a :> b) -> a :> b :> c -down l (Zipper h (Level n ls b rs)) = case l (Context id) b of - Context k c -> Zipper (Snoc h n (cloneLens l) ls (k . extract) rs) (Level 0 [] c []) -{-# INLINE down #-} +downward :: SimpleLensLike (Context a a) s a -> (h :> s) -> h :> s :> a +downward l (Zipper h n ls s rs) = case l (Context id) s of + Context k a -> Zipper (Snoc h (cloneLens l) n ls (k . head) rs) 0 [] a [] +{-# INLINE downward #-} -- | Step down into the 'leftmost' entry of a 'Traversal'. -- -- @ --- 'within' :: 'Simple' 'Traversal' b c -> (a :> b) -> Maybe (a :> b :> c) --- 'within' :: 'Simple' 'Lens' b c -> (a :> b) -> Maybe (a :> b :> c) --- 'within' :: 'Simple' 'Iso' b c -> (a :> b) -> Maybe (a :> b :> c) +-- 'within' :: 'Simple' 'Traversal' s a -> (h :> s) -> Maybe (h :> s :> a) +-- 'within' :: 'Simple' 'Lens' s a -> (h :> s) -> Maybe (h :> s :> a) +-- 'within' :: 'Simple' 'Iso' s a -> (h :> s) -> Maybe (h :> s :> a) -- @ -within :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> Maybe (a :> b :> c) -within l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of - Context _ [] -> Nothing - Context k (c:cs) -> Just (Zipper (Snoc h n l ls (k . NonEmpty.toList) rs) (Level 0 [] c cs)) +within :: MonadPlus m => SimpleLensLike (Bazaar a a) s a -> (h :> s) -> m (h :> s :> a) +within l (Zipper h n ls s rs) = case partsOf' l (Context id) s of + Context _ [] -> mzero + Context k (a:as) -> return (Zipper (Snoc h l n ls k rs) 0 [] a as) {-# INLINE within #-} +-- | Step down into every entry of a 'Traversal' simultaneously. +-- +-- >>> zipper ("hello","world") & withins both >>= leftward >>= withins traverse >>= rightward <&> focus %~ toUpper <&> rezip +-- [("hEllo","world"),("heLlo","world"),("helLo","world"),("hellO","world")] +-- +-- @ +-- 'withins' :: 'Simple' 'Traversal' s a -> (h :> s) -> [h :> s :> a] +-- 'withins' :: 'Simple' 'Lens' s a -> (h :> s) -> [h :> s :> a] +-- 'withins' :: 'Simple' 'Iso' s a -> (h :> s) -> [h :> s :> a] +-- @ +withins :: SimpleLensLike (Bazaar a a) s a -> (h :> s) -> [h :> s :> a] +withins l (Zipper h n ls s rs) = case partsOf' l (Context id) s of + Context k ys -> go k [] ys + where go k xs (y:ys) = Zipper (Snoc h l n ls k rs) 0 xs y ys : go k (y:xs) ys + go _ _ [] = [] + -- | Unsafely step down into a 'Traversal' that is /assumed/ to be non-empty. -- -- If this invariant is not met then this will usually result in an error! -- -- @ --- 'fromWithin' :: 'Simple' 'Traversal' b c -> (a :> b) -> a :> b :> c --- 'fromWithin' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c --- 'fromWithin' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c +-- 'fromWithin' :: 'Simple' 'Traversal' s a -> (h :> s) -> h :> s :> a +-- 'fromWithin' :: 'Simple' 'Lens' s a -> (h :> s) -> h :> s :> a +-- 'fromWithin' :: 'Simple' 'Iso' s a -> (h :> s) -> h :> s :> a -- @ -- -- You can reason about this function as if the definition was: @@ -221,27 +391,32 @@ -- -- but it is lazier in such a way that if this invariant is violated, some code -- can still succeed if it is lazy enough in the use of the focused value. -fromWithin :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> a :> b :> c -fromWithin l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of - Context k cs -> Zipper (Snoc h n l ls (k . NonEmpty.toList) rs) - (Level 0 [] (Prelude.head cs) (Prelude.tail cs)) +fromWithin :: SimpleLensLike (Bazaar a a) s a -> (h :> s) -> h :> s :> a +fromWithin l (Zipper h n ls s rs) = case partsOf' l (Context id) s of + Context k ~(a:as) -> Zipper (Snoc h l n ls k rs) 0 [] a as {-# INLINE fromWithin #-} --- | This enables us to pull the 'zipper' back up to the 'Top'. -class Zipper h a where - recoil :: Coil h a -> NonEmpty a -> Zipped h a +-- | This enables us to pull the 'Zipper' back up to the 'Top'. +class Zipping h a where + recoil :: Coil h a -> [a] -> Zipped h a -instance Zipper Top a where - recoil Coil = extract +instance Zipping Top a where + recoil Coil = head + {-# INLINE recoil #-} -instance Zipper h b => Zipper (h :> b) c where - recoil (Snoc h _ _ ls k rs) as = recoil h (NonEmpty.fromList (Prelude.reverse ls ++ k as : rs)) +instance Zipping h s => Zipping (h :> s) a where + recoil (Snoc h _ _ ls k rs) as = recoil h (reverseList ls ++ k as : rs) + {-# INLINE recoil #-} --- | Close something back up that you opened as a 'zipper'. -rezip :: Zipper h a => (h :> a) -> Zipped h a -rezip (Zipper h w) = recoil h (rezipLevel w) +-- | Close something back up that you opened as a 'Zipper'. +rezip :: Zipping h a => (h :> a) -> Zipped h a +rezip (Zipper h _ ls a rs) = recoil h (reverseList ls ++ a : rs) {-# INLINE rezip #-} +-- | Extract the current 'focus' from a 'Zipper' as a 'Context' +focusedContext :: Zipping h a => (h :> a) -> Context a a (Zipped h a) +focusedContext z = Context (\a -> z & focus .~ a & rezip) (z^.focus) + ----------------------------------------------------------------------------- -- * Tapes ----------------------------------------------------------------------------- @@ -251,34 +426,34 @@ Tape :: Track h a -> {-# UNPACK #-} !Int -> Tape (h :> a) -- | Save the current path as as a 'Tape' we can play back later. -saveTape :: (a :> b) -> Tape (a :> b) -saveTape (Zipper h (Level n _ _ _)) = Tape (peel h) n +saveTape :: (h :> a) -> Tape (h :> a) +saveTape (Zipper h n _ _ _) = Tape (peel h) n {-# INLINE saveTape #-} -- | Restore ourselves to a previously recorded position precisely. -- -- If the position does not exist, then fail. -restoreTape :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a) -restoreTape (Tape h n) = restoreTrack h >=> jerks right n +restoreTape :: MonadPlus m => Tape (h :> a) -> Zipped h a -> m (h :> a) +restoreTape (Tape h n) = restoreTrack h >=> jerks rightward n {-# INLINE restoreTape #-} -- | Restore ourselves to a location near our previously recorded position. -- -- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@, -- so the only failures will occur when one of the sequence of downward traversals find no targets. -restoreNearTape :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a) -restoreNearTape (Tape h n) a = tugs right n <$> restoreNearTrack h a +restoreNearTape :: MonadPlus m => Tape (h :> a) -> Zipped h a -> m (h :> a) +restoreNearTape (Tape h n) a = liftM (tugs rightward n) (restoreNearTrack h a) {-# INLINE restoreNearTape #-} -- | Restore ourselves to a previously recorded position. -- -- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path. -- --- Motions left or right are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. +-- Motions leftward or rightward are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. -- -- Violate these assumptions at your own risk! unsafelyRestoreTape :: Tape (h :> a) -> Zipped h a -> h :> a -unsafelyRestoreTape (Tape h n) = unsafelyRestoreTrack h >>> tugs right n +unsafelyRestoreTape (Tape h n) = unsafelyRestoreTrack h >>> tugs rightward n {-# INLINE unsafelyRestoreTape #-} ----------------------------------------------------------------------------- @@ -288,127 +463,54 @@ -- | This is used to peel off the path information from a 'Coil' for use when saving the current path for later replay. peel :: Coil h a -> Track h a peel Coil = Track -peel (Snoc h n l _ _ _) = Fork (peel h) n l +peel (Snoc h l n _ _ _) = Fork (peel h) n l -- | The 'Track' forms the bulk of a 'Tape'. data Track :: * -> * -> * where Track :: Track Top a - Fork :: Track h b -> {-# UNPACK #-} !Int -> SimpleLensLike (Bazaar a a) b a -> Track (h :> b) a + Fork :: Track h s -> {-# UNPACK #-} !Int -> SimpleLensLike (Bazaar a a) s a -> Track (h :> s) a -- | Restore ourselves to a previously recorded position precisely. -- -- If the position does not exist, then fail. -restoreTrack :: Track h a -> Zipped h a -> Maybe (h :> a) -restoreTrack Track = Just . zipper -restoreTrack (Fork h n l) = restoreTrack h >=> jerks right n >=> within l +restoreTrack :: MonadPlus m => Track h a -> Zipped h a -> m (h :> a) +restoreTrack Track = return . zipper +restoreTrack (Fork h n l) = restoreTrack h >=> jerks rightward n >=> within l -- | Restore ourselves to a location near our previously recorded position. -- --- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@, +-- When moving leftward to rightward through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@, -- so the only failures will occur when one of the sequence of downward traversals find no targets. -restoreNearTrack :: Track h a -> Zipped h a -> Maybe (h :> a) -restoreNearTrack Track = Just . zipper -restoreNearTrack (Fork h n l) = restoreNearTrack h >=> tugs right n >>> within l +restoreNearTrack :: MonadPlus m => Track h a -> Zipped h a -> m (h :> a) +restoreNearTrack Track = return . zipper +restoreNearTrack (Fork h n l) = restoreNearTrack h >=> tugs rightward n >>> within l -- | Restore ourselves to a previously recorded position. -- -- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path. -- --- Motions left or right are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. +-- Motions leftward or rightward are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. -- -- Violate these assumptions at your own risk! unsafelyRestoreTrack :: Track h a -> Zipped h a -> h :> a unsafelyRestoreTrack Track = zipper -unsafelyRestoreTrack (Fork h n l) = unsafelyRestoreTrack h >>> tugs right n >>> fromWithin l +unsafelyRestoreTrack (Fork h n l) = unsafelyRestoreTrack h >>> tugs rightward n >>> fromWithin l ----------------------------------------------------------------------------- --- * Levels +-- * Helper functions ----------------------------------------------------------------------------- --- | A basic non-empty list zipper --- --- All combinators assume the invariant that the length stored matches the number --- of elements in list of items to the left, and the list of items to the left is --- stored reversed. -data Level a = Level {-# UNPACK #-} !Int [a] a [a] - --- | How many entries are there in this level? -levelWidth :: Level a -> Int -levelWidth (Level n _ _ rs) = n + 1 + length rs -{-# INLINE levelWidth #-} - --- | Pull the non-empty list zipper left one entry -leftLevel :: Level a -> Maybe (Level a) -leftLevel (Level _ [] _ _ ) = Nothing -leftLevel (Level n (l:ls) a rs) = Just (Level (n - 1) ls l (a:rs)) -{-# INLINE leftLevel #-} - --- | Pull the non-empty list zipper left one entry, stopping at the first entry. -left1Level :: Level a -> Level a -left1Level z = fromMaybe z (leftLevel z) -{-# INLINE left1Level #-} - --- | Pull the non-empty list zipper all the way to the left. -leftmostLevel :: Level a -> Level a -leftmostLevel (Level _ ls m rs) = case Prelude.reverse ls ++ m : rs of - (c:cs) -> Level 0 [] c cs - _ -> error "the impossible happened" -{-# INLINE leftmostLevel #-} - --- | Pul the non-empty list zipper all the way to the right. --- /NB:/, when given an infinite list this may not terminate. -rightmostLevel :: Level a -> Level a -rightmostLevel (Level _ ls m rs) = go 0 [] (Prelude.head xs) (Prelude.tail xs) where - xs = Prelude.reverse ls ++ m : rs - go n zs y [] = Level n zs y [] - go n zs y (w:ws) = (go $! n + 1) (y:zs) w ws -{-# INLINE rightmostLevel #-} - --- | Pull the non-empty list zipper right one entry. -rightLevel :: Level a -> Maybe (Level a) -rightLevel (Level _ _ _ [] ) = Nothing -rightLevel (Level n ls a (r:rs)) = Just (Level (n + 1) (a:ls) r rs) -{-# INLINE rightLevel #-} - --- | Pull the non-empty list zipper right one entry, stopping at the last entry. -right1Level :: Level a -> Level a -right1Level z = fromMaybe z (rightLevel z) -{-# INLINE right1Level #-} - --- | This is a 'Lens' targeting the value that we would 'extract' from the non-empty list zipper. +-- | Reverse a list. -- --- @'view' 'focusLevel' ≡ 'extract'@ +-- GHC doesn't optimize @reverse []@ into @[]@, so we'll nudge it with our own +-- reverse function. -- --- @'focusLevel' :: 'Simple' 'Lens' ('Level' a) a@ -focusLevel :: Functor f => (a -> f a) -> Level a -> f (Level a) -focusLevel f (Level n ls a rs) = (\b -> Level n ls b rs) <$> f a -{-# INLINE focusLevel #-} - -instance Functor Level where - fmap f (Level n ls a rs) = Level n (f <$> ls) (f a) (f <$> rs) - -instance Foldable Level where - foldMap f (Level _ ls a rs) = foldMapOf (backwards folded) f ls <> f a <> foldMap f rs - -instance Traversable Level where - traverse f (Level n ls a rs) = Level n <$> forwards (traverse (Backwards . f) ls) <*> f a <*> traverse f rs - --- | Zip a non-empty list zipper back up, and return the result. -rezipLevel :: Level a -> NonEmpty a -rezipLevel (Level _ ls a rs) = NonEmpty.fromList (Prelude.reverse ls ++ a : rs) -{-# INLINE rezipLevel #-} - -instance Comonad Level where - extract (Level _ _ a _) = a - extend f w@(Level n ls m rs) = Level n (gol (n - 1) (m:rs) ls) (f w) (gor (n + 1) (m:ls) rs) where - gol k zs (y:ys) = f (Level k ys y zs) : (gol $! k - 1) (y:zs) ys - gol _ _ [] = [] - gor k ys (z:zs) = f (Level k ys z zs) : (gor $! k + 1) (z:ys) zs - gor _ _ [] = [] - -instance ComonadStore Int Level where - pos (Level n _ _ _) = n - peek n (Level m ls a rs) = case compare n m of - LT -> ls Prelude.!! (m - n) - EQ -> a - GT -> rs Prelude.!! (n - m) +-- This is relevant when descending into a lens, for example -- we know the +-- unzipped part of the level will be empty. +reverseList :: [a] -> [a] +reverseList [] = [] +reverseList (x:xs) = go [x] xs + where + go a [] = a + go a (y:ys) = go (y:a) ys +{-# INLINE reverseList #-} 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 @@ -1,5 +1,17 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies #-} +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} +#endif + +#ifndef MIN_VERSION_bytestring +#define MIN_VERSION_bytestring(x,y,z) +#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Iso @@ -14,158 +26,127 @@ ( -- * Isomorphism Lenses Iso - , iso - , isos + , AnIso + -- * Isomorphism Construction + , Isomorphic(..) + , Isoid(..) + -- * Consuming Isomorphisms + , from + , cloneIso -- * Working with isomorphisms - , ala + , au , auf , under , mapping - , review - -- * Primitive isomorphisms - , from - , via - , Isomorphism(..) - , Isomorphic(..) -- ** Common Isomorphisms - , _const - , identity , simple , non + , anon , enum - -- * Storing Isomorphisms - , ReifiedIso(..) + , curried, uncurried + , Strict(..) -- * Simplicity , SimpleIso - , SimpleReifiedIso + -- * Useful Type Families + , CoA, CoB ) where -import Control.Applicative import Control.Category -import Control.Lens.Getter +import Control.Lens.Classes import Control.Lens.Internal -import Control.Lens.Isomorphic -import Control.Lens.Setter import Control.Lens.Type -import Data.Functor.Identity -import Data.Maybe (fromMaybe) +import Data.ByteString as StrictB +import Data.ByteString.Lazy as LazyB +import Data.Text as StrictT +import Data.Text.Lazy as LazyT +import Data.Maybe import Prelude hiding ((.),id) -- $setup -- >>> import Control.Lens -- >>> import Data.Map as Map +-- >>> import Data.Foldable +-- >>> import Data.Monoid ------------------------------------------------------------------------------ --- Isomorphisms families as Lenses +---------------------------------------------------------------------------- +-- Consuming Isomorphisms ----------------------------------------------------------------------------- --- | Isomorphism families can be composed with other lenses using either ('.') and 'id' --- from the Prelude or from Control.Category. However, if you compose them --- with each other using ('.') from the Prelude, they will be dumbed down to a --- mere 'Lens'. +-- | Invert an isomorphism. -- --- @ --- import Control.Category --- import Prelude hiding (('Prelude..'),'Prelude.id') --- @ +-- @'from' ('from' l) ≡ l@ +from :: AnIso s t a b -> Iso b a t s +from Isoid = id +from (Iso sa bt) = iso bt sa +{-# INLINE from #-} + +-- | Convert from an 'Isomorphism' back to any 'Isomorphic' value. -- --- @type 'Iso' s t a b = forall k f. ('Isomorphic' k, 'Functor' f) => 'Overloaded' k f s t a b@ +-- This is useful when you need to store an isomorphism as a data type inside a container +-- and later reconstitute it as an overloaded function. +-- +-- See 'cloneLens' or 'Control.Lens.Traversal.cloneTraversal' for more information on why you might want to do this. +cloneIso :: AnIso s t a b -> Iso s t a b +cloneIso Isoid = id +cloneIso (Iso sa bt) = iso sa bt +{-# INLINE cloneIso #-} + +----------------------------------------------------------------------------- +-- Isomorphisms families as Lenses +----------------------------------------------------------------------------- + +-- | Isomorphism families can be composed with other lenses using ('.') and 'id'. type Iso s t a b = forall k f. (Isomorphic k, Functor f) => k (a -> f b) (s -> f t) +-- | When you see this as an argument to a function, it expects an 'Iso'. +type AnIso s t a b = Overloaded Isoid Mutator s t a b + -- | -- @type 'SimpleIso' = 'Control.Lens.Type.Simple' 'Iso'@ type SimpleIso s a = Iso s s a a - --- | Build an isomorphism family from two pairs of inverse functions --- --- @ --- 'view' ('isos' sa as tb bt) ≡ sa --- 'view' ('from' ('isos' sa as tb bt)) ≡ as --- 'set' ('isos' sa as tb bt) ab ≡ bt '.' ab '.' sa --- 'set' ('from' ('isos' ac ca bd db)) ab ≡ bd '.' ab '.' ca --- @ --- --- @isos :: (s -> a) -> (a -> s) -> (t -> b) -> (b -> t) -> 'Iso' s t a b@ -isos :: (Isomorphic k, Functor f) => (s -> a) -> (a -> s) -> (t -> b) -> (b -> t) -> k (a -> f b) (s -> f t) -isos sa as tb bt = isomorphic - (\afb s -> bt <$> afb (sa s)) - (\sft a -> tb <$> sft (as a)) -{-# INLINE isos #-} - --- | Build a simple isomorphism from a pair of inverse functions --- --- --- @ --- 'view' ('iso' f g) ≡ f --- 'view' ('from' ('iso' f g)) ≡ g --- 'set' ('iso' f g) h ≡ g '.' h '.' f --- 'set' ('from' ('iso' f g)) h ≡ f '.' h '.' g --- @ +-- | Based on 'Control.Lens.Wrapped.ala' from Conor McBride's work on Epigram. -- --- @iso :: (s -> a) -> (a -> s) -> 'Control.Lens.Type.Simple' 'Iso' s a@ -iso :: (Isomorphic k, Functor f) => (s -> a) -> (a -> s) -> k (a -> f a) (s -> f s) -iso sa as = isos sa as sa as -{-# INLINE iso #-} - --- | Based on @ala@ from Conor McBride's work on Epigram. +-- This version is generalized to accept any 'Iso', not just a @newtype@. -- --- >>> :m + Data.Monoid.Lens Data.Foldable --- >>> ala _sum foldMap [1,2,3,4] +-- >>> au (wrapping Sum) foldMap [1,2,3,4] -- 10 -ala :: Simple Iso s a -> ((s -> a) -> e -> a) -> e -> s -ala l f e = f (view l) e ^. from l -{-# INLINE ala #-} +au :: AnIso s t a b -> ((s -> a) -> e -> b) -> e -> t +au Isoid f e = f id e +au (Iso sa bt) f e = bt (f sa e) +{-# INLINE au #-} -- | -- Based on @ala'@ from Conor McBride's work on Epigram. -- +-- This version is generalized to accept any 'Iso', not just a @newtype@. +-- +-- 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 'ala' with an extra function argument. -auf :: Simple Iso s a -> ((b -> a) -> e -> a) -> (b -> s) -> e -> s -auf l f g e = f (view l . g) e ^. from l +-- is 'au' with an extra function argument. +-- +-- >>> auf (wrapping Sum) (foldMapOf both) Prelude.length ("hello","world") +-- 10 +auf :: AnIso s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t +auf Isoid f g e = f g e +auf (Iso sa bt) f g e = bt (f (sa . g) e) {-# INLINE auf #-} -- | The opposite of working 'over' a Setter is working 'under' an Isomorphism. -- --- @'under' = 'over' '.' 'from'@ +-- @'under' ≡ 'over' '.' 'from'@ -- -- @'under' :: 'Iso' s t a b -> (s -> t) -> a -> b@ -under :: Isomorphism (a -> Mutator b) (s -> Mutator t) -> (s -> t) -> a -> b -under = over . from +under :: AnIso s t a b -> (t -> s) -> b -> a +under Isoid ts b = ts b +under (Iso sa bt) ts b = sa (ts (bt b)) {-# INLINE under #-} --- | This can be used to turn an 'Iso' around and 'view' the other way. --- --- @'review' = 'view' '.' 'from'@ -review :: Overloaded Isomorphism (Accessor s) s t a b -> a -> s -review (Isomorphism _ l) = view l -{-# INLINE review #-} - ----------------------------------------------------------------------------- -- Isomorphisms ----------------------------------------------------------------------------- --- | This isomorphism can be used to wrap or unwrap a value in 'Identity'. --- --- @ --- x^.identity ≡ 'Identity' x --- 'Identity' x '^.' 'from' 'identity' ≡ x --- @ -identity :: Iso a b (Identity a) (Identity b) -identity = isos Identity runIdentity Identity runIdentity -{-# INLINE identity #-} - --- | This isomorphism can be used to wrap or unwrap a value in 'Const' --- --- @ --- x '^.' '_const' ≡ 'Const' x --- 'Const' x '^.' 'from' '_const' ≡ x --- @ -_const :: Iso a b (Const a c) (Const b d) -_const = isos Const getConst Const getConst -{-# INLINE _const #-} - -- | This isomorphism can be used to convert to or from an instance of 'Enum'. -- -- >>> LT^.from enum @@ -184,8 +165,9 @@ {-# INLINE enum #-} -- | This can be used to lift any 'SimpleIso' into an arbitrary functor. -mapping :: Functor f => SimpleIso s a -> SimpleIso (f s) (f a) -mapping l = iso (view l <$>) (view (from l) <$>) +mapping :: Functor f => AnIso s t a b -> Iso (f s) (f t) (f a) (f b) +mapping Isoid = id +mapping (Iso sa bt) = iso (fmap sa) (fmap bt) {-# INLINE mapping #-} -- | Composition with this isomorphism is occasionally useful when your 'Lens', @@ -193,7 +175,7 @@ -- argument to force that argument to agree with the -- type of a used argument and avoid @ScopedTypeVariables@ or other ugliness. simple :: Simple Iso a a -simple = isomorphic id id +simple = id {-# INLINE simple #-} -- | If @v@ is an element of a type @a@, and @a'@ is @a@ sans the element @v@, then @non v@ is an isomorphism from @@ -222,23 +204,65 @@ -- >>> Map.empty & at "hello" . non Map.empty . at "world" ?~ "!!!" -- fromList [("hello",fromList [("world","!!!")])] -- --- and when have deleting the last entry from the nested map mean that we +-- and when have deleting the last entry from the nested map mean that we -- should delete its entry from the surrounding one: -- -- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . non Map.empty . at "world" .~ Nothing -- fromList [] - non :: Eq a => a -> Simple Iso (Maybe a) a -non a = iso (fromMaybe a) go where - go b | a == b = Nothing +non a = anon a (a==) +{-# INLINE non #-} + +-- | @'anon' a p@ generalizes @'non' a@ to take any value and a predicate. +-- +-- This function assumes that @p a@ holds @True@ and generates an isomorphism between @'Maybe' (a | not (p a))@ and @a@ +-- +-- >>> Map.empty & at "hello" . anon Map.empty Map.null . at "world" ?~ "!!!" +-- fromList [("hello",fromList [("world","!!!")])] +-- +-- >>> fromList [("hello",fromList [("world","!!!")])] & at "hello" . anon Map.empty Map.null . at "world" .~ Nothing +-- fromList [] +anon :: a -> (a -> Bool) -> Simple Iso (Maybe a) a +anon a p = iso (fromMaybe a) go where + go b | p b = Nothing | otherwise = Just b +{-# INLINE anon #-} ------------------------------------------------------------------------------ --- Reifying Isomorphisms ------------------------------------------------------------------------------ +-- | The canonical isomorphism for currying and uncurrying a function. +-- +-- >>> :t fst^.curried +-- fst^.curried :: a -> b -> a +-- +-- @'curried' = 'iso' 'curry' 'uncurry'@ +curried :: Iso ((a,b) -> c) ((d,e) -> f) (a -> b -> c) (d -> e -> f) +curried = iso curry uncurry +{-# INLINE curried #-} --- | Useful for storing isomorphisms in containers. -newtype ReifiedIso s t a b = ReifyIso { reflectIso :: Iso s t a b } +-- | The canonical isomorphism for uncurrying and currying a function. +-- +-- >>> :t flip (,)^.uncurried +-- flip (,)^.uncurried :: (b, a) -> (a, b) +-- +-- @'uncurried' = 'iso' 'uncurry' 'curry'@ +-- +-- @'uncurried' = 'from' 'curried'@ +uncurried :: Iso (a -> b -> c) (d -> e -> f) ((a,b) -> c) ((d,e) -> f) +uncurried = iso uncurry curry +{-# INLINE uncurried #-} --- | @type 'SimpleReifiedIso' = 'Control.Lens.Type.Simple' 'ReifiedIso'@ -type SimpleReifiedIso s a = ReifiedIso s s a a +-- | Ad hoc conversion between \"strict\" and \"lazy\" versions of a structure, +-- such as 'StrictT.Text' or 'StrictB.ByteString'. +class Strict s t a b | s -> a, a -> s, b -> t, t -> b, s b -> a t, a t -> s b where + strict :: Iso s t a b + +instance Strict LazyB.ByteString LazyB.ByteString StrictB.ByteString StrictB.ByteString where +#if MIN_VERSION_bytestring(0,10,0) + strict = iso LazyB.toStrict LazyB.fromStrict +#else + strict = iso (StrictB.concat . LazyB.toChunks) (LazyB.fromChunks . return) +#endif + {-# INLINE strict #-} + +instance Strict LazyT.Text LazyT.Text StrictT.Text StrictT.Text where + strict = iso LazyT.toStrict LazyT.fromStrict + {-# INLINE strict #-} diff --git a/src/Control/Lens/Isomorphic.hs b/src/Control/Lens/Isomorphic.hs deleted file mode 100644 --- a/src/Control/Lens/Isomorphic.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Lens.Isomorphic --- Copyright : (C) 2012 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : Rank2Types --- ----------------------------------------------------------------------------- -module Control.Lens.Isomorphic - ( Isomorphic(..) - , Isomorphism(..) - , from - , via - ) where - -import Control.Category -import Data.Typeable -import Prelude hiding ((.),id) - ----------------------------------------------------------------------------- --- Isomorphism Implementation Details ------------------------------------------------------------------------------ - --- | Used to provide overloading of isomorphism application --- --- This is a 'Category' with a canonical mapping to it from the --- category of isomorphisms over Haskell types. -class Category k => Isomorphic k where - -- | Build this morphism out of an isomorphism - -- - -- The intention is that by using 'isomorphic', you can supply both halves of an - -- isomorphism, but k can be instantiated to @(->)@, so you can freely use - -- the resulting isomorphism as a function. - isomorphic :: (a -> b) -> (b -> a) -> k a b - - -- | Map a morphism in the target category using an isomorphism between morphisms - -- in Hask. - isomap :: ((a -> b) -> c -> d) -> ((b -> a) -> d -> c) -> k a b -> k c d - -instance Isomorphic (->) where - isomorphic = const - {-# INLINE isomorphic #-} - isomap = const - {-# INLINE isomap #-} - --- | A concrete data type for isomorphisms. --- --- This lets you place an isomorphism inside a container without using @ImpredicativeTypes@. -data Isomorphism a b = Isomorphism (a -> b) (b -> a) - deriving Typeable - -instance Category Isomorphism where - id = Isomorphism id id - {-# INLINE id #-} - Isomorphism bc cb . Isomorphism ab ba = Isomorphism (bc . ab) (ba . cb) - {-# INLINE (.) #-} - -instance Isomorphic Isomorphism where - isomorphic = Isomorphism - {-# INLINE isomorphic #-} - isomap abcd badc (Isomorphism ab ba) = Isomorphism (abcd ab) (badc ba) - {-# INLINE isomap #-} - --- | Invert an isomorphism. --- --- Note to compose an isomorphism and receive an isomorphism in turn you'll need to use --- 'Control.Category.Category' --- --- @'from' ('from' l) ≡ l@ --- --- If you imported 'Control.Category..' from @Control.Category@, then: --- --- @'from' l '.' 'from' r ≡ 'from' (r '.' l)@ -from :: Isomorphic k => Isomorphism a b -> k b a -from (Isomorphism a b) = isomorphic b a -{-# INLINE from #-} - --- | Convert from an 'Isomorphism' back to any 'Isomorphic' value. --- --- This is useful when you need to store an isomoprhism as a data type inside a container --- and later reconstitute it as an overloaded function. -via :: Isomorphic k => Isomorphism a b -> k a b -via (Isomorphism a b) = isomorphic a b -{-# INLINE via #-} diff --git a/src/Control/Lens/Loupe.hs b/src/Control/Lens/Loupe.hs --- a/src/Control/Lens/Loupe.hs +++ b/src/Control/Lens/Loupe.hs @@ -49,7 +49,7 @@ -- A @'Loupe' s t a b@ is almost a 'Lens'. It can be composed on the left of other lenses, -- you can use 'cloneLens' to promote it to a 'Lens', and it provides a minimalist lens-like -- interface. They can be used in an API where you need to pass around lenses inside containers --- or as monadic results. Unlike a 'ReifiedLens' they can be composed and used directly, but +-- or as monadic results. Unlike a 'ReifiedLens' they can be composed and used directly, but -- they are slightly lower performance. -- 1) You get back what you put in: @@ -74,30 +74,45 @@ type SimpleLoupe s a = Loupe s s a a -- | A 'Loupe'-specific version of ('Control.Lens.Getter.^.') +-- +-- >>> ("hello","world")^#_2 +-- "world" (^#) :: s -> Loupe s t a b -> a s ^# l = case l (Context id) s of Context _ a -> a {-# INLINE (^#) #-} -- | A 'Loupe'-specific version of 'Control.Lens.Setter.set' +-- +-- >>> storing _2 "world" ("hello","there") +-- ("hello","world") storing :: Loupe s t a b -> b -> s -> t storing l b s = case l (Context id) s of Context g _ -> g b {-# INLINE storing #-} -- | A 'Loupe'-specific version of ('Control.Lens.Setter..~') +-- +-- >>> ("hello","there") & _2 #~ "world" +-- ("hello","world") (#~) :: Loupe s t a b -> b -> s -> t (#~) l b s = case l (Context id ) s of Context g _ -> g b {-# INLINE (#~) #-} -- | A 'Loupe'-specific version of ('Control.Lens.Setter.%~') +-- +-- >>> ("hello","world") & _2 #%~ length +-- ("hello",5) (#%~) :: Loupe s t a b -> (a -> b) -> s -> t (#%~) l f s = case l (Context id) s of Context g a -> g (f a) {-# INLINE (#%~) #-} -- | A 'Loupe'-specific version of ('Control.Lens.Type.%%~') +-- +-- >>> ("hello","world") & _2 #%%~ \x -> (length x, x ++ "!") +-- (5,("hello","world!")) (#%%~) :: Functor f => Loupe s t a b -> (a -> f b) -> s -> f t (#%%~) l f s = case l (Context id) s of Context g a -> g <$> f a @@ -113,6 +128,9 @@ {-# INLINE (#%=) #-} -- | Modify the target of a 'Loupe' and return the result. +-- +-- >>> ("hello","world") & _2 <#%~ length +-- (5,("hello",5)) (<#%~) :: Loupe s t a b -> (a -> b) -> s -> (b, t) l <#%~ f = \s -> case l (Context id) s of Context g a -> let b = f a in (b, g b) @@ -123,7 +141,7 @@ l <#%= f = l #%%= \a -> let b = f a in (b,b) {-# INLINE (<#%=) #-} --- | Modify the target of a 'Loupe' in the current monadic state, returning an auxillary result. +-- | Modify the target of a 'Loupe' in the current monadic state, returning an auxiliary result. (#%%=) :: MonadState s m => Loupe s s a b -> (a -> (r, b)) -> m r #if MIN_VERSION_mtl(2,1,1) l #%%= f = State.state $ \s -> case l (Context id) s of @@ -137,6 +155,9 @@ #endif -- | Replace the target of a 'Loupe' and return the new value. +-- +-- >>> ("hello","there") & _2 <#~ "world" +-- ("world",("hello","world")) (<#~) :: Loupe s t a b -> b -> s -> (b, t) l <#~ b = \s -> (b, storing l b s) 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 @@ -1,10 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +#ifdef DEFAULT_SIGNATURES +{-# LANGUAGE DefaultSignatures #-} +#endif +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} -- template-haskell +#endif + #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(x,y,z) 1 #endif @@ -29,7 +35,7 @@ -- -- By implementing these combinators in terms of 'plate' instead of 'uniplate' -- additional type safety is gained, as the user is no longer responsible for --- maintaining invariants such as the number of children he received. +-- maintaining invariants such as the number of children they received. -- -- Note: The @Biplate@ is /deliberately/ excluded from the API here, with the -- intention that you replace them with either explicit traversals, or by using the @@ -81,7 +87,9 @@ import Control.Lens.Traversal import Control.Lens.Type import qualified Language.Haskell.TH as TH +#ifdef DEFAULT_SIGNATURES import Data.Data +#endif import Data.Data.Lens import Data.Monoid import Data.Tree @@ -175,10 +183,14 @@ class Plated a where -- | 'Traversal' of the immediate children of this structure. -- - -- The default definition finds no children. + -- If you're using GHC 7.2 or newer and your type has a 'Data' instance, + -- 'plate' will default to 'uniplate' and you can choose to not override + -- it with your own definition. plate :: Simple Traversal a a +#ifdef DEFAULT_SIGNATURES default plate :: Data a => Simple Traversal a a plate = uniplate +#endif instance Plated [a] where plate f (x:xs) = (x:) <$> f xs @@ -187,15 +199,15 @@ instance Plated (Tree a) where plate f (Node a as) = Node a <$> traverse f as -instance Plated TH.Exp -instance Plated TH.Dec -instance Plated TH.Con -instance Plated TH.Type +instance Plated TH.Exp where plate = uniplate +instance Plated TH.Dec where plate = uniplate +instance Plated TH.Con where plate = uniplate +instance Plated TH.Type where plate = uniplate #if !(MIN_VERSION_template_haskell(2,8,0)) -instance Plated TH.Kind -- in 2.8 Kind is an alias for Type +instance Plated TH.Kind where plate = uniplate -- in 2.8 Kind is an alias for Type #endif -instance Plated TH.Stmt -instance Plated TH.Pat +instance Plated TH.Stmt where plate = uniplate +instance Plated TH.Pat where plate = uniplate ------------------------------------------------------------------------------- -- Children diff --git a/src/Control/Lens/Prism.hs b/src/Control/Lens/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Prism.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} +#endif +------------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Prism +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : non-portable +-- +------------------------------------------------------------------------------- +module Control.Lens.Prism + ( + -- * Prisms + Prism + , APrism + -- * Constructing Prisms + , Prismatic(..) + , Prismoid(..) + + -- * Consuming Prisms + , clonePrism + , remit + , review, reviews + , reuse, reuses + , outside + , aside + , without + + -- * Common Prisms + , _left + , _right + , _just + + -- * Simple + , SimplePrism + ) where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Monad.Reader as Reader +import Control.Monad.State as State +import Control.Lens.Classes +import Control.Lens.Combinators +import Control.Lens.Getter +import Control.Lens.Internal +import Control.Lens.Type +import Prelude hiding (id,(.)) + +-- $setup +-- >>> import Control.Lens +-- >>> import Numeric.Natural +-- >>> :set -XFlexibleContexts -XTypeFamilies +-- >>> let nat :: Simple Prism Integer Natural; nat = prism toInteger $ \i -> if i <= 0 then Left i else Right (fromInteger i) +-- >>> let isLeft (Left _) = True; isLeft _ = False +-- >>> let isRight (Right _) = True; isRight _ = False + +------------------------------------------------------------------------------ +-- Prism Internals +------------------------------------------------------------------------------ + +-- | A 'Prism' @l@ is a 0-or-1 target 'Traversal' that can also be turned around with 'remit' to +-- obtain a 'Getter' in the opposite direction, such that in addition to the 'Traversal' laws, we also +-- have +-- +-- @x '^.' 'remit' l '^?' l ≡ 'Just' x@ +-- +-- @'Control.Lens.Fold.lengthOf' l x '<=' 1@ +-- +-- It may help to think of this as a 'Control.Lens.Iso.Iso' that can be partial in one direction. +-- +-- Every 'Prism' is a valid 'Traversal'. +-- +-- Every 'Control.Lens.Iso.Iso' is a valid 'Prism'. +-- +-- For example, you might have a @'Simple' 'Prism' 'Integer' Natural@ allows you to always +-- go from a 'Natural' to an 'Integer', and provide you with tools to check if an 'Integer' is +-- a 'Natural' and/or to edit one if it is. +-- +-- +-- @ +-- 'nat' :: 'Simple' 'Prism' 'Integer' 'Numeric.Natural.Natural' +-- 'nat' = 'prism' 'toInteger' '$' \\ i -> +-- if i '<' 0 +-- then 'Left' i +-- else 'Right' ('fromInteger' i) +-- @ +-- +-- Now we can ask if an 'Integer' is a 'Natural'. +-- +-- >>> 5^?nat +-- Just 5 +-- +-- >>> (-5)^?nat +-- Nothing +-- +-- We can update the ones that are: +-- +-- >>> (-3,4) & both.nat *~ 2 +-- (-3,8) +-- +-- And we can then convert from a 'Natural' to an 'Integer'. +-- +-- >>> 5 ^. remit nat -- :: Natural +-- 5 +-- +-- Similarly we can use a 'Prism' to 'traverse' the left half of an 'Either': +-- +-- >>> Left "hello" & _left %~ length +-- Left 5 +-- +-- or to construct an 'Either': +-- +-- >>> 5^.remit _left +-- Left 5 +-- +-- such that if you query it with the 'Prism', you will get your original input back. +-- +-- >>> 5^.remit _left ^? _left +-- Just 5 +-- +-- Another interesting way to think of a 'Prism' is as the categorical dual of a 'Lens' +-- a /co/-'Lens', so to speak. This is what permits the construction of 'outside'. +type Prism s t a b = forall k f. (Prismatic k, Applicative f) => k (a -> f b) (s -> f t) + +-- | If you see this in a signature for a function, the function is expecting a 'Prism', +-- not some kind of alien invader. +type APrism s t a b = Overloaded Prismoid Mutator s t a b + +-- | A @'Simple' 'Prism'@. +type SimplePrism s a = Prism s s a a + +-- | Clone a 'Prism' so that you can reuse the same monomorphically typed 'Prism' for different purposes. +-- +-- See 'cloneLens' and 'cloneTraversal' for examples of why you might want to do this. +clonePrism :: APrism s t a b -> Prism s t a b +clonePrism Prismoid = id +clonePrism (Prism f g) = prism f g + +------------------------------------------------------------------------------ +-- Prism Combinators +------------------------------------------------------------------------------ + +-- | Use a 'Prism' as a kind of first-class pattern. +-- +-- @'outside' :: 'Prism' s t a b -> 'Lens' (t -> r) (s -> r) (b -> r) (a -> r)@ +outside :: APrism s t a b -> Lens (t -> r) (s -> r) (b -> r) (a -> r) +outside Prismoid f tr = f tr +outside (Prism bt seta) f tr = f (tr.bt) <&> \ar -> either tr ar . seta + +-- | Use a 'Prism' to work over part of a structure. +aside :: APrism s t a b -> Prism (e, s) (e, t) (e, a) (e, b) +aside Prismoid = id +aside (Prism bt seta) = prism (fmap bt) $ \(e,s) -> case seta s of + Left t -> Left (e,t) + Right a -> Right (e,a) + +-- | Given a pair of prisms, project sums. +-- +-- Viewing a 'Prism' as a co-lens, this combinator can be seen to be dual to 'alongside'. +without :: APrism s t a b + -> APrism u v c d + -> Prism (Either s u) (Either t v) (Either a c) (Either b d) +without Prismoid Prismoid = id +without (Prism bt seta) Prismoid = prism (left bt) go where + go (Left s) = either (Left . Left) (Right . Left) (seta s) + go (Right u) = Right (Right u) +without Prismoid (Prism dv uevc) = prism (right dv) go where + go (Left s) = Right (Left s) + go (Right u) = either (Left . Right) (Right . Right) (uevc u) +without (Prism bt seta) (Prism dv uevc) = prism (bt +++ dv) go where + go (Left s) = either (Left . Left) (Right . Left) (seta s) + go (Right u) = either (Left . Right) (Right . Right) (uevc u) + +-- | Turn a 'Prism' or 'Control.Lens.Iso.Iso' around to build a 'Getter'. +-- +-- If you have an 'Control.Lens.Iso.Iso', 'Control.Lens.Iso.from' is a more powerful version of this function +-- that will return an 'Control.Lens.Iso.Iso' instead of a mere 'Getter'. +-- +-- >>> 5 ^.remit _left +-- Left 5 +-- +-- @ +-- 'remit' :: 'Prism' s t a b -> 'Getter' b t +-- 'remit' :: 'Iso' s t a b -> 'Getter' b t +-- @ +remit :: APrism s t a b -> Getter b t +remit Prismoid = id +remit (Prism bt _) = to bt + +-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way. +-- +-- @'review' ≡ 'view' '.' 'remit'@ +-- +-- >>> review _left "mustard" +-- Left "mustard" +-- +-- Usually 'review' is used in the @(->)@ monad with a 'Simple' 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of +-- it as having one of these more restricted type signatures: +-- +-- @ +-- 'review' :: 'Simple' 'Iso' s a -> a -> s +-- 'review' :: 'Simple' 'Prism' s a -> a -> s +-- @ +-- +-- However, when working with a monad transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of +-- these more slightly more liberal type signatures may be beneficial to think of it as having: +-- +-- @ +-- 'review' :: 'MonadReader' a m => 'Simple' 'Iso' s a -> m s +-- 'review' :: 'MonadReader' a m => 'Simple' 'Prism' s a -> m s +-- @ +review :: MonadReader b m => APrism s t a b -> m t +review Prismoid = ask +review (Prism bt _) = asks bt +{-# INLINE review #-} + +-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'view' a value (or the current environment) through it the other way, +-- applying a function. +-- +-- @'reviews' ≡ 'views' '.' 'remit'@ +-- +-- >>> reviews _left isRight "mustard" +-- False +-- +-- Usually this function is used in the @(->)@ monad with a 'Simple' 'Prism' or 'Control.Lens.Iso.Iso', in which case it may be useful to think of +-- it as having one of these more restricted type signatures: +-- +-- @ +-- 'reviews' :: 'Simple' 'Iso' s a -> (s -> r) -> a -> r +-- 'reviews' :: 'Simple' 'Prism' s a -> (s -> r) -> a -> r +-- @ +-- +-- However, when working with a monad transformer stack, it is sometimes useful to be able to 'review' the current environment, in which case one of +-- these more slightly more liberal type signatures may be beneficial to think of it as having: +-- +-- @ +-- 'reviews' :: 'MonadReader' a m => 'Simple' 'Iso' s a -> (s -> r) -> m r +-- 'reviews' :: 'MonadReader' a m => 'Simple' 'Prism' s a -> (s -> r) -> m r +-- @ +reviews :: MonadReader b m => APrism s t a b -> (t -> r) -> m r +reviews Prismoid f = asks f +reviews (Prism bt _) f = asks (f . bt) +{-# INLINE reviews #-} + +-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' a value (or the current environment) through it the other way. +-- +-- @'reuse' ≡ 'use' '.' 'remit'@ +-- +-- >>> evalState (reuse _left) 5 +-- Left 5 +-- +-- @ +-- 'reuse' :: 'MonadState' a m => 'Simple' 'Prism' s a -> m s +-- 'reuse' :: 'MonadState' a m => 'Simple' 'Iso' s a -> m s +-- @ +reuse :: MonadState b m => APrism s t a b -> m t +reuse Prismoid = get +reuse (Prism bt _) = gets bt +{-# INLINE reuse #-} + +-- | This can be used to turn an 'Control.Lens.Iso.Iso' or 'Prism' around and 'use' the current state through it the other way, +-- applying a function. +-- +-- @'reuses' ≡ 'uses' '.' 'remit'@ +-- +-- >>> evalState (reuses _left isLeft) (5 :: Int) +-- True +-- +-- @ +-- 'reuses' :: 'MonadState' a m => 'Simple' 'Prism' s a -> (s -> r) -> m r +-- 'reuses' :: 'MonadState' a m => 'Simple' 'Iso' s a -> (s -> r) -> m r +-- @ +reuses :: MonadState b m => APrism s t a b -> (t -> r) -> m r +reuses Prismoid f = gets f +reuses (Prism bt _) f = gets (f . bt) +{-# INLINE reuses #-} + +------------------------------------------------------------------------------ +-- Common Prisms +------------------------------------------------------------------------------ + +-- | This prism provides a traversal for tweaking the left-hand value of an 'Either': +-- +-- >>> over _left (+1) (Left 2) +-- Left 3 +-- +-- >>> over _left (+1) (Right 2) +-- Right 2 +-- +-- >>> Right 42 ^._left :: String +-- "" +-- +-- >>> Left "hello" ^._left +-- "hello" +-- +-- It also can be turned around to obtain the embedding into the 'Left' half of an 'Either': +-- +-- >>> 5^.remit _left +-- Left 5 +_left :: Prism (Either a c) (Either b c) a b +_left = prism Left $ either Right (Left . Right) +{-# INLINE _left #-} + +-- | This prism provides a traversal for tweaking the right-hand value of an 'Either': +-- +-- >>> over _right (+1) (Left 2) +-- Left 2 +-- +-- >>> over _right (+1) (Right 2) +-- Right 3 +-- +-- >>> Right "hello" ^._right +-- "hello" +-- +-- >>> Left "hello" ^._right :: [Double] +-- [] +-- +-- It also can be turned around to obtain the embedding into the 'Right' half of an 'Either': +-- +-- >>> 5^.remit _right +-- Right 5 +-- +-- (Unfortunately the instance for +-- @'Data.Traversable.Traversable' ('Either' c)@ is still missing from base, +-- so this can't just be 'Data.Traversable.traverse'.) +_right :: Prism (Either c a) (Either c b) a b +_right = prism Right $ left Left +{-# INLINE _right #-} + +-- | This prism provides a traversal for tweaking the target of the value of 'Just' in a 'Maybe'. +-- +-- >>> over _just (+1) (Just 2) +-- Just 3 +-- +-- Unlike 'traverse' this is a 'Prism', and so you can use it to inject as well: +-- +-- >>> 5^.remit _just +-- Just 5 +_just :: Prism (Maybe a) (Maybe b) a b +_just = prism Just $ maybe (Left Nothing) Right diff --git a/src/Control/Lens/Projection.hs b/src/Control/Lens/Projection.hs deleted file mode 100644 --- a/src/Control/Lens/Projection.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -------------------------------------------------------------------------------- --- | --- Module : Control.Lens.Projection --- Copyright : (C) 2012 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : non-portable --- -------------------------------------------------------------------------------- -module Control.Lens.Projection - ( Projection - , Projective(..) - , project - , by - , Project(..) - , projection - , stereo - , mirror - -- * Simple - , SimpleProjection - ) where - -import Control.Applicative -import Control.Lens.Type -import Control.Lens.Getter -import Data.Functor.Identity -import Control.Lens.Iso - --- | A 'Projection' is a 'Traversal' that can also be turned around with 'by' to obtain a 'Getter' -type Projection s t a b = forall k f. (Projective k s b, Applicative f) => k (a -> f b) (s -> f s) - --- | Used to provide overloading of projections. -class Projective k a d where - projective :: (d -> a) -> (x -> y) -> k x y - -instance Projective (->) a d where - projective _ x = x - --- | A concrete 'Projection', suitable for storing in a container or extracting an embedding. -data Project s b x y = Project (b -> s) (x -> y) - --- | Compose projections. -stereo :: Projective k s a => Project t a y z -> Project s t x y -> k x z -stereo (Project g f) (Project i h) = projective (i.g) (f.h) - -instance (s ~ s', b ~ b') => Projective (Project s b) s' b' where - projective = Project - --- | Reflect a 'Projection'. -project :: Projective k s b => Overloaded (Project s b) f s s a b -> Overloaded k f s s a b -project (Project f g) = projective f g - --- | Turn a 'Projection' around to get an embedding -by :: Project s b (b -> Identity b) (s -> Identity s) -> Getter b s -by (Project g _) = to g - --- | Build a 'Projection' -projection :: (b -> s) -> (s -> Maybe a) -> Projection s t a b -projection bs sma = projective bs (\afb a -> maybe (pure a) (fmap bs . afb) (sma a)) - --- | Convert an 'Iso' to a 'Projection'. --- --- Ideally we would be able to use an 'Iso' directly as a 'Projection', but this opens a can of worms. -mirror :: Projective k s a => Simple Iso s a -> Simple Projection s a -mirror l = projection (^.from l) (\a -> Just (a^.l)) - --- | @type 'SimpleProjection' = 'Simple' 'Projection'@ -type SimpleProjection s a = Projection s s a a diff --git a/src/Control/Lens/Representable.hs b/src/Control/Lens/Representable.hs --- a/src/Control/Lens/Representable.hs +++ b/src/Control/Lens/Representable.hs @@ -88,15 +88,14 @@ import Control.Applicative import Control.Lens.Classes import Control.Lens.Getter -import Control.Lens.Indexed import Control.Lens.IndexedFold import Control.Lens.IndexedLens import Control.Lens.IndexedSetter import Control.Lens.IndexedTraversal import Control.Lens.Internal import Control.Lens.Internal.Combinators -import Control.Lens.Iso import Control.Lens.Type +import Control.Lens.Wrapped import Data.Foldable as Foldable import Data.Functor.Identity import Data.Monoid @@ -124,7 +123,7 @@ rep :: (Rep f -> a) -> f a instance Representable Identity where - rep f = Identity (f (from identity)) + rep f = Identity (f (unwrapping Identity)) -- | NB: The 'Eq' requirement on this instance is a consequence of the choice of 'Lens' as a 'Rep', it isn't fundamental. instance Eq e => Representable ((->) e) where @@ -232,7 +231,7 @@ -- | A version of 'rep' that is an isomorphism. Predicativity requires that -- we wrap the 'Rep' as a 'Key', however. tabulated :: Representable f => (Path f -> a) -> f a -tabulated = isomorphic (\f -> rep (f . Path)) (\fa path -> view (walk path) fa) +tabulated f = rep (f . Path) {-# INLINE tabulated #-} ----------------------------------------------------------------------------- @@ -303,15 +302,15 @@ -- | An 'IndexedSetter' that walks an 'Representable' 'Functor' using a 'Path' for an index. rmapped :: Representable f => IndexedSetter (Path f) (f a) (f b) a b -rmapped = index $ \f -> tainted# (rmap (\i -> untainted# (f (Path i)))) +rmapped = indexed $ \f -> tainted# (rmap (\i -> untainted# (f (Path i)))) {-# INLINE rmapped #-} -- | An 'IndexedFold' that walks an 'Foldable' 'Representable' 'Functor' using a 'Path' for an index. rfolded :: (Representable f, Foldable f) => IndexedFold (Path f) (f a) a -rfolded = index $ \f -> coerce . getFolding . rfoldMap (\i -> folding# (f (Path i))) +rfolded = indexed $ \f -> coerce . getFolding . rfoldMap (\i -> folding# (f (Path i))) {-# INLINE rfolded #-} -- | An 'IndexedTraversal' for a 'Traversable' 'Representable' 'Functor'. rtraversed :: (Representable f, Traversable f) => IndexedTraversal (Path f) (f a) (f b) a b -rtraversed = index $ \ f -> sequenceA . rmap (f . Path) +rtraversed = indexed $ \ f -> sequenceA . rmap (f . Path) {-# INLINE rtraversed #-} 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 @@ -36,12 +36,14 @@ , mapOf , set , (.~), (%~) - , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (&&~), (<.~), (?~), (~), (&&~), (<.~), (?~), (=), (&&=), (<.=), (?=), (>> import Control.Lens +-- >>> import Control.Monad.State +-- >>> import Data.Map as Map +-- >>> import Debug.SimpleReflect.Expr as Expr +-- >>> import Debug.SimpleReflect.Vars as Vars +-- >>> let f :: Expr -> Expr; f = Vars.f +-- >>> let g :: Expr -> Expr; g = Vars.g +-- >>> let h :: Expr -> Expr -> Expr; h = Vars.h +-- >>> let getter :: Expr -> Expr; getter = fun "getter" +-- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" -infixr 4 .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, ||~, %~, <.~, ?~, >> instance Monoid Expr where mappend = Expr.op InfixR 6 "<>"; mempty = var "mempty" + +infixr 4 .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, <>~, ||~, %~, <.~, ?~, =, ||=, %=, <.=, ?=, >> over traverse f [a,b,c,d] +-- [f a,f b,f c,f d] +-- +-- >>> over _1 f (a,b) +-- (f a,b) +-- +-- >>> over (traverse._1) f [(a,b),(c,d)] +-- [(f a,b),(f c,d)] +-- +-- >>> over both f (a,b) +-- (f a,f b) +-- +-- >>> over (traverse.both) f [(a,b),(c,d)] +-- [(f a,f b),(f c,f d)] type Setter s t a b = forall f. Settable f => (a -> f b) -> s -> f t -- | @@ -137,14 +170,17 @@ -- ('<$') ≡ 'set' 'mapped' -- @ -- +-- >>> over mapped f [a,b,c] +-- [f a,f b,f c] +-- -- >>> over mapped (+1) [1,2,3] -- [2,3,4] -- --- >>> set mapped () [1,2,3] --- [(),(),()] +-- >>> set mapped x [a,b,c] +-- [x,x,x] -- --- >>> mapped.mapped %~ (+1) $ [[1,2],[3]] --- [[2,3],[4]] +-- >>> [[a,b],[c]] & mapped.mapped +~ x +-- [[a + x,b + x],[c + x]] -- -- >>> over (mapped._2) length [("hello","world"),("leaders","!!!")] -- [("hello",5),("leaders",3)] @@ -161,8 +197,11 @@ -- 'liftM' ≡ 'over' 'lifted' -- @ -- --- >>> over lifted (+1) [1,2,3] --- [2,3,4] +-- >>> over lifted f [a,b,c] +-- [f a,f b,f c] +-- +-- >>> set lifted b (Just a) +-- Just b lifted :: Monad m => Setter (m a) (m b) a b lifted = sets liftM {-# INLINE lifted #-} @@ -203,49 +242,40 @@ -- 'over' '.' 'sets' ≡ 'id' -- @ -- +-- Given any valid 'Setter' @l@, you can also rely on the law: +-- +-- @'over' l f . 'over' l g = 'over' l (f . g)@ +-- +-- /e.g./ +-- +-- >>> over mapped f (over mapped g [a,b,c]) == over mapped (f . g) [a,b,c] +-- True +-- +-- Another way to view 'over' is to say that it transforms a 'Setter' into a +-- \"semantic editor combinator\". +-- +-- >>> over mapped f (Just a) +-- Just (f a) +-- -- >>> over mapped (*10) [1,2,3] -- [10,20,30] -- +-- >>> over _1 f (a,b) +-- (f a,b) +-- -- >>> over _1 show (10,20) -- ("10",20) -- --- Another way to view 'over' is to say that it transformers a 'Setter' into a --- \"semantic editor combinator\". --- -- @'over' :: 'Setter' s t a b -> (a -> b) -> s -> t@ over :: Setting s t a b -> (a -> b) -> s -> t over l f = runMutator# (l (mutator# f)) {-# INLINE over #-} --- | Modify the target of a 'Control.Lens.Type.Lens' or all the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' --- with a function. This is an alias for 'over' that is provided for consistency. --- --- @ --- 'mapOf' ≡ 'over' --- 'fmap' ≡ 'mapOf' 'mapped' --- 'fmapDefault' ≡ 'mapOf' 'traverse' --- 'sets' '.' 'mapOf' ≡ 'id' --- 'mapOf' '.' 'sets' ≡ 'id' --- @ --- --- >>> mapOf mapped (+1) [1,2,3,4] --- [2,3,4,5] --- --- >>> mapOf _1 (+1) (1,2) --- (2,2) --- --- >>> mapOf both (+1) (1,2) --- (2,3) --- --- @ --- 'mapOf' :: 'Setter' s t a b -> (a -> b) -> s -> t --- 'mapOf' :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> t --- 'mapOf' :: 'Control.Lens.Type.Lens' s t a b -> (a -> b) -> s -> t --- 'mapOf' :: 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> t --- @ +-- | 'mapOf' is a deprecated alias for 'over'. mapOf :: Setting s t a b -> (a -> b) -> s -> t mapOf = over {-# INLINE mapOf #-} +{-# DEPRECATED mapOf "Use `over`" #-} -- | Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' -- or 'Control.Lens.Traversal.Traversal' with a constant value. @@ -271,6 +301,34 @@ set l b = runMutator# (l (\_ -> Mutator b)) {-# INLINE set #-} +-- | +-- Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Control.Lens.Type.Simple' 'Setter' +-- or 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' with a constant value, without changing its type. +-- +-- This is a type restricted version of 'set', which retains the type of the original. +-- +-- >>> set' mapped x [a,b,c,d] +-- [x,x,x,x] +-- +-- >>> set' _2 "hello" (1,"world") +-- (1,"hello") +-- +-- >>> set' mapped 0 [1,2,3,4] +-- [0,0,0,0] +-- +-- Note: Attempting to adjust 'set'' a 'Fold' or 'Getter' will fail at compile time with an +-- relatively nice error message. +-- +-- @ +-- 'set'' :: 'Control.Lens.Type.Simple' 'Setter' s a -> a -> s -> s +-- 'set'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> s +-- 'set'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> a -> s -> s +-- 'set'' :: 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> a -> s -> s +-- @ +set' :: Setting s s a a -> a -> s -> s +set' l b = runMutator# (l (\_ -> Mutator b)) +{-# INLINE set' #-} + -- | Modifies the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or -- 'Control.Lens.Traversal.Traversal' with a user supplied function. -- @@ -281,14 +339,20 @@ -- 'Data.Traversable.fmapDefault' f ≡ 'traverse' '%~' f -- @ -- +-- >>> (a,b,c) & _3 %~ f +-- (a,b,f c) +-- +-- >>> (a,b) & both %~ f +-- (f a,f b) +-- -- >>> _2 %~ length $ (1,"hello") -- (1,5) -- --- >>> traverse %~ (+1) $ [1,2,3] --- [2,3,4] +-- >>> traverse %~ f $ [a,b,c] +-- [f a,f b,f c] -- --- >>> _2 %~ (+1) $ (3,4) --- (3,5) +-- >>> traverse %~ even $ [1,2,3] +-- [False,True,False] -- -- >>> traverse.traverse %~ length $ [["hello","world"],["!!!"]] -- [[5,5],[3]] @@ -310,9 +374,15 @@ -- -- @f '<$' a ≡ 'mapped' '.~' f '$' a@ -- --- >>> _1 .~ "hello" $ (42,"world") +-- >>> (a,b,c,d) & _4 .~ e +-- (a,b,c,e) +-- +-- >>> (42,"world") & _1 .~ "hello" -- ("hello","world") -- +-- >>> (a,b) & both .~ c +-- (c,c) +-- -- @ -- ('.~') :: 'Setter' s t a b -> b -> s -> t -- ('.~') :: 'Control.Lens.Iso.Iso' s t a b -> b -> s -> t @@ -327,6 +397,12 @@ -- -- @l '?~' t ≡ 'set' l ('Just' t)@ -- +-- >>> Nothing & id ?~ a +-- Just a +-- +-- >>> Map.empty & at 3 ?~ x +-- fromList [(3,x)] +-- -- @ -- ('?~') :: 'Setter' s t a ('Maybe' b) -> b -> s -> t -- ('?~') :: 'Control.Lens.Iso.Iso' s t a ('Maybe' b) -> b -> s -> t @@ -343,11 +419,13 @@ -- -- If you do not need a copy of the intermediate result, then using @l '.~' t@ directly is a good idea. -- --- >>> _3 <.~ "world" $ ("good","morning","vietnam") +-- >>> (a,b) & _1 <.~ c +-- (c,(c,b)) +-- +-- >>> ("good","morning","vietnam") & _3 <.~ "world" -- ("world",("good","morning","world")) -- --- >>> import Data.Map as Map --- >>> _2.at "hello" <.~ Just "world" $ (42,Map.fromList [("goodnight","gracie")]) +-- >>> (42,Map.fromList [("goodnight","gracie")]) & _2.at "hello" <.~ Just "world" -- (Just "world",(42,fromList [("goodnight","gracie"),("hello","world")])) -- -- @ @@ -382,12 +460,18 @@ -- | Increment the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' -- --- >>> _1 +~ 1 $ (1,2) --- (2,2) +-- >>> (a,b) & _1 +~ c +-- (a + c,b) -- --- >>> both +~ 2 $ (5,6) --- (7,8) +-- >>> (a,b) & both +~ c +-- (a + c,b + c) -- +-- >>> (1,2) & _2 +~ 1 +-- (1,3) +-- +-- >>> [(a,b),(c,d)] & traverse.both +~ e +-- [(a + e,b + e),(c + e,d + e)] +-- -- @ -- ('+~') :: Num a => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> s -> s -- ('+~') :: Num a => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> s -> s @@ -400,10 +484,16 @@ -- | Multiply the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' -- --- >>> _2 *~ 4 $ (1,2) +-- >>> (a,b) & _1 *~ c +-- (a * c,b) +-- +-- >>> (a,b) & both *~ c +-- (a * c,b * c) +-- +-- >>> (1,2) & _2 *~ 4 -- (1,8) -- --- >>> mapped *~ 2 $ Just 24 +-- >>> Just 24 & mapped *~ 2 -- Just 48 -- -- @ @@ -418,6 +508,12 @@ -- | Decrement the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' -- +-- >>> (a,b) & _1 -~ c +-- (a - c,b) +-- +-- >>> (a,b) & both -~ c +-- (a - c,b - c) +-- -- >>> _1 -~ 2 $ (1,2) -- (-1,2) -- @@ -436,7 +532,13 @@ -- | Divide the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' -- --- >>> _2 //~ 2 $ ("Hawaii",10) +-- >>> (a,b) & _1 //~ c +-- (a / c,b) +-- +-- >>> (a,b) & both //~ c +-- (a / c,b / c) +-- +-- >>> ("Hawaii",10) & _2 //~ 2 -- ("Hawaii",5.0) -- -- @ @@ -450,7 +552,7 @@ -- | Raise the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to a non-negative integral power -- --- >>> _2 ^~ 2 $ (1,3) +-- >>> (1,3) & _2 ^~ 2 -- (1,9) -- -- @ @@ -465,7 +567,7 @@ -- | Raise the target(s) of a fractionally valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an integral power -- --- >>> _2 ^^~ (-1) $ (1,2) +-- >>> (1,2) & _2 ^^~ (-1) -- (1,0.5) -- -- @ @@ -481,6 +583,12 @@ -- | Raise the target(s) of a floating-point valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an arbitrary power. -- +-- >>> (a,b) & _1 **~ c +-- (a**c,b) +-- +-- >>> (a,b) & both **~ c +-- (a**c,b**c) +-- -- >>> _2 **~ pi $ (1,3) -- (1,31.54428070019754) -- @@ -539,6 +647,12 @@ -- -- This is an alias for ('.='). -- +-- >>> execState (do assign _1 c; assign _2 d) (a,b) +-- (c,d) +-- +-- >>> execState (both .= c) (a,b) +-- (c,c) +-- -- @ -- 'assign' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () -- 'assign' :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> a -> m () @@ -554,6 +668,12 @@ -- -- This is an infix version of 'assign'. -- +-- >>> execState (do _1 .= c; _2 .= d) (a,b) +-- (c,d) +-- +-- >>> execState (both .= c) (a,b) +-- (c,c) +-- -- @ -- ('.=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () -- ('.=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> a -> m () @@ -568,6 +688,12 @@ -- | Map over the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' in our monadic state. -- +-- >>> execState (do _1 %= f;_2 %= g) (a,b) +-- (f a,g b) +-- +-- >>> execState (do both %= f) (a,b) +-- (f a,f b) +-- -- @ -- ('%=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m () -- ('%=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s a -> (a -> a) -> m () @@ -581,6 +707,12 @@ -- | Replace the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' in our monadic -- state with 'Just' a new value, irrespective of the old. -- +-- >>> execState (do at 1 ?= a; at 2 ?= b) Map.empty +-- fromList [(1,a),(2,b)] +-- +-- >>> execState (do _1 ?= b; _2 ?= c) (Just a, Nothing) +-- (Just b,Just c) +-- -- @ -- ('?=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s ('Maybe' a) -> a -> m () -- ('?=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' s ('Maybe' a) -> a -> m () @@ -602,6 +734,12 @@ -- 'use' 'id' -- @ -- +-- >>> execState (do _1 += c; _2 += d) (a,b) +-- (a + c,b + d) +-- +-- >>> execState (do _1.at 1.non 0 += 10) (Map.fromList [(2,100)],"hello") +-- (fromList [(1,10),(2,100)],"hello") +-- -- @ -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('+=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () @@ -614,6 +752,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by subtracting a value -- +-- >>> execState (do _1 -= c; _2 -= d) (a,b) +-- (a - c,b - d) +-- -- @ -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('-=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () @@ -626,6 +767,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by multiplying by value. -- +-- >>> execState (do _1 *= c; _2 *= d) (a,b) +-- (a * c,b * d) +-- -- @ -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('*=') :: ('MonadState' s m, 'Num' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () @@ -638,6 +782,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by dividing by a value. -- +-- >>> execState (do _1 //= c; _2 //= d) (a,b) +-- (a / c,b / d) +-- -- @ -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('//=') :: ('MonadState' s m, 'Fractional' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () @@ -674,6 +821,9 @@ -- | Raise the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an arbitrary power -- +-- >>> execState (do _1 **= c; _2 **= d) (a,b) +-- (a**c,b**d) +-- -- @ -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () -- ('**=') :: ('MonadState' s m, 'Floating' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s a -> a -> m () @@ -686,6 +836,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' by taking their logical '&&' with a value -- +-- >>> execState (do _1 &&= True; _2 &&= False; _3 &&= True; _4 &&= False) (True,True,False,False) +-- (True,False,False,False) +-- -- @ -- ('&&=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Setter' s 'Bool' -> 'Bool' -> m () -- ('&&=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> 'Bool' -> m () @@ -698,6 +851,9 @@ -- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens', 'Iso, 'Setter' or 'Control.Lens.Traversal.Traversal' by taking their logical '||' with a value -- +-- >>> execState (do _1 ||= True; _2 ||= False; _3 ||= True; _4 ||= False) (True,True,False,False) +-- (True,True,True,False) +-- -- @ -- ('||=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Setter' s 'Bool' -> 'Bool' -> m () -- ('||=') :: 'MonadState' s m => 'Control.Lens.Type.Simple' 'Control.Lens.Iso.Iso' s 'Bool' -> 'Bool' -> m () @@ -776,6 +932,45 @@ l ?= b return b {-# INLINE (>> (Sum a,b) & _1 <>~ Sum c +-- (Sum {getSum = a + c},b) +-- +-- >>> (Sum a,Sum b) & both <>~ Sum c +-- (Sum {getSum = a + c},Sum {getSum = b + c}) +-- +-- >>> both <>~ "!!!" $ ("hello","world") +-- ("hello!!!","world!!!") +-- +-- @ +-- ('<>~') :: 'Monoid' a => 'Setter' s t a a -> a -> s -> t +-- ('<>~') :: 'Monoid' a => 'Iso' s t a a -> a -> s -> t +-- ('<>~') :: 'Monoid' a => 'Lens' s t a a -> a -> s -> t +-- ('<>~') :: 'Monoid' a => 'Traversal' s t a a -> a -> s -> t +-- @ +(<>~) :: Monoid a => Setting s t a a -> a -> s -> t +l <>~ n = over l (`mappend` n) +{-# INLINE (<>~) #-} + +-- | Modify the target(s) of a 'Control.Lens.Type.Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value. +-- +-- >>> execState (do _1 <>= Sum c; _2 <>= Product d) (Sum a,Product b) +-- (Sum {getSum = a + c},Product {getProduct = b * d}) +-- +-- >>> execState (both <>= "!!!") ("hello","world") +-- ("hello!!!","world!!!") +-- +-- @ +-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Setter' s a -> a -> m () +-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Iso' s a -> a -> m () +-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Lens' s a -> a -> m () +-- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Control.Lens.Type.Simple' 'Traversal' s a -> a -> m () +-- @ +(<>=) :: (MonadState s m, Monoid a) => SimpleSetting s a -> a -> m () +l <>= a = State.modify (l <>~ a) +{-# INLINE (<>=) #-} -- | Reify a setter so it can be stored safely in a container. newtype ReifiedSetter s t a b = ReifySetter { reflectSetter :: Setter s t a b } diff --git a/src/Control/Lens/Simple.hs b/src/Control/Lens/Simple.hs --- a/src/Control/Lens/Simple.hs +++ b/src/Control/Lens/Simple.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif @@ -50,15 +50,18 @@ ) where import Control.Applicative +#if !(MIN_VERSION_template_haskell(2,7,0)) +import Control.Monad (ap) +#endif +import Control.Lens.Combinators import Control.Lens.Fold import Control.Lens.Getter +import Control.Lens.IndexedLens import Control.Lens.Iso import Control.Lens.Setter import Control.Lens.Tuple import Control.Lens.Traversal import Control.Lens.Type -import Control.Lens.IndexedLens -import Control.Monad import Data.Char (toLower) import Data.Either (lefts) import Data.Foldable hiding (concat) @@ -153,24 +156,24 @@ -- -- Defaults to lowercasing the first letter of the constructor. lensIso :: Simple Lens LensRules (String -> Maybe String) -lensIso f (LensRules i n c o) = (\i' -> LensRules i' n c o) <$> f i +lensIso f (LensRules i n c o) = f i <&> \i' -> LensRules i' n c o -- | Lens to access the convention for naming fields in our lens rules. -- -- Defaults to stripping the _ off of the field name, lowercasing the name, and -- rejecting the field if it doesn't start with an '_'. lensField :: Simple Lens LensRules (String -> Maybe String) -lensField f (LensRules i n c o) = (\n' -> LensRules i n' c o) <$> f n +lensField f (LensRules i n c o) = f n <&> \n' -> LensRules i n' c o -- | Retrieve options such as the name of the class and method to put in it to -- build a class around monomorphic data types. lensClass :: Simple Lens LensRules (String -> Maybe (String, String)) -lensClass f (LensRules i n c o) = (\c' -> LensRules i n c' o) <$> f c +lensClass f (LensRules i n c o) = f c <&> \c' -> LensRules i n c' o -- | Retrieve options such as the name of the class and method to put in it to -- build a class around monomorphic data types. lensFlags :: Simple Lens LensRules (Set LensFlag) -lensFlags f (LensRules i n c o) = LensRules i n c <$> f o +lensFlags f (LensRules i n c o) = f o <&> LensRules i n c -- | Default lens rules defaultRules :: LensRules @@ -312,35 +315,30 @@ freshMap ns = Map.fromList <$> for (toList ns) (\ n -> (,) n <$> newName (nameBase n)) makeIsoTo :: Name -> ExpQ -makeIsoTo conName = do - f <- newName "f" - a <- newName "a" - lamE [varP f, conP conName [varP a]] $ - appsE [ return (VarE 'fmap) - , conE conName - , varE f `appE` varE a - ] +makeIsoTo = conE makeIsoFrom :: Name -> ExpQ makeIsoFrom conName = do - f <- newName "f" - a <- newName "a" b <- newName "b" - lamE [varP f, varP a] $ - appsE [ return (VarE 'fmap) - , lamE [conP conName [varP b]] $ varE b - , varE f `appE` (conE conName `appE` varE a) - ] + lamE [conP conName [varP b]] $ varE b makeIsoBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ makeIsoBody lensName conName f g = funD lensName [clause [] (normalB body) []] where - body = appsE [ return (VarE 'isomorphic) - , f conName + body = appsE [ varE 'iso , g conName + , f conName ] makeLensBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ -makeLensBody lensName conName f _ = funD lensName [clause [] (normalB (f conName)) []] +makeLensBody lensName conName i o = do + f <- newName "f" + a <- newName "a" + funD lensName [clause [] (normalB ( + lamE [varP f, varP a] $ + appsE [ varE 'fmap + , o conName + , varE f `appE` (i conName `appE` varE a) + ])) []] plain :: TyVarBndr -> TyVarBndr plain (KindedTV t _) = PlainTV t @@ -356,21 +354,6 @@ appsT :: TypeQ -> [TypeQ] -> TypeQ appsT = Prelude.foldl appT --- | Given --- --- > newtype Cxt b => Foo a b c d = Foo { _baz :: Bar a b } --- --- This will generate: --- --- > foo :: (Cxt b, Cxt f) => Iso (Foo a b c d) (Foo e f g h) (Bar a b) (Bar e f) --- > foo = isomorphic (\f a -> (\(Foo b) -> b) <$> f (Foo a)) --- > (\f (Foo a) -> fmap Foo (f a)) --- > {-# INLINE foo #-} - --- > baz :: (Cxt b, Cxt f) => Iso (Bar a b) (Bar e f) (Foo a b c d) (Foo e f g h) --- > baz = isomorphic (\f (Foo a) -> fmap Foo (f a)) --- > (\f a -> fmap (\(Foo b) -> b) (f (Foo a))) --- > {-# INLINE baz #-} makeIsoLenses :: LensRules -> Cxt -> Name @@ -462,13 +445,11 @@ -> Q [Dec] makeFieldLenses cfg ctx tyConName tyArgs0 cons = do let tyArgs = map plain tyArgs0 - maybeLensClass = do - guard $ tyArgs == [] - view lensClass cfg $ nameBase tyConName + maybeLensClass = view lensClass cfg $ nameBase tyConName maybeClassName = fmap (^._1.to mkName) maybeLensClass t <- newName "t" a <- newName "a" - + --TODO: there's probably a more efficient way to do this. lensFields <- map (\xs -> (fst $ head xs, map snd xs)) . groupBy ((==) `on` fst) . sortBy (comparing fst) @@ -496,12 +477,15 @@ relevantBndr b = s^.contains (b^.name) relevantCtx = not . Set.null . Set.intersection s . setOf typeVars tvs = tyArgs' ++ filter relevantBndr (substTypeVars m tyArgs') - ps = ctx ++ filter relevantCtx (substTypeVars m ctx) + ps = filter relevantCtx (substTypeVars m ctx) qs = case maybeClassName of - Just n | not (cfg^.createClass) -> ClassP n [VarT t] : ps - _ -> ps - tvs' | isJust maybeClassName && not (cfg^.createClass) = PlainTV t : tvs - | otherwise = tvs + Just n | not (cfg^.createClass) -> ClassP n [VarT t] : (ctx ++ ps) + | otherwise -> ps + _ -> ctx ++ ps + tvs' = case maybeClassName of + Just _ | not (cfg^.createClass) -> PlainTV t : tvs + | otherwise -> [] + _ -> tvs --TODO: Better way to write this? fieldMap = fromListWith (++) $ map (\(cn,fn,_) -> (cn, [fn])) fields @@ -510,7 +494,7 @@ isTraversal <- do let notSingular = filter ((/= 1) . length . snd) conList - showCon (c, fs) = pprint (view name c) ++ " { " ++ concat (intersperse ", " $ map pprint fs) ++ " }" + showCon (c, fs) = pprint (c^.name) ++ " { " ++ intercalate ", " (map pprint fs) ++ " }" case (cfg^.buildTraversals, cfg^.partialLenses) of (True, True) -> fail "Cannot makeLensesWith both of the flags buildTraversals and partialLenses." (False, True) -> return False @@ -528,8 +512,8 @@ --TODO: consider detecting simpleLenses, and generating signatures involving "Simple"? let decl = SigD lensName . ForallT tvs' qs - . apps (if isTraversal then ConT ''Traversal else ConT ''Lens) - $ if cfg^.simpleLenses then [aty,aty,cty,cty] else [aty,bty,cty,dty] + . apps (ConT (if isTraversal then ''Traversal else ''Lens)) + $ if cfg^.simpleLenses || isJust maybeClassName then [aty,aty,cty,cty] else [aty,bty,cty,dty] body <- makeFieldLensBody isTraversal lensName conList maybeMethodName #ifndef INLINING @@ -544,13 +528,15 @@ Just (clsNameString, methodNameString) -> do let clsName = mkName clsNameString methodName = mkName methodNameString + varArgs = varT . view name <$> tyArgs + appliedCon = conT tyConName `appsT` varArgs Prelude.sequence $ filter (\_ -> cfg^.createClass) [ - classD (return []) clsName [PlainTV t] [] ( - sigD methodName (appsT (conT ''Lens) [varT t, varT t, conT tyConName, conT tyConName]) : + classD (return []) clsName (PlainTV t : tyArgs) (if List.null tyArgs then [] else [FunDep [t] (view name <$> tyArgs)]) ( + sigD methodName (appsT (conT ''Lens) [varT t, varT t, appliedCon, appliedCon]) : map return defs)] ++ filter (\_ -> cfg^.createInstance) [ - instanceD (return []) (conT clsName `appT` conT tyConName) [ + instanceD (return []) ((conT clsName `appT` appliedCon) `appsT` varArgs) [ funD methodName [clause [varP a] (normalB (varE a)) []] #ifdef INLINING , inlinePragma methodName @@ -562,7 +548,7 @@ getLensFields :: (String -> Maybe String) -> Con -> Q [(Name, (Name, Name, Type))] getLensFields f (RecC cn fs) = return . catMaybes - $ map (\(fn,_,t) -> (\ln -> (mkName ln, (cn,fn,t))) <$> f (nameBase fn)) fs + $ fs <&> \(fn,_,t) -> f (nameBase fn) <&> \ln -> (mkName ln, (cn,fn,t)) getLensFields _ _ = return [] @@ -575,7 +561,7 @@ unifyTypes tvs tys = return (tvs, head tys) #if !(MIN_VERSION_template_haskell(2,7,0)) --- | The orphan instance for old versions is bad, but programing without 'Applicative' is worse. +-- | The orphan instance for old versions is bad, but programming without 'Applicative' is worse. instance Applicative Q where pure = return (<*>) = ap 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 @@ -1,7 +1,9 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Traversal @@ -45,16 +47,18 @@ , unsafePartsOf , unsafePartsOf' , holesOf + , singular + , unsafeSingular -- * Common Traversals , Traversable(traverse) - , _left - , _right , both , beside , taking , dropping + , loci + -- * Cloning Traversals , cloneTraversal , ReifiedTraversal(..) @@ -69,6 +73,7 @@ import Control.Applicative as Applicative import Control.Applicative.Backwards +import Control.Lens.Combinators import Control.Lens.Fold import Control.Lens.Internal import Control.Lens.Internal.Combinators @@ -255,8 +260,8 @@ -- 'mapAccumROf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumROf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ -mapAccumROf :: LensLike (Lazy.State acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -mapAccumROf l f s0 a = swap (Lazy.runState (l (\c -> State.state (\s -> swap (f s c))) a) s0) +mapAccumROf :: LensLike (Backwards (Lazy.State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) +mapAccumROf = mapAccumLOf . backwards {-# INLINE mapAccumROf #-} -- | This generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'. @@ -270,8 +275,8 @@ -- 'mapAccumLOf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- 'mapAccumLOf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -- @ -mapAccumLOf :: LensLike (Backwards (Lazy.State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) -mapAccumLOf = mapAccumROf . backwards +mapAccumLOf :: LensLike (Lazy.State acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) +mapAccumLOf l f acc0 s = swap (Lazy.runState (l (\a -> State.state (\acc -> swap (f acc a))) s) acc0) {-# INLINE mapAccumLOf #-} swap :: (a,b) -> (b,a) @@ -287,7 +292,7 @@ -- 'scanr1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t -- 'scanr1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t -- @ -scanr1Of :: LensLike (Lazy.State (Maybe a)) s t a a -> (a -> a -> a) -> s -> t +scanr1Of :: LensLike (Backwards (Lazy.State (Maybe a))) s t a a -> (a -> a -> a) -> s -> t scanr1Of l f = snd . mapAccumROf l step Nothing where step Nothing a = (Just a, a) step (Just s) a = (Just r, r) where r = f a s @@ -302,12 +307,18 @@ -- 'scanr1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t -- 'scanr1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t -- @ -scanl1Of :: LensLike (Backwards (Lazy.State (Maybe a))) s t a a -> (a -> a -> a) -> s -> t +scanl1Of :: LensLike (Lazy.State (Maybe a)) s t a a -> (a -> a -> a) -> s -> t scanl1Of l f = snd . mapAccumLOf l step Nothing where step Nothing a = (Just a, a) step (Just s) a = (Just r, r) where r = f s a {-# INLINE scanl1Of #-} +-- | This 'Traversal' allows you to 'traverse' the individual stores in a 'Bazaar'. +loci :: Traversal (Bazaar a c s) (Bazaar b c s) a b +loci f w = traverse f (ins w) <&> \xs -> Bazaar $ \g -> traverse g xs <&> unsafeOuts w + + + ------------------------------------------------------------------------------- -- Parts and Holes ------------------------------------------------------------------------------- @@ -387,6 +398,40 @@ f (x:xs) g = Context (g . (:xs)) x : f xs (g . (x:)) {-# INLINE holesOf #-} +-- | This converts a 'Traversal' that you "know" will target one or more elements to a 'Lens'. It can +-- also be used to transform a non-empty 'Fold' into a 'Getter' or a non-empty 'Control.Lens.Action.MonadicFold' into an +-- 'Control.Lens.Action.Action'. +-- +-- The resulting 'Lens', 'Getter', or 'Control.Lens.Action.Action' will be partial if the supplied traversal returns +-- no results. +-- +-- @ +-- 'singular' :: 'Traversal' s t a a -> 'Lens' s t a a +-- 'singular' :: 'Fold' s a -> 'Getter' s a +-- 'singular' :: 'Control.Lens.Action.MonadicFold' m s a -> 'Control.Lens.Action.Action' m s a +-- @ +singular :: Functor f => LensLike (BazaarT a a f) s t a a -> LensLike f s t a a +singular l f = partsOf l $ \xs -> case xs of + (a:as) -> (:as) <$> f a + [] -> [] <$ f (error "singular: empty traversal") + +-- | This converts a 'Traversal' that you "know" will target only one element to a 'Lens'. It can also be +-- used to transform a 'Fold' into a 'Getter' or a 'Control.Lens.Action.MonadicFold' into an 'Control.Lens.Action.Action'. +-- +-- The resulting 'Lens', 'Getter', or 'Control.Lens.Action.Action' will be partial if the Traversal targets nothing +-- or more than one element. +-- +-- @ +-- 'unsafeSingular' :: 'Traversal' s t a b -> 'Lens' s t a b +-- 'unsafeSingular' :: 'Fold' s a -> 'Getter' s a +-- 'unsafeSingular' :: 'Control.Lens.Action.MonadicFold' m s a -> 'Control.Lens.Action.Action' m s a +-- @ +unsafeSingular :: Functor f => LensLike (BazaarT a b f) s t a b -> LensLike f s t a b +unsafeSingular l f = unsafePartsOf l $ \xs -> case xs of + [a] -> return <$> f a + [] -> error "unsafeSingular: empty traversal" + _ -> error "unsafeSingular: traversing multiple results" + ------------------------------------------------------------------------------ -- Internal functions used by 'partsOf', 'holesOf', etc. ------------------------------------------------------------------------------ @@ -447,52 +492,6 @@ beside l r f ~(s,s') = (,) <$> l f s <*> r f s' {-# INLINE beside #-} --- | A traversal for tweaking the left-hand value of an 'Either': --- --- >>> over _left (+1) (Left 2) --- Left 3 --- --- >>> over _left (+1) (Right 2) --- Right 2 --- --- >>> Right 42 ^._left :: String --- "" --- --- >>> Left "hello" ^._left --- "hello" --- --- @_left :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f ('Either' b c)@ -_left :: Traversal (Either a c) (Either b c) a b -_left f (Left a) = Left <$> f a -_left _ (Right c) = pure $ Right c -{-# INLINE _left #-} - --- | traverse the right-hand value of an 'Either': --- --- @'_right' ≡ 'Data.Traversable.traverse'@ --- --- Unfortunately the instance for --- @'Data.Traversable.Traversable' ('Either' c)@ is still missing from base, --- so this can't just be 'Data.Traversable.traverse' --- --- >>> over _right (+1) (Left 2) --- Left 2 --- --- >>> over _right (+1) (Right 2) --- Right 3 --- --- >>> Right "hello" ^._right --- "hello" --- --- >>> Left "hello" ^._right :: [Double] --- [] --- --- @_right :: 'Applicative' f => (a -> f b) -> 'Either' c a -> f ('Either' c a)@ -_right :: Traversal (Either c a) (Either c b) a b -_right _ (Left c) = pure $ Left c -_right f (Right a) = Right <$> f a -{-# INLINE _right #-} - -- | Visit the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'. -- -- >>> [("hello","world"),("!!!","!!!")]^.. taking 2 (traverse.both) @@ -517,7 +516,7 @@ -- >>> [1..]^? dropping 1 folded -- Just 2 dropping :: Applicative f => Int -> SimpleLensLike (Indexing f) s a -> SimpleLensLike f s a -dropping n l f s = case runIndexing (l (\a -> Indexing $ \i -> (if i >= n then f a else pure a, i + 1)) s) 0 of +dropping n l f s = case runIndexing (l (\a -> Indexing $ \i -> i `seq` (if i >= n then f a else pure a, i + 1)) s) 0 of (r, _) -> r {-# INLINE dropping #-} diff --git a/src/Control/Lens/Tuple.hs b/src/Control/Lens/Tuple.hs --- a/src/Control/Lens/Tuple.hs +++ b/src/Control/Lens/Tuple.hs @@ -28,8 +28,8 @@ , Field9(..) ) where +import Control.Lens.Combinators import Control.Lens.Type -import Data.Functor -- $setup -- >>> import Control.Lens @@ -67,35 +67,35 @@ -- | @'_1' k ~(a,b) = (\a' -> (a',b)) '<$>' k a@ instance Field1 (a,b) (a',b) a a' where - _1 k ~(a,b) = (\a' -> (a',b)) <$> k a + _1 k ~(a,b) = k a <&> \a' -> (a',b) {-# INLINE _1 #-} instance Field1 (a,b,c) (a',b,c) a a' where - _1 k ~(a,b,c) = (\a' -> (a',b,c)) <$> k a + _1 k ~(a,b,c) = k a <&> \a' -> (a',b,c) {-# INLINE _1 #-} instance Field1 (a,b,c,d) (a',b,c,d) a a' where - _1 k ~(a,b,c,d) = (\a' -> (a',b,c,d)) <$> k a + _1 k ~(a,b,c,d) = k a <&> \a' -> (a',b,c,d) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e) (a',b,c,d,e) a a' where - _1 k ~(a,b,c,d,e) = (\a' -> (a',b,c,d,e)) <$> k a + _1 k ~(a,b,c,d,e) = k a <&> \a' -> (a',b,c,d,e) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f) (a',b,c,d,e,f) a a' where - _1 k ~(a,b,c,d,e,f) = (\a' -> (a',b,c,d,e,f)) <$> k a + _1 k ~(a,b,c,d,e,f) = k a <&> \a' -> (a',b,c,d,e,f) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g) (a',b,c,d,e,f,g) a a' where - _1 k ~(a,b,c,d,e,f,g) = (\a' -> (a',b,c,d,e,f,g)) <$> k a + _1 k ~(a,b,c,d,e,f,g) = k a <&> \a' -> (a',b,c,d,e,f,g) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h) (a',b,c,d,e,f,g,h) a a' where - _1 k ~(a,b,c,d,e,f,g,h) = (\a' -> (a',b,c,d,e,f,g,h)) <$> k a + _1 k ~(a,b,c,d,e,f,g,h) = k a <&> \a' -> (a',b,c,d,e,f,g,h) {-# INLINE _1 #-} instance Field1 (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' where - _1 k ~(a,b,c,d,e,f,g,h,i) = (\a' -> (a',b,c,d,e,f,g,h,i)) <$> k a + _1 k ~(a,b,c,d,e,f,g,h,i) = k a <&> \a' -> (a',b,c,d,e,f,g,h,i) {-# INLINE _1 #-} -- | Provides access to the 2nd field of a tuple @@ -121,35 +121,35 @@ -- | @'_2' k ~(a,b) = (\b' -> (a,b')) '<$>' k b@ instance Field2 (a,b) (a,b') b b' where - _2 k ~(a,b) = (\b' -> (a,b')) <$> k b + _2 k ~(a,b) = k b <&> \b' -> (a,b') {-# INLINE _2 #-} instance Field2 (a,b,c) (a,b',c) b b' where - _2 k ~(a,b,c) = (\b' -> (a,b',c)) <$> k b + _2 k ~(a,b,c) = k b <&> \b' -> (a,b',c) {-# INLINE _2 #-} instance Field2 (a,b,c,d) (a,b',c,d) b b' where - _2 k ~(a,b,c,d) = (\b' -> (a,b',c,d)) <$> k b + _2 k ~(a,b,c,d) = k b <&> \b' -> (a,b',c,d) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e) (a,b',c,d,e) b b' where - _2 k ~(a,b,c,d,e) = (\b' -> (a,b',c,d,e)) <$> k b + _2 k ~(a,b,c,d,e) = k b <&> \b' -> (a,b',c,d,e) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f) (a,b',c,d,e,f) b b' where - _2 k ~(a,b,c,d,e,f) = (\b' -> (a,b',c,d,e,f)) <$> k b + _2 k ~(a,b,c,d,e,f) = k b <&> \b' -> (a,b',c,d,e,f) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g) (a,b',c,d,e,f,g) b b' where - _2 k ~(a,b,c,d,e,f,g) = (\b' -> (a,b',c,d,e,f,g)) <$> k b + _2 k ~(a,b,c,d,e,f,g) = k b <&> \b' -> (a,b',c,d,e,f,g) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h) (a,b',c,d,e,f,g,h) b b' where - _2 k ~(a,b,c,d,e,f,g,h) = (\b' -> (a,b',c,d,e,f,g,h)) <$> k b + _2 k ~(a,b,c,d,e,f,g,h) = k b <&> \b' -> (a,b',c,d,e,f,g,h) {-# INLINE _2 #-} instance Field2 (a,b,c,d,e,f,g,h,i) (a,b',c,d,e,f,g,h,i) b b' where - _2 k ~(a,b,c,d,e,f,g,h,i) = (\b' -> (a,b',c,d,e,f,g,h,i)) <$> k b + _2 k ~(a,b,c,d,e,f,g,h,i) = k b <&> \b' -> (a,b',c,d,e,f,g,h,i) {-# INLINE _2 #-} -- | Provides access to the 3rd field of a tuple @@ -158,31 +158,31 @@ _3 :: Lens s t a b instance Field3 (a,b,c) (a,b,c') c c' where - _3 k ~(a,b,c) = (\c' -> (a,b,c')) <$> k c + _3 k ~(a,b,c) = k c <&> \c' -> (a,b,c') {-# INLINE _3 #-} instance Field3 (a,b,c,d) (a,b,c',d) c c' where - _3 k ~(a,b,c,d) = (\c' -> (a,b,c',d)) <$> k c + _3 k ~(a,b,c,d) = k c <&> \c' -> (a,b,c',d) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e) (a,b,c',d,e) c c' where - _3 k ~(a,b,c,d,e) = (\c' -> (a,b,c',d,e)) <$> k c + _3 k ~(a,b,c,d,e) = k c <&> \c' -> (a,b,c',d,e) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f) (a,b,c',d,e,f) c c' where - _3 k ~(a,b,c,d,e,f) = (\c' -> (a,b,c',d,e,f)) <$> k c + _3 k ~(a,b,c,d,e,f) = k c <&> \c' -> (a,b,c',d,e,f) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g) (a,b,c',d,e,f,g) c c' where - _3 k ~(a,b,c,d,e,f,g) = (\c' -> (a,b,c',d,e,f,g)) <$> k c + _3 k ~(a,b,c,d,e,f,g) = k c <&> \c' -> (a,b,c',d,e,f,g) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h) (a,b,c',d,e,f,g,h) c c' where - _3 k ~(a,b,c,d,e,f,g,h) = (\c' -> (a,b,c',d,e,f,g,h)) <$> k c + _3 k ~(a,b,c,d,e,f,g,h) = k c <&> \c' -> (a,b,c',d,e,f,g,h) {-# INLINE _3 #-} instance Field3 (a,b,c,d,e,f,g,h,i) (a,b,c',d,e,f,g,h,i) c c' where - _3 k ~(a,b,c,d,e,f,g,h,i) = (\c' -> (a,b,c',d,e,f,g,h,i)) <$> k c + _3 k ~(a,b,c,d,e,f,g,h,i) = k c <&> \c' -> (a,b,c',d,e,f,g,h,i) {-# INLINE _3 #-} -- | Provide access to the 4th field of a tuple @@ -191,27 +191,27 @@ _4 :: Lens s t a b instance Field4 (a,b,c,d) (a,b,c,d') d d' where - _4 k ~(a,b,c,d) = (\d' -> (a,b,c,d')) <$> k d + _4 k ~(a,b,c,d) = k d <&> \d' -> (a,b,c,d') {-# INLINE _4 #-} instance Field4 (a,b,c,d,e) (a,b,c,d',e) d d' where - _4 k ~(a,b,c,d,e) = (\d' -> (a,b,c,d',e)) <$> k d + _4 k ~(a,b,c,d,e) = k d <&> \d' -> (a,b,c,d',e) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f) (a,b,c,d',e,f) d d' where - _4 k ~(a,b,c,d,e,f) = (\d' -> (a,b,c,d',e,f)) <$> k d + _4 k ~(a,b,c,d,e,f) = k d <&> \d' -> (a,b,c,d',e,f) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g) (a,b,c,d',e,f,g) d d' where - _4 k ~(a,b,c,d,e,f,g) = (\d' -> (a,b,c,d',e,f,g)) <$> k d + _4 k ~(a,b,c,d,e,f,g) = k d <&> \d' -> (a,b,c,d',e,f,g) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h) (a,b,c,d',e,f,g,h) d d' where - _4 k ~(a,b,c,d,e,f,g,h) = (\d' -> (a,b,c,d',e,f,g,h)) <$> k d + _4 k ~(a,b,c,d,e,f,g,h) = k d <&> \d' -> (a,b,c,d',e,f,g,h) {-# INLINE _4 #-} instance Field4 (a,b,c,d,e,f,g,h,i) (a,b,c,d',e,f,g,h,i) d d' where - _4 k ~(a,b,c,d,e,f,g,h,i) = (\d' -> (a,b,c,d',e,f,g,h,i)) <$> k d + _4 k ~(a,b,c,d,e,f,g,h,i) = k d <&> \d' -> (a,b,c,d',e,f,g,h,i) {-# INLINE _4 #-} -- | Provides access to the 5th field of a tuple @@ -220,23 +220,23 @@ _5 :: Lens s t a b instance Field5 (a,b,c,d,e) (a,b,c,d,e') e e' where - _5 k ~(a,b,c,d,e) = (\e' -> (a,b,c,d,e')) <$> k e + _5 k ~(a,b,c,d,e) = k e <&> \e' -> (a,b,c,d,e') {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f) (a,b,c,d,e',f) e e' where - _5 k ~(a,b,c,d,e,f) = (\e' -> (a,b,c,d,e',f)) <$> k e + _5 k ~(a,b,c,d,e,f) = k e <&> \e' -> (a,b,c,d,e',f) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g) (a,b,c,d,e',f,g) e e' where - _5 k ~(a,b,c,d,e,f,g) = (\e' -> (a,b,c,d,e',f,g)) <$> k e + _5 k ~(a,b,c,d,e,f,g) = k e <&> \e' -> (a,b,c,d,e',f,g) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h) (a,b,c,d,e',f,g,h) e e' where - _5 k ~(a,b,c,d,e,f,g,h) = (\e' -> (a,b,c,d,e',f,g,h)) <$> k e + _5 k ~(a,b,c,d,e,f,g,h) = k e <&> \e' -> (a,b,c,d,e',f,g,h) {-# INLINE _5 #-} instance Field5 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e',f,g,h,i) e e' where - _5 k ~(a,b,c,d,e,f,g,h,i) = (\e' -> (a,b,c,d,e',f,g,h,i)) <$> k e + _5 k ~(a,b,c,d,e,f,g,h,i) = k e <&> \e' -> (a,b,c,d,e',f,g,h,i) {-# INLINE _5 #-} -- | Provides access to the 6th element of a tuple @@ -245,19 +245,19 @@ _6 :: Lens s t a b instance Field6 (a,b,c,d,e,f) (a,b,c,d,e,f') f f' where - _6 k ~(a,b,c,d,e,f) = (\f' -> (a,b,c,d,e,f')) <$> k f + _6 k ~(a,b,c,d,e,f) = k f <&> \f' -> (a,b,c,d,e,f') {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g) (a,b,c,d,e,f',g) f f' where - _6 k ~(a,b,c,d,e,f,g) = (\f' -> (a,b,c,d,e,f',g)) <$> k f + _6 k ~(a,b,c,d,e,f,g) = k f <&> \f' -> (a,b,c,d,e,f',g) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f',g,h) f f' where - _6 k ~(a,b,c,d,e,f,g,h) = (\f' -> (a,b,c,d,e,f',g,h)) <$> k f + _6 k ~(a,b,c,d,e,f,g,h) = k f <&> \f' -> (a,b,c,d,e,f',g,h) {-# INLINE _6 #-} instance Field6 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f',g,h,i) f f' where - _6 k ~(a,b,c,d,e,f,g,h,i) = (\f' -> (a,b,c,d,e,f',g,h,i)) <$> k f + _6 k ~(a,b,c,d,e,f,g,h,i) = k f <&> \f' -> (a,b,c,d,e,f',g,h,i) {-# INLINE _6 #-} -- | Provide access to the 7th field of a tuple @@ -266,15 +266,15 @@ _7 :: Lens s t a b instance Field7 (a,b,c,d,e,f,g) (a,b,c,d,e,f,g') g g' where - _7 k ~(a,b,c,d,e,f,g) = (\g' -> (a,b,c,d,e,f,g')) <$> k g + _7 k ~(a,b,c,d,e,f,g) = k g <&> \g' -> (a,b,c,d,e,f,g') {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g',h) g g' where - _7 k ~(a,b,c,d,e,f,g,h) = (\g' -> (a,b,c,d,e,f,g',h)) <$> k g + _7 k ~(a,b,c,d,e,f,g,h) = k g <&> \g' -> (a,b,c,d,e,f,g',h) {-# INLINE _7 #-} instance Field7 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g',h,i) g g' where - _7 k ~(a,b,c,d,e,f,g,h,i) = (\g' -> (a,b,c,d,e,f,g',h,i)) <$> k g + _7 k ~(a,b,c,d,e,f,g,h,i) = k g <&> \g' -> (a,b,c,d,e,f,g',h,i) {-# INLINE _7 #-} -- | Provide access to the 8th field of a tuple @@ -283,11 +283,11 @@ _8 :: Lens s t a b instance Field8 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h') h h' where - _8 k ~(a,b,c,d,e,f,g,h) = (\h' -> (a,b,c,d,e,f,g,h')) <$> k h + _8 k ~(a,b,c,d,e,f,g,h) = k h <&> \h' -> (a,b,c,d,e,f,g,h') {-# INLINE _8 #-} instance Field8 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h',i) h h' where - _8 k ~(a,b,c,d,e,f,g,h,i) = (\h' -> (a,b,c,d,e,f,g,h',i)) <$> k h + _8 k ~(a,b,c,d,e,f,g,h,i) = k h <&> \h' -> (a,b,c,d,e,f,g,h',i) {-# INLINE _8 #-} -- | Provides access to the 9th field of a tuple @@ -296,5 +296,5 @@ _9 :: Lens s t a b instance Field9 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i') i i' where - _9 k ~(a,b,c,d,e,f,g,h,i) = (\i' -> (a,b,c,d,e,f,g,h,i')) <$> k i + _9 k ~(a,b,c,d,e,f,g,h,i) = k i <&> \i' -> (a,b,c,d,e,f,g,h,i') {-# INLINE _9 #-} 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 @@ -2,7 +2,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} @@ -50,6 +49,9 @@ -- The lens laws follow from this property and the desire for it to act like -- a 'Data.Traversable.Traversable' when used as a -- 'Control.Lens.Traversal.Traversal'. +-- +-- In the examples below, 'getter' and 'setter' are supplied as example getters +-- and setters, and are not actual functions supplied by this package. ------------------------------------------------------------------------------- module Control.Lens.Type ( @@ -61,21 +63,23 @@ , (%%~) , (%%=) + -- * Lateral Composition , choosing , chosen , alongside + , inside -- * Setting Functionally with Passthrough , (<%~), (<+~), (<-~), (<*~), (~) , (<<%~), (<<.~) -- * Setting State with Passthrough , (<%=), (<+=), (<-=), (<*=), (=) , (<<%=), (<<.=) , (<<~) @@ -83,6 +87,10 @@ , cloneLens , ReifiedLens(..) + -- * Context + , Context(..) + , locus + -- * Simplified and In-Progress , LensLike , Overloaded @@ -90,22 +98,29 @@ , SimpleLensLike , SimpleOverloaded , SimpleReifiedLens - - -- * Exposed Implementation Details - , Context(..) ) where -import Control.Applicative as Applicative -import Control.Lens.Internal -import Control.Monad.State as State +import Control.Applicative +import Control.Comonad.Store as Store +import Control.Lens.Combinators ((<&>)) +import Control.Lens.Internal (Context(..)) +import Control.Monad.State as State +import Data.Monoid (Monoid(mappend)) -- $setup -- >>> import Control.Lens +-- >>> import Debug.SimpleReflect.Expr +-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g,h) +-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f +-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g +-- >>> let h :: Expr -> Expr -> Expr; h = Debug.SimpleReflect.Vars.h +-- >>> let getter :: Expr -> Expr; getter = fun "getter" +-- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixr 4 %%~ infix 4 %%= -infixr 4 <+~, <*~, <-~, ~, <%~, <<%~, <<.~ +infix 4 <+=, <*=, <-=, =, <%=, <<%=, <<.= infixr 2 <<~ ------------------------------------------------------------------------------- @@ -178,6 +193,15 @@ -- | Build a 'Lens' from a getter and a setter. -- -- @'lens' :: 'Functor' f => (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t@ +-- +-- >>> s ^. lens getter setter +-- getter s +-- +-- >>> s & lens getter setter .~ b +-- setter s b +-- +-- >>> s & lens getter setter %~ f +-- setter s (f (getter s)) lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-} @@ -240,6 +264,9 @@ -- 'Control.Lens.Traversal.Traversal' in the current state, extracting extra -- information of type @r@ and return a monoidal summary of the changes. -- +-- >>> runState (_1 %%= \x -> (f x, g x)) (a,b) +-- (f a,(g a,b)) +-- -- @('%%=') ≡ ('state' '.')@ -- -- It may be useful to think of ('%%='), instead, as having either of the @@ -265,6 +292,13 @@ -- Common Lenses ------------------------------------------------------------------------------- +-- | Lift a 'Lens' so it can run under a function. +-- +inside :: LensLike (Context a b) s t a b -> Lens (e -> s) (e -> t) (e -> a) (e -> b) +inside l f es = o <$> f i where + i e = case l (Context id) (es e) of Context _ a -> a + o ea e = case l (Context id) (es e) of Context k _ -> k (ea e) + -- | Merge two lenses, getters, setters, folds or traversals. -- -- @'chosen' ≡ 'choosing' 'id' 'id'@ @@ -288,12 +322,17 @@ -- -- @'chosen' ≡ 'choosing' 'id' 'id'@ -- --- >>> Left 12^.chosen --- 12 +-- >>> Left a^.chosen +-- a +-- +-- >>> Right a^.chosen +-- a +-- -- >>> Right "hello"^.chosen -- "hello" --- >>> chosen *~ 10 $ Right 2 --- Right 20 +-- +-- >>> Right a & chosen *~ b +-- Right (a * b) chosen :: Lens (Either a a) (Either b b) a b chosen f (Left a) = Left <$> f a chosen f (Right a) = Right <$> f a @@ -301,15 +340,37 @@ -- | 'alongside' makes a 'Lens' from two other lenses. -- +-- >>> (Left a, Right b)^.alongside chosen chosen +-- (a,b) +-- +-- >>> (Left a, Right b) & alongside chosen chosen .~ (c,d) +-- (Left c,Right d) +-- -- @'alongside' :: 'Lens' s t a b -> 'Lens' s' t' a' b' -> 'Lens' (s,s') (t,t') (a,a') (b,b')@ alongside :: LensLike (Context a b) s t a b -> LensLike (Context a' b') s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b') alongside l r f (s, s') = case l (Context id) s of Context bt a -> case r (Context id) s' of - Context bt' a' -> (\(b,b') -> (bt b, bt' b')) <$> f (a,a') + Context bt' a' -> f (a,a') <&> \(b,b') -> (bt b, bt' b') {-# INLINE alongside #-} +-- | This 'Lens' lets you 'view' the current 'pos' of any 'Store' +-- 'Comonad' and 'seek' to a new position. This reduces the API +-- for working with a 'ComonadStore' instances to a single 'Lens'. +-- +-- @ +-- 'pos' w ≡ w '^.' 'locus' +-- 'seek' s w ≡ w '&' 'locus' '.~' s +-- 'seeks' f w ≡ w '&' 'locus' '%~' f +-- @ +-- +-- @ +-- 'locus' :: Simple Lens ('Context' s s a) s +-- @ +locus :: ComonadStore s w => Simple Lens (w a) s +locus f w = (`seek` w) <$> f (pos w) + ------------------------------------------------------------------------------- -- Cloning Lenses ------------------------------------------------------------------------------- @@ -321,7 +382,9 @@ -- -- Note: This only accepts a proper 'Lens'. -- --- /\"Costate Comonad Coalgebra is equivalent of Java's member variable update technology for Haskell\"/ -- \@PLT_Borat on Twitter +-- > :t let example l x = set (cloneLens l) (x^.cloneLens l + 1) x in example +-- > let example l x = set (cloneLens l) (x^.cloneLens l + 1) x in example +-- > :: Num b => LensLike (Context b b) s t b b -> s -> t cloneLens :: Functor f => LensLike (Context a b) s t a b -> (a -> f b) -> s -> f t @@ -509,7 +572,7 @@ -- @ -- ('<%=') :: 'MonadState' s m => 'Simple' 'Lens' s a -> (a -> a) -> m a -- ('<%=') :: 'MonadState' s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m a --- ('<%=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Traveral' s a -> (a -> a) -> m a +-- ('<%=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Traversal' s a -> (a -> a) -> m a -- @ (<%=) :: MonadState s m => LensLike ((,)b) s s a b -> (a -> b) -> m b l <%= f = l %%= \a -> let b = f a in (b,b) @@ -647,7 +710,7 @@ -- @ -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Lens' s a -> (a -> a) -> m a -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m a --- ('<<%=') :: ('MonadState' s m, 'Monoid' b) => 'Simple' 'Traveral' s a -> (a -> a) -> m a +-- ('<<%=') :: ('MonadState' s m, 'Monoid' b) => 'Simple' 'Traversal' s a -> (a -> a) -> m a -- @ (<<%=) :: MonadState s m => LensLike ((,)a) s s a b -> (a -> b) -> m a l <<%= f = l %%= \a -> (a, f a) @@ -664,7 +727,7 @@ -- @ -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Lens' s a -> (a -> a) -> m a -- ('<<%=') :: 'MonadState' s m => 'Simple' 'Control.Lens.Iso.Iso' s a -> (a -> a) -> m a --- ('<<%=') :: ('MonadState' s m, 'Monoid' t) => 'Simple' 'Traveral' s a -> (a -> a) -> m a +-- ('<<%=') :: ('MonadState' s m, 'Monoid' t) => 'Simple' 'Traversal' s a -> (a -> a) -> m a -- @ (<<.=) :: MonadState s m => LensLike ((,)a) s s a b -> b -> m a l <<.= b = l %%= \a -> (a,b) @@ -685,6 +748,23 @@ modify $ \s -> case l (Context id) s of Context f _ -> f b return b {-# INLINE (<<~) #-} + +-- | 'mappend' a monoidal value onto the end of the target of a 'Lens' and +-- return the result +-- +-- When you do not need the result of the operation, ('<>~') is more flexible. +(<<>~) :: Monoid m => LensLike ((,)m) s t m m -> m -> s -> (m, t) +l <<>~ m = l <%~ (`mappend` m) +{-# INLINE (<<>~) #-} + +-- | 'mappend' a monoidal value onto the end of the target of a 'Lens' into +-- your monad's state and return the result. +-- +-- When you do not need the result of the operation, ('<>=') is more flexible. +(<<>=) :: (MonadState s m, Monoid r) => SimpleLensLike ((,)r) s r -> r -> m r +l <<>= r = l <%= (`mappend` r) +{-# INLINE (<<>=) #-} + -- | Useful for storing lenses in containers. newtype ReifiedLens s t a b = ReifyLens { reflectLens :: Lens s t a b } diff --git a/src/Control/Lens/WithIndex.hs b/src/Control/Lens/WithIndex.hs --- a/src/Control/Lens/WithIndex.hs +++ b/src/Control/Lens/WithIndex.hs @@ -4,11 +4,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 706 +#ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 706 #define MPTC_DEFAULTS #endif +#endif +#ifdef TRUSTWORTHY +{-# LANGUAGE Trustworthy #-} -- vector, hashable +#endif + #ifndef MIN_VERSION_containers #define MIN_VERSION_containers(x,y,z) 1 #endif @@ -67,7 +73,6 @@ import Control.Lens.Fold import Control.Lens.Internal import Control.Lens.Internal.Combinators -import Control.Lens.Indexed import Control.Lens.IndexedSetter import Control.Lens.IndexedFold import Control.Lens.IndexedTraversal @@ -103,6 +108,7 @@ #ifdef MPTC_DEFAULTS default imap :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b imap = imapOf itraversed + {-# INLINE imap #-} #endif -- | The 'IndexedSetter' for a 'FunctorWithIndex'. @@ -143,9 +149,9 @@ -- | -- Left-associative fold of an indexed container with access to the index @i@. -- - -- When you don't need access to the index then 'foldl' is more flexible in what it accepts. + -- When you don't need access to the index then 'Data.Foldable.foldl' is more flexible in what it accepts. -- - -- @'foldl' ≡ 'ifoldl' '.' 'const'@ + -- @'Data.Foldable.foldl' ≡ 'ifoldl' '.' 'const'@ ifoldl :: (i -> b -> a -> b) -> b -> f a -> b ifoldl f z t = appEndo (getDual (ifoldMap (\i -> dual# (endo# (flip (f i)))) t)) z @@ -163,27 +169,20 @@ -- When you don't need access to the index then 'Control.Lens.Fold.foldlOf'' is more flexible in what it accepts. -- -- @'Control.Lens.Fold.foldlOf'' l ≡ 'ifoldlOf'' l '.' 'const'@ - -- - -- @ - -- 'ifoldlOf'' :: 'Control.Lens.IndexedGetter.IndexedGetter' i a c -> (i -> e -> c -> e) -> e -> a -> e - -- 'ifoldlOf'' :: 'IndexedFold' i a c -> (i -> e -> c -> e) -> e -> a -> e - -- 'ifoldlOf'' :: 'Control.Lens.IndexedLens.SimpleIndexedLens' i a c -> (i -> e -> c -> e) -> e -> a -> e - -- 'ifoldlOf'' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i a c -> (i -> e -> c -> e) -> e -> a -> e - -- @ ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b ifoldl' f z0 xs = ifoldr f' id xs z0 where f' i x k z = k $! f i z x -- | The 'IndexedFold' of a 'FoldableWithIndex' container. ifolded :: FoldableWithIndex i f => IndexedFold i (f a) a -ifolded = index $ \ f -> coerce . getFolding . ifoldMap (\i -> folding# (f i)) +ifolded = indexed $ \ f -> coerce . getFolding . ifoldMap (\i -> folding# (f i)) {-# INLINE ifolded #-} -- | Obtain a 'Fold' by lifting an operation that returns a foldable result. -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. -ifolding :: FoldableWithIndex i f => (a -> f c) -> IndexedFold i a c -ifolding afc = index $ \ icgd -> coerce . itraverse_ icgd . afc +ifolding :: FoldableWithIndex i f => (s -> f a) -> IndexedFold i s a +ifolding sfa = indexed $ \ iagb -> coerce . itraverse_ iagb . sfa {-# INLINE ifolding #-} -- | @@ -191,7 +190,7 @@ -- -- When you don't need access to the index then 'any' is more flexible in what it accepts. -- --- @'any' = 'iany' '.' 'const'@ +-- @'any' ≡ 'iany' '.' 'const'@ iany :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool iany f = getAny# (ifoldMap (\i -> any# (f i))) {-# INLINE iany #-} @@ -300,9 +299,9 @@ -- | Extract the key-value pairs from a structure. -- --- When you don't need access to the indices in the result, then 'toList' is more flexible in what it accepts. +-- When you don't need access to the indices in the result, then 'Data.Foldable.toList' is more flexible in what it accepts. -- --- @'toList' ≡ 'map' 'fst' '.' 'itoList'@ +-- @'Data.Foldable.toList' ≡ 'Data.List.map' 'fst' '.' 'itoList'@ itoList :: FoldableWithIndex i f => f a -> [(i,a)] itoList = ifoldr (\i c -> ((i,c):)) [] {-# INLINE itoList #-} @@ -338,13 +337,13 @@ itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b) #ifdef MPTC_DEFAULTS default itraverse :: Applicative f => (Int -> a -> f b) -> t a -> f (t b) - itraverse = withIndex (indexed traverse) + itraverse = withIndex traversed {-# INLINE itraverse #-} #endif -- | The 'IndexedTraversal' of a 'TraversableWithIndex' container. itraversed :: TraversableWithIndex i f => IndexedTraversal i (f a) (f b) a b -itraversed = index itraverse +itraversed = indexed itraverse {-# INLINE itraversed #-} -- | @@ -404,7 +403,7 @@ -- >>> over (iwhere (>0)) Prelude.reverse $ ["He","was","stressed","o_O"] -- ["He","saw","desserts","O_o"] iwhere :: TraversableWithIndex i t => (i -> Bool) -> SimpleIndexedTraversal i (t a) a -iwhere p = index $ \f a -> itraverse (\i c -> if p i then f i c else pure c) a +iwhere p = indexed $ \f a -> itraverse (\i c -> if p i then f i c else pure c) a {-# INLINE iwhere #-} ------------------------------------------------------------------------------- @@ -414,34 +413,45 @@ -- | The position in the list is available as the index. instance FunctorWithIndex Int [] where imap = imapOf itraversed + {-# INLINE imap #-} instance FoldableWithIndex Int [] where ifoldMap = ifoldMapOf itraversed + {-# INLINE ifoldMap #-} instance TraversableWithIndex Int [] where - itraverse = withIndex (indexed traverse) + itraverse = withIndex traversed + {-# INLINE itraverse #-} -- | The position in the sequence is available as the index. instance FunctorWithIndex Int Seq where imap = imapOf itraversed + {-# INLINE imap #-} instance FoldableWithIndex Int Seq where ifoldMap = ifoldMapOf itraversed + {-# INLINE ifoldMap #-} instance TraversableWithIndex Int Seq where - itraverse = withIndex (indexed traverse) + itraverse = withIndex traversed + {-# INLINE itraverse #-} instance FunctorWithIndex Int Vector where imap = V.imap + {-# INLINE imap #-} instance FoldableWithIndex Int Vector where ifoldMap = ifoldMapOf itraversed + {-# INLINE ifoldMap #-} ifoldr = V.ifoldr ifoldl = V.ifoldl . flip ifoldr' = V.ifoldr' ifoldl' = V.ifoldl' . flip instance TraversableWithIndex Int Vector where itraverse f = sequenceA . V.imap f + {-# INLINE itraverse #-} instance FunctorWithIndex Int IntMap where imap = imapOf itraversed + {-# INLINE imap #-} instance FoldableWithIndex Int IntMap where ifoldMap = ifoldMapOf itraversed + {-# INLINE ifoldMap #-} instance TraversableWithIndex Int IntMap where #if MIN_VERSION_containers(0,5,0) itraverse = IntMap.traverseWithKey @@ -450,11 +460,13 @@ #endif {-# INLINE itraverse #-} -instance Ord k => FunctorWithIndex k (Map k) where +instance FunctorWithIndex k (Map k) where imap = imapOf itraversed -instance Ord k => FoldableWithIndex k (Map k) where + {-# INLINE imap #-} +instance FoldableWithIndex k (Map k) where ifoldMap = ifoldMapOf itraversed -instance Ord k => TraversableWithIndex k (Map k) where + {-# INLINE ifoldMap #-} +instance TraversableWithIndex k (Map k) where #if MIN_VERSION_containers(0,5,0) itraverse = Map.traverseWithKey #else @@ -464,8 +476,10 @@ instance (Eq k, Hashable k) => FunctorWithIndex k (HashMap k) where imap = imapOf itraversed + {-# INLINE imap #-} instance (Eq k, Hashable k) => FoldableWithIndex k (HashMap k) where ifoldMap = ifoldMapOf itraversed + {-# INLINE ifoldMap #-} instance (Eq k, Hashable k) => TraversableWithIndex k (HashMap k) where itraverse = HashMap.traverseWithKey {-# INLINE itraverse #-} diff --git a/src/Control/Lens/Wrapped.hs b/src/Control/Lens/Wrapped.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Wrapped.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Wrapped +-- Copyright : (C) 2012 Edward Kmett, Michael Sloan +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : Rank2, MPTCs, fundeps +-- +-- The 'Wrapped' class provides similar functionality as @Control.Newtype@, +-- from the @newtype@ package, but in a more convenient and efficient form. +-- +-- There are a few functions from @newtype@ that are not provided here, because +-- they can be done with the 'Iso' directly: +-- +-- @ +-- Control.Newtype.over 'Sum' f ≡ 'wrapping' 'Sum' '%~' f +-- Control.Newtype.under 'Sum' f ≡ 'unwrapping' 'Sum' '%~' f +-- Control.Newtype.overF 'Sum' f ≡ 'mapping' ('wrapping' 'Sum') '%~' f +-- Control.Newtype.underF 'Sum' f ≡ 'mapping' ('unwrapping' 'Sum') '%~' f +-- @ +-- +-- 'under' can also be used with 'wrapping' to provide the equivalent of +-- @Control.Newtype.under@. Also, most use cases don't need full polymorphism, +-- so only the single constructor 'wrapping' functions would be needed. +-- +-- These equivalences aren't 100% honest, because @newtype@'s operators +-- need to rely on two @Newtype@ constraints. This means that the wrapper used +-- for the output is not necessarily the same as the input. +-- +---------------------------------------------------------------------------- +module Control.Lens.Wrapped + ( Wrapped(..) + , wrapping, unwrapping + , wrappings, unwrappings + , op + , ala, alaf + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Applicative.Lift +import Control.Arrow +-- import Control.Comonad.Trans.Env +-- import Control.Comonad.Trans.Store +import Control.Comonad.Trans.Traced +import Control.Exception +import Control.Lens.Prism +import Control.Lens.Iso +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Error +import Control.Monad.Trans.Identity +import Control.Monad.Trans.List +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict +import Data.Foldable as Foldable +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Coproduct +import Data.Functor.Identity +import Data.Functor.Reverse +import Data.Hashable +import Data.IntSet as IntSet +import Data.IntMap as IntMap +import Data.HashSet as HashSet +import Data.HashMap.Lazy as HashMap +import Data.Map as Map +import Data.Monoid +import Data.Sequence as Seq hiding (length) +import Data.Set as Set + +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Foldable + +-- | 'Wrapped' provides isomorphisms to wrap and unwrap newtypes or +-- data types with one constructor. +class Wrapped s t a b | a -> s, b -> t, a t -> s, b s -> t where + -- | An isomorphism between s and @a@ and a related one between @t@ and @b@, such that when @a = b@, @s = t@. + -- + -- This is often used via 'wrapping' to aid type inference. + wrapped :: Iso s t a b + +-- * base + +instance Wrapped Bool Bool All All where + wrapped = iso All getAll + {-# INLINE wrapped #-} + +instance Wrapped Bool Bool Any Any where + wrapped = iso Any getAny + {-# INLINE wrapped #-} + +instance Wrapped a b (Sum a) (Sum b) where + wrapped = iso Sum getSum + {-# INLINE wrapped #-} + +instance Wrapped a b (Product a) (Product b) where + wrapped = iso Product getProduct + {-# INLINE wrapped #-} + +instance Wrapped (a -> m b) (u -> n v) (Kleisli m a b) (Kleisli n u v) where + wrapped = iso Kleisli runKleisli + {-# INLINE wrapped #-} + +instance Wrapped (m a) (n b) (WrappedMonad m a) (WrappedMonad n b) where + wrapped = iso WrapMonad unwrapMonad + {-# INLINE wrapped #-} + +instance Wrapped (a b c) (u v w) (WrappedArrow a b c) (WrappedArrow u v w) where + wrapped = iso WrapArrow unwrapArrow + {-# INLINE wrapped #-} + +instance Wrapped [a] [b] (ZipList a) (ZipList b) where + wrapped = iso ZipList getZipList + {-# INLINE wrapped #-} + +instance Wrapped a b (Const a x) (Const b y) where + wrapped = iso Const getConst + {-# INLINE wrapped #-} + +instance Wrapped (a -> a) (b -> b) (Endo a) (Endo b) where + wrapped = iso Endo appEndo + {-# INLINE wrapped #-} + +instance Wrapped (Maybe a) (Maybe b) (First a) (First b) where + wrapped = iso First getFirst + {-# INLINE wrapped #-} + +instance Wrapped (Maybe a) (Maybe b) (Last a) (Last b) where + wrapped = iso Last getLast + {-# INLINE wrapped #-} + +instance (ArrowApply m, ArrowApply n) => Wrapped (m () a) (n () b) (ArrowMonad m a) (ArrowMonad n b) where + wrapped = iso ArrowMonad getArrowMonad + {-# INLINE wrapped #-} + +-- * transformers + +instance Wrapped (f a) (f' a') (Backwards f a) (Backwards f' a') where + wrapped = iso Backwards forwards + {-# INLINE wrapped #-} + +instance Wrapped (f (g a)) (f' (g' a')) (Compose f g a) (Compose f' g' a') where + wrapped = iso Compose getCompose + {-# INLINE wrapped #-} + +instance Wrapped a a' (Constant a b) (Constant a' b') where + wrapped = iso Constant getConstant + {-# INLINE wrapped #-} + +instance Wrapped ((a -> m r) -> m r) ((a' -> m' r') -> m' r') (ContT r m a) (ContT r' m' a') where + wrapped = iso ContT runContT + {-# INLINE wrapped #-} + +instance Wrapped (m (Either e a)) (m' (Either e' a')) (ErrorT e m a) (ErrorT e' m' a') where + wrapped = iso ErrorT runErrorT + {-# INLINE wrapped #-} + +instance Wrapped a a' (Identity a) (Identity a') where + wrapped = iso Identity runIdentity + {-# INLINE wrapped #-} + +instance Wrapped (m a) (m' a') (IdentityT m a) (IdentityT m' a') where + wrapped = iso IdentityT runIdentityT + {-# INLINE wrapped #-} + +instance (Applicative f, Applicative g) => Wrapped (f a) (g b) (Lift f a) (Lift g b) where + wrapped = iso Other unLift + {-# INLINE wrapped #-} + +instance Wrapped (m [a]) (m' [a']) (ListT m a) (ListT m' a') where + wrapped = iso ListT runListT + {-# INLINE wrapped #-} + +instance Wrapped (m (Maybe a)) (m' (Maybe a')) (MaybeT m a) (MaybeT m' a') where + wrapped = iso MaybeT runMaybeT + {-# INLINE wrapped #-} + +instance Wrapped (r -> m a) (r' -> m' a') (ReaderT r m a) (ReaderT r' m' a') where + wrapped = iso ReaderT runReaderT + {-# INLINE wrapped #-} + +instance Wrapped (f a) (f' a') (Reverse f a) (Reverse f' a') where + wrapped = iso Reverse getReverse + {-# INLINE wrapped #-} + +instance Wrapped (r -> s -> m (a, s, w)) (r' -> s' -> m' (a', s', w')) (Lazy.RWST r w s m a) (Lazy.RWST r' w' s' m' a') where + wrapped = iso Lazy.RWST Lazy.runRWST + {-# INLINE wrapped #-} + +instance Wrapped (r -> s -> m (a, s, w)) (r' -> s' -> m' (a', s', w')) (Strict.RWST r w s m a) (Strict.RWST r' w' s' m' a') where + wrapped = iso Strict.RWST Strict.runRWST + {-# INLINE wrapped #-} + +instance Wrapped (s -> m (a, s)) (s' -> m' (a', s')) (Lazy.StateT s m a) (Lazy.StateT s' m' a') where + wrapped = iso Lazy.StateT Lazy.runStateT + {-# INLINE wrapped #-} + +instance Wrapped (s -> m (a, s)) (s' -> m' (a', s')) (Strict.StateT s m a) (Strict.StateT s' m' a') where + wrapped = iso Strict.StateT Strict.runStateT + {-# INLINE wrapped #-} + +instance Wrapped (m (a, w)) (m' (a', w')) (Lazy.WriterT w m a) (Lazy.WriterT w' m' a') where + wrapped = iso Lazy.WriterT Lazy.runWriterT + {-# INLINE wrapped #-} + +instance Wrapped (m (a, w)) (m' (a', w')) (Strict.WriterT w m a) (Strict.WriterT w' m' a') where + wrapped = iso Strict.WriterT Strict.runWriterT + {-# INLINE wrapped #-} + +-- * comonad-transformers + +instance Wrapped (Either (f a) (g a)) (Either (f' a') (g' a')) (Coproduct f g a) (Coproduct f' g' a') where + wrapped = iso Coproduct getCoproduct + {-# INLINE wrapped #-} + +instance Wrapped (w (m -> a)) (w' (m' -> a')) (TracedT m w a) (TracedT m' w' a') where + wrapped = iso TracedT runTracedT + {-# INLINE wrapped #-} + +-- * unordered-containers + +-- | Use @'wrapping' HashMap.fromList'@. Unwrapping returns some permutation of the list. +instance (Hashable k, Eq k, Hashable k', Eq k') => Wrapped [(k, a)] [(k', b)] (HashMap k a) (HashMap k' b) where + wrapped = iso HashMap.fromList HashMap.toList + +-- | Use @'wrapping' HashSet.fromList'@. Unwrapping returns some permutation of the list. +instance (Hashable a, Eq a, Hashable b, Eq b) => Wrapped [a] [b] (HashSet a) (HashSet b) where + wrapped = iso HashSet.fromList HashSet.toList + +-- * containers + +-- | Use @'wrapping' 'IntMap.fromList'@. unwrapping returns a /sorted/ list. +instance Wrapped [(Int, a)] [(Int, b)] (IntMap a) (IntMap b) where + wrapped = iso IntMap.fromList IntMap.toAscList + +-- | Use @'wrapping' 'IntSet.fromList'@. unwrapping returns a /sorted/ list. +instance Wrapped [Int] [Int] IntSet IntSet where + wrapped = iso IntSet.fromList IntSet.toAscList + +-- | Use @'wrapping' 'Map.fromList'@. unwrapping returns a /sorted/ list. +instance (Ord k, Ord k') => Wrapped [(k, a)] [(k', b)] (Map k a) (Map k' b) where + wrapped = iso Map.fromList Map.toAscList + +-- | Use @'wrapping' 'Set.fromList'@. unwrapping returns a /sorted/ list. +instance (Ord a, Ord b) => Wrapped [a] [b] (Set a) (Set b) where + wrapped = iso Set.fromList Set.toAscList + +instance Wrapped [a] [b] (Seq a) (Seq b) where + wrapped = iso Seq.fromList Foldable.toList + +-- * Control.Exception + +instance Wrapped String String AssertionFailed AssertionFailed where + wrapped = iso AssertionFailed failedAssertion + {-# INLINE wrapped #-} + +instance Wrapped String String NoMethodError NoMethodError where + wrapped = iso NoMethodError getNoMethodError + {-# INLINE wrapped #-} + +instance Wrapped String String PatternMatchFail PatternMatchFail where + wrapped = iso PatternMatchFail getPatternMatchFail + {-# INLINE wrapped #-} + +instance Wrapped String String RecConError RecConError where + wrapped = iso RecConError getRecConError + {-# INLINE wrapped #-} + +instance Wrapped String String RecSelError RecSelError where + wrapped = iso RecSelError getRecSelError + {-# INLINE wrapped #-} + +instance Wrapped String String RecUpdError RecUpdError where + wrapped = iso RecUpdError getRecUpdError + {-# INLINE wrapped #-} + +instance Wrapped String String ErrorCall ErrorCall where + wrapped = iso ErrorCall getErrorCall + {-# INLINE wrapped #-} + +getErrorCall :: ErrorCall -> String +getErrorCall (ErrorCall x) = x +{-# INLINE getErrorCall #-} + +getRecUpdError :: RecUpdError -> String +getRecUpdError (RecUpdError x) = x +{-# INLINE getRecUpdError #-} + +getRecSelError :: RecSelError -> String +getRecSelError (RecSelError x) = x +{-# INLINE getRecSelError #-} + +getRecConError :: RecConError -> String +getRecConError (RecConError x) = x +{-# INLINE getRecConError #-} + +getPatternMatchFail :: PatternMatchFail -> String +getPatternMatchFail (PatternMatchFail x) = x +{-# INLINE getPatternMatchFail #-} + +getNoMethodError :: NoMethodError -> String +getNoMethodError (NoMethodError x) = x +{-# INLINE getNoMethodError #-} + +failedAssertion :: AssertionFailed -> String +failedAssertion (AssertionFailed x) = x +{-# INLINE failedAssertion #-} + +getArrowMonad :: ArrowApply m => ArrowMonad m a -> m () a +getArrowMonad (ArrowMonad x) = x +{-# INLINE getArrowMonad #-} + +-- | Given the constructor for a @Wrapped@ type, return a +-- deconstructor that is its inverse. +-- +-- Assuming the @Wrapped@ instance is legal, these laws hold: +-- +-- @ +-- 'op' f '.' f ≡ 'id' +-- f '.' 'op' f ≡ 'id' +-- @ +-- +-- +-- >>> op Identity (Identity 4) +-- 4 +-- +-- >>> op Const (Const "hello") +-- "hello" +op :: Wrapped s s a a => (s -> a) -> a -> s +op f = review (wrapping f) +{-# INLINE op #-} + +-- | This is a convenient alias for @'from' 'wrapped'@ +-- +-- >>> Const "hello" & unwrapped %~ length & getConst +-- 5 +unwrapped :: Wrapped t s b a => Iso a b s t +unwrapped = from wrapped +{-# INLINE unwrapped #-} + +-- | This is a convenient version of 'wrapped' with an argument that's ignored. +-- +-- The argument is used to specify which newtype the user intends to wrap +-- by using the constructor for that newtype. +-- +-- The user supplied function is /ignored/, merely its type is used. +wrapping :: Wrapped s s a a => (s -> a) -> Iso s s a a +wrapping _ = wrapped +{-# INLINE wrapping #-} + +-- | This is a convenient version of 'unwrapped' with an argument that's ignored. +-- +-- The argument is used to specify which newtype the user intends to /remove/ +-- by using the constructor for that newtype. +-- +-- The user supplied function is /ignored/, merely its type is used. +unwrapping :: Wrapped s s a a => (s -> a) -> Iso a a s s +unwrapping _ = unwrapped +{-# INLINE unwrapping #-} + +-- | This is a convenient version of 'wrapped' with two arguments that are ignored. +-- +-- These arguments are used to which newtype the user intends to wrap and +-- should both be the same constructor. This redundancy is necessary +-- in order to find the full polymorphic isomorphism family. +-- +-- The user supplied functions are /ignored/, merely their types are used. +wrappings :: Wrapped s t a b => (s -> a) -> (t -> b) -> Iso s t a b +wrappings _ _ = wrapped +{-# INLINE wrappings #-} + +-- | This is a convenient version of 'unwrapped' with two arguments that are ignored. +-- +-- These arguments are used to which newtype the user intends to remove and +-- should both be the same constructor. This redundancy is necessary +-- in order to find the full polymorphic isomorphism family. +-- +-- The user supplied functions are /ignored/, merely their types are used. +unwrappings :: Wrapped t s b a => (s -> a) -> (t -> b) -> Iso a b s t +unwrappings _ _ = unwrapped +{-# INLINE unwrappings #-} + +-- | This combinator is based on @ala@ from Conor McBride's work on Epigram. +-- +-- As with 'wrapping', the user supplied function for the newtype is /ignored/. +-- +-- >>> ala Sum foldMap [1,2,3,4] +-- 10 +-- +-- >>> ala All foldMap [True,True] +-- True +-- +-- >>> ala All foldMap [True,False] +-- False +-- +-- >>> ala Any foldMap [False,False] +-- False +-- +-- >>> ala Any foldMap [True,False] +-- True +-- +-- >>> ala Sum foldMap [1,2,3,4] +-- 10 +-- +-- >>> ala Product foldMap [1,2,3,4] +-- 24 +ala :: Wrapped s s a a => (s -> a) -> ((s -> a) -> e -> a) -> e -> s +ala = au . wrapping +{-# INLINE ala #-} + +-- | +-- This combinator is based on @ala'@ from Conor McBride's work on Epigram. +-- +-- As with 'wrapping', the user supplied function for the newtype is /ignored/. +-- +-- >>> alaf Sum foldMap length ["hello","world"] +-- 10 +alaf :: Wrapped s s a a => (s -> a) -> ((r -> a) -> e -> a) -> (r -> s) -> e -> s +alaf = auf . wrapping +{-# INLINE alaf #-} diff --git a/src/Control/Lens/Zipper.hs b/src/Control/Lens/Zipper.hs --- a/src/Control/Lens/Zipper.hs +++ b/src/Control/Lens/Zipper.hs @@ -17,17 +17,17 @@ -- -- [@'Top' ':>' a@] represents a trivial 'Zipper' with its focus at the root. -- --- [@'Top' ':>' 'Data.Tree.Tree' a ':>' a@] represents a zipper that starts with a +-- [@'Top' ':>' 'Data.Tree.Tree' a ':>' a@] represents a 'Zipper' that starts with a -- 'Data.Tree.Tree' and descends in a single step to values of type @a@. -- -- [@'Top' ':>' 'Data.Tree.Tree' a ':>' 'Data.Tree.Tree' a ':>' 'Data.Tree.Tree' a@] represents a 'Zipper' into a -- 'Data.Tree.Tree' with an intermediate bookmarked 'Data.Tree.Tree', -- focusing in yet another 'Data.Tree.Tree'. -- --- Since individual levels of a zipper are managed by an arbitrary 'Traversal', +-- Since individual levels of a 'Zipper' are managed by an arbitrary 'Traversal', -- you can move left and right through the 'Traversal' selecting neighboring elements. -- --- >>> zipper ("hello","world") & down _1 & fromWithin traverse & focus .~ 'J' & farthest right & focus .~ 'y' & rezip +-- >>> zipper ("hello","world") & downward _1 & fromWithin traverse & focus .~ 'J' & rightmost & focus .~ 'y' & rezip -- ("Jelly","world") -- -- This is particularly powerful when compiled with 'Control.Lens.Plated.plate', @@ -39,16 +39,21 @@ -- * Zippers Top() , (:>)() + , Zipper , zipper -- ** Focusing , focus - -- ** Horizontal Movement - , up - , down + , focusedContext + -- ** Vertical Movement + , upward + , downward , within + , withins -- ** Lateral Movement - , left - , right + , leftward + , rightward + , leftmost + , rightmost -- ** Movement Combinators , tug , tugs @@ -62,7 +67,7 @@ -- ** Closing the zipper , rezip , Zipped - , Zipper() + , Zipping() -- ** Recording , Tape() , saveTape diff --git a/src/Control/Lens/Zoom.hs b/src/Control/Lens/Zoom.hs --- a/src/Control/Lens/Zoom.hs +++ b/src/Control/Lens/Zoom.hs @@ -6,7 +6,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif @@ -31,13 +31,13 @@ import Control.Lens.Internal.Combinators import Control.Lens.Type import Control.Monad -import Control.Monad.Reader.Class as Reader -import Control.Monad.State.Class as State -import Control.Monad.Trans.State.Lazy as Lazy +import Control.Monad.Reader.Class as Reader +import Control.Monad.State as State +import Control.Monad.Trans.State.Lazy as Lazy import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy +import Control.Monad.Trans.Writer.Lazy as Lazy import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy +import Control.Monad.Trans.RWS.Lazy as Lazy import Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Error @@ -46,6 +46,19 @@ import Control.Monad.Trans.Maybe import Data.Monoid +-- $setup +-- >>> import Control.Lens +-- >>> import Control.Monad.State +-- >>> import Data.Map as Map +-- >>> import Debug.SimpleReflect.Expr as Expr +-- >>> import Debug.SimpleReflect.Vars as Vars +-- >>> let f :: Expr -> Expr; f = Vars.f +-- >>> let g :: Expr -> Expr; g = Vars.g +-- >>> let h :: Expr -> Expr -> Expr; h = Vars.h + +-- Chosen so that they have lower fixity than ('%='), and to match ('<~') +infixr 2 `zoom`, `magnify` + -- | This class allows us to use 'zoom' in, changing the State supplied by -- many different monad transformers, potentially quite deep in a monad transformer stack. class (MonadState s m, MonadState t n) => Zoom m n k s t | m -> s k, n -> t k, m t -> n, n s -> m where @@ -61,6 +74,21 @@ -- -- This can be used to edit pretty much any monad transformer stack with a state in it! -- + -- >>> flip State.evalState (a,b) $ zoom _1 $ use id + -- a + -- + -- >>> flip State.execState (a,b) $ zoom _1 $ id .= c + -- (c,b) + -- + -- >>> flip State.execState [(a,b),(c,d)] $ zoom traverse $ _2 %= f + -- [(a,f b),(c,f d)] + -- + -- >>> flip State.runState [(a,b),(c,d)] $ zoom traverse $ _2 <%= f + -- (f b <> f d <> mempty,[(a,f b),(c,f d)]) + -- + -- >>> flip State.evalState (a,b) $ zoom both (use id) + -- a <> b + -- -- @ -- 'zoom' :: 'Monad' m => 'Simple' 'Lens' s t -> 'StateT' t m a -> 'StateT' s m a -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Simple' 'Control.Lens.Traversal.Traversal' s t -> 'StateT' t m c -> 'StateT' s m c @@ -70,7 +98,7 @@ -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Simple' 'Control.Lens.Traversal.Traversal' s t -> 'ErrorT' e ('RWST' r w t m c) -> 'ErrorT' e ('RWST' r w s m c) -- ... -- @ - zoom :: Monad m => SimpleLensLike (k c) t s -> m c -> n c + zoom :: SimpleLensLike (k c) t s -> m c -> n c instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) (Focusing z) s t where zoom l (Strict.StateT m) = Strict.StateT $ unfocusing# (l (focusing# m)) diff --git a/src/Control/Parallel/Strategies/Lens.hs b/src/Control/Parallel/Strategies/Lens.hs --- a/src/Control/Parallel/Strategies/Lens.hs +++ b/src/Control/Parallel/Strategies/Lens.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/src/Data/Array/Lens.hs b/src/Data/Array/Lens.hs --- a/src/Data/Array/Lens.hs +++ b/src/Data/Array/Lens.hs @@ -37,7 +37,7 @@ -- >>> ix 2 .~ 9 $ (listArray (1,5) [4,5,6,7,8] :: Array Int Int) -- array (1,5) [(1,4),(2,9),(3,6),(4,7),(5,8)] ix :: (IArray a e, Ix i) => i -> Simple Lens (a i e) e -ix i f arr = (\e -> arr // [(i,e)]) <$> f (arr ! i) +ix i f arr = f (arr ! i) <&> \e -> arr // [(i,e)] {-# INLINE ix #-} -- | This setter can be used to derive a new 'IArray' from an old array by @@ -60,5 +60,5 @@ -- -- @'amap' ≡ 'over' '_array'@ _array :: (IArray arr a, IArray arr b, Ix i) => IndexedTraversal i (arr i a) (arr i b) a b -_array = index $ \f arr -> array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f i a) (assocs arr) +_array = indexed $ \f arr -> array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f i a) (assocs arr) {-# INLINE _array #-} diff --git a/src/Data/Bits/Lens.hs b/src/Data/Bits/Lens.hs --- a/src/Data/Bits/Lens.hs +++ b/src/Data/Bits/Lens.hs @@ -163,7 +163,7 @@ -- >>> 16 & bitAt 4 .~ False -- 0 bitAt :: Bits b => Int -> SimpleIndexedLens Int b Bool -bitAt n = index $ \f b -> (\x -> if x then setBit b n else clearBit b n) <$> f n (testBit b n) +bitAt n = indexed $ \f b -> f n (testBit b n) <&> \x -> if x then setBit b n else clearBit b n {-# INLINE bitAt #-} -- | Traverse over all bits in a numeric type. @@ -176,7 +176,7 @@ -- If you supply this an 'Integer', the result will be an infinite 'Traversal', which -- can be productively consumed, but not reassembled. bits :: (Num b, Bits b) => SimpleIndexedTraversal Int b Bool -bits = index $ \f b -> let +bits = indexed $ \f b -> let g n = (,) n <$> f n (testBit b n) bs = Prelude.takeWhile hasBit [0..] hasBit n = complementBit b n /= b -- test to make sure that complementing this bit actually changes the value 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,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -5,8 +6,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable +-- Stability : experimental +-- Portability : non-portable -- -- Lenses for lazy bytestrings ---------------------------------------------------------------------------- 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,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -5,8 +6,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable +-- Stability : experimental +-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.ByteString.Lens 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,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -5,8 +6,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable +-- Stability : experimental +-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.ByteString.Strict.Lens 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,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif @@ -9,15 +11,18 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : experimental --- Portability : Rank2Types +-- Portability : non-portable -- -- Lenses and traversals for complex numbers -- ---------------------------------------------------------------------------- module Data.Complex.Lens - ( real - , imaginary - , polarize + ( _realPart + , _imagPart + , _polar + , _magnitude + , _phase + , _conjugate , complex ) where @@ -25,56 +30,114 @@ import Control.Lens import Data.Complex +-- $setup +-- >>> import Debug.SimpleReflect +-- >>> let { a ≈ b = abs (a - b) < 1e-6; infix 4 ≈ } + -- | Access the 'realPart' of a 'Complex' number -- --- >>> (1.0 :+ 0.0)^.real --- 1.0 +-- >>> (a :+ b)^._realPart +-- a -- --- >>> 3 :+ 1 & real *~ 2 --- 6 :+ 1 +-- >>> a :+ b & _realPart *~ 2 +-- a * 2 :+ b -- --- @'real' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ +-- @'_realPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ #if MIN_VERSION_base(4,4,0) -real :: Simple Lens (Complex a) a +_realPart :: Simple Lens (Complex a) a #else -real :: RealFloat a => Simple Lens (Complex a) a +_realPart :: RealFloat a => Simple Lens (Complex a) a #endif -real f (a :+ b) = (:+ b) <$> f a +_realPart f (a :+ b) = (:+ b) <$> f a --- | Access the 'imaginaryPart' of a 'Complex' number +-- | Access the 'imagPart' of a 'Complex' number -- --- >>> (0.0 :+ 1.0)^.imaginary --- 1.0 +-- >>> (a :+ b)^._imagPart +-- b -- --- @'imaginary' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ +-- >>> a :+ b & _imagPart *~ 2 +-- a :+ b * 2 +-- +-- @'_imagPart' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ #if MIN_VERSION_base(4,4,0) -imaginary :: Simple Lens (Complex a) a +_imagPart :: Simple Lens (Complex a) a #else -imaginary :: RealFloat a => Simple Lens (Complex a) a +_imagPart :: RealFloat a => Simple Lens (Complex a) a #endif -imaginary f (a :+ b) = (a :+) <$> f b +_imagPart f (a :+ b) = (a :+) <$> f b --- | This isn't /quite/ a legal lens. Notably the +-- | This isn't /quite/ a legal lens. Notably the -- -- @'view' l ('set' l b a) = b@ -- --- law is violated when you set a 'polar' value with 0 'magnitude' and non-zero 'phase' --- as the 'phase' information is lost. So don't do that! +-- law is violated when you set a 'polar' value with 0 'magnitude' and non-zero +-- 'phase' as the 'phase' information is lost, or with a negative 'magnitude' +-- which flips the 'phase' and retains a positive 'magnitude'. So don't do +-- that! -- -- Otherwise, this is a perfectly cromulent 'Lens'. -polarize :: RealFloat a => Simple Iso (Complex a) (a,a) -polarize = iso polar (uncurry mkPolar) +_polar :: RealFloat a => Simple Iso (Complex a) (a,a) +_polar = iso polar (uncurry mkPolar) --- | Traverse both the 'real' and 'imaginary' parts of a 'Complex' number. +-- | Access the 'magnitude' of a 'Complex' number -- --- >>> 0 & complex .~ 1 --- 1 :+ 1 +-- >>> (10.0 :+ 20.0) & _magnitude *~ 2 +-- 20.0 :+ 40.0 -- --- >>> 3 :+ 4 & complex *~ 2 --- 6 :+ 8 +-- This isn't /quite/ a legal lens. Notably the -- --- >>> sumOf complex (1 :+ 2) --- 3 +-- @'view' l ('set' l b a) = b@ +-- +-- law is violated when you set a negative 'magnitude'. This flips the 'phase' +-- and retains a positive 'magnitude'. So don't do that! +-- +-- Otherwise, this is a perfectly cromulent 'Lens'. +-- +-- Setting the 'magnitude' of a zero 'Complex' number assumes the 'phase' is 0. +_magnitude :: RealFloat a => Simple Lens (Complex a) a +_magnitude f c = setMag <$> f r + where setMag r' | r /= 0 = c * (r' / r :+ 0) + | otherwise = r' :+ 0 + r = magnitude c + +-- | Access the 'phase' of a 'Complex' number +-- +-- >>> (mkPolar 10 (2-pi) & _phase +~ pi & view _phase) ≈ 2 +-- True +-- +-- This isn't /quite/ a legal lens. Notably the +-- +-- @'view' l ('set' l b a) = b@ +-- +-- law is violated when you set a 'phase' outside the range @(-'pi', 'pi']@. +-- The phase is always in that range when queried. So don't do that! +-- +-- Otherwise, this is a perfectly cromulent 'Lens'. +_phase :: RealFloat a => Simple Lens (Complex a) a +_phase f c = setPhase <$> f theta + where setPhase theta' = c * cis (theta' - theta) + theta = phase c + +-- | Access the 'conjugate' of a 'Complex' number +-- +-- >>> (2.0 :+ 3.0) & _conjugate . _imagPart -~ 1 +-- 2.0 :+ 4.0 +-- +-- >>> (mkPolar 10.0 2.0 ^. _conjugate . _phase) ≈ (-2.0) +-- True +_conjugate :: RealFloat a => Simple Iso (Complex a) (Complex a) +_conjugate = iso conjugate conjugate + +-- | Traverse both the 'realPart' and the 'imagPart' of a 'Complex' number. +-- +-- >>> a :+ b & complex .~ c +-- c :+ c +-- +-- >>> a :+ b & complex *~ 2 +-- a * 2 :+ b * 2 +-- +-- >>> sumOf complex (a :+ b) +-- a + b -- -- @'complex' :: 'Applicative' f => (a -> f b) -> 'Complex' a -> f ('Complex' b)@ #if MIN_VERSION_base(4,4,0) diff --git a/src/Data/Data/Lens.hs b/src/Data/Data/Lens.hs --- a/src/Data/Data/Lens.hs +++ b/src/Data/Data/Lens.hs @@ -9,7 +9,7 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -37,14 +37,13 @@ -- * Field Accessor Traversal , upon , upon' - , uponTheDeep - , uponTheDeep' + , onceUpon + , onceUpon' -- * Data Traversal , gtraverse ) where import Control.Applicative -import Control.Arrow ((&&&)) import Control.Exception as E import Control.Lens.Getter import Control.Lens.Indexed @@ -56,6 +55,11 @@ import Control.Lens.Traversal import Control.Lens.Type import Data.Data +import GHC.IO +import Unsafe.Coerce as Unsafe + +#ifndef SAFE +import Control.Arrow ((&&&)) import Data.Foldable import qualified Data.HashMap.Strict as M import Data.HashMap.Strict (HashMap, (!)) @@ -63,9 +67,8 @@ import Data.HashSet (HashSet) import Data.IORef import Data.Monoid -import GHC.IO import GHC.Exts (realWorld#) -import Unsafe.Coerce as Unsafe +#endif -- $setup -- >>> import Control.Lens @@ -103,14 +106,18 @@ -- Smart Traversal ------------------------------------------------------------------------------- --- | Find every occurence of a given type @a@ recursively that doesn't require +-- | Find every occurrence of a given type @a@ recursively that doesn't require -- passing through something of type @a@ using 'Data', while avoiding traversal -- of areas that cannot contain a value of type @a@. -- -- This is 'uniplate' with a more liberal signature. template :: forall s a. (Data s, Typeable a) => Simple Traversal s a +#ifdef SAFE +template = tinplate +#else template = uniplateData (fromOracle answer) where answer = hitTest (undefined :: s) (undefined :: a) +#endif {-# INLINE template #-} -- | Find descendants of type @a@ non-transitively, while avoiding computation of areas that cannot contain values of @@ -123,8 +130,14 @@ -- | 'biplate' performs like 'template', except when @s ~ a@, it returns itself and nothing else. biplate :: forall s a. (Data s, Typeable a) => Simple Traversal s a +#ifdef SAFE +biplate f s + | typeOf (undefined :: s) == typeOf (undefined :: a) = pure s + | otherwise = template f s +#else biplate = biplateData (fromOracle answer) where answer = hitTest (undefined :: s) (undefined :: a) +#endif {-# INLINE biplate #-} ------------------------------------------------------------------------------ @@ -140,27 +153,25 @@ instance Typeable a => Exception (FieldException a) lookupon :: Typeable a => SimpleLensLike (Indexing Mutator) s a -> (s -> a) -> s -> Maybe (Int, Context a a s) -lookupon l field s = case unsafePerformIO $ E.try $ evaluate $ field $ s & indexed l %@~ \i (a::a) -> E.throw (FieldException i a) of +lookupon l field s = case unsafePerformIO $ E.try $ evaluate $ field $ s & indexing l %@~ \i (a::a) -> E.throw (FieldException i a) of Right _ -> Nothing Left e -> case fromException e of Nothing -> Nothing Just (FieldException i a) -> Just (i, Context (\a' -> set (elementOf l i) a' s) a) {-# INLINE lookupon #-} --- | This automatically constructs a 'Simple' 'Traversal' from a field accessor. + +-- | This automatically constructs a 'Simple' 'Traversal' from an function. -- -- >>> (2,4) & upon fst *~ 5 -- (10,4) -- --- There are however, a few caveats on how this function can be used: --- --- First, the user supplied function must access one of the \"immediate descendants\" of the structure as attempts --- to access deeper structures or use non-field accessor functions will generate an empty 'Traversal'. +-- There are however, caveats on how this function can be used! -- --- A more rigorous way to say \"immediate descendants\" is that the function must only inspect one value that would --- be visited by 'template'. +-- First, the user supplied function must access only one field of the specified type. That is to say the target +-- must be a single element that would be visited by @'holesOnOf' 'template' 'uniplate'@ -- --- Note: this even permits some functions to be used directly. +-- Note: this even permits a number of functions to be used directly. -- -- >>> [1,2,3,4] & upon head .~ 0 -- [0,2,3,4] @@ -174,30 +185,67 @@ -- >>> "" ^? upon tail -- Nothing -- --- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data' +-- Accessing parents on the way down to children is okay: -- --- If the supplied function is not a descendant that would be visible to 'template', the resulting 'Traversal' --- will traverse no elements. +-- >>> [1,2,3,4] & upon (tail.tail) .~ [10,20] +-- [1,2,10,20] -- --- If the field you name isn't visible to 'template', but is a "descendant" of a field visible to 'template', then --- upon will return the *ancestor* it can visit, not the field you asked for! Be careful. +-- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data' -- --- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD --- [1,10,20] +-- @'upon' :: ('Data' s, 'Data' a) => (s -> a) -> 'SimpleIndexedTraversal' [Int] s a@ +upon :: forall k f s a. (Indexable [Int] k, Applicative f, Data s, Data a) => (s -> a) -> k (a -> f a) (s -> f s) +upon field = indexed $ \ f s -> case lookupon template field s of + Nothing -> pure s + Just (i, Context k0 a0) -> + let + go :: [Int] -> SimpleTraversal s a -> (a -> s) -> a -> f s + go is l k a = case lookupon (l.uniplate) field s of + Nothing -> k <$> f (reverse is) a + Just (j, Context k' a') -> go (j:is) (l.elementOf uniplate j) k' a' + in go [i] (elementOf template i) k0 a0 +{-# INLINE upon #-} + +-- | The design of 'onceUpon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. +-- 'upon'' provides this additional recursion. -- --- To resolve this when you need deep self-similar recursion, use 'uponTheDeep'. However, 'upon' terminates for --- more inputs, while 'uponTheDeep' can get lost in structures that are infinitely depth-recursive through @a@. +-- Like 'onceUpon'', 'upon'' trusts the user supplied function more than 'upon' using it directly +-- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of +-- generating an illegal lens. -- --- >>> uponTheDeep (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD +-- >>> upon' (tail.tail) .~ [10,20] $ [1,2,3,4] -- [1,2,10,20] +upon' :: forall s a. (Data s, Data a) => (s -> a) -> SimpleIndexedLens [Int] s a +upon' field = indexed $ \ f s -> let + ~(isn, kn) = case lookupon template field s of + Nothing -> (error "upon': no index, not a member", const s) + Just (i, Context k0 _) -> go [i] (elementOf template i) k0 + go :: [Int] -> SimpleTraversal s a -> (a -> s) -> ([Int], a -> s) + go is l k = case lookupon (l.uniplate) field s of + Nothing -> (reverse is, k) + Just (j, Context k' _) -> go (j:is) (l.elementOf uniplate j) k' + in kn <$> f isn (field s) +{-# INLINE upon' #-} + +-- | This automatically constructs a 'Simple' 'Traversal' from a field accessor. -- --- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexed' 'template')@ or into the list +-- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexing' 'template')@ or into the list -- returned by @'holesOf' 'template'@. -upon :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedTraversal Int s a -upon field = index $ \f s -> case lookupon template field s of +-- +-- The design of 'onceUpon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. +-- 'upon' provides this additional recursion, but at the expense of performance. +-- +-- >>> onceUpon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD +-- [1,10,20] +-- +-- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD +-- [1,2,10,20] +-- +-- When in doubt, use 'upon' instead. +onceUpon :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedTraversal Int s a +onceUpon field = indexed $ \f s -> case lookupon template field s of Nothing -> pure s Just (i, Context k a) -> k <$> f i a -{-# INLINE upon #-} +{-# INLINE onceUpon #-} -- | This more trusting version of 'upon' uses your function directly as the getter for a 'Lens'. -- @@ -206,59 +254,23 @@ -- However, you pay for faster access in two ways: -- -- 1. When passed an illegal field accessor, 'upon'' will give you a 'Lens' that quietly violates --- the laws unlike 'upon' will will give you a legal 'Traversal', that avoids modifying the target. +-- the laws, unlike 'upon', which will give you a legal 'Traversal' that avoids modifying the target. -- -- 2. Modifying with the lens is slightly slower, since it has to go back and calculate the index after the fact. -- -- When given a legal field accessor, the index of the 'Lens' can be used as an offset into -- @'elementOf' ('indexed' 'template')@ or into the list returned by @'holesOf' 'template'@. -upon' :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedLens Int s a -upon' field = index $ \f s -> let +-- +-- When in doubt, use 'upon'' instead. +onceUpon' :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedLens Int s a +onceUpon' field = indexed $ \f s -> let ~(i, Context k _) = case lookupon template field s of Nothing -> error "upon': no index, not a member" Just ip -> ip in k <$> f i (field s) -{-# INLINE upon' #-} - --- | The design of 'upon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. --- uponTheDeep provides this additional recursion. --- --- >>> uponTheDeep (tail.tail) .~ [10,20] $ [1,2,3,4] --- [1,2,10,20] --- --- @'uponTheDeep' :: ('Data' s, 'Data' a) => (s -> a) -> 'SimpleIndexedTraversal' [Int] s a@ -uponTheDeep :: forall k f s a. (Indexed [Int] k, Applicative f, Data s, Data a) => (s -> a) -> k (a -> f a) (s -> f s) -uponTheDeep field = index $ \ f s -> case lookupon template field s of - Nothing -> pure s - Just (i, Context k0 a0) -> - let - go :: [Int] -> SimpleTraversal s a -> (a -> s) -> a -> f s - go is l k a = case lookupon (l.uniplate) field s of - Nothing -> k <$> f (reverse is) a - Just (j, Context k' a') -> go (j:is) (l.elementOf uniplate j) k' a' - in go [i] (elementOf template i) k0 a0 -{-# INLINE uponTheDeep #-} +{-# INLINE onceUpon' #-} --- | The design of 'upon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. --- 'uponTheDeep'' provides this additional recursion. --- --- Like 'upon'', 'uponTheDeep'' trusts the user supplied function more than 'uponTheDeep' using it directly --- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of --- generating an illegal lens. --- --- >>> uponTheDeep' (tail.tail) .~ [10,20] $ [1,2,3,4] --- [1,2,10,20] -uponTheDeep' :: forall s a. (Data s, Data a) => (s -> a) -> SimpleIndexedLens [Int] s a -uponTheDeep' field = index $ \ f s -> let - ~(isn, kn) = case lookupon template field s of - Nothing -> (error "uponTheDeep': no index, not a member", const s) - Just (i, Context k0 _) -> go [i] (elementOf template i) k0 - go :: [Int] -> SimpleTraversal s a -> (a -> s) -> ([Int], a -> s) - go is l k = case lookupon (l.uniplate) field s of - Nothing -> (reverse is, k) - Just (j, Context k' _) -> go (j:is) (l.elementOf uniplate j) k' - in kn <$> f isn (field s) -{-# INLINE uponTheDeep' #-} +#ifndef SAFE ------------------------------------------------------------------------------- -- Data Box @@ -437,3 +449,4 @@ | otherwise = \k -> not (S.member k miss) where (hit, miss) = part (\x -> S.member b (m ! x)) (S.insert a (m ! 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,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -19,9 +20,6 @@ -- | -- Traverse the typed value contained in a 'Dynamic' where the type required by your function matches that -- of the contents of the 'Dynamic'. --- --- >>> ()^.by dynamic --- <<()>> -dynamic :: (Typeable a, Typeable b) => Projection Dynamic Dynamic a b -dynamic = projection toDyn fromDynamic +dynamic :: Typeable a => Simple Prism Dynamic a +dynamic = prism toDyn $ \e -> maybe (Left e) Right (fromDynamic e) {-# INLINE dynamic #-} diff --git a/src/Data/HashSet/Lens.hs b/src/Data/HashSet/Lens.hs --- a/src/Data/HashSet/Lens.hs +++ b/src/Data/HashSet/Lens.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- diff --git a/src/Data/List/Lens.hs b/src/Data/List/Lens.hs --- a/src/Data/List/Lens.hs +++ b/src/Data/List/Lens.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | @@ -16,19 +15,37 @@ ---------------------------------------------------------------------------- module Data.List.Lens ( - -- * Partial Lenses _head , _tail , _last , _init + , strippingPrefix ) where import Control.Applicative import Control.Lens +import Data.List +-- $setup +-- >>> import Debug.SimpleReflect.Expr +-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) +-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f +-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g -- | A 'Traversal' reading and writing to the 'head' of a /non-empty/ list. -- +-- >>> [a,b,c]^? _head +-- Just a +-- +-- >>> [a,b,c] & _head .~ d +-- [d,b,c] +-- +-- >>> [a,b,c] & _head %~ f +-- [f a,b,c] +-- +-- >>> [] & _head %~ f +-- [] +-- -- >>> [1,2,3]^?!_head -- 1 -- @@ -46,22 +63,33 @@ -- -- >>> [0,1] & _head .~ 2 -- [2,1] +-- +-- _head :: SimpleIndexedTraversal Int [a] a -_head = index $ \f aas -> case aas of +_head = indexed $ \f aas -> case aas of (a:as) -> (:as) <$> f (0 :: Int) a _ -> pure aas {-# INLINE _head #-} -- | A 'Traversal' reading and writing to the 'tail' of a /non-empty/ list -- +-- >>> [a,b] & _tail .~ [c,d,e] +-- [a,c,d,e] +-- +-- >>> [] & _tail .~ [a,b] +-- [] +-- +-- >>> [a,b,c,d,e] & _tail.traverse %~ f +-- [a,f b,f c,f d,f e] +-- -- >>> [1,2] & _tail .~ [3,4,5] -- [1,3,4,5] -- -- >>> [] & _tail .~ [1,2] -- [] -- --- >>> [1,2,3]^?_tail --- Just [2,3] +-- >>> [a,b,c]^?_tail +-- Just [b,c] -- -- >>> [1,2]^?!_tail -- [2] @@ -78,12 +106,15 @@ -- | A 'Traversal' reading and writing to the last element of a /non-empty/ list -- --- >>> [1,2,3]^?!_last --- 3 +-- >>> [a,b,c]^?!_last +-- c -- -- >>> []^?_last -- Nothing -- +-- >>> [a,b,c] & _last %~ f +-- [a,b,f c] +-- -- >>> [1,2]^?_last -- Just 2 -- @@ -96,29 +127,35 @@ -- >>> [0,1] & _last .~ 2 -- [0,2] _last :: SimpleIndexedTraversal Int [a] a -_last = index $ \f aas -> case aas of +_last = indexed $ \f aas -> case aas of [] -> pure aas - (a:as) -> let go !n b [] = return <$> f n b - go !n b (c:cs) = (b:) <$> go (n + 1) c cs + (a:as) -> let go n b [] = return <$> f n b + go n b (c:cs) = (b:) <$> (go $! n + 1) c cs in go (0 :: Int) a as {-# INLINE _last #-} -- | A 'Traversal' reading and replacing all but the a last element of a /non-empty/ list -- --- >>> [1,2,3,4]^?!_init --- [1,2,3] +-- >>> [a,b,c,d]^?_init +-- Just [a,b,c] -- --- >>> [1,2] & _init .~ [3,4,5] --- [3,4,5,2] +-- >>> []^?_init +-- Nothing -- --- >>> [] & _init .~ [1,2] +-- >>> [a,b] & _init .~ [c,d,e] +-- [c,d,e,b] +-- +-- >>> [] & _init .~ [a,b] -- [] -- +-- >>> [a,b,c,d] & _init.traverse %~ f +-- [f a,f b,f c,d] +-- -- >>> [1,2,3]^?_init -- Just [1,2] -- --- >>> [1,2]^?!_init --- [1] +-- >>> [1,2,3,4]^?!_init +-- [1,2,3] -- -- >>> "hello"^._init -- "hell" @@ -129,3 +166,19 @@ _init _ [] = pure [] _init f as = (++ [Prelude.last as]) <$> f (Prelude.init as) {-# INLINE _init #-} + +-- | A 'Prism' stripping a prefix from a list when used as a 'Traversal', or +-- prepending that prefix when run backwards: +-- +-- >>> "preview" ^? strippingPrefix "pre" +-- Just "view" +-- +-- >>> "review" ^? strippingPrefix "pre" +-- Nothing +-- +-- >>> "amble"^.remit (strippingPrefix "pre") +-- "preamble" +strippingPrefix :: Eq a => [a] -> Simple Prism [a] [a] +strippingPrefix ps = prism (ps ++) $ \xs -> case stripPrefix ps xs of + Nothing -> Left xs + Just xs' -> Right xs' diff --git a/src/Data/List/Split/Lens.hs b/src/Data/List/Split/Lens.hs --- a/src/Data/List/Split/Lens.hs +++ b/src/Data/List/Split/Lens.hs @@ -1,5 +1,4 @@ {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} ---------------------------------------------------------------------------- @@ -163,15 +162,15 @@ -- | Modify or retrieve the list of delimiters for a 'Splitter'. delimiters :: Lens (Splitter a) (Splitter b) [a -> Bool] [b -> Bool] -delimiters f s@Splitter { delimiter = Delimiter ds } = (\ds' -> s { delimiter = Delimiter ds' }) <$> f ds +delimiters f s@Splitter { delimiter = Delimiter ds } = f ds <&> \ds' -> s { delimiter = Delimiter ds' } -- | Modify or retrieve the policy for what a 'Splitter' to do with delimiters. delimiting :: Simple Lens (Splitter a) DelimPolicy -delimiting f s@Splitter { delimPolicy = p } = (\p' -> s { delimPolicy = p' }) <$> f p +delimiting f s@Splitter { delimPolicy = p } = f p <&> \p' -> s { delimPolicy = p' } -- | Modify or retrieve the policy for what a 'Splitter' should about consecutive delimiters. condensing :: Simple Lens (Splitter a) Bool -condensing f s@Splitter { condensePolicy = p } = (\p' -> s { condensePolicy = i p' }) <$> f (o p) where +condensing f s@Splitter { condensePolicy = p } = f (o p) <&> \p' -> s { condensePolicy = i p' } where i True = Condense i False = KeepBlankFields o Condense = True @@ -179,11 +178,11 @@ -- | Modify or retrieve the policy for whether a 'Splitter' should drop an initial blank. keepInitialBlanks :: Simple Lens (Splitter a) Bool -keepInitialBlanks f s@Splitter { initBlankPolicy = p } = (\p' -> s { initBlankPolicy = end p' }) <$> f (keeps p) +keepInitialBlanks f s@Splitter { initBlankPolicy = p } = f (keeps p) <&> \p' -> s { initBlankPolicy = end p' } -- | Modify or retrieve the policy for whether a 'Splitter' should drop a final blank. keepFinalBlanks :: Simple Lens (Splitter a) Bool -keepFinalBlanks f s@Splitter { finalBlankPolicy = p } = (\p' -> s { finalBlankPolicy = end p' }) <$> f (keeps p) +keepFinalBlanks f s@Splitter { finalBlankPolicy = p } = f (keeps p) <&> \p' -> s { finalBlankPolicy = end p' } -- utilities diff --git a/src/Data/Monoid/Lens.hs b/src/Data/Monoid/Lens.hs deleted file mode 100644 --- a/src/Data/Monoid/Lens.hs +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Data.Monoid.Lens --- Copyright : (C) 2012 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : experimental --- Portability : Rank2Types --- ----------------------------------------------------------------------------- -module Data.Monoid.Lens - ( - -- * Monoid Lens Operators - (<>~), (<<>~) - , (<>=), (<<>=) - -- * Isomorphisms for Monoidal Wrappers - , _dual, _endo, _all, _any, _sum, _product, _first, _last - ) where - -import Data.Monoid -import Control.Lens -import Control.Monad.State as State - --- $setup --- >>> :m + Control.Lens Data.Monoid.Lens Data.Foldable - -infixr 4 <>~, <<>~ -infix 4 <>=, <<>= - --- | Modify the target of a monoidally valued by 'mappend'ing another value. --- --- >>> both <>~ "!!!" $ ("hello","world") --- ("hello!!!","world!!!") --- --- @ --- ('<>~') :: 'Monoid' a => 'Setter' s t a a -> a -> s -> t --- ('<>~') :: 'Monoid' a => 'Iso' s t a a -> a -> s -> t --- ('<>~') :: 'Monoid' a => 'Lens' s t a a -> a -> s -> t --- ('<>~') :: 'Monoid' a => 'Traversal' s t a a -> a -> s -> t --- @ -(<>~) :: Monoid a => Setting s t a a -> a -> s -> t -l <>~ n = over l (`mappend` n) -{-# INLINE (<>~) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value. --- --- >>> execState (both <>= "!!!") ("hello","world") --- ("hello!!!","world!!!") --- --- @ --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Setter' s a -> a -> m () --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Iso' s a -> a -> m () --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Lens' s a -> a -> m () --- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Traversal' s a -> a -> m () --- @ -(<>=) :: (MonadState s m, Monoid a) => SimpleSetting s a -> a -> m () -l <>= a = State.modify (l <>~ a) -{-# INLINE (<>=) #-} - - --- | 'mappend' a monoidal value onto the end of the target of a 'Lens' and --- return the result --- --- When you do not need the result of the operation, ('<>~') is more flexible. -(<<>~) :: Monoid m => LensLike ((,)m) s t m m -> m -> s -> (m, t) -l <<>~ m = l <%~ (`mappend` m) -{-# INLINE (<<>~) #-} - --- | 'mappend' a monoidal value onto the end of the target of a 'Lens' into --- your monad's state and return the result. --- --- When you do not need the result of the operation, ('<>=') is more flexible. -(<<>=) :: (MonadState s m, Monoid r) => SimpleLensLike ((,)r) s r -> r -> m r -l <<>= r = l <%= (`mappend` r) -{-# INLINE (<<>=) #-} - --- | Isomorphism for 'Dual' -_dual :: Iso a b (Dual a) (Dual b) -_dual = isos Dual getDual Dual getDual -{-# INLINE _dual #-} - --- | Isomorphism for 'Endo' -_endo :: Iso (a -> a) (b -> b) (Endo a) (Endo b) -_endo = isos Endo appEndo Endo appEndo -{-# INLINE _endo #-} - --- | Isomorphism for 'All' --- --- >>> ala _all foldMap [True,True] --- True --- --- >>> ala _all foldMap [True,False] --- False -_all :: Simple Iso Bool All -_all = iso All getAll -{-# INLINE _all #-} - --- | Isomorphism for 'Any' --- --- >>> ala _any foldMap [False,False] --- False --- --- >>> ala _any foldMap [True,False] --- True -_any :: Simple Iso Bool Any -_any = iso Any getAny -{-# INLINE _any #-} - --- | Isomorphism for 'Sum' --- --- >>> ala _sum foldMap [1,2,3,4] --- 10 -_sum :: Iso a b (Sum a) (Sum b) -_sum = isos Sum getSum Sum getSum -{-# INLINE _sum #-} - --- | Isomorphism for 'Product' --- --- >>> ala _product foldMap [1,2,3,4] --- 24 -_product :: Iso a b (Product a) (Product b) -_product = isos Product getProduct Product getProduct -{-# INLINE _product #-} - --- | Isomorphism for 'First' -_first :: Iso (Maybe a) (Maybe b) (First a) (First b) -_first = isos First getFirst First getFirst -{-# INLINE _first #-} - --- | Isomorphism for 'Last' -_last :: Iso (Maybe a) (Maybe b) (Last a) (Last b) -_last = isos Last getLast Last getLast -{-# INLINE _last #-} 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 @@ -1,13 +1,14 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Sequence.Lens -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable +-- Stability : experimental +-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Sequence.Lens @@ -19,50 +20,104 @@ ) where import Control.Applicative -import Control.Lens as Lens +import Control.Lens import Data.Monoid import Data.Sequence as Seq +-- $setup +-- >>> import Debug.SimpleReflect.Expr +-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) +-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f +-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g + -- | A 'Lens' that can access the @n@th element of a 'Seq'. -- --- Note: This is only a legal lens if there is already such an element! +-- >>> Seq.fromList [a,b,c,d] & ordinal 2 %~ f +-- fromList [a,b,f c,d] +-- +-- >>> Seq.fromList [a,b,c,d] & ordinal 2 .~ e +-- fromList [a,b,e,d] +-- +-- >>> Seq.fromList [a,b,c,d] ^. ordinal 2 +-- c +-- +-- *NB:* This is only a legal lens if there is already such an element! ordinal :: Int -> SimpleIndexedLens Int (Seq a) a -ordinal i = Lens.index $ \ f m -> (\a -> update i a m) <$> f i (Seq.index m i) +ordinal i = indexed $ \ f m -> f i (index m i) <&> \a -> update i a m -- * Sequence isomorphisms -- | A 'Seq' is isomorphic to a 'ViewL' -- --- @'viewl' m = m '^.' 'viewL'@ +-- @'viewl' m ≡ m '^.' 'viewL'@ +-- +-- >>> Seq.fromList [a,b,c] ^. viewL +-- a :< fromList [b,c] +-- +-- >>> Seq.empty ^. viewL +-- EmptyL +-- +-- >>> EmptyL ^. from viewL +-- fromList [] +-- +-- >>> from viewL ^$ a :< fromList [b,c] +-- fromList [a,b,c] +-- viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b) -viewL = isos viewl unviewl viewl unviewl where - -unviewl :: ViewL a -> Seq a -unviewl EmptyL = mempty -unviewl (a :< as) = a <| as +viewL = iso viewl $ \ xs -> case xs of + EmptyL -> mempty + a :< as -> a <| as {-# INLINE viewL #-} -- | A 'Seq' is isomorphic to a 'ViewR' -- --- @'viewr' m = m '^.' 'viewR'@ +-- @'viewr' m ≡ m '^.' 'viewR'@ +-- +-- >>> Seq.fromList [a,b,c] ^. viewR +-- fromList [a,b] :> c +-- +-- >>> Seq.empty ^. viewR +-- EmptyR +-- +-- >>> EmptyR ^. from viewR +-- fromList [] +-- +-- >>> from viewR ^$ fromList [a,b] :> c +-- fromList [a,b,c] viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b) -viewR = isos viewr unviewr viewr unviewr where +viewR = iso viewr $ \xs -> case xs of + EmptyR -> mempty + as :> a -> as |> a {-# INLINE viewR #-} -unviewr :: ViewR a -> Seq a -unviewr EmptyR = mempty -unviewr (as :> a) = as |> a - -- * Traversals -- | Traverse the head of a 'Seq' +-- +-- >>> fromList [a,b,c,d] & _head %~ f +-- fromList [f a,b,c,d] +-- +-- >>> fromList [] ^? _head +-- Nothing +-- +-- >>> fromList [a,b,c,d] ^? _head +-- Just a _head :: SimpleIndexedTraversal Int (Seq a) a -_head = Lens.index $ \f m -> case viewl m of +_head = indexed $ \f m -> case viewl m of a :< as -> (<| as) <$> f (0::Int) a EmptyL -> pure m {-# INLINE _head #-} -- | Traverse the tail of a 'Seq' +-- +-- >>> fromList [a,b] & _tail .~ fromList [c,d,e] +-- fromList [a,c,d,e] +-- +-- >>> fromList [a,b,c] ^? _tail +-- Just (fromList [b,c]) +-- +-- >>> fromList [] ^? _tail +-- Nothing _tail :: SimpleTraversal (Seq a) (Seq a) _tail f m = case viewl m of a :< as -> (a <|) <$> f as @@ -70,13 +125,31 @@ {-# INLINE _tail #-} -- | Traverse the last element of a 'Seq' +-- +-- >>> fromList [a,b,c,d] & _last %~ f +-- fromList [a,b,c,f d] +-- +-- >>> fromList [a,b,c,d] ^? _last +-- Just d +-- +-- >>> fromList [] ^? _last +-- Nothing _last :: SimpleIndexedTraversal Int (Seq a) a -_last = Lens.index $ \f m -> case viewr m of +_last = indexed $ \f m -> case viewr m of as :> a -> (as |>) <$> f (Seq.length as) a EmptyR -> pure m {-# INLINE _last #-} -- | Traverse all but the last element of a 'Seq' +-- +-- >>> fromList [1,2,3] ^? _init +-- Just (fromList [1,2]) +-- +-- >>> fromList [a,b,c,d] & _init.traverse %~ f +-- fromList [f a,f b,f c,d] +-- +-- >>> fromList [] & _init .~ fromList [a,b,c] +-- fromList [] _init :: SimpleTraversal (Seq a) (Seq a) _init f m = case viewr m of as :> a -> (|> a) <$> f as @@ -84,20 +157,47 @@ {-# INLINE _init #-} -- | Traverse the first @n@ elements of a 'Seq' +-- +-- >>> fromList [a,b,c,d,e] ^.. slicedTo 2 +-- [a,b] +-- +-- >>> fromList [a,b,c,d,e] & slicedTo 2 %~ f +-- fromList [f a,f b,c,d,e] +-- +-- >>> fromList [a,b,c,d,e] & slicedTo 10 .~ x +-- fromList [x,x,x,x,x] slicedTo :: Int -> SimpleIndexedTraversal Int (Seq a) a -slicedTo n = Lens.index $ \f m -> case Seq.splitAt n m of +slicedTo n = indexed $ \f m -> case Seq.splitAt n m of (l,r) -> (>< r) <$> itraverse f l {-# INLINE slicedTo #-} -- | Traverse all but the first @n@ elements of a 'Seq' +-- +-- >>> fromList [a,b,c,d,e] ^.. slicedFrom 2 +-- [c,d,e] +-- +-- >>> fromList [a,b,c,d,e] & slicedFrom 2 %~ f +-- fromList [a,b,f c,f d,f e] +-- +-- >>> fromList [a,b,c,d,e] & slicedFrom 10 .~ x +-- fromList [a,b,c,d,e] slicedFrom :: Int -> SimpleIndexedTraversal Int (Seq a) a -slicedFrom n = Lens.index $ \ f m -> case Seq.splitAt n m of +slicedFrom n = indexed $ \ f m -> case Seq.splitAt n m of (l,r) -> (l ><) <$> itraverse (f . (+n)) r {-# INLINE slicedFrom #-} --- | Travere all the elements numbered from @i@ to @j@ of a 'Seq' +-- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq' +-- +-- >>> fromList [a,b,c,d,e] & sliced 1 3 %~ f +-- fromList [a,f b,f c,d,e] + +-- >>> fromList [a,b,c,d,e] ^.. sliced 1 3 +-- [f b,f c] +-- +-- >>> fromList [a,b,c,d,e] & sliced 1 3 .~ x +-- fromList [a,x,x,b,e] sliced :: Int -> Int -> SimpleIndexedTraversal Int (Seq a) a -sliced i j = Lens.index $ \ f s -> case Seq.splitAt i s of +sliced i j = indexed $ \ f s -> case Seq.splitAt i s of (l,mr) -> case Seq.splitAt (j-i) mr of - (m, r) -> (\n -> l >< n >< r) <$> itraverse (f . (+i)) m + (m, r) -> itraverse (f . (+i)) m <&> \n -> l >< n >< r {-# INLINE sliced #-} diff --git a/src/Data/Set/Lens.hs b/src/Data/Set/Lens.hs --- a/src/Data/Set/Lens.hs +++ b/src/Data/Set/Lens.hs @@ -14,8 +14,8 @@ , setOf ) where -import Control.Lens.Getter -import Control.Lens.Setter +import Control.Lens.Getter ( Getting, views ) +import Control.Lens.Setter ( Setter, sets ) import Data.Set as Set -- $setup 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,7 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE FlexibleInstances #-} +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -10,8 +11,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable +-- Stability : experimental +-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Lazy.Lens 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 @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -9,8 +10,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable +-- Stability : experimental +-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Lens 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,6 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -9,8 +10,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable +-- Stability : experimental +-- Portability : non-portable -- ---------------------------------------------------------------------------- module Data.Text.Strict.Lens diff --git a/src/Data/Tree/Lens.hs b/src/Data/Tree/Lens.hs --- a/src/Data/Tree/Lens.hs +++ b/src/Data/Tree/Lens.hs @@ -23,14 +23,13 @@ -- -- >>> view root $ Node 42 [] -- 42 -root :: Simple Lens (Tree a) a +root :: SimpleLens (Tree a) a root f (Node a as) = (`Node` as) <$> f a {-# INLINE root #-} --- | A 'Traversal' of the direct descendants of the root of a 'Tree' --- indexed by its position in the list of children +-- | A 'Lens' returning the direct descendants of the root of a 'Tree' -- --- @'toListOf' 'branches' ≡ 'subForest'@ -branches :: SimpleIndexedTraversal Int (Tree a) (Tree a) -branches = index $ \ f (Node a as) -> Node a <$> itraverse f as +-- @'view' 'branches' ≡ 'subForest'@ +branches :: SimpleLens (Tree a) [Tree a] +branches f (Node a as) = Node a <$> f as {-# INLINE branches #-} diff --git a/src/Data/Typeable/Lens.hs b/src/Data/Typeable/Lens.hs --- a/src/Data/Typeable/Lens.hs +++ b/src/Data/Typeable/Lens.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- @@ -21,18 +21,18 @@ import Control.Applicative import Control.Lens import Data.Typeable -import Unsafe.Coerce as Unsafe +import Data.Maybe -- | A 'Simple' 'Traversal' for working with a 'cast' of a 'Typeable' value. _cast :: (Typeable s, Typeable a) => Simple Traversal s a _cast f s = case cast s of - Just a -> Unsafe.unsafeCoerce <$> f a + Just a -> fromMaybe (error "_cast: recast failed") . cast <$> f a Nothing -> pure s {-# INLINE _cast #-} -- | A 'Simple' 'Traversal' for working with a 'gcast' of a 'Typeable' value. _gcast :: (Typeable s, Typeable a) => Simple Traversal (c s) (c a) _gcast f s = case gcast s of - Just a -> Unsafe.unsafeCoerce <$> f a + Just a -> fromMaybe (error "_gcast: recast failed") . gcast <$> f a Nothing -> pure s {-# INLINE _gcast #-} diff --git a/src/Data/Vector/Generic/Lens.hs b/src/Data/Vector/Generic/Lens.hs --- a/src/Data/Vector/Generic/Lens.hs +++ b/src/Data/Vector/Generic/Lens.hs @@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- @@ -38,11 +38,10 @@ , ordinals ) where -import Control.Applicative import Control.Lens import Data.List (nub) import Data.Monoid -import Data.Vector.Generic as V hiding (zip, filter) +import Data.Vector.Generic as V hiding (zip, filter, indexed) import Data.Vector.Fusion.Stream (Stream) import Data.Vector.Generic.New (New) import Prelude hiding ((++), length, head, tail, init, last, map, reverse) @@ -57,7 +56,7 @@ -- >>> Vector.fromList [1,2,3]^._head -- 1 _head :: Vector v a => SimpleLens (v a) a -_head f v = (\a -> v // [(0,a)]) <$> f (head v) +_head f v = f (head v) <&> \a -> v // [(0,a)] {-# INLINE _head #-} -- | A 'Lens' reading and writing to the 'last' element of a /non-empty/ 'Vector' @@ -67,7 +66,7 @@ -- >>> Vector.fromList [1,2]^._last -- 2 _last :: Vector v a => SimpleLens (v a) a -_last f v = (\a -> v // [(length v - 1, a)]) <$> f (last v) +_last f v = f (last v) <&> \a -> v // [(length v - 1, a)] {-# INLINE _last #-} -- | A lens reading and writing to the 'tail' of a /non-empty/ 'Vector' @@ -77,7 +76,7 @@ -- >>> _tail .~ Vector.fromList [3,4,5] $ Vector.fromList [1,2] -- fromList [1,3,4,5] _tail :: Vector v a => SimpleLens (v a) (v a) -_tail f v = cons (head v) <$> f (tail v) +_tail f v = f (tail v) <&> cons (head v) {-# INLINE _tail #-} -- | A 'Lens' reading and replacing all but the a 'last' element of a /non-empty/ 'Vector' @@ -87,7 +86,7 @@ -- >>> Vector.fromList [1,2,3,4]^._init -- fromList [1,2,3] _init :: Vector v a => SimpleLens (v a) (v a) -_init f v = (`snoc` last v) <$> f (init v) +_init f v = f (init v) <&> \i -> snoc i (last v) {-# INLINE _init #-} -- | @sliced i n@ provides a lens that edits the @n@ elements starting at index @i@ from a lens. @@ -98,7 +97,7 @@ sliced :: Vector v a => Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> SimpleLens (v a) (v a) -sliced i n f v = (\ v0 -> v // zip [i..i+n-1] (V.toList v0)) <$> f (slice i n v) +sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (V.toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'. @@ -140,7 +139,7 @@ -- -- @ordinal n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. ordinal :: Vector v a => Int -> SimpleIndexedLens Int (v a) a -ordinal i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) +ordinal i = indexed $ \ f v -> f i (v ! i) <&> \ a -> v // [(i, a)] {-# INLINE ordinal #-} -- | This 'Traversal' will ignore any duplicates in the supplied list of indices. @@ -148,7 +147,7 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: Vector v a => [Int] -> SimpleIndexedTraversal Int (v a) a -ordinals is = index $ \ f v -> let +ordinals is = indexed $ \ f v -> let l = length v is' = nub $ filter (= 704 +#ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------- @@ -35,9 +35,8 @@ , ordinals ) where -import Control.Applicative import Control.Lens -import Data.Vector as Vector hiding (zip, filter) +import Data.Vector as Vector hiding (zip, filter, indexed) import Prelude hiding ((++), length, head, tail, init, last, map, reverse) import Data.List (nub) import Data.Monoid @@ -49,7 +48,7 @@ -- >>> Vector.fromList [1,2,3]^._head -- 1 _head :: SimpleLens (Vector a) a -_head f v = (\a -> v // [(0,a)]) <$> f (head v) +_head f v = f (head v) <&> \a -> v // [(0,a)] {-# INLINE _head #-} -- | A 'Lens' reading and writing to the 'last' element of a /non-empty/ 'Vector' @@ -59,7 +58,7 @@ -- >>> Vector.fromList [1,2]^._last -- 2 _last :: SimpleLens (Vector a) a -_last f v = (\a -> v // [(length v - 1, a)]) <$> f (last v) +_last f v = f (last v) <&> \a -> v // [(length v - 1, a)] {-# INLINE _last #-} -- | A lens reading and writing to the 'tail' of a /non-empty/ 'Vector' @@ -69,7 +68,7 @@ -- >>> _tail .~ Vector.fromList [3,4,5] $ Vector.fromList [1,2] -- fromList [1,3,4,5] _tail :: SimpleLens (Vector a) (Vector a) -_tail f v = cons (head v) <$> f (tail v) +_tail f v = f (tail v) <&> cons (head v) {-# INLINE _tail #-} -- | A 'Lens' reading and replacing all but the a 'last' element of a /non-empty/ 'Vector' @@ -79,7 +78,7 @@ -- >>> Vector.fromList [1,2,3,4]^._init -- fromList [1,2,3] _init :: SimpleLens (Vector a) (Vector a) -_init f v = (`snoc` last v) <$> f (init v) +_init f v = f (init v) <&> (`snoc` last v) {-# INLINE _init #-} -- | @sliced i n@ provides a lens that edits the @n@ elements starting at index @i@ from a lens. @@ -90,7 +89,7 @@ sliced :: Int -- ^ @i@ starting index -> Int -- ^ @n@ length -> SimpleLens (Vector a) (Vector a) -sliced i n f v = (\ v0 -> v // zip [i..i+n-1] (toList v0)) <$> f (slice i n v) +sliced i n f v = f (slice i n v) <&> \ v0 -> v // zip [i..i+n-1] (toList v0) {-# INLINE sliced #-} -- | Similar to 'toListOf', but returning a 'Vector'. @@ -100,24 +99,24 @@ -- | Convert a list to a 'Vector' (or back) vector :: Iso [a] [b] (Vector a) (Vector b) -vector = isos fromList toList fromList toList +vector = iso fromList toList {-# INLINE vector #-} -- | Convert a 'Vector' to a version with all the elements in the reverse order reversed :: Iso (Vector a) (Vector b) (Vector a) (Vector b) -reversed = isos reverse reverse reverse reverse +reversed = iso reverse reverse {-# INLINE reversed #-} -- | Convert a 'Vector' to a version that doesn't retain any extra memory. forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b) -forced = isos force force force force +forced = iso force force {-# INLINE forced #-} -- | This is a more efficient version of 'element' that works for any 'Vector'. -- -- @ordinal n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. ordinal :: Int -> SimpleIndexedLens Int (Vector a) a -ordinal i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) +ordinal i = indexed $ \ f v -> f i (v ! i) <&> \ a -> v // [(i, a)] {-# INLINE ordinal #-} -- | This 'Traversal' will ignore any duplicates in the supplied list of indices. @@ -125,7 +124,7 @@ -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] ordinals :: [Int] -> SimpleIndexedTraversal Int (Vector a) a -ordinals is = index $ \ f v -> let +ordinals is = indexed $ \ f v -> let l = length v is' = nub $ filter ( +-- package. ---------------------------------------------------------------------------- module GHC.Generics.Lens ( @@ -37,8 +44,13 @@ import Control.Lens hiding (Rep) import Data.Maybe (fromJust) import Data.Typeable +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 import qualified GHC.Generics as Generic -import GHC.Generics hiding (from, to) +import GHC.Generics hiding (from, to) +#else +import qualified Generics.Deriving as Generic +import Generics.Deriving hiding (from, to) +#endif -- | Convert from the data type to its representation (or back) -- @@ -52,7 +64,7 @@ generic1 :: Generic1 f => Simple Iso (f a) (Rep1 f a) generic1 = iso from1 to1 --- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurence +-- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurrence -- of something 'Typeable' anywhere in a container. -- -- >>> allOf tinplate (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"]) diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} #endif @@ -29,9 +28,10 @@ import Control.Lens.Getter import Control.Lens.Setter import Control.Lens.Fold +import Control.Lens.IndexedLens +import Control.Lens.IndexedTraversal import Control.Lens.Type import Control.Lens.Traversal -import Control.Lens.IndexedLens import Data.Map as Map hiding (toList,map) import Data.Maybe (fromMaybe) import Data.Monoid @@ -96,7 +96,7 @@ -- | Substitute using a map of names in for /free/ type variables substTypeVars :: HasTypeVars t => Map Name Name -> t -> t -substTypeVars m = mapOf typeVars $ \n -> fromMaybe n (m^.at n) +substTypeVars m = over typeVars $ \n -> fromMaybe n (m^.at n) -- | Provides substitution for types class SubstType t where diff --git a/tests/hunit.hs b/tests/hunit.hs --- a/tests/hunit.hs +++ b/tests/hunit.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} module Main where @@ -6,7 +7,6 @@ import Data.Char import Data.List as List import Data.Monoid -import Data.Monoid.Lens import Data.Map as Map import Test.Framework.Providers.HUnit import Test.Framework.TH diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -1,6 +1,9 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -13,12 +16,15 @@ import Test.QuickCheck.All import Test.QuickCheck.Function import Data.Text.Strict.Lens +import Data.List.Lens +import Data.Functor.Compose + setter_id :: Eq s => Simple Setter s a -> s -> Bool setter_id l s = runIdentity (l Identity s) == s setter_composition :: Eq s => Simple Setter s a -> s -> Fun a a -> Fun a a -> Bool -setter_composition l s (Fun _ f) (Fun _ g) = mapOf l f (mapOf l g s) == mapOf l (f . g) s +setter_composition l s (Fun _ f) (Fun _ g) = over l f (over l g s) == over l (f . g) s lens_set_view :: Eq s => Simple Lens s a -> s -> Bool lens_set_view l s = set l (view l s) s == s @@ -29,19 +35,40 @@ setter_set_set :: Eq s => Simple Setter s a -> s -> a -> a -> Bool setter_set_set l s a b = set l b (set l a s) == set l b s -iso_hither :: Eq s => Simple Iso s a -> s -> Bool -iso_hither l s = s ^.l.from l == s +iso_hither :: Eq s => Simple AnIso s a -> s -> Bool +iso_hither l s = s ^.cloneIso l.from l == s -iso_yon :: Eq a => Simple Iso s a -> a -> Bool -iso_yon l a = a^.from l.l == a +iso_yon :: Eq a => Simple AnIso s a -> a -> Bool +iso_yon l a = a^.from l.cloneIso l == a +prism_yen :: Eq a => Simple APrism s a -> a -> Bool +prism_yen l a = a^.remit l^?clonePrism l == Just a + +traverse_pure :: forall f s a. (Applicative f, Eq (f s)) => SimpleLensLike f s a -> s -> Bool +traverse_pure l s = l pure s == (pure s :: f s) + +traverse_pureMaybe :: Eq s => SimpleLensLike Maybe s a -> s -> Bool +traverse_pureMaybe = traverse_pure + +traverse_pureList :: Eq s => SimpleLensLike [] s a -> s -> Bool +traverse_pureList = traverse_pure + +traverse_compose :: (Applicative f, Applicative g, Eq (f (g s))) + => Simple Traversal s a -> (a -> g a) -> (a -> f a) -> s -> Bool +traverse_compose t f g s = (fmap (t f) . t g) s == (getCompose . t (Compose . fmap f . g)) s + isSetter :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) => Simple Setter s a -> Property isSetter l = setter_id l .&. setter_composition l .&. setter_set_set l isTraversal :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Function a) => Simple Traversal s a -> Property -isTraversal l = isSetter l +isTraversal l = isSetter l .&. traverse_pureMaybe l .&. traverse_pureList l + .&. do as <- arbitrary + bs <- arbitrary + t <- arbitrary + property $ traverse_compose l (\x -> as++[x]++bs) + (\x -> if t then Just x else Nothing) isLens :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) => Simple Lens s a -> Property @@ -51,6 +78,10 @@ => Simple Iso s a -> Property isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) +isPrism :: (Arbitrary s, Arbitrary a, CoArbitrary a, Show s, Show a, Eq s, Eq a, Function a) + => Simple Prism s a -> Property +isPrism l = isTraversal l .&. prism_yen l + -- an illegal lens bad :: Simple Lens (Int,Int) Int bad f (a,b) = (,) b <$> f a @@ -81,8 +112,19 @@ prop_traverseLeft = isTraversal (_left :: Simple Traversal (Either Int Bool) Int) prop_traverseRight = isTraversal (_right :: Simple Traversal (Either Int Bool) Bool) +prop_simple = isIso (simple :: Simple Iso Int Int) +--prop_enum = isIso (enum :: Simple Iso Int Char) + +prop__left = isPrism (_left :: Simple Prism (Either Int Bool) Int) +prop__right = isPrism (_right :: Simple Prism (Either Int Bool) Bool) +prop__just = isPrism (_just :: Simple Prism (Maybe Int) Int) + +-- Data.List.Lens +prop_strippingPrefix s = isPrism (strippingPrefix s :: Simple Prism String String) + -- Data.Text.Lens prop_text s = s^.packed.from packed == s +--prop_text = isIso packed main :: IO () main = do diff --git a/tests/templates.hs b/tests/templates.hs --- a/tests/templates.hs +++ b/tests/templates.hs @@ -1,4 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} -- | The commented code summarizes what will be auto-generated below module Main where @@ -54,7 +59,7 @@ makeLensesFor [("taskOutput", "outputLens"), ("taskState", "stateLens"), ("taskStop", "stopLens")] ''Task -data Mono = Mono { _monoFoo :: Int, _monoBar :: Int } +data Mono a = Mono { _monoFoo :: a, _monoBar :: Int } makeClassy ''Mono -- class HasMono t where -- mono :: Simple Lens t Mono @@ -63,14 +68,14 @@ -- monoFoo :: HasMono t => Simple Lens t Int -- monoBar :: HasMono t => Simple Lens t Int -data Nucleosis = Nucleosis { _nuclear :: Mono } +data Nucleosis = Nucleosis { _nuclear :: Mono Int } makeClassy ''Nucleosis -- class HasNucleosis t where -- nucleosis :: Simple Lens t Nucleosis -- instance HasNucleosis Nucleosis -- nuclear :: HasNucleosis t => Simple Lens t Mono -instance HasMono Nucleosis where +instance HasMono Nucleosis Int where mono = nuclear -- Dodek's example