diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,25 @@ +lens +==== + +[![Build Status](https://secure.travis-ci.org/ekmett/lens.png?branch=master)](http://travis-ci.org/ekmett/lens) + +This package provides families of lenses, isomorphisms, folds, traversals, getters and setters. + +These lenses are compatible with those from lens-family, lens-family-core and lens-family-th, +but they provide a great deal of additional flexibility in their composition. + +Example +------- + + ghci> :m + Control.Lens Data.Text.Lens + ghci> anyOf (traverse.text) (=='y') ["hello"^.packed, "goodbye"^.packed] + True + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. + +-Edward Kmett diff --git a/examples/Pong.hs b/examples/Pong.hs --- a/examples/Pong.hs +++ b/examples/Pong.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, Rank2Types #-} +{-# LANGUAGE TemplateHaskell, Rank2Types, NoMonomorphismRestriction #-} import Control.Applicative ((<$>), (<*>)) import Control.Lens @@ -16,15 +16,18 @@ -- Some global constants -gameSize = 300 -windowSize = 480 -ballRadius = 0.02 -speedIncrease = 1.1 -initialSpeed = 0.5 -paddleWidth = 0.02 -paddleHeight = 0.3 -paddleSpeed = 1 -textSize = 0.001 +gameSize = 300 +windowWidth = 800 +windowHeight = 600 +ballRadius = 0.02 +speedIncrease = 1.2 +losingAccuracy = 0.7 +winningAccuracy = 0.3 +initialSpeed = 0.6 +paddleWidth = 0.02 +paddleHeight = 0.3 +paddleSpeed = 1 +textSize = 0.001 -- Pure data type for representing the game state @@ -43,6 +46,12 @@ -- Some nice lenses to go with it makeLenses ''Pong +ahead (i, j) = i <= j + +accuracy p + | ahead (p^.score) = winningAccuracy + | otherwise = losingAccuracy + -- Renamed tuple lenses for enhanced clarity with points/vectors _x = _1 _y = _2 @@ -89,7 +98,7 @@ p <- get let paddleMovement = time * paddleSpeed - let keyPressed key = p^.keys.contains (SpecialKey key) + keyPressed key = p^.keys.contains (SpecialKey key) -- Update the player's paddle based on keys when (keyPressed KeyUp) $ paddle1 += paddleMovement @@ -97,7 +106,9 @@ -- Calculate the optimal position let optimal = hitPos (p^.ballPos) (p^.ballSpeed) - let dist = optimal - p^.paddle2 + acc = accuracy p + target = optimal * acc + (p^.ballPos._y) * (1 - acc) + dist = target - p^.paddle2 -- Move the CPU's paddle towards this optimal position as needed when (abs dist > paddleHeight/3) $ @@ -125,16 +136,14 @@ ballSpeed._y %= negate -- Check for collisions with paddles - let { check paddle other = - if y >= p^.paddle - paddleHeight/2 && y <= p^.paddle + paddleHeight/2 - then do - ballSpeed._x %= negate - ballSpeed.both *= speedIncrease - - else do - score.other += 1 - reset - } + let check paddle other + | y >= p^.paddle - paddleHeight/2 && y <= p^.paddle + paddleHeight/2 = do + ballSpeed._x %= negate + ballSpeed._y += 3*(y - p^.paddle) -- add english + ballSpeed.both *= speedIncrease + | otherwise = do + score.other += 1 + reset when (x >= edge) $ check paddle2 _1 when (x <= -edge) $ check paddle1 _2 @@ -194,7 +203,7 @@ play display backColor fps world draw handle update where - display = InWindow "Pong!" (windowSize, windowSize) (200, 200) + display = InWindow "Pong!" (windowWidth, windowHeight) (200, 200) backColor = white fps = 120 diff --git a/examples/Test.hs b/examples/Test.hs deleted file mode 100644 --- a/examples/Test.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Test where - -import Control.Lens -import Control.Lens.TH - -data Foo a = Foo a -makeLenses ''Foo - -data Bar a b c = Bar { _baz :: (a, b) } -makeLenses ''Bar - -data Quux a b = Quux { _quaffle :: Int, _quartz :: Double } -makeLenses ''Quux - -data Quark a = Qualified { _gaffer :: a } - | Unqualified { _gaffer :: a, blockingGaffer :: a } -makeLenses ''Quark - -data LensCrafted a = Still { _still :: a } - | Works { _still :: a } -makeLenses ''LensCrafted - -data Mono = Mono { _monoFoo :: Int, _monoBar :: Int } -makeClassy ''Mono - -data Nucleosis = Nucleosis { _nuclear :: Mono } -makeClassy ''Nucleosis - -instance HasMono Nucleosis where - mono = nuclear diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses -version: 1.6 +version: 1.7 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -44,8 +44,18 @@ build-type: Simple tested-with: GHC == 7.4.1 -extra-source-files: .travis.yml examples/Pong.hs examples/Test.hs +extra-source-files: + .travis.yml + examples/*.hs + test/*.hs + README.markdown +-- Build examples +flag examples + default: False + manual: True + + source-repository head type: git location: git://github.com/ekmett/lens.git @@ -60,12 +70,18 @@ exposed-modules: Control.Exception.Lens Control.Lens - Control.Lens.Internal - Control.Lens.Representable + Control.Lens.Action Control.Lens.Fold Control.Lens.Getter Control.Lens.Indexed + Control.Lens.IndexedGetter + Control.Lens.IndexedFold + Control.Lens.IndexedLens + Control.Lens.IndexedSetter + Control.Lens.IndexedTraversal + Control.Lens.Internal Control.Lens.Iso + Control.Lens.Representable Control.Lens.Setter Control.Lens.TH Control.Lens.Traversal @@ -121,12 +137,48 @@ ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields hs-source-dirs: src +-- Verify the results of the '>>>'s distributed throughout test-suite doctests - type: exitcode-stdio-1.0 - main-is: doctests.hs + type: exitcode-stdio-1.0 + main-is: doctests.hs + build-depends: + base == 4.*, + doctest >= 0.8 && <= 0.9 + ghc-options: -Wall -Werror -threaded + hs-source-dirs: test - build-depends: base == 4.*, - doctest >= 0.8 && <= 0.9 +-- Verify that Template Haskell expansion works +test-suite templates + type: exitcode-stdio-1.0 + main-is: templates.hs + build-depends: + base == 4.*, + lens == 1.7 + ghc-options: -Wall -Werror -threaded + hs-source-dirs: test - ghc-options: -Wall -Werror -threaded - hs-source-dirs: test +-- Verify the properties of lenses with QuickCheck +test-suite properties + type: exitcode-stdio-1.0 + main-is: properties.hs + build-depends: + base == 4.*, + lens == 1.7, + QuickCheck >= 2.4 && < 2.6, + transformers >= 0.3 && < 0.5 + ghc-options: -w -threaded + hs-source-dirs: test + +executable pong + if !flag(examples) + buildable: False + + build-depends: + base == 4.*, + containers >= 0.4.2 && < 0.6, + gloss == 1.7.*, + lens == 1.7, + mtl >= 2.0.1 && < 2.2, + random == 1.0.* + main-is: Pong.hs + hs-source-dirs: examples 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 @@ -5,7 +5,7 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional --- Portability : portable +-- Portability : Control.Exception -- ---------------------------------------------------------------------------- module Control.Exception.Lens @@ -20,8 +20,10 @@ -- Traverse the strongly typed 'Exception' contained in 'SomeException' where the type of your function matches -- the desired 'Exception'. -- --- > traverseException :: (Applicative f, Exception a, Exception b) --- > => (a -> f b) -> SomeException -> f SomeException +-- @ +-- traverseException :: ('Applicative' f, 'Exception' a, 'Exception' b) +-- => (a -> f b) -> 'SomeException' -> f 'SomeException' +-- @ traverseException :: (Exception a, Exception b) => Traversal SomeException SomeException a b traverseException f e = case fromException e of Just a -> toException <$> f a diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -51,9 +51,15 @@ , module Control.Lens.Traversal , module Control.Lens.Getter , module Control.Lens.Setter + , module Control.Lens.Action , module Control.Lens.Fold , module Control.Lens.Iso , 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.Representable , module Control.Lens.TH ) where @@ -62,8 +68,14 @@ import Control.Lens.Traversal import Control.Lens.Getter import Control.Lens.Setter +import Control.Lens.Action import Control.Lens.Fold import Control.Lens.Iso import Control.Lens.Indexed +import Control.Lens.IndexedFold +import Control.Lens.IndexedGetter +import Control.Lens.IndexedLens +import Control.Lens.IndexedTraversal +import Control.Lens.IndexedSetter import Control.Lens.Representable import Control.Lens.TH diff --git a/src/Control/Lens/Action.hs b/src/Control/Lens/Action.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Action.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Action +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : MTPCs, FDs, Rank2 +-- +---------------------------------------------------------------------------- +module Control.Lens.Action + ( + -- * Composable Actions + Action + , act + , acts + , perform + , liftAct + , (^!) + + -- * Folds with Effecs + , MonadicFold + + -- * Implementation Details + , Acting + , Effective(..) + , ineffective + , Effect(..) + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Lens.Getter +import Control.Lens.Iso +import Control.Monad +import Control.Monad.Trans.Class +import Data.Functor.Identity +import Data.Monoid + +infixr 8 ^! + +-- | An 'Action' is a 'Getter' enriched with access to a 'Monad' for side-effects. +-- +-- Every 'Getter' can be used as an 'Action' +-- +-- You can compose an 'Action' with another 'Action' using ('Prelude..') from the @Prelude@. +type Action m a c = forall f b r d. Effective m r f => (c -> f d) -> a -> f b + +-- | A 'MonadicFold' is a 'Fold' enriched with access to a 'Monad' for side-effects. +-- +-- Every 'Fold' can be used as a 'MonadicFold', that simply ignores the access to the 'Monad'. +-- +-- You can compose a 'MonadicFold' with another 'MonadicFold' using ('Prelude..') from the @Prelude@. +type MonadicFold m a c = forall f b r d. (Effective m r f, Applicative f) => (c -> f d) -> a -> f b + +-- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a monad wrapped around a value. +-- +-- 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 #-} + +instance Effective Identity r (Accessor r) where + effective = isomorphic (Accessor . runIdentity) (Identity . runAccessor) + {-# INLINE effective #-} + {-# SPECIALIZE effective :: Identity r -> Accessor r a #-} + {-# SPECIALIZE effective :: Isomorphism (Identity r) (Accessor r a) #-} + +instance Effective m r f => Effective m (Dual r) (Backwards f) where + effective = isomorphic (Backwards . effective . liftM getDual) (liftM Dual . ineffective . forwards) + +-- | Wrap a monadic effect with a phantom type argument. +newtype Effect m r a = Effect { getEffect :: m r } + +instance Monad m => Functor (Effect m r) where + fmap _ (Effect m) = Effect m + +instance (Monad m, Monoid r) => Monoid (Effect m r a) where + mempty = Effect (return mempty) + Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb) + +instance (Monad m, Monoid r) => Applicative (Effect m r) where + pure _ = Effect (return mempty) + Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb) + +instance Monad m => Gettable (Effect m r) where + coerce (Effect m) = Effect m + +instance Monad m => Effective m r (Effect m r) where + effective = isomorphic Effect getEffect + {-# SPECIALIZE effective :: Monad m => m r -> Effect m r a #-} + {-# SPECIALIZE effective :: Monad m => Isomorphism (m r) (Effect m r a) #-} + +-- | Used to evaluate an 'Action'. +type Acting m r a b c d = (c -> Effect m r d) -> a -> Effect m r b + +-- | Perform an 'Action'. +-- +-- > perform = flip (^!) +-- +perform :: Monad m => Acting m c a b c d -> a -> m c +perform l = getEffect . l (Effect . return) +{-# INLINE perform #-} + +-- | Perform an 'Action' +-- +-- >>> import Control.Lens +-- +-- >>> ["hello","world"]^!folded.act putStrLn +-- hello +-- world +-- +(^!) :: Monad m => a -> Acting m c a b c d -> m c +a ^! l = getEffect (l (Effect . return) a) +{-# INLINE (^!) #-} + +-- | Construct an 'Action' from a monadic side-effect +act :: Monad m => (a -> m c) -> Action m a c +act amc cfd a = effective (amc a >>= from effective . cfd) +{-# INLINE act #-} + +-- | A self-running 'Action', analogous to 'Control.Monad.join'. +-- +-- @'acts' = 'act' 'id'@ +-- +-- >>> import Control.Lens +-- +-- >>> (1,"hello")^!_2.acts.to succ +-- "ifmmp" +acts :: Action m (m a) a +acts = act id +{-# INLINE acts #-} + +-- | Apply a 'Monad' transformer to an 'Action'. +liftAct :: (MonadTrans t, Monad m) => Acting m c a b c d -> Action (t m) a c +liftAct l = act (lift . perform l) +{-# INLINE liftAct #-} 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 @@ -1,10 +1,10 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ +---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold -- Copyright : (C) 2012 Edward Kmett @@ -16,16 +16,16 @@ -- A @'Fold' a c@ is a generalization of something 'Foldable'. It allows you to -- extract multiple results from a container. A 'Foldable' container can be -- characterized by the behavior of @foldMap :: ('Foldable' t, 'Monoid' m) => (c -> m) -> t c -> m@. --- Since we want to be able to work with monomorphic containers, we generalize this signature to --- @forall m. 'Monoid' m => (c -> m) -> a -> m@, and then decorate it with 'Const' to obtain +-- Since we want to be able to work with monomorphic containers, we could generalize this signature to +-- @forall m. 'Monoid' m => (c -> m) -> a -> m@, and then decorate it with 'Accessor' to obtain -- -- @type 'Fold' a c = forall m b d. 'Monoid' m => 'Getting' m a b c d@ -- --- In practice the type we use is slightly more complicated to allow for better error messages and --- for it to be transformed by certain 'Applicative' transformers. --- -- Every 'Getter' is a valid 'Fold' that simply doesn't use the 'Monoid' it is passed. -- +-- But in practice the type we use is slightly more complicated to allow for better error messages +-- and for it to be transformed by certain 'Applicative' transformers. +-- -- Everything you can do with a 'Foldable' container, you can with with a 'Fold' and there are -- combinators that generalize the usual 'Foldable' operations here. ---------------------------------------------------------------------------- @@ -33,9 +33,8 @@ ( -- * Folds Fold - , Furled(..) -- ** Building Folds - , folds + --, folds , folding , folded , unfolded @@ -96,29 +95,13 @@ -- -- A 'Getter' is a legal 'Fold' that just ignores the supplied 'Monoid' -- --- Unlike a 'Traversal' a 'Fold' is read-only. Since a 'Fold' cannot be used to write back +-- Unlike a 'Control.Lens.Traversal.Traversal' a 'Fold' is read-only. Since a 'Fold' cannot be used to write back -- there are no lens laws that apply. -type Fold a c = forall r f b d. (Applicative f, Monoid r, Furled r f) => (c -> f d) -> a -> f b - --- | Something we can fold. -class Gettable f => Furled r f | f -> r where - furled :: r -> f a - unfurled :: f a -> r - -instance Furled r (Accessor r) where - furled = Accessor - unfurled = runAccessor - -instance Furled r f => Furled (Dual r) (Backwards f) where - furled = Backwards . furled . getDual - unfurled = Dual . unfurled . forwards +type Fold a c = forall f b d. (Gettable f, Applicative f) => (c -> f d) -> a -> f b --- | Build a 'Getter' or 'Fold' from a 'foldMap'-like function. --- --- > folds :: ((c -> r) -> a -> r) -> (c -> Accessor m d) -> a -> Const m b -folds :: Furled r f => ((c -> r) -> a -> r) -> LensLike f a b c d -folds l f = furled . l (unfurled . f) -{-# INLINE folds #-} +noEffect :: (Applicative f, Gettable f) => f a +noEffect = coerce $ pure () +{-# INLINE noEffect #-} -- | Obtain a 'Fold' by lifting an operation that returns a foldable result. -- @@ -127,44 +110,52 @@ folding afc cgd = coerce . traverse_ cgd . afc {-# INLINE folding #-} +-- | A monoid in a monad as a monoid +newtype GA f a = GA { getGA :: f a } + +instance (Gettable f, Applicative f) => Monoid (GA f a) where + mempty = GA noEffect + {-# INLINE mempty #-} + GA fr `mappend` GA fs = GA (fr *> fs) + {-# INLINE mappend #-} + -- | Obtain a 'Fold' from any 'Foldable'. --- --- > folded = folds foldMap folded :: Foldable f => Fold (f c) c -folded = folds foldMap +folded f = coerce . getGA . foldMap (GA . f) {-# INLINE folded #-} -- | Fold by repeating the input forever. -- --- > repeat = toListOf repeated +-- @'repeat' = 'toListOf' 'repeated'@ repeated :: Fold a a -repeated f a = furled as where as = unfurled (f a) `mappend` as +repeated f a = as where as = f a *> as -- | A fold that replicates its input @n@ times. -- --- > replicate n = toListOf (replicated n) +-- @'replicate' n = 'toListOf' ('replicated' n)@ replicated :: Int -> Fold a a -replicated n0 f a = furled (go n0) where - m = unfurled (f a) - go 0 = mempty - go n = m `mappend` go (n - 1) +replicated n0 f a = go n0 where + m = f a + go 0 = noEffect + go n = m *> go (n - 1) {-# INLINE replicated #-} -- | Transform a fold into a fold that loops over its elements over and over. -- --- > ghci> toListOf (cycled traverse) [1,2,3] --- > [1,2,3,1,2,3,..] -cycled :: (Furled r f, Monoid r) => LensLike f a b c d -> LensLike f a b c d -cycled l f a = furled as where as = unfurled (l f a) `mappend` as +-- >>> import Control.Lens +-- >>> take 6 $ toListOf (cycled traverse) [1,2,3] +-- [1,2,3,1,2,3] +cycled :: (Applicative f, Gettable f) => LensLike f a b c d -> LensLike f a b c d +cycled l f a = as where as = l f a *> as -- | Build a fold that unfolds its values from a seed. -- --- > ghci> unfoldr = toListOf . unfolded +-- @'Prelude.unfoldr' = 'toListOf' . 'unfolded'@ unfolded :: (b -> Maybe (a, b)) -> Fold b a unfolded f g b0 = go b0 where go b = case f b of Just (a, b') -> g a *> go b' - Nothing -> furled mempty + Nothing -> noEffect {-# INLINE unfolded #-} -- | @x ^. 'iterated' f@ Return an infinite fold of repeated applications of @f@ to @x@. @@ -175,38 +166,46 @@ go a = g a *> go (f a) {-# INLINE iterated #-} --- | Obtain a 'Fold' by filtering a 'Lens', 'Iso', 'Getter', 'Fold' or 'Traversal'. -filtered :: (Furled r f, Monoid r) => (c -> Bool) -> LensLike f a b c d -> LensLike f a b c d -filtered p l f = l $ \c -> furled (if p c then unfurled (f c) else mempty) +-- | Obtain a 'Fold' by filtering a 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Getter', 'Fold' or 'Control.Lens.Traversal.Traversal'. +filtered :: (Gettable f, Applicative f) => (c -> Bool) -> LensLike f a b c d -> LensLike f a b c d +filtered p l f = l $ \c -> if p c then f c + else noEffect {-# INLINE filtered #-} --- | This allows you to traverse the elements of a 'Traversal' or 'Fold' in the opposite order. +-- | This allows you to traverse the elements of a 'Control.Lens.Traversal.Traversal' or 'Fold' in the opposite order. -- --- Note: 'backwards' should have no impact on a 'Getter' 'Setter', 'Lens' or 'Iso'. +-- Note: 'backwards' should have no impact on a 'Getter' 'Setter', 'Control.Lens.Type.Lens' or 'Control.Lens.Iso.Iso'. -- --- To change the direction of an 'Iso', use 'from'. +-- To change the direction of an 'Control.Lens.Iso.Iso', use 'from'. backwards :: LensLike (Backwards f) a b c d -> LensLike f a b c d backwards l f = forwards . l (Backwards . f) {-# INLINE backwards #-} --- | Obtain a 'Fold' by taking elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. +-- | Obtain a 'Fold' by taking elements from another 'Fold', 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Getter' or 'Control.Lens.Traversal.Traversal' while a predicate holds. -- --- > takeWhile p = toListOf (takingWhile p folded) +-- @'takeWhile' p = 'toListOf' ('takingWhile' p 'folded')@ -- --- > ghci> toList (takingWhile (<=3) folded) [1..] --- > [1,2,3] -takingWhile :: (Monoid r, Furled r f) => (c -> Bool) -> Getting (Endo r) a b c d -> LensLike f a b c d -takingWhile p l f = furled . foldrOf l (\a r -> if p a then unfurled (f a) `mappend` r else mempty) mempty +-- >>> toListOf (takingWhile (<=3) folded) [1..] +-- [1,2,3] +takingWhile :: (Gettable f, Applicative f) + => (c -> Bool) + -> Getting (Endo (f b)) a b c d + -> LensLike f a b c d +takingWhile p l f = foldrOf l (\a r -> if p a then f a *> r else noEffect) noEffect {-# INLINE takingWhile #-} --- | Obtain a 'Fold' by dropping elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. + +-- | Obtain a 'Fold' by dropping elements from another 'Fold', 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Getter' or 'Control.Lens.Traversal.Traversal' while a predicate holds. -- --- > dropWhile p = toListOf (droppingWhile p folded) +-- @'dropWhile' p = 'toListOf' ('droppingWhile' p 'folded')@ -- --- > ghci> toList (dropWhile (<=3) folded) [1..6] --- > [4,5,6] -droppingWhile :: (Monoid r, Furled r f) => (c -> Bool) -> Getting (Endo r) a b c d -> LensLike f a b c d -droppingWhile p l f = furled . foldrOf l (\a r -> if p a then mempty else mappend r (unfurled (f a))) mempty +-- >>> toListOf (droppingWhile (<=3) folded) [1..6] +-- [4,5,6] +droppingWhile :: (Gettable f, Applicative f) + => (c -> Bool) + -> Getting (Endo (f b)) a b c d + -> LensLike f a b c d +droppingWhile p l f = foldrOf l (\a r -> if p a then r else f a *> r) noEffect {-# INLINE droppingWhile #-} -------------------------- @@ -214,9 +213,9 @@ -------------------------- -- | --- > foldMap = foldMapOf folded +-- @'Data.Foldable.foldMap' = 'foldMapOf' 'folded'@ -- --- > foldMapOf = views +-- @'foldMapOf' = 'views'@ -- -- > foldMapOf :: Getter a c -> (c -> r) -> a -> r -- > foldMapOf :: Monoid r => Fold a c -> (c -> r) -> a -> r @@ -228,9 +227,9 @@ {-# INLINE foldMapOf #-} -- | --- > fold = foldOf folded +-- @'Data.Foldable.fold' = 'foldOf' 'folded'@ -- --- > foldOf = view +-- @'foldOf' = 'view'@ -- -- > foldOf :: Getter a m -> a -> m -- > foldOf :: Monoid m => Fold a m -> a -> m @@ -242,9 +241,9 @@ {-# INLINE foldOf #-} -- | --- Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. +-- Right-associative fold of parts of a structure that are viewed through a 'Control.Lens.Type.Lens', 'Getter', 'Fold' or 'Control.Lens.Traversal.Traversal'. -- --- > foldr = foldrOf folded +-- @'Data.Foldable.foldr' = 'foldrOf' 'folded'@ -- -- > foldrOf :: Getter a c -> (c -> e -> e) -> e -> a -> e -- > foldrOf :: Fold a c -> (c -> e -> e) -> e -> a -> e @@ -256,9 +255,9 @@ {-# INLINE foldrOf #-} -- | --- Left-associative fold of the parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. +-- Left-associative fold of the parts of a structure that are viewed through a 'Control.Lens.Type.Lens', 'Getter', 'Fold' or 'Control.Lens.Traversal.Traversal'. -- --- > foldl = foldlOf folded +-- @'Data.Foldable.foldl' = 'foldlOf' 'folded'@ -- -- > foldlOf :: Getter a c -> (e -> c -> e) -> e -> a -> e -- > foldlOf :: Fold a c -> (e -> c -> e) -> e -> a -> e @@ -270,7 +269,7 @@ {-# INLINE foldlOf #-} -- | --- > toList = toListOf folded +-- @'Data.Foldable.toList' = 'toListOf' 'folded'@ -- -- > toListOf :: Getter a c -> a -> [c] -- > toListOf :: Fold a c -> a -> [c] @@ -282,7 +281,7 @@ {-# INLINE toListOf #-} -- | --- > and = andOf folded +-- @'Data.Foldable.and' = 'andOf' 'folded'@ -- -- > andOf :: Getter a Bool -> a -> Bool -- > andOf :: Fold a Bool -> a -> Bool @@ -294,7 +293,7 @@ {-# INLINE andOf #-} -- | --- > or = orOf folded +-- @'Data.Foldable.or' = 'orOf' 'folded'@ -- -- > orOf :: Getter a Bool -> a -> Bool -- > orOf :: Fold a Bool -> a -> Bool @@ -306,7 +305,7 @@ {-# INLINE orOf #-} -- | --- > any = anyOf folded +-- @'Data.Foldable.any' = 'anyOf' 'folded'@ -- -- > anyOf :: Getter a c -> (c -> Bool) -> a -> Bool -- > anyOf :: Fold a c -> (c -> Bool) -> a -> Bool @@ -318,7 +317,7 @@ {-# INLINE anyOf #-} -- | --- > all = allOf folded +-- @'Data.Foldable.all' = 'allOf' 'folded'@ -- -- > allOf :: Getter a c -> (c -> Bool) -> a -> Bool -- > allOf :: Fold a c -> (c -> Bool) -> a -> Bool @@ -330,7 +329,7 @@ {-# INLINE allOf #-} -- | --- > product = productOf folded +-- @'Data.Foldable.product' = 'productOf' 'folded'@ -- -- > productOf :: Getter a c -> a -> c -- > productOf :: Num c => Fold a c -> a -> c @@ -342,11 +341,12 @@ {-# INLINE productOf #-} -- | --- > sum = sumOf folded +-- @'Data.Foldable.sum' = 'sumOf' 'folded'@ -- --- > sumOf _1 :: (a, b) -> a --- > sumOf (folded._1) :: (Foldable f, Num a) => f (a, b) -> a +-- @'sumOf' '_1' :: (a, b) -> a@ -- +-- @'sumOf' ('folded' . '_1') :: ('Foldable' f, 'Num' a) => f (a, b) -> a@ +-- -- > sumOf :: Getter a c -> a -> c -- > sumOf :: Num c => Fold a c -> a -> c -- > sumOf :: Lens a b c d -> a -> c @@ -362,11 +362,12 @@ -- -- When passed a 'Fold', 'traverseOf_' requires an 'Applicative'. -- --- > traverse_ = traverseOf_ folded +-- @'Data.Foldable.traverse_' = 'traverseOf_' 'folded'@ -- --- > traverseOf_ _2 :: Functor f => (c -> f e) -> (c1, c) -> f () --- > traverseOf_ traverseLeft :: Applicative f => (a -> f b) -> Either a c -> f () +-- @'traverseOf_' '_2' :: 'Functor' f => (c -> f e) -> (c1, c) -> f ()@ -- +-- @'traverseOf_' 'Data.Either.Lens.traverseLeft' :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f ()@ +-- -- The rather specific signature of traverseOf_ allows it to be used as if the signature was either: -- -- > traverseOf_ :: Functor f => Getter a c -> (c -> f e) -> a -> f () @@ -379,7 +380,7 @@ {-# INLINE traverseOf_ #-} -- | --- > for_ = forOf_ folded +-- @'for_' = 'forOf_' 'folded'@ -- -- > forOf_ :: Functor f => Getter a c -> a -> (c -> f e) -> f () -- > forOf_ :: Applicative f => Fold a c -> a -> (c -> f e) -> f () @@ -391,7 +392,7 @@ {-# INLINE forOf_ #-} -- | --- > sequenceA_ = sequenceAOf_ folded +-- @'sequenceA_' = 'sequenceAOf_' 'folded'@ -- -- > sequenceAOf_ :: Functor f => Getter a (f ()) -> a -> f () -- > sequenceAOf_ :: Applicative f => Fold a (f ()) -> a -> f () @@ -403,7 +404,7 @@ {-# INLINE sequenceAOf_ #-} -- | --- > mapM_ = mapMOf_ folded +-- @'Data.Foldable.mapM_' = 'mapMOf_' 'folded'@ -- -- > mapMOf_ :: Monad m => Getter a c -> (c -> m e) -> a -> m () -- > mapMOf_ :: Monad m => Fold a c -> (c -> m e) -> a -> m () @@ -419,7 +420,7 @@ {-# INLINE skip #-} -- | --- > forM_ = forMOf_ folded +-- @'Data.Foldable.forM_' = 'forMOf_' 'folded'@ -- -- > forMOf_ :: Monad m => Getter a c -> a -> (c -> m e) -> m () -- > forMOf_ :: Monad m => Fold a c -> a -> (c -> m e) -> m () @@ -431,7 +432,7 @@ {-# INLINE forMOf_ #-} -- | --- > sequence_ = sequenceOf_ folded +-- @'Data.Foldable.sequence_' = 'sequenceOf_' 'folded'@ -- -- > sequenceOf_ :: Monad m => Getter a (m b) -> a -> m () -- > sequenceOf_ :: Monad m => Fold a (m b) -> a -> m () @@ -444,7 +445,7 @@ -- | The sum of a collection of actions, generalizing 'concatOf'. -- --- > asum = asumOf folded +-- @'asum' = 'asumOf' 'folded'@ -- -- > asumOf :: Alternative f => Getter a c -> a -> f c -- > asumOf :: Alternative f => Fold a c -> a -> f c @@ -457,7 +458,7 @@ -- | The sum of a collection of actions, generalizing 'concatOf'. -- --- > msum = msumOf folded +-- @'msum' = 'msumOf' 'folded'@ -- -- > msumOf :: MonadPlus m => Getter a c -> a -> m c -- > msumOf :: MonadPlus m => Fold a c -> a -> m c @@ -469,7 +470,7 @@ {-# INLINE msumOf #-} -- | --- > elem = elemOf folded +-- @'elem' = 'elemOf' 'folded'@ -- -- > elemOf :: Eq c => Getter a c -> c -> a -> Bool -- > elemOf :: Eq c => Fold a c -> c -> a -> Bool @@ -481,7 +482,7 @@ {-# INLINE elemOf #-} -- | --- > notElem = notElemOf folded +-- @'notElem' = 'notElemOf' 'folded'@ -- -- > notElemOf :: Eq c => Getter a c -> c -> a -> Bool -- > notElemOf :: Eq c => Fold a c -> c -> a -> Bool @@ -493,7 +494,7 @@ {-# INLINE notElemOf #-} -- | --- > concatMap = concatMapOf folded +-- @'concatMap' = 'concatMapOf' 'folded'@ -- -- > concatMapOf :: Getter a c -> (c -> [e]) -> a -> [e] -- > concatMapOf :: Fold a c -> (c -> [e]) -> a -> [e] @@ -505,7 +506,7 @@ {-# INLINE concatMapOf #-} -- | --- > concat = concatOf folded +-- @'concat' = 'concatOf' 'folded'@ -- -- > concatOf :: Getter a [e] -> a -> [e] -- > concatOf :: Fold a [e] -> a -> [e] @@ -519,12 +520,13 @@ -- | -- Note: this can be rather inefficient for large containers. -- --- > length = lengthOf folded +-- @'length' = 'lengthOf' 'folded'@ -- --- > lengthOf _1 :: (a, b) -> Int --- > lengthOf _1 = 1 --- > lengthOf (folded.folded) :: Foldable f => f (g a) -> Int +-- >>> lengthOf _1 ("hello",()) +-- 1 -- +-- @'lengthOf' ('folded' . 'folded') :: 'Foldable' f => f (g a) -> 'Int'@ +-- -- > lengthOf :: Getter a c -> a -> Int -- > lengthOf :: Fold a c -> a -> Int -- > lengthOf :: Lens a b c d -> a -> Int @@ -534,10 +536,10 @@ lengthOf l = getSum . foldMapOf l (\_ -> Sum 1) {-# INLINE lengthOf #-} --- | Perform a safe 'head' of a 'Fold' or 'Traversal' or retrieve 'Just' the result --- from a 'Getter' or 'Lens'. +-- | Perform a safe 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result +-- from a 'Getter' or 'Control.Lens.Type.Lens'. -- --- > listToMaybe . toList = headOf folded +-- @'Data.Maybe.listToMaybe' . 'toList' = 'headOf' 'folded'@ -- -- > headOf :: Getter a c -> a -> Maybe c -- > headOf :: Fold a c -> a -> Maybe c @@ -548,8 +550,8 @@ headOf l = getFirst . foldMapOf l (First . Just) {-# INLINE headOf #-} --- | Perform a safe 'last' of a 'Fold' or 'Traversal' or retrieve 'Just' the result --- from a 'Getter' or 'Lens'. +-- | Perform a safe 'last' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result +-- from a 'Getter' or 'Control.Lens.Type.Lens'. -- -- > lastOf :: Getter a c -> a -> Maybe c -- > lastOf :: Fold a c -> a -> Maybe c @@ -561,18 +563,19 @@ {-# INLINE lastOf #-} -- | --- Returns 'True' if this 'Fold' or 'Traversal' has no targets in the given container. +-- Returns 'True' if this 'Fold' or 'Control.Lens.Traversal.Traversal' has no targets in the given container. -- --- Note: nullOf on a valid 'Iso', 'Lens' or 'Getter' should always return 'False' +-- Note: 'nullOf' on a valid 'Control.Lens.Iso.Iso', 'Control.Lens.Type.Lens' or 'Getter' should always return 'False' -- --- > null = nullOf folded +-- @'null' = 'nullOf' 'folded'@ -- -- This may be rather inefficient compared to the 'null' check of many containers. -- --- > nullOf _1 :: (a, b) -> Int --- > nullOf _1 = False --- > nullOf (folded._1.folded) :: Foldable f => f (g a, b) -> Bool +-- >>> nullOf _1 (1,2) +-- False -- +-- @'nullOf' ('folded' . '_1' . 'folded') :: 'Foldable' f => f (g a, b) -> 'Bool'@ +-- -- > nullOf :: Getter a c -> a -> Bool -- > nullOf :: Fold a c -> a -> Bool -- > nullOf :: Iso a b c d -> a -> Bool @@ -583,11 +586,11 @@ {-# INLINE nullOf #-} -- | --- Obtain the maximum element (if any) targeted by a 'Fold' or 'Traversal' +-- Obtain the maximum element (if any) targeted by a 'Fold' or 'Control.Lens.Traversal.Traversal' -- --- Note: maximumOf on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. +-- Note: maximumOf on a valid 'Control.Lens.Iso.Iso', 'Control.Lens.Type.Lens' or 'Getter' will always return 'Just' a value. -- --- > maximum = fromMaybe (error "empty") . maximumOf folded +-- @'maximum' = 'fromMaybe' ('error' "empty") . 'maximumOf' 'folded'@ -- -- > maximumOf :: Getter a c -> a -> Maybe c -- > maximumOf :: Ord c => Fold a c -> a -> Maybe c @@ -599,11 +602,11 @@ {-# INLINE maximumOf #-} -- | --- Obtain the minimum element (if any) targeted by a 'Fold' or 'Traversal' +-- Obtain the minimum element (if any) targeted by a 'Fold' or 'Control.Lens.Traversal.Traversal' -- --- Note: minimumOf on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. +-- Note: minimumOf on a valid 'Control.Lens.Iso.Iso', 'Control.Lens.Type.Lens' or 'Getter' will always return 'Just' a value. -- --- > minimum = fromMaybe (error "empty") . minimumOf folded +-- @'minimum' = 'Data.Maybe.fromMaybe' ('error' "empty") . 'minimumOf' 'folded'@ -- -- > minimumOf :: Getter a c -> a -> Maybe c -- > minimumOf :: Ord c => Fold a c -> a -> Maybe c @@ -615,10 +618,10 @@ {-# INLINE minimumOf #-} -- | --- Obtain the maximum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso', +-- Obtain the maximum element (if any) targeted by a 'Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', -- or 'Getter' according to a user supplied ordering. -- --- > maximumBy cmp = fromMaybe (error "empty") . maximumByOf folded cmp +-- @'Data.Foldable.maximumBy' cmp = 'Data.Maybe.fromMaybe' ('error' "empty") . 'maximumByOf' 'folded' cmp@ -- -- > maximumByOf :: Getter a c -> (c -> c -> Ordering) -> a -> Maybe c -- > maximumByOf :: Fold a c -> (c -> c -> Ordering) -> a -> Maybe c @@ -632,7 +635,7 @@ {-# INLINE maximumByOf #-} -- | --- Obtain the minimum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso' +-- Obtain the minimum element (if any) targeted by a 'Fold', 'Control.Lens.Traversal.Traversal', 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso' -- or 'Getter' according to a user supplied ordering. -- -- > minimumBy cmp = fromMaybe (error "empty") . minimumByOf folded cmp @@ -648,7 +651,7 @@ step a (Just b) = Just (if cmp a b == GT then b else a) {-# INLINE minimumByOf #-} --- | The 'findOf' function takes a lens (or , getter, iso, fold, or traversal), +-- | The 'findOf' function takes a 'Control.Lens.Type.Lens' (or 'Control.Lens.Getter.Getter', 'Control.Lens.Iso.Iso', 'Control.Lens.Fold.Fold', or 'Control.Lens.Traversal.Traversal'), -- a predicate and a structure and returns the leftmost element of the structure -- matching the predicate, or 'Nothing' if there is no such element. -- @@ -669,9 +672,9 @@ -- to lenses and structures such that the lens views at least one element of -- the structure. -- --- > foldr1Of l f = Prelude.foldr1 f . toListOf l +-- @'foldr1Of' l f = 'Prelude.foldr1' f . 'toListOf' l@ -- --- > foldr1 = foldr1Of folded +-- @'Data.Foldable.foldr1' = 'foldr1Of' 'folded'@ -- -- > foldr1Of :: Getter a c -> (c -> c -> c) -> a -> c -- > foldr1Of :: Fold a c -> (c -> c -> c) -> a -> c @@ -688,9 +691,9 @@ -- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and strutures such -- that the lens views at least one element of the structure. -- --- > foldl1Of l f = Prelude.foldl1Of l f . toList +-- @'foldl1Of' l f = 'Prelude.foldl1Of' l f . 'toList'@ -- --- > foldl1 = foldl1Of folded +-- @'Data.Foldable.foldl1' = 'foldl1Of' 'folded'@ -- -- > foldl1Of :: Getter a c -> (c -> c -> c) -> a -> c -- > foldl1Of :: Fold a c -> (c -> c -> c) -> a -> c @@ -705,7 +708,7 @@ -- | Strictly fold right over the elements of a structure. -- --- > foldr' = foldrOf' folded +-- @'Data.Foldable.foldr'' = 'foldrOf'' 'folded'@ -- -- > foldrOf' :: Getter a c -> (c -> e -> e) -> e -> a -> e -- > foldrOf' :: Fold a c -> (c -> e -> e) -> e -> a -> e @@ -719,7 +722,7 @@ -- | Fold over the elements of a structure, associating to the left, but strictly. -- --- > foldl' = foldlOf' folded +-- @'Data.Foldable.foldl'' = 'foldlOf'' 'folded'@ -- -- > foldlOf' :: Getter a c -> (e -> c -> e) -> e -> a -> e -- > foldlOf' :: Fold a c -> (e -> c -> e) -> e -> a -> e @@ -734,7 +737,7 @@ -- | Monadic fold over the elements of a structure, associating to the right, -- i.e. from right to left. -- --- > foldrM = foldrMOf folded +-- @'Data.Foldable.foldrM' = 'foldrMOf' 'folded'@ -- -- > foldrMOf :: Monad m => Getter a c -> (c -> e -> m e) -> e -> a -> m e -- > foldrMOf :: Monad m => Fold a c -> (c -> e -> m e) -> e -> a -> m e @@ -751,7 +754,7 @@ -- | Monadic fold over the elements of a structure, associating to the left, -- i.e. from left to right. -- --- > foldlM = foldlMOf folded +-- @'Data.Foldable.foldlM' = 'foldlMOf' 'folded'@ -- -- > foldlMOf :: Monad m => Getter a c -> (e -> c -> m e) -> e -> a -> m e -- > foldlMOf :: Monad m => Fold a c -> (e -> c -> m e) -> e -> a -> m e 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 @@ -1,5 +1,4 @@ {-# LANGUAGE Rank2Types #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Getter @@ -13,18 +12,19 @@ -- A @'Getter' a c@ is just any function @(a -> c)@, which we've flipped into continuation -- passing style, @(c -> r) -> a -> r@ and decorated with 'Accessor' to obtain -- --- > type Getting r a b c d = (c -> Accessor r d) -> a -> Accessor r b +-- @type 'Getting' r a b c d = (c -> 'Accessor' r d) -> a -> 'Accessor' r b@ -- -- If we restrict access to knowledge about the type 'r' and can work for any d and b, we could get: -- --- > type Getter a c = forall r b d. Getting r a b c d +-- @type 'Getter' a c = forall r b d. 'Getting' r a b c d@ -- -- But we actually hide the use of 'Accessor' behind a class 'Gettable' to error messages from -- type class resolution rather than at unification time, where they are much uglier. --- type Getter a c = forall f b d. Gettable f => (c -> f d) -> a -> f b -- +-- @type 'Getter' a c = forall f b d. 'Gettable' f => (c -> f d) -> a -> f b@ +-- -- Everything you can do with a function, you can do with a 'Getter', but note that because of the --- continuation passing style @(.)@ composes them in the opposite order. +-- continuation passing style ('.') composes them in the opposite order. -- -- Since it is only a function, every 'Getter' obviously only retrieves a single value for a given -- input. @@ -54,10 +54,8 @@ import Control.Lens.Internal import Control.Monad.Reader.Class as Reader import Control.Monad.State.Class as State -import Data.Complex -- for tests import Data.Functor.Compose import Data.Monoid -import Control.Lens.Type -- for tests infixl 8 ^. infixr 0 ^$ @@ -69,17 +67,19 @@ -- | A 'Getter' describes how to retrieve a single value in a way that can be composed with -- other lens-like constructions. -- --- Unlike a 'Lens' a 'Getter' is read-only. Since a 'Getter' cannot be used to write back --- there are no lens laws that can be applied to it. +-- Unlike a 'Control.Lens.Type.Lens' a 'Getter' is read-only. Since a 'Getter' cannot be used to write back +-- there are no lens laws that can be applied to it. In fact, it is isomorphic to an arbitrary function from @(a -> c)@. -- --- Moreover, a 'Getter' can be used directly as a 'Fold', since it just ignores the 'Monoid'. +-- Moreover, a 'Getter' can be used directly as a 'Control.Lens.Fold.Fold', since it just ignores the 'Applicative'. type Getter a c = forall f b d. Gettable f => (c -> f d) -> a -> f b -- | Build a 'Getter' from an arbitrary Haskell function. -- --- > to f . to g = to (g . f) --- > a^.to f = f a +-- @'to' f . 'to' g = 'to' (g . f)@ -- +-- @a '^.' 'to' f = f a@ +-- +-- >>> import Control.Lens -- >>> (0, -5)^._2.to abs -- 5 to :: (a -> c) -> Getter a c @@ -87,23 +87,31 @@ {-# INLINE to #-} -- | --- Most 'Getter' combinators are able to be used with both a 'Getter' or a 'Fold' in +-- 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 with 'Lens', 'Traversal' and 'Iso' we also +-- extract with 'Const'. To be compatible with 'Control.Lens.Type.Lens', 'Control.Lens.Traversal.Traversal' and 'Control.Lens.Iso.Iso' we also -- restricted choices of the irrelevant b and d parameters. -- --- If a function accepts a @Getting m r a b c d@, then when @r@ is a Monoid, and @m@ is a --- 'Monad' you can pass a 'Fold' (or 'Traversal'), otherwise you can only pass this a --- 'Getter' or 'Lens'. +-- If a function accepts a @'Getting' m r a b c d@, then when @r@ is a 'Monoid', and @m@ is a +-- 'Monad' 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 a b c d = (c -> Accessor r d) -> a -> Accessor r b ----------------------------------------------------------------------------- -- Gettables & Accessors ----------------------------------------------------------------------------- --- | Generalizing Const so we can apply simple Applicative transformations to it +-- | Generalizing 'Const' so we can apply simple 'Applicative' transformations to it -- and so we can get nicer error messages +-- +-- A 'Gettable' 'Functor' ignores its argument, which it carries solely as a phantom +-- type parameter. +-- +-- To ensure this, it is required to satisfy: +-- +-- > id = fmap f = coerce class Functor f => Gettable f where + -- | Replace the phantom type argument. coerce :: f a -> f b instance Gettable (Const r) where @@ -115,14 +123,19 @@ instance (Functor f, Gettable g) => Gettable (Compose f g) where coerce = Compose . fmap coerce . getCompose +-- | This instance is a lie, but it is a useful lie. instance Gettable f => Gettable (ElementOf f) where coerce (ElementOf m) = ElementOf $ \i -> case m i of - Searching _ _ -> NotFound "coerced while searching" + Searching _ _ -> NotFound "coerced while searching" -- er... Found j as -> Found j (coerce as) NotFound s -> NotFound s --- | Used instead of Const to report 'no instance of (Settable Accessor)' when --- attempting to misuse a 'Setter' as a 'Getter'. +-- | Used instead of 'Const' to report +-- +-- @No instance of ('Control.Lens.Setter.Settable' 'Accessor')@ +-- +-- when the user attempts to misuse a 'Control.Lens.Setter.Setter' as a 'Getter', +-- rather than a monolithic unification error. newtype Accessor r a = Accessor { runAccessor :: r } instance Functor (Accessor r) where @@ -139,75 +152,87 @@ -- Getting Values ------------------------------- --- | View the value pointed to by a 'Getter', 'Iso' or 'Lens' or the result of folding over --- all the results of a 'Fold' or 'Traversal' that points at a monoidal values. +-- | 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 at a monoidal values. -- -- It may be useful to think of 'view' as having these more restrictive signatures: -- --- > view . to = id +-- @'view' . 'to' = 'id'@ -- +-- >>> import Control.Lens -- >>> view _2 (1,"hello") -- "hello" -- --- > view :: Getter a c -> a -> c --- > view :: Monoid m => Fold a m -> a -> m --- > view :: Iso a b c d -> a -> c --- > view :: Lens a b c d -> a -> c --- > view :: Monoid m => Traversal a b m d -> a -> m +-- @ +-- view :: 'Getter' a c -> a -> c +-- view :: 'Monoid' m => 'Control.Lens.Fold.Fold' a m -> a -> m +-- view :: 'Control.Lens.Iso.Iso' a b c d -> a -> c +-- view :: 'Control.Lens.Type.Lens' a b c d -> a -> c +-- view :: 'Monoid' m => 'Control.Lens.Traversal.Traversal' a b m d -> a -> m +-- @ view :: Getting c a b c d -> a -> c view l = runAccessor . l Accessor {-# INLINE view #-} --- | View the value of a 'Getter', 'Iso', 'Lens' or the result of folding over the --- result of mapping the targets of a 'Fold' or 'Traversal'. +-- | 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 'views' as having these more restrictive signatures: -- +-- >>> import Control.Lens -- >>> views _2 length (1,"hello") -- 5 -- --- > views :: Getter a c -> (c -> d) -> a -> d --- > views :: Monoid m => Fold a c -> (c -> m) -> a -> m --- > views :: Iso a b c d -> (c -> d) -> a -> d --- > views :: Lens a b c d -> (c -> d) -> a -> d --- > views :: Monoid m => Traversal a b c d -> (c -> m) -> a -> m +-- @ +-- views :: 'Getter' a c -> (c -> d) -> a -> d +-- views :: 'Monoid' m => 'Control.Lens.Fold.Fold' a c -> (c -> m) -> a -> m +-- views :: 'Control.Lens.Iso.Iso' a b c d -> (c -> d) -> a -> d +-- views :: 'Control.Lens.Type.Lens' a b c d -> (c -> d) -> a -> d +-- views :: 'Monoid' m => 'Control.Lens.Traversal.Traversal' a b c d -> (c -> m) -> a -> m +-- @ views :: Getting m a b c d -> (c -> m) -> a -> m views l f = runAccessor . l (Accessor . f) {-# INLINE views #-} --- | View the value pointed to by a 'Getter', 'Iso' or 'Lens' or the result of folding over --- all the results of a 'Fold' or 'Traversal' that points at a monoidal values. +-- | 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 at a monoidal values. -- -- This is the same operation as 'view', only infix. -- +-- >>> import Control.Lens -- >>> _2 ^$ (1, "hello") -- "hello" -- --- > (^$) :: Getter a c -> a -> c --- > (^$) :: Monoid m => Fold a m -> a -> m --- > (^$) :: Iso a b c d -> a -> c --- > (^$) :: Lens a b c d -> a -> c --- > (^$) :: Monoid m => Traversal a b m d -> a -> m +-- @ +-- (^$) :: 'Getter' a c -> a -> c +-- (^$) :: 'Monoid' m => 'Control.Lens.Fold.Fold' a m -> a -> m +-- (^$) :: 'Control.Lens.Iso.Iso' a b c d -> a -> c +-- (^$) :: 'Control.Lens.Type.Lens' a b c d -> a -> c +-- (^$) :: 'Monoid' m => 'Control.Lens.Traversal.Traversal' a b m d -> a -> m +-- @ (^$) :: Getting c a b c d -> a -> c l ^$ a = runAccessor (l Accessor a) {-# INLINE (^$) #-} --- | View the value pointed to by a 'Getter' or 'Lens' or the result of folding over --- all the results of a 'Fold' or 'Traversal' that points at a monoidal values. +-- | View the value pointed to by a 'Getter' 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 at a monoidal values. -- -- This is the same operation as 'view' with the arguments flipped. -- -- The fixity and semantics are such that subsequent field accesses can be --- performed with (Prelude..) +-- performed with ('Prelude..') -- +-- >>> :m + Data.Complex Control.Lens -- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude -- 2.23606797749979 -- --- > (^.) :: a -> Getter a c -> c --- > (^.) :: Monoid m => a -> Fold a m -> m --- > (^.) :: a -> Iso a b c d -> c --- > (^.) :: a -> Lens a b c d -> c --- > (^.) :: Monoid m => a -> Traversal a b m d -> m +-- @ +-- (^.) :: a -> 'Getter' a c -> c +-- (^.) :: 'Monoid' m => a -> 'Control.Lens.Fold.Fold' a m -> m +-- (^.) :: a -> 'Control.Lens.Iso.Iso' a b c d -> c +-- (^.) :: a -> 'Control.Lens.Type.Lens' a b c d -> c +-- (^.) :: 'Monoid' m => a -> 'Control.Lens.Traversal.Traversal' a b m d -> m +-- @ (^.) :: a -> Getting c a b c d -> c a ^. l = runAccessor (l Accessor a) {-# INLINE (^.) #-} @@ -217,31 +242,31 @@ ------------------------------------------------------------------------------ -- | --- Query the target of a 'Lens', 'Iso' or 'Getter' in the current state, or use a --- summary of a 'Fold' or 'Traversal' that points to a monoidal value. --- --- > query :: MonadReader a m => Getter a c -> m c --- > query :: (MonadReader a m, Monoid c) => Fold a c -> m c --- > query :: MonadReader a m => Iso a b c d -> m c --- > query :: MonadReader a m => Lens a b c d -> m c --- > query :: (MonadReader a m, Monoid c) => Traversal a b c d -> m c +-- Query 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. -- --- > query :: MonadReader a m => ((c -> Const c d) -> a -> Const c b) -> m c +-- @ +-- query :: 'MonadReader' a m => 'Getter' a c -> m c +-- query :: ('MonadReader' a m, 'Monoid' c) => 'Control.Lens.Fold.Fold' a c -> m c +-- query :: 'MonadReader' a m => 'Control.Lens.Iso.Iso' a b c d -> m c +-- query :: 'MonadReader' a m => 'Control.Lens.Type.Lens' a b c d -> m c +-- query :: ('MonadReader' a m, 'Monoid' c) => 'Control.Lens.Traversal.Traversal' a b c d -> m c +-- @ query :: MonadReader a m => Getting c a b c d -> m c query l = Reader.asks (^.l) {-# INLINE query #-} -- | --- Use the target of a 'Lens', 'Iso' or 'Getter' in the current state, or use a --- summary of a 'Fold' or 'Traversal' that points to a monoidal value. --- --- > queries :: MonadReader a m => Getter a c -> (c -> e) -> m e --- > queries :: (MonadReader a m, Monoid c) => Fold a c -> (c -> e) -> m e --- > queries :: MonadReader a m => Iso a b c d -> (c -> e) -> m e --- > queries :: MonadReader a m => Lens a b c d -> (c -> e) -> m e --- > queries :: (MonadReader a m, Monoid c) => Traversal a b c d -> (c -> e) -> m e +-- 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. -- --- > queries :: MonadReader a m => ((c -> Const e d) -> a -> Const e b) -> (c -> e) -> m e +-- @ +-- queries :: 'MonadReader' a m => 'Getter' a c -> (c -> e) -> m e +-- queries :: ('MonadReader' a m, 'Monoid' c) => 'Control.Lens.Fold.Fold' a c -> (c -> e) -> m e +-- queries :: 'MonadReader' a m => 'Control.Lens.Iso.Iso' a b c d -> (c -> e) -> m e +-- queries :: 'MonadReader' a m => 'Control.Lens.Type.Lens' a b c d -> (c -> e) -> m e +-- queries :: ('MonadReader' a m, 'Monoid' c) => 'Control.Lens.Traversal.Traversal' a b c d -> (c -> e) -> m e +-- @ queries :: MonadReader a m => Getting e a b c d -> (c -> e) -> m e queries l f = Reader.asks (views l f) {-# INLINE queries #-} @@ -251,29 +276,31 @@ ------------------------------------------------------------------------------ -- | --- Use the target of a 'Lens', 'Iso', or 'Getter' in the current state, or use a --- summary of a 'Fold' or 'Traversal' that points to a monoidal value. +-- 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. -- --- > use :: MonadState a m => Action m a b -> m b --- > use :: MonadState a m => Getter a c -> m c --- > use :: (MonadState a m, Monoid r) => Fold a r -> m r --- > use :: MonadState a m => Iso a b c d -> m c --- > use :: MonadState a m => Lens a b c d -> m c --- > use :: (MonadState a m, Monoid r) => Traversal a b r d -> m r +-- @ +-- use :: 'MonadState' a m => 'Getter' a c -> m c +-- use :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Fold.Fold' a r -> m r +-- use :: 'MonadState' a m => 'Control.Lens.Iso.Iso' a b c d -> m c +-- use :: 'MonadState' a m => 'Control.Lens.Type.Lens' a b c d -> m c +-- use :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Traversal.Traversal' a b r d -> m r +-- @ use :: MonadState a m => Getting c a b c d -> m c use l = State.gets (view l) {-# INLINE use #-} -- | --- Use the target of a 'Lens', 'Iso' or 'Getter' in the current state, or use a --- summary of a 'Fold' or 'Traversal' that points to a monoidal value. +-- 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. -- --- > uses :: MonadState a m => Action m a c -> (c -> e) -> m e --- > uses :: MonadState a m => Getter a c -> (c -> e) -> m e --- > uses :: (MonadState a m, Monoid r) => Fold a c -> (c -> r) -> m r --- > uses :: MonadState a m => Lens a b c d -> (c -> e) -> m e --- > uses :: MonadState a m => Iso a b c d -> (c -> e) -> m e --- > uses :: (MonadState a m, Monoid r) => Traversal a b c d -> (c -> r) -> m r +-- @ +-- uses :: 'MonadState' a m => 'Getter' a c -> (c -> e) -> m e +-- uses :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Fold.Fold' a c -> (c -> r) -> m r +-- uses :: 'MonadState' a m => 'Control.Lens.Type.Lens' a b c d -> (c -> e) -> m e +-- uses :: 'MonadState' a m => 'Control.Lens.Iso.Iso' a b c d -> (c -> e) -> m e +-- uses :: ('MonadState' a m, 'Monoid' r) => 'Control.Lens.Traversal.Traversal' a b c d -> (c -> r) -> m r +-- @ uses :: MonadState a m => Getting e a b c d -> (c -> e) -> m e uses l f = State.gets (views l f) {-# INLINE uses #-} 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 @@ -12,6 +12,7 @@ -- Stability : provisional -- Portability : rank 2 types, MPTCs, TFs, flexible -- +-- Combinators for working with 'Indexed' functions. ---------------------------------------------------------------------------- module Control.Lens.Indexed ( @@ -19,67 +20,22 @@ Indexed(..) , Indexable , Index(..) - , (.@) + , (<.>), (<.), (.>) , icompose , reindex - - -- * Indexed Setter - , IndexedSetter - , imapOf - , (%@) - - -- * Indexed Traversals - , IndexedTraversal - , itraverseOf - , iforOf - , imapMOf - , iforMOf - , imapAccumROf - , imapAccumLOf - - -- * Indexed Folds - , IndexedFold - , IndexedFolding - , ifoldMapOf - , ifoldrOf - , ifoldlOf - , ianyOf - , iallOf - , itraverseOf_ - , iforOf_ - , imapMOf_ - , iforMOf_ - , iconcatMapOf - -- , imaximumByOf , iminimumByOf , ifindOf - , ifoldrOf' - , ifoldlOf' - , ifoldrMOf - , ifoldlMOf - - -- * Simple - , SimpleIndexedTraversal - , SimpleIndexedSetter ) where -import Control.Applicative -import Control.Applicative.Backwards -import Control.Lens.Getter -import Control.Lens.Internal -import Control.Lens.Setter -import Control.Lens.Type -import Control.Monad -import Control.Monad.State.Class as State -import Control.Monad.Trans.State.Lazy as Lazy -import Data.Monoid +infixr 9 <.>, <., .> -- | Permit overloading of function application for things that also admit a notion of a key or index. --- | Provides overloading for indexed functions. +-- | Provides overloading for 'Indexed' functions. class Indexed i k where - -- | Build a function from an indexed function + -- | Build a function from an 'Indexed' function index :: ((i -> a) -> b) -> k a b --- | Type alias for passing around polymorphic indexed functions. +-- | 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 @@ -87,7 +43,7 @@ {-# INLINE index #-} -- | A function with access to a index. This constructor may be useful when you need to store --- a 'HasIndex'. +-- 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 @@ -96,272 +52,42 @@ 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) +{-# INLINE (<.) #-} +{-# SPECIALIZE (<.) :: Index i b c -> (a -> b) -> a -> c #-} +{-# SPECIALIZE (<.) :: Index i b c -> (a -> b) -> Index i a c #-} + +-- | Compose a non-indexed function with an 'Indexed' function. +-- +-- 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) +{-# INLINE (.>) #-} +{-# SPECIALIZE (.>) :: (b -> c) -> Index i a b -> a -> c #-} +{-# SPECIALIZE (.>) :: (b -> c) -> Index i a b -> Index i a c #-} + -- | Remap the index. reindex :: Indexed j k => (i -> j) -> Index i a b -> k a b reindex ij (Index iab) = index $ \ ja -> iab $ \i -> ja (ij i) -{-# SPECIALIZE reindex :: (i -> j) -> Index i a b -> Index j a b #-} {-# SPECIALIZE reindex :: (i -> j) -> Index i a b -> a -> b #-} +{-# SPECIALIZE reindex :: (i -> j) -> Index i a b -> Index j a b #-} -infixr 9 .@ --- | Composition of indexed functions -(.@) :: Indexed (i, j) k => Index i b c -> Index j a b -> k a c -f .@ g = icompose (,) f g -{-# INLINE (.@) #-} -{-# SPECIALIZE (.@) :: Index i b c -> Index j a b -> Index (i,j) a c #-} -{-# SPECIALIZE (.@) :: Index i b c -> Index j a b -> a -> c #-} +-- | 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 +f <.> g = icompose (,) f g +{-# INLINE (<.>) #-} +{-# SPECIALIZE (<.>) :: Index i b c -> Index j a b -> a -> c #-} +{-# SPECIALIZE (<.>) :: Index i b c -> Index j a b -> Index (i,j) a c #-} --- | Composition of indexed functions with a user supplied function for combining indexs +-- | Composition of 'Indexed' functions with a user supplied function for combining indexs icompose :: Indexed k r => (i -> j -> k) -> Index i b c -> Index j a b -> r a c icompose ijk (Index ibc) (Index jab) = index $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j) {-# INLINE icompose #-} {-# SPECIALIZE icompose :: (i -> j -> k) -> Index i b c -> Index j a b -> a -> c #-} - ------------------------------------------------------------------------------- --- Indexed Folds ------------------------------------------------------------------------------- - --- | Every 'IndexedFold' is a valid 'Fold'. -type IndexedFold i a c = forall k f b d. (Indexed i k, Applicative f, Gettable f) => k (c -> f d) (a -> f b) - -type IndexedFolding i m a b c d = Index i (c -> Accessor m d) (a -> Accessor m b) - --- | --- --- > ifoldMapOf :: Monoid m => IndexedFold i a c -> (i -> c -> m) -> a -> m --- > ifoldMapOf :: Monoid m => IndexedTraversal i a b c d -> (i -> c -> m) -> a -> m -ifoldMapOf :: IndexedFolding i m a b c d -> (i -> c -> m) -> a -> m -ifoldMapOf l f = runAccessor . withIndex l (\i -> Accessor . f i) -{-# INLINE ifoldMapOf #-} - --- | --- Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. --- --- > ifoldrOf :: IndexedFold i a c -> (i -> c -> e -> e) -> e -> a -> e --- > ifoldrOf :: IndexedTraversal i a b c d -> (i -> c -> e -> e) -> e -> a -> e -ifoldrOf :: IndexedFolding i (Endo e) a b c d -> (i -> c -> e -> e) -> e -> a -> e -ifoldrOf l f z t = appEndo (ifoldMapOf l (\i -> Endo . f i) t) z -{-# INLINE ifoldrOf #-} - --- | --- Left-associative fold of the parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. --- --- > foldl = foldlOf folded --- --- > ifoldlOf :: IndexedFold i a c -> (i -> e -> c -> e) -> e -> a -> e --- > ifoldlOf :: IndexedTraversal i a b c d -> (i -> e -> c -> e) -> e -> a -> e -ifoldlOf :: IndexedFolding i (Dual (Endo e)) a b c d -> (i -> e -> c -> e) -> e -> a -> e -ifoldlOf l f z t = appEndo (getDual (ifoldMapOf l (\i -> Dual . Endo . flip (f i)) t)) z -{-# INLINE ifoldlOf #-} - - --- | --- > ianyOf :: IndexedFold i a c -> (i -> c -> Bool) -> a -> Bool --- > ianyOf :: IndexedTraversal i a b c d -> (i -> c -> Bool) -> a -> Bool -ianyOf :: IndexedFolding i Any a b c d -> (i -> c -> Bool) -> a -> Bool -ianyOf l f = getAny . ifoldMapOf l (\i -> Any . f i) -{-# INLINE ianyOf #-} - --- | --- > iallOf :: IndexedFold i a c -> (i -> c -> Bool) -> a -> Bool --- > iallOf :: IndexedTraversal i a b c d -> (i -> c -> Bool) -> a -> Bool -iallOf :: IndexedFolding i All a b c d -> (i -> c -> Bool) -> a -> Bool -iallOf l f = getAll . ifoldMapOf l (\i -> All . f i) -{-# INLINE iallOf #-} - --- | --- > itraverseOf_ :: Applicative f => IndexedFold i a c -> (i -> c -> f e) -> a -> f () --- > itraverseOf_ :: Applicative f => IndexedTraversal i a b c d -> (i -> c -> f e) -> a -> f () -itraverseOf_ :: Functor f => IndexedFolding i (Traversed f) a b c d -> (i -> c -> f e) -> a -> f () -itraverseOf_ l f = getTraversed . ifoldMapOf l (\i -> Traversed . void . f i) -{-# INLINE itraverseOf_ #-} - --- | --- > iforOf_ :: Applicative f => IndexedFold i a c -> a -> (i -> c -> f e) -> f () --- > iforOf_ :: Applicative f => IndexedTraversal i a b c d -> a -> (i -> c -> f e) -> f () -iforOf_ :: Functor f => IndexedFolding i (Traversed f) a b c d -> a -> (i -> c -> f e) -> f () -iforOf_ = flip . itraverseOf_ -{-# INLINE iforOf_ #-} - --- | --- > imapMOf_ :: Monad m => IndexedFold i a c -> (i -> c -> m e) -> a -> m () --- > imapMOf_ :: Monad m => IndexedTraversal i a b c d -> (i -> c -> m e) -> a -> m () -imapMOf_ :: Monad m => IndexedFolding i (Sequenced m) a b c d -> (i -> c -> m e) -> a -> m () -imapMOf_ l f = getSequenced . ifoldMapOf l (\i -> Sequenced . liftM skip . f i) -{-# INLINE imapMOf_ #-} - -skip :: a -> () -skip _ = () -{-# INLINE skip #-} - --- | --- > iforMOf_ :: Monad m => IndexedFold i a c -> a -> (i -> c -> m e) -> m () --- > iforMOf_ :: Monad m => IndexedTraversal i a b c d -> a -> (i -> c -> m e) -> m () -iforMOf_ :: Monad m => IndexedFolding i (Sequenced m) a b c d -> a -> (i -> c -> m e) -> m () -iforMOf_ = flip . imapMOf_ -{-# INLINE iforMOf_ #-} - --- | --- > iconcatMapOf :: IndexedFold i a c -> (i -> c -> [e]) -> a -> [e] --- > iconcatMapOf :: IndexedTraversal i a b c d -> (i -> c -> [e]) -> a -> [e] -iconcatMapOf :: IndexedFolding i [e] a b c d -> (i -> c -> [e]) -> a -> [e] -iconcatMapOf l ices = runAccessor . withIndex l (\i -> Accessor . ices i) -{-# INLINE iconcatMapOf #-} - -{- --- | --- Obtain the maximum element (if any) targeted by an 'IndexedFold' or 'IndexedTraversal' --- according to a user supplied ordering with access to the indices, returning the index and result of the winning entry --- --- > imaximumByOf :: IndexedFold a c -> (i -> i -> c -> c -> Ordering) -> a -> Maybe (i, c) --- > imaximumByOf :: IndexedTraversal a b c d -> (i -> i -> c -> c -> Ordering) -> a -> Maybe (i, c) -imaximumByOf :: IndexedFolding i (Endo (Maybe c)) a b c d -> (i -> i -> c -> c -> Ordering) -> a -> Maybe (i, c) -imaximumByOf l cmp = ifoldrOf l step Nothing where - step i a Nothing = Just (i, a) - step i a (Just (j, b)) = Just $! if cmp i j a b == GT then (i, a) else (j, b) -{-# INLINE imaximumByOf #-} - --- | --- Obtain the minimum element (if any) targeted by an 'IndexedFold' or 'IndexedTraversal' --- according to a user supplied ordering with access to the indices, returning the index and result of the winning entry --- --- > iminimumByOf :: IndexedFold a c -> (i -> i -> c -> c -> Ordering) -> a -> Maybe (i, c) --- > iminimumByOf :: IndexedTraversal a b c d -> (i -> i -> c -> c -> Ordering) -> a -> Maybe (i, c) -iminimumByOf :: IndexedFolding i (Endo (Maybe c)) a b c d -> (i -> i -> c -> c -> Ordering) -> a -> Maybe (i, c) -iminimumByOf l cmp = ifoldrOf l step Nothing where - step i a Nothing = Just (i, a) - step i a (Just (j, b)) = Just $! if cmp i j a b == GT then (j, b) else (i, a) -{-# INLINE iminimumByOf #-} - --- | The 'findOf' function takes an IndexedFold or IndexedTraversal, a predicate, --- a structure and returns the leftmost element of the structure --- matching the predicate, or 'Nothing' if there is no such element. --- --- > ifindOf :: IndexedFold a c -> (i -> c -> Bool) -> a -> Maybe (i, c) --- > ifindOf :: IndexedTraversal a b c d -> (i -> c -> Bool) -> a -> Maybe (i, c) -ifindOf :: IndexedFolding i (First c) a b c d -> (i -> c -> Bool) -> a -> Maybe (i, c) -ifindOf l p = getFirst . ifoldMapOf l step where - step i c - | p i c = First (Just (i, c)) - | otherwise = First Nothing -{-# INLINE ifindOf #-} --} - --- | Strictly fold right over the elements of a structure with an index. --- --- > ifoldrOf' :: IndexedFold i a c -> (i -> c -> e -> e) -> e -> a -> e --- > ifoldrOf' :: IndexedTraversal i a b c d -> (i -> c -> e -> e) -> e -> a -> e -ifoldrOf' :: IndexedFolding i (Dual (Endo (e -> e))) a b c d -> (i -> c -> e -> e) -> e -> a -> e -ifoldrOf' l f z0 xs = ifoldlOf l f' id xs z0 - where f' i k x z = k $! f i x z -{-# INLINE ifoldrOf' #-} - --- | Fold over the elements of a structure with an index, associating to the left, but strictly. --- --- > ifoldlOf' :: IndexedFold i a c -> (i -> e -> c -> e) -> e -> a -> e --- > ifoldlOf' :: IndexedTraversal i a b c d -> (i -> e -> c -> e) -> e -> a -> e -ifoldlOf' :: IndexedFolding i (Endo (e -> e)) a b c d -> (i -> e -> c -> e) -> e -> a -> e -ifoldlOf' l f z0 xs = ifoldrOf l f' id xs z0 - where f' i x k z = k $! f i z x -{-# INLINE ifoldlOf' #-} - --- | Monadic fold right over the elements of a structure with an index. --- --- > ifoldrMOf :: Monad m => IndexedFold i a c -> (i -> c -> e -> m e) -> e -> a -> e --- > ifoldrMOf :: Monad m => IndexedTraversal i a b c d -> (i -> c -> e -> m e) -> e -> a -> e -ifoldrMOf :: Monad m => IndexedFolding i (Dual (Endo (e -> m e))) a b c d -> (i -> c -> e -> m e) -> e -> a -> m e -ifoldrMOf l f z0 xs = ifoldlOf l f' return xs z0 - where f' i k x z = f i x z >>= k -{-# INLINE ifoldrMOf #-} - --- | Monadic fold over the elements of a structure with an index, associating to the left. --- --- > ifoldlOf' :: Monad m => IndexedFold i a c -> (i -> e -> c -> m e) -> e -> a -> e --- > ifoldlOf' :: Monad m => IndexedTraversal i a b c d -> (i -> e -> c -> m e) -> e -> a -> e -ifoldlMOf :: Monad m => IndexedFolding i (Endo (e -> m e)) a b c d -> (i -> e -> c -> m e) -> e -> a -> m e -ifoldlMOf l f z0 xs = ifoldrOf l f' return xs z0 - where f' i x k z = f i z x >>= k -{-# INLINE ifoldlMOf #-} - ------------------------------------------------------------------------------- --- Indexed Traversals ------------------------------------------------------------------------------- - --- | Every indexed traversal is a valid Traversal or indexed fold. --- --- The Traversal laws are still required to hold. -type IndexedTraversal i a b c d = forall f k. (Indexed i k, Applicative f) => k (c -> f d) (a -> f b) - --- | @type 'SimpleIdexedTraversal' i = 'Simple' ('IndexedTraversal' i)@ -type SimpleIndexedTraversal i a b = IndexedTraversal i a a b b - --- | Traversal with an index. --- --- > itraverseOf = withIndex --- --- > itraverseOf :: IndexedTraversal i a b c d -> (i -> c -> f d) -> a -> f b -itraverseOf :: Overloaded (Index i) f a b c d -> (i -> c -> f d) -> a -> f b -itraverseOf = withIndex -{-# INLINE itraverseOf #-} - --- | --- > iforOf = flip . itraverseOf -iforOf :: Overloaded (Index i) f a b c d -> a -> (i -> c -> f d) -> f b -iforOf = flip . withIndex -{-# INLINE iforOf #-} - --- | Map each element of a structure targeted by a lens to a monadic action, --- evaluate these actions from left to right, and collect the results, with access --- its position. --- --- > imapMOf :: Monad m => IndexedTraversal a b c d -> (i -> c -> m d) -> a -> m b -imapMOf :: Overloaded (Index i) (WrappedMonad m) a b c d -> (i -> c -> m d) -> a -> m b -imapMOf l f = unwrapMonad . withIndex l (\i -> WrapMonad . f i) -{-# INLINE imapMOf #-} - --- | --- > iforMOf = flip . imapMOf -iforMOf :: Overloaded (Index i) (WrappedMonad m) a b c d -> a -> (i -> c -> m d) -> m b -iforMOf = flip . imapMOf -{-# INLINE iforMOf #-} - --- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'IndexedTraversal'. --- --- 'imapAccumROf' accumulates state from right to left. --- -imapAccumROf :: Overloaded (Index i) (Lazy.State s) a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) -imapAccumROf l f s0 a = swap (Lazy.runState (withIndex l (\i c -> State.state (\s -> swap (f i s c))) a) s0) -{-# INLINE imapAccumROf #-} - --- | Generalized 'Data.Traversable.mapAccumL' to an arbitrary 'IndexedTraversal'. --- --- 'imapAccumLOf' accumulates state from left to right. -imapAccumLOf :: Overloaded (Index i) (Backwards (Lazy.State s)) a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) -imapAccumLOf l f s0 a = swap (Lazy.runState (forwards (withIndex l (\i c -> Backwards (State.state (\s -> swap (f i s c)))) a)) s0) -{-# INLINE imapAccumLOf #-} - -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) -{-# INLINE swap #-} - --- | Every 'IndexedSetter' is a valid 'Setter' --- --- The 'Setter' laws are still required to hold. -type IndexedSetter i a b c d = forall f k. (Indexed i k, Settable f) => k (c -> f d) (a -> f b) - --- | @type 'SimpleIdexedTraversal i = 'Simple' ('IndexedTraversal' i)@ -type SimpleIndexedSetter i a b = IndexedSetter i a a b b - --- | Map with index --- --- > imapOf :: IndexedTraversal i a b c d -> (i -> c -> d) -> a -> b --- > imapOf :: IndexedSetter i a b c d -> (i -> c -> d) -> a -> b -imapOf :: Overloaded (Index i) Mutator a b c d -> (i -> c -> d) -> a -> b -imapOf l f = runMutator . withIndex l (\i -> Mutator . f i) -{-# INLINE imapOf #-} - -infixr 4 %@ - --- | > (%@) = imapOf -(%@) :: Overloaded (Index i) Mutator a b c d -> (i -> c -> d) -> a -> b -l %@ f = runMutator . withIndex l (\i -> Mutator . f i) -{-# INLINE (%@) #-} +{-# SPECIALIZE icompose :: (k ~ l) => (i -> j -> k) -> Index i b c -> Index j a b -> Index l a c #-} diff --git a/src/Control/Lens/IndexedFold.hs b/src/Control/Lens/IndexedFold.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/IndexedFold.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.IndexedFold +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : rank 2 types, MPTCs, TFs, flexible +-- +---------------------------------------------------------------------------- +module Control.Lens.IndexedFold + ( + -- * Indexed Folds + IndexedFold + , ifoldMapOf + , ifoldrOf + , ifoldlOf + , ianyOf + , iallOf + , itraverseOf_ + , iforOf_ + , imapMOf_ + , iforMOf_ + , iconcatMapOf + , ifindOf + , ifoldrOf' + , ifoldlOf' + , ifoldrMOf + , ifoldlMOf + , itoListOf + ) where + +import Control.Applicative +import Control.Lens.Getter +import Control.Lens.Indexed +import Control.Lens.IndexedGetter +import Control.Lens.Internal +import Control.Monad +import Data.Monoid + +------------------------------------------------------------------------------ +-- Indexed Folds +------------------------------------------------------------------------------ + +-- | Every 'IndexedFold' is a valid 'Control.Lens.Fold.Fold'. +type IndexedFold i a c = forall k f b d. (Indexed i k, Applicative f, Gettable f) => k (c -> f d) (a -> f b) + +-- | +-- Fold an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' by mapping indices and values to an arbitrary 'Monoid' with access +-- to the index @i@. +-- +-- When you don't need access to the index then 'foldMapOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.foldMapOf' l = 'ifoldMapOf' l . 'const'@ +-- +-- > ifoldMapOf :: IndexedGetter i a c -> (i -> c -> m) -> a -> m +-- > ifoldMapOf :: Monoid m => IndexedFold i a c -> (i -> c -> m) -> a -> m +-- > ifoldMapOf :: IndexedLens i a b c d -> (i -> c -> m) -> a -> m +-- > ifoldMapOf :: Monoid m => IndexedTraversal i a b c d -> (i -> c -> m) -> a -> m +ifoldMapOf :: IndexedGetting i m a b c d -> (i -> c -> m) -> a -> m +ifoldMapOf l f = runAccessor . withIndex l (\i -> Accessor . f i) +{-# INLINE ifoldMapOf #-} + +-- | +-- 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@. +-- +-- When you don't need access to the index then 'foldrOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.foldrOf' l = 'ifoldrOf' l . 'const'@ +-- +-- > ifoldrOf :: IndexedGetter i a c -> (i -> c -> e -> e) -> e -> a -> e +-- > ifoldrOf :: IndexedFold i a c -> (i -> c -> e -> e) -> e -> a -> e +-- > ifoldrOf :: IndexedLens i a b c d -> (i -> c -> e -> e) -> e -> a -> e +-- > ifoldrOf :: IndexedTraversal i a b c d -> (i -> c -> e -> e) -> e -> a -> e +ifoldrOf :: IndexedGetting i (Endo e) a b c d -> (i -> c -> e -> e) -> e -> a -> e +ifoldrOf l f z t = appEndo (ifoldMapOf l (\i -> Endo . f i) t) z +{-# INLINE ifoldrOf #-} + +-- | +-- 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@. +-- +-- When you don't need access to the index then 'foldlOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.foldlOf' l = 'ifoldlOf' l . 'const'@ +-- +-- > ifoldlOf :: IndexedGetter i a c -> (i -> e -> c -> e) -> e -> a -> e +-- > ifoldlOf :: IndexedFold i a c -> (i -> e -> c -> e) -> e -> a -> e +-- > ifoldlOf :: IndexedLens i a b c d -> (i -> e -> c -> e) -> e -> a -> e +-- > ifoldlOf :: IndexedTraversal i a b c d -> (i -> e -> c -> e) -> e -> a -> e +ifoldlOf :: IndexedGetting i (Dual (Endo e)) a b c d -> (i -> e -> c -> e) -> e -> a -> e +ifoldlOf l f z t = appEndo (getDual (ifoldMapOf l (\i -> Dual . Endo . flip (f i)) t)) z +{-# INLINE ifoldlOf #-} + +-- | +-- Return whether or not any element viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' +-- satisfy a predicate, with access to the index @i@. +-- +-- When you don't need access to the index then 'anyOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.anyOf' l = 'ianyOf' l . 'const'@ +-- +-- > ianyOf :: IndexedGetter i a c -> (i -> c -> Bool) -> a -> Bool +-- > ianyOf :: IndexedFold i a c -> (i -> c -> Bool) -> a -> Bool +-- > ianyOf :: IndexedLens i a b c d -> (i -> c -> Bool) -> a -> Bool +-- > ianyOf :: IndexedTraversal i a b c d -> (i -> c -> Bool) -> a -> Bool +ianyOf :: IndexedGetting i Any a b c d -> (i -> c -> Bool) -> a -> Bool +ianyOf l f = getAny . ifoldMapOf l (\i -> Any . f i) +{-# INLINE ianyOf #-} + +-- | +-- Return whether or not all elements viewed through an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' +-- satisfy a predicate, with access to the index @i@. +-- +-- When you don't need access to the index then 'allOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.allOf' l = 'iallOf' l . 'const'@ +-- +-- > iallOf :: IndexedGetter i a c -> (i -> c -> Bool) -> a -> Bool +-- > iallOf :: IndexedFold i a c -> (i -> c -> Bool) -> a -> Bool +-- > iallOf :: IndexedLens i a b c d -> (i -> c -> Bool) -> a -> Bool +-- > iallOf :: IndexedTraversal i a b c d -> (i -> c -> Bool) -> a -> Bool +iallOf :: IndexedGetting i All a b c d -> (i -> c -> Bool) -> a -> Bool +iallOf l f = getAll . ifoldMapOf l (\i -> All . f i) +{-# INLINE iallOf #-} + +-- | +-- Traverse the targets of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index @i@, discarding the results. +-- +-- When you don't need access to the index then 'traverseOf_' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.traverseOf_' l = 'itraverseOf' l . 'const'@ +-- +-- > itraverseOf_ :: Functor f => IndexedGetter i a c -> (i -> c -> f e) -> a -> f () +-- > itraverseOf_ :: Applicative f => IndexedFold i a c -> (i -> c -> f e) -> a -> f () +-- > itraverseOf_ :: Functor f => IndexedLens i a b c d -> (i -> c -> f e) -> a -> f () +-- > itraverseOf_ :: Applicative f => IndexedTraversal i a b c d -> (i -> c -> f e) -> a -> f () +itraverseOf_ :: Functor f => IndexedGetting i (Traversed f) a b c d -> (i -> c -> f e) -> a -> f () +itraverseOf_ l f = getTraversed . ifoldMapOf l (\i -> Traversed . void . f i) +{-# INLINE itraverseOf_ #-} + +-- | +-- Traverse the targets of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index, discarding the results +-- (with the arguments flipped). +-- +-- @'iforOf_' = 'flip' . 'itraverseOf_'@ +-- +-- When you don't need access to the index then 'forOf_' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.forOf_' l a = 'iforOf' l a . 'const'@ +-- +-- > iforOf_ :: Functor f => IndexedGetter i a c -> a -> (i -> c -> f e) -> f () +-- > iforOf_ :: Applicative f => IndexedFold i a c -> a -> (i -> c -> f e) -> f () +-- > iforOf_ :: Functor f => IndexedLens i a b c d -> a -> (i -> c -> f e) -> f () +-- > iforOf_ :: Applicative f => IndexedTraversal i a b c d -> a -> (i -> c -> f e) -> f () +iforOf_ :: Functor f => IndexedGetting i (Traversed f) a b c d -> a -> (i -> c -> f e) -> f () +iforOf_ = flip . itraverseOf_ +{-# INLINE iforOf_ #-} + +-- | +-- Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index, +-- discarding the results. +-- +-- When you don't need access to the index then 'mapMOf_' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.mapMOf_' l = 'imapMOf' l . 'const'@ +-- +-- > imapMOf_ :: Monad m => IndexedGetter i a c -> (i -> c -> m e) -> a -> m () +-- > imapMOf_ :: Monad m => IndexedFold i a c -> (i -> c -> m e) -> a -> m () +-- > imapMOf_ :: Monad m => IndexedLens i a b c d -> (i -> c -> m e) -> a -> m () +-- > imapMOf_ :: Monad m => IndexedTraversal i a b c d -> (i -> c -> m e) -> a -> m () +imapMOf_ :: Monad m => IndexedGetting i (Sequenced m) a b c d -> (i -> c -> m e) -> a -> m () +imapMOf_ l f = getSequenced . ifoldMapOf l (\i -> Sequenced . liftM skip . f i) +{-# INLINE imapMOf_ #-} + +skip :: a -> () +skip _ = () +{-# INLINE skip #-} + +-- | +-- Run monadic actions for each target of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' with access to the index, +-- discarding the results (with the arguments flipped). +-- +-- @'iforMOf_' = 'flip' . 'imapMOf_'@ +-- +-- When you don't need access to the index then 'forMOf_' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.forMOf_' l a = 'iforMOf' l a . 'const'@ +-- +-- > iforMOf_ :: Monad m => IndexedGetter i a c -> a -> (i -> c -> m e) -> m () +-- > iforMOf_ :: Monad m => IndexedFold i a c -> a -> (i -> c -> m e) -> m () +-- > iforMOf_ :: Monad m => IndexedLens i a b c d -> a -> (i -> c -> m e) -> m () +-- > iforMOf_ :: Monad m => IndexedTraversal i a b c d -> a -> (i -> c -> m e) -> m () +iforMOf_ :: Monad m => IndexedGetting i (Sequenced m) a b c d -> a -> (i -> c -> m e) -> m () +iforMOf_ = flip . imapMOf_ +{-# INLINE iforMOf_ #-} + +-- | +-- Concatenate the results of a function of the elements of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal' +-- with access to the index. +-- +-- When you don't need access to the index then 'concatMapOf_' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.concatMapOf_' l = 'iconcatMapMOf' l . 'const'@ +-- +-- > iconcatMapOf :: IndexedGetter i a c -> (i -> c -> [e]) -> a -> [e] +-- > iconcatMapOf :: IndexedFold i a c -> (i -> c -> [e]) -> a -> [e] +-- > iconcatMapOf :: IndexedLens i a b c d -> (i -> c -> [e]) -> a -> [e] +-- > iconcatMapOf :: IndexedTraversal i a b c d -> (i -> c -> [e]) -> a -> [e] +iconcatMapOf :: IndexedGetting i [e] a b c d -> (i -> c -> [e]) -> a -> [e] +iconcatMapOf l ices = runAccessor . withIndex l (\i -> Accessor . ices i) +{-# INLINE iconcatMapOf #-} + +-- | The 'findOf' function takes an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal', a predicate that is also +-- supplied the index, a structure and returns the left-most element of the structure +-- matching the predicate, or 'Nothing' if there is no such element. +-- +-- When you don't need access to the index then 'findOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.findOf' l = 'ifoldOf' l . 'const'@ +-- +-- > ifindOf :: IndexedGetter a c -> (i -> c -> Bool) -> a -> Maybe (i, c) +-- > ifindOf :: IndexedFold a c -> (i -> c -> Bool) -> a -> Maybe (i, c) +-- > ifindOf :: IndexedLens a b c d -> (i -> c -> Bool) -> a -> Maybe (i, c) +-- > ifindOf :: IndexedTraversal a b c d -> (i -> c -> Bool) -> a -> Maybe (i, c) +ifindOf :: IndexedGetting i (First (i, c)) a b c d -> (i -> c -> Bool) -> a -> Maybe (i, c) +ifindOf l p = getFirst . ifoldMapOf l step where + step i c + | p i c = First $ Just (i, c) + | otherwise = First Nothing +{-# INLINE ifindOf #-} + +-- | /Strictly/ fold right over the elements of a structure with an index. +-- +-- When you don't need access to the index then 'foldrOf'' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.foldrOf'' l = 'ifoldrOf'' l . 'const'@ +-- +-- > ifoldrOf' :: IndexedGetter i a c -> (i -> c -> e -> e) -> e -> a -> e +-- > ifoldrOf' :: IndexedFold i a c -> (i -> c -> e -> e) -> e -> a -> e +-- > ifoldrOf' :: IndexedLens i a b c d -> (i -> c -> e -> e) -> e -> a -> e +-- > ifoldrOf' :: IndexedTraversal i a b c d -> (i -> c -> e -> e) -> e -> a -> e +ifoldrOf' :: IndexedGetting i (Dual (Endo (e -> e))) a b c d -> (i -> c -> e -> e) -> e -> a -> e +ifoldrOf' l f z0 xs = ifoldlOf l f' id xs z0 + where f' i k x z = k $! f i x z +{-# INLINE ifoldrOf' #-} + +-- | Fold over the elements of a structure with an index, associating to the left, but /strictly/. +-- +-- When you don't need access to the index then 'foldlOf'' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.foldlOf'' l = 'ifoldlOf'' l . 'const'@ +-- +-- > ifoldlOf' :: IndexedGetter i a c -> (i -> e -> c -> e) -> e -> a -> e +-- > ifoldlOf' :: IndexedFold i a c -> (i -> e -> c -> e) -> e -> a -> e +-- > ifoldlOf' :: IndexedLens i a b c d -> (i -> e -> c -> e) -> e -> a -> e +-- > ifoldlOf' :: IndexedTraversal i a b c d -> (i -> e -> c -> e) -> e -> a -> e +ifoldlOf' :: IndexedGetting i (Endo (e -> e)) a b c d -> (i -> e -> c -> e) -> e -> a -> e +ifoldlOf' l f z0 xs = ifoldrOf l f' id xs z0 + where f' i x k z = k $! f i z x +{-# INLINE ifoldlOf' #-} + +-- | Monadic fold right over the elements of a structure with an index. +-- +-- When you don't need access to the index then 'foldrMOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.foldrMOf' l = 'ifoldrMOf' l . 'const'@ +-- +-- > ifoldrMOf :: Monad m => IndexedGetter i a c -> (i -> c -> e -> m e) -> e -> a -> e +-- > ifoldrMOf :: Monad m => IndexedFold i a c -> (i -> c -> e -> m e) -> e -> a -> e +-- > ifoldrMOf :: Monad m => IndexedLens i a b c d -> (i -> c -> e -> m e) -> e -> a -> e +-- > ifoldrMOf :: Monad m => IndexedTraversal i a b c d -> (i -> c -> e -> m e) -> e -> a -> e +ifoldrMOf :: Monad m => IndexedGetting i (Dual (Endo (e -> m e))) a b c d -> (i -> c -> e -> m e) -> e -> a -> m e +ifoldrMOf l f z0 xs = ifoldlOf l f' return xs z0 + where f' i k x z = f i x z >>= k +{-# INLINE ifoldrMOf #-} + +-- | Monadic fold over the elements of a structure with an index, associating to the left. +-- +-- When you don't need access to the index then 'foldlMOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.foldlMOf' l = 'ifoldlMOf' l . 'const'@ +-- +-- > ifoldlOf' :: Monad m => IndexedGetter i a c -> (i -> e -> c -> m e) -> e -> a -> e +-- > ifoldlOf' :: Monad m => IndexedFold i a c -> (i -> e -> c -> m e) -> e -> a -> e +-- > ifoldlOf' :: Monad m => IndexedLens i a b c d -> (i -> e -> c -> m e) -> e -> a -> e +-- > ifoldlOf' :: Monad m => IndexedTraversal i a b c d -> (i -> e -> c -> m e) -> e -> a -> e +ifoldlMOf :: Monad m => IndexedGetting i (Endo (e -> m e)) a b c d -> (i -> e -> c -> m e) -> e -> a -> m e +ifoldlMOf l f z0 xs = ifoldrOf l f' return xs z0 + where f' i x k z = f i z x >>= k +{-# INLINE ifoldlMOf #-} + +-- | Extract the key-value pairs from a structure. +-- +-- When you don't need access to the indices, then 'toListOf' is more flexible in what it accepts. +-- +-- @'Control.Lens.Fold.toListOf' l = 'map' 'fst' . 'itoListOf' l@ +-- +-- > itoListOf :: IndexedGetter i a c -> a -> [(i,c)] +-- > itoListOf :: IndexedFold i a c -> a -> [(i,c)] +-- > itoListOf :: IndexedLens i a b c d -> a -> [(i,c)] +-- > itoListOf :: IndexedTraversal i a b c d -> a -> [(i,c)] +itoListOf :: IndexedGetting i [(i,c)] a b c d -> a -> [(i,c)] +itoListOf l = ifoldMapOf l (\i c -> [(i,c)]) +{-# INLINE itoListOf #-} diff --git a/src/Control/Lens/IndexedGetter.hs b/src/Control/Lens/IndexedGetter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/IndexedGetter.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.IndexedGetter +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : rank 2 types, MPTCs +-- +---------------------------------------------------------------------------- +module Control.Lens.IndexedGetter + ( + -- * Indexed Folds + IndexedGetter + , IndexedGetting + ) where + +import Control.Lens.Getter +import Control.Lens.Indexed + +------------------------------------------------------------------------------ +-- Indexed Getters +------------------------------------------------------------------------------ + +-- | Every 'IndexedGetter' is a valid 'Control.Lens.IndexedFold.IndexedFold' and 'Getter'. +type IndexedGetter i a c = forall k f b d. (Indexed i k, Gettable f) => k (c -> f d) (a -> f b) + +-- | Used to consume an 'Control.Lens.IndexedFold.IndexedFold'. +type IndexedGetting i m a b c d = Index i (c -> Accessor m d) (a -> Accessor m b) diff --git a/src/Control/Lens/IndexedLens.hs b/src/Control/Lens/IndexedLens.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/IndexedLens.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +#ifndef MIN_VERSION_mtl +#define MIN_VERSION_mtl(x,y,z) 1 +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.IndexedLens +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : rank 2 types, MPTCs, TFs, flexible +-- +---------------------------------------------------------------------------- +module Control.Lens.IndexedLens + ( + -- * Indexed Lenses + IndexedLens + , (%%@~) + , (<%@~) + , (%%@=) + , (<%@=) + + -- * Simple + , SimpleIndexedLens + ) where + +import Control.Lens.Indexed +import Control.Lens.Type +import Control.Monad.State.Class as State + +infixr 4 %%@~, <%@~ +infix 4 %%@=, <%@= + +-- | Every 'IndexedLens' is a valid 'Lens' and a valid 'Control.Lens.IndexedTraversal.IndexedTraversal'. +type IndexedLens i a b c d = forall f k. (Indexed i k, Functor f) => k (c -> f d) (a -> f b) + +-- | @type 'SimpleIndexedLens' i = 'Simple' ('IndexedLens' i)@ +type SimpleIndexedLens i a b = IndexedLens i a a b b + +-- | Adjust the target of an 'IndexedLens' returning the intermediate result, or +-- 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@ +-- +-- When you do not need access to the index then ('<%~') is more liberal in what it can accept. +-- +-- If you do not need the intermediate result, you can use ('Control.Lens.Type.%@~') or even ('Control.Lens.Type.%~'). +-- +-- > (<%@~) :: IndexedLens i a b c d -> (i -> c -> d) -> a -> (d, b) +-- > (<%@~) :: Monoid d => IndexedTraversal i a b c d -> (i -> c -> d) -> a -> (d, b) +(<%@~) :: Overloaded (Index i) ((,)d) a b c d -> (i -> c -> d) -> a -> (d, b) +l <%@~ f = withIndex l $ \i c -> let d = f i c in (d, d) +{-# INLINE (<%@~) #-} + +-- | Adjust the target of an 'IndexedLens' returning a supplementary result, or +-- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' and return a monoidal summary +-- of the supplementary results and the answer. +-- +-- @('%%@~') = 'withIndex'@ +-- +-- > (%%@~) :: IndexedLens i a b c d -> (i -> c -> (e, d)) -> a -> (e, b) +-- > (%%@~) :: Monoid e => IndexedTraversal i a b c d -> (i -> c -> (e, d)) -> a -> (e, b) +(%%@~) :: Overloaded (Index i) ((,)e) a b c d -> (i -> c -> (e, d)) -> a -> (e, b) +(%%@~) = withIndex +{-# INLINE (%%@~) #-} + +-- | Adjust the target of an 'IndexedLens' returning a supplementary result, or +-- 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)@ +-- +-- > (%%@=) :: MonadState a m IndexedLens i a a c d -> (i -> c -> (e, d)) -> a -> m e +-- > (%%@=) :: (MonadState a m, Monoid e) => IndexedTraversal i a a c d -> (i -> c -> (e, d)) -> a -> m e +(%%@=) :: MonadState a m => Overloaded (Index i) ((,)e) a a c d -> (i -> c -> (e, d)) -> m e +#if MIN_VERSION_mtl(2,1,0) +l %%@= f = State.state (l %%@~ f) +#else +l %%@= f = do + (e, d) <- State.gets (l %%@~ f) + State.put d + return e +#endif +{-# INLINE (%%@=) #-} + +-- | Adjust the target of an 'IndexedLens' returning the intermediate result, or +-- adjust all of the targets of an 'Control.Lens.IndexedTraversal.IndexedTraversal' within the current state, and +-- return a monoidal summary of the intermediate results. +-- +-- > (<%@=) :: MonadState a m IndexedLens i a a c d -> (i -> c -> d) -> a -> m d +-- > (<%@=) :: (MonadState a m, Monoid e) => IndexedTraversal i a a c d -> (i -> c -> d) -> a -> m d +(<%@=) :: MonadState a m => Overloaded (Index i) ((,)d) a a c d -> (i -> c -> d) -> m d +l <%@= f = l %%@= \ i c -> let d = f i c in (d, d) +{-# INLINE (<%@=) #-} diff --git a/src/Control/Lens/IndexedSetter.hs b/src/Control/Lens/IndexedSetter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/IndexedSetter.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.IndexedSetter +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : rank 2 types, MPTCs, TFs, flexible +-- +---------------------------------------------------------------------------- +module Control.Lens.IndexedSetter + ( + -- * Indexed Setter + IndexedSetter + , imapOf + , (%@~) + , (%@=) + -- * Simple + , SimpleIndexedSetter + ) where + +import Control.Lens.Indexed +import Control.Lens.Setter +import Control.Lens.Type +import Control.Monad.State.Class as State + +infixr 4 %@~ +infix 4 %@= + +-- | Every 'IndexedSetter' is a valid 'Setter' +-- +-- The 'Setter' laws are still required to hold. +type IndexedSetter i a b c d = forall f k. (Indexed i k, Settable f) => k (c -> f d) (a -> f b) + +-- | @type 'SimpleIndexedSetter i = 'Simple' ('IndexedSetter' i)@ +type SimpleIndexedSetter i a b = IndexedSetter i a a b b + +-- | Map with index. +-- +-- When you do not need access to the index, then 'mapOf' is more liberal in what it can accept. +-- +-- @'mapOf' l = 'imapOf' l . 'const'@ +-- +-- > imapOf :: IndexedSetter i a b c d -> (i -> c -> d) -> a -> b +-- > imapOf :: IndexedLens i a b c d -> (i -> c -> d) -> a -> b +-- > imapOf :: IndexedTraversal i a b c d -> (i -> c -> d) -> a -> b +imapOf :: Overloaded (Index i) Mutator a b c d -> (i -> c -> d) -> a -> b +imapOf l f = runMutator . withIndex l (\i -> Mutator . f i) +{-# INLINE imapOf #-} + +-- | Adjust every target of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal' +-- with access to the index. +-- +-- @('%@~') = 'imapOf'@ +-- +-- When you do not need access to the index then ('%@~') is more liberal in what it can accept. +-- +-- @l '%~' f = l '%@~' 'const' f@ +-- +-- > (%@~) :: IndexedSetter i a b c d -> (i -> c -> d) -> a -> b +-- > (%@~) :: IndexedLens i a b c d -> (i -> c -> d) -> a -> b +-- > (%@~) :: IndexedTraversal i a b c d -> (i -> c -> d) -> a -> b +(%@~) :: Overloaded (Index i) Mutator a b c d -> (i -> c -> d) -> a -> b +l %@~ f = runMutator . withIndex l (\i -> Mutator . f i) +{-# INLINE (%@~) #-} + +-- | Adjust every target in the current state of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal' +-- with access to the index. +-- +-- When you do not need access to the index then ('%=') is more liberal in what it can accept. +-- +-- @l '%=' f = l '%@=' 'const' f@ +-- +-- > (%@=) :: MonadState a m => IndexedSetter i a a c d -> (i -> c -> d) -> m () +-- > (%@=) :: MonadState a m => IndexedLens i a a c d -> (i -> c -> d) -> m () +-- > (%@=) :: MonadState a m => IndexedTraversal i a b c d -> (i -> c -> d) -> m () +(%@=) :: MonadState a m => Overloaded (Index i) Mutator a a c d -> (i -> c -> d) -> m () +l %@= f = State.modify (l %@~ f) +{-# INLINE (%@=) #-} diff --git a/src/Control/Lens/IndexedTraversal.hs b/src/Control/Lens/IndexedTraversal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/IndexedTraversal.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.IndexedTraversal +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : rank 2 types, MPTCs, TFs, flexible +-- +---------------------------------------------------------------------------- +module Control.Lens.IndexedTraversal + ( + -- * Indexed Traversals + IndexedTraversal + , itraverseOf + , iforOf + , imapMOf + , iforMOf + , imapAccumROf + , imapAccumLOf + + -- * Simple + , SimpleIndexedTraversal + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Lens.Indexed +import Control.Lens.Type +import Control.Monad.Trans.State.Lazy as Lazy + +------------------------------------------------------------------------------ +-- Indexed Traversals +------------------------------------------------------------------------------ + +-- | 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 'Control.Lens.Traversal.Traversal' laws are still required to hold. +type IndexedTraversal i a b c d = forall f k. (Indexed i k, Applicative f) => k (c -> f d) (a -> f b) + +-- | @type 'SimpleIndexedTraversal' i = 'Simple' ('IndexedTraversal' i)@ +type SimpleIndexedTraversal i a b = IndexedTraversal i a a b b + +-- | Traversal with an index. +-- +-- NB: When you don't need access to the index then you can just apply your 'IndexedTraversal' +-- directly as a function! +-- +-- @'itraverseOf' = 'withIndex'@ +-- +-- @'Control.Lens.Traversal.traverseOf' = 'itraverseOf' . 'const' = 'id'@ +-- +-- > itraverseOf :: IndexedLens i a b c d -> (i -> c -> f d) -> a -> f b +-- > itraverseOf :: IndexedTraversal i a b c d -> (i -> c -> f d) -> a -> f b +itraverseOf :: Overloaded (Index i) f a b c d -> (i -> c -> f d) -> a -> f b +itraverseOf = withIndex +{-# INLINE itraverseOf #-} + +-- | +-- Traverse with an index (and the arguments flipped) +-- +-- @'Control.Lens.Traversal.forOf' l a = 'iforOf' l a . 'const'@ +-- +-- @'iforOf' = 'flip' . 'itraverseOf'@ +-- +-- > iforOf :: IndexedLens i a b c d -> a -> (i -> c -> f d) -> f b +-- > iforOf :: IndexedTraversal i a b c d -> a -> (i -> c -> f d) -> f b +iforOf :: Overloaded (Index i) f a b c d -> a -> (i -> c -> f d) -> f b +iforOf = flip . withIndex +{-# INLINE iforOf #-} + +-- | Map each element of a structure targeted by a lens to a monadic action, +-- evaluate these actions from left to right, and collect the results, with access +-- its position. +-- +-- When you don't need access to the index 'mapMOf' is more liberal in what it can accept. +-- +-- @'Control.Lens.Traversal.mapMOf' = 'imapMOf' . 'const'@ +-- +-- > imapMOf :: Monad m => IndexedLens i a b c d -> (i -> c -> m d) -> a -> m b +-- > imapMOf :: Monad m => IndexedTraversal i a b c d -> (i -> c -> m d) -> a -> m b +imapMOf :: Overloaded (Index i) (WrappedMonad m) a b c d -> (i -> c -> m d) -> a -> m b +imapMOf l f = unwrapMonad . withIndex l (\i -> WrapMonad . f i) +{-# INLINE imapMOf #-} + +-- | Map each element of a structure targeted by a lens to a monadic action, +-- evaluate these actions from left to right, and collect the results, with access +-- its position (and the arguments flipped). +-- +-- @'Control.Lens.Traversal.forMOf' l a = 'iforMOf' l a . 'const'@ +-- +-- @'iforMOf' = 'flip' . 'imapMOf'@ +-- +-- > iforMOf :: Monad m => IndexedLens i a b c d -> a -> (i -> c -> m d) -> m b +-- > iforMOf :: Monad m => IndexedTraversal i a b c d -> a -> (i -> c -> m d) -> m b +iforMOf :: Overloaded (Index i) (WrappedMonad m) a b c d -> a -> (i -> c -> m d) -> m b +iforMOf = flip . imapMOf +{-# INLINE iforMOf #-} + +-- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'IndexedTraversal' with access to the index. +-- +-- 'imapAccumROf' accumulates state from right to left. +-- +-- @'Control.Lens.Traversal.mapAccumROf' l = 'imapAccumROf' l . 'const'@ +-- +-- > imapAccumROf :: IndexedLens i a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) +-- > imapAccumROf :: IndexedTraversal i a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) +imapAccumROf :: Overloaded (Index i) (Lazy.State s) a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) +imapAccumROf l f s0 a = swap (Lazy.runState (withIndex l (\i c -> Lazy.state (\s -> swap (f i s c))) a) s0) +{-# INLINE imapAccumROf #-} + +-- | Generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'IndexedTraversal' with access to the index. +-- +-- 'imapAccumLOf' accumulates state from left to right. +-- +-- @'Control.Lens.Traversal.mapAccumLOf' l = 'imapAccumLOf' l . 'const'@ +-- +-- > imapAccumLOf :: IndexedLens i a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) +-- > imapAccumLOf :: IndexedTraversal i a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) +imapAccumLOf :: Overloaded (Index i) (Backwards (Lazy.State s)) a b c d -> (i -> s -> c -> (s, d)) -> s -> a -> (s, b) +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 #-} + +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) +{-# INLINE swap #-} + 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 @@ -31,6 +31,7 @@ import Control.Applicative import Control.Category +import Control.Monad import Prelude hiding ((.),id) import Data.Monoid @@ -38,7 +39,7 @@ -- Functors ----------------------------------------------------------------------------- --- | Used by 'Focus' +-- | Used by 'Control.Lens.Type.Focus' newtype Focusing m c a = Focusing { unfocusing :: m (c, a) } @@ -54,16 +55,16 @@ (d, a) <- ma return (mappend c d, f a) --- | The indexed store can be used to characterize a 'LensFamily' --- and is used by 'clone' +-- | The indexed store can be used to characterize a 'Control.Lens.Type.Lens' +-- and is used by 'Control.Lens.Type.clone' data IndexedStore c d a = IndexedStore (d -> a) c instance Functor (IndexedStore c d) where fmap f (IndexedStore g c) = IndexedStore (f . g) c --- | Applicative composition of @State Int@ with a 'Functor', used --- by 'elementOf', 'elementsOf', 'traverseElement', 'traverseElementsOf' +-- | Applicative composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used +-- by 'Control.Lens.Traversal.elementOf', 'Control.Lens.Traversal.elementsOf', 'Control.Lens.Traversal.traverseElement', 'Control.Lens.Traversal.traverseElementsOf' newtype AppliedState f a = AppliedState { runAppliedState :: Int -> (f a, Int) } @@ -77,7 +78,7 @@ (ff, j) -> case ma j of (fa, k) -> (ff <*> fa, k) --- | Used internally by 'traverseOf_', 'mapM_' and the like. +-- | Used internally by 'Control.Lens.Traversal.traverseOf_' and the like. newtype Traversed f = Traversed { getTraversed :: f () } @@ -85,14 +86,14 @@ mempty = Traversed (pure ()) Traversed ma `mappend` Traversed mb = Traversed (ma *> mb) --- | Used internally by 'mapM_' and the like. +-- | Used internally by 'Control.Lens.Traversal.mapM_' and the like. newtype Sequenced m = Sequenced { getSequenced :: m () } instance Monad m => Monoid (Sequenced m) where mempty = Sequenced (return ()) Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) --- | Used for 'minimumOf' +-- | Used for 'Control.Lens.Fold.minimumOf' data Min a = NoMin | Min a instance Ord a => Monoid (Min a) where @@ -101,12 +102,12 @@ mappend m NoMin = m mappend (Min a) (Min b) = Min (min a b) --- | Obtain the minimum +-- | Obtain the minimum. getMin :: Min a -> Maybe a getMin NoMin = Nothing getMin (Min a) = Just a --- | Used for 'maximumOf' +-- | Used for 'Control.Lens.Fold.maximumOf' data Max a = NoMax | Max a instance Ord a => Monoid (Max a) where @@ -120,7 +121,7 @@ getMax NoMax = Nothing getMax (Max a) = Just a --- | The result of trying to find the nth element of a 'Traversal'. +-- | The result of trying to find the /n/th 'Control.Lens.Traversal.element' of a 'Control.Lens.Traversal.Traversal'. data ElementOfResult f a = Searching {-# UNPACK #-} !Int a | Found {-# UNPACK #-} !Int (f a) @@ -131,8 +132,8 @@ fmap f (Found i as) = Found i (fmap f as) fmap _ (NotFound e) = NotFound e --- | Used to find the nth element of a 'Traversal'. -data ElementOf f a = ElementOf { getElementOf :: Int -> ElementOfResult f a } +-- | Used to find the /n/th 'Control.Lens.Traversal.element' of a 'Control.Lens.Traversal.Traversal'. +newtype ElementOf f a = ElementOf { getElementOf :: Int -> ElementOfResult f a } instance Functor f => Functor (ElementOf f) where fmap f (ElementOf m) = ElementOf $ \i -> case m i of 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 @@ -146,18 +146,20 @@ -- | This isomorphism can be used to wrap or unwrap a value in 'Identity'. -- --- @x^.identity = 'Identity' x@ --- --- @'Identity' x^.from identity = x@ +-- @ +-- 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@ +-- @ +-- 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 #-} 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 @@ -10,7 +10,7 @@ -- -- Corepresentable endofunctors represented by their polymorphic lenses -- --- The polymorphic lenses of the form @(forall x. Lens (f x) x)@ each +-- The polymorphic lenses of the form @(forall x. 'Lens' (f x) x)@ each -- represent a distinct path into a functor @f@. If the functor is entirely -- characterized by assigning values to these paths, then the functor is -- representable. @@ -22,23 +22,31 @@ -- -- > data Pair a = Pair { _x :: a, _y :: a } -- --- > makeLenses ''Pair +-- @ 'Control.Lens.TH.makeLenses' \'\'Pair@ -- --- > instance Representable Pair where --- > rep f = Pair (f x) (f y) +-- @ +-- instance 'Representable' Pair where +-- 'rep' f = Pair (f x) (f y) +-- @ -- -- From there, you can get definitions for a number of instances for free. -- --- > instance Applicative Pair where --- > pure = pureRep --- > (<*>) = apRep +-- @ +-- instance 'Applicative' Pair where +-- 'pure' = 'pureRep' +-- ('<*>') = 'apRep' +-- @ -- --- > instance Monad Pair where --- > return = pureRep --- > (>>=) = bindRep +-- @ +-- instance 'Monad' Pair where +-- 'return' = 'pureRep' +-- ('>>=') = 'bindRep' +-- @ -- --- > instance Distributive Pair where --- > distribute = distributeRep +-- @ +-- instance 'Data.Distributive.Distributive' Pair where +-- 'Data.Distributive.distribute' = 'distributeRep' +-- @ -- ---------------------------------------------------------------------------- module Control.Lens.Representable @@ -84,9 +92,9 @@ -- | Representable Functors. -- -- A 'Functor' @f@ is 'Representable' if it is isomorphic to @(x -> a)@ --- for some x. All such functors can be represented by choosing @x@ to be +-- for some x. Nearly all such functors can be represented by choosing @x@ to be -- the set of lenses that are polymorphic in the contents of the 'Functor', --- that is to say @x = Rep f@ is a valid choice of 'x' for every +-- that is to say @x = 'Rep' f@ is a valid choice of 'x' for (nearly) every -- 'Representable' 'Functor'. -- -- Note: Some sources refer to covariant representable functors as @@ -104,53 +112,60 @@ instance Representable Identity where rep f = Identity (f (from identity)) --- | NB: The Eq requirement on this instance is a consequence of a lens --- rather than 'e' as the representation. +-- | 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 rep f e = f (resultAt e) --- | 'fmapRep' is a valid default definition for 'fmap' for a representable +-- | 'fmapRep' is a valid default definition for 'fmap' for a 'Representable' -- functor. -- --- > fmapRep f m = rep $ \i -> f (m^.i) +-- @'fmapRep' f m = 'rep' '$' \i -> f (m '^.' i)@ -- --- Usage for a representable functor @Foo@: +-- Usage for a @'Representable' Foo@: -- --- > instance Functor Foo where --- > fmap = fmapRep +-- @ +-- instance 'Functor' Foo where +-- 'fmap' = 'fmapRep' +-- @ fmapRep :: Representable f => (a -> b) -> f a -> f b fmapRep f m = rep $ \i -> f (m^.i) {-# INLINE fmapRep #-} -- | 'pureRep' is a valid default definition for 'pure' and 'return' for a --- representable functor. +-- 'Representable' functor. -- --- > pureRep = rep . const +-- @'pureRep' = 'rep' . 'const'@ -- --- Usage for a representable functor @Foo@: +-- Usage for a @'Representable' Foo@: -- --- > instance Applicative Foo where --- > pure = pureRep --- > (<*>) = apRep +-- @ +-- instance 'Applicative' Foo where +-- 'pure' = 'pureRep' +-- ... +-- @ -- --- > instance Monad Foo where --- > return = pureRep --- > (>>=) = bindRep +-- @ +-- instance 'Monad' Foo where +-- 'return' = 'pureRep' +-- ... +-- @ pureRep :: Representable f => a -> f a pureRep = rep . const {-# INLINE pureRep #-} --- | 'apRep' is a valid default definition for '(<*>)' for a representable +-- | 'apRep' is a valid default definition for ('<*>') for a 'Representable' -- functor. -- --- > apRep mf ma = rep $ \i -> mf^.i $ ma^.i +-- @'apRep' mf ma = 'rep' '$' \i -> mf '^.' i '$' ma '^.' i@ -- --- Usage for a representable functor @Foo@: +-- Usage for a @'Representable' Foo@: -- --- > instance Applicative Foo where --- > pure = pureRep --- > (<*>) = apRep +-- @ +-- instance 'Applicative' Foo where +-- 'pure' = 'pureRep' +-- ('<*>') = 'apRep' +-- @ apRep :: Representable f => f (a -> b) -> f a -> f b apRep mf ma = rep $ \i -> mf^.i $ ma^.i {-# INLINE apRep #-} @@ -158,25 +173,29 @@ -- | 'bindRep' is a valid default default definition for '(>>=)' for a -- representable functor. -- --- > bindRep m f = rep $ \i -> f(m^.i)^.i +-- @'bindRep' m f = 'rep' '$' \i -> f (m '^.' i) '^.' i@ -- --- Usage for a representable functor @Foo@: +-- Usage for a @'Representable' Foo@: -- --- > instance Monad ... where --- > return = pureRep --- > (>>=) = bindRep +-- @ +-- instance 'Monad' Foo where +-- 'return' = 'pureRep' +-- ('>>=') = 'bindRep' +-- @ bindRep :: Representable f => f a -> (a -> f b) -> f b bindRep m f = rep $ \i -> f(m^.i)^.i {-# INLINE bindRep #-} -- | A default definition for 'Data.Distributive.distribute' for a 'Representable' 'Functor' -- --- > distributeRep wf = rep $ \i -> fmap (^.i) wf +-- @'distributeRep' wf = 'rep' '$' \i -> 'fmap' ('^.' i) wf@ -- --- Typical Usage: +-- Usage for a @'Representable' Foo@: -- --- > instance Distributive ... where --- > distribute = distributeRep +-- @ +-- instance 'Data.Distributive.Distributive' Foo where +-- 'Data.Distributive.distribute' = 'distributeRep' +-- @ distributeRep :: (Representable f, Functor w) => w (f a) -> f (w a) distributeRep wf = rep $ \i -> fmap (^.i) wf {-# INLINE distributeRep #-} @@ -186,9 +205,9 @@ ----------------------------------------------------------------------------- -- | Sometimes you need to store a path lens into a container, but at least --- at this time, impredicative polymorphism in GHC is somewhat lacking. +-- at this time, @ImpredicativePolymorphism@ in GHC is somewhat lacking. -- --- This type provides a way to, say, store a list of polymorphic lenses. +-- This type provides a way to, say, store a @[]@ of polymorphic lenses. newtype Path f = Path { walk :: Rep f } -- | A 'Representable' 'Functor' has a fixed shape. This fills each position @@ -208,64 +227,64 @@ ----------------------------------------------------------------------------- --- | Map over a 'Representable' 'Functor' with access to the lens for the +-- | Map over a 'Representable' functor with access to the 'Lens' for the -- current position -- --- > mapWithKey f m = rep $ \i -> f i (m^.i) +-- @'mapWithRep' f m = 'rep' '$' \i -> f i (m '^.' i)@ mapWithRep :: Representable f => (Rep f -> a -> b) -> f a -> f b mapWithRep f m = rep $ \i -> f i (m^.i) {-# INLINE mapWithRep #-} --- | Traverse a 'Representable' 'Functor' with access to the current path +-- | Traverse a 'Representable' functor with access to the current path traverseWithRep :: (Representable f, Traversable f, Applicative g) => (Rep f -> a -> g b) -> f a -> g (f b) traverseWithRep f m = sequenceA (mapWithRep f m) {-# INLINE traverseWithRep #-} --- | Traverse a 'Representable' 'Functor' with access to the current path --- as a lens, discarding the result +-- | Traverse a 'Representable' functor with access to the current path +-- as a 'Lens', discarding the result traverseWithRep_ :: (Representable f, Foldable f, Applicative g) => (Rep f -> a -> g b) -> f a -> g () traverseWithRep_ f m = sequenceA_ (mapWithRep f m) {-# INLINE traverseWithRep_ #-} --- | Traverse a 'Representable' 'Functor' with access to the current path --- and a lens (and the arguments flipped) +-- | Traverse a 'Representable' functor with access to the current path +-- and a 'Lens' (and the arguments flipped) forWithRep :: (Representable f, Traversable f, Applicative g) => f a -> (Rep f -> a -> g b) -> g (f b) forWithRep m f = sequenceA (mapWithRep f m) {-# INLINE forWithRep #-} --- | 'mapM' over a 'Representable' 'Functor' with access to the current path --- as a lens +-- | 'mapM' over a 'Representable' functor with access to the current path +-- as a 'Lens' mapMWithRep :: (Representable f, Traversable f, Monad m) => (Rep f -> a -> m b) -> f a -> m (f b) mapMWithRep f m = Traversable.sequence (mapWithRep f m) {-# INLINE mapMWithRep #-} --- | 'mapM' over a 'Representable' 'Functor' with access to the current path --- as a lens, discarding the result +-- | 'mapM' over a 'Representable' functor with access to the current path +-- as a 'Lens', discarding the result mapMWithRep_ :: (Representable f, Foldable f, Monad m) => (Rep f -> a -> m b) -> f a -> m () mapMWithRep_ f m = Foldable.sequence_ (mapWithRep f m) {-# INLINE mapMWithRep_ #-} --- | 'mapM' over a 'Representable' 'Functor' with access to the current path --- as a lens (with the arguments flipped) +-- | 'mapM' over a 'Representable' functor with access to the current path +-- as a 'Lens' (with the arguments flipped) forMWithRep :: (Representable f, Traversable f, Monad m) => f a -> (Rep f -> a -> m b) -> m (f b) forMWithRep m f = Traversable.sequence (mapWithRep f m) {-# INLINE forMWithRep #-} --- | Fold over a 'Representable' 'Functor' with access to the current path --- as a lens, yielding a 'Monoid' +-- | Fold over a 'Representable' functor with access to the current path +-- as a 'Lens', yielding a 'Monoid' foldMapWithRep :: (Representable f, Foldable f, Monoid m) => (Rep f -> a -> m) -> f a -> m foldMapWithRep f m = fold (mapWithRep f m) {-# INLINE foldMapWithRep #-} --- | Fold over a 'Representable' 'Functor' with access to the current path --- as a lens. +-- | Fold over a 'Representable' functor with access to the current path +-- as a 'Lens'. foldrWithRep :: (Representable f, Foldable f) => (Rep f -> a -> b -> b) -> b -> f a -> b foldrWithRep f b m = Foldable.foldr id b (mapWithRep f m) {-# INLINE foldrWithRep #-} 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 @@ -1,6 +1,5 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Setter @@ -11,13 +10,13 @@ -- Portability : Rank2Types -- -- A @'Setter' a b c d@ is a generalization of 'fmap' from 'Functor'. It allows you to map into a --- structure and change out the contents, but it isn't strong enough to allow you to --- enumerate those contents. Starting with @fmap :: 'Functor' f => (c -> d) -> f c -> f d@ --- we monomorphize the type to obtain @(c -> d) -> a -> b@ and then decorate it with 'Identity' to obtain +-- structure and change out the contents, but it isn't strong enough to allow you to +-- enumerate those contents. Starting with @fmap :: 'Functor' f => (c -> d) -> f c -> f d@ +-- we monomorphize the type to obtain @(c -> d) -> a -> b@ and then decorate it with 'Identity' to obtain -- --- > type Setter a b c d = (c -> Identity d) -> a -> Identity b +-- @type 'Setter' a b c d = (c -> 'Identity' d) -> a -> 'Identity' b@ -- --- Every 'Control.Lens.Traversal.Traversal' is a valid 'Setter', since 'Identity' is 'Applicative'. +-- Every 'Control.Lens.Traversal.Traversal' is a valid 'Setter', since 'Identity' is 'Applicative'. -- -- Everything you can do with a 'Functor', you can do with a 'Setter'. There -- are combinators that generalize 'fmap' and ('<$'). @@ -75,17 +74,19 @@ -- -- You can't 'view' a 'Setter' in general, so the other two laws are irrelevant. -- --- However, two functor laws apply to a 'Setter' +-- However, two functor laws apply to a 'Setter': -- --- > adjust l id = id --- > adjust l f . adjust l g = adjust l (f . g) +-- 1. @'adjust' l id = id@ -- +-- 2. @'adjust' l f . 'adjust' l g = 'adjust' l (f . g)@ +-- -- These an be stated more directly: -- --- > l pure = pure --- > l f . run . l g = l (f . run . g) +-- 1. @l 'pure' = 'pure'@ -- --- You can compose a 'Setter' with a 'Control.Lens.Type.Lens' or a 'Control.Lens.Traversal.Traversal' using @(.)@ from the Prelude +-- 2. @l f . 'run' . l g = l (f . 'run' . g)@ +-- +-- You can compose a 'Setter' with a 'Control.Lens.Type.Lens' or a 'Control.Lens.Traversal.Traversal' using ('.') from the Prelude -- and the result is always only a 'Setter' and nothing more. type Setter a b c d = forall f. Settable f => (c -> f d) -> a -> f b @@ -140,9 +141,11 @@ -- | This setter can be used to map over all of the values in a 'Functor'. -- --- > fmap = adjust mapped --- > fmapDefault = adjust traverse --- > (<$) = set mapped +-- @'fmap' = 'adjust' 'mapped'@ +-- +-- @'Data.Traversable.fmapDefault' = 'adjust' 'Data.Traversable.traverse'@ +-- +-- @('<$') = 'set' 'mapped'@ mapped :: Functor f => Setter (f a) (f b) a b mapped = sets fmap {-# INLINE mapped #-} @@ -151,15 +154,16 @@ -- -- Your supplied function @f@ is required to satisfy: -- --- > f id = id --- > f g . f h = f (g . h) +-- @f 'id' = 'id'@ +-- @f g '.' f h = f (g '.' h)@ -- -- Equational reasoning: -- --- > sets . adjust = id --- > adjust . sets = id +-- @'sets' . 'adjust' = 'id'@ -- --- Another way to view 'sets' is that it takes a 'semantic editor combinator' +-- @'adjust' . 'sets' = 'id'@ +-- +-- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. sets :: ((c -> d) -> a -> b) -> Setter a b c d sets f g = pure . f (run . g) @@ -172,16 +176,20 @@ -- | Modify the target of a 'Control.Lens.Type.Lens' or all the targets of a 'Setter' or 'Control.Lens.Traversal.Traversal' -- with a function. -- --- > fmap = adjust mapped --- > fmapDefault = adjust traverse +-- @'fmap' = 'adjust' 'mapped'@ -- --- > sets . adjust = id --- > adjust . sets = id +-- @'Data.Traversable.fmapDefault' = 'adjust' 'Data.Traversable.traverse'@ -- --- > adjust :: Setter a b c d -> (c -> d) -> a -> b +-- Free Theorems: -- +-- 1. @'sets' . 'adjust' = 'id'@ +-- +-- 2. @'adjust' . 'sets' = 'id'@ +-- -- Another way to view 'adjust' is to say that it transformers a 'Setter' into a -- \"semantic editor combinator\". +-- +-- @'adjust' :: 'Setter' a b c d -> (c -> d) -> a -> b@ adjust :: Setting a b c d -> (c -> d) -> a -> b adjust l f = runMutator . l (Mutator . f) {-# INLINE adjust #-} @@ -189,14 +197,18 @@ -- | 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 adjust that is provided for consistency. -- --- > mapOf = adjust +-- @'mapOf' = 'adjust'@ -- --- > fmap = mapOf mapped --- > fmapDefault = mapOf traverse +-- @'fmap' = 'mapOf' 'mapped'@ -- --- > sets . mapOf = id --- > mapOf . sets = id +-- @'fmapDefault' = 'mapOf' 'traverse'@ -- +-- Free Theorems: +-- +-- 1. @'sets' . 'mapOf' = 'id'@ +-- +-- 2. @'mapOf' . 'sets' = 'id'@ +-- -- > mapOf :: Setter a b c d -> (c -> d) -> a -> b -- > mapOf :: Iso a b c d -> (c -> d) -> a -> b -- > mapOf :: Lens a b c d -> (c -> d) -> a -> b @@ -208,7 +220,7 @@ -- | 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. -- --- > (<$) = set mapped +-- @('<$') = 'set' 'mapped'@ -- -- > set :: Setter a b c d -> d -> a -> b -- > set :: Iso a b c d -> d -> a -> b @@ -223,12 +235,14 @@ -- -- This is an infix version of 'adjust' -- --- > fmap f = mapped %~ f --- > fmapDefault f = traverse %~ f +-- @'fmap' f = 'mapped' '%~' f@ -- --- > ghci> _2 %~ length $ (1,"hello") --- > (1,5) +-- @'Data.Traversable.fmapDefault' f = 'traverse' '%~' f@ -- +-- >>> import Control.Lens +-- >>> _2 %~ length $ (1,"hello") +-- (1,5) +-- -- > (%~) :: Setter a b c d -> (c -> d) -> a -> b -- > (%~) :: Iso a b c d -> (c -> d) -> a -> b -- > (%~) :: Lens a b c d -> (c -> d) -> a -> b @@ -242,11 +256,11 @@ -- -- This is an infix version of 'set', provided for consistency with ('.=') -- --- --- > f <$ a = mapped .~ f $ a +-- @f '<$' a = 'mapped' '.~' f '$' a@ -- --- > ghci> bitAt 0 .~ True $ 0 --- > 1 +-- >>> import Control.Lens +-- >>> _1 .~ "hello" $ (42,"world") +-- ("hello","world") -- -- > (.~) :: Setter a b c d -> d -> a -> b -- > (.~) :: Iso a b c d -> d -> a -> b @@ -267,14 +281,16 @@ -- | Increment the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' -- --- > ghci> _1 +~ 1 $ (1,2) --- > (2,2) +-- >>> import Control.Lens +-- >>> _1 +~ 1 $ (1,2) +-- (2,2) (+~) :: Num c => Setting a b c c -> c -> a -> b l +~ n = adjust l (+ n) {-# INLINE (+~) #-} -- | Multiply the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' -- +-- >>> import Control.Lens -- >>> _2 *~ 4 $ (1,2) -- (1,8) (*~) :: Num c => Setting a b c c -> c -> a -> b @@ -283,6 +299,7 @@ -- | Decrement the target(s) of a numerically valued 'Control.Lens.Type.Lens', 'Control.Lens.Iso.Iso', 'Setter' or 'Control.Lens.Traversal.Traversal' -- +-- >>> import Control.Lens -- >>> _1 -~ 2 $ (1,2) -- (-1,2) (-~) :: Num c => Setting a b c c -> c -> a -> b @@ -295,6 +312,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 -- +-- >>> import Control.Lens -- >>> _2 ^~ 2 $ (1,3) -- (1,9) (^~) :: (Num c, Integral e) => Setting a b c c -> e -> a -> b @@ -303,6 +321,7 @@ -- | Raise the target(s) of a fractionally valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an integral power -- +-- >>> import Control.Lens -- >>> _2 ^^~ (-1) $ (1,2) -- (1,0.5) (^^~) :: (Fractional c, Integral e) => Setting a b c c -> e -> a -> b @@ -311,6 +330,7 @@ -- | Raise the target(s) of a floating-point valued 'Control.Lens.Type.Lens', 'Setter' or 'Control.Lens.Traversal.Traversal' to an arbitrary power. -- +-- >>> import Control.Lens -- >>> _2 **~ pi $ (1,3) -- (1,31.54428070019754) (**~) :: Floating c => Setting a b c c -> c -> a -> b @@ -349,7 +369,7 @@ l .= b = State.modify (l .~ b) {-# INLINE (.=) #-} --- | Map over the target of a 'Control.Lens.Type.Lens' or all of the targets of a 'Setter' or 'Traversal in our monadic state. +-- | 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. -- -- > (%=) :: MonadState a m => Iso a a c d -> (c -> d) -> m () -- > (%=) :: MonadState a m => Lens a a c d -> (c -> d) -> m () @@ -433,7 +453,7 @@ -- > do foo <~ bar -- > ... -- --- will store the result in a lens/setter/traversal. +-- will store the result in a 'Control.Lens.Type.Lens', 'Setter', or 'Control.Lens.Traversal.Traversal'. (<~) :: MonadState a m => Setting a a c d -> m d -> m () l <~ md = md >>= (l .=) {-# INLINE (<~) #-} @@ -468,11 +488,3 @@ whisper :: (MonadWriter b m, Monoid a) => Setting a b c d -> d -> m () whisper l d = tell (set l d mempty) {-# INLINE whisper #-} - --- Local definition for doctests to avoid cycles - -_1 :: Functor f => (b -> f c) -> (b, a) -> f (c, a) -_1 f (a,b) = (\c -> (c,b)) <$> f a - -_2 :: Functor f => (b -> f c) -> (a, b) -> f (a, c) -_2 f (a,b) = (,) a <$> f b 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 @@ -19,30 +19,30 @@ -- -- A @'Lens' a b c d@ is a purely functional reference. -- --- While a 'Traversal' could be used for 'Getting' like a valid 'Fold', +-- While a 'Control.Lens.Traversal.Traversal' could be used for 'Control.Lens.Getter.Getting' like a valid 'Control.Lens.Fold.Fold', -- it wasn't a valid 'Getter' as Applicative isn't a superclass of -- 'Gettable'. -- -- 'Functor', however is the superclass of both. -- --- > type Lens a b c d = forall f. Functor f => (c -> f d) -> a -> f b +-- @type 'Lens' a b c d = forall f. 'Functor' f => (c -> f d) -> a -> f b@ -- --- Every 'Lens' is a valid 'Setter', choosing @f@ = 'Identity'. +-- Every 'Lens' is a valid 'Setter', choosing @f@ = 'Control.Lens.Getter.Mutator'. -- --- Every 'Lens' can be used for 'Getting' like a 'Fold' that doesn't use --- the 'Monoid'. +-- Every 'Lens' can be used for 'Control.Lens.Getter.Getting' like a 'Control.Lens.Fold.Fold' that doesn't use +-- the 'Applicative' or 'Control.Lens.Getter.Gettable'. -- --- Every 'Lens' is a valid 'Traversal' that only uses the 'Functor' part +-- Every 'Lens' is a valid 'Control.Lens.Traversal.Traversal' that only uses the 'Functor' part -- of the 'Applicative' it is supplied. -- --- Every 'Lens' can be used for 'Getting' like a valid 'Getter', choosing --- @f@ = 'Accessor' @r@ for an appropriate @r@ +-- Every 'Lens' can be used for 'Control.Lens.Getter.Getting' like a valid 'Getter', since 'Functor' is +-- a superclass of 'Control.Lens.Getter.Gettable' -- --- Since every 'Lens' can be used for 'Getting' like a valid 'Getter' it +-- Since every 'Lens' can be used for 'Control.Lens.Getter.Getting' like a valid 'Getter' it -- follows that it must view exactly one element in the structure. -- -- The lens laws follow from this property and the desire for it to act like --- a 'Traversable' when used as a 'Traversal'. +-- a 'Data.Traversable.Traversable' when used as a 'Control.Lens.Traversal.Traversal'. ---------------------------------------------------------------------------- module Control.Lens.Type ( @@ -95,6 +95,7 @@ infixr 4 <+~, <*~, <-~, ~ infix 4 <+=, <*=, <-=, = + -------------------------- -- Lenses -------------------------- @@ -105,50 +106,52 @@ -- -- 1) You get back what you put in: -- --- > view l (set l b a) = b +-- @'view' l ('set' l b a) = b@ -- -- 2) Putting back what you got doesn't change anything: -- --- > set l (view l a) a = a +-- @'set' l ('view' l a) a = a@ -- -- 3) Setting twice is the same as setting once: -- --- > set l c (set l b a) = set l c a +-- @'set' l c ('set' l b a) = 'set' l c a@ -- -- These laws are strong enough that the 4 type parameters of a 'Lens' cannot vary fully independently. For more on -- how they interact, read the "Why is it a Lens Family?" section of . -- --- Every 'Lens' can be used directly as a 'Setter' or 'Traversal'. +-- Every 'Lens' can be used directly as a 'Setter' or 'Control.Lens.Traversal.Traversal'. -- --- You can also use a 'Lens' for 'Getting' as if it were a 'Fold' or 'Getter'. +-- You can also use a 'Lens' for 'Control.Lens.Getter.Getting' as if it were a 'Control.Lens.Fold.Fold' or 'Getter'. -- --- Since every lens is a valid 'Traversal', the traversal laws should also apply to any lenses you create. +-- Since every lens is a valid 'Control.Lens.Traversal.Traversal', the traversal laws should also apply to any lenses you create. -- -- 1.) Idiomatic naturality: -- --- > l pure = pure +-- @l 'pure' = 'pure'@ -- -- 2.) Sequential composition: -- --- > fmap (l f) . l g = getCompose . l (Compose . fmap f . g) +-- @'fmap' (l f) . l g = 'Data.Functor.Compose.getCompose' . l ('Data.Functor.Compose.Compose' . 'fmap' f . g)@ -- --- > type Lens = forall f. Functor f => LensLike f a b c d +-- @type 'Lens' a b c d = forall f. 'Functor' f => 'LensLike' f a b c d@ type Lens a b c d = forall f. Functor f => (c -> f d) -> a -> f b --- | A @'Simple' 'Lens'@, @'Simple' 'Traversal'@, ... can be used instead of a 'Lens','Traversal', ... +-- | A 'Simple' 'Lens', 'Simple' 'Control.Lens.Traversal.Traversal', ... can be used instead of a 'Lens','Control.Lens.Traversal.Traversal', ... -- whenever the type variables don't change upon setting a value. -- --- > imaginary :: Simple Lens (Complex a) a --- > traverseHead :: Simple Traversal [a] a +-- @ +-- 'Data.Complex.Lens.imaginary' :: 'Simple' 'Lens' ('Data.Complex.Complex' a) a +-- 'Data.List.Lens.traverseHead' :: 'Simple' 'Control.Lens.Lens.Traversal' [a] a +-- @ -- --- Note: To use this alias in your own code with @'LensLike' f@ or @Setter@, you may have to turn on +-- Note: To use this alias in your own code with @'LensLike' f@ or 'Control.Lens.Setter.Setter', you may have to turn on -- @LiberalTypeSynonyms@. type Simple f a b = f a a b b --- | > type SimpleLens = Simple Lens +-- | @type 'SimpleLens' = 'Simple' 'Lens'@ type SimpleLens a b = Lens a a b b --- | > type SimpleLensLike f = Simple (LensLike f) +-- | @type 'SimpleLensLike' f = 'Simple' ('LensLike' f)@ type SimpleLensLike f a b = LensLike f a a b b -------------------------- @@ -167,13 +170,13 @@ -------------------------- -- | --- Many combinators that accept a 'Lens' can also accept a 'Traversal' in limited situations. +-- Many combinators that accept a 'Lens' can also accept a 'Control.Lens.Traversal.Traversal' in limited situations. -- -- They do so by specializing the type of 'Functor' that they require of the caller. -- -- If a function accepts a @'LensLike' f a b c d@ for some 'Functor' @f@, then they may be passed a 'Lens'. -- --- Further, if @f@ is an 'Applicative', they may also be passed a 'Traversal'. +-- Further, if @f@ is an 'Applicative', they may also be passed a 'Control.Lens.Traversal.Traversal'. type LensLike f a b c d = (c -> f d) -> a -> f b -- | ('%%~') can be used in one of two scenarios: @@ -181,12 +184,12 @@ -- When applied to a 'Lens', it can edit the target of the 'Lens' in a structure, extracting a -- functorial result. -- --- When applied to a 'Traversal', it can edit the targets of the 'Traversals', extracting an +-- When applied to a 'Control.Lens.Traversal.Traversal', it can edit the targets of the 'Traversals', extracting an -- applicative summary of its actions. -- -- For all that the definition of this combinator is just: -- --- > (%%~) = id +-- @('%%~') = 'id'@ -- -- > (%%~) :: Functor f => Iso a b c d -> (c -> f d) -> a -> f b -- > (%%~) :: Functor f => Lens a b c d -> (c -> f d) -> a -> f b @@ -194,7 +197,7 @@ -- -- It may be beneficial to think about it as if it had these even more restrictive types, however: -- --- When applied to a 'Traversal', it can edit the targets of the 'Traversals', extracting a +-- When applied to a 'Control.Lens.Traversal.Traversal', it can edit the targets of the 'Traversals', extracting a -- supplemental monoidal summary of its actions, by choosing f = ((,) m) -- -- > (%%~) :: Iso a b c d -> (c -> (e, d)) -> a -> (e, b) @@ -205,10 +208,10 @@ {-# INLINE (%%~) #-} -- | Modify the target of a 'Lens' in the current state returning some extra information of @c@ or --- modify all targets of a 'Traversal' in the current state, extracting extra information of type @c@ +-- modify all targets of a 'Control.Lens.Traversal.Traversal' in the current state, extracting extra information of type @c@ -- and return a monoidal summary of the changes. -- --- > (%%=) = (state.) +-- @('%%=') = ('state' '.')@ -- -- It may be useful to think of ('%%='), instead, as having either of the following more restricted -- type signatures: @@ -229,11 +232,11 @@ -- | This class allows us to use 'focus' on a number of different monad transformers. class Focus st where - -- | Run a monadic action in a larger context than it was defined in, using a 'Simple' 'Lens' or 'Simple' 'Traversal'. + -- | Run a monadic action in a larger context than it was defined in, using a 'Simple' 'Lens' or 'Simple' 'Control.Lens.Traversal.Traversal'. -- -- This is commonly used to lift actions in a simpler state monad into a state monad with a larger state type. -- - -- When applied to a 'Simple 'Traversal' over multiple values, the actions for each target are executed sequentially + -- When applied to a 'Simple 'Control.Lens.Traversal.Traversal' over multiple values, the actions for each target are executed sequentially -- and the results are aggregated monoidally -- and a monoidal summary -- of the result is given. @@ -286,24 +289,28 @@ -- | This is a lens that can change the value (and type) of the first field of -- a pair. -- --- > ghci> (1,2)^._1 --- > 1 +-- >>> import Control.Lens -- --- > ghci> _1 +~ "hello" $ (1,2) --- > ("hello",2) +-- >>> (1,2)^._1 +-- 1 -- --- > _1 :: Functor f => (a -> f b) -> (a,c) -> f (a,c) +-- >>> _1 .~ "hello" $ (1,2) +-- ("hello",2) +-- +-- @_1 :: 'Functor' f => (a -> f b) -> (a,c) -> f (a,c)@ _1 :: Lens (a,c) (b,c) a b _1 f (a,c) = (\b -> (b,c)) <$> f a {-# INLINE _1 #-} -- | As '_1', but for the second field of a pair. -- --- > anyOf _2 :: (c -> Bool) -> (a, c) -> Bool --- > traverse._2 :: (Applicative f, Traversable t) => (a -> f b) -> t (c, a) -> f (t (c, b)) --- > foldMapOf (traverse._2) :: (Traversable t, Monoid m) => (c -> m) -> t (b, c) -> m +-- @ +-- 'Control.Lens.Fold.anyOf' '_2' :: (c -> 'Bool') -> (a, c) -> 'Bool' +-- 'Data.Traversable.traverse' '.' '_2' :: ('Applicative' f, 'Data.Traversable.Traversable' t) => (a -> f b) -> t (c, a) -> f (t (c, b)) +-- 'Control.Lens.Fold.foldMapOf' ('Data.Traversable.traverse' '.' '_2') :: ('Data.Traversable.Traversable' t, 'Data.Monoid.Monoid' m) => (c -> m) -> t (b, c) -> m +-- @ -- --- > _2 :: Functor f => (a -> f b) -> (c,a) -> f (c,b) +-- @_2 :: 'Functor' f => (a -> f b) -> (c,a) -> f (c,b)@ _2 :: Lens (c,a) (c,b) a b _2 f (c,a) = (,) c <$> f a {-# INLINE _2 #-} @@ -337,11 +344,11 @@ -- | -- -- Cloning a 'Lens' is one way to make sure you arent given --- something weaker, such as a 'Traversal' and can be used +-- something weaker, such as a 'Control.Lens.Traversal.Traversal' and can be used -- as a way to pass around lenses that have to be monomorphic in 'f'. -- -- Note: This only accepts a proper 'Lens', because 'IndexedStore' lacks its --- (admissable) Applicative instance. +-- (admissable) 'Applicative' instance. -- clone :: Functor f => LensLike (IndexedStore c d) a b c d @@ -354,10 +361,10 @@ -- Overloading function application ----------------------------------------------------------------------------- --- | > type LensLike f a b c d = Overloaded (->) f a b c d +-- | @type 'LensLike' f a b c d = 'Overloaded' (->) f a b c d@ type Overloaded k f a b c d = k (c -> f d) (a -> f b) --- | > type SimpleOverloaded k f a b = Simple (Overloaded k f) a b +-- | @type 'SimpleOverloaded' k f a b = 'Simple' ('Overloaded' k f) a b@ type SimpleOverloaded k f a b = Overloaded k f a a b b ----------------------------------------------------------------------------- @@ -385,9 +392,9 @@ l <-~ c = l <%~ subtract c {-# INLINE (<-~) #-} --- | Decrement the target of a numerically valued 'Lens' and return the result +-- | Multiply the target of a numerically valued 'Lens' and return the result -- --- When you do not need the result of the subtraction, ('*~') is more flexible. +-- When you do not need the result of the multiplication, ('*~') is more flexible. (<*~) :: Num c => LensLike ((,)c) a b c c -> c -> a -> (c, b) l <*~ c = l <%~ (* c) {-# INLINE (<*~) #-} @@ -445,7 +452,7 @@ -- Setting and Remembering State ----------------------------------------------------------------------------- --- | Modify the target of a ' into your monad's state by a user supplied function and return the result. +-- | Modify the target of a 'Lens' into your monad's state by a user supplied function and return the result. -- -- When you do not need the result of the operation, ('%=') is more flexible. (<%=) :: MonadState a m => LensLike ((,)d) a a c d -> (c -> d) -> m d 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 @@ -24,39 +24,46 @@ -- | Evaluate the targets of a 'Lens' or 'Traversal' into a data structure -- according to the given strategy. -- --- > evalTraversable = evalTraversal traverse --- --- > evalTraversal = id --- --- > evalTraversal :: Simple Lens a b -> Strategy b -> Strategy a --- > evalTraversal :: Simple Traversal a b -> Strategy b -> Strategy a +-- @ +-- 'evalTraversable' = 'evalTraversal' 'traverse' = 'traverse' +-- 'evalTraversal' = 'id' +-- @ -- --- > evalTraversal :: (b -> Eval b) -> a -> Eval a) -> Strategy b -> Strategy a +-- @ +-- evalTraversal :: 'Simple' 'Lens' a b -> 'Strategy' b -> 'Strategy' a +-- evalTraversal :: 'Simple' 'Traversal' a b -> 'Strategy' b -> 'Strategy' a +-- evalTraversal :: (b -> 'Eval' b) -> a -> 'Eval' a) -> 'Strategy' b -> 'Strategy' a +-- @ evalOf :: LensLike Eval a a b b -> Strategy b -> Strategy a evalOf l = l -- | Evaluate the targets of a 'Lens' or 'Traversal' according into a -- data structure according to a given 'Strategy' in parallel. -- --- > parTraversable = parTraversal traverse --- --- > parTraversal :: Simple Lens a b -> Strategy b -> Strategy a --- > parTraversal :: Simple Traversal a b -> Strategy b -> Strategy a +-- @'parTraversable' = 'parTraversal' 'traverse'@ -- --- > parTraversal :: ((b -> Eval b) -> a -> Eval a) -> Strategy b -> Strategy a +-- @ +-- parTraversal :: 'Simple' 'Lens' a b -> 'Strategy' b -> 'Strategy' a +-- parTraversal :: 'Simple' 'Traversal' a b -> 'Strategy' b -> 'Strategy' a +-- parTraversal :: ((b -> 'Eval' b) -> a -> 'Eval' a) -> 'Strategy' b -> 'Strategy' a +-- @ parOf :: LensLike Eval a a b b -> Strategy b -> Strategy a parOf l s = l (rparWith s) -- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to --- first evaluates its argument according to a given strategy, before proceeding. +-- first evaluates its argument according to a given strategy /before/ proceeding. -- --- > after rdeepseq traverse +-- @ +-- 'after' 'rdeepseq' 'traverse' :: 'Traversable' t => 'Strategy' a -> 'Strategy' [a] +-- @ after :: Strategy a -> LensLike f a b c d -> LensLike f a b c d after s l f = l f $| s -- | Transform a 'Lens', 'Fold', 'Getter', 'Setter' or 'Traversal' to --- evaluate its argument according to a given strategy in parallel with evaluating. +-- evaluate its argument according to a given strategy /in parallel with/ evaluating. -- --- > meanwhile rdeepseq traverse +-- @ +-- 'meanwhile' 'rdeepseq' 'traverse' :: 'Traversable' t => 'Strategy' a -> 'Strategy' [a] +-- @ meanwhile :: Strategy a -> LensLike f a b c d -> LensLike f a b c d meanwhile s l f = l f $|| s 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 @@ -27,35 +27,38 @@ -- | Access an element of an array. -- --- Note: The indexed element is assumed to exist in the target array. +-- Note: The indexed element is assumed to exist in the target 'IArray'. -- --- > arr ! i = arr^.ix i --- > arr // [(i,e)] = ix i ^= e $ arr +-- @arr '!' i = arr '^.' 'ix' i@ -- --- >>> ix 2 ^= 9 $ listArray (1,5) [4,5,6,7,8] --- array (1,5) [4,9,6,7,8] +-- @arr '//' [(i,e)] = 'ix' i '.~' e '$' arr@ +-- +-- >>> 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) {-# INLINE ix #-} --- | This setter can be used to derive a new array from an old array by --- applying a function to each of the indices. +-- | This setter can be used to derive a new 'IArray' from an old array by +-- applying a function to each of the indices to look it up in the old 'IArray'. -- -- This is a /contravariant/ 'Setter'. -- --- > ixmap = adjust . ixmapped --- > ixmapped = sets . ixmap +-- @'ixmap' = 'adjust' . 'ixmapped'@ -- --- > adjust (ixmapped b) f arr ! i = arr ! f i --- > bounds (adjust (ixmapped b) f arr) = b +-- @'ixmapped' = 'sets' . 'ixmap'@ +-- +-- @'adjust' ('ixmapped' b) f arr '!' i = arr '!' f i@ +-- +-- @'bounds' ('adjust' ('ixmapped' b) f arr) = b@ ixmapped :: (IArray a e, Ix i, Ix j) => (i,i) -> Setter (a j e) (a i e) i j ixmapped = sets . ixmap {-# INLINE ixmapped #-} --- | Generic 'IndexedTraversal' of the elements of an array, using the index into the --- array as the index of the traversal. +-- | An 'IndexedTraversal' of the elements of an 'IArray', using the +-- index into the array as the index of the traversal. -- --- > amap = adjust traverseArray +-- @'amap' = 'adjust' 'traverseArray'@ traverseArray :: (IArray a c, IArray a d, Ix i) => IndexedTraversal i (a i c) (a i d) c d traverseArray = index $ \f arr -> array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f i a) (assocs arr) {-# INLINE traverseArray #-} 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 @@ -6,7 +6,7 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional +-- Stability : experimental -- Portability : LiberalTypeSynonyms -- ---------------------------------------------------------------------------- @@ -53,26 +53,27 @@ -- | This lens can be used to access the value of the nth bit in a number. -- --- @bitAt n@ is only a legal 'Lens' into @b@ if @0 <= n < bitSize (undefined :: b)@ +-- @'bitAt' n@ is only a legal 'Lens' into @b@ if @0 <= n < 'bitSize' ('undefined' :: b)@ -- -- >>> 16^.bitAt 4 -- True -- -- >>> 15^.bitAt 4 -- False -bitAt :: Bits b => Int -> Simple Lens b Bool -bitAt n f b = (\x -> if x then setBit b n else clearBit b n) <$> f (testBit b n) +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) {-# INLINE bitAt #-} -- | Traverse over all bits in a numeric type. -- -- The bit position is available as the index. -- +-- >>> import Data.Word -- >>> toListOf traverseBits (5 :: Word8) -- [True,False,True,False,False,False,False,False] -- --- If you supply this an Integer, it won't crash, but the result will --- be an infinite traversal that can be productively consumed. +-- If you supply this an 'Integer', the result will +-- be an infinite 'Traversal' that can be productively consumed. traverseBits :: Bits b => SimpleIndexedTraversal Int b Bool traverseBits = index $ \f b -> let g n = (,) n <$> f n (testBit b n) 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 FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lazy.Lens @@ -17,12 +18,14 @@ import Control.Lens import Data.ByteString.Lazy as Words import Data.ByteString.Lazy.Char8 as Char8 +import Data.List.Lens import Data.Word (Word8) --- | Pack (or unpack) a list of bytes into a 'ByteString' +-- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString' -- --- > pack x = x^.packedBytes --- > unpack x = x^.from packedBytes +-- @'Data.ByteString.Lazy.pack' x = x '^.' 'packedBytes'@ +-- +-- @'Data.ByteString.Lazy.unpack' x = x '^.' 'from' 'packedBytes'@ packedBytes :: Simple Iso [Word8] ByteString packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} @@ -30,20 +33,21 @@ -- | Traverse the individual bytes in a 'ByteString' -- --- > bytes = from packedBytes . traverse +-- @'bytes' = 'from' 'packedBytes' . 'traverseList'@ -- --- > anyOf bytes (==0x80) :: ByteString -> Bool -bytes :: Simple Traversal ByteString Word8 -bytes = from packedBytes . traverse +-- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@ +bytes :: SimpleIndexedTraversal Int ByteString Word8 +bytes = from packedBytes .> traverseList {-# INLINE bytes #-} --- | Pack (or unpack) a list of characters into a 'ByteString' +-- | 'Data.ByteString.Lazy.Char8.pack' (or 'Data.ByteString.Lazy.Char8.unpack') a list of characters into a 'ByteString' -- --- When writing back to the byteString it is assumed that all characters --- lie between '\x00' and '\xff'. +-- When writing back to the 'ByteString' it is assumed that every 'Char' +-- lies between '\x00' and '\xff'. -- --- > pack x = x^.packedChars --- > unpack x = x^.from packedChars +-- @'Data.ByteString.Lazy.Char8.pack' x = x '^.' 'packedChars'@ +-- +-- @'Data.ByteString.Lazy.Char8.unpack' x = x '^.' 'from' 'packedChars'@ packedChars :: Simple Iso String ByteString packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-} @@ -51,12 +55,12 @@ -- | Traverse the individual bytes in a 'ByteString' as characters. -- --- When writing back to the byteString it is assumed that all characters --- lie between '\x00' and '\xff'. +-- When writing back to the 'ByteString' it is assumed that every 'Char' +-- lies between '\x00' and '\xff'. -- --- > chars = from packed . traverse +-- @'chars' = 'from' 'packedChars' '.>' 'traverseList'@ -- --- > anyOf chars (=='c') :: ByteString -> Bool -chars :: Simple Traversal ByteString Char -chars = from packedChars . traverse +-- @'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'@ +chars :: SimpleIndexedTraversal Int ByteString Char +chars = from packedChars .> traverseList {-# INLINE chars #-} 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 FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.ByteString.Lens @@ -16,33 +17,36 @@ import Control.Lens import Data.ByteString as Words import Data.ByteString.Char8 as Char8 +import Data.List.Lens import Data.Word (Word8) --- | Pack (or unpack) a list of bytes into a 'ByteString' +-- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' -- --- > pack x = x^.packedBytes --- > unpack x = x^.from packedBytes +-- @'Data.ByteString.pack' x = x '^.' 'packedBytes'@ +-- +-- @'Data.ByteString.unpack' x = x '^.' 'from' 'packedBytes'@ packedBytes :: Simple Iso [Word8] ByteString packedBytes = iso Words.pack Words.unpack {-# INLINE packedBytes #-} {-# SPECIALIZE packedBytes :: Simple Lens [Word8] ByteString #-} --- | Traverse the individual bytes in a 'ByteString' +-- | Traverse each 'Word8' in a 'ByteString' -- --- > bytes = from packedBytes . traverse +-- @'bytes' = 'from' 'packedBytes' '.>' 'traverseList'@ -- --- > anyOf bytes (==0x80) :: ByteString -> Bool -bytes :: Simple Traversal ByteString Word8 -bytes = from packedBytes . traverse +-- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@ +bytes :: SimpleIndexedTraversal Int ByteString Word8 +bytes = from packedBytes .> traverseList {-# INLINE bytes #-} --- | Pack (or unpack) a list of characters into a 'ByteString' +-- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a 'ByteString' -- --- When writing back to the byteString it is assumed that all characters --- lie between '\x00' and '\xff'. +-- When writing back to the 'ByteString' it is assumed that every 'Char' +-- lies between '\x00' and '\xff'. -- --- > pack x = x^.packedChars --- > unpack x = x^.from packedChars +-- @'Data.ByteString.Char8.pack' x = x '^.' 'packedChars'@ +-- +-- @'Data.ByteString.Char8.unpack' x = x '^.' 'from' 'packedChars'@ packedChars :: Simple Iso String ByteString packedChars = iso Char8.pack Char8.unpack {-# INLINE packedChars #-} @@ -50,12 +54,12 @@ -- | Traverse the individual bytes in a 'ByteString' as characters. -- --- When writing back to the byteString it is assumed that all characters --- lie between '\x00' and '\xff'. +-- When writing back to the 'ByteString' it is assumed that every 'Char' +-- lies between '\x00' and '\xff'. -- --- > chars = from packed . traverse +-- @'chars' = 'from' 'packed' . 'traverse'@ -- --- > anyOf chars (=='c') :: ByteString -> Bool -chars :: Simple Traversal ByteString Char -chars = from packedChars . traverse +-- @'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'@ +chars :: SimpleIndexedTraversal Int ByteString Char +chars = from packedChars .> traverseList {-# INLINE chars #-} 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 @@ -5,8 +5,8 @@ -- Copyright : (C) 2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett --- Stability : provisional --- Portability : Haskell2010 +-- Stability : experimental +-- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Complex.Lens @@ -18,7 +18,7 @@ import Control.Lens import Data.Complex --- | Access the real part of a complex number +-- | Access the 'realPart' of a 'Complex' number -- -- > real :: Functor f => (a -> f a) -> Complex a -> f (Complex a) #if MIN_VERSION_base(4,4,0) @@ -28,7 +28,7 @@ #endif real f (a :+ b) = (:+ b) <$> f a --- | Access the imaginary part of a complex number +-- | Access the 'imaginaryPart' of a 'Complex' number -- -- > imaginary :: Functor f => (a -> f a) -> Complex a -> f (Complex a) #if MIN_VERSION_base(4,4,0) @@ -38,16 +38,20 @@ #endif imaginary f (a :+ b) = (a :+) <$> f b --- | 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! Otherwise, this is a --- perfectly cromulent lens. +-- | 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! +-- +-- Otherwise, this is a perfectly cromulent 'Lens'. polarize :: (RealFloat a, RealFloat b) => Iso (Complex a) (Complex b) (a,a) (b,b) polarize = isos polar (uncurry mkPolar) polar (uncurry mkPolar) --- | Traverse both the real and imaginary parts of a complex number. +-- | Traverse both the real and imaginary parts of a 'Complex' number. -- -- > traverseComplex :: Applicative f => (a -> f b) -> Complex a -> f (Complex b) #if MIN_VERSION_base(4,4,0) diff --git a/src/Data/IntMap/Lens.hs b/src/Data/IntMap/Lens.hs --- a/src/Data/IntMap/Lens.hs +++ b/src/Data/IntMap/Lens.hs @@ -34,10 +34,10 @@ -- fromList [(1,"hello")] -- -- > at :: Int -> (Maybe v -> f (Maybe v)) -> IntMap v -> f (IntMap v) -at :: Int -> Simple Lens (IntMap v) (Maybe v) -at k f m = go <$> f (IntMap.lookup k m) where - go Nothing = IntMap.delete k m - go (Just v') = IntMap.insert k v' m +at :: Int -> SimpleIndexedLens Int (IntMap v) (Maybe v) +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 #-} -- | Traversal of an 'IntMap' indexed by the key. @@ -49,8 +49,8 @@ -- -- > traverseAt :: Applicative f => Int -> (v -> f v) -> IntMap v -> f (IntMap v) -- > traverseAt k = at k . traverse -traverseAt :: Int -> Simple Traversal (IntMap v) v -traverseAt k = at k . traverse +traverseAt :: Int -> SimpleIndexedTraversal Int (IntMap v) v +traverseAt k = at k <. traverse {-# INLINE traverseAt #-} -- | Traverse the value at the minimum key in a Map diff --git a/src/Data/Map/Lens.hs b/src/Data/Map/Lens.hs --- a/src/Data/Map/Lens.hs +++ b/src/Data/Map/Lens.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Map.Lens @@ -21,16 +20,17 @@ ) where import Control.Applicative as Applicative -import Control.Lens.Type import Control.Lens.Traversal import Control.Lens.Indexed -import Control.Lens.Getter -- used by tests -import Control.Lens.Setter -- used by tests +import Control.Lens.IndexedLens +import Control.Lens.IndexedTraversal import Data.Map as Map import Data.Traversable -- | This 'Lens' can be used to read, write or delete the value associated with a key in a 'Map'. -- +-- >>> :m + Control.Lens Data.Map.Lens +-- -- >>> Map.fromList [("hello",12)] ^.at "hello" -- Just 12 -- @@ -38,10 +38,10 @@ -- fromList [(10,"hello")] -- -- > at :: Ord k => k -> (Maybe v -> f (Maybe v)) -> Map k v -> f (Map k v) -at :: Ord k => k -> SimpleLens (Map k v) (Maybe v) -at k f m = go <$> f (Map.lookup k m) where - go Nothing = Map.delete k m - go (Just v') = Map.insert k v' m +at :: Ord k => k -> SimpleIndexedLens k (Map k v) (Maybe v) +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 #-} -- | Traversal of a 'Map' indexed by the key. @@ -52,8 +52,8 @@ -- -- > traverseAt :: (Applicative f, Ord k) => k -> (v -> f v) -> Map k v -> f (Map k v) -- > traverseAt k = valueAt k . traverse -traverseAt :: Ord k => k -> SimpleTraversal (Map k v) v -traverseAt k = at k . traverse +traverseAt :: Ord k => k -> SimpleIndexedTraversal k (Map k v) v +traverseAt k = at k <. traverse {-# INLINE traverseAt #-} -- | Traverse the value at the minimum key in a Map. 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 @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Set.Lens @@ -19,11 +18,11 @@ import Control.Lens.Type import Control.Lens.Setter import Control.Lens.Getter -import Control.Lens.Fold -- For tests import Data.Set as Set -- | This 'Lens' can be used to read, write or delete a member of a 'Set' -- +-- >>> :m + Data.Set.Lens Control.Lens -- >>> contains 3 .~ False $ Set.fromList [1,2,3,4] -- fromList [1,2,4] -- @@ -40,6 +39,7 @@ -- Sadly, you can't create a valid 'Traversal' for a 'Set', but you can -- manipulate it by reading using 'folded' and reindexing it via 'setmap'. -- +-- >>> :m + Data.Set.Lens Control.Lens -- >>> adjust setmapped (+1) (fromList [1,2,3,4]) -- fromList [2,3,4,5] setmapped :: (Ord i, Ord j) => Setter (Set i) (Set j) i j @@ -47,6 +47,7 @@ -- | Construct a set from a 'Getter', 'Fold', 'Traversal', 'Lens' or 'Iso'. -- +-- >>> :m + Data.Set.Lens Control.Lens -- >>> setOf (folded._2) [("hello",1),("world",2),("!!!",3)] -- fromList [1,2,3] -- diff --git a/src/GHC/Generics/Lens.hs b/src/GHC/Generics/Lens.hs --- a/src/GHC/Generics/Lens.hs +++ b/src/GHC/Generics/Lens.hs @@ -10,38 +10,49 @@ -- Stability : experimental -- Portability : GHC -- +-- Note: @GHC.Generics@ exports a number of names that collide with @Control.Lens@. +-- +-- You can use hiding or imports to mitigate this to an extent, and the following imports, +-- represent a fair compromise for user code: +-- +-- > import Control.Lens hiding (Rep) +-- > import GHC.Generics hiding (from, to) +-- +-- You can use 'generic' to replace 'GHC.Generics.from' and 'GHC.Generics.to' from @GHC.Generics@, +-- and probably won't be explicitly referencing 'Control.Lens.Representable.Rep' from @Control.Lens@ +-- in code that uses generics. ---------------------------------------------------------------------------- module GHC.Generics.Lens ( - -- * Conversion to/from generic + -- * Isomorphisms for @GHC.Generics@ generic , generic1 - -- * Generic Traversal + -- * 'Generic' 'Traversal' , every , GTraversal ) where -import Control.Applicative -import Control.Lens.Iso hiding (from) -import Control.Lens.Traversal -import Control.Lens.Type -import Data.Maybe (fromJust) -import Data.Typeable -import GHC.Generics +import Control.Applicative +import Control.Lens hiding (Rep) +import Data.Maybe (fromJust) +import Data.Typeable +import qualified GHC.Generics as Generic +import GHC.Generics hiding (from, to) -- | Convert from the data type to its representation (or back) -- --- >>> "hello"^.generic.from generic +-- >>> "hello"^.generic.from generic :: String -- "hello" -- -generic :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b y) -generic = isos from to from to +generic :: Generic a => Simple Iso a (Rep a b) +generic = iso Generic.from Generic.to -- | Convert from the data type to its representation (or back) -generic1 :: (Generic1 f, Generic1 g) => Iso (f a) (g b) (Rep1 f a) (Rep1 g b) -generic1 = isos from1 to1 from1 to1 +generic1 :: Generic1 f => Simple Iso (f a) (Rep1 f a) +generic1 = iso from1 to1 --- | Traverse using GHC.Generics. +-- | A 'GHC.Generics.Generic' 'Traversal' that visits every occurence +-- of something 'Typeable' anywhere in a container. -- -- >>> allOf every (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"]) -- True @@ -52,7 +63,7 @@ every :: (Generic a, GTraversal (Rep a), Typeable b) => Simple Traversal a b every = generic . everyr True --- | Traversable generic data types. Used by 'every'. +-- | Used to traverse 'Generic' data by 'every'. class GTraversal f where everyr :: Typeable b => Bool -> Simple Traversal (f a) b diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -7,10 +7,16 @@ "-isrc" , "-idist/build/autogen" , "-optP-include", "-optPdist/build/autogen/cabal_macros.h" - , "src/Control/Lens.hs" + , "src/Control/Lens/Action.hs" + , "src/Control/Lens/Fold.hs" + , "src/Control/Lens/Getter.hs" + , "src/Control/Lens/Setter.hs" + , "src/Data/Array/Lens.hs" + , "src/Data/Bits/Lens.hs" , "src/Data/IntMap/Lens.hs" , "src/Data/IntSet/Lens.hs" , "src/Data/List/Lens.hs" , "src/Data/Map/Lens.hs" , "src/Data/Set/Lens.hs" + , "src/GHC/Generics/Lens.hs" ] diff --git a/test/properties.hs b/test/properties.hs new file mode 100644 --- /dev/null +++ b/test/properties.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.Applicative +import Control.Monad +import Control.Lens +import Data.Functor.Identity +import System.Exit +import Test.QuickCheck +import Test.QuickCheck.All +import Test.QuickCheck.Function +import Data.Pair.Lens +import Data.Either.Lens +import Data.Text.Lens + +setter_id :: Eq a => Simple Setter a b -> a -> Bool +setter_id l a = runIdentity (l Identity a) == a + +setter_composition :: Eq a => Simple Setter a b -> a -> Fun b b -> Fun b b -> Bool +setter_composition l a (Fun _ f) (Fun _ g) = mapOf l f (mapOf l g a) == mapOf l (f . g) a + +lens_set_view :: Eq a => Simple Lens a b -> a -> Bool +lens_set_view l a = set l (a^.l) a == a + +lens_view_set :: Eq b => Simple Lens a b -> a -> b -> Bool +lens_view_set l a b = set l b a^.l == b + +traversal_set_set :: Eq a => Simple Traversal a b -> a -> b -> b -> Bool +traversal_set_set l a b c = set l c (set l b a) == set l c a + +iso_hither :: Eq a => Simple Iso a b -> a -> Bool +iso_hither l a = a ^.l.from l == a + +iso_yon :: Eq b => Simple Iso a b -> b -> Bool +iso_yon l b = b^.from l.l == b + +isSetter :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b) + => Simple Setter a b -> Property +isSetter l = setter_id l .&. setter_composition l + +isTraversal :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Function b) + => Simple Traversal a b -> Property +isTraversal l = isSetter l .&. traversal_set_set l + +isLens :: (Arbitrary a, Arbitrary b, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function b) + => Simple Lens a b -> Property +isLens l = lens_set_view l .&. lens_view_set l .&. isTraversal l + +isIso :: (Arbitrary a, Arbitrary b, CoArbitrary a, CoArbitrary b, Show a, Show b, Eq a, Eq b, Function a, Function b) + => Simple Iso a b -> Property +isIso l = iso_hither l .&. iso_yon l .&. isLens l .&. isLens (from l) + +-- an illegal lens +bad :: Simple Lens (Int,Int) Int +bad f (a,b) = (,) b <$> f a + +badIso :: Simple Iso Int Bool +badIso = iso even fromEnum + +-- Control.Lens.Type +prop_1 = isLens (_1 :: Simple Lens (Int,Double) Int) +prop_2 = isLens (_2 :: Simple Lens (Int,Bool) Bool) +prop_2_2 = isLens (_2._2 :: Simple Lens (Int,(Int,Bool)) Bool) + +prop_illegal_lens = expectFailure $ isLens bad +prop_illegal_traversal = expectFailure $ isTraversal bad +prop_illegal_setter = expectFailure $ isSetter bad +prop_illegal_iso = expectFailure $ isIso badIso + +-- Control.Lens.Setter +prop_mapped = isSetter (mapped :: Simple Setter [Int] Int) +prop_mapped_mapped = isSetter (mapped.mapped :: Simple Setter [Maybe Int] Int) + + + +prop_both = isTraversal (both :: Simple Traversal (Int,Int) Int) +prop_value (Fun _ k :: Fun Int Bool) = isTraversal (value k :: Simple Traversal (Int,Int) Int) +prop_traverseLeft = isTraversal (traverseLeft :: Simple Traversal (Either Int Bool) Int) +prop_traverseRight = isTraversal (traverseRight:: Simple Traversal (Either Int Bool) Bool) + +-- Data.Text.Lens +prop_text s = s^.packed.from packed == s + +main :: IO () +main = do + b <- $quickCheckAll + unless b $ exitWith (ExitFailure 1) diff --git a/test/templates.hs b/test/templates.hs new file mode 100644 --- /dev/null +++ b/test/templates.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} +-- | The commented code summarizes what will be auto-generated below +module Main where + +import Control.Lens +-- import Test.QuickCheck (quickCheck) + +-- newtype Foo a = Foo a +-- makeIso ''Foo +-- foo :: Iso a b (Foo a) (Foo b) + +data Bar a b c = Bar { _baz :: (a, b) } +makeLenses ''Bar +-- baz :: Lens (Bar a b c) (Bar a' b' c) (a,b) (a',b') + +data Quux a b = Quux { _quaffle :: Int, _quartz :: Double } +makeLenses ''Quux +-- quaffle :: Lens (Quux a b) (Quux a' b') Int Int +-- quartz :: Lens (Quux a b) (Quux a' b') Double Double + +data Quark a = Qualified { _gaffer :: a } + | Unqualified { _gaffer :: a, tape :: a } +makeLenses ''Quark +-- gaffer :: Simple Lens (Quark a) a + +data LensCrafted a = Still { _still :: a } + | Works { _still :: a } +makeLenses ''LensCrafted +-- still :: Lens (LensCrafted a) (LensCrafted b) a b + +data Mono = Mono { _monoFoo :: Int, _monoBar :: Int } +makeClassy ''Mono +-- class HasMono t where +-- mono :: Simple Lens t Mono +-- instance HasMono Mono where +-- mono = id +-- monoFoo :: HasMono t => Simple Lens t Int +-- monoBar :: HasMono t => Simple Lens t Int + +data Nucleosis = Nucleosis { _nuclear :: Mono } +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 + mono = nuclear + +main :: IO () +main = putStrLn "test/templates.hs: ok"