diff --git a/examples/Pong.hs b/examples/Pong.hs --- a/examples/Pong.hs +++ b/examples/Pong.hs @@ -1,27 +1,30 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell, Rank2Types #-} import Control.Applicative ((<$>), (<*>)) import Control.Lens -import Control.Lens.TH +import Control.Lens.TH (makeLenses) import Control.Monad.State import Data.Set (Set, member, empty, insert, delete) +import Data.Set.Lens (contains) +import Data.Pair.Lens (both) import Graphics.Gloss import Graphics.Gloss.Interface.Pure.Game +import System.Random + -- Some global constants gameSize = 300 windowSize = 480 ballRadius = 0.02 -initialSpeed = (0.8, 0.3) speedIncrease = 1.1 +initialSpeed = 0.5 paddleWidth = 0.02 paddleHeight = 0.3 paddleSpeed = 1 -textSize = 0.3 / gameSize +textSize = 0.001 -- Pure data type for representing the game state @@ -31,25 +34,38 @@ , _paddle1 :: Float , _paddle2 :: Float , _score :: (Int, Int) + , _vectors :: [Vector] -- Since gloss doesn't cover this, we store the set of pressed keys , _keys :: Set Key } -initial :: Pong -initial = Pong (0, 0) initialSpeed 0 0 (0, 0) empty - -- Some nice lenses to go with it makeLenses ''Pong --- I'm just renaming the tuple lenses for enhanced clarity with points/vectors +-- Renamed tuple lenses for enhanced clarity with points/vectors _x = _1 _y = _2 --- This will be in Data.Pair.Lens soon -both :: Traversal (a,a) (b,b) a b -both f (x,y) = (,) <$> f x <*> f y +initial :: Pong +initial = Pong (0, 0) (0, 0) 0 0 (0, 0) [] empty +-- Calculate the y position at which the ball will next hit (on player2's side) +hitPos :: Point -> Vector -> Float +hitPos (x,y) (u,v) = ypos + where + xdist = if u >= 0 then 1 - x else 3 + x + time = xdist / abs u + ydist = v * time + ypos = bounce (y + ydist) + o = 1 - ballRadius + + -- Calculate bounces iteratively + bounce n + | n > o = bounce ( 2 *o - n) + | n < -o = bounce ((-2)*o - n) + | otherwise = n + -- Game update logic update :: Float -> Pong -> Pong @@ -61,46 +77,42 @@ -- Move the ball by adding its current speed updateBall :: Float -> State Pong () updateBall time = do - speed <- use ballSpeed - ballPos += speed `mul` time + (u, v) <- use ballSpeed + ballPos += (time * u, time * v) -- Make sure it doesn't leave the playing area - ballPos.both %= clampPad ballRadius - - where - (a,b) `mul` c = (c*a, c*b) - infixl 7 `mul` + ballPos.both %= clamp ballRadius -- Update the paddles updatePaddles :: Float -> State Pong () updatePaddles time = do p <- get + let paddleMovement = time * paddleSpeed + let keyPressed key = p^.keys.contains (SpecialKey key) + -- Update the player's paddle based on keys - when (SpecialKey KeyUp `isIn` p^.keys) $ - paddle1 += paddleSpeed * time + when (keyPressed KeyUp) $ paddle1 += paddleMovement + when (keyPressed KeyDown) $ paddle1 -= paddleMovement - when (SpecialKey KeyDown `isIn` p^.keys) $ - paddle1 -= paddleSpeed * time + -- Calculate the optimal position + let optimal = hitPos (p^.ballPos) (p^.ballSpeed) + let dist = optimal - p^.paddle2 - -- Update the CPU's paddle based on the ball's relative position - case compare (p^.ballPos._y) (p^.paddle2) of - GT -> paddle2 += paddleSpeed * time - LT -> paddle2 -= paddleSpeed * time - _ -> return () + -- Move the CPU's paddle towards this optimal position as needed + when (abs dist > paddleHeight/3) $ + case compare dist 0 of + GT -> paddle2 += paddleMovement + LT -> paddle2 -= paddleMovement + _ -> return () -- Make sure both paddles don't leave the playing area - paddle1 %= clamp - paddle2 %= clamp - - where - clamp = clampPad (paddleHeight/2) - isIn = member - infixl 7 `isIn` + paddle1 %= clamp (paddleHeight/2) + paddle2 %= clamp (paddleHeight/2) -- Clamp to the region (-1, 1) but with padding -clampPad :: Float -> Float -> Float -clampPad pad = max (pad - 1) . min (1 - pad) +clamp :: Float -> Float -> Float +clamp pad = max (pad - 1) . min (1 - pad) -- Check for collisions and/or scores checkBounds :: State Pong () @@ -109,57 +121,55 @@ let (x,y) = p^.ballPos -- Check for collisions with the top or bottom - when (abs y >= top) $ + when (abs y >= edge) $ ballSpeed._y %= negate -- Check for collisions with paddles - let check l = y >= p^.l - paddleHeight/2 && y <= p^.l + paddleHeight/2 - collide = do + let { check paddle other = + if y >= p^.paddle - paddleHeight/2 && y <= p^.paddle + paddleHeight/2 + then do ballSpeed._x %= negate ballSpeed.both *= speedIncrease - when (x <= left) $ - if check paddle1 - then collide else do - score._2 += 1 + score.other += 1 reset + } - when (x >= right) $ - if check paddle2 - then collide - else do - score._1 += 1 - reset + when (x >= edge) $ check paddle2 _1 + when (x <= -edge) $ check paddle1 _2 where - top = 1 - ballRadius - left = ballRadius + paddleWidth/2 - 1 - right = -left + edge = 1 - ballRadius -- Reset the game reset :: State Pong () reset = do - ballPos ^= initial^.ballPos - ballSpeed ^= initial^.ballSpeed + ballPos .= (0, 0) + ballSpeed <~ nextSpeed +-- Retrieve a speed from the list, dropping it in the process +nextSpeed :: State Pong Vector +nextSpeed = do + v:vs <- use vectors + vectors .= vs + return v + -- Drawing a pong state to the screen draw :: Pong -> Picture draw p = scale gameSize gameSize $ Pictures [ drawBall `at` p^.ballPos - , drawPaddle `at` (-1, p^.paddle1) - , drawPaddle `at` ( 1, p^.paddle2) + , drawPaddle `at` (-paddleX, p^.paddle1) + , drawPaddle `at` ( paddleX, p^.paddle2) -- Score and playing field - , scale textSize textSize (p^.score.pretty.to text) `at` (-0.1, 0.85) + , drawScore (p^.score) `at` (-0.1, 0.85) , rectangleWire 2 2 ] where - -- Pretty printing lens - pretty = to (\(x,y) -> show x ++ " " ++ show y) - p `at` (x,y) = translate x y p - infixr 1 `at` + paddleX = 1 + paddleWidth/2 + p `at` (x,y) = translate x y p; infixr 1 `at` drawPaddle :: Picture drawPaddle = rectangleSolid paddleWidth paddleHeight @@ -167,18 +177,35 @@ drawBall :: Picture drawBall = circleSolid ballRadius +drawScore :: (Int, Int) -> Picture +drawScore (x, y) = scale textSize textSize . text $ show x ++ " " ++ show y + -- Handle input by simply updating the keys set handle :: Event -> Pong -> Pong -handle (EventKey k Down _ _) = keys %~ insert k -handle (EventKey k Up _ _) = keys %~ delete k +handle (EventKey k s _ _) = keys.contains k .~ (s == Down) handle _ = id -- The main program action -main = play display backColor fps initial draw handle update +main = do + v:vs <- startingSpeeds + let world = ballSpeed .~ v $ vectors .~ vs $ initial + play display backColor fps world draw handle update + where - -- display = InWindow "Pong!" (windowSize, windowSize) (800, 600) - display = FullScreen (800,600) + display = InWindow "Pong!" (windowSize, windowSize) (200, 200) backColor = white fps = 120 + +-- Generate the random list of starting speeds + +startingSpeeds :: IO [Vector] +startingSpeeds = do + rs <- randomRs (-initialSpeed, initialSpeed) <$> getStdGen + return . interleave $ filter ((> 0.2) . abs) rs + + where + interleave :: [a] -> [(a,a)] + interleave (x:y:xs) = (x,y) : interleave xs + interleave _ = [] diff --git a/examples/Pong2.hs b/examples/Pong2.hs deleted file mode 100644 --- a/examples/Pong2.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} - -import Control.Applicative ((<$>), (<*>)) -import Control.Lens -import Control.Lens.TH -import Control.Monad.State - -import Data.Set (Set, member, empty, insert, delete) - -import Graphics.Gloss -import Graphics.Gloss.Interface.Pure.Game - --- Some global constants - -gameSize = 300 -windowSize = 480 -ballRadius = 0.02 -initialSpeed = (0.5, 0.3) -speedIncrease = 1.1 -paddleWidth = 0.02 -paddleHeight = 0.3 -paddleSpeed = 1 -textSize = 0.3 / gameSize - --- Pure data type for representing the game state - -data Pong = Pong - { _ballPos :: Point - , _ballSpeed :: Vector - , _paddle1 :: Float - , _paddle2 :: Float - , _score :: (Int, Int) - - -- Since gloss doesn't cover this, we store the set of pressed keys - , _keys :: Set Key - } - -initial :: Pong -initial = Pong (0, 0) initialSpeed 0 0 (0, 0) empty - --- Some nice lenses to go with it -makeLenses ''Pong - --- I'm just renaming the tuple lenses for enhanced clarity with points/vectors -_x = _1 -_y = _2 - --- This will be in Data.Pair.Lens soon -both :: Traversal (a,a) (b,b) a b -both f (x,y) = (,) <$> f x <*> f y - --- Calculate the y position at which the ball will next hit (on player2's side) -hitPos :: Point -> Vector -> Float -hitPos (x,y) (u,v) = ypos - where - xdist = if u >= 0 then 1 - x else 3 + x - time = xdist / abs u - ydist = v * time - ypos = bounce (y + ydist) - o = 1 - ballRadius - - -- Calculate bounces iteratively - bounce n - | n > o = bounce ( 2 *o - n) - | n < -o = bounce ((-2)*o - n) - | otherwise = n - --- Game update logic - -update :: Float -> Pong -> Pong -update time = execState $ do - updatePaddles time - updateBall time - checkBounds - --- Move the ball by adding its current speed -updateBall :: Float -> State Pong () -updateBall time = do - speed <- use ballSpeed - ballPos += speed `mul` time - - -- Make sure it doesn't leave the playing area - ballPos.both %= clampPad ballRadius - - where - (a,b) `mul` c = (c*a, c*b) - infixl 7 `mul` - --- Update the paddles -updatePaddles :: Float -> State Pong () -updatePaddles time = do - p <- get - - -- Update the player's paddle based on keys - when (SpecialKey KeyUp `isIn` p^.keys) $ - paddle1 += paddleSpeed * time - - when (SpecialKey KeyDown `isIn` p^.keys) $ - paddle1 -= paddleSpeed * time - - -- Calculate the optimal position - let optimal = hitPos (p^.ballPos) (p^.ballSpeed) - - -- Move the CPU's paddle towards this optimal position - case compare optimal (p^.paddle2) of - GT -> paddle2 += paddleSpeed * time - LT -> paddle2 -= paddleSpeed * time - _ -> return () - - -- Make sure both paddles don't leave the playing area - paddle1 %= clamp - paddle2 %= clamp - - where - clamp = clampPad (paddleHeight/2) - isIn = member - infixl 7 `isIn` - --- Clamp to the region (-1, 1) but with padding -clampPad :: Float -> Float -> Float -clampPad pad = max (pad - 1) . min (1 - pad) - --- Check for collisions and/or scores -checkBounds :: State Pong () -checkBounds = do - p <- get - let (x,y) = p^.ballPos - - -- Check for collisions with the top or bottom - when (abs y >= top) $ - ballSpeed._y %= negate - - -- Check for collisions with paddles - let check l = y >= p^.l - paddleHeight/2 && y <= p^.l + paddleHeight/2 - - let { collide = do - ballSpeed._x %= negate - ballSpeed.both *= speedIncrease - } - - when (x <= left) $ - if check paddle1 - then collide - else score._2 += 1 >> reset - - when (x >= right) $ - if check paddle2 - then collide - else score._1 += 1 >> reset - - where - top = 1 - ballRadius - left = ballRadius + paddleWidth/2 - 1 - right = -left - --- Reset the game -reset :: State Pong () -reset = do - ballPos ^= initial^.ballPos - ballSpeed ^= initial^.ballSpeed - --- Drawing a pong state to the screen - -draw :: Pong -> Picture -draw p = scale gameSize gameSize $ Pictures - [ drawBall `at` p^.ballPos - , drawPaddle `at` (-1, p^.paddle1) - , drawPaddle `at` ( 1, p^.paddle2) - - -- Score and playing field - , scale textSize textSize (p^.score.pretty.to text) `at` (-0.1, 0.85) - , rectangleWire 2 2 - ] - where - -- Pretty printing lens - pretty = to (\(x,y) -> show x ++ " " ++ show y) - p `at` (x,y) = translate x y p - infixr 1 `at` - -drawPaddle :: Picture -drawPaddle = rectangleSolid paddleWidth paddleHeight - -drawBall :: Picture -drawBall = circleSolid ballRadius - --- Handle input by simply updating the keys set - -handle :: Event -> Pong -> Pong -handle (EventKey k Down _ _) = keys %~ insert k -handle (EventKey k Up _ _) = keys %~ delete k -handle _ = id - --- The main program action - -main = play display backColor fps initial draw handle update - where - -- display = InWindow "Pong!" (windowSize, windowSize) (200, 200) - display = FullScreen (800,600) - backColor = white - fps = 120 diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,8 +1,8 @@ name: lens category: Data, Lenses -version: 1.4.1 +version: 1.5 license: BSD3 -cabal-version: >= 1.6 +cabal-version: >= 1.8 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -13,115 +13,11 @@ synopsis: Lenses, Folds and Traversals description: The combinators in @Control.Lens@ provide a highly generic toolbox for composing - families of getters, folds, traversals, setters and lenses. - . - /Getter/ - . - 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 'Const' to obtain - . - > type Getting r a b c d = (c -> Const r d) -> a -> Const r b - . - If we restrict access to knowledge about the type 'r' and can work for any d and b, we get: - . - > type Getter a c = forall r b d. Getting r a b c d - . - 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. - . - Since it is only a function, every 'Getter' obviously only retrieves a single value for a given - input. - . - /Fold/ - . - 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 - . - > type Fold a c = forall m b d. Monoid m => Getting m a b c d - . - Every 'Getter' is a valid 'Fold' that simply doesn't use the 'Monoid' it is passed. - . - Everything you can do with a 'Foldable' container, you can with with a 'Fold' and there are - combinators that generalize the usual 'Foldable' operations in @Control.Lens@. - . - /Traversal/ - . - A @'Traversal' a b c d@ is a generalization of 'traverse' from 'Traversable'. It allows - you to traverse over a structure and change out its contents with monadic or - applicative side-effects. Starting from - @'traverse' :: ('Traversable' t, 'Applicative' f) => (c -> f d) -> t c -> f (t d)@, - we monomorphize the contents and result to obtain - . - > type Traversal a b c d = forall f. Applicative f => (c -> f d) -> a -> f b - . - While a 'Traversal' isn't quite a 'Fold', it _can_ be used for 'Getting' like a 'Fold', because - given a 'Monoid' @m@, we have an 'Applicative' for @('Const' m)@. - . - Everything you can do with a 'Traversable' container, you can with with a 'Traversal', and there - are combinators that generalize the usual 'Traversable' operations in @Control.Lens@. - . - /Setter/ - . - 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 - . - > type Setter a b c d = (c -> Identity d) -> a -> Identity b - . - Every 'Traversal' is a valid 'Setter', since 'Identity' is 'Applicative'. - . - Everything you can do with a 'Functor', you can do with a 'Setter', and there are combinators that - generalize the usual 'Functor' operations in @Control.Lens@. - . - /Lens/ - . - A @'Lens' a b c d@ is a purely functional reference. - . - While a 'Traversal' could be used for 'Getting' like a valid 'Fold', it wasn't a valid 'Getter'. - To make the 'Applicative' for 'Const' it required a 'Monoid' for the argument we passed it, which - a 'Getter' doesn't recieve. - . - However, the instance of 'Functor' for 'Const' requires no such thing. If we weaken the type - requirement from 'Applicative' to 'Functor' for 'Traversal', we obtain - . - > 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' can be used for 'Getting' like a 'Fold' that doesn't use the 'Monoid' it is passed. - . - Every 'Lens' is a valid '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@ = 'Const' @r@ for an appropriate @r@ - . - Since every 'Lens' can be used for '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 'Functor' when used as a 'Setter'. - . - /Isomorphisms and Iso/ - . - Control.Isomorphic provides easy overloading of function application for isomorphisms and @Iso a b c d@ uses it - to form isomorphism families that can be composed with other isomorphisms and with lenses, setters, folds, - traversals and getters. - . - > type Iso a b c d = forall k f. (Isomorphic k, Functor f) => k (c -> f d) (a -> f b) - . - /Composition/ - . - Note that all of these types are type aliases, and you can compose these lenses with mere function compositon. - . - This is a generalization of the well-known trick for @(.).(.)@ or @fmap.fmap@, and their less well-known cousins - @foldMap.foldMap@ @traverse.traverse@. It follows because each one is a function between values of type @(x -> f y)@ - and the composition takes the intersection of supplied functionality for you automatically! + families of getters, folds, isomorphisms, traversals, setters and lenses and their indexed variants. . /Lens Families/ . - For a longer description of why you should care about lenses, and an overview of why we use 4 + For a longer description of why you should care about lens families, and an overview of why we use 4 parameters a, b, c, and d instead of just 2, see . . Sometimes you won't need the flexibility those extra parameters afford you and you can use @@ -142,13 +38,13 @@ . /Deriving Lenses/ . - You can derive lenses automatically for many data types using 'Control.Lens.TH', and if a - container is fully characterized by its lenses, you can use 'Control.Lens.Representable' to - automatically derive 'Functor', 'Applicative', 'Monad', and 'Derivable'. + You can derive lenses automatically for many data types using 'makeLenses', and if a + container is fully characterized by its lenses, you can use 'Representable' to + automatically derive 'Functor', 'Applicative', 'Monad', and 'Distributive'. build-type: Simple tested-with: GHC == 7.4.1 -extra-source-files: .travis.yml examples/Pong.hs examples/Test.hs examples/Pong2.hs +extra-source-files: .travis.yml examples/Pong.hs examples/Test.hs source-repository head type: git @@ -156,36 +52,37 @@ library build-depends: - base >= 4.3 && < 5, - containers >= 0.4.2 && < 0.6, - mtl >= 2.0.1 && < 2.2, - transformers >= 0.2.2 && < 0.4 + base >= 4.3 && < 5, + containers >= 0.4.2 && < 0.6, + mtl >= 2.0.1 && < 2.2, + template-haskell >= 2.4 && < 2.8, + transformers >= 0.3 && < 0.4 - exposed-modules: Control.Indexed - Control.Isomorphic + exposed-modules: Control.Exception.Lens Control.Lens Control.Lens.Internal Control.Lens.Representable - -- base - exposed-modules: Control.Exception.Lens + Control.Lens.Fold + Control.Lens.Getter + Control.Lens.Indexed + Control.Lens.Iso + Control.Lens.Setter + Control.Lens.TH + Control.Lens.Traversal + Control.Lens.Type Data.Bits.Lens Data.Complex.Lens Data.Dynamic.Lens Data.Either.Lens Data.List.Lens Data.Pair.Lens - - -- containers - exposed-modules: Data.IntMap.Lens + Data.IntMap.Lens Data.IntSet.Lens Data.Map.Lens Data.Sequence.Lens Data.Set.Lens Data.Tree.Lens - - build-depends: template-haskell >= 2.4 && < 2.8 - exposed-modules: Language.Haskell.TH.Lens - Control.Lens.TH + Language.Haskell.TH.Lens -- platform build-depends: array >= 0.3.0.2 && < 0.5 @@ -201,10 +98,12 @@ exposed-modules: Control.Parallel.Strategies.Lens Control.Seq.Lens other-extensions: + BangPatterns CPP DeriveDataTypeable FlexibleContexts FlexibleInstances + FunctionalDependencies LiberalTypeSynonyms MultiParamTypeClasses Rank2Types @@ -212,6 +111,7 @@ TemplateHaskell TypeFamilies TypeOperators + UndecidableInstances if (impl(ghc>=7.4)) other-extensions: Trustworthy @@ -220,3 +120,13 @@ ghc-options: -Wall -fwarn-tabs -O2 -fdicts-cheap -funbox-strict-fields hs-source-dirs: src + +test-suite doctests + 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 diff --git a/src/Control/Indexed.hs b/src/Control/Indexed.hs deleted file mode 100644 --- a/src/Control/Indexed.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Indexed --- 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.Indexed - ( - -- * Overloading indexed functions - Indexed(..) - , Indexable - , Index(..) - , (.@) - , composeWithIndex - , reindex - ) where - --- | Permit overloading of function application for things that also admit a notion of a key or index. - --- | Provides overloading for indexed functions. -class Indexed i k where - -- | Build a function from an indexed function - index :: ((i -> a) -> b) -> k a b - --- | Type alias for passing around polymorphic indexed functions. -type Indexable i a b = forall k. Indexed i k => k a b - -instance Indexed i (->) where - index f = f . const - {-# INLINE index #-} - --- | A function with access to a index. This constructor may be useful when you need to store --- a 'HasIndex'. -newtype Index i a b = Index { withIndex :: (i -> a) -> b } - --- | Using an equality witness to avoid potential overlapping instances --- and aid dispatch. -instance i ~ j => Indexed i (Index j) where - index = Index - {-# INLINE index #-} - --- | 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 #-} - -infixr 9 .@ --- | Composition of indexed functions -(.@) :: Indexed (i, j) k => Index i b c -> Index j a b -> k a c -f .@ g = composeWithIndex (,) 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 with a user supplied function for combining indexs -composeWithIndex :: Indexed k r => (i -> j -> k) -> Index i b c -> Index j a b -> r a c -composeWithIndex ijk (Index ibc) (Index jab) = index $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j) -{-# INLINE composeWithIndex #-} -{-# SPECIALIZE composeWithIndex :: (i -> j -> k) -> Index i b c -> Index j a b -> a -> c #-} - diff --git a/src/Control/Isomorphic.hs b/src/Control/Isomorphic.hs deleted file mode 100644 --- a/src/Control/Isomorphic.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------ --- | --- Module : Control.Isomorphic --- Copyright : (C) 2012 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : rank 2 types --- ----------------------------------------------------------------------------- -module Control.Isomorphic - ( Isomorphic(..) - , Isomorphism(..) - , from - , via - , (:~>) - ) where - -import Control.Category -import Prelude hiding ((.),id) -import Data.Typeable - ----------------------------------------------------------------------------- --- Isomorphism Implementation Details ------------------------------------------------------------------------------ - --- | An isomorphism from a to b, overloaded to permit its use directly as a function. --- --- You can use a value of type @(a :~ b)@ as if it were @(a -> b)@ or @Isomorphism a b@. -infixr 0 :~> -type a :~> b = forall k. Isomorphic k => k a b - --- | Used to provide overloading of isomorphism application --- --- This is a 'Category' with a canonical mapping to it from the --- category of isomorphisms over Haskell types. -class Category k => Isomorphic k where - -- | Build this morphism out of an isomorphism - -- - -- The intention is that by using 'isomorphic', you can supply both halves of an - -- isomorphism, but k can be instantiated to (->), so you can freely use - -- the resulting isomorphism as a function. - isomorphic :: (a -> b) -> (b -> a) -> k a b - - -- | Map a morphism in the target category using an isomorphism between morphisms - -- in Hask. - isomap :: ((a -> b) -> c -> d) -> ((b -> a) -> d -> c) -> k a b -> k c d - -instance Isomorphic (->) where - isomorphic = const - {-# INLINE isomorphic #-} - isomap = const - {-# INLINE isomap #-} - --- | A concrete data type for isomorphisms. --- --- This lets you place an isomorphism inside a container without using @ImpredicativeTypes@. -data Isomorphism a b = Isomorphism (a -> b) (b -> a) - deriving (Typeable) - -instance Category Isomorphism where - id = Isomorphism id id - {-# INLINE id #-} - Isomorphism bc cb . Isomorphism ab ba = Isomorphism (bc . ab) (ba . cb) - {-# INLINE (.) #-} - -instance Isomorphic Isomorphism where - isomorphic = Isomorphism - {-# INLINE isomorphic #-} - isomap abcd badc (Isomorphism ab ba) = Isomorphism (abcd ab) (badc ba) - {-# INLINE isomap #-} - --- | Invert an isomorphism. --- --- Note to compose an isomorphism and receive an isomorphism in turn you'll need to use --- 'Control.Category.Category' --- --- > from (from l) = l --- --- If you imported 'Control.Category.(.)', then: --- --- > from l . from r = from (r . l) --- --- > from :: (a :~> b) -> (b :~> a) -from :: Isomorphic k => Isomorphism a b -> k b a -from (Isomorphism a b) = isomorphic b a -{-# INLINE from #-} -{-# SPECIALIZE from :: Isomorphism a b -> b -> a #-} -{-# SPECIALIZE from :: Isomorphism a b -> Isomorphism b a #-} - --- | --- > via :: Isomorphism a b -> (a :~> b) -via :: Isomorphic k => Isomorphism a b -> k a b -via (Isomorphism a b) = isomorphic a b -{-# INLINE via #-} -{-# SPECIALIZE via :: Isomorphism a b -> a -> b #-} -{-# SPECIALIZE via :: Isomorphism a b -> Isomorphism a b #-} diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -33,1937 +33,37 @@ -- -- You can derive lenses automatically for many data types: -- --- > import Control.Lens.TH --- > data Foo a = Foo { _fooArgs :: [String], _fooValue :: a } --- > makeLenses ''Foo --- --- This defines the following lenses: --- --- > fooArgs :: Simple Lens (Foo a) [String] --- > fooValue :: Lens (Foo a) (Foo b) a b --- --- The combinators here have unusually specific type signatures, so for --- particularly tricky ones, I've tried to list the simpler type signatures --- you might want to pretend the combinators have. --- ----------------------------------------------------------------------------- -module Control.Lens - ( - -- * Lenses - Lens - , LensLike - , Traversal - , Simple - , SimpleLens - , SimpleTraversal - , SimpleLensLike - , (%%~), (%%=) - , lens - - -- ** Common Lenses - , _1, _2 - , resultAt - , element - , elementOf - - -- * Isomorphisms - , Iso - , SimpleIso - , Overloaded - , SimpleOverloaded - , iso - , isos - , Isomorphic(..) - , from - - -- * Setters - , Setter - , SimpleSetter - , sets - , mapped - , adjust, mapOf - , set - , whisper - , (^~), (%~), (<~) - , (^=), (%=) - - -- * Getters and Folds - , Getter - , Fold - , Getting - , to - , folds - , folding - , folded - , unfolded - , iterated - , filtered - , reversed - , repeated - , replicated - , cycled - , takingWhile - , droppingWhile - , view, views - , (^.), (^$) - , use, uses - , query, queries - - -- ** Getting and Folding - , foldMapOf, foldOf - , foldrOf, foldlOf - , toListOf - , anyOf, allOf - , andOf, orOf - , productOf, sumOf - , traverseOf_, forOf_, sequenceAOf_ - , mapMOf_, forMOf_, sequenceOf_ - , asumOf, msumOf - , concatMapOf, concatOf - , elemOf, notElemOf - , lengthOf - , nullOf - , headOf, lastOf - , maximumOf, minimumOf - , maximumByOf, minimumByOf - , findOf - , foldrOf', foldlOf' - , foldr1Of, foldl1Of - , foldrMOf, foldlMOf - - -- * Setting - , (+~), (-~), (*~), (//~), (||~), (&&~), (<>~) - , (+=), (-=), (*=), (//=), (||=), (&&=), (<>=) - - -- * Traversing and Lensing - , Focus(..) - , traverseOf, forOf, sequenceAOf - , mapMOf, forMOf, sequenceOf - , transposeOf - , mapAccumLOf, mapAccumROf - , scanr1Of, scanl1Of - - -- * Common Traversals - , Traversable(traverse) - , traverseNothing - - -- * Transforming Traversals - , backwards - - -- * Cloning Lenses - , clone - , merged - , bothLenses - - -- ** Common Isomorphisms - , identity - , konst - - -- * Indexed Folds - , Index(..) - , Indexed(..) - , IndexedFold - , foldMapWithIndexOf - , foldrWithIndexOf - - -- * Indexed Traversals - , IndexedTraversal - , SimpleIndexedTraversal - , traverseWithIndexOf - , mapMWithIndexOf - ) where - -import Control.Applicative as Applicative -import Control.Applicative.Backwards -import Control.Category -import Control.Indexed -import Control.Isomorphic -import Control.Lens.Internal -import Control.Monad -import Control.Monad.Reader.Class as Reader -import Control.Monad.State.Class as State -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Reader -import Control.Monad.Writer.Class as Writer -import Data.Foldable as Foldable -import Data.Functor.Identity -import Data.Maybe -import Data.Monoid -import Data.Traversable -import Prelude hiding ((.),id) - -infixl 8 ^. -infixr 4 ^~, +~, *~, -~, //~, &&~, ||~, %~, <>~, %%~, <~ -infix 4 ^=, +=, *=, -=, //=, &&=, ||=, %=, <>=, %%= -infixr 0 ^$ - - - --------------------------- --- Lenses --------------------------- - --- | A 'Lens' is actually a lens family as described in . --- --- With great power comes great responsibility and a 'Lens' is subject to the three common sense lens laws: --- --- 1) You get back what you put in: --- --- > view l (set l b a) = b --- --- 2) Putting back what you got doesn't change anything: --- --- > 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 --- --- 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'. --- --- You can also use a 'Lens' for 'Getting' as if it were a 'Fold' or 'Getter'. --- --- Since every lens is a valid 'Traversal', the traversal laws should also apply to any lenses you create. --- --- 1.) Idiomatic naturality: --- --- > l pure = pure --- --- 2.) Sequential composition: --- --- > fmap (l f) . l g = getCompose . l (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 => (c -> f d) -> a -> f b - ------------------------------------------------------------------------------- --- Traversals ------------------------------------------------------------------------------- - --- | A 'Traversal' can be used directly as a 'Setter' or a 'Fold' (but not as a 'Lens') and provides --- the ability to both read and update multiple fields, subject to some relatively weak 'Traversal' laws. --- --- These have also been known as multilenses, but they have the signature and spirit of --- --- > traverse :: Traversable f => Traversal (f a) (f b) a b --- --- and the more evocative name suggests their application. --- --- Most of the time the 'Traversal' you will want to use is just 'traverse', but you can also pass any --- 'Lens' or 'Iso' as a Traversal, and composition of a 'Traversal' (or 'Lens' or 'Iso') with a 'Traversal' (or 'Lens' or 'Iso') --- using (.) forms a valid 'Traversal'. --- --- The laws for a Traversal @t@ follow from the laws for Traversable as stated in \"The Essence of the Iterator Pattern\". --- --- 1) Idiomatic naturality: --- --- > t pure = pure --- --- 2) Sequential composition: --- --- > fmap (t f) . t g = getCompose . t (Compose . fmap f . g) --- --- One consequence of this requirement is that a traversal needs to leave the same number of elements as a candidate for --- subsequent traversal as it started with. --- --- 3) No duplication of elements (as defined in \"The Essence of the Iterator Pattern\" section 5.5), which states --- that you should incur no effect caused by visiting the same element of the container twice. -type Traversal a b c d = forall f. Applicative f => (c -> f d) -> a -> f b - --- | A @'Simple' 'Lens'@, @'Simple' 'Traversal'@, ... can be used instead of a 'Lens','Traversal', ... --- whenever the type variables don't change upon setting a value. --- --- > imaginary :: Simple Lens (Complex a) a --- > traverseHead :: Simple Traversal [a] a --- --- Note: To use this alias in your own code with @'LensLike' f@ or @Setter@, you may have to turn on --- @LiberalTypeSynonyms@. -type Simple f a b = f a a b b - --- | > type SimpleTraversal = Simple Traversal -type SimpleTraversal a b = Traversal a a b b - --- | > type SimpleLens = Simple Lens -type SimpleLens a b = Lens a a b b - --- | > type SimpleLensLike f = Simple (LensLike f) -type SimpleLensLike f a b = LensLike f a a b b - --------------------------- --- Constructing Lenses --------------------------- - --- | Build a 'Lens' from a getter and a setter. --- --- > lens :: Functor f => (a -> c) -> (a -> d -> b) -> (c -> f d) -> a -> f b -lens :: (a -> c) -> (a -> d -> b) -> Lens a b c d -lens ac adb cfd a = adb a <$> cfd (ac a) -{-# INLINE lens #-} - --------------------------- --- LensLike --------------------------- - --- | --- Many combinators that accept a 'Lens' can also accept a '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'. -type LensLike f a b c d = (c -> f d) -> a -> f b - --- | ('%%~') can be used in one of two scenarios: --- --- 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 --- applicative summary of its actions. --- --- For all that the definition of this combinator is just: --- --- > (%%~) = 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 --- > (%%~) :: Applicative f => Traversal a b c d -> (c -> f d) -> a -> f b --- --- 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 --- supplemental monoidal summary of its actions, by choosing f = ((,) m) --- --- > (%%~) :: Iso a b c d -> (c -> (e, d)) -> a -> (e, b) --- > (%%~) :: Lens a b c d -> (c -> (e, d)) -> a -> (e, b) --- > (%%~) :: Monoid m => Traversal a b c d -> (c -> (m, d)) -> a -> (m, b) -(%%~) :: LensLike f a b c d -> (c -> f d) -> a -> f b -(%%~) = id -{-# 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@ --- and return a monoidal summary of the changes. --- --- > (%%=) = (state.) --- --- It may be useful to think of ('%%='), instead, as having either of the following more restricted --- type signatures: --- --- > (%%=) :: MonadState a m => Iso a a c d -> (c -> (e, d) -> m e --- > (%%=) :: MonadState a m => Lens a a c d -> (c -> (e, d) -> m e --- > (%%=) :: (MonadState a m, Monoid e) => Traversal a a c d -> (c -> (e, d) -> m e -(%%=) :: MonadState a m => LensLike ((,) e) a a c d -> (c -> (e, d)) -> m e -#if MIN_VERSION_mtl(2,1,1) -l %%= f = State.state (l f) -#else -l %%= f = do - (e, b) <- State.gets (l f) - State.put b - return e -#endif -{-# INLINE (%%=) #-} - --- | 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'. - -- - -- 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 - -- and the results are aggregated monoidally - -- and a monoidal summary - -- of the result is given. - -- - -- > focus :: Monad m => Simple Iso a b -> st b m c -> st a m c - -- > focus :: Monad m => Simple Lens a b -> st b m c -> st a m c - -- > focus :: (Monad m, Monoid c) => Simple Traversal a b -> st b m c -> st a m c - focus :: Monad m => LensLike (Focusing m c) a a b b -> st b m c -> st a m c - - -- | Like 'focus', but discarding any accumulated results as you go. - -- - -- > focus_ :: Monad m => Simple Iso a b -> st b m c -> st a m () - -- > focus_ :: Monad m => Simple Lens a b -> st b m c -> st a m () - -- > focus_ :: (Monad m, Monoid c) => Simple Traversal a b -> st b m c -> st a m () - focus_ :: Monad m => LensLike (Focusing m ()) a a b b -> st b m c -> st a m () - - -- | A much more limited version of 'focus' that can work with a 'Setter'. - setFocus :: Simple Setter a b -> st b Identity c -> st a Identity () - -skip :: a -> () -skip _ = () -{-# INLINE skip #-} - -instance Focus Strict.StateT where - focus l m = Strict.StateT $ unfocusing . l (Focusing . Strict.runStateT m) - {-# INLINE focus #-} - focus_ l m = Strict.StateT $ unfocusing . l (Focusing . Strict.runStateT (liftM skip m)) - {-# INLINE focus_ #-} - setFocus l m = Strict.state $ (,) () . runIdentity . l (Identity . snd . Strict.runState m) - -instance Focus Lazy.StateT where - focus l m = Lazy.StateT $ unfocusing . l (Focusing . Lazy.runStateT m) - {-# INLINE focus #-} - focus_ l m = Lazy.StateT $ unfocusing . l (Focusing . Lazy.runStateT (liftM skip m)) - {-# INLINE focus_ #-} - setFocus l m = Lazy.state $ (,) () . runIdentity . l (Identity . snd . Lazy.runState m) - -instance Focus ReaderT where - --focus l m = ReaderT $ \a -> liftM fst $ unfocusing $ l (\b -> Focusing $ (\c -> (c,b)) `liftM` runReaderT m b) a - focus l m = ReaderT $ liftM fst . unfocusing . l (\b -> Focusing $ (\c -> (c,b)) `liftM` runReaderT m b) - {-# INLINE focus #-} - focus_ l m = ReaderT $ \a -> liftM skip $ unfocusing $ l (\b -> Focusing $ (\_ -> ((),b)) `liftM` runReaderT m b) a - {-# INLINE focus_ #-} - setFocus _ _ = return () -- BOOORING - --------------------------- --- Traversal Combinators --------------------------- - --- | --- Map each element of a structure targeted by a Lens or Traversal, --- evaluate these actions from left to right, and collect the results. --- --- > traverseOf = id --- --- > traverse = traverseOf traverse --- --- > traverseOf :: Iso a b c d -> (c -> f d) -> a -> f b --- > traverseOf :: Lens a b c d -> (c -> f d) -> a -> f b --- > traverseOf :: Traversal a b c d -> (c -> f d) -> a -> f b -traverseOf :: Category k => k (LensLike f a b c d) ((c -> f d) -> a -> f b) -traverseOf = id -{-# INLINE traverseOf #-} -{-# SPECIALIZE traverseOf :: LensLike f a b c d -> (c -> f d) -> a -> f b #-} - --- | --- --- > forOf l = flip (traverseOf l) --- --- > for = forOf traverse --- > forOf = morphism flip flip --- --- > forOf :: Lens a b c d -> a -> (c -> f d) -> f b -forOf :: Isomorphic k => k (LensLike f a b c d) (a -> (c -> f d) -> f b) -forOf = isomorphic flip flip -{-# INLINE forOf #-} -{-# SPECIALIZE forOf :: LensLike f a b c d -> a -> (c -> f d) -> f b #-} - --- | --- Evaluate each action in the structure from left to right, and collect --- the results. --- --- > sequenceA = sequenceAOf traverse --- > sequenceAOf l = traverseOf l id --- > sequenceAOf l = l id --- --- > sequenceAOf :: Iso a b (f c) c -> a -> f b --- > sequenceAOf :: Lens a b (f c) c -> a -> f b --- > sequenceAOf :: Applicative f => Traversal a b (f c) c -> a -> f b -sequenceAOf :: LensLike f a b (f c) c -> a -> f b -sequenceAOf l = l id -{-# INLINE sequenceAOf #-} - --- | 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. --- --- > mapM = mapMOf traverse --- --- > mapMOf :: Iso a b c d -> (c -> m d) -> a -> m b --- > mapMOf :: Lens a b c d -> (c -> m d) -> a -> m b --- > mapMOf :: Monad m => Traversal a b c d -> (c -> m d) -> a -> m b -mapMOf :: LensLike (WrappedMonad m) a b c d -> (c -> m d) -> a -> m b -mapMOf l cmd = unwrapMonad . l (WrapMonad . cmd) -{-# INLINE mapMOf #-} - --- | --- > forM = forMOf traverse --- > forMOf l = flip (mapMOf l) --- --- > forMOf :: Iso a b c d -> a -> (c -> m d) -> m b --- > forMOf :: Lens a b c d -> a -> (c -> m d) -> m b --- > forMOf :: Monad m => Traversal a b c d -> a -> (c -> m d) -> m b -forMOf :: LensLike (WrappedMonad m) a b c d -> a -> (c -> m d) -> m b -forMOf l a cmd = unwrapMonad (l (WrapMonad . cmd) a) -{-# INLINE forMOf #-} - --- | --- > sequence = sequenceOf traverse --- > sequenceOf l = mapMOf l id --- > sequenceOf l = unwrapMonad . l WrapMonad --- --- > sequenceOf :: Iso a b (m c) c -> a -> m b --- > sequenceOf :: Lens a b (m c) c -> a -> m b --- > sequenceOf :: Monad m => Traversal a b (m c) c -> a -> m b -sequenceOf :: LensLike (WrappedMonad m) a b (m c) c -> a -> m b -sequenceOf l = unwrapMonad . l WrapMonad -{-# INLINE sequenceOf #-} - --- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'. --- --- > transpose = transposeOf traverse --- --- > ghci> transposeOf traverse [[1,2,3],[4,5,6]] --- > [[1,4],[2,5],[3,6]] --- --- Since every 'Lens' is a Traversal, we can use this as a form of --- monadic strength. --- --- > transposeOf _2 :: (b, [a]) -> [(b, a)] -transposeOf :: LensLike ZipList a b [c] c -> a -> [b] -transposeOf l = getZipList . l ZipList -{-# INLINE transposeOf #-} - --- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'. --- --- > mapAccumR = mapAccumROf traverse --- --- 'mapAccumROf' accumulates state from right to left. --- --- > mapAccumROf :: Iso a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) --- > mapAccumROf :: Lens a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) --- > mapAccumROf :: Traversal a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) -mapAccumROf :: LensLike (Lazy.State s) a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) -mapAccumROf l f s0 a = swap (Lazy.runState (l (\c -> State.state (\s -> swap (f s c))) a) s0) -{-# INLINE mapAccumROf #-} - --- | Generalized 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'. --- --- > mapAccumL = mapAccumLOf traverse --- --- 'mapAccumLOf' accumulates state from left to right. --- --- > mapAccumLOf :: Iso a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) --- > mapAccumLOf :: Lens a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) --- > mapAccumLOf :: Traversal a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) -mapAccumLOf :: LensLike (Backwards (Lazy.State s)) a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) -mapAccumLOf l = mapAccumROf (backwards l) -{-# INLINE mapAccumLOf #-} - -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) -{-# INLINE swap #-} - --- | Permit the use of 'scanr1' over an arbitrary 'Traversal' or 'Lens'. --- --- > scanr1 = scanr1Of traverse --- --- > scanr1Of :: Iso a b c c -> (c -> c -> c) -> a -> b --- > scanr1Of :: Lens a b c c -> (c -> c -> c) -> a -> b --- > scanr1Of :: Traversal a b c c -> (c -> c -> c) -> a -> b -scanr1Of :: LensLike (Lazy.State (Maybe c)) a b c c -> (c -> c -> c) -> a -> b -scanr1Of l f = snd . mapAccumROf l step Nothing where - step Nothing c = (Just c, c) - step (Just s) c = (Just r, r) where r = f c s -{-# INLINE scanr1Of #-} - --- | Permit the use of 'scanl1' over an arbitrary 'Traversal' or 'Lens'. --- --- > scanl1 = scanl1Of traverse --- --- > scanr1Of :: Iso a b c c -> (c -> c -> c) -> a -> b --- > scanr1Of :: Lens a b c c -> (c -> c -> c) -> a -> b --- > scanr1Of :: Traversal a b c c -> (c -> c -> c) -> a -> b -scanl1Of :: LensLike (Backwards (Lazy.State (Maybe c))) a b c c -> (c -> c -> c) -> a -> b -scanl1Of l f = snd . mapAccumLOf l step Nothing where - step Nothing c = (Just c, c) - step (Just s) c = (Just r, r) where r = f s c -{-# INLINE scanl1Of #-} - ------------------------------------------------------------------------------- --- Setters ------------------------------------------------------------------------------- - --- | --- The only 'Lens'-like law that can apply to a 'Setter' @l@ is that --- --- > set l c (set l b a) = set l c a --- --- You can't 'view' a 'Setter' in general, so the other two laws are irrelevant. --- --- However, two functor laws apply to a 'Setter' --- --- > adjust l id = id --- > adjust l f . adjust l g = adjust l (f . g) --- --- These an be stated more directly: --- --- > l Identity = Identity --- > l f . runIdentity . l g = l (f . runIdentity . g) --- --- You can compose a 'Setter' with a 'Lens' or a 'Traversal' using @(.)@ from the Prelude --- and the result is always only a 'Setter' and nothing more. --- --- > type Setter a b c d = LensLike Identity a b c d -type Setter a b c d = (c -> Identity d) -> a -> Identity b - --- | This alias is supplied for those who don't want to use @LiberalTypeSynonyms@ with --- 'Simple'. --- --- > 'SimpleSetter ' = 'Simple' 'Setter' -type SimpleSetter a b = Setter a a b b - --- | This setter can be used to map over all of the values in a 'Functor'. --- --- > fmap = adjust mapped --- > fmapDefault = adjust traverse --- > (<$) = set mapped -mapped :: Functor f => Setter (f a) (f b) a b -mapped = sets fmap -{-# INLINE mapped #-} - --- | Build a Setter. --- --- > sets . adjust = id --- > adjust . sets = id --- > sets = from adjust --- > adjust = from sets --- --- > sets :: ((c -> d) -> a -> b) -> Setter a b c d -sets :: Isomorphic k => k ((c -> d) -> a -> b) (Setter a b c d) -sets = isomorphic (\f g -> Identity . f (runIdentity . g)) - (\l f -> runIdentity . l (Identity . f)) -{-# INLINE sets #-} -{-# SPECIALIZE sets :: ((c -> d) -> a -> b) -> Setter a b c d #-} - --- | Modify the target of a 'Lens' or all the targets of a 'Setter' or 'Traversal' --- with a function. --- --- > fmap = adjust mapped --- > fmapDefault = adjust traverse --- --- > sets . adjust = id --- > adjust . sets = id --- --- > adjust :: Setter a b c d -> (c -> d) -> a -> b -adjust :: Isomorphic k => k (Setter a b c d) ((c -> d) -> a -> b) -adjust = isomorphic (\l f -> runIdentity . l (Identity . f)) - (\f g -> Identity . f (runIdentity . g)) -{-# INLINE adjust #-} -{-# SPECIALIZE adjust :: Setter a b c d -> (c -> d) -> a -> b #-} - --- | Modify the target of a 'Lens' or all the targets of a 'Setter' or 'Traversal' --- with a function. This is an alias for adjust that is provided for consistency. --- --- > mapOf = adjust --- --- > fmap = mapOf mapped --- > fmapDefault = mapOf traverse --- --- > sets . mapOf = id --- > 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 --- > mapOf :: Traversal a b c d -> (c -> d) -> a -> b -mapOf :: Isomorphic k => k (Setter a b c d) ((c -> d) -> a -> b) -mapOf = adjust -{-# INLINE mapOf #-} -{-# SPECIALIZE mapOf :: Setter a b c d -> (c -> d) -> a -> b #-} - --- | Replace the target of a 'Lens' or all of the targets of a 'Setter' --- or 'Traversal' with a constant value. --- --- > (<$) = set mapped --- --- > set :: Setter a b c d -> d -> a -> b --- > set :: Iso a b c d -> d -> a -> b --- > set :: Lens a b c d -> d -> a -> b --- > set :: Traversal a b c d -> d -> a -> b -set :: Setter a b c d -> d -> a -> b -set l d = runIdentity . l (\_ -> Identity d) -{-# INLINE set #-} - --- | Modifies the target of a 'Lens' or all of the targets of a 'Setter' or --- 'Traversal' with a user supplied function. --- --- This is an infix version of 'adjust' --- --- > fmap f = mapped %~ f --- > fmapDefault f = traverse %~ f --- --- > ghci> _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 --- > (%~) :: Traversal a b c d -> (c -> d) -> a -> b -(%~) :: Setter a b c d -> (c -> d) -> a -> b -(%~) = adjust -{-# INLINE (%~) #-} - --- | Replace the target of a 'Lens' or all of the targets of a 'Setter' --- or 'Traversal' with a constant value. --- --- This is an infix version of 'set', provided for consistency with '(^=)' -(^~) :: Setter a b c d -> d -> a -> b -(^~) = set -{-# INLINE (^~) #-} - --- | Replace the target of a 'Lens' or all of the targets of a 'Setter' --- or 'Traversal' with a constant value. --- --- This is an infix version of 'set' --- --- > f <$ a = mapped <~ f $ a --- --- > ghci> bitAt 0 <~ True $ 0 --- > 1 --- --- > (<~) :: Setter a b c d -> d -> a -> b --- > (<~) :: Iso a b c d -> d -> a -> b --- > (<~) :: Lens a b c d -> d -> a -> b --- > (<~) :: Traversal a b c d -> d -> a -> b -(<~) :: Setter a b c d -> d -> a -> b -(<~) = set -{-# INLINE (<~) #-} - --- | Increment the target(s) of a numerically valued 'Lens', Setter' or 'Traversal' --- --- > ghci> _1 +~ 1 $ (1,2) --- > (2,2) -(+~) :: Num c => Setter a b c c -> c -> a -> b -l +~ n = adjust l (+ n) -{-# INLINE (+~) #-} - --- | Multiply the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal' --- --- > ghci> _2 *~ 4 $ (1,2) --- > (1,8) -(*~) :: Num c => Setter a b c c -> c -> a -> b -l *~ n = adjust l (* n) -{-# INLINE (*~) #-} - --- | Decrement the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal' --- --- > ghci> _1 -~ 2 $ (1,2) --- > (-1,2) -(-~) :: Num c => Setter a b c c -> c -> a -> b -l -~ n = adjust l (subtract n) -{-# INLINE (-~) #-} - --- | Divide the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal' -(//~) :: Fractional c => Setter a b c c -> c -> a -> b -l //~ n = adjust l (/ n) - --- | Logically '||' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' -(||~):: Setter a b Bool Bool -> Bool -> a -> b -l ||~ n = adjust l (|| n) -{-# INLINE (||~) #-} - --- | Logically '&&' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' -(&&~) :: Setter a b Bool Bool -> Bool -> a -> b -l &&~ n = adjust l (&& n) -{-# INLINE (&&~) #-} - --- | Modify the target of a monoidally valued by 'mappend'ing another value. -(<>~) :: Monoid c => Setter a b c c -> c -> a -> b -l <>~ n = adjust l (mappend n) -{-# INLINE (<>~) #-} - ---------------- --- Getters ---------------- - --- | 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. --- --- Moreover, a 'Getter' can be used directly as a 'Fold', since it just ignores the 'Monoid'. --- --- In practice the @b@ and @d@ are left dangling and unused, and as such is no real point in --- using a @'Simple' 'Getter'@. --- --- > type Getter a c = forall r. LensLike (Const r) a b c d -type Getter a c = forall r b d. (c -> Const r d) -> a -> Const r b - --- | Build a 'Getter' from an arbitrary Haskell function. --- --- > to f . to g = to (g . f) --- > to = from view --- --- > to . from = id -to :: (a -> c) -> Getter a c -to f g = Const . getConst . g . f -{-# INLINE to #-} - --- | --- Most 'Getter' combinators are able to be used with both a 'Getter' or a '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 --- restricted choices of the irrelevant b and d parameters. --- --- If a function accepts a @Getting r a b c d@, then when @r@ is a Monoid, you can --- pass a 'Fold' (or 'Traversal'), otherwise you can only pass this a 'Getter' or 'Lens'. --- --- > type Getting r a b c d = LensLike (Const r) a b c d -type Getting r a b c d = (c -> Const r d) -> a -> Const r b - -------------------------------- --- 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. --- --- It may be useful to think of 'view' as having these more restrictive signatures: --- --- > 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 :: Getting c a b c d -> a -> c -view l = getConst . l Const - --- | 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'. --- --- It may be useful to think of 'views' as having these more restrictive signatures: --- --- > 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 :: ((c -> Const m d) -> a -> Const m b) -> (c -> m) -> a -> m -views :: Isomorphic k => k (Getting m a b c d) ((c -> m) -> a -> m) -views = isomorphic (\l f -> getConst . l (Const . f)) (\l f -> Const . l (getConst . f)) -{-# INLINE views #-} -{-# SPECIALIZE views :: Getting m a b c d -> (c -> m) -> a -> m #-} -{-# SPECIALIZE views :: Isomorphism (Getting m a b c d) ((c -> m) -> a -> m) #-} - --- | 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. --- --- This is the same operation as 'view', only infix. --- --- > (^$) :: 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 --- --- > (^$) :: ((c -> Const c d) -> a -> Const c b) -> a -> c -(^$) :: Getting c a b c d -> a -> c -l ^$ a = getConst (l Const 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. --- --- 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..) --- --- > ghci> ((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 -> ((c -> Const c d) -> a -> Const c b) -> c -(^.) :: a -> Getting c a b c d -> c -a ^. l = getConst (l Const a) -{-# INLINE (^.) #-} - ------------------------------------------------------------------------------- --- Common Lenses ------------------------------------------------------------------------------- - --- | This is a lens that can change the value (and type) of the first field of --- a pair. --- --- > ghci> (1,2)^._1 --- > 1 --- --- > ghci> _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 --- --- > _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 #-} - --- | A 'Lens' to view/edit the nth element 'elementOf' a 'Traversal', 'Lens' or 'Iso'. --- --- Attempts to access beyond the range of the 'Traversal' will cause an error. --- --- > ghci> [[1],[3,4]]^.elementOf (traverse.traverse) 1 --- > 3 -elementOf :: Functor f => LensLike (ElementOf f) a b c c -> Int -> LensLike f a b c c -elementOf l i f a = case getElementOf (l go a) 0 of - Found _ fb -> fb - Searching _ _ -> error "elementOf: index out of range" - where - go c = ElementOf $ \j -> if i == j then Found (j + 1) (f c) else Searching (j + 1) c - --- | Access the nth element of a 'Traversable' container. --- --- Attempts to access beyond the range of the 'Traversal' will cause an error. --- --- > element = elementOf traverse -element :: Traversable t => Int -> Simple Lens (t a) a -element = elementOf traverse - --- | This lens can be used to change the result of a function but only where --- the arguments match the key given. -resultAt :: Eq e => e -> Simple Lens (e -> a) a -resultAt e afa ea = go <$> afa a where - a = ea e - go a' e' | e == e' = a' - | otherwise = a -{-# INLINE resultAt #-} - ------------------------------------------------------------------------------- --- MonadWriter ------------------------------------------------------------------------------- - --- | Tell a part of a value to a 'MonadWriter', filling in the rest from 'mempty' --- --- > whisper l d = tell (set l d mempty) - --- > whisper :: (MonadWriter b m, Monoid a) => Iso a b c d -> d -> m () --- > whisper :: (MonadWriter b m, Monoid a) => Lens a b c d -> d -> m () --- > whisper :: (MonadWriter b m, Monoid a) => Traversal a b c d -> d -> m () --- > whisper :: (MonadWriter b m, Monoid a) => Setter a b c d -> d -> m () --- --- > whisper :: (MonadWriter b m, Monoid a) => ((c -> Identity d) -> a -> Identity b) -> d -> m () -whisper :: (MonadWriter b m, Monoid a) => Setter a b c d -> d -> m () -whisper l d = tell (set l d mempty) -{-# INLINE whisper #-} - ------------------------------------------------------------------------------- --- MonadReader ------------------------------------------------------------------------------- - --- | --- 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 :: MonadReader a m => ((c -> Const c d) -> a -> Const c b) -> 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 --- --- > queries :: MonadReader a m => ((c -> Const e d) -> a -> Const e b) -> (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 #-} - ------------------------------------------------------------------------------- --- MonadState ------------------------------------------------------------------------------- - --- | --- 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 :: 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 => ((c -> Const c d) -> a -> Const c b) -> m c -use :: MonadState a m => Getting c a b c d -> m c -use l = State.gets (^.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. --- --- > 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 => ((c -> Const e d) -> a -> Const e b) -> (c -> e) -> m e -uses :: MonadState a m => Getting e a b c d -> (c -> e) -> m e -uses l f = State.gets (views l f) -{-# INLINE uses #-} - - --- | Replace the target of a 'Lens' or all of the targets of a 'Setter' or 'Traversal' in our monadic --- state with a new value, irrespective of the old. --- --- > (^=) :: MonadState a m => Iso a a c d -> d -> m () --- > (^=) :: MonadState a m => Lens a a c d -> d -> m () --- > (^=) :: MonadState a m => Traversal a a c d -> d -> m () --- > (^=) :: MonadState a m => Setter a a c d -> d -> m () --- - --- "It puts the state in the monad or it gets the hose again." -(^=) :: MonadState a m => Setter a a c d -> d -> m () -l ^= b = State.modify (l ^~ b) -{-# INLINE (^=) #-} - --- | Map over the target of a 'Lens' or all of the targets of a 'Setter' or '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 () --- > (%=) :: MonadState a m => Traversal a a c d -> (c -> d) -> m () --- > (%=) :: MonadState a m => Setter a a c d -> (c -> d) -> m () -(%=) :: MonadState a m => Setter a a c d -> (c -> d) -> m () -l %= f = State.modify (l %~ f) -{-# INLINE (%=) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding a value --- --- Example: --- --- > fresh = do --- > id += 1 --- > access id -(+=) :: (MonadState a m, Num b) => Simple Setter a b -> b -> m () -l += b = State.modify (l +~ b) -{-# INLINE (+=) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by subtracting a value -(-=) :: (MonadState a m, Num b) => Simple Setter a b -> b -> m () -l -= b = State.modify (l -~ b) -{-# INLINE (-=) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by multiplying by value -(*=) :: (MonadState a m, Num b) => Simple Setter a b -> b -> m () -l *= b = State.modify (l *~ b) -{-# INLINE (*=) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by dividing by a value -(//=) :: (MonadState a m, Fractional b) => Simple Setter a b -> b -> m () -l //= b = State.modify (l //~ b) -{-# INLINE (//=) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by taking their logical '&&' with a value -(&&=):: MonadState a m => Simple Setter a Bool -> Bool -> m () -l &&= b = State.modify (l &&~ b) -{-# INLINE (&&=) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso, 'Setter' or 'Traversal' by taking their logical '||' with a value -(||=) :: MonadState a m => Simple Setter a Bool -> Bool -> m () -l ||= b = State.modify (l ||~ b) -{-# INLINE (||=) #-} - --- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value. -(<>=) :: (MonadState a m, Monoid b) => Simple Setter a b -> b -> m () -l <>= b = State.modify (l <>~ b) -{-# INLINE (<>=) #-} - --------------------------- --- Folds --------------------------- --- | A 'Fold' describes how to retrieve multiple values in a way that can be composed --- with other lens-like constructions. --- --- A @'Fold' a c@ provides a structure with operations very similar to those of the 'Foldable' --- typeclass, see 'foldMapOf' and the other 'Fold' combinators. --- --- By convention, if there exists a 'foo' method that expects a @'Foldable' (f c)@, then there should be a --- 'fooOf' method that takes a @'Fold' a c@ and a value of type @a@. --- --- 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 --- there are no lens laws that apply. --- --- > type Fold a c = forall m b d. Monoid m => Getting m a b c d -type Fold a c = forall m b d. Monoid m => (c -> Const m d) -> a -> Const m b - --- | Build a 'Getter' or 'Fold' from a 'foldMap'-like function. --- --- > folds :: ((c -> m) -> a -> m) -> (c -> Const m d) -> a -> Const m b --- > folds :: ((c -> m) -> a -> m) -> Getting m a b c d -folds :: Isomorphic k => k ((c -> m) -> a -> m) (Getting m a b c d) -folds = isomorphic (\l f -> Const . l (getConst . f)) - (\l f -> getConst . l (Const . f)) -{-# INLINE folds #-} -{-# SPECIALIZE folds :: ((c -> m) -> a -> m) -> Getting m a b c d #-} -{-# SPECIALIZE folds :: Isomorphism ((c -> m) -> a -> m) (Getting m a b c d) #-} - --- | Obtain a 'Fold' by lifting an operation that returns a foldable result. --- --- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. -folding :: Foldable f => (a -> f c) -> Fold a c -folding f g = Const . foldMap (getConst . g) . f -{-# INLINE folding #-} - --- | Obtain a 'Fold' from any 'Foldable'. --- --- > folded = folds foldMap -folded :: Foldable f => Fold (f c) c -folded = folds foldMap -{-# INLINE folded #-} - --- | Fold by repeating the input forever. --- --- > repeat = toListOf repeated -repeated :: Fold a a -repeated f a = Const as where as = getConst (f a) `mappend` as - --- | A fold that replicates its input @n@ times. --- --- > replicate n = toListOf (replicated n) -replicated :: Int -> Fold a a -replicated n0 f a = Const (go n0) where - m = getConst (f a) - go 0 = mempty - go n = m `mappend` 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 :: Monoid m => Getting m a b c d -> Getting m a b c d -cycled l f a = Const as where as = getConst (l f a) `mappend` as - --- | Build a fold that unfolds its values from a seed. --- --- > ghci> 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 -> Const mempty -{-# INLINE unfolded #-} - - --- | @x ^. 'iterated' f@ Return an infinite fold of repeated applications of @f@ to @x@. --- --- > toListOf (iterated f) a = iterate f a -iterated :: (a -> a) -> Fold a a -iterated f g a0 = go a0 where - go a = g a *> go (f a) -{-# INLINE iterated #-} - --- | Obtain a 'Fold' by filtering a 'Lens', 'Iso', 'Getter', 'Fold' or 'Traversal'. -filtered :: Monoid m => (c -> Bool) -> Getting m a b c d -> Getting m a b c d -filtered p l f = l (\c -> if p c then f c else Const mempty) -{-# INLINE filtered #-} - --- | Obtain a 'Fold' by reversing the order of traversal for a 'Lens', 'Iso', 'Getter', 'Fold' or 'Traversal'. --- --- Of course, reversing a 'Lens', 'Iso' or 'Getter' has no effect. -reversed :: Getting (Dual m) a b c d -> Getting m a b c d -reversed l f = Const . getDual . getConst . l (Const . Dual . getConst . f) -{-# INLINE reversed #-} - ---taking :: Int -> Getting (Taking m) a b c d -> Getting m a b c d ---dropping :: Int -> Getting (Dropping m) a b c d -> Getting m a b c d - --- | Obtain a 'Fold' by taking elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. --- --- > takeWhile p = toListOf (takingWhile p folded) --- --- > ghci> toList (takingWhile (<=3) folded) [1..] --- > [1,2,3] -takingWhile :: Monoid m => (c -> Bool) -> Getting (Endo m) a b c d -> Getting m a b c d -takingWhile p l f = Const . foldrOf l (\a r -> if p a then getConst (f a) `mappend` r else mempty) mempty -{-# INLINE takingWhile #-} - --- | Obtain a 'Fold' by dropping elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. --- --- > dropWhile p = toListOf (droppingWhile p folded) --- --- > ghci> toList (dropWhile (<=3) folded) [1..6] --- > [4,5,6] -droppingWhile :: Monoid m => (c -> Bool) -> Getting (Endo m) a b c d -> Getting m a b c d -droppingWhile p l f = Const . foldrOf l (\a r -> if p a then mempty else mappend r (getConst (f a))) mempty -{-# INLINE droppingWhile #-} - --------------------------- --- Fold/Getter combinators --------------------------- - --- | --- > foldMap = foldMapOf folded --- --- > foldMapOf = views --- > foldMapOf = from folds --- --- > foldMapOf :: Getter a c -> (c -> m) -> a -> m --- > foldMapOf :: Monoid m => Fold a c -> (c -> m) -> a -> m --- > foldMapOf :: Lens a b c d -> (c -> m) -> a -> m --- > foldMapOf :: Iso a b c d -> (c -> m) -> a -> m --- > foldMapOf :: Monoid m => Traversal a b c d -> (c -> m) -> a -> m --- --- > foldMapOf :: Getting m a b c d -> (c -> m) -> a -> m -foldMapOf :: Isomorphic k => k (Getting m a b c d) ((c -> m) -> a -> m) -foldMapOf = isomorphic (\l f -> getConst . l (Const . f)) - (\l f -> Const . l (getConst . f)) -{-# INLINE foldMapOf #-} -{-# SPECIALIZE foldMapOf :: Getting m a b c d -> (c -> m) -> a -> m #-} - --- | --- > fold = foldOf folded --- --- > foldOf = view --- --- > foldOf :: Getter a m -> a -> m --- > foldOf :: Monoid m => Fold a m -> a -> m --- > foldOf :: Lens a b m d -> a -> m --- > foldOf :: Iso a b m d -> a -> m --- > foldOf :: Monoid m => Traversal a b m d -> a -> m -foldOf :: Getting m a b m d -> a -> m -foldOf l = getConst . l Const -{-# INLINE foldOf #-} - --- | --- Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. --- --- > foldr = foldrOf folded --- --- > foldrOf :: Getter a c -> (c -> e -> e) -> e -> a -> e --- > foldrOf :: Fold a c -> (c -> e -> e) -> e -> a -> e --- > foldrOf :: Lens a b c d -> (c -> e -> e) -> e -> a -> e --- > foldrOf :: Iso a b c d -> (c -> e -> e) -> e -> a -> e --- > foldrOf :: Traversal a b c d -> (c -> e -> e) -> e -> a -> e -foldrOf :: Getting (Endo e) a b c d -> (c -> e -> e) -> e -> a -> e -foldrOf l f z t = appEndo (foldMapOf l (Endo . f) t) z -{-# INLINE foldrOf #-} - --- | --- Left-associative fold of the parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. --- --- > foldl = foldlOf folded --- --- > foldlOf :: Getter a c -> (e -> c -> e) -> e -> a -> e --- > foldlOf :: Fold a c -> (e -> c -> e) -> e -> a -> e --- > foldlOf :: Lens a b c d -> (e -> c -> e) -> e -> a -> e --- > foldlOf :: Iso a b c d -> (e -> c -> e) -> e -> a -> e --- > foldlOf :: Traversal a b c d -> (e -> c -> e) -> e -> a -> e -foldlOf :: Getting (Dual (Endo e)) a b c d -> (e -> c -> e) -> e -> a -> e -foldlOf l f z t = appEndo (getDual (foldMapOf l (Dual . Endo . flip f) t)) z -{-# INLINE foldlOf #-} - --- | --- > toList = toListOf folded --- --- > toListOf :: Getter a c -> a -> [c] --- > toListOf :: Fold a c -> a -> [c] --- > toListOf :: Lens a b c d -> a -> [c] --- > toListOf :: Iso a b c d -> a -> [c] --- > toListOf :: Traversal a b c d -> a -> [c] -toListOf :: Getting [c] a b c d -> a -> [c] -toListOf l = foldMapOf l return -{-# INLINE toListOf #-} - --- | --- > and = andOf folded --- --- > andOf :: Getter a Bool -> a -> Bool --- > andOf :: Fold a Bool -> a -> Bool --- > andOf :: Lens a b Bool d -> a -> Bool --- > andOf :: Iso a b Bool d -> a -> Bool --- > andOf :: Traversl a b Bool d -> a -> Bool -andOf :: Getting All a b Bool d -> a -> Bool -andOf l = getAll . foldMapOf l All -{-# INLINE andOf #-} - --- | --- > or = orOf folded --- --- > orOf :: Getter a Bool -> a -> Bool --- > orOf :: Fold a Bool -> a -> Bool --- > orOf :: Lens a b Bool d -> a -> Bool --- > orOf :: Iso a b Bool d -> a -> Bool --- > orOf :: Traversal a b Bool d -> a -> Bool -orOf :: Getting Any a b Bool d -> a -> Bool -orOf l = getAny . foldMapOf l Any -{-# INLINE orOf #-} - --- | --- > any = anyOf folded --- --- > anyOf :: Getter a c -> (c -> Bool) -> a -> Bool --- > anyOf :: Fold a c -> (c -> Bool) -> a -> Bool --- > anyOf :: Lens a b c d -> (c -> Bool) -> a -> Bool --- > anyOf :: Iso a b c d -> (c -> Bool) -> a -> Bool --- > anyOf :: Traversal a b c d -> (c -> Bool) -> a -> Bool -anyOf :: Getting Any a b c d -> (c -> Bool) -> a -> Bool -anyOf l f = getAny . foldMapOf l (Any . f) -{-# INLINE anyOf #-} - --- | --- > all = allOf folded --- --- > allOf :: Getter a c -> (c -> Bool) -> a -> Bool --- > allOf :: Fold a c -> (c -> Bool) -> a -> Bool --- > allOf :: Lens a b c d -> (c -> Bool) -> a -> Bool --- > allOf :: Iso a b c d -> (c -> Bool) -> a -> Bool --- > allOf :: Traversal a b c d -> (c -> Bool) -> a -> Bool -allOf :: Getting All a b c d -> (c -> Bool) -> a -> Bool -allOf l f = getAll . foldMapOf l (All . f) -{-# INLINE allOf #-} - --- | --- > product = productOf folded --- --- > productOf :: Getter a c -> a -> c --- > productOf :: Num c => Fold a c -> a -> c --- > productOf :: Lens a b c d -> a -> c --- > productOf :: Iso a b c d -> a -> c --- > productOf :: Num c => Traversal a b c d -> a -> c -productOf :: Getting (Product c) a b c d -> a -> c -productOf l = getProduct . foldMapOf l Product -{-# INLINE productOf #-} - --- | --- > sum = sumOf folded --- --- > 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 --- > sumOf :: Iso a b c d -> a -> c --- > sumOf :: Num c => Traversal a b c d -> a -> c -sumOf :: Getting (Sum c) a b c d -> a -> c -sumOf l = getSum . foldMapOf l Sum -{-# INLINE sumOf #-} - --- | --- --- When passed a 'Getter', 'traverseOf_' can work over a 'Functor'. --- --- When passed a 'Fold', 'traverseOf_' requires an 'Applicative'. --- --- > traverse_ = traverseOf_ folded --- --- > traverseOf_ _2 :: Functor f => (c -> f e) -> (c1, c) -> f () --- > traverseOf_ 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 () --- > traverseOf_ :: Applicative f => Fold a c -> (c -> f e) -> a -> f () --- > traverseOf_ :: Functor f => Lens a b c d -> (c -> f e) -> a -> f () --- > traverseOf_ :: Functor f => Iso a b c d -> (c -> f e) -> a -> f () --- > traverseOf_ :: Applicative f => Traversal a b c d -> (c -> f e) -> a -> f () -traverseOf_ :: Functor f => Getting (Traversed f) a b c d -> (c -> f e) -> a -> f () -traverseOf_ l f = getTraversed . foldMapOf l (Traversed . void . f) -{-# INLINE traverseOf_ #-} - --- | --- > 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 () --- > forOf_ :: Functor f => Lens a b c d -> a -> (c -> f e) -> f () --- > forOf_ :: Functor f => Iso a b c d -> a -> (c -> f e) -> f () --- > forOf_ :: Applicative f => Traversal a b c d -> a -> (c -> f e) -> f () -forOf_ :: Functor f => Getting (Traversed f) a b c d -> a -> (c -> f e) -> f () -forOf_ l a f = traverseOf_ l f a -{-# INLINE forOf_ #-} - --- | --- > sequenceA_ = sequenceAOf_ folded --- --- > sequenceAOf_ :: Functor f => Getter a (f ()) -> a -> f () --- > sequenceAOf_ :: Applicative f => Fold a (f ()) -> a -> f () --- > sequenceAOf_ :: Functor f => Lens a b (f ()) d -> a -> f () --- > sequenceAOf_ :: Functor f => Iso a b (f ()) d -> a -> f () --- > sequenceAOf_ :: Applicative f => Traversal a b (f ()) d -> a -> f () -sequenceAOf_ :: Functor f => Getting (Traversed f) a b (f ()) d -> a -> f () -sequenceAOf_ l = getTraversed . foldMapOf l (Traversed . void) -{-# INLINE sequenceAOf_ #-} - --- | --- > 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 () --- > mapMOf_ :: Monad m => Lens a b c d -> (c -> m e) -> a -> m () --- > mapMOf_ :: Monad m => Iso a b c d -> (c -> m e) -> a -> m () --- > mapMOf_ :: Monad m => Traversal a b c d -> (c -> m e) -> a -> m () -mapMOf_ :: Monad m => Getting (Action m) a b c d -> (c -> m e) -> a -> m () -mapMOf_ l f = getAction . foldMapOf l (Action . liftM skip . f) -{-# INLINE mapMOf_ #-} - --- | --- > 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 () --- > forMOf_ :: Monad m => Lens a b c d -> a -> (c -> m e) -> m () --- > forMOf_ :: Monad m => Iso a b c d -> a -> (c -> m e) -> m () --- > forMOf_ :: Monad m => Traversal a b c d -> a -> (c -> m e) -> m () -forMOf_ :: Monad m => Getting (Action m) a b c d -> a -> (c -> m e) -> m () -forMOf_ l a f = mapMOf_ l f a -{-# INLINE forMOf_ #-} - --- | --- > sequence_ = sequenceOf_ folded --- --- > sequenceOf_ :: Monad m => Getter a (m b) -> a -> m () --- > sequenceOf_ :: Monad m => Fold a (m b) -> a -> m () --- > sequenceOf_ :: Monad m => Lens a b (m b) d -> a -> m () --- > sequenceOf_ :: Monad m => Iso a b (m b) d -> a -> m () --- > sequenceOf_ :: Monad m => Traversal a b (m b) d -> a -> m () -sequenceOf_ :: Monad m => Getting (Action m) a b (m c) d -> a -> m () -sequenceOf_ l = getAction . foldMapOf l (Action . liftM skip) -{-# INLINE sequenceOf_ #-} - --- | The sum of a collection of actions, generalizing 'concatOf'. --- --- > asum = asumOf folded --- --- > asumOf :: Alternative f => Getter a c -> a -> f c --- > asumOf :: Alternative f => Fold a c -> a -> f c --- > asumOf :: Alternative f => Lens a b c d -> a -> f c --- > asumOf :: Alternative f => Iso a b c d -> a -> f c --- > asumOf :: Alternative f => Traversal a b c d -> a -> f c -asumOf :: Alternative f => Getting (Endo (f c)) a b (f c) d -> a -> f c -asumOf l = foldrOf l (<|>) Applicative.empty -{-# INLINE asumOf #-} - --- | The sum of a collection of actions, generalizing 'concatOf'. --- --- > msum = msumOf folded --- --- > msumOf :: MonadPlus m => Getter a c -> a -> m c --- > msumOf :: MonadPlus m => Fold a c -> a -> m c --- > msumOf :: MonadPlus m => Lens a b c d -> a -> m c --- > msumOf :: MonadPlus m => Iso a b c d -> a -> m c --- > msumOf :: MonadPlus m => Traversal a b c d -> a -> m c -msumOf :: MonadPlus m => Getting (Endo (m c)) a b (m c) d -> a -> m c -msumOf l = foldrOf l mplus mzero -{-# INLINE msumOf #-} - --- | --- > elem = elemOf folded --- --- > elemOf :: Eq c => Getter a c -> c -> a -> Bool --- > elemOf :: Eq c => Fold a c -> c -> a -> Bool --- > elemOf :: Eq c => Lens a b c d -> c -> a -> Bool --- > elemOf :: Eq c => Iso a b c d -> c -> a -> Bool --- > elemOf :: Eq c => Traversal a b c d -> c -> a -> Bool -elemOf :: Eq c => Getting Any a b c d -> c -> a -> Bool -elemOf l = anyOf l . (==) -{-# INLINE elemOf #-} - --- | --- > notElem = notElemOf folded --- --- > notElemOf :: Eq c => Getter a c -> c -> a -> Bool --- > notElemOf :: Eq c => Fold a c -> c -> a -> Bool --- > notElemOf :: Eq c => Iso a b c d -> c -> a -> Bool --- > notElemOf :: Eq c => Lens a b c d -> c -> a -> Bool --- > notElemOf :: Eq c => Traversal a b c d -> c -> a -> Bool -notElemOf :: Eq c => Getting All a b c d -> c -> a -> Bool -notElemOf l = allOf l . (/=) -{-# INLINE notElemOf #-} - --- | --- > concatMap = concatMapOf folded --- --- > concatMapOf :: Getter a c -> (c -> [e]) -> a -> [e] --- > concatMapOf :: Fold a c -> (c -> [e]) -> a -> [e] --- > concatMapOf :: Lens a b c d -> (c -> [e]) -> a -> [e] --- > concatMapOf :: Iso a b c d -> (c -> [e]) -> a -> [e] --- > concatMapOf :: Traversal a b c d -> (c -> [e]) -> a -> [e] -concatMapOf :: Getting [e] a b c d -> (c -> [e]) -> a -> [e] -concatMapOf l ces a = getConst (l (Const . ces) a) -{-# INLINE concatMapOf #-} - --- | --- > concat = concatOf folded --- --- > concatOf :: Getter a [e] -> a -> [e] --- > concatOf :: Fold a [e] -> a -> [e] --- > concatOf :: Iso a b [e] d -> a -> [e] --- > concatOf :: Lens a b [e] d -> a -> [e] --- > concatOf :: Traversal a b [e] d -> a -> [e] -concatOf :: Getting [e] a b [e] d -> a -> [e] -concatOf = view -{-# INLINE concatOf #-} - --- | --- Note: this can be rather inefficient for large containers. --- --- > length = lengthOf folded --- --- > lengthOf _1 :: (a, b) -> Int --- > lengthOf _1 = 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 --- > lengthOf :: Iso a b c d -> a -> Int --- > lengthOf :: Traversal a b c d -> a -> Int -lengthOf :: Getting (Sum Int) a b c d -> a -> Int -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'. --- --- > listToMaybe . toList = headOf folded --- --- > headOf :: Getter a c -> a -> Maybe c --- > headOf :: Fold a c -> a -> Maybe c --- > headOf :: Lens a b c d -> a -> Maybe c --- > headOf :: Iso a b c d -> a -> Maybe c --- > headOf :: Traversal a b c d -> a -> Maybe c -headOf :: Getting (First c) a b c d -> a -> Maybe c -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'. --- --- > lastOf :: Getter a c -> a -> Maybe c --- > lastOf :: Fold a c -> a -> Maybe c --- > lastOf :: Lens a b c d -> a -> Maybe c --- > lastOf :: Iso a b c d -> a -> Maybe c --- > lastOf :: Traversal a b c d -> a -> Maybe c -lastOf :: Getting (Last c) a b c d -> a -> Maybe c -lastOf l = getLast . foldMapOf l (Last . Just) -{-# INLINE lastOf #-} - --- | --- Returns 'True' if this 'Fold' or 'Traversal' has no targets in the given container. --- --- Note: nullOf on a valid 'Iso', 'Lens' or 'Getter' should always return 'False' --- --- > 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 :: Getter a c -> a -> Bool --- > nullOf :: Fold a c -> a -> Bool --- > nullOf :: Iso a b c d -> a -> Bool --- > nullOf :: Lens a b c d -> a -> Bool --- > nullOf :: Traversal a b c d -> a -> Bool -nullOf :: Getting All a b c d -> a -> Bool -nullOf l = getAll . foldMapOf l (\_ -> All False) -{-# INLINE nullOf #-} - --- | --- Obtain the maximum element (if any) targeted by a 'Fold' or 'Traversal' --- --- Note: maximumOf on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. --- --- > maximum = fromMaybe (error "empty") . maximumOf folded --- --- > maximumOf :: Getter a c -> a -> Maybe c --- > maximumOf :: Ord c => Fold a c -> a -> Maybe c --- > maximumOf :: Iso a b c d -> a -> Maybe c --- > maximumOf :: Lens a b c d -> a -> Maybe c --- > maximumOf :: Ord c => Traversal a b c d -> a -> Maybe c -maximumOf :: Getting (Max c) a b c d -> a -> Maybe c -maximumOf l = getMax . foldMapOf l Max -{-# INLINE maximumOf #-} - --- | --- Obtain the minimum element (if any) targeted by a 'Fold' or 'Traversal' --- --- Note: minimumOf on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. --- --- > minimum = fromMaybe (error "empty") . minimumOf folded --- --- > minimumOf :: Getter a c -> a -> Maybe c --- > minimumOf :: Ord c => Fold a c -> a -> Maybe c --- > minimumOf :: Iso a b c d -> a -> Maybe c --- > minimumOf :: Lens a b c d -> a -> Maybe c --- > minimumOf :: Ord c => Traversal a b c d -> a -> Maybe c -minimumOf :: Getting (Min c) a b c d -> a -> Maybe c -minimumOf l = getMin . foldMapOf l Min -{-# INLINE minimumOf #-} - --- | --- Obtain the maximum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso', --- or 'Getter' according to a user supplied ordering. --- --- > maximumBy cmp = 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 --- > maximumByOf :: Iso a b c d -> (c -> c -> Ordering) -> a -> Maybe c --- > maximumByOf :: Lens a b c d -> (c -> c -> Ordering) -> a -> Maybe c --- > maximumByOf :: Traversal a b c d -> (c -> c -> Ordering) -> a -> Maybe c -maximumByOf :: Getting (Endo (Maybe c)) a b c d -> (c -> c -> Ordering) -> a -> Maybe c -maximumByOf l cmp = foldrOf l step Nothing where - step a Nothing = Just a - step a (Just b) = Just (if cmp a b == GT then a else b) -{-# INLINE maximumByOf #-} - --- | --- Obtain the minimum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso' --- or 'Getter' according to a user supplied ordering. --- --- > minimumBy cmp = fromMaybe (error "empty") . minimumByOf folded cmp --- --- > minimumByOf :: Getter a c -> (c -> c -> Ordering) -> a -> Maybe c --- > minimumByOf :: Fold a c -> (c -> c -> Ordering) -> a -> Maybe c --- > minimumByOf :: Iso a b c d -> (c -> c -> Ordering) -> a -> Maybe c --- > minimumByOf :: Lens a b c d -> (c -> c -> Ordering) -> a -> Maybe c --- > minimumByOf :: Traversal a b c d -> (c -> c -> Ordering) -> a -> Maybe c -minimumByOf :: Getting (Endo (Maybe c)) a b c d -> (c -> c -> Ordering) -> a -> Maybe c -minimumByOf l cmp = foldrOf l step Nothing where - step a Nothing = Just a - 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), --- a predicate and a structure and returns the leftmost element of the structure --- matching the predicate, or 'Nothing' if there is no such element. --- --- > findOf :: Getter a c -> (c -> Bool) -> a -> Maybe c --- > findOf :: Fold a c -> (c -> Bool) -> a -> Maybe c --- > findOf :: Iso a b c d -> (c -> Bool) -> a -> Maybe c --- > findOf :: Lens a b c d -> (c -> Bool) -> a -> Maybe c --- > findOf :: Traversal a b c d -> (c -> Bool) -> a -> Maybe c -findOf :: Getting (First c) a b c d -> (c -> Bool) -> a -> Maybe c -findOf l p = getFirst . foldMapOf l step where - step c - | p c = First (Just c) - | otherwise = First Nothing -{-# INLINE findOf #-} - --- | --- A variant of 'foldrOf' that has no base case and thus may only be applied --- to lenses and structures such that the lens views at least one element of --- the structure. --- --- > foldr1Of l f = Prelude.foldr1 f . toListOf l --- --- > foldr1 = foldr1Of folded --- --- > foldr1Of :: Getter a c -> (c -> c -> c) -> a -> c --- > foldr1Of :: Fold a c -> (c -> c -> c) -> a -> c --- > foldr1Of :: Iso a b c d -> (c -> c -> c) -> a -> c --- > foldr1Of :: Lens a b c d -> (c -> c -> c) -> a -> c --- > foldr1Of :: Traversal a b c d -> (c -> c -> c) -> a -> c -foldr1Of :: Getting (Endo (Maybe c)) a b c d -> (c -> c -> c) -> a -> c -foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") - (foldrOf l mf Nothing xs) where - mf x Nothing = Just x - mf x (Just y) = Just (f x y) -{-# INLINE foldr1Of #-} - --- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and strutures such --- that the lens views at least one element of the structure. --- --- > foldl1Of l f = Prelude.foldl1Of l f . toList --- --- > foldl1 = foldl1Of folded --- --- > foldl1Of :: Getter a c -> (c -> c -> c) -> a -> c --- > foldl1Of :: Fold a c -> (c -> c -> c) -> a -> c --- > foldl1Of :: Iso a b c d -> (c -> c -> c) -> a -> c --- > foldl1Of :: Lens a b c d -> (c -> c -> c) -> a -> c --- > foldl1Of :: Traversal a b c d -> (c -> c -> c) -> a -> c -foldl1Of :: Getting (Dual (Endo (Maybe c))) a b c d -> (c -> c -> c) -> a -> c -foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where - mf Nothing y = Just y - mf (Just x) y = Just (f x y) -{-# INLINE foldl1Of #-} - --- | Strictly fold right over the elements of a structure. --- --- > foldr' = foldrOf' folded --- --- > foldrOf' :: Getter a c -> (c -> e -> e) -> e -> a -> e --- > foldrOf' :: Fold a c -> (c -> e -> e) -> e -> a -> e --- > foldrOf' :: Iso a b c d -> (c -> e -> e) -> e -> a -> e --- > foldrOf' :: Lens a b c d -> (c -> e -> e) -> e -> a -> e --- > foldrOf' :: Traversal a b c d -> (c -> e -> e) -> e -> a -> e -foldrOf' :: Getting (Dual (Endo (e -> e))) a b c d -> (c -> e -> e) -> e -> a -> e -foldrOf' l f z0 xs = foldlOf l f' id xs z0 - where f' k x z = k $! f x z -{-# INLINE foldrOf' #-} - --- | Fold over the elements of a structure, associating to the left, but strictly. --- --- > foldl' = foldlOf' folded --- --- > foldlOf' :: Getter a c -> (e -> c -> e) -> e -> a -> e --- > foldlOf' :: Fold a c -> (e -> c -> e) -> e -> a -> e --- > foldlOf' :: Iso a b c d -> (e -> c -> e) -> e -> a -> e --- > foldlOf' :: Lens a b c d -> (e -> c -> e) -> e -> a -> e --- > foldlOf' :: Traversal a b c d -> (e -> c -> e) -> e -> a -> e -foldlOf' :: Getting (Endo (e -> e)) a b c d -> (e -> c -> e) -> e -> a -> e -foldlOf' l f z0 xs = foldrOf l f' id xs z0 - where f' x k z = k $! f z x -{-# INLINE foldlOf' #-} - --- | Monadic fold over the elements of a structure, associating to the right, --- i.e. from right to left. --- --- > 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 --- > foldrMOf :: Monad m => Iso a b c d -> (c -> e -> m e) -> e -> a -> m e --- > foldrMOf :: Monad m => Lens a b c d -> (c -> e -> m e) -> e -> a -> m e --- > foldrMOf :: Monad m => Traversal a b c d -> (c -> e -> m e) -> e -> a -> m e -foldrMOf :: Monad m - => Getting (Dual (Endo (e -> m e))) a b c d - -> (c -> e -> m e) -> e -> a -> m e -foldrMOf l f z0 xs = foldlOf l f' return xs z0 - where f' k x z = f x z >>= k -{-# INLINE foldrMOf #-} - --- | Monadic fold over the elements of a structure, associating to the left, --- i.e. from left to right. --- --- > 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 --- > foldlMOf :: Monad m => Iso a b c d -> (e -> c -> m e) -> e -> a -> m e --- > foldlMOf :: Monad m => Lens a b c d -> (e -> c -> m e) -> e -> a -> m e --- > foldlMOf :: Monad m => Traversal a b c d -> (e -> c -> m e) -> e -> a -> m e -foldlMOf :: Monad m - => Getting (Endo (e -> m e)) a b c d - -> (e -> c -> m e) -> e -> a -> m e -foldlMOf l f z0 xs = foldrOf l f' return xs z0 - where f' x k z = f z x >>= k -{-# INLINE foldlMOf #-} - ------------------------------------------------------------------------------- --- Traversals ------------------------------------------------------------------------------- - --- | This is the traversal that just doesn't return anything --- --- > traverseNothing :: Applicative f => (c -> f d) -> a -> f a -traverseNothing :: Traversal a a c d -traverseNothing = const pure -{-# INLINE traverseNothing #-} - ------------------------------------------------------------------------------- --- Transforming Traversals ------------------------------------------------------------------------------- - --- | This allows you to 'traverse' the elements of a 'Traversal' in the --- opposite order. --- --- Note: 'reversed' is similar, but is able to accept a 'Fold' (or 'Getter') --- and produce a 'Fold' (or 'Getter'). --- --- This requires at least a 'Traversal' (or 'Lens') and can produce a --- 'Traversal' (or 'Lens') in turn. --- --- A backwards 'Iso' is the same 'Iso'. If you reverse the direction of --- the isomorphism use 'from' instead. -backwards :: Isomorphic k => Overloaded k (Backwards f) a b c d -> Overloaded k f a b c d -backwards = isomap - (\l f -> forwards . l (Backwards . f)) - (\l f -> forwards . l (Backwards . f)) -{-# INLINE backwards #-} -{-# SPECIALIZE backwards :: LensLike (Backwards f) a b c d -> LensLike f a b c d #-} -{-# SPECIALIZE backwards :: Overloaded Isomorphism (Backwards f) a b c d -> Overloaded Isomorphism f a b c d #-} - --- | Merge two lenses, getters, setters, folds or traversals. -merged :: Functor f => LensLike f a b c c -> LensLike f a' b' c c -> LensLike f (Either a a') (Either b b') c c -merged l _ f (Left a) = Left <$> l f a -merged _ r f (Right a') = Right <$> r f a' -{-# INLINE merged #-} - --- | 'bothLenses' makes a lens from two other lenses (or isomorphisms) -bothLenses :: Lens a b c d -> Lens a' b' c' d' -> Lens (a,a') (b,b') (c,c') (d,d') -bothLenses l r f (a, a') = case l (IndexedStore id) a of - IndexedStore db c -> case r (IndexedStore id) a' of - IndexedStore db' c' -> (\(d,d') -> (db d, db' d')) <$> f (c,c') -{-# INLINE bothLenses #-} - ------------------------------------------------------------------------------ --- Overloading function application ------------------------------------------------------------------------------ - --- | > 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 = Overloaded k f a a b b - ------------------------------------------------------------------------------ --- Isomorphisms families as Lenses ------------------------------------------------------------------------------ - --- | Isomorphim families can be composed with other lenses using either' (.)' and 'id' --- from the Prelude or from Control.Category. However, if you compose them --- with each other using '(.)' from the Prelude, they will be dumbed down to a --- mere 'Lens'. --- --- > import Control.Category --- > import Prelude hiding ((.),id) --- --- > type Iso a b c d = forall k f. (Isomorphic k, Functor f) => Overloaded k f a b c d -type Iso a b c d = forall k f. (Isomorphic k, Functor f) => k (c -> f d) (a -> f b) - --- | > type SimpleIso a b = Simple Iso a b -type SimpleIso a b = Iso a a b b - --- | Build an isomorphism family from two pairs of inverse functions --- --- > isos :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Iso a b c d -isos :: (Isomorphic k, Functor f) => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Overloaded k f a b c d -isos ac ca bd db = isomorphic - (\cfd a -> db <$> cfd (ac a)) - (\afb c -> bd <$> afb (ca c)) -{-# INLINE isos #-} -{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> LensLike f a b c d #-} -{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Overloaded Isomorphism f a b c d #-} - --- | Build a simple isomorphism from a pair of inverse functions --- --- > iso :: (a -> b) -> (b -> a) -> Simple Iso a b -iso :: (Isomorphic k, Functor f) => (a -> b) -> (b -> a) -> SimpleOverloaded k f a b -iso ab ba = isos ab ba ab ba -{-# INLINE iso #-} -{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> SimpleLensLike f a b #-} -{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> SimpleOverloaded Isomorphism f a b #-} - ------------------------------------------------------------------------------ --- Isomorphism ------------------------------------------------------------------------------ - --- | This isomorphism can be used to wrap or unwrap a value in 'Identity'. --- --- > x^.identity = Identity x --- > Identity x^.from identity = x -identity :: Iso a b (Identity a) (Identity b) -identity = isos Identity runIdentity Identity runIdentity -{-# INLINE identity #-} - --- | This isomorphism can be used to wrap or unwrap a value in 'Const' --- --- > x^.konst = Const x --- > Const x^.from konst = x -konst :: Iso a b (Const a c) (Const b d) -konst = isos Const getConst Const getConst -{-# INLINE konst #-} - ------------------------------------------------------------------------------- --- Cloning Lenses ------------------------------------------------------------------------------- - --- | --- --- Cloning a 'Lens' is one way to make sure you arent given --- something weaker, such as a '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. --- -clone :: Functor f - => LensLike (IndexedStore c d) a b c d - -> (c -> f d) -> a -> f b -clone f cfd a = case f (IndexedStore id) a of - IndexedStore db c -> db <$> cfd c -{-# INLINE clone #-} - ------------------------------------------------------------------------------- --- Indexed Folds ------------------------------------------------------------------------------- - --- | Every 'IndexedFold' is a valid 'Fold' -type IndexedFold i a c = forall k m b d. (Indexed i k, Monoid m) => k (c -> Const m d) (a -> Const m b) - -type IndexedFolding i m a b c d = Index i (c -> Const m d) (a -> Const m b) - --- | --- --- > foldMapWithIndexOf :: Monoid m => IndexedFold i a c -> (i -> c -> m) -> a -> m --- > foldMapWithIndexOf :: Monoid m => IndexedTraversal i a b c d -> (i -> c -> m) -> a -> m -foldMapWithIndexOf :: IndexedFolding i m a b c d -> (i -> c -> m) -> a -> m -foldMapWithIndexOf l f = getConst . withIndex l (\i -> Const . f i) -{-# INLINE foldMapWithIndexOf #-} - --- | --- Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. --- --- > foldrWithIndexOf :: IndexedFold i a c -> (i -> c -> e -> e) -> e -> a -> e --- > foldrWithIndexOf :: IndexedTraversal i a b c d -> (i -> c -> e -> e) -> e -> a -> e -foldrWithIndexOf :: IndexedFolding i (Endo e) a b c d -> (i -> c -> e -> e) -> e -> a -> e -foldrWithIndexOf l f z t = appEndo (foldMapWithIndexOf l (\i -> Endo . f i) t) z -{-# INLINE foldrWithIndexOf #-} - ------------------------------------------------------------------------------- --- Indexed Traversals ------------------------------------------------------------------------------- - - --- | Every indexed traversal is a valid Traversal or indexed fold. --- --- The Traversal laws are still required to hold. Moreover, each index should be distinct. -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 - --- | --- > traverseWithIndexOf :: IndexedTraversal i a b c d -> (i -> c -> f d) -> a -> f b -traverseWithIndexOf :: Overloaded (Index i) f a b c d -> (i -> c -> f d) -> a -> f b -traverseWithIndexOf = withIndex -{-# INLINE traverseWithIndexOf #-} - --- | 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. --- --- > mapMWithIndexOf :: Monad m => IndexedTraversal a b c d -> (i -> c -> m d) -> a -> m b -mapMWithIndexOf :: Overloaded (Index i) (WrappedMonad m) a b c d -> (i -> c -> m d) -> a -> m b -mapMWithIndexOf l f = unwrapMonad . withIndex l (\i -> WrapMonad . f i) -{-# INLINE mapMWithIndexOf #-} - -{- -traverseList :: IndexedTraversal Int [a] [b] a b -traverseList = index $ go (0::Int) where - go n f (x:xs) = (:) <$> f n x <*> go (n + 1) f xs - go _ _ [] = pure [] - {-# INLINE traverseList #-} --} +-- > import Control.Lens +-- > data Foo a = Foo { _fooArgs :: [String], _fooValue :: a } +-- > makeLenses ''Foo +-- +-- This defines the following lenses: +-- +-- > fooArgs :: Simple Lens (Foo a) [String] +-- > fooValue :: Lens (Foo a) (Foo b) a b +-- +-- The combinators here have unusually specific type signatures, so for +-- particularly tricky ones, I've tried to list the simpler type signatures +-- you might want to pretend the combinators have. +---------------------------------------------------------------------------- +module Control.Lens + ( module Control.Lens.Type + , module Control.Lens.Traversal + , module Control.Lens.Getter + , module Control.Lens.Setter + , module Control.Lens.Fold + , module Control.Lens.Iso + , module Control.Lens.Indexed + , module Control.Lens.Representable + , module Control.Lens.TH + ) where + +import Control.Lens.Type +import Control.Lens.Traversal +import Control.Lens.Getter +import Control.Lens.Setter +import Control.Lens.Fold +import Control.Lens.Iso +import Control.Lens.Indexed +import Control.Lens.Representable +import Control.Lens.TH diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Fold.hs @@ -0,0 +1,763 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Fold +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +-- 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 +-- +-- > type Fold a c = forall m b d. Monoid m => Getting m a b c d +-- +-- Every 'Getter' is a valid 'Fold' that simply doesn't use the 'Monoid' it is passed. +-- +-- Everything you can do with a 'Foldable' container, you can with with a 'Fold' and there are +-- combinators that generalize the usual 'Foldable' operations in @Control.Lens@. +---------------------------------------------------------------------------- +module Control.Lens.Fold + ( + -- * Folds + Fold + , Furled(..) + -- ** Building Folds + , folds + , folding + , folded + , unfolded + , iterated + , filtered + , backwards + , repeated + , replicated + , cycled + , takingWhile + , droppingWhile + -- ** Folding + , foldMapOf, foldOf + , foldrOf, foldlOf + , toListOf + , anyOf, allOf + , andOf, orOf + , productOf, sumOf + , traverseOf_, forOf_, sequenceAOf_ + , mapMOf_, forMOf_, sequenceOf_ + , asumOf, msumOf + , concatMapOf, concatOf + , elemOf, notElemOf + , lengthOf + , nullOf + , headOf, lastOf + , maximumOf, minimumOf + , maximumByOf, minimumByOf + , findOf + , foldrOf', foldlOf' + , foldr1Of, foldl1Of + , foldrMOf, foldlMOf + ) where + +import Control.Applicative as Applicative +import Control.Applicative.Backwards +import Control.Lens.Getter +import Control.Lens.Internal +import Control.Lens.Type +import Control.Monad +import Data.Foldable as Foldable +import Data.Maybe +import Data.Monoid + + +-------------------------- +-- Folds +-------------------------- + +-- | A 'Fold' describes how to retrieve multiple values in a way that can be composed +-- with other lens-like constructions. +-- +-- A @'Fold' a c@ provides a structure with operations very similar to those of the 'Foldable' +-- typeclass, see 'foldMapOf' and the other 'Fold' combinators. +-- +-- By convention, if there exists a 'foo' method that expects a @'Foldable' (f c)@, then there should be a +-- 'fooOf' method that takes a @'Fold' a c@ and a value of type @a@. +-- +-- 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 +-- 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 + +-- | 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 #-} + +-- | Obtain a 'Fold' by lifting an operation that returns a foldable result. +-- +-- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. +folding :: (Foldable f, Applicative g, Gettable g) => (a -> f c) -> LensLike g a b c d +folding afc cgd = coerce . traverse_ cgd . afc +{-# INLINE folding #-} + +-- | Obtain a 'Fold' from any 'Foldable'. +-- +-- > folded = folds foldMap +folded :: Foldable f => Fold (f c) c +folded = folds foldMap +{-# INLINE folded #-} + +-- | Fold by repeating the input forever. +-- +-- > repeat = toListOf repeated +repeated :: Fold a a +repeated f a = furled as where as = unfurled (f a) `mappend` as + +-- | A fold that replicates its input @n@ times. +-- +-- > 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) +{-# 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 + +-- | Build a fold that unfolds its values from a seed. +-- +-- > ghci> 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 +{-# INLINE unfolded #-} + +-- | @x ^. 'iterated' f@ Return an infinite fold of repeated applications of @f@ to @x@. +-- +-- > toListOf (iterated f) a = iterate f a +iterated :: (a -> a) -> Fold a a +iterated f g a0 = go a0 where + 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) +{-# INLINE filtered #-} + +-- | This allows you to traverse the elements of a 'Traversal' or 'Fold' in the opposite order. +-- +-- Note: 'backwards' should have no impact on a 'Getter' 'Setter', 'Lens' or 'Iso'. +-- +-- To change the direction of an '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. +-- +-- > 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 +{-# INLINE takingWhile #-} + +-- | Obtain a 'Fold' by dropping elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. +-- +-- > 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 +{-# INLINE droppingWhile #-} + +-------------------------- +-- Fold/Getter combinators +-------------------------- + +-- | +-- > foldMap = foldMapOf folded +-- +-- > foldMapOf = views +-- +-- > foldMapOf :: Getter a c -> (c -> r) -> a -> r +-- > foldMapOf :: Monoid r => Fold a c -> (c -> r) -> a -> r +-- > foldMapOf :: Lens a b c d -> (c -> r) -> a -> r +-- > foldMapOf :: Iso a b c d -> (c -> r) -> a -> r +-- > foldMapOf :: Monoid r => Traversal a b c d -> (c -> r) -> a -> r +foldMapOf :: Getting r a b c d -> (c -> r) -> a -> r +foldMapOf l f = runAccessor . l (Accessor . f) +{-# INLINE foldMapOf #-} + +-- | +-- > fold = foldOf folded +-- +-- > foldOf = view +-- +-- > foldOf :: Getter a m -> a -> m +-- > foldOf :: Monoid m => Fold a m -> a -> m +-- > foldOf :: Lens a b m d -> a -> m +-- > foldOf :: Iso a b m d -> a -> m +-- > foldOf :: Monoid m => Traversal a b m d -> a -> m +foldOf :: Getting c a b c d -> a -> c +foldOf l = runAccessor . l Accessor +{-# INLINE foldOf #-} + +-- | +-- Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. +-- +-- > foldr = foldrOf folded +-- +-- > foldrOf :: Getter a c -> (c -> e -> e) -> e -> a -> e +-- > foldrOf :: Fold a c -> (c -> e -> e) -> e -> a -> e +-- > foldrOf :: Lens a b c d -> (c -> e -> e) -> e -> a -> e +-- > foldrOf :: Iso a b c d -> (c -> e -> e) -> e -> a -> e +-- > foldrOf :: Traversal a b c d -> (c -> e -> e) -> e -> a -> e +foldrOf :: Getting (Endo e) a b c d -> (c -> e -> e) -> e -> a -> e +foldrOf l f z t = appEndo (foldMapOf l (Endo . f) t) z +{-# INLINE foldrOf #-} + +-- | +-- Left-associative fold of the parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. +-- +-- > foldl = foldlOf folded +-- +-- > foldlOf :: Getter a c -> (e -> c -> e) -> e -> a -> e +-- > foldlOf :: Fold a c -> (e -> c -> e) -> e -> a -> e +-- > foldlOf :: Lens a b c d -> (e -> c -> e) -> e -> a -> e +-- > foldlOf :: Iso a b c d -> (e -> c -> e) -> e -> a -> e +-- > foldlOf :: Traversal a b c d -> (e -> c -> e) -> e -> a -> e +foldlOf :: Getting (Dual (Endo e)) a b c d -> (e -> c -> e) -> e -> a -> e +foldlOf l f z t = appEndo (getDual (foldMapOf l (Dual . Endo . flip f) t)) z +{-# INLINE foldlOf #-} + +-- | +-- > toList = toListOf folded +-- +-- > toListOf :: Getter a c -> a -> [c] +-- > toListOf :: Fold a c -> a -> [c] +-- > toListOf :: Lens a b c d -> a -> [c] +-- > toListOf :: Iso a b c d -> a -> [c] +-- > toListOf :: Traversal a b c d -> a -> [c] +toListOf :: Getting [c] a b c d -> a -> [c] +toListOf l = foldMapOf l return +{-# INLINE toListOf #-} + +-- | +-- > and = andOf folded +-- +-- > andOf :: Getter a Bool -> a -> Bool +-- > andOf :: Fold a Bool -> a -> Bool +-- > andOf :: Lens a b Bool d -> a -> Bool +-- > andOf :: Iso a b Bool d -> a -> Bool +-- > andOf :: Traversl a b Bool d -> a -> Bool +andOf :: Getting All a b Bool d -> a -> Bool +andOf l = getAll . foldMapOf l All +{-# INLINE andOf #-} + +-- | +-- > or = orOf folded +-- +-- > orOf :: Getter a Bool -> a -> Bool +-- > orOf :: Fold a Bool -> a -> Bool +-- > orOf :: Lens a b Bool d -> a -> Bool +-- > orOf :: Iso a b Bool d -> a -> Bool +-- > orOf :: Traversal a b Bool d -> a -> Bool +orOf :: Getting Any a b Bool d -> a -> Bool +orOf l = getAny . foldMapOf l Any +{-# INLINE orOf #-} + +-- | +-- > any = anyOf folded +-- +-- > anyOf :: Getter a c -> (c -> Bool) -> a -> Bool +-- > anyOf :: Fold a c -> (c -> Bool) -> a -> Bool +-- > anyOf :: Lens a b c d -> (c -> Bool) -> a -> Bool +-- > anyOf :: Iso a b c d -> (c -> Bool) -> a -> Bool +-- > anyOf :: Traversal a b c d -> (c -> Bool) -> a -> Bool +anyOf :: Getting Any a b c d -> (c -> Bool) -> a -> Bool +anyOf l f = getAny . foldMapOf l (Any . f) +{-# INLINE anyOf #-} + +-- | +-- > all = allOf folded +-- +-- > allOf :: Getter a c -> (c -> Bool) -> a -> Bool +-- > allOf :: Fold a c -> (c -> Bool) -> a -> Bool +-- > allOf :: Lens a b c d -> (c -> Bool) -> a -> Bool +-- > allOf :: Iso a b c d -> (c -> Bool) -> a -> Bool +-- > allOf :: Traversal a b c d -> (c -> Bool) -> a -> Bool +allOf :: Getting All a b c d -> (c -> Bool) -> a -> Bool +allOf l f = getAll . foldMapOf l (All . f) +{-# INLINE allOf #-} + +-- | +-- > product = productOf folded +-- +-- > productOf :: Getter a c -> a -> c +-- > productOf :: Num c => Fold a c -> a -> c +-- > productOf :: Lens a b c d -> a -> c +-- > productOf :: Iso a b c d -> a -> c +-- > productOf :: Num c => Traversal a b c d -> a -> c +productOf :: Getting (Product c) a b c d -> a -> c +productOf l = getProduct . foldMapOf l Product +{-# INLINE productOf #-} + +-- | +-- > sum = sumOf folded +-- +-- > 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 +-- > sumOf :: Iso a b c d -> a -> c +-- > sumOf :: Num c => Traversal a b c d -> a -> c +sumOf :: Getting (Sum c) a b c d -> a -> c +sumOf l = getSum . foldMapOf l Sum +{-# INLINE sumOf #-} + +-- | +-- +-- When passed a 'Getter', 'traverseOf_' can work over a 'Functor'. +-- +-- When passed a 'Fold', 'traverseOf_' requires an 'Applicative'. +-- +-- > traverse_ = traverseOf_ folded +-- +-- > traverseOf_ _2 :: Functor f => (c -> f e) -> (c1, c) -> f () +-- > traverseOf_ 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 () +-- > traverseOf_ :: Applicative f => Fold a c -> (c -> f e) -> a -> f () +-- > traverseOf_ :: Functor f => Lens a b c d -> (c -> f e) -> a -> f () +-- > traverseOf_ :: Functor f => Iso a b c d -> (c -> f e) -> a -> f () +-- > traverseOf_ :: Applicative f => Traversal a b c d -> (c -> f e) -> a -> f () +traverseOf_ :: Functor f => Getting (Traversed f) a b c d -> (c -> f e) -> a -> f () +traverseOf_ l f = getTraversed . foldMapOf l (Traversed . void . f) +{-# INLINE traverseOf_ #-} + +-- | +-- > 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 () +-- > forOf_ :: Functor f => Lens a b c d -> a -> (c -> f e) -> f () +-- > forOf_ :: Functor f => Iso a b c d -> a -> (c -> f e) -> f () +-- > forOf_ :: Applicative f => Traversal a b c d -> a -> (c -> f e) -> f () +forOf_ :: Functor f => Getting (Traversed f) a b c d -> a -> (c -> f e) -> f () +forOf_ l a f = traverseOf_ l f a +{-# INLINE forOf_ #-} + +-- | +-- > sequenceA_ = sequenceAOf_ folded +-- +-- > sequenceAOf_ :: Functor f => Getter a (f ()) -> a -> f () +-- > sequenceAOf_ :: Applicative f => Fold a (f ()) -> a -> f () +-- > sequenceAOf_ :: Functor f => Lens a b (f ()) d -> a -> f () +-- > sequenceAOf_ :: Functor f => Iso a b (f ()) d -> a -> f () +-- > sequenceAOf_ :: Applicative f => Traversal a b (f ()) d -> a -> f () +sequenceAOf_ :: Functor f => Getting (Traversed f) a b (f ()) d -> a -> f () +sequenceAOf_ l = getTraversed . foldMapOf l (Traversed . void) +{-# INLINE sequenceAOf_ #-} + +-- | +-- > 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 () +-- > mapMOf_ :: Monad m => Lens a b c d -> (c -> m e) -> a -> m () +-- > mapMOf_ :: Monad m => Iso a b c d -> (c -> m e) -> a -> m () +-- > mapMOf_ :: Monad m => Traversal a b c d -> (c -> m e) -> a -> m () +mapMOf_ :: Monad m => Getting (Sequenced m) a b c d -> (c -> m e) -> a -> m () +mapMOf_ l f = getSequenced . foldMapOf l (Sequenced . liftM skip . f) +{-# INLINE mapMOf_ #-} + +skip :: a -> () +skip _ = () +{-# INLINE skip #-} + +-- | +-- > 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 () +-- > forMOf_ :: Monad m => Lens a b c d -> a -> (c -> m e) -> m () +-- > forMOf_ :: Monad m => Iso a b c d -> a -> (c -> m e) -> m () +-- > forMOf_ :: Monad m => Traversal a b c d -> a -> (c -> m e) -> m () +forMOf_ :: Monad m => Getting (Sequenced m) a b c d -> a -> (c -> m e) -> m () +forMOf_ l a f = mapMOf_ l f a +{-# INLINE forMOf_ #-} + +-- | +-- > sequence_ = sequenceOf_ folded +-- +-- > sequenceOf_ :: Monad m => Getter a (m b) -> a -> m () +-- > sequenceOf_ :: Monad m => Fold a (m b) -> a -> m () +-- > sequenceOf_ :: Monad m => Lens a b (m b) d -> a -> m () +-- > sequenceOf_ :: Monad m => Iso a b (m b) d -> a -> m () +-- > sequenceOf_ :: Monad m => Traversal a b (m b) d -> a -> m () +sequenceOf_ :: Monad m => Getting (Sequenced m) a b (m c) d -> a -> m () +sequenceOf_ l = getSequenced . foldMapOf l (Sequenced . liftM skip) +{-# INLINE sequenceOf_ #-} + +-- | The sum of a collection of actions, generalizing 'concatOf'. +-- +-- > asum = asumOf folded +-- +-- > asumOf :: Alternative f => Getter a c -> a -> f c +-- > asumOf :: Alternative f => Fold a c -> a -> f c +-- > asumOf :: Alternative f => Lens a b c d -> a -> f c +-- > asumOf :: Alternative f => Iso a b c d -> a -> f c +-- > asumOf :: Alternative f => Traversal a b c d -> a -> f c +asumOf :: Alternative f => Getting (Endo (f c)) a b (f c) d -> a -> f c +asumOf l = foldrOf l (<|>) Applicative.empty +{-# INLINE asumOf #-} + +-- | The sum of a collection of actions, generalizing 'concatOf'. +-- +-- > msum = msumOf folded +-- +-- > msumOf :: MonadPlus m => Getter a c -> a -> m c +-- > msumOf :: MonadPlus m => Fold a c -> a -> m c +-- > msumOf :: MonadPlus m => Lens a b c d -> a -> m c +-- > msumOf :: MonadPlus m => Iso a b c d -> a -> m c +-- > msumOf :: MonadPlus m => Traversal a b c d -> a -> m c +msumOf :: MonadPlus m => Getting (Endo (m c)) a b (m c) d -> a -> m c +msumOf l = foldrOf l mplus mzero +{-# INLINE msumOf #-} + +-- | +-- > elem = elemOf folded +-- +-- > elemOf :: Eq c => Getter a c -> c -> a -> Bool +-- > elemOf :: Eq c => Fold a c -> c -> a -> Bool +-- > elemOf :: Eq c => Lens a b c d -> c -> a -> Bool +-- > elemOf :: Eq c => Iso a b c d -> c -> a -> Bool +-- > elemOf :: Eq c => Traversal a b c d -> c -> a -> Bool +elemOf :: Eq c => Getting Any a b c d -> c -> a -> Bool +elemOf l = anyOf l . (==) +{-# INLINE elemOf #-} + +-- | +-- > notElem = notElemOf folded +-- +-- > notElemOf :: Eq c => Getter a c -> c -> a -> Bool +-- > notElemOf :: Eq c => Fold a c -> c -> a -> Bool +-- > notElemOf :: Eq c => Iso a b c d -> c -> a -> Bool +-- > notElemOf :: Eq c => Lens a b c d -> c -> a -> Bool +-- > notElemOf :: Eq c => Traversal a b c d -> c -> a -> Bool +notElemOf :: Eq c => Getting All a b c d -> c -> a -> Bool +notElemOf l = allOf l . (/=) +{-# INLINE notElemOf #-} + +-- | +-- > concatMap = concatMapOf folded +-- +-- > concatMapOf :: Getter a c -> (c -> [e]) -> a -> [e] +-- > concatMapOf :: Fold a c -> (c -> [e]) -> a -> [e] +-- > concatMapOf :: Lens a b c d -> (c -> [e]) -> a -> [e] +-- > concatMapOf :: Iso a b c d -> (c -> [e]) -> a -> [e] +-- > concatMapOf :: Traversal a b c d -> (c -> [e]) -> a -> [e] +concatMapOf :: Getting [e] a b c d -> (c -> [e]) -> a -> [e] +concatMapOf l ces a = runAccessor (l (Accessor . ces) a) +{-# INLINE concatMapOf #-} + +-- | +-- > concat = concatOf folded +-- +-- > concatOf :: Getter a [e] -> a -> [e] +-- > concatOf :: Fold a [e] -> a -> [e] +-- > concatOf :: Iso a b [e] d -> a -> [e] +-- > concatOf :: Lens a b [e] d -> a -> [e] +-- > concatOf :: Traversal a b [e] d -> a -> [e] +concatOf :: Getting [e] a b [e] d -> a -> [e] +concatOf = view +{-# INLINE concatOf #-} + +-- | +-- Note: this can be rather inefficient for large containers. +-- +-- > length = lengthOf folded +-- +-- > lengthOf _1 :: (a, b) -> Int +-- > lengthOf _1 = 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 +-- > lengthOf :: Iso a b c d -> a -> Int +-- > lengthOf :: Traversal a b c d -> a -> Int +lengthOf :: Getting (Sum Int) a b c d -> a -> Int +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'. +-- +-- > listToMaybe . toList = headOf folded +-- +-- > headOf :: Getter a c -> a -> Maybe c +-- > headOf :: Fold a c -> a -> Maybe c +-- > headOf :: Lens a b c d -> a -> Maybe c +-- > headOf :: Iso a b c d -> a -> Maybe c +-- > headOf :: Traversal a b c d -> a -> Maybe c +headOf :: Getting (First c) a b c d -> a -> Maybe c +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'. +-- +-- > lastOf :: Getter a c -> a -> Maybe c +-- > lastOf :: Fold a c -> a -> Maybe c +-- > lastOf :: Lens a b c d -> a -> Maybe c +-- > lastOf :: Iso a b c d -> a -> Maybe c +-- > lastOf :: Traversal a b c d -> a -> Maybe c +lastOf :: Getting (Last c) a b c d -> a -> Maybe c +lastOf l = getLast . foldMapOf l (Last . Just) +{-# INLINE lastOf #-} + +-- | +-- Returns 'True' if this 'Fold' or 'Traversal' has no targets in the given container. +-- +-- Note: nullOf on a valid 'Iso', 'Lens' or 'Getter' should always return 'False' +-- +-- > 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 :: Getter a c -> a -> Bool +-- > nullOf :: Fold a c -> a -> Bool +-- > nullOf :: Iso a b c d -> a -> Bool +-- > nullOf :: Lens a b c d -> a -> Bool +-- > nullOf :: Traversal a b c d -> a -> Bool +nullOf :: Getting All a b c d -> a -> Bool +nullOf l = getAll . foldMapOf l (\_ -> All False) +{-# INLINE nullOf #-} + +-- | +-- Obtain the maximum element (if any) targeted by a 'Fold' or 'Traversal' +-- +-- Note: maximumOf on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. +-- +-- > maximum = fromMaybe (error "empty") . maximumOf folded +-- +-- > maximumOf :: Getter a c -> a -> Maybe c +-- > maximumOf :: Ord c => Fold a c -> a -> Maybe c +-- > maximumOf :: Iso a b c d -> a -> Maybe c +-- > maximumOf :: Lens a b c d -> a -> Maybe c +-- > maximumOf :: Ord c => Traversal a b c d -> a -> Maybe c +maximumOf :: Getting (Max c) a b c d -> a -> Maybe c +maximumOf l = getMax . foldMapOf l Max +{-# INLINE maximumOf #-} + +-- | +-- Obtain the minimum element (if any) targeted by a 'Fold' or 'Traversal' +-- +-- Note: minimumOf on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. +-- +-- > minimum = fromMaybe (error "empty") . minimumOf folded +-- +-- > minimumOf :: Getter a c -> a -> Maybe c +-- > minimumOf :: Ord c => Fold a c -> a -> Maybe c +-- > minimumOf :: Iso a b c d -> a -> Maybe c +-- > minimumOf :: Lens a b c d -> a -> Maybe c +-- > minimumOf :: Ord c => Traversal a b c d -> a -> Maybe c +minimumOf :: Getting (Min c) a b c d -> a -> Maybe c +minimumOf l = getMin . foldMapOf l Min +{-# INLINE minimumOf #-} + +-- | +-- Obtain the maximum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso', +-- or 'Getter' according to a user supplied ordering. +-- +-- > maximumBy cmp = 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 +-- > maximumByOf :: Iso a b c d -> (c -> c -> Ordering) -> a -> Maybe c +-- > maximumByOf :: Lens a b c d -> (c -> c -> Ordering) -> a -> Maybe c +-- > maximumByOf :: Traversal a b c d -> (c -> c -> Ordering) -> a -> Maybe c +maximumByOf :: Getting (Endo (Maybe c)) a b c d -> (c -> c -> Ordering) -> a -> Maybe c +maximumByOf l cmp = foldrOf l step Nothing where + step a Nothing = Just a + step a (Just b) = Just (if cmp a b == GT then a else b) +{-# INLINE maximumByOf #-} + +-- | +-- Obtain the minimum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso' +-- or 'Getter' according to a user supplied ordering. +-- +-- > minimumBy cmp = fromMaybe (error "empty") . minimumByOf folded cmp +-- +-- > minimumByOf :: Getter a c -> (c -> c -> Ordering) -> a -> Maybe c +-- > minimumByOf :: Fold a c -> (c -> c -> Ordering) -> a -> Maybe c +-- > minimumByOf :: Iso a b c d -> (c -> c -> Ordering) -> a -> Maybe c +-- > minimumByOf :: Lens a b c d -> (c -> c -> Ordering) -> a -> Maybe c +-- > minimumByOf :: Traversal a b c d -> (c -> c -> Ordering) -> a -> Maybe c +minimumByOf :: Getting (Endo (Maybe c)) a b c d -> (c -> c -> Ordering) -> a -> Maybe c +minimumByOf l cmp = foldrOf l step Nothing where + step a Nothing = Just a + 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), +-- a predicate and a structure and returns the leftmost element of the structure +-- matching the predicate, or 'Nothing' if there is no such element. +-- +-- > findOf :: Getter a c -> (c -> Bool) -> a -> Maybe c +-- > findOf :: Fold a c -> (c -> Bool) -> a -> Maybe c +-- > findOf :: Iso a b c d -> (c -> Bool) -> a -> Maybe c +-- > findOf :: Lens a b c d -> (c -> Bool) -> a -> Maybe c +-- > findOf :: Traversal a b c d -> (c -> Bool) -> a -> Maybe c +findOf :: Getting (First c) a b c d -> (c -> Bool) -> a -> Maybe c +findOf l p = getFirst . foldMapOf l step where + step c + | p c = First (Just c) + | otherwise = First Nothing +{-# INLINE findOf #-} + +-- | +-- A variant of 'foldrOf' that has no base case and thus may only be applied +-- to lenses and structures such that the lens views at least one element of +-- the structure. +-- +-- > foldr1Of l f = Prelude.foldr1 f . toListOf l +-- +-- > foldr1 = foldr1Of folded +-- +-- > foldr1Of :: Getter a c -> (c -> c -> c) -> a -> c +-- > foldr1Of :: Fold a c -> (c -> c -> c) -> a -> c +-- > foldr1Of :: Iso a b c d -> (c -> c -> c) -> a -> c +-- > foldr1Of :: Lens a b c d -> (c -> c -> c) -> a -> c +-- > foldr1Of :: Traversal a b c d -> (c -> c -> c) -> a -> c +foldr1Of :: Getting (Endo (Maybe c)) a b c d -> (c -> c -> c) -> a -> c +foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") + (foldrOf l mf Nothing xs) where + mf x Nothing = Just x + mf x (Just y) = Just (f x y) +{-# INLINE foldr1Of #-} + +-- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and strutures such +-- that the lens views at least one element of the structure. +-- +-- > foldl1Of l f = Prelude.foldl1Of l f . toList +-- +-- > foldl1 = foldl1Of folded +-- +-- > foldl1Of :: Getter a c -> (c -> c -> c) -> a -> c +-- > foldl1Of :: Fold a c -> (c -> c -> c) -> a -> c +-- > foldl1Of :: Iso a b c d -> (c -> c -> c) -> a -> c +-- > foldl1Of :: Lens a b c d -> (c -> c -> c) -> a -> c +-- > foldl1Of :: Traversal a b c d -> (c -> c -> c) -> a -> c +foldl1Of :: Getting (Dual (Endo (Maybe c))) a b c d -> (c -> c -> c) -> a -> c +foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where + mf Nothing y = Just y + mf (Just x) y = Just (f x y) +{-# INLINE foldl1Of #-} + +-- | Strictly fold right over the elements of a structure. +-- +-- > foldr' = foldrOf' folded +-- +-- > foldrOf' :: Getter a c -> (c -> e -> e) -> e -> a -> e +-- > foldrOf' :: Fold a c -> (c -> e -> e) -> e -> a -> e +-- > foldrOf' :: Iso a b c d -> (c -> e -> e) -> e -> a -> e +-- > foldrOf' :: Lens a b c d -> (c -> e -> e) -> e -> a -> e +-- > foldrOf' :: Traversal a b c d -> (c -> e -> e) -> e -> a -> e +foldrOf' :: Getting (Dual (Endo (e -> e))) a b c d -> (c -> e -> e) -> e -> a -> e +foldrOf' l f z0 xs = foldlOf l f' id xs z0 + where f' k x z = k $! f x z +{-# INLINE foldrOf' #-} + +-- | Fold over the elements of a structure, associating to the left, but strictly. +-- +-- > foldl' = foldlOf' folded +-- +-- > foldlOf' :: Getter a c -> (e -> c -> e) -> e -> a -> e +-- > foldlOf' :: Fold a c -> (e -> c -> e) -> e -> a -> e +-- > foldlOf' :: Iso a b c d -> (e -> c -> e) -> e -> a -> e +-- > foldlOf' :: Lens a b c d -> (e -> c -> e) -> e -> a -> e +-- > foldlOf' :: Traversal a b c d -> (e -> c -> e) -> e -> a -> e +foldlOf' :: Getting (Endo (e -> e)) a b c d -> (e -> c -> e) -> e -> a -> e +foldlOf' l f z0 xs = foldrOf l f' id xs z0 + where f' x k z = k $! f z x +{-# INLINE foldlOf' #-} + +-- | Monadic fold over the elements of a structure, associating to the right, +-- i.e. from right to left. +-- +-- > 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 +-- > foldrMOf :: Monad m => Iso a b c d -> (c -> e -> m e) -> e -> a -> m e +-- > foldrMOf :: Monad m => Lens a b c d -> (c -> e -> m e) -> e -> a -> m e +-- > foldrMOf :: Monad m => Traversal a b c d -> (c -> e -> m e) -> e -> a -> m e +foldrMOf :: Monad m + => Getting (Dual (Endo (e -> m e))) a b c d + -> (c -> e -> m e) -> e -> a -> m e +foldrMOf l f z0 xs = foldlOf l f' return xs z0 + where f' k x z = f x z >>= k +{-# INLINE foldrMOf #-} + +-- | Monadic fold over the elements of a structure, associating to the left, +-- i.e. from left to right. +-- +-- > 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 +-- > foldlMOf :: Monad m => Iso a b c d -> (e -> c -> m e) -> e -> a -> m e +-- > foldlMOf :: Monad m => Lens a b c d -> (e -> c -> m e) -> e -> a -> m e +-- > foldlMOf :: Monad m => Traversal a b c d -> (e -> c -> m e) -> e -> a -> m e +foldlMOf :: Monad m + => Getting (Endo (e -> m e)) a b c d + -> (e -> c -> m e) -> e -> a -> m e +foldlMOf l f z0 xs = foldrOf l f' return xs z0 + where f' x k z = f z x >>= k +{-# INLINE foldlMOf #-} diff --git a/src/Control/Lens/Getter.hs b/src/Control/Lens/Getter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Getter.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Getter +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +-- +-- 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 +-- +-- 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 +-- +-- 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 +-- +-- 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. +-- +-- Since it is only a function, every 'Getter' obviously only retrieves a single value for a given +-- input. +-- +---------------------------------------------------------------------------- +module Control.Lens.Getter + ( + -- * Getters + Getter + , Getting + , Gettable(..) + , Accessor(..) + -- * Building Getters + , to + -- * Combinators for Getters and Folds + , (^.), (^$) + , view + , views + , use + , uses + , query + , queries + ) where + +import Control.Applicative +import Control.Applicative.Backwards +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 ^$ + +--------------- +-- Getters +--------------- + +-- | 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. +-- +-- Moreover, a 'Getter' can be used directly as a 'Fold', since it just ignores the 'Monoid'. +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 +-- +-- >>> (0, -5)^._2.to abs +-- 5 +to :: (a -> c) -> Getter a c +to f g = coerce . g . f +{-# INLINE to #-} + +-- | +-- Most 'Getter' combinators are able to be used with both a 'Getter' or a '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 +-- 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'. +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 +-- and so we can get nicer error messages +class Functor f => Gettable f where + coerce :: f a -> f b + +instance Gettable (Const r) where + coerce (Const m) = Const m + +instance Gettable f => Gettable (Backwards f) where + coerce = Backwards . coerce . forwards + +instance (Functor f, Gettable g) => Gettable (Compose f g) where + coerce = Compose . fmap coerce . getCompose + +instance Gettable f => Gettable (ElementOf f) where + coerce (ElementOf m) = ElementOf $ \i -> case m i of + Searching _ _ -> NotFound "coerced while searching" + 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'. +newtype Accessor r a = Accessor { runAccessor :: r } + +instance Functor (Accessor r) where + fmap _ (Accessor m) = Accessor m + +instance Gettable (Accessor r) where + coerce (Accessor m) = Accessor m + +instance Monoid r => Applicative (Accessor r) where + pure _ = Accessor mempty + Accessor a <*> Accessor b = Accessor (mappend a b) + +------------------------------- +-- 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. +-- +-- It may be useful to think of 'view' as having these more restrictive signatures: +-- +-- > view . to = id +-- +-- >>> 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 :: 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'. +-- +-- It may be useful to think of 'views' as having these more restrictive signatures: +-- +-- >>> 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 :: 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. +-- +-- This is the same operation as 'view', only infix. +-- +-- >>> _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 +(^$) :: 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. +-- +-- 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..) +-- +-- >>> ((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 -> Getting c a b c d -> c +a ^. l = runAccessor (l Accessor a) +{-# INLINE (^.) #-} + +------------------------------------------------------------------------------ +-- MonadReader +------------------------------------------------------------------------------ + +-- | +-- 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 :: MonadReader a m => ((c -> Const c d) -> a -> Const c b) -> 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 +-- +-- > queries :: MonadReader a m => ((c -> Const e d) -> a -> Const e b) -> (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 #-} + +------------------------------------------------------------------------------ +-- MonadState +------------------------------------------------------------------------------ + +-- | +-- 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 :: 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 => 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. +-- +-- > 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 => 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 new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Indexed.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Indexed +-- 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.Indexed + ( + -- * Indexed Functions + Indexed(..) + , Indexable + , Index(..) + , (.@) + , composeWithIndex + , reindex + + -- * Indexed Folds + , IndexedFold + , foldMapWithIndexOf + , foldrWithIndexOf + + -- * Indexed Traversals + , IndexedTraversal + , traverseWithIndexOf + , mapMWithIndexOf + + -- * Indexed Setter + , IndexedSetter + , mapWithIndexOf + , (%@) + + -- * Simple + , SimpleIndexedTraversal + , SimpleIndexedSetter + ) where + +import Control.Applicative +import Control.Lens.Type +import Control.Lens.Getter +import Control.Lens.Setter +import Data.Monoid + +-- | Permit overloading of function application for things that also admit a notion of a key or index. + +-- | Provides overloading for indexed functions. +class Indexed i k where + -- | Build a function from an indexed function + index :: ((i -> a) -> b) -> k a b + +-- | Type alias for passing around polymorphic indexed functions. +type Indexable i a b = forall k. Indexed i k => k a b + +instance Indexed i (->) where + index f = f . const + {-# INLINE index #-} + +-- | A function with access to a index. This constructor may be useful when you need to store +-- a 'HasIndex'. +newtype Index i a b = Index { withIndex :: (i -> a) -> b } + +-- | Using an equality witness to avoid potential overlapping instances +-- and aid dispatch. +instance i ~ j => Indexed i (Index j) where + index = Index + {-# INLINE index #-} + +-- | 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 #-} + +infixr 9 .@ +-- | Composition of indexed functions +(.@) :: Indexed (i, j) k => Index i b c -> Index j a b -> k a c +f .@ g = composeWithIndex (,) 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 with a user supplied function for combining indexs +composeWithIndex :: Indexed k r => (i -> j -> k) -> Index i b c -> Index j a b -> r a c +composeWithIndex ijk (Index ibc) (Index jab) = index $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j) +{-# INLINE composeWithIndex #-} +{-# SPECIALIZE composeWithIndex :: (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) + +-- | +-- +-- > foldMapWithIndexOf :: Monoid m => IndexedFold i a c -> (i -> c -> m) -> a -> m +-- > foldMapWithIndexOf :: Monoid m => IndexedTraversal i a b c d -> (i -> c -> m) -> a -> m +foldMapWithIndexOf :: IndexedFolding i m a b c d -> (i -> c -> m) -> a -> m +foldMapWithIndexOf l f = runAccessor . withIndex l (\i -> Accessor . f i) +{-# INLINE foldMapWithIndexOf #-} + +-- | +-- Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. +-- +-- > foldrWithIndexOf :: IndexedFold i a c -> (i -> c -> e -> e) -> e -> a -> e +-- > foldrWithIndexOf :: IndexedTraversal i a b c d -> (i -> c -> e -> e) -> e -> a -> e +foldrWithIndexOf :: IndexedFolding i (Endo e) a b c d -> (i -> c -> e -> e) -> e -> a -> e +foldrWithIndexOf l f z t = appEndo (foldMapWithIndexOf l (\i -> Endo . f i) t) z +{-# INLINE foldrWithIndexOf #-} + +------------------------------------------------------------------------------ +-- 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 + +-- | +-- > traverseWithIndexOf :: IndexedTraversal i a b c d -> (i -> c -> f d) -> a -> f b +traverseWithIndexOf :: Overloaded (Index i) f a b c d -> (i -> c -> f d) -> a -> f b +traverseWithIndexOf = withIndex +{-# INLINE traverseWithIndexOf #-} + +-- | 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. +-- +-- > mapMWithIndexOf :: Monad m => IndexedTraversal a b c d -> (i -> c -> m d) -> a -> m b +mapMWithIndexOf :: Overloaded (Index i) (WrappedMonad m) a b c d -> (i -> c -> m d) -> a -> m b +mapMWithIndexOf l f = unwrapMonad . withIndex l (\i -> WrapMonad . f i) +{-# INLINE mapMWithIndexOf #-} + +-- | Every indexed Setter 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 +-- +-- > mapWithIndexOf :: IndexedSetter i a b c d -> (i -> c -> d) -> a -> b +mapWithIndexOf :: Overloaded (Index i) Mutator a b c d -> (i -> c -> d) -> a -> b +mapWithIndexOf l f = runMutator . withIndex l (\i -> Mutator . f i) + +infixr 4 %@ + +-- | > (%@) = mapWithIndexOf +(%@) :: Overloaded (Index i) Mutator a b c d -> (i -> c -> d) -> a -> b +l %@ f = runMutator . withIndex l (\i -> Mutator . f i) + 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 @@ -19,7 +19,7 @@ IndexedStore(..) , Focusing(..) , Traversed(..) - , Action(..) + , Sequenced(..) , AppliedState(..) , Min(..) , getMin @@ -86,11 +86,11 @@ Traversed ma `mappend` Traversed mb = Traversed (ma *> mb) -- | Used internally by 'mapM_' and the like. -newtype Action m = Action { getAction :: m () } +newtype Sequenced m = Sequenced { getSequenced :: m () } -instance Monad m => Monoid (Action m) where - mempty = Action (return ()) - Action ma `mappend` Action mb = Action (ma >> mb) +instance Monad m => Monoid (Sequenced m) where + mempty = Sequenced (return ()) + Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb) -- | Used for 'minimumOf' data Min a = NoMin | Min a @@ -124,10 +124,12 @@ data ElementOfResult f a = Searching {-# UNPACK #-} !Int a | Found {-# UNPACK #-} !Int (f a) + | NotFound String instance Functor f => Functor (ElementOfResult f) where fmap f (Searching i a) = Searching i (f a) 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 } @@ -135,15 +137,18 @@ instance Functor f => Functor (ElementOf f) where fmap f (ElementOf m) = ElementOf $ \i -> case m i of Searching j a -> Searching j (f a) - Found j as -> Found j (fmap f as) + Found j as -> Found j (fmap f as) + NotFound e -> NotFound e instance Functor f => Applicative (ElementOf f) where pure a = ElementOf $ \i -> Searching i a ElementOf mf <*> ElementOf ma = ElementOf $ \i -> case mf i of Found j ff -> case ma j of - Found _ _ -> error "elementOf: found multiple results" + Found _ _ -> NotFound "multiple results" Searching k a -> Found k (fmap ($a) ff) + NotFound e -> NotFound e Searching j f -> case ma j of - Found k as -> Found k (fmap f as) + Found k as -> Found k (fmap f as) Searching k a -> Searching k (f a) - + NotFound e -> NotFound e + NotFound e -> NotFound e diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Iso.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Iso +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +---------------------------------------------------------------------------- +module Control.Lens.Iso + ( + -- * Isomorphisms + Isomorphic(..) + , Isomorphism(..) + , iso + , isos + , from + , via + , Iso + , SimpleIso + , _const + , identity + ) where + +import Control.Applicative +import Control.Category +import Data.Functor.Identity +import Data.Typeable +import Prelude hiding ((.),id) + +---------------------------------------------------------------------------- +-- Isomorphism Implementation Details +----------------------------------------------------------------------------- + +-- | Used to provide overloading of isomorphism application +-- +-- This is a 'Category' with a canonical mapping to it from the +-- category of isomorphisms over Haskell types. +class Category k => Isomorphic k where + -- | Build this morphism out of an isomorphism + -- + -- The intention is that by using 'isomorphic', you can supply both halves of an + -- isomorphism, but k can be instantiated to (->), so you can freely use + -- the resulting isomorphism as a function. + isomorphic :: (a -> b) -> (b -> a) -> k a b + + -- | Map a morphism in the target category using an isomorphism between morphisms + -- in Hask. + isomap :: ((a -> b) -> c -> d) -> ((b -> a) -> d -> c) -> k a b -> k c d + +instance Isomorphic (->) where + isomorphic = const + {-# INLINE isomorphic #-} + isomap = const + {-# INLINE isomap #-} + +-- | A concrete data type for isomorphisms. +-- +-- This lets you place an isomorphism inside a container without using @ImpredicativeTypes@. +data Isomorphism a b = Isomorphism (a -> b) (b -> a) + deriving Typeable + +instance Category Isomorphism where + id = Isomorphism id id + {-# INLINE id #-} + Isomorphism bc cb . Isomorphism ab ba = Isomorphism (bc . ab) (ba . cb) + {-# INLINE (.) #-} + +instance Isomorphic Isomorphism where + isomorphic = Isomorphism + {-# INLINE isomorphic #-} + isomap abcd badc (Isomorphism ab ba) = Isomorphism (abcd ab) (badc ba) + {-# INLINE isomap #-} + +-- | Invert an isomorphism. +-- +-- Note to compose an isomorphism and receive an isomorphism in turn you'll need to use +-- 'Control.Category.Category' +-- +-- > from (from l) = l +-- +-- If you imported 'Control.Category.(.)', then: +-- +-- > from l . from r = from (r . l) +-- +-- > from :: (a :~> b) -> (b :~> a) +from :: Isomorphic k => Isomorphism a b -> k b a +from (Isomorphism a b) = isomorphic b a +{-# INLINE from #-} +{-# SPECIALIZE from :: Isomorphism a b -> b -> a #-} +{-# SPECIALIZE from :: Isomorphism a b -> Isomorphism b a #-} + +-- | +-- > via :: Isomorphism a b -> (a :~> b) +via :: Isomorphic k => Isomorphism a b -> k a b +via (Isomorphism a b) = isomorphic a b +{-# INLINE via #-} +{-# SPECIALIZE via :: Isomorphism a b -> a -> b #-} +{-# SPECIALIZE via :: Isomorphism a b -> Isomorphism a b #-} + +----------------------------------------------------------------------------- +-- Isomorphisms families as Lenses +----------------------------------------------------------------------------- + +-- | Isomorphim families can be composed with other lenses using either' (.)' and 'id' +-- from the Prelude or from Control.Category. However, if you compose them +-- with each other using '(.)' from the Prelude, they will be dumbed down to a +-- mere 'Lens'. +-- +-- > import Control.Category +-- > import Prelude hiding ((.),id) +-- +-- > type Iso a b c d = forall k f. (Isomorphic k, Functor f) => Overloaded k f a b c d +type Iso a b c d = forall k f. (Isomorphic k, Functor f) => k (c -> f d) (a -> f b) + +-- | > type SimpleIso a b = Simple Iso a b +type SimpleIso a b = Iso a a b b + +-- | Build an isomorphism family from two pairs of inverse functions +-- +-- > isos :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Iso a b c d +isos :: (Isomorphic k, Functor f) => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> k (c -> f d) (a -> f b) +isos ac ca bd db = isomorphic + (\cfd a -> db <$> cfd (ac a)) + (\afb c -> bd <$> afb (ca c)) +{-# INLINE isos #-} +{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> (c -> f d) -> a -> f b #-} +{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Isomorphism (c -> f d) (a -> f b) #-} + +-- | Build a simple isomorphism from a pair of inverse functions +-- +-- > iso :: (a -> b) -> (b -> a) -> Simple Iso a b +iso :: (Isomorphic k, Functor f) => (a -> b) -> (b -> a) -> k (b -> f b) (a -> f a) +iso ab ba = isos ab ba ab ba +{-# INLINE iso #-} +{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> (b -> f b) -> a -> f a #-} +{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> Isomorphism (b -> f b) (a -> f a) #-} + +----------------------------------------------------------------------------- +-- Isomorphisms +----------------------------------------------------------------------------- + +-- | This isomorphism can be used to wrap or unwrap a value in 'Identity'. +-- +-- > x^.identity = Identity x +-- > Identity x^.from identity = x +identity :: Iso a b (Identity a) (Identity b) +identity = isos Identity runIdentity Identity runIdentity +{-# INLINE identity #-} + +-- | This isomorphism can be used to wrap or unwrap a value in 'Const' +-- +-- > x^._const = Const x +-- > Const x^.from _const = x +_const :: Iso a b (Const a c) (Const b d) +_const = isos Const getConst Const getConst +{-# INLINE _const #-} 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 @@ -1,5 +1,4 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Representable @@ -19,8 +18,6 @@ -- Consider the following example. -- -- > import Control.Lens --- > import Control.Lens.Representable --- > import Control.Lens.TH -- > import Data.Distributive -- -- > data Pair a = Pair { _x :: a, _y :: a } @@ -57,8 +54,8 @@ , bindRep , distributeRep -- * Wrapped Representations - , Key(..) - , keys + , Path(..) + , paths , tabulated -- * Traversal with representation , mapWithRep @@ -73,8 +70,9 @@ ) where import Control.Applicative -import Control.Isomorphic -import Control.Lens +import Control.Lens.Iso +import Control.Lens.Type +import Control.Lens.Getter import Data.Foldable as Foldable import Data.Functor.Identity import Data.Monoid @@ -184,25 +182,25 @@ {-# INLINE distributeRep #-} ----------------------------------------------------------------------------- --- Keys +-- Paths ----------------------------------------------------------------------------- -- | Sometimes you need to store a path lens into a container, but at least -- at this time, impredicative polymorphism in GHC is somewhat lacking. -- -- This type provides a way to, say, store a list of polymorphic lenses. -newtype Key f = Key { turn :: Rep f } +newtype Path f = Path { walk :: Rep f } -- | A 'Representable' 'Functor' has a fixed shape. This fills each position --- in it with a 'Key' -keys :: Representable f => f (Key f) -keys = rep Key -{-# INLINE keys #-} +-- in it with a 'Path' +paths :: Representable f => f (Path f) +paths = rep Path +{-# INLINE paths #-} -- | A version of 'rep' that is an isomorphism. Predicativity requires that -- we wrap the 'Rep' as a 'Key', however. -tabulated :: Representable f => (Key f -> a) :~> f a -tabulated = isomorphic (\f -> rep (f . Key)) (\fa key -> view (turn key) fa) +tabulated :: (Isomorphic k, Representable f) => k (Path f -> a) (f a) +tabulated = isomorphic (\f -> rep (f . Path)) (\fa path -> view (walk path) fa) {-# INLINE tabulated #-} ----------------------------------------------------------------------------- diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Setter.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Setter +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- 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 +-- +-- > type Setter a b c d = (c -> Identity d) -> a -> Identity b +-- +-- Every '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 '(<$)'. +---------------------------------------------------------------------------- +module Control.Lens.Setter + ( + -- * Setters + Setter + , Settable(..) + -- * Consuming Setters + , Setting + , Mutator(..) + -- * Building Setters + , sets + -- * Common Setters + , mapped + -- * Functional Combinators + , adjust + , mapOf + , set + , (.~), (%~) + , (+~), (-~), (*~), (//~), (^~), (^^~), (**~), (||~), (&&~), (<>~) + -- * State Combinators + , (.=), (%=) + , (+=), (-=), (*=), (//=), (^=), (^^=), (**=), (||=), (&&=), (<>=) + , (<~) + -- * MonadWriter + , whisper + -- * Simplicity + , SimpleSetter + , SimpleSetting + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Monad.State.Class as State +import Control.Monad.Writer.Class as Writer +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Monoid + +infixr 4 .~, +~, *~, -~, //~, ^~, ^^~, **~, &&~, ||~, %~, <>~ +infix 4 .=, +=, *=, -=, //=, ^=, ^^=, **=, &&=, ||=, %=, <>= + +infixr 2 <~ + + +------------------------------------------------------------------------------ +-- Setters +------------------------------------------------------------------------------ + +-- | +-- The only 'Lens'-like law that can apply to a 'Setter' @l@ is that +-- +-- > set l c (set l b a) = set l c a +-- +-- You can't 'view' a 'Setter' in general, so the other two laws are irrelevant. +-- +-- However, two functor laws apply to a 'Setter' +-- +-- > adjust l id = id +-- > 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) +-- +-- You can compose a 'Setter' with a 'Lens' or a '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 + +-- | +-- Running a Setter instantiates it to a concrete type. +-- +-- When consuming a setter, use this type. +type Setting a b c d = (c -> Mutator d) -> a -> Mutator b + +-- | +-- > 'SimpleSetter' = 'Simple' 'Setter' +type SimpleSetter a b = Setter a a b b + +-- | +-- > 'SimpleSetting' m = 'Simple' 'Setting' +type SimpleSetting a b = Setting a a b b + +----------------------------------------------------------------------------- +-- Settables & Mutators +----------------------------------------------------------------------------- + +-- | Anything Settable must be isomorphic to the Identity Functor. +class Applicative f => Settable f where + run :: f a -> a + +instance Settable Identity where + run = runIdentity + +instance Settable f => Settable (Backwards f) where + run = run . forwards + +instance (Settable f, Settable g) => Settable (Compose f g) where + run = run . run . getCompose + +-- | 'Mutator' is just a renamed 'Identity' functor to give better error +-- messages when someone attempts to use a getter as a setter. +newtype Mutator a = Mutator { runMutator :: a } + +instance Functor Mutator where + fmap f (Mutator a) = Mutator (f a) + +instance Applicative Mutator where + pure = Mutator + Mutator f <*> Mutator a = Mutator (f a) + +instance Settable Mutator where + run = runMutator + +----------------------------------------------------------------------------- +-- Setters +----------------------------------------------------------------------------- + +-- | This setter can be used to map over all of the values in a 'Functor'. +-- +-- > fmap = adjust mapped +-- > fmapDefault = adjust traverse +-- > (<$) = set mapped +mapped :: Functor f => Setter (f a) (f b) a b +mapped = sets fmap +{-# INLINE mapped #-} + +-- | Build a Setter from a map-like function. +-- +-- Your supplied function @f@ is required to satisfy: +-- +-- > f id = id +-- > f g . f h = f (g . h) +-- +-- Equational reasoning: +-- +-- > sets . adjust = id +-- > 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) +{-# INLINE sets #-} + +----------------------------------------------------------------------------- +-- Using Setters +----------------------------------------------------------------------------- + +-- | Modify the target of a 'Lens' or all the targets of a 'Setter' or 'Traversal' +-- with a function. +-- +-- > fmap = adjust mapped +-- > fmapDefault = adjust traverse +-- +-- > sets . adjust = id +-- > adjust . sets = id +-- +-- > adjust :: Setter a b c d -> (c -> d) -> a -> b +-- +-- Another way to view 'adjust' is to say that it transformers a 'Setter' into a +-- \"semantic editor combinator\". +adjust :: Setting a b c d -> (c -> d) -> a -> b +adjust l f = runMutator . l (Mutator . f) +{-# INLINE adjust #-} + +-- | Modify the target of a 'Lens' or all the targets of a 'Setter' or 'Traversal' +-- with a function. This is an alias for adjust that is provided for consistency. +-- +-- > mapOf = adjust +-- +-- > fmap = mapOf mapped +-- > fmapDefault = mapOf traverse +-- +-- > sets . mapOf = id +-- > 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 +-- > mapOf :: Traversal a b c d -> (c -> d) -> a -> b +mapOf :: Setting a b c d -> (c -> d) -> a -> b +mapOf = adjust +{-# INLINE mapOf #-} + +-- | Replace the target of a 'Lens' or all of the targets of a 'Setter' +-- or 'Traversal' with a constant value. +-- +-- > (<$) = set mapped +-- +-- > set :: Setter a b c d -> d -> a -> b +-- > set :: Iso a b c d -> d -> a -> b +-- > set :: Lens a b c d -> d -> a -> b +-- > set :: Traversal a b c d -> d -> a -> b +set :: Setting a b c d -> d -> a -> b +set l d = runMutator . l (\_ -> Mutator d) +{-# INLINE set #-} + +-- | Modifies the target of a 'Lens' or all of the targets of a 'Setter' or +-- 'Traversal' with a user supplied function. +-- +-- This is an infix version of 'adjust' +-- +-- > fmap f = mapped %~ f +-- > fmapDefault f = traverse %~ f +-- +-- > ghci> _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 +-- > (%~) :: Traversal a b c d -> (c -> d) -> a -> b +(%~) :: Setting a b c d -> (c -> d) -> a -> b +(%~) = adjust +{-# INLINE (%~) #-} + +-- | Replace the target of a 'Lens' or all of the targets of a 'Setter' +-- or 'Traversal' with a constant value. +-- +-- This is an infix version of 'set', provided for consistency with '(.=)' +-- +-- +-- > f <$ a = mapped .~ f $ a +-- +-- > ghci> bitAt 0 .~ True $ 0 +-- > 1 +-- +-- > (.~) :: Setter a b c d -> d -> a -> b +-- > (.~) :: Iso a b c d -> d -> a -> b +-- > (.~) :: Lens a b c d -> d -> a -> b +-- > (.~) :: Traversal a b c d -> d -> a -> b +(.~) :: Setting a b c d -> d -> a -> b +(.~) = set +{-# INLINE (.~) #-} + +-- | Increment the target(s) of a numerically valued 'Lens', Setter' or 'Traversal' +-- +-- > ghci> _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 'Lens', 'Iso', 'Setter' or 'Traversal' +-- +-- >>> _2 *~ 4 $ (1,2) +-- (1,8) +(*~) :: Num c => Setting a b c c -> c -> a -> b +l *~ n = adjust l (* n) +{-# INLINE (*~) #-} + +-- | Decrement the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal' +-- +-- >>> _1 -~ 2 $ (1,2) +-- (-1,2) +(-~) :: Num c => Setting a b c c -> c -> a -> b +l -~ n = adjust l (subtract n) +{-# INLINE (-~) #-} + +-- | Divide the target(s) of a numerically valued 'Lens', 'Iso', 'Setter' or 'Traversal' +(//~) :: Fractional c => Setting a b c c -> c -> a -> b +l //~ n = adjust l (/ n) + +-- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to a non-negative integral power +-- +-- >>> _2 ^~ 2 $ (1,3) +-- (1,9) +(^~) :: (Num c, Integral e) => Setting a b c c -> e -> a -> b +l ^~ n = adjust l (^ n) +{-# INLINE (^~) #-} + +-- | Raise the target(s) of a fractionally valued 'Lens', 'Setter' or 'Traversal' to an integral power +-- +-- >>> _2 ^^~ (-1) $ (1,2) +-- (1,0.5) +(^^~) :: (Fractional c, Integral e) => Setting a b c c -> e -> a -> b +l ^^~ n = adjust l (^^ n) +{-# INLINE (^^~) #-} + +-- | Raise the target(s) of a floating-point valued 'Lens', 'Setter' or 'Traversal' to an arbitrary power. +-- +-- >>> _2 **~ pi $ (1,3) +-- (1,31.54428070019754) +(**~) :: Floating c => Setting a b c c -> c -> a -> b +l **~ n = adjust l (** n) +{-# INLINE (**~) #-} + +-- | Logically '||' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' +(||~):: Setting a b Bool Bool -> Bool -> a -> b +l ||~ n = adjust l (|| n) +{-# INLINE (||~) #-} + +-- | Logically '&&' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' +(&&~) :: Setting a b Bool Bool -> Bool -> a -> b +l &&~ n = adjust l (&& n) +{-# INLINE (&&~) #-} + +-- | Modify the target of a monoidally valued by 'mappend'ing another value. +(<>~) :: Monoid c => Setting a b c c -> c -> a -> b +l <>~ n = adjust l (mappend n) +{-# INLINE (<>~) #-} + +------------------------------------------------------------------------------ +-- Using Setters with State +------------------------------------------------------------------------------ + +-- | Replace the target of a 'Lens' or all of the targets of a 'Setter' or 'Traversal' in our monadic +-- state with a new value, irrespective of the old. +-- +-- > (.=) :: MonadState a m => Iso a a c d -> d -> m () +-- > (.=) :: MonadState a m => Lens a a c d -> d -> m () +-- > (.=) :: MonadState a m => Traversal a a c d -> d -> m () +-- > (.=) :: MonadState a m => Setter a a c d -> d -> m () +-- +-- "It puts the state in the monad or it gets the hose again." +(.=) :: MonadState a m => Setting a a c d -> d -> m () +l .= b = State.modify (l .~ b) +{-# INLINE (.=) #-} + +-- | Map over the target of a 'Lens' or all of the targets of a 'Setter' or '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 () +-- > (%=) :: MonadState a m => Traversal a a c d -> (c -> d) -> m () +-- > (%=) :: MonadState a m => Setter a a c d -> (c -> d) -> m () +(%=) :: MonadState a m => Setting a a c d -> (c -> d) -> m () +l %= f = State.modify (l %~ f) +{-# INLINE (%=) #-} + +-- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding a value +-- +-- Example: +-- +-- > fresh = do +-- > id += 1 +-- > access id +(+=) :: (MonadState a m, Num b) => SimpleSetting a b -> b -> m () +l += b = State.modify (l +~ b) +{-# INLINE (+=) #-} + +-- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by subtracting a value +(-=) :: (MonadState a m, Num b) => SimpleSetting a b -> b -> m () +l -= b = State.modify (l -~ b) +{-# INLINE (-=) #-} + +-- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by multiplying by value +(*=) :: (MonadState a m, Num b) => SimpleSetting a b -> b -> m () +l *= b = State.modify (l *~ b) +{-# INLINE (*=) #-} + +-- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by dividing by a value +(//=) :: (MonadState a m, Fractional b) => SimpleSetting a b -> b -> m () +l //= b = State.modify (l //~ b) +{-# INLINE (//=) #-} + +-- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to a non-negative integral power +(^=) :: (MonadState a m, Fractional b, Integral c) => SimpleSetting a b -> c -> m () +l ^= c = State.modify (l ^~ c) +{-# INLINE (^=) #-} + +-- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to an integral power +(^^=) :: (MonadState a m, Fractional b, Integral c) => SimpleSetting a b -> c -> m () +l ^^= c = State.modify (l ^^~ c) +{-# INLINE (^^=) #-} + +-- | Raise the target(s) of a numerically valued 'Lens', 'Setter' or 'Traversal' to an arbitrary power +(**=) :: (MonadState a m, Floating b) => SimpleSetting a b -> b -> m () +l **= b = State.modify (l **~ b) +{-# INLINE (**=) #-} + +-- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by taking their logical '&&' with a value +(&&=):: MonadState a m => SimpleSetting a Bool -> Bool -> m () +l &&= b = State.modify (l &&~ b) +{-# INLINE (&&=) #-} + +-- | Modify the target(s) of a 'Simple' 'Lens', 'Iso, 'Setter' or 'Traversal' by taking their logical '||' with a value +(||=) :: MonadState a m => SimpleSetting a Bool -> Bool -> m () +l ||= b = State.modify (l ||~ b) +{-# INLINE (||=) #-} + +-- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value. +(<>=) :: (MonadState a m, Monoid b) => SimpleSetting a b -> b -> m () +l <>= b = State.modify (l <>~ b) +{-# INLINE (<>=) #-} + +-- | Run a monadic action, and set all of the targets of a 'Lens', 'Setter' or 'Traversal' to its result. +-- +-- > (<~) :: MonadState a m => Iso a a c d -> m d -> m () +-- > (<~) :: MonadState a m => Lens a a c d -> m d -> m () +-- > (<~) :: MonadState a m => Traversal a a c d -> m d -> m () +-- > (<~) :: MonadState a m => Setter a a c d -> m d -> m () +-- +-- As a reasonable mnemonic, this lets you store the result of a monadic action in a lens rather than +-- in a local variable. +-- +-- > do foo <- bar +-- > ... +-- +-- will store the result in a variable, while +-- +-- > do foo <~ bar +-- > ... +-- +-- will store the result in a lens/setter/traversal. +(<~) :: MonadState a m => Setting a a c d -> m d -> m () +l <~ md = md >>= (l .=) +{-# INLINE (<~) #-} + +------------------------------------------------------------------------------ +-- MonadWriter +------------------------------------------------------------------------------ + +-- | Tell a part of a value to a 'MonadWriter', filling in the rest from 'mempty' +-- +-- > whisper l d = tell (set l d mempty) + +-- > whisper :: (MonadWriter b m, Monoid a) => Iso a b c d -> d -> m () +-- > whisper :: (MonadWriter b m, Monoid a) => Lens a b c d -> d -> m () +-- > whisper :: (MonadWriter b m, Monoid a) => Traversal a b c d -> d -> m () +-- > whisper :: (MonadWriter b m, Monoid a) => Setter a b c d -> d -> m () +-- +-- > whisper :: (MonadWriter b m, Monoid a) => ((c -> Identity d) -> a -> Identity b) -> d -> m () +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/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -26,11 +26,19 @@ , makeIso , makeLenses, makeLensesFor , makeLensesWith + , lensRules + , classyRules + , isoRules , defaultRules ) where import Control.Applicative -import Control.Lens +import Control.Lens.Fold +import Control.Lens.Getter +import Control.Lens.Iso +import Control.Lens.Setter +import Control.Lens.Type +import Control.Lens.Traversal import Control.Monad import Data.Char (toLower) import Data.Foldable @@ -48,12 +56,10 @@ -- | Flags for lens construction data LensFlag = SimpleLenses - | SingletonAndField | SingletonIso | HandleSingletons | SingletonRequired - | CreateClass | CreateInstance | ClassRequired @@ -163,12 +169,10 @@ appArgs t (x:xs) = appArgs (AppT t (VarT (x^.name))) xs apps :: Type -> [Type] -> Type -apps t [] = t -apps t (x:xs) = apps (t `AppT` x) xs +apps = Prelude.foldl AppT appsT :: TypeQ -> [TypeQ] -> TypeQ -appsT t [] = t -appsT t (x:xs) = appsT (t `appT` x) xs +appsT = Prelude.foldl appT -- | Given -- @@ -202,8 +206,8 @@ quantified = ForallT (tyArgs ++ substTypeVars m tyArgs) (ctx ++ substTypeVars m ctx) maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName) lensOnly = not $ cfg^.singletonIso - isoCon | lensOnly = ConT (mkName "Control.Lens.Body") - | otherwise = ConT (mkName "Control.Lens.Iso") + isoCon | lensOnly = ConT ''Lens + | otherwise = ConT ''Iso makeBody | lensOnly = makeLensBody | otherwise = makeIsoBody isoDecls <- flip (maybe (return [])) maybeIsoName $ \isoName -> do @@ -247,8 +251,8 @@ commonFieldDescs = toList . Prelude.foldr walk mempty where walk con m = Prelude.foldr step m (conFieldDescs con) step d@(FieldDesc nm ty bds) m = case m^.at nm of - Just (FieldDesc _ _ bds') -> at nm <~ Just (FieldDesc nm ty (bds `Set.union` bds')) $ m - Nothing -> at nm <~ Just d $ m + Just (FieldDesc _ _ bds') -> at nm .~ Just (FieldDesc nm ty (bds `Set.union` bds')) $ m + Nothing -> at nm .~ Just d $ m errorClause :: Name -> Name -> Name -> ClauseQ errorClause lensName fieldName conName @@ -272,7 +276,7 @@ x <- newName "y" clause [varP f, conP conName $ map varP names] (normalB (appsE [ varE (mkName "fmap") - , lamE [varP x] $ appsE $ conE conName : map varE (element i <~ x $ names) + , lamE [varP x] $ appsE $ conE conName : map varE (element i .~ x $ names) , varE (mkName "f") `appE` varE (names^.element i) ])) [] Nothing -> errorClause lensName fieldName conName @@ -307,7 +311,7 @@ Prelude.sequence $ filter (\_ -> cfg^.createClass) [ classD (return []) clsName [PlainTV t] [] - [ sigD methodName $ conT (mkName "Control.Lens.Lens") `appsT` [varT t,varT t, conT tyConName, conT tyConName]]] + [ sigD methodName $ appsT (return (ConT ''Lens)) [varT t, varT t, conT tyConName, conT tyConName] ]] ++ filter (\_ -> cfg^.createInstance) [ instanceD (return []) (conT clsName `appT` conT tyConName) [ funD methodName [clause [varP a] (normalB (varE a)) []] @@ -329,9 +333,12 @@ _ -> ps tvs' | isJust maybeClassName = PlainTV x : tvs | otherwise = tvs - let decl = SigD lensName $ ForallT tvs' qs $ ConT (mkName "Control.Lens.Lens") `apps` - if cfg^.simpleLenses then [aty,aty,cty,cty] - else [aty,bty,cty,dty] + + let decl = SigD lensName $ ForallT tvs' qs $ + apps (ConT ''Lens) $ + if cfg^.simpleLenses + then [aty,aty,cty,cty] + else [aty,bty,cty,dty] body <- makeFieldLensBody lensName nm cons $ fmap (mkName . view _2) maybeLensClass inlining <- pragInlD lensName $ inlineSpecNoPhase True False return [decl, body, inlining] @@ -356,31 +363,40 @@ _ -> fail "Expected the name of a data type or newtype" -- | Build lenses with a sensible default configuration +-- +-- > makeLenses = makeLensesWith lensRules makeLenses :: Name -> Q [Dec] -makeLenses = makeLensesWith - $ lensIso <~ const Nothing - $ lensClass <~ const Nothing - $ handleSingletons <~ True -- generate an Iso for the field if its the only one - $ defaultRules +makeLenses = makeLensesWith lensRules -- | Make a top level isomorphism injecting _into_ the type -- -- The supplied name is required to be for a type with a single constructor that has a single argument +-- +-- > makeIso = makeLensesWith isoRules makeIso :: Name -> Q [Dec] -makeIso = makeLensesWith - $ singletonRequired <~ True - $ singletonAndField <~ True +makeIso = makeLensesWith isoRules + +-- | Rules for making an isomorphism from a data type +isoRules :: LensRules +isoRules + = singletonRequired .~ True + $ singletonAndField .~ True $ defaultRules -- | Make 'classy lenses' for a type +-- +-- > makeClassy = makeLensesWith classyRules makeClassy :: Name -> Q [Dec] -makeClassy = makeLensesWith - $ lensIso <~ const Nothing - $ handleSingletons <~ False - $ lensClass <~ classy - $ classRequired <~ True - $ defaultRules +makeClassy = makeLensesWith classyRules +-- | Rules for making lenses that precompose another lens. +classyRules :: LensRules +classyRules = lensIso .~ const Nothing + $ handleSingletons .~ False + $ lensClass .~ classy + $ classRequired .~ True + $ defaultRules + classy :: String -> Maybe (String, String) classy n@(a:as) = Just ("Has" ++ n, toLower a:as) classy _ = Nothing @@ -392,10 +408,15 @@ -- > makeLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo makeLensesFor :: [(String, String)] -> Name -> Q [Dec] makeLensesFor fields = makeLensesWith - $ lensField <~ (`Prelude.lookup` fields) - $ lensIso <~ const Nothing - $ lensClass <~ const Nothing - $ handleSingletons <~ True + $ lensField .~ (`Prelude.lookup` fields) + $ lensRules + +-- | Rules for making fairly simple lenses, ignoring the special cases for isomorphisms, and not making any classes. +lensRules :: LensRules +lensRules + = lensIso .~ const Nothing + $ lensClass .~ const Nothing + $ handleSingletons .~ True $ defaultRules -- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@ @@ -406,11 +427,9 @@ -- > makeClassyFor "HasFoo" "foo" [("_foo", "fooLens"), ("bar", "lbar")] ''Foo makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec] makeClassyFor clsName funName fields = makeLensesWith - $ lensField <~ (`Prelude.lookup` fields) - $ lensIso <~ const Nothing - $ lensClass <~ const (Just (clsName,funName)) - $ handleSingletons <~ False - $ defaultRules + $ lensClass .~ const (Just (clsName,funName)) + $ lensField .~ (`Prelude.lookup` fields) + $ classyRules -- The orphan instance for old versions is bad, but programing without Applicative is worse. #if !(MIN_VERSION_template_haskell(2,7,0)) diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Traversal.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Traversal +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +-- A @'Traversal' a b c d@ is a generalization of 'traverse' from +-- 'Traversable'. It allows you to traverse over a structure and change out +-- its contents with monadic or applicative side-effects. Starting from +-- +-- @'traverse' :: ('Traversable' t, 'Applicative' f) => (c -> f d) -> t c -> f (t d)@, +-- +-- we monomorphize the contents and result to obtain +-- +-- > type Traversal a b c d = forall f. Applicative f => (c -> f d) -> a -> f b +-- +-- While a 'Traversal' isn't quite a 'Fold', it _can_ be used for 'Getting' +-- like a 'Fold', because given a 'Monoid' @m@, we have an 'Applicative' +-- for @('Const' m)@. Everything you know how to do with a 'Traversable' +-- container, you can with with a 'Traversal', and here we provide +-- combinators that generalize the usual 'Traversable' operations. +---------------------------------------------------------------------------- +module Control.Lens.Traversal + ( + -- * Lenses + Traversal + + -- ** Lensing Traversals + , element + , elementOf + + -- * Traversing and Lensing + , traverseOf, forOf, sequenceAOf + , mapMOf, forMOf, sequenceOf + , transposeOf + , mapAccumLOf, mapAccumROf + , scanr1Of, scanl1Of + + -- * Common Traversals + , Traversable(traverse) + , traverseNothing + + -- * Simple + , SimpleTraversal + ) where + +import Control.Applicative as Applicative +import Control.Applicative.Backwards +import Control.Lens.Fold +import Control.Lens.Internal +import Control.Lens.Type +import Control.Monad.State.Class as State +import Control.Monad.Trans.State.Lazy as Lazy +import Data.Traversable + +------------------------------------------------------------------------------ +-- Traversals +------------------------------------------------------------------------------ + +-- | A 'Traversal' can be used directly as a 'Setter' or a 'Fold' (but not as a 'Lens') and provides +-- the ability to both read and update multiple fields, subject to some relatively weak 'Traversal' laws. +-- +-- These have also been known as multilenses, but they have the signature and spirit of +-- +-- > traverse :: Traversable f => Traversal (f a) (f b) a b +-- +-- and the more evocative name suggests their application. +-- +-- Most of the time the 'Traversal' you will want to use is just 'traverse', but you can also pass any +-- 'Lens' or 'Iso' as a Traversal, and composition of a 'Traversal' (or 'Lens' or 'Iso') with a 'Traversal' (or 'Lens' or 'Iso') +-- using (.) forms a valid 'Traversal'. +-- +-- The laws for a Traversal @t@ follow from the laws for Traversable as stated in \"The Essence of the Iterator Pattern\". +-- +-- 1) Idiomatic naturality: +-- +-- > t pure = pure +-- +-- 2) Sequential composition: +-- +-- > fmap (t f) . t g = getCompose . t (Compose . fmap f . g) +-- +-- One consequence of this requirement is that a traversal needs to leave the same number of elements as a candidate for +-- subsequent traversal as it started with. +-- +-- 3) No duplication of elements (as defined in \"The Essence of the Iterator Pattern\" section 5.5), which states +-- that you should incur no effect caused by visiting the same element of the container twice. +type Traversal a b c d = forall f. Applicative f => (c -> f d) -> a -> f b + +-- | > type SimpleTraversal = Simple Traversal +type SimpleTraversal a b = Traversal a a b b + +-------------------------- +-- Traversal Combinators +-------------------------- + +-- | +-- Map each element of a structure targeted by a Lens or Traversal, +-- evaluate these actions from left to right, and collect the results. +-- +-- > traverseOf = id +-- +-- > traverse = traverseOf traverse +-- +-- > traverseOf :: Iso a b c d -> (c -> f d) -> a -> f b +-- > traverseOf :: Lens a b c d -> (c -> f d) -> a -> f b +-- > traverseOf :: Traversal a b c d -> (c -> f d) -> a -> f b +traverseOf :: LensLike f a b c d -> (c -> f d) -> a -> f b +traverseOf = id +{-# INLINE traverseOf #-} + +-- | +-- +-- > forOf l = flip (traverseOf l) +-- +-- > for = forOf traverse +-- > forOf = morphism flip flip +-- +-- > forOf :: Lens a b c d -> a -> (c -> f d) -> f b +forOf :: LensLike f a b c d -> a -> (c -> f d) -> f b +forOf = flip +{-# INLINE forOf #-} + +-- | +-- Evaluate each action in the structure from left to right, and collect +-- the results. +-- +-- > sequenceA = sequenceAOf traverse +-- > sequenceAOf l = traverseOf l id +-- > sequenceAOf l = l id +-- +-- > sequenceAOf :: Iso a b (f c) c -> a -> f b +-- > sequenceAOf :: Lens a b (f c) c -> a -> f b +-- > sequenceAOf :: Applicative f => Traversal a b (f c) c -> a -> f b +sequenceAOf :: LensLike f a b (f c) c -> a -> f b +sequenceAOf l = l id +{-# INLINE sequenceAOf #-} + +-- | 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. +-- +-- > mapM = mapMOf traverse +-- +-- > mapMOf :: Iso a b c d -> (c -> m d) -> a -> m b +-- > mapMOf :: Lens a b c d -> (c -> m d) -> a -> m b +-- > mapMOf :: Monad m => Traversal a b c d -> (c -> m d) -> a -> m b +mapMOf :: LensLike (WrappedMonad m) a b c d -> (c -> m d) -> a -> m b +mapMOf l cmd = unwrapMonad . l (WrapMonad . cmd) +{-# INLINE mapMOf #-} + +-- | +-- > forM = forMOf traverse +-- > forMOf l = flip (mapMOf l) +-- +-- > forMOf :: Iso a b c d -> a -> (c -> m d) -> m b +-- > forMOf :: Lens a b c d -> a -> (c -> m d) -> m b +-- > forMOf :: Monad m => Traversal a b c d -> a -> (c -> m d) -> m b +forMOf :: LensLike (WrappedMonad m) a b c d -> a -> (c -> m d) -> m b +forMOf l a cmd = unwrapMonad (l (WrapMonad . cmd) a) +{-# INLINE forMOf #-} + +-- | +-- > sequence = sequenceOf traverse +-- > sequenceOf l = mapMOf l id +-- > sequenceOf l = unwrapMonad . l WrapMonad +-- +-- > sequenceOf :: Iso a b (m c) c -> a -> m b +-- > sequenceOf :: Lens a b (m c) c -> a -> m b +-- > sequenceOf :: Monad m => Traversal a b (m c) c -> a -> m b +sequenceOf :: LensLike (WrappedMonad m) a b (m c) c -> a -> m b +sequenceOf l = unwrapMonad . l WrapMonad +{-# INLINE sequenceOf #-} + +-- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'. +-- +-- > transpose = transposeOf traverse +-- +-- > ghci> transposeOf traverse [[1,2,3],[4,5,6]] +-- > [[1,4],[2,5],[3,6]] +-- +-- Since every 'Lens' is a Traversal, we can use this as a form of +-- monadic strength. +-- +-- > transposeOf _2 :: (b, [a]) -> [(b, a)] +transposeOf :: LensLike ZipList a b [c] c -> a -> [b] +transposeOf l = getZipList . l ZipList +{-# INLINE transposeOf #-} + +-- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'. +-- +-- > mapAccumR = mapAccumROf traverse +-- +-- 'mapAccumROf' accumulates state from right to left. +-- +-- > mapAccumROf :: Iso a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +-- > mapAccumROf :: Lens a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +-- > mapAccumROf :: Traversal a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +mapAccumROf :: LensLike (Lazy.State s) a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +mapAccumROf l f s0 a = swap (Lazy.runState (l (\c -> State.state (\s -> swap (f s c))) a) s0) +{-# INLINE mapAccumROf #-} + +-- | Generalized 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'. +-- +-- > mapAccumL = mapAccumLOf traverse +-- +-- 'mapAccumLOf' accumulates state from left to right. +-- +-- > mapAccumLOf :: Iso a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +-- > mapAccumLOf :: Lens a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +-- > mapAccumLOf :: Traversal a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +mapAccumLOf :: LensLike (Backwards (Lazy.State s)) a b c d -> (s -> c -> (s, d)) -> s -> a -> (s, b) +mapAccumLOf = mapAccumROf . backwards +{-# INLINE mapAccumLOf #-} + +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) +{-# INLINE swap #-} + +-- | Permit the use of 'scanr1' over an arbitrary 'Traversal' or 'Lens'. +-- +-- > scanr1 = scanr1Of traverse +-- +-- > scanr1Of :: Iso a b c c -> (c -> c -> c) -> a -> b +-- > scanr1Of :: Lens a b c c -> (c -> c -> c) -> a -> b +-- > scanr1Of :: Traversal a b c c -> (c -> c -> c) -> a -> b +scanr1Of :: LensLike (Lazy.State (Maybe c)) a b c c -> (c -> c -> c) -> a -> b +scanr1Of l f = snd . mapAccumROf l step Nothing where + step Nothing c = (Just c, c) + step (Just s) c = (Just r, r) where r = f c s +{-# INLINE scanr1Of #-} + +-- | Permit the use of 'scanl1' over an arbitrary 'Traversal' or 'Lens'. +-- +-- > scanl1 = scanl1Of traverse +-- +-- > scanr1Of :: Iso a b c c -> (c -> c -> c) -> a -> b +-- > scanr1Of :: Lens a b c c -> (c -> c -> c) -> a -> b +-- > scanr1Of :: Traversal a b c c -> (c -> c -> c) -> a -> b +scanl1Of :: LensLike (Backwards (Lazy.State (Maybe c))) a b c c -> (c -> c -> c) -> a -> b +scanl1Of l f = snd . mapAccumLOf l step Nothing where + step Nothing c = (Just c, c) + step (Just s) c = (Just r, r) where r = f s c +{-# INLINE scanl1Of #-} + +------------------------------------------------------------------------------ +-- Common Lenses +------------------------------------------------------------------------------ + +-- | A 'Lens' to view/edit the nth element 'elementOf' a 'Traversal', 'Lens' or 'Iso'. +-- +-- Attempts to access beyond the range of the 'Traversal' will cause an error. +-- +-- > ghci> [[1],[3,4]]^.elementOf (traverse.traverse) 1 +-- > 3 +elementOf :: Functor f => LensLike (ElementOf f) a b c c -> Int -> LensLike f a b c c +elementOf l i f a = case getElementOf (l go a) 0 of + Found _ fb -> fb + Searching _ _ -> error "elementOf: index out of range" + NotFound e -> error $ "elementOf: " ++ e + where + go c = ElementOf $ \j -> if i == j then Found (j + 1) (f c) else Searching (j + 1) c + +-- | Access the nth element of a 'Traversable' container. +-- +-- Attempts to access beyond the range of the 'Traversal' will cause an error. +-- +-- > element = elementOf traverse +element :: Traversable t => Int -> Simple Lens (t a) a +element = elementOf traverse + +------------------------------------------------------------------------------ +-- Traversals +------------------------------------------------------------------------------ + +-- | This is the traversal that just doesn't return anything +-- +-- > traverseNothing :: Applicative f => (c -> f d) -> a -> f a +traverseNothing :: Traversal a a c d +traverseNothing = const pure +{-# INLINE traverseNothing #-} + diff --git a/src/Control/Lens/Type.hs b/src/Control/Lens/Type.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Type.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Type +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +-- A @'Lens' a b c d@ is a purely functional reference. +-- +-- While a 'Traversal' could be used for 'Getting' like a valid '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 +-- +-- Every 'Lens' is a valid 'Setter', choosing @f@ = 'Identity'. +-- +-- Every 'Lens' can be used for 'Getting' like a 'Fold' that doesn't use +-- the 'Monoid'. +-- +-- Every 'Lens' is a valid '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@ +-- +-- Since every 'Lens' can be used for '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'. +---------------------------------------------------------------------------- +module Control.Lens.Type + ( + -- * Lenses + Lens + , Simple + , lens + , (%%~) + , (%%=) + + -- ** Common Lenses + , _1, _2 + , resultAt + + -- * Traversing and Lensing + , Focus(..) + + -- * Cloning Lenses + , clone + , merged + , bothLenses + + -- * Simplified and In-Progress + , LensLike + , Overloaded + , SimpleLens + , SimpleLensLike + , SimpleOverloaded + ) where + +import Control.Applicative as Applicative +import Control.Lens.Internal +import Control.Lens.Setter +import Control.Monad +import Control.Monad.State.Class as State +import Control.Monad.Trans.State.Lazy as Lazy +import Control.Monad.Trans.State.Strict as Strict +import Control.Monad.Trans.Reader +import Data.Functor.Identity + +infixr 4 %%~ +infix 4 %%= + +-------------------------- +-- Lenses +-------------------------- + +-- | A 'Lens' is actually a lens family as described in . +-- +-- With great power comes great responsibility and a 'Lens' is subject to the three common sense lens laws: +-- +-- 1) You get back what you put in: +-- +-- > view l (set l b a) = b +-- +-- 2) Putting back what you got doesn't change anything: +-- +-- > 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 +-- +-- 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'. +-- +-- You can also use a 'Lens' for 'Getting' as if it were a 'Fold' or 'Getter'. +-- +-- Since every lens is a valid 'Traversal', the traversal laws should also apply to any lenses you create. +-- +-- 1.) Idiomatic naturality: +-- +-- > l pure = pure +-- +-- 2.) Sequential composition: +-- +-- > fmap (l f) . l g = getCompose . l (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 => (c -> f d) -> a -> f b + +-- | A @'Simple' 'Lens'@, @'Simple' 'Traversal'@, ... can be used instead of a 'Lens','Traversal', ... +-- whenever the type variables don't change upon setting a value. +-- +-- > imaginary :: Simple Lens (Complex a) a +-- > traverseHead :: Simple Traversal [a] a +-- +-- Note: To use this alias in your own code with @'LensLike' f@ or @Setter@, you may have to turn on +-- @LiberalTypeSynonyms@. +type Simple f a b = f a a b b + +-- | > type SimpleLens = Simple Lens +type SimpleLens a b = Lens a a b b + +-- | > type SimpleLensLike f = Simple (LensLike f) +type SimpleLensLike f a b = LensLike f a a b b + +-------------------------- +-- Constructing Lenses +-------------------------- + +-- | Build a 'Lens' from a getter and a setter. +-- +-- > lens :: Functor f => (a -> c) -> (a -> d -> b) -> (c -> f d) -> a -> f b +lens :: (a -> c) -> (a -> d -> b) -> Lens a b c d +lens ac adb cfd a = adb a <$> cfd (ac a) +{-# INLINE lens #-} + +-------------------------- +-- LensLike +-------------------------- + +-- | +-- Many combinators that accept a 'Lens' can also accept a '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'. +type LensLike f a b c d = (c -> f d) -> a -> f b + +-- | ('%%~') can be used in one of two scenarios: +-- +-- 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 +-- applicative summary of its actions. +-- +-- For all that the definition of this combinator is just: +-- +-- > (%%~) = 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 +-- > (%%~) :: Applicative f => Traversal a b c d -> (c -> f d) -> a -> f b +-- +-- 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 +-- supplemental monoidal summary of its actions, by choosing f = ((,) m) +-- +-- > (%%~) :: Iso a b c d -> (c -> (e, d)) -> a -> (e, b) +-- > (%%~) :: Lens a b c d -> (c -> (e, d)) -> a -> (e, b) +-- > (%%~) :: Monoid m => Traversal a b c d -> (c -> (m, d)) -> a -> (m, b) +(%%~) :: LensLike f a b c d -> (c -> f d) -> a -> f b +(%%~) = id +{-# 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@ +-- and return a monoidal summary of the changes. +-- +-- > (%%=) = (state.) +-- +-- It may be useful to think of ('%%='), instead, as having either of the following more restricted +-- type signatures: +-- +-- > (%%=) :: MonadState a m => Iso a a c d -> (c -> (e, d) -> m e +-- > (%%=) :: MonadState a m => Lens a a c d -> (c -> (e, d) -> m e +-- > (%%=) :: (MonadState a m, Monoid e) => Traversal a a c d -> (c -> (e, d) -> m e +(%%=) :: MonadState a m => LensLike ((,) e) a a c d -> (c -> (e, d)) -> m e +#if MIN_VERSION_mtl(2,1,1) +l %%= f = State.state (l f) +#else +l %%= f = do + (e, b) <- State.gets (l f) + State.put b + return e +#endif +{-# INLINE (%%=) #-} + +-- | 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'. + -- + -- 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 + -- and the results are aggregated monoidally + -- and a monoidal summary + -- of the result is given. + -- + -- > focus :: Monad m => Simple Iso a b -> st b m c -> st a m c + -- > focus :: Monad m => Simple Lens a b -> st b m c -> st a m c + -- > focus :: (Monad m, Monoid c) => Simple Traversal a b -> st b m c -> st a m c + focus :: Monad m => LensLike (Focusing m c) a a b b -> st b m c -> st a m c + + -- | Like 'focus', but discarding any accumulated results as you go. + -- + -- > focus_ :: Monad m => Simple Iso a b -> st b m c -> st a m () + -- > focus_ :: Monad m => Simple Lens a b -> st b m c -> st a m () + -- > focus_ :: (Monad m, Monoid c) => Simple Traversal a b -> st b m c -> st a m () + focus_ :: Monad m => LensLike (Focusing m ()) a a b b -> st b m c -> st a m () + + -- | A much more limited version of 'focus' that can work with a 'Setter'. + setFocus :: Simple Setter a b -> st b Identity c -> st a Identity () + +skip :: a -> () +skip _ = () +{-# INLINE skip #-} + +instance Focus Strict.StateT where + focus l m = Strict.StateT $ unfocusing . l (Focusing . Strict.runStateT m) + {-# INLINE focus #-} + focus_ l m = Strict.StateT $ unfocusing . l (Focusing . Strict.runStateT (liftM skip m)) + {-# INLINE focus_ #-} + setFocus l m = Strict.state $ (,) () . runIdentity . l (Identity . snd . Strict.runState m) + +instance Focus Lazy.StateT where + focus l m = Lazy.StateT $ unfocusing . l (Focusing . Lazy.runStateT m) + {-# INLINE focus #-} + focus_ l m = Lazy.StateT $ unfocusing . l (Focusing . Lazy.runStateT (liftM skip m)) + {-# INLINE focus_ #-} + setFocus l m = Lazy.state $ (,) () . runIdentity . l (Identity . snd . Lazy.runState m) + +instance Focus ReaderT where + --focus l m = ReaderT $ \a -> liftM fst $ unfocusing $ l (\b -> Focusing $ (\c -> (c,b)) `liftM` runReaderT m b) a + focus l m = ReaderT $ liftM fst . unfocusing . l (\b -> Focusing $ (\c -> (c,b)) `liftM` runReaderT m b) + {-# INLINE focus #-} + focus_ l m = ReaderT $ \a -> liftM skip $ unfocusing $ l (\b -> Focusing $ (\_ -> ((),b)) `liftM` runReaderT m b) a + {-# INLINE focus_ #-} + setFocus _ _ = return () -- BOOORING + +------------------------------------------------------------------------------ +-- Common Lenses +------------------------------------------------------------------------------ + +-- | This is a lens that can change the value (and type) of the first field of +-- a pair. +-- +-- > ghci> (1,2)^._1 +-- > 1 +-- +-- > ghci> _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 +-- +-- > _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 #-} + +-- | This lens can be used to change the result of a function but only where +-- the arguments match the key given. +resultAt :: Eq e => e -> Simple Lens (e -> a) a +resultAt e afa ea = go <$> afa a where + a = ea e + go a' e' | e == e' = a' + | otherwise = a +{-# INLINE resultAt #-} + +-- | Merge two lenses, getters, setters, folds or traversals. +merged :: Functor f => LensLike f a b c c -> LensLike f a' b' c c -> LensLike f (Either a a') (Either b b') c c +merged l _ f (Left a) = Left <$> l f a +merged _ r f (Right a') = Right <$> r f a' +{-# INLINE merged #-} + +-- | 'bothLenses' makes a lens from two other lenses (or isomorphisms) +bothLenses :: Lens a b c d -> Lens a' b' c' d' -> Lens (a,a') (b,b') (c,c') (d,d') +bothLenses l r f (a, a') = case l (IndexedStore id) a of + IndexedStore db c -> case r (IndexedStore id) a' of + IndexedStore db' c' -> (\(d,d') -> (db d, db' d')) <$> f (c,c') +{-# INLINE bothLenses #-} + +------------------------------------------------------------------------------ +-- Cloning Lenses +------------------------------------------------------------------------------ + +-- | +-- +-- Cloning a 'Lens' is one way to make sure you arent given +-- something weaker, such as a '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. +-- +clone :: Functor f + => LensLike (IndexedStore c d) a b c d + -> (c -> f d) -> a -> f b +clone f cfd a = case f (IndexedStore id) a of + IndexedStore db c -> db <$> cfd c +{-# INLINE clone #-} + +----------------------------------------------------------------------------- +-- Overloading function application +----------------------------------------------------------------------------- + +-- | > 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 = Overloaded k f a a b b + diff --git a/src/Control/Seq/Lens.hs b/src/Control/Seq/Lens.hs --- a/src/Control/Seq/Lens.hs +++ b/src/Control/Seq/Lens.hs @@ -16,7 +16,7 @@ import Control.Lens import Control.Seq --- | Evaluate the elements targeted by a 'Lens', 'Traversal', 'Iso', +-- | Evaluate the elements targeted by a 'Lens', 'Traversal', 'Iso', -- 'Getter' or 'Fold' according to the given strategy. -- -- > seqFoldable = seqOf folded 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 @@ -16,7 +16,6 @@ -- * Indexing ix -- * Setters - , amapped , ixmapped -- * Traversal , traverseArray @@ -24,7 +23,7 @@ import Control.Applicative import Control.Lens -import Data.Array.IArray +import Data.Array.IArray hiding (index) -- | Access an element of an array. -- @@ -33,26 +32,16 @@ -- > arr ! i = arr^.ix i -- > arr // [(i,e)] = ix i ^= e $ arr -- --- > ghci> ix 2 ^= 9 $ listArray (1,5) [4,5,6,7,8] --- > array (1,5) [4,9,6,7,8] +-- >>> ix 2 ^= 9 $ listArray (1,5) [4,5,6,7,8] +-- array (1,5) [4,9,6,7,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 map over all of the values in an array. --- --- Note: 'traverseArray' is strictly more general and permits more operations --- --- > amap = adjust amapped --- > amapped = sets amap -amapped :: (IArray a c, IArray a d, Ix i) => Setter (a i c) (a i d) c d -amapped = sets amap -{-# INLINE amapped #-} - -- | This setter can be used to derive a new array from an old array by -- applying a function to each of the indices. -- --- This is a /contravariant/ Setter. +-- This is a /contravariant/ 'Setter'. -- -- > ixmap = adjust . ixmapped -- > ixmapped = sets . ixmap @@ -63,9 +52,10 @@ ixmapped = sets . ixmap {-# INLINE ixmapped #-} --- | Generic 'Traversal' of the elements of an array. +-- | Generic 'IndexedTraversal' of the elements of an array, using the index into the +-- array as the index of the traversal. -- -- > amap = adjust traverseArray -traverseArray :: (IArray a c, IArray a d, Ix i) => Traversal (a i c) (a i d) c d -traverseArray f arr = array (bounds arr) <$> (traverse._2) f (assocs arr) +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 @@ -1,4 +1,5 @@ {-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Bits.Lens @@ -25,48 +26,59 @@ infix 4 |=, &= -- | Bitwise '.|.' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' -(|~):: Bits c => Setter a b c c -> c -> a -> b +-- +-- >>> _2 |~ 6 $ ("hello",3) +-- ("hello",7) +(|~):: Bits c => Setting a b c c -> c -> a -> b l |~ n = adjust l (.|. n) {-# INLINE (|~) #-} -- | Bitwise '.&.' the target(s) of a 'Bool'-valued 'Lens' or 'Setter' -(&~) :: Bits c => Setter a b c c -> c -> a -> b +-- +-- >>> _2 &~ 7 $ ("hello",254) +-- ("hello",6) +(&~) :: Bits c => Setting a b c c -> c -> a -> b l &~ n = adjust l (.&. n) {-# INLINE (&~) #-} -- | Modify the target(s) of a 'Simple' 'Lens', 'Setter' or 'Traversal' by computing its bitwise '.&.' with another value. -(&=):: (MonadState a m, Bits b) => Simple Setter a b -> b -> m () +(&=):: (MonadState a m, Bits b) => Simple Setting a b -> b -> m () l &= b = modify (l &~ b) {-# INLINE (&=) #-} -- | Modify the target(s) of a 'Simple' 'Lens', 'Setter' or 'Traversal' by computing its bitwise '.|.' with another value. -(|=) :: (MonadState a m, Bits b) => Simple Setter a b -> b -> m () +(|=) :: (MonadState a m, Bits b) => Simple Setting a b -> b -> m () l |= b = modify (l |~ b) {-# INLINE (|=) #-} -- | This lens can be used to access the value of the nth bit in a number. -- --- @bitsAt 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) {-# INLINE bitAt #-} -- | Traverse over all bits in a numeric type. -- --- > ghci> toListOf traverseBits (5 :: Word8) --- > [True,False,True,False,False,False,False,False] +-- The bit position is available as the index. -- +-- >>> 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. --- --- > ghci> toListOf traverseBits 5 --- > [True,False,True,False,False,False,False,False,False,False,False,False... -traverseBits :: Bits b => Simple Traversal b Bool -traverseBits f b = Prelude.foldr step 0 <$> traverse g bits - where - g n = (,) n <$> f (testBit b n) +traverseBits :: Bits b => SimpleIndexedTraversal Int b Bool +traverseBits = index $ \f b -> let + g n = (,) n <$> f n (testBit b n) bits = Prelude.takeWhile hasBit [0..] hasBit n = complementBit b n /= b -- test to make sure that complementing this bit actually changes the value step (n,True) r = setBit r n step _ r = r + in Prelude.foldr step 0 <$> traverse g bits {-# INLINE traverseBits #-} 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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} ----------------------------------------------------------------------------- -- | @@ -13,6 +14,7 @@ ---------------------------------------------------------------------------- module Data.IntMap.Lens ( at + , traverseIntMap , traverseAt , traverseAtMin , traverseAtMax @@ -21,14 +23,15 @@ import Control.Applicative as Applicative import Control.Lens import Data.IntMap as IntMap +import Data.Traversable -- | This 'Lens' can be used to read, write or delete the value associated with a key in an 'IntMap'. -- --- > ghci> fromList [(1,"hello")] ^.at 1 --- > Just "hello" +-- >>> fromList [(1,"hello")] ^.at 1 +-- Just "hello" -- --- > ghci> at 1 ^~ Just "hello" $ mempty --- > fromList [(1,"hello")] +-- >>> at 1 .~ Just "hello" $ IntMap.empty +-- fromList [(1,"hello")] -- -- > at :: Int -> (Maybe v -> f (Maybe v)) -> IntMap v -> f (IntMap v) at :: Int -> Simple Lens (IntMap v) (Maybe v) @@ -37,6 +40,11 @@ go (Just v') = IntMap.insert k v' m {-# INLINE at #-} +-- | Traversal of an 'IntMap' indexed by the key. +traverseIntMap :: IndexedTraversal Int (IntMap v) (IntMap v') v v' +traverseIntMap = index $ \f -> sequenceA . mapWithKey f +{-# INLINE traverseIntMap #-} + -- | Traverse the value at a given key in an IntMap -- -- > traverseAt :: Applicative f => Int -> (v -> f v) -> IntMap v -> f (IntMap v) @@ -46,23 +54,25 @@ {-# INLINE traverseAt #-} -- | Traverse the value at the minimum key in a Map -traverseAtMin :: Simple Traversal (IntMap v) v -traverseAtMin f m = case IntMap.minView m of +-- +-- The key of the minimum element is available as the index. +traverseAtMin :: SimpleIndexedTraversal Int (IntMap v) v +traverseAtMin = index $ \f m -> case IntMap.minViewWithKey m of #if MIN_VERSION_containers(0,5,0) - Just (a, _) -> (\v -> IntMap.updateMin (const (Just v)) m) <$> f a + Just ((k,a), _) -> (\v -> IntMap.updateMin (const (Just v)) m) <$> f k a #else - Just (a, _) -> (\v -> IntMap.updateMin (const v) m) <$> f a + Just ((k,a), _) -> (\v -> IntMap.updateMin (const v) m) <$> f k a #endif Nothing -> pure m {-# INLINE traverseAtMin #-} -- | Traverse the value at the maximum key in a Map -traverseAtMax :: Simple Traversal (IntMap v) v -traverseAtMax f m = case IntMap.maxView m of +traverseAtMax :: SimpleIndexedTraversal Int (IntMap v) v +traverseAtMax = index $ \f m -> case IntMap.maxViewWithKey m of #if MIN_VERSION_containers(0,5,0) - Just (a, _) -> (\v -> IntMap.updateMax (const (Just v)) m) <$> f a + Just ((k,a), _) -> (\v -> IntMap.updateMax (const (Just v)) m) <$> f k a #else - Just (a, _) -> (\v -> IntMap.updateMax (const v) m) <$> f a + Just ((k,a), _) -> (\v -> IntMap.updateMax (const v) m) <$> f k a #endif Nothing -> pure m {-# INLINE traverseAtMax #-} diff --git a/src/Data/IntSet/Lens.hs b/src/Data/IntSet/Lens.hs --- a/src/Data/IntSet/Lens.hs +++ b/src/Data/IntSet/Lens.hs @@ -11,6 +11,7 @@ module Data.IntSet.Lens ( contains , members + , setmapped , setOf ) where @@ -30,6 +31,13 @@ go True = IntSet.insert k s {-# INLINE contains #-} +-- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of an 'IntSet'. +-- +-- >>> sumOf members $ setOf folded [1,2,3,4] +-- 10 +members :: Fold IntSet Int +members = folding IntSet.toAscList + -- | This 'Setter' can be used to change the contents of an 'IntSet' by mapping -- the elements to new values. -- @@ -37,10 +45,10 @@ -- elements might change but you can manipulate it by reading using 'folded' and -- reindexing it via 'setmap'. -- --- > ghci> adjust members (+1) (fromList [1,2,3,4] --- > fromList [2,3,4,5] -members :: Setter IntSet IntSet Int Int -members = sets IntSet.map +-- >>> adjust setmapped (+1) (fromList [1,2,3,4]) +-- fromList [2,3,4,5] +setmapped :: Setter IntSet IntSet Int Int +setmapped = sets IntSet.map -- | Construct an 'IntSet' from a 'Getter', 'Fold', 'Traversal', 'Lens' or 'Iso'. -- @@ -50,4 +58,4 @@ -- > setOf :: Lens a b Int d -> a -> IntSet -- > setOf :: Traversal a b Int d -> a -> IntSet setOf :: Getting IntSet a b Int d -> a -> IntSet -setOf l = getConst . l (Const . IntSet.singleton) +setOf l = runAccessor . l (Accessor . IntSet.singleton) diff --git a/src/Data/List/Lens.hs b/src/Data/List/Lens.hs --- a/src/Data/List/Lens.hs +++ b/src/Data/List/Lens.hs @@ -1,4 +1,6 @@ {-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | @@ -19,6 +21,8 @@ , _init , interspersed , intercalated + -- * Traversals + , traverseList , traverseHead , traverseTail , traverseInit @@ -31,8 +35,8 @@ -- | A lens reading and writing to the head of a /non-empty/ list -- --- > ghci> [1,2,3]^._head --- > 1 +-- >>> [1,2,3]^._head +-- 1 _head :: Simple Lens [a] a _head _ [] = error "_head: empty list" _head f (a:as) = (:as) <$> f a @@ -40,14 +44,17 @@ -- | A lens reading and writing to the tail of a /non-empty/ list -- --- > ghci> _tail <~ [3,4,5] $ [1,2] --- > [1,3,4,5] +-- >>> _tail .~ [3,4,5] $ [1,2] +-- [1,3,4,5] _tail :: Simple Lens [a] [a] _tail _ [] = error "_tail: empty list" _tail f (a:as) = (a:) <$> f as {-# INLINE _tail #-} -- | A lens reading and writing to the last element of a /non-empty/ list +-- +-- >>> [1,2]^._last +-- 2 _last :: Simple Lens [a] a _last _ [] = error "_last: empty list" _last f [a] = return <$> f a @@ -55,6 +62,9 @@ {-# INLINE _last #-} -- | A lens reading and replacing all but the a last element of a /non-empty/ list +-- +-- >>> [1,2,3,4]^._init +-- [1,2,3] _init :: Simple Lens [a] [a] _init _ [] = error "_init: empty list" _init f as = (++ [Prelude.last as]) <$> f (Prelude.init as) @@ -62,8 +72,8 @@ -- | Obtain a version of the list with the supplied value interspersed. -- --- > ghci> "abcde"^.interspersed ',' --- > "a,b,c,d,e" +-- >>> "abcde"^.interspersed ',' +-- "a,b,c,d,e" -- -- > xs^.interspersed a = intersperse a xs interspersed :: a -> Getter [a] [a] @@ -75,35 +85,67 @@ intercalated = to . intercalate {-# INLINE intercalated #-} +-- | Indexed traversal of a list. The position in the list is available as the index. +traverseList :: IndexedTraversal Int [a] [b] a b +traverseList = index $ go (0::Int) where + go !n f (x:xs) = (:) <$> f n x <*> go (n + 1) f xs + go _ _ [] = pure [] +{-# INLINE traverseList #-} + -- | The traversal for reading and writing to the head of a list -- +-- The position of the head in the original list (0) is available as the index. +-- +-- >>> traverseHead +~ 1 $ [1,2,3] +-- [2,2,3] +-- -- > traverseHead :: Applicative f => (a -> f a) -> [a] -> f [a] -traverseHead :: SimpleTraversal [a] a -traverseHead _ [] = pure [] -traverseHead f (a:as) = (:as) <$> f a +traverseHead :: SimpleIndexedTraversal Int [a] a +traverseHead = index $ \f aas -> case aas of + [] -> pure [] + (a:as) -> (:as) <$> f (0::Int) a {-# INLINE traverseHead #-} -- | Traversal for editing the tail of a list. -- +-- The position of each element /in the original list/ is available as the index. +-- +-- >>> traverseTail +~ 1 $ [1,2,3] +-- [1,3,4] +-- -- > traverseTail :: Applicative f => (a -> f a) -> [a] -> f [a] -traverseTail :: SimpleTraversal [a] a -traverseTail _ [] = pure [] -traverseTail f (a:as) = (a:) <$> traverse f as +traverseTail :: SimpleIndexedTraversal Int [a] a +traverseTail = index $ \f aas -> case aas of + [] -> pure [] + (a:as) -> (a:) <$> traverseWithIndexOf traverseList (f . (+1)) as {-# INLINE traverseTail #-} -- | Traverse the last element in a list. -- +-- The position of the last element in the original list is available as the index. +-- +-- >>> traverseLast +~ 1 $ [1,2,3] +-- [1,2,4] +-- -- > traverseLast :: Applicative f => (a -> f a) -> [a] -> f [a] -traverseLast :: SimpleTraversal [a] a -traverseLast _ [] = pure [] -traverseLast f [a] = return <$> f a -traverseLast f (a:as) = (a:) <$> traverseLast f as +traverseLast :: SimpleIndexedTraversal Int [a] a +traverseLast = index $ \f xs0 -> let + go [a] n = return <$> f n a + go (a:as) n = (a:) <$> (go as $! n + 1) + go [] _ = pure [] + in go xs0 (0::Int) where {-# INLINE traverseLast #-} -- | Traverse all but the last element of a list -- +-- The position of each element is available as the index. +-- +-- >>> traverseInit +~ 1 $ [1,2,3] +-- [2,3,3] +-- -- > traverseInit :: Applicative f => (a -> f a) -> [a] -> f [a] -traverseInit :: SimpleTraversal [a] a -traverseInit _ [] = pure [] -traverseInit f as = (++ [Prelude.last as]) <$> traverse f (Prelude.init as) +traverseInit :: SimpleIndexedTraversal Int [a] a +traverseInit = index $ \f aas -> case aas of + [] -> pure [] + as -> (++ [Prelude.last as]) <$> traverseWithIndexOf traverseList f (Prelude.init as) {-# INLINE traverseInit #-} 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,5 +1,7 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LiberalTypeSynonyms #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Map.Lens @@ -12,20 +14,29 @@ ---------------------------------------------------------------------------- module Data.Map.Lens ( at + , traverseMap , traverseAt , traverseAtMin , traverseAtMax ) where import Control.Applicative as Applicative -import Control.Lens +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 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'. -- --- > ghci> Map.fromList [("hello",12)] ^.at "hello" --- > Just 12 +-- >>> Map.fromList [("hello",12)] ^.at "hello" +-- Just 12 -- +-- >>> at 10 .~ Just "hello" $ Map.empty +-- 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 @@ -33,6 +44,10 @@ go (Just v') = Map.insert k v' m {-# INLINE at #-} +-- | Traversal of a 'Map' indexed by the key. +traverseMap :: IndexedTraversal k (Map k v) (Map k v') v v' +traverseMap = index $ \f -> sequenceA . mapWithKey f + -- | Traverse the value at a given key in a Map -- -- > traverseAt :: (Applicative f, Ord k) => k -> (v -> f v) -> Map k v -> f (Map k v) @@ -41,16 +56,20 @@ traverseAt k = at k . traverse {-# INLINE traverseAt #-} --- | Traverse the value at the minimum key in a Map -traverseAtMin :: SimpleTraversal (Map k v) v -traverseAtMin f m = case Map.minView m of - Just (a, _) -> (\v -> Map.updateMin (const (Just v)) m) <$> f a - Nothing -> pure m +-- | Traverse the value at the minimum key in a Map. +-- +-- The key of the minimum element is available as the index of the traversal. +traverseAtMin :: SimpleIndexedTraversal k (Map k v) v +traverseAtMin = index $ \f m -> case Map.minViewWithKey m of + Just ((k, a), _) -> (\v -> Map.updateMin (const (Just v)) m) <$> f k a + Nothing -> pure m {-# INLINE traverseAtMin #-} --- | Traverse the value at the maximum key in a Map -traverseAtMax :: SimpleTraversal (Map k v) v -traverseAtMax f m = case Map.maxView m of - Just (a, _) -> (\v -> Map.updateMax (const (Just v)) m) <$> f a - Nothing -> pure m +-- | Traverse the value at the maximum key in a Map. +-- +-- The key of the maximum element is available as the index of the traversal. +traverseAtMax :: SimpleIndexedTraversal k (Map k v) v +traverseAtMax = index $ \f m -> case Map.maxViewWithKey m of + Just ((k, a), _) -> (\v -> Map.updateMax (const (Just v)) m) <$> f k a + Nothing -> pure m {-# INLINE traverseAtMax #-} diff --git a/src/Data/Pair/Lens.hs b/src/Data/Pair/Lens.hs --- a/src/Data/Pair/Lens.hs +++ b/src/Data/Pair/Lens.hs @@ -27,8 +27,6 @@ -- | This provides a 'Traversal' that checks a predicate on a key before -- allowing you to traverse into a value. -value :: (k -> Bool) -> Simple Traversal (k, v) v -value p f kv@(k,v) - | p k = (,) k <$> f v - | otherwise = pure kv +value :: (k -> Bool) -> SimpleIndexedTraversal k (k, v) v +value p = index $ \ f kv@(k,v) -> if p k then (,) k <$> f k v else pure kv {-# INLINE value #-} 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,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Set.Lens @@ -10,18 +11,21 @@ ---------------------------------------------------------------------------- module Data.Set.Lens ( contains - , members + , setmapped , setOf ) where import Control.Applicative -import Control.Lens +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' -- --- > ghci> contains 3 +~ False $ Set.fromList [1,2,3,4] --- > fromList [1,2,4] +-- >>> contains 3 .~ False $ Set.fromList [1,2,3,4] +-- fromList [1,2,4] -- -- > contains :: Ord k => k -> (Bool -> f Bool) -> Set k -> f (Set k) contains :: Ord k => k -> Simple Lens (Set k) Bool @@ -36,17 +40,20 @@ -- 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'. -- --- > ghci> adjust members (+1) (fromList [1,2,3,4] --- > fromList [2,3,4,5] -members :: (Ord i, Ord j) => Setter (Set i) (Set j) i j -members = sets Set.map +-- >>> 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 +setmapped = sets Set.map -- | Construct a set from a 'Getter', 'Fold', 'Traversal', 'Lens' or 'Iso'. -- +-- >>> setOf (folded._2) [("hello",1),("world",2),("!!!",3)] +-- fromList [1,2,3] +-- -- > setOf :: Getter a c -> a -> Set c -- > setOf :: Ord c => Fold a c -> a -> Set c -- > setOf :: Iso a b c d -> a -> Set c -- > setOf :: Lens a b c d -> a -> Set c -- > setOf :: Ord c => Traversal a b c d -> a -> Set c setOf :: Getting (Set c) a b c d -> a -> Set c -setOf l = getConst . l (Const . Set.singleton) +setOf l = runAccessor . l (Accessor . Set.singleton) diff --git a/src/Data/Tree/Lens.hs b/src/Data/Tree/Lens.hs --- a/src/Data/Tree/Lens.hs +++ b/src/Data/Tree/Lens.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Tree.Lens @@ -5,7 +6,7 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional --- Portability : portable +-- Portability : MTPCs -- ---------------------------------------------------------------------------- @@ -16,12 +17,16 @@ import Control.Lens import Data.Functor +import Data.List.Lens import Data.Tree -- | A 'Lens' that focuses on the root of a 'Tree'. root :: Simple Lens (Tree a) a root f (Node a as) = (`Node` as) <$> f a +{-# INLINE root #-} --- | A 'Traversal' of the direct descendants of the root of a 'Tree'. -children :: Simple Traversal (Tree a) (Tree a) -children f (Node a as) = Node a <$> traverse f as +-- | A 'Traversal' of the direct descendants of the root of a 'Tree' +-- indexed by its position in the list of children +children :: SimpleIndexedTraversal Int (Tree a) (Tree a) +children = index $ \ f (Node a as) -> Node a <$> traverseWithIndexOf traverseList f as +{-# INLINE children #-} 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 @@ -1,3 +1,6 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LiberalTypeSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Generics.Lens @@ -9,17 +12,73 @@ -- ---------------------------------------------------------------------------- module GHC.Generics.Lens - ( generic + ( + -- * Conversion to/from generic + generic , generic1 + -- * Generic Traversal + , every + , GTraversal ) where -import Control.Lens hiding (from, to) +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 -- | Convert from the data type to its representation (or back) +-- +-- >>> "hello"^.generic.from generic +-- "hello" +-- generic :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b y) generic = isos from to from 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 + +-- | Traverse using GHC.Generics. +-- +-- >>> allOf every (=="Hello") (1::Int,2::Double,(),"Hello",["Hello"]) +-- True +-- +-- >>> mapMOf_ every putStrLn ("hello",[(2 :: Int, "world!")]) +-- hello +-- world! +every :: (Generic a, GTraversal (Rep a), Typeable b) => Simple Traversal a b +every = generic . everyr True + +-- | Traversable generic data types. Used by 'every'. +class GTraversal f where + everyr :: Typeable b => Bool -> Simple Traversal (f a) b + +instance (Generic a, GTraversal (Rep a), Typeable a) => GTraversal (K1 i a) where + everyr rec f (K1 a) = case cast a `maybeArg1Of` f of + Just b -> K1 . fromJust . cast <$> f b + Nothing | rec -> K1 <$> fmap generic (everyr False) f a + | otherwise -> pure $ K1 a + where + maybeArg1Of :: Maybe c -> (c -> d) -> Maybe c + maybeArg1Of = const + +instance GTraversal U1 where + everyr _ _ U1 = pure U1 + +instance (GTraversal f, GTraversal g) => GTraversal (f :*: g) where + everyr _ f (x :*: y) = (:*:) <$> everyr True f x <*> everyr True f y + +instance (GTraversal f, GTraversal g) => GTraversal (f :+: g) where + everyr _ f (L1 x) = L1 <$> everyr True f x + everyr _ f (R1 x) = R1 <$> everyr True f x + +instance GTraversal a => GTraversal (M1 i c a) where + everyr rec f (M1 x) = M1 <$> everyr rec f x + +-- ? +instance (Traversable f, GTraversal g) => GTraversal (f :.: g) where + everyr _ f (Comp1 fgp) = Comp1 <$> traverse (everyr True f) fgp + diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs @@ -19,7 +19,10 @@ ) where import Control.Applicative -import Control.Lens +import Control.Lens.Getter +import Control.Lens.Setter +import Control.Lens.Type +import Control.Lens.Traversal import Data.Map as Map hiding (toList,map) import Data.Map.Lens import Data.Maybe (fromMaybe) diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,16 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "-isrc" + , "-idist/build/autogen" + , "-optP-include", "-optPdist/build/autogen/cabal_macros.h" + , "src/Control/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" + ]