diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -2,6 +2,7 @@ before_install: # Uncomment whenever hackage is down. # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update + - cabal update # Try installing some of the build-deps with apt-get for speed. - travis/cabal-apt-install $mode @@ -12,6 +13,7 @@ script: - $script && hlint src --cpp-define HLINT + - scripts/stats notifications: irc: diff --git a/AUTHORS.markdown b/AUTHORS.markdown --- a/AUTHORS.markdown +++ b/AUTHORS.markdown @@ -35,6 +35,7 @@ * Yair Chuchem [@yairchu](https://github.com/yairchu) * [Michael Thompson](mailto:what_is_it_to_do_anything@yahoo.com) [@michaelt](https://github.com/michaelt) * [John Wiegley](mailto:johnw@newartisans.com) [@jwiegley](https://github.com/jwiegley) +* [Jonathan Fischoff](mailto:jfischoff@yahoo.com) [@jfischoff](https://github.com/jfischoff) You can watch them carry on the quest for bragging rights in the [contributors graph](https://github.com/ekmett/lens/graphs/contributors). diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,18 @@ +3.9 +----- +* Changed `Getting` to take 3 arguments instead of 5. If you need the old behavior for portability you can use + `Overloaded (Accessor r) s t a b` instead of `Getting r s t a b` and it'll work consistently back through the last few releases. +* Added `involuted` to `Control.Lens.Iso`. +* Factored out a common `reversed` definition from all the various forms of it around the library and placed it in `Control.Lens.Iso`. +* Added `binary`, `octal`, `decimal` and `hex` to `Numeric.Lens`. +* Added `sans` to `Control.Lens.At`. +* Improved interoperability: + * Reimplemented `Gettable` as an alias for `Contravariant` and `Functor` together to derive `Getter` and `Fold`. This means you can now + implement a `Getter` or `Fold` with only a Haskell 98 dependency (`contravariant`). + * Removed `Reviewable`. We now use `Bifunctor` and `Profunctor` together to derive `Review`. This means you can now implement a `Review` + with Haskell 98 dependencies (`profunctors` and `bifunctors`). + * These changes enables more types to be defined without incurring a dependency on the `lens` package. + 3.8.7.0-3.8.7.3 [maintenance releases] ----- * Fixes to dependencies and pragmas. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -71,7 +71,7 @@ ```haskell ghci> _1 .~ "hello" $ ((),"world") -("hello","world) +("hello","world") ``` Conversely `view`, can be used as a prefix alias for `(^.)`. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -5,14 +5,15 @@ import Data.List ( nub ) import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity, normal ) import System.FilePath ( () ) main :: IO () @@ -20,7 +21,17 @@ { buildHook = \pkg lbi hooks flags -> do generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi buildHook simpleUserHooks pkg lbi hooks flags + , postHaddock = \args flags pkg lbi -> do + copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")] + postHaddock simpleUserHooks args flags pkg lbi } + +haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath +haddockOutputDir flags pkg = destDir where + baseDir = case haddockDistPref flags of + NoFlag -> "." + Flag x -> x + destDir = baseDir "doc" "html" display (packageName pkg) generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () generateBuildModule verbosity pkg lbi = do diff --git a/examples/Pong.hs b/examples/Pong.hs --- a/examples/Pong.hs +++ b/examples/Pong.hs @@ -111,7 +111,7 @@ p <- get let paddleMovement = time * paddleSpeed - keyPressed key = p^.keys.ix (SpecialKey key) + keyPressed key = p^.keys.contains (SpecialKey key) -- Update the player's paddle based on keys when (keyPressed KeyUp) $ paddle1 += paddleMovement @@ -205,7 +205,7 @@ -- Handle input by simply updating the keys set handle :: Event -> Pong -> Pong -handle (EventKey k s _ _) = keys.ix k .~ (s == Down) +handle (EventKey k s _ _) = keys.contains k .~ (s == Down) handle _ = id -- The main program action diff --git a/images/Hierarchy.png b/images/Hierarchy.png new file mode 100644 Binary files /dev/null and b/images/Hierarchy.png differ diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses -version: 3.8.7.3 +version: 3.9 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -37,7 +37,7 @@ . The core of the hierarchy of lens-like constructions looks like: . - <> + <> . You can compose any two elements of the hierarchy above using @(.)@ from the @Prelude@, and you can use any element of the hierarchy as any type it linked to above it. @@ -91,6 +91,7 @@ examples/*.hs examples/*.lhs examples/bf-examples/*.bf + images/*.png travis/cabal-apt-install travis/config AUTHORS.markdown @@ -167,7 +168,7 @@ comonad >= 3 && < 4, comonad-transformers >= 3 && < 4, comonads-fd >= 3 && < 4, - contravariant >= 0.2.0.2 && < 1, + contravariant >= 0.3 && < 1, containers >= 0.4.0 && < 0.6, distributive >= 0.3 && < 1, filepath >= 1.2.0.0 && < 1.4, @@ -180,7 +181,7 @@ profunctors >= 3.2 && < 4, profunctor-extras >= 3.3 && < 4, reflection >= 1.1.6 && < 2, - semigroupoids >= 3 && < 4, + semigroupoids >= 3.0.2 && < 4, semigroups >= 0.8.4 && < 1, split == 0.2.*, tagged >= 0.4.4 && < 1, diff --git a/src/Control/Exception/Lens.hs b/src/Control/Exception/Lens.hs --- a/src/Control/Exception/Lens.hs +++ b/src/Control/Exception/Lens.hs @@ -126,11 +126,11 @@ -- the desired 'Exception'. -- -- @ --- 'exception' :: ('Applicative' f, 'Exception' a, 'Exception' b) --- => (a -> f b) -> 'SomeException' -> f 'SomeException' +-- 'exception' :: ('Applicative' f, 'Exception' a) +-- => (a -> f a) -> 'SomeException' -> f 'SomeException' -- @ exception :: Exception a => Prism' SomeException a -exception = prism toException $ \ e -> maybe (Left e) Right $ fromException e +exception = prism' toException fromException {-# INLINE exception #-} ------------------------------------------------------------------------------ @@ -150,7 +150,7 @@ -- 'catching' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> (a -> m r) -> m r -- @ -catching :: MonadCatchIO m => Getting (First a) SomeException t a b -> m r -> (a -> m r) -> m r +catching :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} @@ -170,7 +170,7 @@ -- 'catching_' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> m r -> m r -- 'catching_' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> m r -> m r -- @ -catching_ :: MonadCatchIO m => Getting (First a) SomeException t a b -> m r -> m r -> m r +catching_ :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) {-# INLINE catching_ #-} @@ -199,7 +199,7 @@ -- 'handling' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> (a -> m r) -> m r -> m r -- @ -handling :: MonadCatchIO m => Getting (First a) SomeException t a b -> (a -> m r) -> m r -> m r +handling :: MonadCatchIO m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} @@ -217,7 +217,7 @@ -- 'handling_' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> m r -> m r -- 'handling_' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> m r -> m r -- @ -handling_ :: MonadCatchIO m => Getting (First a) SomeException t a b -> m r -> m r -> m r +handling_ :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} @@ -237,7 +237,7 @@ -- 'trying' :: 'MonadCatchIO' m => 'Getter' 'SomeException' a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadCatchIO' m => 'Fold' 'SomeException' a -> m r -> m ('Either' a r) -- @ -trying :: MonadCatchIO m => Getting (First a) SomeException t a b -> m r -> m (Either a r) +trying :: MonadCatchIO m => Getting (First a) SomeException a -> m r -> m (Either a r) trying l = tryJust (preview l) -- | A helper version of 'Control.Exception.try' that doesn't needlessly require 'Functor'. diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -37,7 +37,7 @@ -- -- -- --- <> +-- <> ---------------------------------------------------------------------------- module Control.Lens ( module Control.Lens.Action diff --git a/src/Control/Lens/Action.hs b/src/Control/Lens/Action.hs --- a/src/Control/Lens/Action.hs +++ b/src/Control/Lens/Action.hs @@ -91,6 +91,9 @@ {-# INLINE (^!) #-} -- | Perform a 'MonadicFold' and collect all of the results in a list. +-- +-- >>> ["ab","cd","ef"]^!!folded.acts +-- ["ace","acf","ade","adf","bce","bcf","bde","bdf"] (^!!) :: Monad m => s -> Acting m [a] s t a b -> m [a] a ^!! l = getEffect (l (Effect #. return . return) a) {-# INLINE (^!!) #-} @@ -98,6 +101,11 @@ -- | Perform a 'MonadicFold' and collect the leftmost result. -- -- /Note:/ this still causes all effects for all elements. +-- +-- >>> [Just 1, Just 2, Just 3]^!?folded.acts +-- Just (Just 1) +-- >>> [Just 1, Nothing]^!?folded.acts +-- Nothing (^!?) :: Monad m => s -> Acting m (Leftmost a) s t a b -> m (Maybe a) a ^!? l = liftM getLeftmost .# getEffect $ l (Effect #. return . LLeaf) a {-# INLINE (^!?) #-} diff --git a/src/Control/Lens/At.hs b/src/Control/Lens/At.hs --- a/src/Control/Lens/At.hs +++ b/src/Control/Lens/At.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} #ifdef DEFAULT_SIGNATURES {-# LANGUAGE DefaultSignatures #-} @@ -31,7 +32,7 @@ module Control.Lens.At ( -- * At - At(at) + At(at), sans -- * Ixed , IxValue , Ixed(ix) @@ -50,6 +51,7 @@ import Control.Lens.Fold import Control.Lens.Getter import Control.Lens.Indexed as Lens +import Control.Lens.Setter import Control.Lens.Type import Control.Lens.Traversal import Data.Array.IArray as Array @@ -89,7 +91,7 @@ _at, resultAt :: Ixed f m => Index m -> IndexedLensLike' (Index m) f m (IxValue m) _at = ix resultAt = ix -{-# DEPRECATED _at, resultAt "use 'ix'. This function will be removed in version 3.9" #-} +{-# DEPRECATED _at, resultAt "use 'ix'. This function will be removed after GHC 7.8 is released." #-} -- | -- This class provides a simple 'IndexedFold' (or 'IndexedTraversal') that lets you view (and modify) @@ -106,18 +108,18 @@ -- fromList [1,2,4] contains :: Index m -> IndexedLensLike' (Index m) f m Bool #ifdef DEFAULT_SIGNATURES - default contains :: (Gettable f, At m) => Index m -> IndexedLensLike' (Index m) f m Bool + default contains :: (Contravariant f, Functor f, At m) => Index m -> IndexedLensLike' (Index m) f m Bool contains = containsAt #endif -- | A definition of 'contains' for types with an 'Ix' instance. -containsIx :: (Gettable f, Ixed (Accessor Any) m) => Index m -> IndexedLensLike' (Index m) f m Bool +containsIx :: (Contravariant f, Functor f, Ixed (Accessor Any) m) => Index m -> IndexedLensLike' (Index m) f m Bool containsIx i f = coerce . Lens.indexed f i . has (ix i) {-# INLINE containsIx #-} -- | A definition of 'ix' for types with an 'At' instance. This is the default -- if you don't specify a definition for 'contains' and you are on GHC >= 7.0.2 -containsAt :: (Gettable f, At m) => Index m -> IndexedLensLike' (Index m) f m Bool +containsAt :: (Contravariant f, Functor f, At m) => Index m -> IndexedLensLike' (Index m) f m Bool containsAt i f = coerce . Lens.indexed f i . views (at i) isJust {-# INLINE containsAt #-} @@ -141,7 +143,7 @@ containsLookup isb = \i pafb s -> coerce $ Lens.indexed pafb (i :: i) (isJust (isb i s)) {-# INLINE containsLookup #-} -instance Gettable f => Contains f (e -> a) where +instance (Functor f, Contravariant f) => Contains f (e -> a) where contains i f _ = coerce (Lens.indexed f i True) {-# INLINE contains #-} @@ -160,118 +162,119 @@ if b then HashSet.insert k s else HashSet.delete k s {-# INLINE contains #-} -instance Gettable f => Contains f [a] where +instance (Contravariant f, Functor f) => Contains f [a] where contains = containsLength Prelude.length {-# INLINE contains #-} -instance Gettable f => Contains f (Seq a) where +instance (Contravariant f, Functor f) => Contains f (Seq a) where contains = containsLength Seq.length {-# INLINE contains #-} #if MIN_VERSION_base(4,4,0) -instance Gettable f => Contains f (Complex a) where +instance (Contravariant f, Functor f) => Contains f (Complex a) where contains = containsN 2 {-# INLINE contains #-} #else -instance (Gettable f, RealFloat a) => Contains f (Complex a) where +instance (Contravariant f, Functor f, RealFloat a) => Contains f (Complex a) where contains = containsN 2 {-# INLINE contains #-} #endif -instance Gettable f => Contains f (Tree a) where +instance (Contravariant f, Functor f) => Contains f (Tree a) where contains xs0 pafb = coerce . Lens.indexed pafb xs0 . go xs0 where go [] (Node _ _) = True - go (i:is) (Node _ as) = goto i is as + go (i:is) (Node _ as) | i < 0 = False + | otherwise = goto i is as goto 0 is (a:_) = go is a goto _ _ [] = False goto n is (_:as) = (goto $! n - 1) is as {-# INLINE contains #-} -instance Gettable k => Contains k (Identity a) where +instance (Contravariant k, Functor k) => Contains k (Identity a) where contains () f _ = coerce (Lens.indexed f () True) {-# INLINE contains #-} -instance Gettable k => Contains k (a,b) where +instance (Contravariant k, Functor k) => Contains k (a,b) where contains = containsN 2 {-# INLINE contains #-} -instance Gettable k => Contains k (a,b,c) where +instance (Contravariant k, Functor k) => Contains k (a,b,c) where contains = containsN 3 {-# INLINE contains #-} -instance Gettable k => Contains k (a,b,c,d) where +instance (Contravariant k, Functor k) => Contains k (a,b,c,d) where contains = containsN 4 {-# INLINE contains #-} -instance Gettable k => Contains k (a,b,c,d,e) where +instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e) where contains = containsN 5 {-# INLINE contains #-} -instance Gettable k => Contains k (a,b,c,d,e,f) where +instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f) where contains = containsN 6 {-# INLINE contains #-} -instance Gettable k => Contains k (a,b,c,d,e,f,g) where +instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f,g) where contains = containsN 7 {-# INLINE contains #-} -instance Gettable k => Contains k (a,b,c,d,e,f,g,h) where +instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f,g,h) where contains = containsN 8 {-# INLINE contains #-} -instance Gettable k => Contains k (a,b,c,d,e,f,g,h,i) where +instance (Contravariant k, Functor k) => Contains k (a,b,c,d,e,f,g,h,i) where contains = containsN 9 {-# INLINE contains #-} -instance Gettable k => Contains k (IntMap a) where +instance (Contravariant k, Functor k) => Contains k (IntMap a) where contains = containsLookup IntMap.lookup {-# INLINE contains #-} -instance (Gettable f, Ord k) => Contains f (Map k a) where +instance (Contravariant f, Functor f, Ord k) => Contains f (Map k a) where contains = containsLookup Map.lookup {-# INLINE contains #-} -instance (Gettable f, Eq k, Hashable k) => Contains f (HashMap k a) where +instance (Contravariant f, Functor f, Eq k, Hashable k) => Contains f (HashMap k a) where contains = containsLookup HashMap.lookup {-# INLINE contains #-} -instance (Gettable f, Ix i) => Contains f (Array i e) where +instance (Contravariant f, Functor f, Ix i) => Contains f (Array i e) where contains = containsTest $ \i s -> inRange (bounds s) i {-# INLINE contains #-} -instance (Gettable f, IArray UArray e, Ix i) => Contains f (UArray i e) where +instance (Contravariant f, Functor f, IArray UArray e, Ix i) => Contains f (UArray i e) where contains = containsTest $ \i s -> inRange (bounds s) i {-# INLINE contains #-} -instance Gettable f => Contains f (Vector.Vector a) where +instance (Contravariant f, Functor f) => Contains f (Vector.Vector a) where contains = containsLength Vector.length {-# INLINE contains #-} -instance (Gettable f, Prim a) => Contains f (Prim.Vector a) where +instance (Contravariant f, Functor f, Prim a) => Contains f (Prim.Vector a) where contains = containsLength Prim.length {-# INLINE contains #-} -instance (Gettable f, Storable a) => Contains f (Storable.Vector a) where +instance (Contravariant f, Functor f, Storable a) => Contains f (Storable.Vector a) where contains = containsLength Storable.length {-# INLINE contains #-} -instance (Gettable f, Unbox a) => Contains f (Unboxed.Vector a) where +instance (Contravariant f, Functor f, Unbox a) => Contains f (Unboxed.Vector a) where contains = containsLength Unboxed.length {-# INLINE contains #-} -instance Gettable f => Contains f StrictT.Text where +instance (Contravariant f, Functor f) => Contains f StrictT.Text where contains = containsTest $ \i s -> StrictT.compareLength s i == GT {-# INLINE contains #-} -instance Gettable f => Contains f LazyT.Text where +instance (Contravariant f, Functor f) => Contains f LazyT.Text where contains = containsTest $ \i s -> LazyT.compareLength s i == GT {-# INLINE contains #-} -instance Gettable f => Contains f StrictB.ByteString where +instance (Contravariant f, Functor f) => Contains f StrictB.ByteString where contains = containsLength StrictB.length {-# INLINE contains #-} -instance Gettable f => Contains f LazyB.ByteString where +instance (Contravariant f, Functor f) => Contains f LazyB.ByteString where contains = containsTest $ \i s -> not (LazyB.null (LazyB.drop i s)) {-# INLINE contains #-} @@ -280,7 +283,7 @@ -- | This simple 'IndexedTraversal' lets you 'traverse' the value at a given -- key in a 'Map' or element at an ordinal position in a list or 'Seq'. -class (Functor f, Contains (Accessor (IxValue m)) m) => Ixed f m where +class Functor f => Ixed f m where -- | This simple 'IndexedTraversal' lets you 'traverse' the value at a given -- key in a 'Map' or element at an ordinal position in a list or 'Seq'. -- @@ -320,7 +323,8 @@ type instance IxValue [a] = a instance Applicative f => Ixed f [a] where - ix k f xs0 = go xs0 k where + ix k f xs0 | k < 0 = pure xs0 + | otherwise = go xs0 k where go [] _ = pure [] go (a:as) 0 = Lens.indexed f k a <&> (:as) go (a:as) i = (a:) <$> (go as $! i - 1) @@ -335,7 +339,8 @@ instance Applicative f => Ixed f (Tree a) where ix xs0 f = go xs0 where go [] (Node a as) = Lens.indexed f xs0 a <&> \a' -> Node a' as - go (i:is) (Node a as) = Node a <$> goto is as i + go (i:is) t@(Node a as) | i < 0 = pure t + | otherwise = Node a <$> goto is as i goto is (a:as) 0 = go is a <&> (:as) goto is (_:as) n = goto is as $! n - 1 goto _ [] _ = pure [] @@ -530,6 +535,10 @@ -- /Note:/ 'Map'-like containers form a reasonable instance, but not 'Array'-like ones, where -- you cannot satisfy the 'Lens' laws. at :: Index m -> IndexedLens' (Index m) m (Maybe (IxValue m)) + +sans :: At m => Index m -> m -> m +sans k m = m & at k .~ Nothing +{-# INLINE sans #-} instance At (IntMap a) where at k f m = Lens.indexed f k mv <&> \r -> case r of diff --git a/src/Control/Lens/Cons.hs b/src/Control/Lens/Cons.hs --- a/src/Control/Lens/Cons.hs +++ b/src/Control/Lens/Cons.hs @@ -155,6 +155,7 @@ -- | 'cons' an element onto a container. cons :: Cons Reviewed Identity s s a a => a -> s -> s cons = curry (simply review _Cons) +{-# INLINE cons #-} -- | Attempt to extract the left-most element from a container, and a version of the container without that element. uncons :: Cons (->) (Accessor (First (a, s))) s s a a => s -> Maybe (a, s) @@ -274,7 +275,7 @@ -- | Most of the time this is a 'Prism'. -- -- @ - -- '_Snoc' :: 'Prism' [a] [b] (a, [a]) (b, [b]) + -- '_Snoc' :: 'Prism' [a] [b] ([a], a) ([b], b) -- '_Snoc' :: 'Prism' ('Seq' a) ('Seq' b) ('Seq' a, a) ('Seq' b, b) -- '_Snoc' :: 'Prism' ('Vector' a) ('Vector' b) ('Vector' a, a) ('Vector' b, b) -- '_Snoc' :: 'Prism'' 'String' ('String', 'Char') @@ -376,9 +377,9 @@ -- "" -- -- @ --- '_init' :: 'Traversal'' [a] a --- '_init' :: 'Traversal'' ('Seq' a) a --- '_init' :: 'Traversal'' ('Vector' a) a +-- '_init' :: 'Traversal'' [a] [a] +-- '_init' :: 'Traversal'' ('Seq' a) ('Seq' a) +-- '_init' :: 'Traversal'' ('Vector' a) ('Vector' a) -- @ _init :: Snoc (->) f s s a a => LensLike' f s s _init = _Snoc._1 @@ -419,9 +420,9 @@ -- fromList "abcdQ" -- -- @ --- '_last' :: 'Traversal'' [a] [a] --- '_last' :: 'Traversal'' ('Seq' a) ('Seq' a) --- '_last' :: 'Traversal'' ('Vector' a) ('Vector' a) +-- '_last' :: 'Traversal'' [a] a +-- '_last' :: 'Traversal'' ('Seq' a) a +-- '_last' :: 'Traversal'' ('Vector' a) a -- @ _last :: Snoc (->) f s s a a => LensLike' f s a _last = _Snoc._2 diff --git a/src/Control/Lens/Each.hs b/src/Control/Lens/Each.hs --- a/src/Control/Lens/Each.hs +++ b/src/Control/Lens/Each.hs @@ -203,7 +203,7 @@ where f' = Lens.indexed f {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' ('Map' c a) ('Map' c b) a b@ +-- | @'each' :: 'IndexedTraversal' c ('Map' c a) ('Map' c b) a b@ instance Applicative f => Each f (IntMap a) (IntMap b) a b where each f m = sequenceA $ IntMap.mapWithKey f' m where f' = Lens.indexed f @@ -219,12 +219,12 @@ each = traversed {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' ('Identity' a) ('Identity' b) a b@ +-- | @'each' :: 'IndexedTraversal' () ('Identity' a) ('Identity' b) a b@ instance Functor f => Each f (Identity a) (Identity b) a b where each f (Identity a) = Identity <$> Lens.indexed f () a {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' ('Maybe' a) ('Maybe' b) a b@ +-- | @'each' :: 'IndexedTraversal' () ('Maybe' a) ('Maybe' b) a b@ instance Applicative f => Each f (Maybe a) (Maybe b) a b where each f (Just a) = Just <$> Lens.indexed f () a each _ Nothing = pure Nothing @@ -274,12 +274,12 @@ each = iso LazyT.unpack LazyT.pack . traversed64 {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int' 'StrictB.ByteString' 'StrictB.ByteString' 'Char' 'Char'@ +-- | @'each' :: 'IndexedTraversal' 'Int' 'StrictB.ByteString' 'StrictB.ByteString' 'Word8' 'Word8'@ instance Applicative f => Each f StrictB.ByteString StrictB.ByteString Word8 Word8 where each = iso StrictB.unpack StrictB.pack . traversed {-# INLINE each #-} --- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyB.ByteString' 'LazyB.ByteString' 'Char' 'Char'@ +-- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyB.ByteString' 'LazyB.ByteString' 'Word8' 'Word8'@ instance Applicative f => Each f LazyB.ByteString LazyB.ByteString Word8 Word8 where each = iso LazyB.unpack LazyB.pack . traversed64 {-# INLINE each #-} @@ -294,7 +294,7 @@ each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> Lens.indexed f i a) (IArray.assocs arr) {-# INLINE each #-} --- | @'each' :: 'Control.Lens.IndexedSetter.IndexedSetter' i (i -> a) (i -> b) a b@ +-- | @'each' :: 'Control.Lens.IndexedSetter' i (i -> a) (i -> b) a b@ instance Settable f => Each f (i -> a) (i -> b) a b where each f g = pure (\i -> untaintedDot (Lens.indexed f i) (g i)) {-# INLINE each #-} diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs --- a/src/Control/Lens/Fold.hs +++ b/src/Control/Lens/Fold.hs @@ -6,6 +6,8 @@ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif + +{-# OPTIONS_GHC -fno-warn-orphans #-} ---------------------------------------------------------------------------- -- | -- Module : Control.Lens.Fold @@ -23,7 +25,7 @@ -- generalize this signature to @forall m. 'Monoid' m => (a -> m) -> s -> m@, -- and then decorate it with 'Accessor' to obtain -- --- @type 'Fold' s a = forall m. 'Monoid' m => 'Getting' m s s a a@ +-- @type 'Fold' s a = forall m. 'Monoid' m => 'Getting' m s a@ -- -- Every 'Getter' is a valid 'Fold' that simply doesn't use the 'Monoid' -- it is passed. @@ -134,7 +136,7 @@ import Control.Lens.Internal.Indexed import Control.Lens.Internal.Magma import Control.Lens.Type -import Control.Monad +import Control.Monad as Monad import Control.Monad.Reader import Control.Monad.State import Data.Foldable as Foldable @@ -177,7 +179,7 @@ -- -- >>> [1,2,3,4]^..folding tail -- [2,3,4] -folding :: (Foldable f, Applicative g, Gettable g) => (s -> f a) -> LensLike g s t a b +folding :: (Foldable f, Contravariant g, Applicative g) => (s -> f a) -> LensLike g s t a b folding sfa agb = coerce . traverse_ agb . sfa {-# INLINE folding #-} @@ -226,7 +228,7 @@ -- -- >>> timingOut $ [1,2,3]^..taking 7 (cycled traverse) -- [1,2,3,1,2,3,1] -cycled :: (Applicative f, Gettable f) => LensLike f s t a b -> LensLike f s t a b +cycled :: (Contravariant f, Applicative f) => LensLike f s t a b -> LensLike f s t a b cycled l f a = as where as = l f a *> as {-# INLINE cycled #-} @@ -338,7 +340,7 @@ -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingLens'' s a -> 'IndexPreservingFold' s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingGetter' s a -> 'IndexPreservingFold' s a -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingFold' s a -> 'IndexPreservingFold' s a --- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingAction' m s a -> 'IndexPreservingFold' m s a +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingAction' m s a -> 'IndexPreservingFold' s a -- @ -- -- @ @@ -350,7 +352,7 @@ -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- see notes -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a -- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a --- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedAction' i m s a -> 'IndexedFold' i m s a +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedAction' i m s a -> 'IndexedFold' i s a -- @ -- -- @ @@ -395,9 +397,9 @@ -- @ -- -- @ --- 'foldMapOf' :: 'Getting' r s t a b -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Getting' r s a -> (a -> r) -> s -> r -- @ -foldMapOf :: Profunctor p => Accessing p r s t a b -> p a r -> s -> r +foldMapOf :: Profunctor p => Accessing p r s a -> p a r -> s -> r foldMapOf l f = runAccessor #. l (Accessor #. f) {-# INLINE foldMapOf #-} @@ -417,7 +419,7 @@ -- 'foldOf' :: 'Monoid' m => 'Traversal'' s m -> s -> m -- 'foldOf' :: 'Monoid' m => 'Prism'' s m -> s -> m -- @ -foldOf :: Getting a s t a b -> s -> a +foldOf :: Getting a s a -> s -> a foldOf l = runAccessor #. l Accessor {-# INLINE foldOf #-} @@ -441,9 +443,9 @@ -- @ -- -- @ --- 'foldrOf' :: 'Getting' ('Endo' r) s t a b -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf' :: 'Getting' ('Endo' r) s a -> (a -> r -> r) -> r -> s -> r -- @ -foldrOf :: Profunctor p => Accessing p (Endo r) s t a b -> p a (r -> r) -> r -> s -> r +foldrOf :: Profunctor p => Accessing p (Endo r) s a -> p a (r -> r) -> r -> s -> r foldrOf l f z = flip appEndo z `rmap` foldMapOf l (Endo #. f) {-# INLINE foldrOf #-} @@ -461,7 +463,7 @@ -- 'foldlOf' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf' :: 'Prism'' s a -> (r -> a -> r) -> r -> s -> r -- @ -foldlOf :: Getting (Dual (Endo r)) s t a b -> (r -> a -> r) -> r -> s -> r +foldlOf :: Getting (Dual (Endo r)) s a -> (r -> a -> r) -> r -> s -> r foldlOf l f z = (flip appEndo z .# getDual) `rmap` foldMapOf l (Dual #. Endo #. flip f) {-# INLINE foldlOf #-} @@ -483,7 +485,7 @@ -- 'toListOf' :: 'Traversal'' s a -> s -> [a] -- 'toListOf' :: 'Prism'' s a -> s -> [a] -- @ -toListOf :: Getting (Endo [a]) s t a b -> s -> [a] +toListOf :: Getting (Endo [a]) s a -> s -> [a] toListOf l = foldrOf l (:) [] {-# INLINE toListOf #-} @@ -508,7 +510,7 @@ -- ('^..') :: s -> 'Traversal'' s a -> [a] -- ('^..') :: s -> 'Prism'' s a -> [a] -- @ -(^..) :: s -> Getting (Endo [a]) s t a b -> [a] +(^..) :: s -> Getting (Endo [a]) s a -> [a] s ^.. l = toListOf l s {-# INLINE (^..) #-} @@ -531,7 +533,7 @@ -- 'andOf' :: 'Traversal'' s 'Bool' -> s -> 'Bool' -- 'andOf' :: 'Prism'' s 'Bool' -> s -> 'Bool' -- @ -andOf :: Getting All s t Bool b -> s -> Bool +andOf :: Getting All s Bool -> s -> Bool andOf l = getAll #. foldMapOf l All {-# INLINE andOf #-} @@ -554,7 +556,7 @@ -- 'orOf' :: 'Traversal'' s 'Bool' -> s -> 'Bool' -- 'orOf' :: 'Prism'' s 'Bool' -> s -> 'Bool' -- @ -orOf :: Getting Any s t Bool b -> s -> Bool +orOf :: Getting Any s Bool -> s -> Bool orOf l = getAny #. foldMapOf l Any {-# INLINE orOf #-} @@ -582,7 +584,7 @@ -- 'anyOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'anyOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -anyOf :: Profunctor p => Accessing p Any s t a b -> p a Bool -> s -> Bool +anyOf :: Profunctor p => Accessing p Any s a -> p a Bool -> s -> Bool anyOf l f = getAny #. foldMapOf l (Any #. f) {-# INLINE anyOf #-} @@ -609,7 +611,7 @@ -- 'allOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' -- 'allOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' -- @ -allOf :: Profunctor p => Accessing p All s t a b -> p a Bool -> s -> Bool +allOf :: Profunctor p => Accessing p All s a -> p a Bool -> s -> Bool allOf l f = getAll #. foldMapOf l (All #. f) {-# INLINE allOf #-} @@ -635,7 +637,7 @@ -- 'productOf' :: 'Num' a => 'Traversal'' s a -> s -> a -- 'productOf' :: 'Num' a => 'Prism'' s a -> s -> a -- @ -productOf :: Num a => Getting (Endo (Endo a)) s t a b -> s -> a +productOf :: Num a => Getting (Endo (Endo a)) s a -> s -> a productOf l = foldlOf' l (*) 1 {-# INLINE productOf #-} @@ -659,7 +661,7 @@ -- want a lazier version use @'ala' 'Sum' '.' 'foldMapOf'@ -- -- @ --- 'sumOf' '_1' :: (a, b) -> a +-- 'sumOf' '_1' :: 'Num' a => (a, b) -> a -- 'sumOf' ('folded' '.' 'Control.Lens.Tuple._1') :: ('Foldable' f, 'Num' a) => f (a, b) -> a -- @ -- @@ -671,7 +673,7 @@ -- 'sumOf' :: 'Num' a => 'Traversal'' s a -> s -> a -- 'sumOf' :: 'Num' a => 'Prism'' s a -> s -> a -- @ -sumOf :: Num a => Getting (Endo (Endo a)) s t a b -> s -> a +sumOf :: Num a => Getting (Endo (Endo a)) s a -> s -> a sumOf l = foldlOf' l (+) 0 {-# INLINE sumOf #-} @@ -692,7 +694,7 @@ -- -- @ -- 'traverseOf_' '_2' :: 'Functor' f => (c -> f r) -> (d, c) -> f () --- 'traverseOf_' 'Data.Either.Lens.traverseLeft' :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f () +-- 'traverseOf_' 'Control.Lens.Prism._Left' :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f () -- @ -- -- @ @@ -709,7 +711,7 @@ -- 'traverseOf_' :: 'Applicative' f => 'Traversal'' s a -> (a -> f r) -> s -> f () -- 'traverseOf_' :: 'Applicative' f => 'Prism'' s a -> (a -> f r) -> s -> f () -- @ -traverseOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s t a b -> p a (f r) -> s -> f () +traverseOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> p a (f r) -> s -> f () traverseOf_ l f = void . getTraversed #. foldMapOf l (Traversed #. f) {-# INLINE traverseOf_ #-} @@ -742,7 +744,7 @@ -- 'forOf_' :: 'Applicative' f => 'Traversal'' s a -> s -> (a -> f r) -> f () -- 'forOf_' :: 'Applicative' f => 'Prism'' s a -> s -> (a -> f r) -> f () -- @ -forOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s t a b -> s -> p a (f r) -> f () +forOf_ :: (Profunctor p, Functor f) => Accessing p (Traversed r f) s a -> s -> p a (f r) -> f () forOf_ = flip . traverseOf_ {-# INLINE forOf_ #-} @@ -764,7 +766,7 @@ -- 'sequenceAOf_' :: 'Applicative' f => 'Traversal'' s (f a) -> s -> f () -- 'sequenceAOf_' :: 'Applicative' f => 'Prism'' s (f a) -> s -> f () -- @ -sequenceAOf_ :: Functor f => Getting (Traversed a f) s t (f a) b -> s -> f () +sequenceAOf_ :: Functor f => Getting (Traversed a f) s (f a) -> s -> f () sequenceAOf_ l = void . getTraversed #. foldMapOf l Traversed {-# INLINE sequenceAOf_ #-} @@ -786,7 +788,7 @@ -- 'mapMOf_' :: 'Monad' m => 'Traversal'' s a -> (a -> m r) -> s -> m () -- 'mapMOf_' :: 'Monad' m => 'Prism'' s a -> (a -> m r) -> s -> m () -- @ -mapMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s t a b -> p a (m r) -> s -> m () +mapMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> p a (m r) -> s -> m () mapMOf_ l f = liftM skip . getSequenced #. foldMapOf l (Sequenced #. f) {-# INLINE mapMOf_ #-} @@ -808,7 +810,7 @@ -- 'forMOf_' :: 'Monad' m => 'Traversal'' s a -> s -> (a -> m r) -> m () -- 'forMOf_' :: 'Monad' m => 'Prism'' s a -> s -> (a -> m r) -> m () -- @ -forMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s t a b -> s -> p a (m r) -> m () +forMOf_ :: (Profunctor p, Monad m) => Accessing p (Sequenced r m) s a -> s -> p a (m r) -> m () forMOf_ = flip . mapMOf_ {-# INLINE forMOf_ #-} @@ -830,7 +832,7 @@ -- 'sequenceOf_' :: 'Monad' m => 'Traversal'' s (m a) -> s -> m () -- 'sequenceOf_' :: 'Monad' m => 'Prism'' s (m a) -> s -> m () -- @ -sequenceOf_ :: Monad m => Getting (Sequenced a m) s t (m a) b -> s -> m () +sequenceOf_ :: Monad m => Getting (Sequenced a m) s (m a) -> s -> m () sequenceOf_ l = liftM skip . getSequenced #. foldMapOf l Sequenced {-# INLINE sequenceOf_ #-} @@ -847,14 +849,14 @@ -- @ -- -- @ --- 'asumOf' :: 'Alternative' f => 'Getter' s a -> s -> f a --- 'asumOf' :: 'Alternative' f => 'Fold' s a -> s -> f a --- 'asumOf' :: 'Alternative' f => 'Lens'' s a -> s -> f a --- 'asumOf' :: 'Alternative' f => 'Iso'' s a -> s -> f a --- 'asumOf' :: 'Alternative' f => 'Traversal'' s a -> s -> f a --- 'asumOf' :: 'Alternative' f => 'Prism'' s a -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Getter' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Fold' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Lens'' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Iso'' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Traversal'' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Prism'' s (f a) -> s -> f a -- @ -asumOf :: Alternative f => Getting (Endo (f a)) s t (f a) b -> s -> f a +asumOf :: Alternative f => Getting (Endo (f a)) s (f a) -> s -> f a asumOf l = foldrOf l (<|>) Applicative.empty {-# INLINE asumOf #-} @@ -871,14 +873,14 @@ -- @ -- -- @ --- 'msumOf' :: 'MonadPlus' m => 'Getter' s a -> s -> m a --- 'msumOf' :: 'MonadPlus' m => 'Fold' s a -> s -> m a --- 'msumOf' :: 'MonadPlus' m => 'Lens'' s a -> s -> m a --- 'msumOf' :: 'MonadPlus' m => 'Iso'' s a -> s -> m a --- 'msumOf' :: 'MonadPlus' m => 'Traversal'' s a -> s -> m a --- 'msumOf' :: 'MonadPlus' m => 'Prism'' s a -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Getter' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Fold' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Lens'' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Iso'' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Traversal'' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Prism'' s (m a) -> s -> m a -- @ -msumOf :: MonadPlus m => Getting (Endo (m a)) s t (m a) b -> s -> m a +msumOf :: MonadPlus m => Getting (Endo (m a)) s (m a) -> s -> m a msumOf l = foldrOf l mplus mzero {-# INLINE msumOf #-} @@ -899,7 +901,7 @@ -- 'elemOf' :: 'Eq' a => 'Traversal'' s a -> a -> s -> 'Bool' -- 'elemOf' :: 'Eq' a => 'Prism'' s a -> a -> s -> 'Bool' -- @ -elemOf :: Eq a => Getting Any s t a b -> a -> s -> Bool +elemOf :: Eq a => Getting Any s a -> a -> s -> Bool elemOf l = anyOf l . (==) {-# INLINE elemOf #-} @@ -923,7 +925,7 @@ -- 'notElemOf' :: 'Eq' a => 'Traversal'' s a -> a -> s -> 'Bool' -- 'notElemOf' :: 'Eq' a => 'Prism'' s a -> a -> s -> 'Bool' -- @ -notElemOf :: Eq a => Getting All s t a b -> a -> s -> Bool +notElemOf :: Eq a => Getting All s a -> a -> s -> Bool notElemOf l = allOf l . (/=) {-# INLINE notElemOf #-} @@ -943,7 +945,7 @@ -- 'concatMapOf' :: 'Iso'' s a -> (a -> [r]) -> s -> [r] -- 'concatMapOf' :: 'Traversal'' s a -> (a -> [r]) -> s -> [r] -- @ -concatMapOf :: Profunctor p => Accessing p [r] s t a b -> p a [r] -> s -> [r] +concatMapOf :: Profunctor p => Accessing p [r] s a -> p a [r] -> s -> [r] concatMapOf l ces = runAccessor #. l (Accessor #. ces) {-# INLINE concatMapOf #-} @@ -964,10 +966,11 @@ -- 'concatOf' :: 'Lens'' s [r] -> s -> [r] -- 'concatOf' :: 'Traversal'' s [r] -> s -> [r] -- @ -concatOf :: Getting [r] s t [r] b -> s -> [r] +concatOf :: Getting [r] s [r] -> s -> [r] concatOf l = runAccessor #. l Accessor {-# INLINE concatOf #-} + -- | Calculate the number of targets there are for a 'Fold' in a given container. -- -- /Note:/ This can be rather inefficient for large containers and just like 'length', @@ -987,7 +990,7 @@ -- 6 -- -- @ --- 'lengthOf' ('folded' '.' 'folded') :: 'Foldable' f => f (g a) -> 'Int' +-- 'lengthOf' ('folded' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a) -> 'Int' -- @ -- -- @ @@ -997,7 +1000,7 @@ -- 'lengthOf' :: 'Iso'' s a -> s -> 'Int' -- 'lengthOf' :: 'Traversal'' s a -> s -> 'Int' -- @ -lengthOf :: Getting (Endo (Endo Int)) s t a b -> s -> Int +lengthOf :: Getting (Endo (Endo Int)) s a -> s -> Int lengthOf l = foldlOf' l (\a _ -> a + 1) 0 {-# INLINE lengthOf #-} @@ -1033,7 +1036,7 @@ -- ('^?') :: s -> 'Iso'' s a -> 'Maybe' a -- ('^?') :: s -> 'Traversal'' s a -> 'Maybe' a -- @ -(^?) :: s -> Getting (First a) s t a b -> Maybe a +(^?) :: s -> Getting (First a) s a -> Maybe a s ^? l = getFirst (foldMapOf l (First #. Just) s) {-# INLINE (^?) #-} @@ -1052,7 +1055,7 @@ -- ('^?!') :: s -> 'Iso'' s a -> a -- ('^?!') :: s -> 'Traversal'' s a -> a -- @ -(^?!) :: s -> Getting (Endo a) s t a b -> a +(^?!) :: s -> Getting (Endo a) s a -> a s ^?! l = foldrOf l const (error "(^?!): empty Fold") s {-# INLINE (^?!) #-} @@ -1079,7 +1082,7 @@ -- 'firstOf' :: 'Iso'' s a -> s -> 'Maybe' a -- 'firstOf' :: 'Traversal'' s a -> s -> 'Maybe' a -- @ -firstOf :: Getting (Leftmost a) s t a b -> s -> Maybe a +firstOf :: Getting (Leftmost a) s a -> s -> Maybe a firstOf l = getLeftmost . foldMapOf l LLeaf {-# INLINE firstOf #-} @@ -1106,7 +1109,7 @@ -- 'lastOf' :: 'Iso'' s a -> s -> 'Maybe' a -- 'lastOf' :: 'Traversal'' s a -> s -> 'Maybe' a -- @ -lastOf :: Getting (Rightmost a) s t a b -> s -> Maybe a +lastOf :: Getting (Rightmost a) s a -> s -> Maybe a lastOf l = getRightmost . foldMapOf l RLeaf {-# INLINE lastOf #-} @@ -1133,7 +1136,7 @@ -- True -- -- @ --- 'nullOf' ('folded' '.' '_1' '.' 'folded') :: 'Foldable' f => f (g a, b) -> 'Bool' +-- 'nullOf' ('folded' '.' '_1' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a, b) -> 'Bool' -- @ -- -- @ @@ -1143,11 +1146,10 @@ -- 'nullOf' :: 'Lens'' s a -> s -> 'Bool' -- 'nullOf' :: 'Traversal'' s a -> s -> 'Bool' -- @ -nullOf :: Getting All s t a b -> s -> Bool -nullOf l = getAll #. foldMapOf l (\_ -> All False) +nullOf :: Getting All s a -> s -> Bool +nullOf = hasn't {-# INLINE nullOf #-} - -- | Returns 'True' if this 'Fold' or 'Traversal' has any targets in the given container. -- -- A more \"conversational\" alias for this combinator is 'has'. @@ -1173,7 +1175,7 @@ -- False -- -- @ --- 'notNullOf' ('folded' '.' '_1' '.' 'folded') :: 'Foldable' f => f (g a, b) -> 'Bool' +-- 'notNullOf' ('folded' '.' '_1' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a, b) -> 'Bool' -- @ -- -- @ @@ -1183,8 +1185,8 @@ -- 'notNullOf' :: 'Lens'' s a -> s -> 'Bool' -- 'notNullOf' :: 'Traversal'' s a -> s -> 'Bool' -- @ -notNullOf :: Getting Any s t a b -> s -> Bool -notNullOf l = getAny #. foldMapOf l (\_ -> Any True) +notNullOf :: Getting Any s a -> s -> Bool +notNullOf = has {-# INLINE notNullOf #-} -- | Obtain the maximum element (if any) targeted by a 'Fold' or 'Traversal' safely. @@ -1214,11 +1216,10 @@ -- 'maximumOf' :: 'Ord' a => 'Lens'' s a -> s -> 'Maybe' a -- 'maximumOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Maybe' a -- @ -maximumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s t a b -> s -> Maybe a +maximumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s a -> s -> Maybe a maximumOf l = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! max x y - {-# INLINE maximumOf #-} -- | Obtain the minimum element (if any) targeted by a 'Fold' or 'Traversal' safely. @@ -1249,14 +1250,10 @@ -- 'minimumOf' :: 'Ord' a => 'Lens'' s a -> s -> 'Maybe' a -- 'minimumOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Maybe' a -- @ - -minimumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s t a b -> s -> Maybe a +minimumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s a -> s -> Maybe a minimumOf l = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! min x y - --- minimumOf :: Getting (Min a) s t a b -> s -> Maybe a --- minimumOf l = getMin `rmap` foldMapOf l Min {-# INLINE minimumOf #-} -- | Obtain the maximum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso', @@ -1278,7 +1275,7 @@ -- 'maximumByOf' :: 'Lens'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'maximumByOf' :: 'Traversal'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- @ -maximumByOf :: Getting (Endo (Endo (Maybe a))) s t a b -> (a -> a -> Ordering) -> s -> Maybe a +maximumByOf :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> Ordering) -> s -> Maybe a maximumByOf l cmp = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! if cmp x y == GT then x else y @@ -1303,7 +1300,7 @@ -- 'minimumByOf' :: 'Lens'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- 'minimumByOf' :: 'Traversal'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a -- @ -minimumByOf :: Getting (Endo (Endo (Maybe a))) s t a b -> (a -> a -> Ordering) -> s -> Maybe a +minimumByOf :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> Ordering) -> s -> Maybe a minimumByOf l cmp = foldlOf' l mf Nothing where mf Nothing y = Just $! y mf (Just x) y = Just $! if cmp x y == GT then y else x @@ -1335,10 +1332,10 @@ -- A simpler version that didn't permit indexing, would be: -- -- @ --- 'findOf' :: 'Getting' ('Endo' ('Maybe' a)) s t a b -> (a -> 'Bool') -> s -> 'Maybe' a +-- 'findOf' :: 'Getting' ('Endo' ('Maybe' a)) s a -> (a -> 'Bool') -> s -> 'Maybe' a -- 'findOf' l p = 'foldrOf' l (\a y -> if p a then 'Just' a else y) 'Nothing' -- @ -findOf :: Conjoined p => Accessing p (Endo (Maybe a)) s t a b -> p a Bool -> s -> Maybe a +findOf :: Conjoined p => Accessing p (Endo (Maybe a)) s a -> p a Bool -> s -> Maybe a findOf l p = foldrOf l (cotabulate $ \wa y -> if corep p wa then Just (extract wa) else y) Nothing {-# INLINE findOf #-} @@ -1361,7 +1358,7 @@ -- 'foldr1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldr1Of :: Getting (Endo (Maybe a)) s t a b -> (a -> a -> a) -> s -> a +foldr1Of :: Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") (foldrOf l mf Nothing xs) where mf x my = Just $ case my of @@ -1387,7 +1384,7 @@ -- 'foldl1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldl1Of :: Getting (Dual (Endo (Maybe a))) s t a b -> (a -> a -> a) -> s -> a +foldl1Of :: Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where mf mx y = Just $ case mx of Nothing -> y @@ -1407,7 +1404,7 @@ -- 'foldrOf'' :: 'Lens'' s a -> (a -> r -> r) -> r -> s -> r -- 'foldrOf'' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r -- @ -foldrOf' :: Getting (Dual (Endo (Endo r))) s t a b -> (a -> r -> r) -> r -> s -> r +foldrOf' :: Getting (Dual (Endo (Endo r))) s a -> (a -> r -> r) -> r -> s -> r foldrOf' l f z0 xs = foldlOf l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z {-# INLINE foldrOf' #-} @@ -1425,7 +1422,7 @@ -- 'foldlOf'' :: 'Lens'' s a -> (r -> a -> r) -> r -> s -> r -- 'foldlOf'' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r -- @ -foldlOf' :: Getting (Endo (Endo r)) s t a b -> (r -> a -> r) -> r -> s -> r +foldlOf' :: Getting (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r foldlOf' l f z0 xs = foldrOf l f' (Endo id) xs `appEndo` z0 where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldlOf' #-} @@ -1445,7 +1442,7 @@ -- 'foldr1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldr1Of' :: Getting (Dual (Endo (Endo (Maybe a)))) s t a b -> (a -> a -> a) -> s -> a +foldr1Of' :: Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a 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 @@ -1466,7 +1463,7 @@ -- 'foldl1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a -- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a -- @ -foldl1Of' :: Getting (Endo (Endo (Maybe a))) s t a b -> (a -> a -> a) -> s -> a +foldl1Of' :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a 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 @@ -1487,7 +1484,7 @@ -- 'foldrMOf' :: 'Monad' m => 'Traversal'' s a -> (a -> r -> m r) -> r -> s -> m r -- @ foldrMOf :: Monad m - => Getting (Dual (Endo (r -> m r))) s t a b + => Getting (Dual (Endo (r -> m r))) s a -> (a -> r -> m r) -> r -> s -> m r foldrMOf l f z0 xs = foldlOf l f' return xs z0 where f' k x z = f x z >>= k @@ -1508,7 +1505,7 @@ -- 'foldlMOf' :: 'Monad' m => 'Traversal'' s a -> (r -> a -> m r) -> r -> s -> m r -- @ foldlMOf :: Monad m - => Getting (Endo (r -> m r)) s t a b + => Getting (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r foldlMOf l f z0 xs = foldrOf l f' return xs z0 where f' x k z = f z x >>= k @@ -1537,10 +1534,12 @@ -- 'has' :: 'Lens'' s a -> s -> 'Bool' -- 'has' :: 'Traversal'' s a -> s -> 'Bool' -- @ -has :: Getting Any s t a b -> s -> Bool +has :: Getting Any s a -> s -> Bool has l = getAny #. foldMapOf l (\_ -> Any True) {-# INLINE has #-} + + -- | Check to see if this 'Fold' or 'Traversal' has no matches. -- -- >>> hasn't _Left (Right 12) @@ -1548,7 +1547,7 @@ -- -- >>> hasn't _Left (Left 12) -- False -hasn't :: Getting All s t a b -> s -> Bool +hasn't :: Getting All s a -> s -> Bool hasn't l = getAll #. foldMapOf l (\_ -> All False) {-# INLINE hasn't #-} @@ -1556,32 +1555,33 @@ -- Pre ------------------------------------------------------------------------------ --- | This converts a 'Fold' to a 'IndexPreservingGetter' that returns the first element if it --- exists as a 'Maybe'. +-- | This converts a 'Fold' to a 'IndexPreservingGetter' that returns the first element, if it +-- exists, as a 'Maybe'. -- -- @ --- 'pre' :: 'Getter' s a -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Fold' s a -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Traversal' s t a b -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Lens' s t a b -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Iso' s t a b -> 'IndexPreservingGetter' s ('Maybe' a) --- 'pre' :: 'Prism' s t a b -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Getter' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Fold' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Simple' 'Traversal' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Simple' 'Lens' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Simple' 'Iso' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Simple' 'Prism' s a -> 'IndexPreservingGetter' s ('Maybe' a) -- @ -pre :: Getting (First a) s t a b -> IndexPreservingGetter s (Maybe a) +pre :: Getting (First a) s a -> IndexPreservingGetter s (Maybe a) pre l = dimap (getFirst . runAccessor #. l (Accessor #. First #. Just)) coerce - +{-# INLINE pre #-} -- | This converts an 'IndexedFold' to an 'IndexPreservingGetter' that returns the first index --- and element if it exists as a 'Maybe'. +-- and element, if they exist, as a 'Maybe'. -- -- @ --- 'ipre' :: 'IndexedGetter' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) --- 'ipre' :: 'IndexedFold' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) --- 'ipre' :: 'IndexedTraversal' i s t a b -> 'IndexPreservingGetter' s ('Maybe' (i, a)) --- 'ipre' :: 'IndexedLens' i s t a b -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- 'ipre' :: 'IndexedGetter' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- 'ipre' :: 'IndexedFold' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- 'ipre' :: 'Simple' ('IndexedTraversal' i) s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- 'ipre' :: 'Simple' ('IndexedLens' i) s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) -- @ -ipre :: IndexedGetting i (First (i, a)) s t a b -> IndexPreservingGetter s (Maybe (i, a)) +ipre :: IndexedGetting i (First (i, a)) s a -> IndexPreservingGetter s (Maybe (i, a)) ipre l = dimap (getFirst . runAccessor #. l (Indexed $ \i a -> Accessor (First (Just (i, a))))) coerce +{-# INLINE ipre #-} ------------------------------------------------------------------------------ -- Preview @@ -1619,7 +1619,7 @@ -- 'preview' :: 'MonadReader' s m => 'Iso'' s a -> m ('Maybe' a) -- 'preview' :: 'MonadReader' s m => 'Traversal'' s a -> m ('Maybe' a) -- @ -preview :: MonadReader s m => Getting (First a) s t a b -> m (Maybe a) +preview :: MonadReader s m => Getting (First a) s a -> m (Maybe a) preview l = asks (getFirst #. foldMapOf l (First #. Just)) {-# INLINE preview #-} @@ -1649,7 +1649,7 @@ -- 'ipreview' :: 'MonadReader' s m => 'IndexedLens'' s a -> m ('Maybe' (i, a)) -- 'ipreview' :: 'MonadReader' s m => 'IndexedTraversal'' s a -> m ('Maybe' (i, a)) -- @ -ipreview :: MonadReader s m => IndexedGetting i (First (i, a)) s t a b -> m (Maybe (i, a)) +ipreview :: MonadReader s m => IndexedGetting i (First (i, a)) s a -> m (Maybe (i, a)) ipreview l = asks (getFirst #. ifoldMapOf l (\i a -> First (Just (i, a)))) {-# INLINE ipreview #-} @@ -1681,7 +1681,7 @@ -- 'previews' :: 'MonadReader' s m => 'Iso'' s a -> (a -> r) -> m ('Maybe' r) -- 'previews' :: 'MonadReader' s m => 'Traversal'' s a -> (a -> r) -> m ('Maybe' r) -- @ -previews :: MonadReader s m => Getting (First r) s t a b -> (a -> r) -> m (Maybe r) +previews :: MonadReader s m => Getting (First r) s a -> (a -> r) -> m (Maybe r) previews l f = asks (getFirst . foldMapOf l (First #. Just . f)) {-# INLINE previews #-} @@ -1707,12 +1707,12 @@ -- a 'Control.Monad.Monad' transformer stack: -- -- @ --- 'ipreviews' :: 'MonadReader' s m => 'IndexedGetter' s a -> (i -> a -> r) -> m ('Maybe' r) --- 'ipreviews' :: 'MonadReader' s m => 'IndexedFold' s a -> (i -> a -> r) -> m ('Maybe' r) --- 'ipreviews' :: 'MonadReader' s m => 'IndexedLens'' s a -> (i -> a -> r) -> m ('Maybe' r) --- 'ipreviews' :: 'MonadReader' s m => 'IndexedTraversal'' s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedGetter' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedFold' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedLens'' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedTraversal'' i s a -> (i -> a -> r) -> m ('Maybe' r) -- @ -ipreviews :: MonadReader s m => IndexedGetting i (First r) s t a b -> (i -> a -> r) -> m (Maybe r) +ipreviews :: MonadReader s m => IndexedGetting i (First r) s a -> (i -> a -> r) -> m (Maybe r) ipreviews l f = asks (getFirst . ifoldMapOf l (\i -> First #. Just . f i)) {-# INLINE ipreviews #-} @@ -1734,7 +1734,7 @@ -- 'preuse' :: 'MonadState' s m => 'Iso'' s a -> m ('Maybe' a) -- 'preuse' :: 'MonadState' s m => 'Traversal'' s a -> m ('Maybe' a) -- @ -preuse :: MonadState s m => Getting (First a) s t a b -> m (Maybe a) +preuse :: MonadState s m => Getting (First a) s a -> m (Maybe a) preuse l = gets (preview l) {-# INLINE preuse #-} @@ -1751,7 +1751,7 @@ -- 'ipreuse' :: 'MonadState' s m => 'IndexedLens'' i s a -> m ('Maybe' (i, a)) -- 'ipreuse' :: 'MonadState' s m => 'IndexedTraversal'' i s a -> m ('Maybe' (i, a)) -- @ -ipreuse :: MonadState s m => IndexedGetting i (First (i, a)) s t a b -> m (Maybe (i, a)) +ipreuse :: MonadState s m => IndexedGetting i (First (i, a)) s a -> m (Maybe (i, a)) ipreuse l = gets (ipreview l) {-# INLINE ipreuse #-} @@ -1769,7 +1769,7 @@ -- 'preuses' :: 'MonadState' s m => 'Iso'' s a -> (a -> r) -> m ('Maybe' r) -- 'preuses' :: 'MonadState' s m => 'Traversal'' s a -> (a -> r) -> m ('Maybe' r) -- @ -preuses :: MonadState s m => Getting (First r) s t a b -> (a -> r) -> m (Maybe r) +preuses :: MonadState s m => Getting (First r) s a -> (a -> r) -> m (Maybe r) preuses l f = gets (previews l f) {-# INLINE preuses #-} @@ -1787,7 +1787,7 @@ -- 'ipreuses' :: 'MonadState' s m => 'IndexedLens'' i s a -> (i -> a -> r) -> m ('Maybe' r) -- 'ipreuses' :: 'MonadState' s m => 'IndexedTraversal'' i s a -> (i -> a -> r) -> m ('Maybe' r) -- @ -ipreuses :: MonadState s m => IndexedGetting i (First r) s t a b -> (i -> a -> r) -> m (Maybe r) +ipreuses :: MonadState s m => IndexedGetting i (First r) s a -> (i -> a -> r) -> m (Maybe r) ipreuses l f = gets (ipreviews l f) {-# INLINE ipreuses #-} @@ -1828,7 +1828,7 @@ -- 'ifoldMapOf' :: 'Monoid' m => 'IndexedTraversal'' i s a -> (i -> a -> m) -> s -> m -- @ -- -ifoldMapOf :: IndexedGetting i m s t a b -> (i -> a -> m) -> s -> m +ifoldMapOf :: IndexedGetting i m s a -> (i -> a -> m) -> s -> m ifoldMapOf l = foldMapOf l .# Indexed {-# INLINE ifoldMapOf #-} @@ -1847,7 +1847,7 @@ -- 'ifoldrOf' :: 'IndexedLens'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- @ -ifoldrOf :: IndexedGetting i (Endo r) s t a b -> (i -> a -> r -> r) -> r -> s -> r +ifoldrOf :: IndexedGetting i (Endo r) s a -> (i -> a -> r -> r) -> r -> s -> r ifoldrOf l = foldrOf l .# Indexed {-# INLINE ifoldrOf #-} @@ -1866,7 +1866,7 @@ -- 'ifoldlOf' :: 'IndexedLens'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf' :: 'IndexedTraversal'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- @ -ifoldlOf :: IndexedGetting i (Dual (Endo r)) s t a b -> (i -> r -> a -> r) -> r -> s -> r +ifoldlOf :: IndexedGetting i (Dual (Endo r)) s a -> (i -> r -> a -> r) -> r -> s -> r ifoldlOf l f z = (flip appEndo z .# getDual) `rmap` ifoldMapOf l (\i -> Dual #. Endo #. flip (f i)) {-# INLINE ifoldlOf #-} @@ -1885,7 +1885,7 @@ -- 'ianyOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'ianyOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ -ianyOf :: IndexedGetting i Any s t a b -> (i -> a -> Bool) -> s -> Bool +ianyOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool ianyOf l = anyOf l .# Indexed {-# INLINE ianyOf #-} @@ -1904,7 +1904,7 @@ -- 'iallOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- 'iallOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ -iallOf :: IndexedGetting i All s t a b -> (i -> a -> Bool) -> s -> Bool +iallOf :: IndexedGetting i All s a -> (i -> a -> Bool) -> s -> Bool iallOf l = allOf l .# Indexed {-# INLINE iallOf #-} @@ -1922,7 +1922,7 @@ -- 'itraverseOf_' :: 'Functor' f => 'IndexedLens'' i s a -> (i -> a -> f r) -> s -> f () -- 'itraverseOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> (i -> a -> f r) -> s -> f () -- @ -itraverseOf_ :: Functor f => IndexedGetting i (Traversed r f) s t a b -> (i -> a -> f r) -> s -> f () +itraverseOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> (i -> a -> f r) -> s -> f () itraverseOf_ l = traverseOf_ l .# Indexed {-# INLINE itraverseOf_ #-} @@ -1945,7 +1945,7 @@ -- 'iforOf_' :: 'Functor' f => 'IndexedLens'' i s a -> s -> (i -> a -> f r) -> f () -- 'iforOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> s -> (i -> a -> f r) -> f () -- @ -iforOf_ :: Functor f => IndexedGetting i (Traversed r f) s t a b -> s -> (i -> a -> f r) -> f () +iforOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> s -> (i -> a -> f r) -> f () iforOf_ = flip . itraverseOf_ {-# INLINE iforOf_ #-} @@ -1964,7 +1964,7 @@ -- 'imapMOf_' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> m r) -> s -> m () -- 'imapMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m r) -> s -> m () -- @ -imapMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s t a b -> (i -> a -> m r) -> s -> m () +imapMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> (i -> a -> m r) -> s -> m () imapMOf_ l = mapMOf_ l .# Indexed {-# INLINE imapMOf_ #-} @@ -1987,7 +1987,7 @@ -- 'iforMOf_' :: 'Monad' m => 'IndexedLens'' i s a -> s -> (i -> a -> m r) -> m () -- 'iforMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> s -> (i -> a -> m r) -> m () -- @ -iforMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s t a b -> s -> (i -> a -> m r) -> m () +iforMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> s -> (i -> a -> m r) -> m () iforMOf_ = flip . imapMOf_ {-# INLINE iforMOf_ #-} @@ -2007,7 +2007,7 @@ -- 'iconcatMapOf' :: 'IndexedLens'' i s a -> (i -> a -> [r]) -> s -> [r] -- 'iconcatMapOf' :: 'IndexedTraversal'' i s a -> (i -> a -> [r]) -> s -> [r] -- @ -iconcatMapOf :: IndexedGetting i [r] s t a b -> (i -> a -> [r]) -> s -> [r] +iconcatMapOf :: IndexedGetting i [r] s a -> (i -> a -> [r]) -> s -> [r] iconcatMapOf = ifoldMapOf {-# INLINE iconcatMapOf #-} @@ -2022,12 +2022,12 @@ -- @ -- -- @ --- 'ifindOf' :: 'IndexedGetter' s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a --- 'ifindOf' :: 'IndexedFold' s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a --- 'ifindOf' :: 'IndexedLens'' s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a --- 'ifindOf' :: 'IndexedTraversal'' s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- 'ifindOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- 'ifindOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- 'ifindOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- 'ifindOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a -- @ -ifindOf :: IndexedGetting i (Endo (Maybe a)) s t a b -> (i -> a -> Bool) -> s -> Maybe a +ifindOf :: IndexedGetting i (Endo (Maybe a)) s a -> (i -> a -> Bool) -> s -> Maybe a ifindOf l = findOf l .# Indexed {-# INLINE ifindOf #-} @@ -2045,7 +2045,7 @@ -- 'ifoldrOf'' :: 'IndexedLens'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- 'ifoldrOf'' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r -- @ -ifoldrOf' :: IndexedGetting i (Dual (Endo (r -> r))) s t a b -> (i -> a -> r -> r) -> r -> s -> r +ifoldrOf' :: IndexedGetting i (Dual (Endo (r -> r))) s a -> (i -> a -> r -> r) -> r -> s -> r ifoldrOf' l f z0 xs = ifoldlOf l f' id xs z0 where f' i k x z = k $! f i x z {-# INLINE ifoldrOf' #-} @@ -2064,7 +2064,7 @@ -- 'ifoldlOf'' :: 'IndexedLens'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- 'ifoldlOf'' :: 'IndexedTraversal'' i s a -> (i -> r -> a -> r) -> r -> s -> r -- @ -ifoldlOf' :: IndexedGetting i (Endo (r -> r)) s t a b -> (i -> r -> a -> r) -> r -> s -> r +ifoldlOf' :: IndexedGetting i (Endo (r -> r)) s a -> (i -> r -> a -> r) -> r -> s -> r ifoldlOf' l f z0 xs = ifoldrOf l f' id xs z0 where f' i x k z = k $! f i z x {-# INLINE ifoldlOf' #-} @@ -2078,12 +2078,12 @@ -- @ -- -- @ --- 'ifoldrMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> r -> m r) -> r -> s -> r --- 'ifoldrMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> r -> m r) -> r -> s -> r --- 'ifoldrMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> r -> m r) -> r -> s -> r --- 'ifoldrMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> r -> m r) -> r -> s -> r +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> r -> m r) -> r -> s -> m r +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> r -> m r) -> r -> s -> m r +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> r -> m r) -> r -> s -> m r +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> r -> m r) -> r -> s -> m r -- @ -ifoldrMOf :: Monad m => IndexedGetting i (Dual (Endo (r -> m r))) s t a b -> (i -> a -> r -> m r) -> r -> s -> m r +ifoldrMOf :: Monad m => IndexedGetting i (Dual (Endo (r -> m r))) s a -> (i -> a -> r -> m r) -> r -> s -> m r ifoldrMOf l f z0 xs = ifoldlOf l f' return xs z0 where f' i k x z = f i x z >>= k {-# INLINE ifoldrMOf #-} @@ -2097,12 +2097,12 @@ -- @ -- -- @ --- 'ifoldlOf'' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> r -> a -> m r) -> r -> s -> r --- 'ifoldlOf'' :: 'Monad' m => 'IndexedFold' i s a -> (i -> r -> a -> m r) -> r -> s -> r --- 'ifoldlOf'' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> r -> a -> m r) -> r -> s -> r --- 'ifoldlOf'' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> r -> a -> m r) -> r -> s -> r +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> r -> a -> m r) -> r -> s -> m r +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> r -> a -> m r) -> r -> s -> m r +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> r -> a -> m r) -> r -> s -> m r +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> r -> a -> m r) -> r -> s -> m r -- @ -ifoldlMOf :: Monad m => IndexedGetting i (Endo (r -> m r)) s t a b -> (i -> r -> a -> m r) -> r -> s -> m r +ifoldlMOf :: Monad m => IndexedGetting i (Endo (r -> m r)) s a -> (i -> r -> a -> m r) -> r -> s -> m r ifoldlMOf l f z0 xs = ifoldrOf l f' return xs z0 where f' i x k z = f i z x >>= k {-# INLINE ifoldlMOf #-} @@ -2121,7 +2121,7 @@ -- 'itoListOf' :: 'IndexedLens'' i s a -> s -> [(i,a)] -- 'itoListOf' :: 'IndexedTraversal'' i s a -> s -> [(i,a)] -- @ -itoListOf :: IndexedGetting i (Endo [(i,a)]) s t a b -> s -> [(i,a)] +itoListOf :: IndexedGetting i (Endo [(i,a)]) s a -> s -> [(i,a)] itoListOf l = ifoldrOf l (\i a -> ((i,a):)) [] {-# INLINE itoListOf #-} @@ -2133,8 +2133,9 @@ -- ('^@..') :: s -> 'IndexedLens'' i s a -> [(i,a)] -- ('^@..') :: s -> 'IndexedTraversal'' i s a -> [(i,a)] -- @ -(^@..) :: s -> IndexedGetting i (Endo [(i,a)]) s t a b -> [(i,a)] +(^@..) :: s -> IndexedGetting i (Endo [(i,a)]) s a -> [(i,a)] s ^@.. l = ifoldrOf l (\i a -> ((i,a):)) [] s +{-# INLINE (^@..) #-} -- | Perform a safe 'head' (with index) of an 'IndexedFold' or 'IndexedTraversal' or retrieve 'Just' the index and result -- from an 'IndexedGetter' or 'IndexedLens'. @@ -2143,26 +2144,24 @@ -- way to extract the optional value. -- -- @ --- ('^@?') :: s -> 'IndexedGetter' i s a -> 'Maybe' (i, a) --- ('^@?') :: s -> 'IndexedFold' i s a -> 'Maybe' (i, a) --- ('^@?') :: s -> 'IndexedLens'' i s a -> 'Maybe' (i, a) --- ('^@?') :: s -> 'Iso'' i s a -> 'Maybe' (i, a) --- ('^@?') :: s -> 'Traversal'' i s a -> 'Maybe' (i, a) +-- ('^@?') :: s -> 'IndexedGetter' i s a -> 'Maybe' (i, a) +-- ('^@?') :: s -> 'IndexedFold' i s a -> 'Maybe' (i, a) +-- ('^@?') :: s -> 'IndexedLens'' i s a -> 'Maybe' (i, a) +-- ('^@?') :: s -> 'IndexedTraversal'' i s a -> 'Maybe' (i, a) -- @ -(^@?) :: s -> IndexedGetting i (Endo (Maybe (i, a))) s t a b -> Maybe (i, a) +(^@?) :: s -> IndexedGetting i (Endo (Maybe (i, a))) s a -> Maybe (i, a) s ^@? l = ifoldrOf l (\i x _ -> Just (i,x)) Nothing s {-# INLINE (^@?) #-} -- | Perform an *UNSAFE* 'head' (with index) of an 'IndexedFold' or 'IndexedTraversal' assuming that it is there. -- -- @ --- ('^@?!') :: s -> 'IndexedGetter' i s a -> (i, a) --- ('^@?!') :: s -> 'IndexedFold' i s a -> (i, a) --- ('^@?!') :: s -> 'Lens'' i s a -> (i, a) --- ('^@?!') :: s -> 'Iso'' i s a -> (i, a) --- ('^@?!') :: s -> 'Traversal'' i s a -> (i, a) +-- ('^@?!') :: s -> 'IndexedGetter' i s a -> (i, a) +-- ('^@?!') :: s -> 'IndexedFold' i s a -> (i, a) +-- ('^@?!') :: s -> 'IndexedLens'' i s a -> (i, a) +-- ('^@?!') :: s -> 'IndexedTraversal'' i s a -> (i, a) -- @ -(^@?!) :: s -> IndexedGetting i (Endo (i, a)) s t a b -> (i, a) +(^@?!) :: s -> IndexedGetting i (Endo (i, a)) s a -> (i, a) s ^@?! l = ifoldrOf l (\i x _ -> (i,x)) (error "(^@?!): empty Fold") s {-# INLINE (^@?!) #-} @@ -2194,7 +2193,7 @@ -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s a -- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedAction' i m s a -> 'IndexedMonadicFold' i m s a -- @ -itakingWhile :: (Indexable i p, Profunctor q, Applicative f, Gettable f) +itakingWhile :: (Indexable i p, Profunctor q, Contravariant f, Applicative f) => (i -> a -> Bool) -> Overloading (Indexed i) q (Accessor (Endo (f s))) s s a a -> Overloading p q f s s a a @@ -2231,10 +2230,10 @@ ------------------------------------------------------------------------------ -- | A deprecated alias for 'firstOf'. -headOf :: Getting (First a) s t a b -> s -> Maybe a +headOf :: Getting (First a) s a -> s -> Maybe a headOf l = getFirst #. foldMapOf l (First #. Just) {-# INLINE headOf #-} -{-# DEPRECATED headOf "`headOf' will be removed in 3.9. (Use `preview' or `firstOf')" #-} +{-# DEPRECATED headOf "`headOf' will be removed after GHC 7.8 is released. (Use `preview' or `firstOf')" #-} ------------------------------------------------------------------------------ -- Misc. diff --git a/src/Control/Lens/Getter.hs b/src/Control/Lens/Getter.hs --- a/src/Control/Lens/Getter.hs +++ b/src/Control/Lens/Getter.hs @@ -5,6 +5,10 @@ #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE NoPolyKinds #-} +{-# LANGUAGE NoDataKinds #-} +#endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Getter @@ -50,8 +54,8 @@ , to -- * Combinators for Getters and Folds , (^.) - , view, views, view', views' - , use, uses, use', uses' + , view, views + , use, uses , listening, listenings -- * Indexed Getters -- ** Indexed Getter Combinators @@ -60,8 +64,10 @@ , iuse, iuses , ilistening, ilistenings -- * Implementation Details - , Gettable(..) + , Contravariant(..) + , coerce, coerced , Accessor(..) + , Gettable ) where import Control.Lens.Internal.Getter @@ -70,6 +76,7 @@ import Control.Monad.Reader.Class as Reader import Control.Monad.State as State import Control.Monad.Writer as Writer +import Data.Functor.Contravariant import Data.Profunctor import Data.Profunctor.Unsafe @@ -130,15 +137,14 @@ -- you can pass a 'Control.Lens.Fold.Fold' (or -- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a -- 'Getter' or 'Lens'. --- -type Getting r s t a b = (a -> Accessor r b) -> s -> Accessor r t +type Getting r s a = (a -> Accessor r a) -> s -> Accessor r s -- | Used to consume an 'Control.Lens.Fold.IndexedFold'. -type IndexedGetting i m s t a b = Indexed i a (Accessor m b) -> s -> Accessor m t +type IndexedGetting i m s a = Indexed i a (Accessor m a) -> s -> Accessor m s -- | This is a convenient alias used when consuming (indexed) getters and (indexed) folds -- in a highly general fashion. -type Accessing p m s t a b = p a (Accessor m b) -> s -> Accessor m t +type Accessing p m s a = p a (Accessor m a) -> s -> Accessor m s ------------------------------------------------------------------------------- -- Getting Values @@ -186,7 +192,7 @@ -- 'view' :: 'MonadReader' s m => 'Lens'' s a -> m a -- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a -- @ -view :: MonadReader s m => Getting a s t a b -> m a +view :: MonadReader s m => Getting a s a -> m a view l = Reader.asks (runAccessor #. l Accessor) {-# INLINE view #-} @@ -226,10 +232,10 @@ -- @ -- -- @ --- 'views' :: 'MonadReader' s m => 'Getting' r s t a b -> (a -> r) -> m r +-- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r -- @ -views :: (Profunctor p, MonadReader s m) => Overloading p (->) (Accessor r) s t a b -> p a r -> m r -views l f = Reader.asks (runAccessor #. l (rmap Accessor f)) +views :: (Profunctor p, MonadReader s m) => Overloading p (->) (Accessor r) s s a a -> p a r -> m r +views l f = Reader.asks (runAccessor #. l (Accessor #. f)) {-# INLINE views #-} -- | View the value pointed to by a 'Getter' or 'Lens' or the @@ -258,7 +264,7 @@ -- ('^.') :: s -> 'Lens'' s a -> a -- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Traversal.Traversal'' s m -> m -- @ -(^.) :: s -> Getting a s t a b -> a +(^.) :: s -> Getting a s a -> a s ^. l = runAccessor (l Accessor s) {-# INLINE (^.) #-} @@ -284,7 +290,7 @@ -- 'use' :: 'MonadState' s m => 'Lens'' s a -> m a -- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s r -> m r -- @ -use :: MonadState s m => Getting a s t a b -> m a +use :: MonadState s m => Getting a s a -> m a use l = State.gets (view l) {-# INLINE use #-} @@ -307,7 +313,7 @@ -- @ -- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r -- @ -uses :: (Profunctor p, MonadState s m) => Overloading p (->) (Accessor r) s t a b -> p a r -> m r +uses :: (Profunctor p, MonadState s m) => Overloading p (->) (Accessor r) s s a a -> p a r -> m r uses l f = State.gets (views l f) {-# INLINE uses #-} @@ -324,7 +330,7 @@ -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Traversal'' w u -> m a -> m (a, u) -- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Prism'' w u -> m a -> m (a, u) -- @ -listening :: MonadWriter w m => Getting u w t u b -> m a -> m (a, u) +listening :: MonadWriter w m => Getting u w u -> m a -> m (a, u) listening l m = do (a, w) <- listen m return (a, view l w) @@ -341,7 +347,7 @@ -- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedFold' i w u -> m a -> m (a, (i, u)) -- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedTraversal'' i w u -> m a -> m (a, (i, u)) -- @ -ilistening :: MonadWriter w m => IndexedGetting i (i, u) w t u b -> m a -> m (a, (i, u)) +ilistening :: MonadWriter w m => IndexedGetting i (i, u) w u -> m a -> m (a, (i, u)) ilistening l m = do (a, w) <- listen m return (a, iview l w) @@ -360,7 +366,7 @@ -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Traversal'' w u -> (u -> v) -> m a -> m (a, v) -- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Prism'' w u -> (u -> v) -> m a -> m (a, v) -- @ -listenings :: MonadWriter w m => Getting v w t u b -> (u -> v) -> m a -> m (a, v) +listenings :: MonadWriter w m => Getting v w u -> (u -> v) -> m a -> m (a, v) listenings l uv m = do (a, w) <- listen m return (a, views l uv w) @@ -377,165 +383,13 @@ -- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedFold' w u -> (i -> u -> v) -> m a -> m (a, v) -- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v) -- @ -ilistenings :: MonadWriter w m => IndexedGetting i v w t u b -> (i -> u -> v) -> m a -> m (a, v) +ilistenings :: MonadWriter w m => IndexedGetting i v w u -> (i -> u -> v) -> m a -> m (a, v) ilistenings l iuv m = do (a, w) <- listen m return (a, iviews l iuv w) {-# INLINE ilistenings #-} --- | View the value of a 'Getter', 'Control.Lens.Iso.Iso', - ------------------------------------------------------------------------------ --- Accessing State, Simplified ------------------------------------------------------------------------------- - --- | This is a type restricted version of 'use' that expects a 'Simple' 'Getter'. --- --- Use the target of a 'Lens'', 'Control.Lens.Iso.Iso', or --- 'Getter' in the current state, or use a summary of a --- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points --- to a monoidal value. --- --- This use of this combinator may aid type-inference when working with lenses or traversals that --- have non-defaultable typeclass constraints on their arguments. --- --- >>> evalState (use' _1) (a,b) --- a --- --- --- >>> evalState (use' _1) ("hello","world") --- "hello" --- --- @ --- 'use'' :: 'MonadState' s m => 'Getter' s a -> m a --- 'use'' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s r -> m r --- 'use'' :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> m a --- 'use'' :: 'MonadState' s m => 'Lens'' s a -> m a --- 'use'' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s r -> m r --- @ -use' :: MonadState s m => Getting a s s a a -> m a -use' l = State.gets (view' l) -{-# INLINE use' #-} - --- | This is a type restricted version of 'uses' that expects a 'Simple' 'Getter'. --- --- Use the target of a 'Lens', 'Control.Lens.Iso.Iso' or --- 'Getter' in the current state, or use a summary of a --- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that --- points to a monoidal value. --- --- >>> evalState (uses' _1 length) ("hello","world") --- 5 --- --- @ --- 'uses'' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r --- 'uses'' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r --- 'uses'' :: 'MonadState' s m => 'Lens'' s a -> (a -> r) -> m r --- 'uses'' :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> m r --- 'uses'' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r --- @ --- --- @ --- 'uses'' :: 'MonadState' s m => 'Getting' r s s a a -> (a -> r) -> m r --- @ -uses' :: (Profunctor p, MonadState s m) => Overloading' p (->) (Accessor r) s a -> p a r -> m r -uses' l f = State.gets (views' l f) -{-# INLINE uses' #-} - ------------------------------------------------------------------------------- --- Viewing, Simplified ------------------------------------------------------------------------------- - --- | This is a type restricted version of 'view' that expects a 'Simple' 'Getter'. --- --- View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or --- 'Lens' or the result of folding over all the results of a --- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points --- at a monoidal values. --- --- @ --- 'view'' '.' 'to' ≡ 'id' --- @ --- --- >>> view' (to f) a --- f a --- --- >>> view' _2 (1,"hello") --- "hello" --- --- >>> view' (to succ) 5 --- 6 --- --- >>> view' (_2._1) ("hello",("world","!!!")) --- "world" --- --- As 'view'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', --- It may be useful to think of it as having one of these more restricted signatures: --- --- @ --- 'view'' :: 'Getter' s a -> s -> a --- 'view'' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s m -> s -> m --- 'view'' :: 'Control.Lens.Iso.Iso'' s a -> s -> a --- 'view'' :: 'Lens'' s a -> s -> a --- 'view'' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s m -> s -> m --- @ --- --- In a more general setting, such as when working with a 'Monad' transformer stack you can use: --- --- @ --- 'view'' :: 'MonadReader' s m => 'Getter' s a -> m a --- 'view'' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a --- 'view'' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> m a --- 'view'' :: 'MonadReader' s m => 'Lens'' s a -> m a --- 'view'' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a --- @ -view' :: MonadReader s m => Getting a s s a a -> m a -view' l = Reader.asks (runAccessor #. l Accessor) -{-# INLINE view' #-} - --- | This is a type restricted version of 'views' that expects a 'Simple' 'Getter'. --- --- View the value of a 'Getter', 'Control.Lens.Iso.Iso', --- 'Lens' or the result of folding over the result of mapping --- the targets of a 'Control.Lens.Fold.Fold' or --- 'Control.Lens.Traversal.Traversal'. --- --- @ --- 'views'' l f ≡ 'view'' (l '.' 'to' f) --- @ --- --- >>> views' _2 length (1,"hello") --- 5 --- --- As 'views'' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', --- It may be useful to think of it as having one of these more restricted signatures: --- --- @ --- 'views'' :: 'Getter' s a -> (a -> r) -> s -> r --- 'views'' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m --- 'views'' :: 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> s -> r --- 'views'' :: 'Lens'' s a -> (a -> r) -> s -> r --- 'views'' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s a -> (a -> m) -> s -> m --- @ --- --- In a more general setting, such as when working with a 'Monad' transformer stack you can use: --- --- @ --- 'views'' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m r --- 'views'' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r --- 'views'' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> m r --- 'views'' :: 'MonadReader' s m => 'Lens'' s a -> (a -> r) -> m r --- 'views'' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r --- @ --- --- @ --- 'views'' :: 'MonadReader' s m => 'Getting' r s s a a -> (a -> r) -> m r --- @ -views' :: (Profunctor p, MonadReader s m) => Overloading' p (->) (Accessor r) s a -> p a r -> m r -views' l f = Reader.asks (runAccessor #. l (rmap Accessor f)) -{-# INLINE views' #-} - ------------------------------------------------------------------------------- -- Indexed Getters ------------------------------------------------------------------------------ @@ -543,7 +397,7 @@ -- -- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of -- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. -iview :: MonadReader s m => IndexedGetting i (i,a) s t a b -> m (i,a) +iview :: MonadReader s m => IndexedGetting i (i,a) s a -> m (i,a) iview l = asks (runAccessor #. l (Indexed $ \i -> Accessor #. (,) i)) {-# INLINE iview #-} @@ -554,7 +408,7 @@ -- @ -- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf' -- @ -iviews :: MonadReader s m => IndexedGetting i r s t a b -> (i -> a -> r) -> m r +iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r iviews l = views l .# Indexed {-# INLINE iviews #-} @@ -562,14 +416,14 @@ -- -- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of -- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. -iuse :: MonadState s m => IndexedGetting i (i,a) s t a b -> m (i,a) +iuse :: MonadState s m => IndexedGetting i (i,a) s a -> m (i,a) iuse l = gets (runAccessor #. l (Indexed $ \i -> Accessor #. (,) i)) {-# INLINE iuse #-} -- | Use a function of the index and value of an 'IndexedGetter' into the current state. -- -- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. -iuses :: MonadState s m => IndexedGetting i r s t a b -> (i -> a -> r) -> m r +iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r iuses l = uses l .# Indexed {-# INLINE iuses #-} @@ -592,6 +446,11 @@ -- @ -- -- The result probably doesn't have much meaning when applied to an 'IndexedFold'. -(^@.) :: s -> IndexedGetting i (i, a) s t a b -> (i, a) +(^@.) :: s -> IndexedGetting i (i, a) s a -> (i, a) s ^@. l = runAccessor $ l (Indexed $ \i -> Accessor #. (,) i) s {-# INLINE (^@.) #-} + +-- | Coerce a 'Gettable' 'LensLike' to a 'Simple' 'LensLike'. This is useful +-- when using a 'Traversal' that is not simple as a 'Getter' or a 'Fold'. +coerced :: (Functor f, Contravariant f) => LensLike f s t a b -> LensLike' f s a +coerced l f = coerce . l (coerce . f) diff --git a/src/Control/Lens/Indexed.hs b/src/Control/Lens/Indexed.hs --- a/src/Control/Lens/Indexed.hs +++ b/src/Control/Lens/Indexed.hs @@ -88,6 +88,7 @@ import Control.Lens.Traversal import Control.Lens.Type import Data.Foldable +import Data.Functor.Contravariant import Data.Functor.Identity import Data.Functor.Reverse import Data.Hashable @@ -158,7 +159,7 @@ -- | When composed with an 'IndexedFold' or 'IndexedTraversal' this yields an -- ('Indexed') 'Fold' of the indices. -asIndex :: (Indexable i p, Functor f, Gettable f) => Overloading' p (Indexed i) f s i +asIndex :: (Indexable i p, Contravariant f, Functor f) => Overloading' p (Indexed i) f s i asIndex f = Indexed $ \i _ -> coerce (indexed f i i) {-# INLINE asIndex #-} @@ -250,6 +251,7 @@ -- @ ifoldr :: (i -> a -> b -> b) -> b -> f a -> b ifoldr f z t = appEndo (ifoldMap (\i -> Endo #. f i) t) z + {-# INLINE ifoldr #-} -- | Left-associative fold of an indexed container with access to the index @i@. -- @@ -260,6 +262,7 @@ -- @ ifoldl :: (i -> b -> a -> b) -> b -> f a -> b ifoldl f z t = appEndo (getDual (ifoldMap (\i -> Dual #. Endo #. flip (f i)) t)) z + {-# INLINE ifoldl #-} -- | /Strictly/ fold right over the elements of a structure with access to the index @i@. -- @@ -271,6 +274,7 @@ ifoldr' :: (i -> a -> b -> b) -> b -> f a -> b ifoldr' f z0 xs = ifoldl f' id xs z0 where f' i k x z = k $! f i x z + {-# INLINE ifoldr' #-} -- | Fold over the elements of a structure with an index, associating to the left, but /strictly/. -- @@ -282,6 +286,7 @@ ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b ifoldl' f z0 xs = ifoldr f' id xs z0 where f' i x k z = k $! f i z x + {-# INLINE ifoldl' #-} -- | Obtain a 'Fold' by lifting an operation that returns a 'Foldable' result. -- @@ -451,7 +456,6 @@ itraversed = conjoined traverse (itraverse . indexed) {-# INLINE itraversed #-} - -- | Traverse with an index (and the arguments flipped). -- -- @ @@ -515,30 +519,39 @@ instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where imap f = Backwards . imap f . forwards + {-# INLINE imap #-} instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where ifoldMap f = ifoldMap f . forwards + {-# INLINE ifoldMap #-} instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where itraverse f = fmap Backwards . itraverse f . forwards + {-# INLINE itraverse #-} instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where imap f = Reverse . imap f . getReverse + {-# INLINE imap #-} instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where ifoldMap f = getDual . ifoldMap (\i -> Dual #. f i) . getReverse + {-# INLINE ifoldMap #-} instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where itraverse f = fmap Reverse . forwards . itraverse (\i -> Backwards . f i) . getReverse + {-# INLINE itraverse #-} instance FunctorWithIndex () Identity where imap f (Identity a) = Identity (f () a) + {-# INLINE imap #-} instance FoldableWithIndex () Identity where ifoldMap f (Identity a) = f () a + {-# INLINE ifoldMap #-} instance TraversableWithIndex () Identity where itraverse f (Identity a) = Identity <$> f () a + {-# INLINE itraverse #-} instance FunctorWithIndex k ((,) k) where imap f (k,a) = (k, f k a) @@ -563,6 +576,16 @@ itraverse = itraverseOf traversed {-# INLINE itraverse #-} +instance FunctorWithIndex () Maybe where + imap f = fmap (f ()) + {-# INLINE imap #-} +instance FoldableWithIndex () Maybe where + ifoldMap f = foldMap (f ()) + {-# INLINE ifoldMap #-} +instance TraversableWithIndex () Maybe where + itraverse f = traverse (f ()) + {-# INLINE itraverse #-} + -- | The position in the 'Seq' is available as the index. instance FunctorWithIndex Int Seq where imap = iover itraversed @@ -581,9 +604,13 @@ ifoldMap = ifoldMapOf itraversed {-# INLINE ifoldMap #-} ifoldr = V.ifoldr + {-# INLINE ifoldr #-} ifoldl = V.ifoldl . flip + {-# INLINE ifoldl #-} ifoldr' = V.ifoldr' + {-# INLINE ifoldr' #-} ifoldl' = V.ifoldl' . flip + {-# INLINE ifoldl' #-} instance TraversableWithIndex Int Vector where itraverse f = sequenceA . V.imap f {-# INLINE itraverse #-} diff --git a/src/Control/Lens/Internal/Action.hs b/src/Control/Lens/Internal/Action.hs --- a/src/Control/Lens/Internal/Action.hs +++ b/src/Control/Lens/Internal/Action.hs @@ -30,6 +30,7 @@ import Control.Lens.Internal.Getter import Control.Monad import Data.Functor.Bind +import Data.Functor.Contravariant import Data.Functor.Identity import Data.Profunctor.Unsafe import Data.Semigroup @@ -41,7 +42,7 @@ -- | An 'Effective' 'Functor' ignores its argument and is isomorphic to a 'Monad' wrapped around a value. -- -- That said, the 'Monad' is possibly rather unrelated to any 'Applicative' structure. -class (Monad m, Gettable f) => Effective m r f | f -> m r where +class (Monad m, Functor f, Contravariant f) => Effective m r f | f -> m r where effective :: m r -> f a ineffective :: f a -> m r @@ -68,9 +69,9 @@ fmap _ (Effect m) = Effect m {-# INLINE fmap #-} -instance Gettable (Effect m r) where - coerce (Effect m) = Effect m - {-# INLINE coerce #-} +instance Contravariant (Effect m r) where + contramap _ (Effect m) = Effect m + {-# INLINE contramap #-} instance Monad m => Effective m r (Effect m r) where effective = Effect diff --git a/src/Control/Lens/Internal/Bazaar.hs b/src/Control/Lens/Internal/Bazaar.hs --- a/src/Control/Lens/Internal/Bazaar.hs +++ b/src/Control/Lens/Internal/Bazaar.hs @@ -28,10 +28,10 @@ import Control.Category import Control.Comonad import Control.Lens.Internal.Context -import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Data.Functor.Apply import Data.Functor.Compose +import Data.Functor.Contravariant import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Rep @@ -121,8 +121,8 @@ -- BazaarT ------------------------------------------------------------------------------ --- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Gettable' instance --- To protect this instance it relies on the soundness of another 'Gettable' type, and usage conventions. +-- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Contravariant' instance +-- To protect this instance it relies on the soundness of another 'Contravariant' type, and usage conventions. -- -- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there -- must be a better way! @@ -177,6 +177,6 @@ (<@>) = (<*>) {-# INLINE (<@>) #-} -instance (Profunctor p, Gettable g) => Gettable (BazaarT p g a b) where - coerce = (<$) (error "coerced BazaarT") - {-# INLINE coerce #-} +instance (Profunctor p, Contravariant g) => Contravariant (BazaarT p g a b) where + contramap _ = (<$) (error "contramap: BazaarT") + {-# INLINE contramap #-} diff --git a/src/Control/Lens/Internal/ByteString.hs b/src/Control/Lens/Internal/ByteString.hs --- a/src/Control/Lens/Internal/ByteString.hs +++ b/src/Control/Lens/Internal/ByteString.hs @@ -95,20 +95,19 @@ -- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a balanced tree with biased runs of -- elements at the leaves. traversedStrictTree :: Int -> IndexedTraversal' Int B.ByteString Word8 -traversedStrictTree i0 pafb (BI.PS fp off len) = rebuild len <$> go i0 (i0 + len) +traversedStrictTree i0 pafb (BI.PS fp off len) = rebuild len <$> go (unsafeForeignPtrToPtr fp `plusPtr` (off - i0)) i0 (i0 + len) where - p = unsafeForeignPtrToPtr fp `plusPtr` (off - i0) - rebuild n f = unsafeCreate n $ \q -> f (q `plusPtr` (off - i0)) - go !i !j - | i + grain < j, k <- i + shiftR (j - i) 1 = (\l r q -> l q >> r q) <$> go i k <*> go k j - | otherwise = run i j - run !i !j + rebuild n f = unsafeCreate n $ \q -> f $! (q `plusPtr` (off - i0)) + go !p !i !j + | i + grain < j, k <- i + shiftR (j - i) 1 = (\l r q -> l q >> r q) <$> go p i k <*> go p k j + | otherwise = run p i j + run !p !i !j | i == j = pure (\_ -> return ()) | otherwise = let !x = BI.inlinePerformIO $ do x' <- peekByteOff p i touchForeignPtr fp return x' - in (\y ys q -> poke (q `plusPtr` i) y >> ys q) <$> indexed pafb (i :: Int) x <*> run (i + 1) j + in (\y ys !q -> pokeByteOff q i y >> ys q) <$> indexed pafb (i :: Int) x <*> run p (i + 1) j {-# INLINE traversedStrictTree #-} -- | Traverse a strict 'B.ByteString' in a relatively balanced fashion, as a balanced tree with biased runs of diff --git a/src/Control/Lens/Internal/Context.hs b/src/Control/Lens/Internal/Context.hs --- a/src/Control/Lens/Internal/Context.hs +++ b/src/Control/Lens/Internal/Context.hs @@ -34,9 +34,9 @@ import Control.Category import Control.Comonad import Control.Comonad.Store.Class -import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Data.Functor.Compose +import Data.Functor.Contravariant import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Rep @@ -338,9 +338,9 @@ sell = cotabulate $ \ w -> PretextT (`corep` w) {-# INLINE sell #-} -instance (Profunctor p, Gettable g) => Gettable (PretextT p g a b) where - coerce = (<$) (error "coerced PretextT") - {-# INLINE coerce #-} +instance (Profunctor p, Contravariant g) => Contravariant (PretextT p g a b) where + contramap _ = (<$) (error "contramap: PretextT") + {-# INLINE contramap #-} ------------------------------------------------------------------------------ -- Utilities diff --git a/src/Control/Lens/Internal/Deque.hs b/src/Control/Lens/Internal/Deque.hs --- a/src/Control/Lens/Internal/Deque.hs +++ b/src/Control/Lens/Internal/Deque.hs @@ -30,6 +30,7 @@ import Control.Lens.Cons import Control.Lens.Fold import Control.Lens.Indexed hiding ((<.>)) +import Control.Lens.Iso import Control.Lens.Prism import Control.Monad import Data.Foldable as Foldable @@ -124,6 +125,10 @@ | size xs < size ys = Foldable.foldr cons ys xs | otherwise = Foldable.foldl snoc xs ys {-# INLINE (<|>) #-} + +instance Reversing (Deque a) where + reversing (BD lf f lr r) = BD lr r lf f + {-# INLINE reversing #-} instance Bind Deque where ma >>- k = fromList (toList ma >>= toList . k) diff --git a/src/Control/Lens/Internal/Exception.hs b/src/Control/Lens/Internal/Exception.hs --- a/src/Control/Lens/Internal/Exception.hs +++ b/src/Control/Lens/Internal/Exception.hs @@ -84,7 +84,7 @@ -- 'handler' :: 'Control.Lens.Lens.Lens'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler' :: 'Control.Lens.Traversal.Traversal'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r -- @ - handler :: Getting (First a) e t a b -> (a -> m r) -> h r + handler :: Getting (First a) e a -> (a -> m r) -> h r -- | This builds a 'Handler' for just the targets of a given 'Control.Lens.Prism.Prism' (or any 'Getter', really). -- that ignores its input and just recovers with the stated monadic action. @@ -124,7 +124,7 @@ -- 'handler_' :: 'Control.Lens.Lens.Lens'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r -- 'handler_' :: 'Control.Lens.Traversal.Traversal'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r -- @ - handler_ :: Getting (First a) e t a b -> m r -> h r + handler_ :: Getting (First a) e a -> m r -> h r handler_ l = handler l . const {-# INLINE handler_ #-} @@ -134,10 +134,10 @@ instance Handleable SomeException m (CatchIO.Handler m) where handler = handlerCatchIO -handlerIO :: forall t a b r. Getting (First a) SomeException t a b -> (a -> IO r) -> Exception.Handler r +handlerIO :: forall a r. Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r handlerIO l f = reify (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a) -handlerCatchIO :: forall m t a b r. Getting (First a) SomeException t a b -> (a -> m r) -> CatchIO.Handler m r +handlerCatchIO :: forall m a r. Getting (First a) SomeException a -> (a -> m r) -> CatchIO.Handler m r handlerCatchIO l f = reify (preview l) $ \ (_ :: Proxy s) -> CatchIO.Handler (\(Handling a :: Handling a s m) -> f a) ------------------------------------------------------------------------------ diff --git a/src/Control/Lens/Internal/Fold.hs b/src/Control/Lens/Internal/Fold.hs --- a/src/Control/Lens/Internal/Fold.hs +++ b/src/Control/Lens/Internal/Fold.hs @@ -26,27 +26,27 @@ import Control.Applicative import Control.Lens.Internal.Getter -import Data.Maybe import Data.Functor.Bind +import Data.Functor.Contravariant +import Data.Maybe import Data.Semigroup hiding (Min, getMin, Max, getMax) ------------------------------------------------------------------------------ -- Folding ------------------------------------------------------------------------------ --- | A 'Monoid' for a 'Gettable' 'Applicative'. +-- | A 'Monoid' for a 'Contravariant' 'Applicative'. newtype Folding f a = Folding { getFolding :: f a } -instance (Gettable f, Apply f) => Semigroup (Folding f a) where +instance (Contravariant f, Apply f) => Semigroup (Folding f a) where Folding fr <> Folding fs = Folding (fr .> fs) {-# INLINE (<>) #-} -instance (Gettable f, Applicative f) => Monoid (Folding f a) where +instance (Contravariant f, Applicative f) => Monoid (Folding f a) where mempty = Folding noEffect {-# INLINE mempty #-} Folding fr `mappend` Folding fs = Folding (fr *> fs) {-# INLINE mappend #-} - ------------------------------------------------------------------------------ -- Traversed diff --git a/src/Control/Lens/Internal/Getter.hs b/src/Control/Lens/Internal/Getter.hs --- a/src/Control/Lens/Internal/Getter.hs +++ b/src/Control/Lens/Internal/Getter.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} -#ifdef TRUSTWORTHY -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Getter @@ -15,54 +13,43 @@ module Control.Lens.Internal.Getter ( -- * Internal Classes + Gettable -- ** Getters - Gettable(..) + , coerce , noEffect , Accessor(..) ) where import Control.Applicative -import Control.Applicative.Backwards import Data.Functor.Apply -import Data.Functor.Compose -import Data.Profunctor.Unsafe +import Data.Functor.Contravariant import Data.Semigroup +import Data.Void +-- | This class is provided mostly for backwards compatibility with lens 3.8, +-- but it can also shorten type signatures. +class (Contravariant f, Functor f) => Gettable f +instance (Contravariant f, Functor f) => Gettable f + ------------------------------------------------------------------------------- -- Gettables & Accessors ------------------------------------------------------------------------------- --- | Generalizing 'Const' so we can apply simple 'Applicative' +-- | This Generalizes 'Const' so we can apply simple 'Applicative' -- transformations to it and so we can get nicer error messages. -- --- A 'Gettable' 'Functor' ignores its argument, which it carries solely as a +-- A 'Functor' you can 'coerce' ignores its argument, which it carries solely as a -- phantom type parameter. -- --- To ensure this, an instance of 'Gettable' is required to satisfy: --- --- @'id' = 'fmap' f = 'coerce'@ +-- By the 'Functor' and 'Contravariant' laws, an instance of 'Gettable' will necessarily satisfy: -- --- Which is equivalent to making a @'Gettable' f@ an \"anyvariant\" --- 'Functor'. - -class Functor f => Gettable f where - -- | Replace the phantom type argument. - coerce :: f a -> f b - -instance Gettable (Const r) where - coerce (Const m) = Const m - {-# INLINE coerce #-} - -instance Gettable f => Gettable (Backwards f) where - coerce = Backwards #. coerce .# forwards - {-# INLINE coerce #-} - -instance (Functor f, Gettable g) => Gettable (Compose f g) where - coerce = Compose #. fmap coerce .# getCompose - {-# INLINE coerce #-} +-- @'id' = 'fmap' f = 'coerce' = 'contramap' g@ +coerce :: (Contravariant f, Functor f) => f a -> f b +coerce a = absurd <$> contramap absurd a +{-# INLINE coerce #-} -- | The 'mempty' equivalent for a 'Gettable' 'Applicative' 'Functor'. -noEffect :: (Applicative f, Gettable f) => f a +noEffect :: (Contravariant f, Applicative f) => f a noEffect = coerce $ pure () {-# INLINE noEffect #-} @@ -82,6 +69,10 @@ fmap _ (Accessor m) = Accessor m {-# INLINE fmap #-} +instance Contravariant (Accessor r) where + contramap _ (Accessor m) = Accessor m + {-# INLINE contramap #-} + instance Semigroup r => Apply (Accessor r) where Accessor a <.> Accessor b = Accessor (a <> b) {-# INLINE (<.>) #-} @@ -91,7 +82,3 @@ {-# INLINE pure #-} Accessor a <*> Accessor b = Accessor (mappend a b) {-# INLINE (<*>) #-} - -instance Gettable (Accessor r) where - coerce (Accessor m) = Accessor m - {-# INLINE coerce #-} diff --git a/src/Control/Lens/Internal/Indexed.hs b/src/Control/Lens/Internal/Indexed.hs --- a/src/Control/Lens/Internal/Indexed.hs +++ b/src/Control/Lens/Internal/Indexed.hs @@ -37,12 +37,12 @@ import Control.Arrow as Arrow import Control.Category import Control.Comonad -import Control.Lens.Internal.Getter import Control.Lens.Internal.Instances () import Control.Monad import Control.Monad.Fix import Data.Distributive import Data.Functor.Bind +import Data.Functor.Contravariant import Data.Int import Data.Profunctor import Data.Profunctor.Rep @@ -244,10 +244,10 @@ ~(k, fa) -> (k, ff <*> fa) {-# INLINE (<*>) #-} -instance Gettable f => Gettable (Indexing f) where - coerce (Indexing m) = Indexing $ \i -> case m i of - (j, ff) -> (j, coerce ff) - {-# INLINE coerce #-} +instance Contravariant f => Contravariant (Indexing f) where + contramap f (Indexing m) = Indexing $ \i -> case m i of + (j, ff) -> (j, contramap f ff) + {-# INLINE contramap #-} -- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or -- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc. @@ -293,10 +293,10 @@ ~(k, fa) -> (k, ff <*> fa) {-# INLINE (<*>) #-} -instance Gettable f => Gettable (Indexing64 f) where - coerce (Indexing64 m) = Indexing64 $ \i -> case m i of - (j, ff) -> (j, coerce ff) - {-# INLINE coerce #-} +instance Contravariant f => Contravariant (Indexing64 f) where + contramap f (Indexing64 m) = Indexing64 $ \i -> case m i of + (j, ff) -> (j, contramap f ff) + {-# INLINE contramap #-} -- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or -- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc. diff --git a/src/Control/Lens/Internal/Iso.hs b/src/Control/Lens/Internal/Iso.hs --- a/src/Control/Lens/Internal/Iso.hs +++ b/src/Control/Lens/Internal/Iso.hs @@ -14,6 +14,7 @@ ---------------------------------------------------------------------------- module Control.Lens.Internal.Iso ( Exchange(..) + , Reversing(..) ) where import Data.Profunctor @@ -21,6 +22,15 @@ #ifndef SAFE import Unsafe.Coerce #endif +import Data.ByteString as StrictB +import Data.ByteString.Lazy as LazyB +import Data.Text as StrictT +import Data.Text.Lazy as LazyT +import Data.Vector as Vector +import Data.Vector.Primitive as Prim +import Data.Vector.Storable as Storable +import Data.Vector.Unboxed as Unbox +import Data.Sequence as Seq ------------------------------------------------------------------------------ -- Isomorphism: Exchange @@ -45,3 +55,41 @@ {-# INLINE ( #. ) #-} ( .# ) p _ = unsafeCoerce p {-# INLINE ( .# ) #-} + +------------------------------------------------------------------------------ +-- Reversible +------------------------------------------------------------------------------ + +-- | This class provides a generalized notion of list reversal extended to other containers. +class Reversing t where + reversing :: t -> t + +instance Reversing [a] where + reversing = Prelude.reverse + +instance Reversing StrictB.ByteString where + reversing = StrictB.reverse + +instance Reversing LazyB.ByteString where + reversing = LazyB.reverse + +instance Reversing StrictT.Text where + reversing = StrictT.reverse + +instance Reversing LazyT.Text where + reversing = LazyT.reverse + +instance Reversing (Vector.Vector a) where + reversing = Vector.reverse + +instance Reversing (Seq a) where + reversing = Seq.reverse + +instance Prim a => Reversing (Prim.Vector a) where + reversing = Prim.reverse + +instance Unbox a => Reversing (Unbox.Vector a) where + reversing = Unbox.reverse + +instance Storable a => Reversing (Storable.Vector a) where + reversing = Storable.reverse diff --git a/src/Control/Lens/Internal/Magma.hs b/src/Control/Lens/Internal/Magma.hs --- a/src/Control/Lens/Internal/Magma.hs +++ b/src/Control/Lens/Internal/Magma.hs @@ -41,10 +41,10 @@ import Control.Comonad import Control.Lens.Internal.Bazaar import Control.Lens.Internal.Context -import Control.Lens.Internal.Getter import Control.Lens.Internal.Indexed import Data.Foldable import Data.Functor.Apply +import Data.Functor.Contravariant import Data.Monoid import Data.Profunctor.Rep import Data.Profunctor.Unsafe @@ -240,8 +240,9 @@ go (Magma _ wa) = corep pafb wa {-# INLINE bazaar #-} -instance Gettable f => Gettable (TakingWhile p f a b) where - coerce = (<$) (error "coerced TakingWhile") +instance Contravariant f => Contravariant (TakingWhile p f a b) where + contramap _ = (<$) (error "contramap: TakingWhile") + {-# INLINE contramap #-} instance IndexedFunctor (TakingWhile p f) where ifmap = fmap diff --git a/src/Control/Lens/Internal/Review.hs b/src/Control/Lens/Internal/Review.hs --- a/src/Control/Lens/Internal/Review.hs +++ b/src/Control/Lens/Internal/Review.hs @@ -19,10 +19,12 @@ -- ---------------------------------------------------------------------------- module Control.Lens.Internal.Review - ( - -- ** Reviewing - Reviewable(..) - , Reviewed(..) + ( + -- * Internal Classes + Reviewable, + -- * Reviews + retagged, + Reviewed(..) ) where import Control.Applicative @@ -38,24 +40,16 @@ import Data.Profunctor.Rep import Data.Profunctor.Unsafe import Data.Proxy -import Data.Tagged import Data.Traversable +import Data.Void #ifndef SAFE import Unsafe.Coerce #endif ------------------------------------------------------------------------------ --- Reviewable ----------------------------------------------------------------------------- - --- | This provides a dual notion to that of 'Control.Lens.Getter.Gettable'. -class Profunctor p => Reviewable p where - retagged :: p a b -> p s b - -- retaggedDot, dotRetagged? - -instance Reviewable Tagged where - retagged = retag - {-# INLINE retagged #-} +-- | This class is provided mostly for backwards compatibility with lens 3.8, +-- but it can also shorten type signatures. +class (Profunctor p, Bifunctor p) => Reviewable p +instance (Profunctor p, Bifunctor p) => Reviewable p ------------------------------------------------------------------------------ -- Review: Reviewed @@ -65,11 +59,10 @@ -- -- It plays a role similar to that of 'Control.Lens.Internal.Getter.Accessor' -- or 'Const' do for "Control.Lens.Getter" -newtype Reviewed a b = Reviewed { runReviewed :: b } +retagged :: (Profunctor p, Bifunctor p) => p a b -> p s b +retagged = first absurd . lmap absurd -instance Reviewable Reviewed where - retagged (Reviewed b) = Reviewed b - {-# INLINE retagged #-} +newtype Reviewed a b = Reviewed { runReviewed :: b } instance Functor (Reviewed a) where fmap bc (Reviewed b) = Reviewed (bc b) diff --git a/src/Control/Lens/Internal/Setter.hs b/src/Control/Lens/Internal/Setter.hs --- a/src/Control/Lens/Internal/Setter.hs +++ b/src/Control/Lens/Internal/Setter.hs @@ -26,6 +26,7 @@ import Data.Foldable import Data.Functor.Bind import Data.Functor.Compose +import Data.Functor.Extend import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Unsafe @@ -92,6 +93,8 @@ instance Bind Mutator where Mutator x >>- f = f x {-# INLINE (>>-) #-} + join = runMutator + {-# INLINE join #-} instance Monad Mutator where return = Mutator @@ -99,6 +102,12 @@ Mutator x >>= f = f x {-# INLINE (>>=) #-} +instance Extend Mutator where + extended f w = Mutator (f w) + {-# INLINE extended #-} + duplicated = Mutator + {-# INLINE duplicated #-} + instance Comonad Mutator where extract = runMutator {-# INLINE extract #-} @@ -108,7 +117,7 @@ {-# INLINE duplicate #-} instance ComonadApply Mutator where - (<@>) = (<*>) + Mutator f <@> Mutator a = Mutator (f a) {-# INLINE (<@>) #-} instance Distributive Mutator where diff --git a/src/Control/Lens/Internal/Zoom.hs b/src/Control/Lens/Internal/Zoom.hs --- a/src/Control/Lens/Internal/Zoom.hs +++ b/src/Control/Lens/Internal/Zoom.hs @@ -49,6 +49,7 @@ import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Data.Functor.Bind +import Data.Functor.Contravariant import Data.Semigroup import Prelude hiding ((.),id) @@ -287,6 +288,6 @@ EffectRWS m <*> EffectRWS n = EffectRWS $ \st -> m st >>= \ (s,t,w) -> n t >>= \ (s',u,w') -> return (mappend s s', u, mappend w w') {-# INLINE (<*>) #-} -instance Gettable (EffectRWS w st m s) where - coerce (EffectRWS m) = EffectRWS m - {-# INLINE coerce #-} +instance Contravariant (EffectRWS w st m s) where + contramap _ (EffectRWS m) = EffectRWS m + {-# INLINE contramap #-} diff --git a/src/Control/Lens/Iso.hs b/src/Control/Lens/Iso.hs --- a/src/Control/Lens/Iso.hs +++ b/src/Control/Lens/Iso.hs @@ -44,32 +44,43 @@ , flipped , Swapped(..) , Strict(..) + , Reversing(..), reversed + , involuted -- ** Uncommon Isomorphisms , magma , imagma , Magma + -- ** Contravariant functors + , contramapping -- * Profunctors , Profunctor(dimap,rmap,lmap) + , dimapping + , lmapping + , rmapping ) where import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed -import Control.Lens.Internal.Iso +import Control.Lens.Internal.Iso as Iso import Control.Lens.Internal.Magma import Control.Lens.Internal.Setter import Control.Lens.Type +import Control.Monad.State.Lazy as Lazy +import Control.Monad.State.Strict as Strict +import Control.Monad.Writer.Lazy as Lazy +import Control.Monad.Writer.Strict as Strict +import Control.Monad.RWS.Lazy as Lazy +import Control.Monad.RWS.Strict as Strict import Data.Bifunctor -import Data.ByteString as StrictB -import Data.ByteString.Lazy as LazyB -import Data.Text as StrictT -import Data.Text.Lazy as LazyT +import Data.ByteString as StrictB hiding (reverse) +import Data.ByteString.Lazy as LazyB hiding (reverse) +import Data.Functor.Contravariant +import Data.Text as StrictT hiding (reverse) +import Data.Text.Lazy as LazyT hiding (reverse) import Data.Tuple (swap) import Data.Maybe import Data.Profunctor import Data.Profunctor.Unsafe -#ifndef SAFE -import Unsafe.Coerce -#endif {-# ANN module "HLint: ignore Use on" #-} @@ -113,13 +124,15 @@ -- 'from' ('from' l) ≡ l -- @ from :: AnIso s t a b -> Iso b a t s -from l = case runIso l of - Exchange sa bt -> iso bt sa +from l = withIso l $ \ sa bt -> iso bt sa {-# INLINE from #-} +-- | Extract the two functions, one from @s -> a@ and +-- one from @b -> t@ that characterize an 'Iso'. withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r -withIso l k = case runIso l of - Exchange sa bt -> k sa bt +withIso ai k = case ai (Exchange id Mutator) of + Exchange sa bt -> k sa (runMutator #. bt) +{-# INLINE withIso #-} -- | Convert from 'AnIso' back to any 'Iso'. -- @@ -128,26 +141,13 @@ -- -- See 'Control.Lens.Lens.cloneLens' or 'Control.Lens.Traversal.cloneTraversal' for more information on why you might want to do this. cloneIso :: AnIso s t a b -> Iso s t a b -cloneIso k = case runIso k of - Exchange sa bt -> iso sa bt +cloneIso k = withIso k $ \ sa bt -> iso sa bt {-# INLINE cloneIso #-} ----------------------------------------------------------------------------- -- Isomorphisms families as Lenses ----------------------------------------------------------------------------- --- | Extract the two functions, one from @s -> a@ and one from @b -> t@ that characterize --- an 'Iso'. -runIso :: AnIso s t a b -> Exchange a b s t -#ifdef SAFE -runIso ai = case ai (Exchange id Mutator) of - Exchange sa bt -> Exchange sa (runMutator #. bt) -#else -runIso ai = unsafeCoerce $ ai $ Exchange id Mutator -#endif - -{-# INLINE runIso #-} - -- | Based on 'Control.Lens.Wrapped.ala' from Conor McBride's work on Epigram. -- -- This version is generalized to accept any 'Iso', not just a @newtype@. @@ -155,8 +155,7 @@ -- >>> au (wrapping Sum) foldMap [1,2,3,4] -- 10 au :: AnIso s t a b -> ((s -> a) -> e -> b) -> e -> t -au k = case runIso k of - Exchange sa bt -> \ f e -> bt (f sa e) +au k = withIso k $ \ sa bt f e -> bt (f sa e) {-# INLINE au #-} -- | Based on @ala'@ from Conor McBride's work on Epigram. @@ -171,8 +170,7 @@ -- >>> auf (wrapping Sum) (foldMapOf both) Prelude.length ("hello","world") -- 10 auf :: AnIso s t a b -> ((r -> a) -> e -> b) -> (r -> s) -> e -> t -auf k = case runIso k of - Exchange sa bt -> \ f g e -> bt (f (sa . g) e) +auf k = withIso k $ \ sa bt f g e -> bt (f (sa . g) e) {-# INLINE auf #-} -- | The opposite of working 'Control.Lens.Setter.over' a 'Setter' is working 'under' an isomorphism. @@ -182,11 +180,10 @@ -- @ -- -- @ --- 'under' :: 'Iso' s t a b -> (s -> t) -> a -> b +-- 'under' :: 'Iso' s t a b -> (t -> s) -> b -> a -- @ under :: AnIso s t a b -> (t -> s) -> b -> a -under k = case runIso k of - Exchange sa bt -> \ts -> sa . ts . bt +under k = withIso k $ \ sa bt ts -> sa . ts . bt {-# INLINE under #-} ----------------------------------------------------------------------------- @@ -212,8 +209,7 @@ -- | This can be used to lift any 'Iso' into an arbitrary 'Functor'. mapping :: Functor f => AnIso s t a b -> Iso (f s) (f t) (f a) (f b) -mapping k = case runIso k of - Exchange sa bt -> iso (fmap sa) (fmap bt) +mapping k = withIso k $ \ sa bt -> iso (fmap sa) (fmap bt) {-# INLINE mapping #-} -- | Composition with this isomorphism is occasionally useful when your 'Lens', @@ -350,6 +346,44 @@ strict = iso LazyT.toStrict LazyT.fromStrict {-# INLINE strict #-} +instance Strict (Lazy.StateT s m a) (Strict.StateT s m a) where + strict = iso (Strict.StateT . Lazy.runStateT) (Lazy.StateT . Strict.runStateT) + {-# INLINE strict #-} + +instance Strict (Lazy.WriterT w m a) (Strict.WriterT w m a) where + strict = iso (Strict.WriterT . Lazy.runWriterT) (Lazy.WriterT . Strict.runWriterT) + {-# INLINE strict #-} + +instance Strict (Lazy.RWST r w s m a) (Strict.RWST r w s m a) where + strict = iso (Strict.RWST . Lazy.runRWST) (Lazy.RWST . Strict.runRWST) + {-# INLINE strict #-} + + +-- | An 'Iso' between a list, 'ByteString', 'Text' fragment, etc. and its reversal. +-- +-- >>> "live" ^. reversed +-- "evil" +-- +-- >>> "live" & reversed %~ ('d':) +-- "lived" +reversed :: Reversing a => Iso' a a +reversed = involuted Iso.reversing + +-- | Given a function that is its own inverse, this gives you an 'Iso' using it in both directions. +-- +-- @ +-- 'involuted' ≡ 'Control.Monad.join' 'iso' +-- @ +-- +-- >>> "live" ^. involuted reverse +-- "evil" +-- +-- >>> "live" & involuted reverse %~ ('d':) +-- "lived" +involuted :: (a -> a) -> Iso' a a +involuted a = iso a a +{-# INLINE involuted #-} + ------------------------------------------------------------------------------ -- Magma ------------------------------------------------------------------------------ @@ -367,3 +401,52 @@ imagma :: Overloading (Indexed i) (->) (Molten i a b) s t a b -> Iso s t' (Magma i t b a) (Magma j t' c c) imagma l = iso (runMolten #. l sell) (iextract .# Molten) {-# INLINE imagma #-} + +------------------------------------------------------------------------------ +-- Contravariant +------------------------------------------------------------------------------ + +-- | Lift an 'Iso' into a 'Contravariant' functor. +-- +-- @ +-- contramapping :: 'Contravariant' f => 'Iso' s t a b -> 'Iso' (f a) (f b) (f s) (f t) +-- contramapping :: 'Contravariant' f => 'Iso'' s a -> 'Iso'' (f a) (f s) +-- @ +contramapping :: Contravariant f => AnIso s t a b -> Iso (f a) (f b) (f s) (f t) +contramapping f = withIso f $ \ sa bt -> iso (contramap sa) (contramap bt) +{-# INLINE contramapping #-} + +------------------------------------------------------------------------------ +-- Profunctor +------------------------------------------------------------------------------ + +-- | Lift two 'Iso's into both arguments of a 'Profunctor' simultaneously. +-- +-- @ +-- dimapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' s' t' a' b' -> 'Iso' (p a s') (p b t') (p s a') (p t b') +-- dimapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' s' a' -> 'Iso'' (p a s') (p s a') +-- @ +dimapping :: Profunctor p => AnIso s t a b -> AnIso s' t' a' b' -> Iso (p a s') (p b t') (p s a') (p t b') +dimapping f g = withIso f $ \ s'a' b't' -> withIso g $ \ sa bt -> + iso (dimap s'a' sa) (dimap b't' bt) +{-# INLINE dimapping #-} + +-- | Lift an 'Iso' contravariantly into the left argument of a 'Profunctor'. +-- +-- @ +-- lmapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' (p a x) (p b y) (p s x) (p t y) +-- lmapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' (p a x) (p s x) +-- @ +lmapping :: Profunctor p => AnIso s t a b -> Iso (p a x) (p b y) (p s x) (p t y) +lmapping f = withIso f $ \ sa bt -> iso (lmap sa) (lmap bt) +{-# INLINE lmapping #-} + +-- | Lift an 'Iso' covariantly into the right argument of a 'Profunctor'. +-- +-- @ +-- rmapping :: 'Profunctor' p => 'Iso' s t a b -> 'Iso' (p x s) (p y t) (p x a) (p y b) +-- rmapping :: 'Profunctor' p => 'Iso'' s a -> 'Iso'' (p x s) (p x a) +-- @ +rmapping :: Profunctor p => AnIso s t a b -> Iso (p x s) (p y t) (p x a) (p y b) +rmapping g = withIso g $ \ sa bt -> iso (rmap sa) (rmap bt) +{-# INLINE rmapping #-} diff --git a/src/Control/Lens/Lens.hs b/src/Control/Lens/Lens.hs --- a/src/Control/Lens/Lens.hs +++ b/src/Control/Lens/Lens.hs @@ -71,6 +71,7 @@ , (%%~), (%%=) , (%%@~), (%%@=) , (<%@~), (<%@=) + , (<<%@~), (<<%@=) -- * Lateral Composition , choosing @@ -139,8 +140,8 @@ -- >>> let setter :: Expr -> Expr -> Expr; setter = fun "setter" infixl 8 ^# -infixr 4 %%@~, <%@~, %%~, <+~, <*~, <-~, ~, <%~, <<%~, <<.~, <#~, #~, #%~, <#%~, #%%~ -infix 4 %%@=, <%@=, %%=, <+=, <*=, <-=, =, <%=, <<%=, <<.=, <#=, #=, #%=, <#%=, #%%= +infixr 4 %%@~, <%@~, <<%@~, %%~, <+~, <*~, <-~, ~, <%~, <<%~, <<.~, <#~, #~, #%~, <#%~, #%%~ +infix 4 %%@=, <%@=, <<%@=, %%=, <+=, <*=, <-=, =, <%=, <<%=, <<.=, <#=, #=, #%=, <#%=, #%%= infixr 2 <<~ ------------------------------------------------------------------------------- @@ -367,8 +368,8 @@ -- -- @ -- 'locus' :: 'Lens'' ('Context'' a s) a --- 'locus' :: 'Lens'' ('Pretext'' p a s) a --- 'locus' :: 'Lens'' ('PretextT'' p g a s) a +-- 'locus' :: 'Conjoined' p => 'Lens'' ('Pretext'' p a s) a +-- 'locus' :: 'Conjoined' p => 'Lens'' ('PretextT'' p g a s) a -- @ locus :: IndexedComonadStore p => Lens (p a c s) (p b c s) a b locus f w = (`iseek` w) <$> f (ipos w) @@ -448,8 +449,8 @@ -- flexible. -- -- @ --- ('<*~') :: 'Num' b => 'Lens'' s a -> a -> a -> (s, a) --- ('<*~') :: 'Num' b => 'Control.Lens.Iso.Iso'' s a -> a -> a -> (s, a) +-- ('<*~') :: 'Num' a => 'Lens'' s a -> a -> s -> (a, s) +-- ('<*~') :: 'Num' a => 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ (<*~) :: Num a => Overloading (->) q ((,)a) s t a a -> a -> q s (a, t) l <*~ a = l <%~ (* a) @@ -460,8 +461,8 @@ -- When you do not need the result of the division, ('Control.Lens.Setter.//~') is more flexible. -- -- @ --- (' 'Lens'' s a -> a -> a -> (s, a) --- (' 'Control.Lens.Iso.Iso'' s a -> a -> a -> (s, a) +-- (' 'Lens'' s a -> a -> s -> (a, s) +-- (' 'Control.Lens.Iso.Iso'' s a -> a -> s -> (a, s) -- @ ( Overloading (->) q ((,)a) s t a a -> a -> q s (a, t) l 'Lens'' s a -> e -> a -> (a, s) --- ('<^~') :: ('Num' b, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> a -> (a, s) +-- ('<^~') :: ('Num' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) +-- ('<^~') :: ('Num' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> s -> (a, s) -- @ (<^~) :: (Num a, Integral e) => Overloading (->) q ((,)a) s t a a -> e -> q s (a, t) l <^~ e = l <%~ (^ e) @@ -486,8 +487,8 @@ -- When you do not need the result of the division, ('Control.Lens.Setter.^^~') is more flexible. -- -- @ --- ('<^^~') :: ('Fractional' b, 'Integral' e) => 'Lens'' s a -> e -> a -> (a, s) --- ('<^^~') :: ('Fractional' b, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> a -> (a, s) +-- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Lens'' s a -> e -> s -> (a, s) +-- ('<^^~') :: ('Fractional' a, 'Integral' e) => 'Control.Lens.Iso.Iso'' s a -> e -> s -> (a, s) -- @ (<^^~) :: (Fractional a, Integral e) => Overloading (->) q ((,)a) s t a a -> e -> q s (a, t) l <^^~ e = l <%~ (^^ e) @@ -535,9 +536,9 @@ -- When you do not need the result of the addition, ('Control.Lens.Setter.%~') is more flexible. -- -- @ --- ('<<%~') :: 'Lens' s t a b -> (a -> b) -> s -> (b, t) --- ('<<%~') :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> (b, t) --- ('<<%~') :: 'Monoid' b => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> (b, t) +-- ('<<%~') :: 'Lens' s t a b -> (a -> b) -> s -> (a, t) +-- ('<<%~') :: 'Control.Lens.Iso.Iso' s t a b -> (a -> b) -> s -> (a, t) +-- ('<<%~') :: 'Monoid' a => 'Control.Lens.Traversal.Traversal' s t a b -> (a -> b) -> s -> (a, t) -- @ (<<%~) :: Strong p => Overloading p q ((,)a) s t a b -> p a b -> q s (a, t) (<<%~) l = l . lmap (\a -> (a, a)) . second' @@ -548,9 +549,9 @@ -- When you do not need the old value, ('Control.Lens.Setter.%~') is more flexible. -- -- @ --- ('<<%~') :: 'Lens' s t a b -> b -> s -> (a, t) --- ('<<%~') :: 'Control.Lens.Iso.Iso' s t a b -> b -> s -> (a, t) --- ('<<%~') :: 'Monoid' b => 'Control.Lens.Traversal.Traversal' s t a b -> b -> s -> (a, t) +-- ('<<.~') :: 'Lens' s t a b -> b -> s -> (a, t) +-- ('<<.~') :: 'Control.Lens.Iso.Iso' s t a b -> b -> s -> (a, t) +-- ('<<.~') :: 'Monoid' a => 'Control.Lens.Traversal.Traversal' s t a b -> b -> s -> (a, t) -- @ (<<.~) :: Overloading (->) q ((,)a) s t a b -> b -> q s (a, t) l <<.~ b = l $ \a -> (a, b) @@ -788,6 +789,19 @@ l <%@~ f = l (Indexed $ \i a -> let b = f i a in (b, b)) {-# INLINE (<%@~) #-} +-- | Adjust the target of an 'IndexedLens' returning the old value, or +-- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' and return a monoidal summary +-- of the old values along with the answer. +-- +-- @ +-- ('<<%@~') :: 'IndexedLens' i s t a b -> (i -> a -> b) -> s -> (a, t) +-- ('<<%@~') :: 'Monoid' a => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> (a, t) +-- @ +(<<%@~) :: Overloading (Indexed i) q ((,) a) s t a b -> (i -> a -> b) -> q s (a, t) +l <<%@~ f = l $ Indexed $ \i a -> second' (f i) (a,a) + +{-# INLINE (<<%@~) #-} + -- | Adjust the target of an 'IndexedLens' returning a supplementary result, or -- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' and return a monoidal summary -- of the supplementary results and the answer. @@ -796,7 +810,7 @@ -- -- @ -- ('%%@~') :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t --- ('%%@~') :: 'Functor' f => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t +-- ('%%@~') :: 'Applicative' f => 'Control.Lens.Traversal.IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t -- @ -- -- In particular, it is often useful to think of this function as having one of these even more @@ -817,7 +831,7 @@ -- @l '%%@=' f ≡ 'state' (l '%%@~' f)@ -- -- @ --- ('%%@=') :: 'MonadState' s m 'IndexedLens' i s s a b -> (i -> a -> (r, b)) -> s -> m r +-- ('%%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- ('%%@=') :: ('MonadState' s m, 'Monoid' r) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> (r, b)) -> s -> m r -- @ (%%@=) :: MonadState s m => IndexedLensLike i ((,) r) s s a b -> (i -> a -> (r, b)) -> m r @@ -836,13 +850,32 @@ -- return a monoidal summary of the intermediate results. -- -- @ --- ('<%@=') :: 'MonadState' s m 'IndexedLens' i s s a b -> (i -> a -> b) -> m b +-- ('<%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> b) -> m b -- ('<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m b -- @ (<%@=) :: MonadState s m => IndexedLensLike i ((,) b) s s a b -> (i -> a -> b) -> m b l <%@= f = l %%@= \ i a -> let b = f i a in (b, b) {-# INLINE (<%@=) #-} +-- | Adjust the target of an 'IndexedLens' returning the old value, or +-- adjust all of the targets of an 'Control.Lens.Traversal.IndexedTraversal' within the current state, and +-- return a monoidal summary of the old values. +-- +-- @ +-- ('<<%@=') :: 'MonadState' s m => 'IndexedLens' i s s a b -> (i -> a -> b) -> m a +-- ('<<%@=') :: ('MonadState' s m, 'Monoid' b) => 'Control.Lens.Traversal.IndexedTraversal' i s s a b -> (i -> a -> b) -> m a +-- @ +(<<%@=) :: MonadState s m => IndexedLensLike i ((,) a) s s a b -> (i -> a -> b) -> m a +#if MIN_VERSION_mtl(2,1,0) +l <<%@= f = State.state (l (Indexed $ \ i a -> (a, f i a))) +#else +l <<%@= f = do + (r, s) <- State.gets (l (Indexed $ \ i a -> (a, f i a))) + State.put s + return r +#endif +{-# INLINE (<<%@=) #-} + ------------------------------------------------------------------------------ -- ALens Combinators ------------------------------------------------------------------------------ @@ -943,7 +976,7 @@ -- >>> [] & mapped.devoid +~ 1 -- [] -- --- Nothing & mapped.devoid %~ abs +-- >>> Nothing & mapped.devoid %~ abs -- Nothing -- -- @ diff --git a/src/Control/Lens/Loupe.hs b/src/Control/Lens/Loupe.hs --- a/src/Control/Lens/Loupe.hs +++ b/src/Control/Lens/Loupe.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Rank2Types #-} ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Loupe diff --git a/src/Control/Lens/Operators.hs b/src/Control/Lens/Operators.hs --- a/src/Control/Lens/Operators.hs +++ b/src/Control/Lens/Operators.hs @@ -56,6 +56,7 @@ -- *** with Indices , (%@~), (%@=) , (<%@~), (<%@=) + , (<<%@~), (<<%@=) -- ** Traversing , (%%~), (%%=) diff --git a/src/Control/Lens/Plated.hs b/src/Control/Lens/Plated.hs --- a/src/Control/Lens/Plated.hs +++ b/src/Control/Lens/Plated.hs @@ -104,7 +104,7 @@ -- @ -- import Control.Applicative -- import Control.Lens --- import Control.Plated +-- import Control.Lens.Plated -- import Data.Data -- import Data.Data.Lens ('Data.Data.Lens.uniplate') -- @ @@ -136,7 +136,7 @@ -- @ -- import Control.Applicative -- import Control.Lens --- import Control.Plated +-- import Control.Lens.Plated -- import Data.Data -- import Data.Data.Lens ('Data.Data.Lens.uniplate') -- @ @@ -330,13 +330,13 @@ -- @ -- 'universeOf' :: 'Fold' a a -> a -> [a] -- @ -universeOf :: Getting [a] a b a b -> a -> [a] +universeOf :: Getting [a] a a -> a -> [a] universeOf l = go where go a = a : foldMapOf l go a {-# INLINE universeOf #-} -- | Given a 'Fold' that knows how to find 'Plated' parts of a container retrieve them and all of their descendants, recursively. -universeOn :: Plated a => Getting [a] s t a a -> s -> [a] +universeOn :: Plated a => Getting [a] s a -> s -> [a] universeOn b = universeOnOf b plate {-# INLINE universeOn #-} @@ -346,7 +346,7 @@ -- @ -- 'toListOf' l ≡ 'universeOnOf' l 'ignored' -- @ -universeOnOf :: Getting [a] s t a b -> Getting [a] a b a b -> s -> [a] +universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a] universeOnOf b = foldMapOf b . universeOf {-# INLINE universeOnOf #-} @@ -429,7 +429,7 @@ -- @ -- 'transformMOnOf' :: 'Monad' m => 'Traversal'' s a -> 'Traversal'' a a -> (a -> m a) -> s -> m s -- @ -transformMOnOf :: Monad m => LensLike (WrappedMonad m) s a a a -> LensLike' (WrappedMonad m) a a -> (a -> m a) -> s -> m a +transformMOnOf :: Monad m => LensLike (WrappedMonad m) s t a a -> LensLike' (WrappedMonad m) a a -> (a -> m a) -> s -> m t transformMOnOf b l = mapMOf b . transformMOf l {-# INLINE transformMOnOf #-} @@ -459,7 +459,7 @@ -- @ -- -- @ --- 'contextsOf' :: 'Traversal'' a a -> a -> ['Context' a a] +-- 'contextsOf' :: 'Traversal'' a a -> a -> ['Context' a a a] -- @ contextsOf :: ATraversal' a a -> a -> [Context a a a] contextsOf l x = sell x : f (map context (holesOf l x)) where @@ -558,7 +558,7 @@ -- @ -- 'paraOf' :: 'Fold' a a -> (a -> [r] -> r) -> a -> r -- @ -paraOf :: Getting (Endo [a]) a b a b -> (a -> [r] -> r) -> a -> r +paraOf :: Getting (Endo [a]) a a -> (a -> [r] -> r) -> a -> r paraOf l f = go where go a = f a (go <$> toListOf l a) {-# INLINE paraOf #-} diff --git a/src/Control/Lens/Prism.hs b/src/Control/Lens/Prism.hs --- a/src/Control/Lens/Prism.hs +++ b/src/Control/Lens/Prism.hs @@ -51,6 +51,8 @@ import Unsafe.Coerce #endif +{-# ANN module "HLint: ignore Use camelCase" #-} + -- $setup -- >>> :set -XNoOverloadedStrings -- >>> import Control.Lens @@ -267,3 +269,4 @@ -- Nothing only :: Eq a => a -> Prism' a () only a = prism' (\() -> a) $ guard . (a ==) +{-# INLINE only #-} diff --git a/src/Control/Lens/Review.hs b/src/Control/Lens/Review.hs --- a/src/Control/Lens/Review.hs +++ b/src/Control/Lens/Review.hs @@ -25,8 +25,9 @@ , review, reviews , reuse, reuses , ( # ) - -- * Reviewable Profunctors - , Reviewable(..) + , Bifunctor(bimap) + , retagged + , Reviewable ) where import Control.Monad.Reader as Reader @@ -35,9 +36,11 @@ import Control.Lens.Internal.Review import Control.Lens.Internal.Setter import Control.Lens.Type +import Data.Bifunctor import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Unsafe +import Data.Void -- $setup -- >>> :set -XNoOverloadedStrings @@ -46,7 +49,7 @@ -- >>> let isLeft (Left _) = True; isLeft _ = False -- >>> let isRight (Right _) = True; isRight _ = False -infixr 9 # +infixr 8 # ------------------------------------------------------------------------------ -- Review @@ -58,7 +61,7 @@ -- -- You can generate a 'Review' by using 'unto'. You can also use any 'Prism' or 'Iso' -- directly as a 'Review'. -type Review s t a b = forall p f. (Reviewable p, Settable f) => Overloaded p f s t a b +type Review s t a b = forall p f. (Profunctor p, Bifunctor p, Settable f) => Overloaded p f s t a b -- | A 'Simple' 'Review' type Review' t b = Review t t b b @@ -75,8 +78,9 @@ -- @ -- 'unto' :: (b -> t) -> 'Review'' t b -- @ -unto :: (Reviewable p, Functor f) => (b -> t) -> Overloaded p f s t a b -unto f = retagged . rmap (fmap f) +unto :: (Profunctor p, Bifunctor p, Functor f) => (b -> t) -> Overloaded p f s t a b +unto f = first absurd . lmap absurd . rmap (fmap f) +{-# INLINE unto #-} -- | Turn a 'Prism' or 'Control.Lens.Iso.Iso' around to build a 'Getter'. -- 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 @@ -790,7 +790,7 @@ prefix ('_':xs) | '_' `List.elem` xs = Just (takeWhile (/= '_') xs) prefix _ = Nothing rawLens x = x ++ "_lens" - niceLens x = prefix x <&> \n -> drop (length n + 2) n + niceLens x = prefix x <&> \n -> drop (length n + 2) x classNaming x = niceLens x <&> ("Has_" ++) -- | Field rules for fields in the form @ prefixFieldname @ @@ -805,12 +805,35 @@ niceLens x = overHead toLower . snd <$> sep x classNaming x = niceLens x <&> \ (n:ns) -> "Has" ++ toUpper n : ns +collectRecords :: [Con] -> [VarStrictType] +collectRecords cons = rs + where + recs = filter (\r -> case r of RecC{} -> True; _ -> False) cons + rs' = List.concatMap (\(RecC _ _rs) -> _rs) recs + rs = nubBy ((==) `on` (^._1)) rs' + verboseLenses :: FieldRules -> Name -> Q [Dec] verboseLenses c src = do - TyConI (DataD _ _ _ [RecC _ rs] _) <- reify src - flip makeLensesFor src + rs <- do + inf <- reify src + case inf of + TyConI decl -> case deNewtype decl of + DataD _ _ _ cons _ -> do + let rs = collectRecords cons + if List.null rs + then fail "verboseLenses: Expected the name of a record type" + else return rs + _ -> fail "verboseLenses: Unsupported data type" + _ -> fail "verboseLenses: Expected the name of a data type or newtype" + flip makeLenses' src $ mkFields c rs & map (\(Field n _ l _ _) -> (show n, show l)) + where + makeLenses' fields' = + makeLensesWith $ lensRules + & lensField .~ (`Prelude.lookup` fields') + & buildTraversals .~ False + & partialLenses .~ True mkFields :: FieldRules -> [VarStrictType] -> [Field] mkFields (FieldRules prefix' raw' nice' clas') rs @@ -832,7 +855,17 @@ hasClassAndInstance cfg src = do c <- newName "c" e <- newName "e" - TyConI (DataD _ _ vs [RecC _ rs] _) <- reify src + (vs,rs) <- do + inf <- reify src + case inf of + TyConI decl -> case deNewtype decl of + DataD _ _ vs cons _ -> do + let rs = collectRecords cons + if List.null rs + then fail "hasClassAndInstance: Expected the name of a record type" + else return (vs,rs) + _ -> fail "hasClassAndInstance: Unsupported data type" + _ -> fail "hasClassAndInstance: Expected the name of a data type or newtype" fmap concat . forM (mkFields cfg rs) $ \(Field field _ fullLensName className lensName) -> do classHas <- classD (return []) diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs --- a/src/Control/Lens/Traversal.hs +++ b/src/Control/Lens/Traversal.hs @@ -59,6 +59,7 @@ , transposeOf , mapAccumLOf, mapAccumROf , scanr1Of, scanl1Of + , failover -- * Monomorphic Traversals , cloneTraversal @@ -107,16 +108,19 @@ , Bazaar(..) , Bazaar' , loci + , iloci ) where import Control.Applicative as Applicative import Control.Applicative.Backwards import Control.Category import Control.Comonad +import Control.Monad import Control.Lens.Combinators import Control.Lens.Fold -import Control.Lens.Internal.Context +import Control.Lens.Getter (coerced) import Control.Lens.Internal.Bazaar +import Control.Lens.Internal.Context import Control.Lens.Internal.Indexed import Control.Lens.Type import Control.Monad.Trans.State.Lazy @@ -124,6 +128,7 @@ import Data.Int import Data.IntMap as IntMap import Data.Map as Map +import Data.Monoid import Data.Traversable import Data.Tuple (swap) import Data.Profunctor @@ -137,6 +142,7 @@ -- >>> import Control.DeepSeq (NFData (..), force) -- >>> import Control.Exception (evaluate) -- >>> import Data.Maybe (fromMaybe) +-- >>> import Data.Void -- >>> import System.Timeout (timeout) -- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force @@ -208,9 +214,9 @@ -- @ -- -- @ --- 'traverseOf' :: 'Iso' s t a b -> (a -> f b) -> s -> f t --- 'traverseOf' :: 'Lens' s t a b -> (a -> f b) -> s -> f t --- 'traverseOf' :: 'Traversal' s t a b -> (a -> f b) -> s -> f t +-- 'traverseOf' :: 'Functor' f => 'Iso' s t a b -> (a -> f b) -> s -> f t +-- 'traverseOf' :: 'Functor' f => 'Lens' s t a b -> (a -> f b) -> s -> f t +-- 'traverseOf' :: 'Applicative' f => 'Traversal' s t a b -> (a -> f b) -> s -> f t -- @ traverseOf :: Over p f s t a b -> p a (f b) -> s -> f t traverseOf = id @@ -237,9 +243,9 @@ -- @ -- -- @ --- 'forOf' :: 'Iso' s t a b -> s -> (a -> f b) -> f t --- 'forOf' :: 'Lens' s t a b -> s -> (a -> f b) -> f t --- 'forOf' :: 'Traversal' s t a b -> s -> (a -> f b) -> f t +-- 'forOf' :: 'Functor' f => 'Iso' s t a b -> s -> (a -> f b) -> f t +-- 'forOf' :: 'Functor' f => 'Lens' s t a b -> s -> (a -> f b) -> f t +-- 'forOf' :: 'Applicative' f => 'Traversal' s t a b -> s -> (a -> f b) -> f t -- @ forOf :: Over p f s t a b -> s -> p a (f b) -> f t forOf = flip @@ -257,8 +263,8 @@ -- @ -- -- @ --- 'sequenceAOf' :: 'Iso' s t (f b) b -> s -> f t --- 'sequenceAOf' :: 'Lens' s t (f b) b -> s -> f t +-- 'sequenceAOf' :: 'Functor' f => 'Iso' s t (f b) b -> s -> f t +-- 'sequenceAOf' :: 'Functor' f => 'Lens' s t (f b) b -> s -> f t -- 'sequenceAOf' :: 'Applicative' f => 'Traversal' s t (f b) b -> s -> f t -- @ sequenceAOf :: LensLike f s t (f b) b -> s -> f t @@ -277,8 +283,8 @@ -- @ -- -- @ --- 'mapMOf' :: 'Iso' s t a b -> (a -> m b) -> s -> m t --- 'mapMOf' :: 'Lens' s t a b -> (a -> m b) -> s -> m t +-- 'mapMOf' :: 'Monad' m => 'Iso' s t a b -> (a -> m b) -> s -> m t +-- 'mapMOf' :: 'Monad' m => 'Lens' s t a b -> (a -> m b) -> s -> m t -- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t -- @ mapMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t @@ -297,8 +303,8 @@ -- @ -- -- @ --- 'forMOf' :: 'Iso' s t a b -> s -> (a -> m b) -> m t --- 'forMOf' :: 'Lens' s t a b -> s -> (a -> m b) -> m t +-- 'forMOf' :: 'Monad' m => 'Iso' s t a b -> s -> (a -> m b) -> m t +-- 'forMOf' :: 'Monad' m => 'Lens' s t a b -> s -> (a -> m b) -> m t -- 'forMOf' :: 'Monad' m => 'Traversal' s t a b -> s -> (a -> m b) -> m t -- @ forMOf :: Profunctor p => Over p (WrappedMonad m) s t a b -> s -> p a (m b) -> m t @@ -317,8 +323,8 @@ -- @ -- -- @ --- 'sequenceOf' :: 'Iso' s t (m b) b -> s -> m t --- 'sequenceOf' :: 'Lens' s t (m b) b -> s -> m t +-- 'sequenceOf' :: 'Monad' m => 'Iso' s t (m b) b -> s -> m t +-- 'sequenceOf' :: 'Monad' m => 'Lens' s t (m b) b -> s -> m t -- 'sequenceOf' :: 'Monad' m => 'Traversal' s t (m b) b -> s -> m t -- @ sequenceOf :: LensLike (WrappedMonad m) s t (m b) b -> s -> m t @@ -431,6 +437,12 @@ loci f w = getCompose (runBazaar w (Compose #. fmap sell . f)) {-# INLINE loci #-} +-- | This 'IndexedTraversal' allows you to 'traverse' the individual stores in +-- a 'Bazaar' with access to their indices. +iloci :: IndexedTraversal i (Bazaar (Indexed i) a c s) (Bazaar (Indexed i) b c s) a b +iloci f w = getCompose (runBazaar w (Compose #. Indexed (\i -> fmap (indexed sell i) . indexed f i))) +{-# INLINE iloci #-} + ------------------------------------------------------------------------------- -- Parts and Holes ------------------------------------------------------------------------------- @@ -592,7 +604,7 @@ ------------------------------------------------------------------------------ ins :: Bizarre (->) w => w a b t -> [a] -ins = toListOf bazaar +ins = toListOf (coerced bazaar) {-# INLINE ins #-} pins :: (Bizarre p w, Corepresentable p) => w a b t -> [Corep p a] @@ -641,7 +653,7 @@ -- 'beside' :: 'Traversal' s t a b -> 'Traversal' s' t' a b -> 'Traversal' (s,s') (t,t') a b -- 'beside' :: 'Lens' s t a b -> 'Lens' s' t' a b -> 'Traversal' (s,s') (t,t') a b -- 'beside' :: 'Fold' s a -> 'Fold' s' a -> 'Fold' (s,s') a --- 'beside' :: 'Getter' s a -> 'Getter' s' a -> 'Traversal' (s,s') a +-- 'beside' :: 'Getter' s a -> 'Getter' s' a -> 'Fold' (s,s') a -- 'beside' :: 'Action' m s a -> 'Action' m s' a -> 'MonadicFold' m (s,s') a -- 'beside' :: 'MonadicFold' m s a -> 'MonadicFold' m s' a -> 'MonadicFold' m (s,s') a -- @ @@ -650,7 +662,7 @@ -- 'beside' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s' t' a b -> 'IndexedTraversal' i (s,s') (t,t') a b -- 'beside' :: 'IndexedLens' i s t a b -> 'IndexedLens' i s' t' a b -> 'IndexedTraversal' i (s,s') (t,t') a b -- 'beside' :: 'IndexedFold' i s a -> 'IndexedFold' i s' a -> 'IndexedFold' i (s,s') a --- 'beside' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s' a -> 'IndexedTraversal' i (s,s') a +-- 'beside' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s' a -> 'IndexedFold' i (s,s') a -- 'beside' :: 'IndexedAction' i m s a -> 'IndexedAction' i m s' a -> 'IndexedMonadicFold' i m (s,s') a -- 'beside' :: 'IndexedMonadicFold' i m s a -> 'IndexedMonadicFold' i m s' a -> 'IndexedMonadicFold' i m (s,s') a -- @ @@ -659,7 +671,7 @@ -- 'beside' :: 'IndexPreservingTraversal' s t a b -> 'IndexPreservingTraversal' s' t' a b -> 'IndexPreservingTraversal' (s,s') (t,t') a b -- 'beside' :: 'IndexPreservingLens' s t a b -> 'IndexPreservingLens' s' t' a b -> 'IndexPreservingTraversal' (s,s') (t,t') a b -- 'beside' :: 'IndexPreservingFold' s a -> 'IndexPreservingFold' s' a -> 'IndexPreservingFold' (s,s') a --- 'beside' :: 'IndexPreservingGetter' s a -> 'IndexPreservingGetter' s' a -> 'IndexPreservingTraversal' (s,s') a +-- 'beside' :: 'IndexPreservingGetter' s a -> 'IndexPreservingGetter' s' a -> 'IndexPreservingFold' (s,s') a -- 'beside' :: 'IndexPreservingAction' m s a -> 'IndexPreservingAction' m s' a -> 'IndexPreservingMonadicFold' m (s,s') a -- 'beside' :: 'IndexPreservingMonadicFold' m s a -> 'IndexPreservingMonadicFold' m s' a -> 'IndexPreservingMonadicFold' m (s,s') a -- @ @@ -756,12 +768,12 @@ -- former can execute at full speed, while the latter needs to round trip through -- the 'Bazaar'. -- --- >>> let foo l a = (view (cloneTraversal l) a, set (cloneTraversal l) 10 a) +-- >>> let foo l a = (view (coerced (cloneTraversal l)) a, set (cloneTraversal l) 10 a) -- >>> foo both ("hello","world") -- ("helloworld",(10,10)) -- -- @ --- 'cloneTraversal' :: 'LensLike' ('Bazaar' a b) s t a b -> 'Traversal' s t a b +-- 'cloneTraversal' :: 'LensLike' ('Bazaar' (->) a b) s t a b -> 'Traversal' s t a b -- @ cloneTraversal :: ATraversal s t a b -> Traversal s t a b cloneTraversal l f = bazaar f . l sell @@ -793,8 +805,8 @@ -- @ -- -- @ --- 'itraverseOf' :: 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t --- 'itraverseOf' :: 'IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t +-- 'itraverseOf' :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t +-- 'itraverseOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t -- @ itraverseOf :: (Indexed i a (f b) -> s -> f t) -> (i -> a -> f b) -> s -> f t itraverseOf l = l .# Indexed @@ -808,8 +820,8 @@ -- @ -- -- @ --- 'iforOf' :: 'IndexedLens' i s t a b -> s -> (i -> a -> f b) -> f t --- 'iforOf' :: 'IndexedTraversal' i s t a b -> s -> (i -> a -> f b) -> f t +-- 'iforOf' :: 'Functor' f => 'IndexedLens' i s t a b -> s -> (i -> a -> f b) -> f t +-- 'iforOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> s -> (i -> a -> f b) -> f t -- @ iforOf :: (Indexed i a (f b) -> s -> f t) -> s -> (i -> a -> f b) -> f t iforOf = flip . itraverseOf @@ -905,6 +917,9 @@ -- @ -- 'ignored' ≡ 'const' 'pure' -- @ +-- +-- >>> 6 & ignored %~ absurd +-- 6 ignored :: Applicative f => pafb -> s -> f s ignored _ = pure {-# INLINE ignored #-} @@ -1007,3 +1022,19 @@ elements :: Traversable t => (Int -> Bool) -> IndexedTraversal' Int (t a) a elements = elementsOf traverse {-# INLINE elements #-} + +-- | Try to map a function over this 'Traversal', failing if the 'Traversal' has no targets. +-- +-- >>> failover (element 3) (*2) [1,2] :: Maybe [Int] +-- Nothing +-- +-- >>> failover _Left (*2) (Right 4) :: Maybe (Either Int Int) +-- Nothing +-- +-- >>> failover _Right (*2) (Right 4) :: Maybe (Either Int Int) +-- Just (Right 8) +failover :: MonadPlus m => LensLike ((,) Any) s t a b -> (a -> b) -> s -> m t +failover l f s = case l ((,) (Any True) . f) s of + (Any True, t) -> return t + (Any False, _) -> mzero +{-# INLINE failover #-} diff --git a/src/Control/Lens/Tuple.hs b/src/Control/Lens/Tuple.hs --- a/src/Control/Lens/Tuple.hs +++ b/src/Control/Lens/Tuple.hs @@ -70,7 +70,7 @@ -- '_1' :: 'Lens' (a,b,c) (a',b,c) a a' -- '_1' :: 'Lens' (a,b,c,d) (a',b,c,d) a a' -- ... - -- '_1' :: 'Lens' (a,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' + -- '_1' :: 'Lens' (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' -- @ _1 :: IndexedLens Int s t a b diff --git a/src/Control/Lens/Type.hs b/src/Control/Lens/Type.hs --- a/src/Control/Lens/Type.hs +++ b/src/Control/Lens/Type.hs @@ -54,9 +54,9 @@ import Control.Applicative import Control.Lens.Internal.Action -import Control.Lens.Internal.Getter import Control.Lens.Internal.Setter import Control.Lens.Internal.Indexed +import Data.Functor.Contravariant import Data.Profunctor -- $setup @@ -409,14 +409,14 @@ -- -- Moreover, a 'Getter' can be used directly as a 'Control.Lens.Fold.Fold', -- since it just ignores the 'Applicative'. -type Getter s a = forall f. Gettable f => (a -> f a) -> s -> f s +type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s -- | Every 'IndexedGetter' is a valid 'Control.Lens.Fold.IndexedFold' and can be used for 'Control.Lens.Getter.Getting' like a 'Getter'. -type IndexedGetter i s a = forall p f. (Indexable i p, Gettable f) => p a (f a) -> s -> f s +type IndexedGetter i s a = forall p f. (Indexable i p, Contravariant f, Functor f) => p a (f a) -> s -> f s -- | An 'IndexPreservingGetter' can be used as a 'Getter', but when composed with an 'IndexedTraversal', -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold', 'IndexedFold' or 'IndexedGetter' respectively. -type IndexPreservingGetter s a = forall p f. (Conjoined p, Gettable f) => p a (f a) -> p s (f s) +type IndexPreservingGetter s a = forall p f. (Conjoined p, Contravariant f, Functor f) => p a (f a) -> p s (f s) -------------------------- -- Folds @@ -435,14 +435,14 @@ -- -- Unlike a 'Control.Lens.Traversal.Traversal' a 'Fold' is read-only. Since a 'Fold' cannot be used to write back -- there are no 'Lens' laws that apply. -type Fold s a = forall f. (Gettable f, Applicative f) => (a -> f a) -> s -> f s +type Fold s a = forall f. (Contravariant f, Applicative f) => (a -> f a) -> s -> f s -- | Every 'IndexedFold' is a valid 'Control.Lens.Fold.Fold' and can be used for 'Control.Lens.Getter.Getting'. -type IndexedFold i s a = forall p f. (Indexable i p, Applicative f, Gettable f) => p a (f a) -> s -> f s +type IndexedFold i s a = forall p f. (Indexable i p, Contravariant f, Applicative f) => p a (f a) -> s -> f s -- | An 'IndexPreservingFold' can be used as a 'Fold', but when composed with an 'IndexedTraversal', -- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold' respectively. -type IndexPreservingFold s a = forall p f. (Conjoined p, Gettable f, Applicative f) => p a (f a) -> p s (f s) +type IndexPreservingFold s a = forall p f. (Conjoined p, Contravariant f, Applicative f) => p a (f a) -> p s (f s) ------------------------------------------------------------------------------- -- Actions @@ -497,8 +497,8 @@ -- whenever the type variables don't change upon setting a value. -- -- @ --- 'Data.Complex.Lens.imaginary' :: 'Simple' 'Lens' ('Data.Complex.Complex' a) a --- 'Data.List.Lens._head' :: 'Simple' 'IndexedTraversal' 'Int' [a] a +-- 'Data.Complex.Lens._imagPart' :: 'Simple' 'Lens' ('Data.Complex.Complex' a) a +-- 'Control.Lens.Traversal.traversed' :: 'Simple' ('IndexedTraversal' 'Int') [a] a -- @ -- -- Note: To use this alias in your own code with @'LensLike' f@ or diff --git a/src/Control/Lens/Zoom.hs b/src/Control/Lens/Zoom.hs --- a/src/Control/Lens/Zoom.hs +++ b/src/Control/Lens/Zoom.hs @@ -90,10 +90,10 @@ -- @ -- 'zoom' :: 'Monad' m => 'Lens'' s t -> 'StateT' t m a -> 'StateT' s m a -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'StateT' t m c -> 'StateT' s m c - -- 'zoom' :: 'Monad' m => 'Lens'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c - -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c - -- 'zoom' :: 'Monad' m => 'Lens'' s t -> 'ErrorT' e ('RWST' r w t m c) -> 'ErrorT' e ('RWST' r w s m c) - -- 'zoom' :: ('Monad' m, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'ErrorT' e ('RWST' r w t m c) -> 'ErrorT' e ('RWST' r w s m c) + -- 'zoom' :: ('Monad' m, 'Monoid' w) => 'Lens'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c + -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Monoid' c) => 'Control.Lens.Traversal.Traversal'' s t -> 'RWST' r w t m c -> 'RWST' r w s m c + -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Error' e) => 'Lens'' s t -> 'ErrorT' e ('RWST' r w t m) c -> 'ErrorT' e ('RWST' r w s m) c + -- 'zoom' :: ('Monad' m, 'Monoid' w, 'Monoid' c, 'Error' e) => 'Control.Lens.Traversal.Traversal'' s t -> 'ErrorT' e ('RWST' r w t m) c -> 'ErrorT' e ('RWST' r w s m) c -- ... -- @ zoom :: LensLike' (Zoomed m c) t s -> m c -> n c @@ -167,13 +167,13 @@ -- [11,12,13,14,15,16,17,18,19,20] -- -- @ - -- 'magnify' :: 'Getter' s a -> (a -> r) -> s -> r - -- 'magnify' :: 'Monoid' c => 'Fold' s a -> (a -> r) -> s -> r + -- 'magnify' :: 'Getter' s a -> (a -> r) -> s -> r + -- 'magnify' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r -- @ -- -- @ - -- 'magnify' :: 'Monoid' w 'Getter' s t -> 'RWST' s w st c -> 'RWST' t w st c - -- 'magnify' :: ('Monoid' w, 'Monoid' c) => 'Fold' s t -> 'RWST' s w st c -> 'RWST' t w st c + -- 'magnify' :: 'Monoid' w => 'Getter' s t -> 'RWS' t w st c -> 'RWS' s w st c + -- 'magnify' :: ('Monoid' w, 'Monoid' c) => 'Fold' s a -> 'RWS' a w st c -> 'RWS' s w st c -- ... -- @ magnify :: LensLike' (Magnified m c) a b -> m c -> n c diff --git a/src/Control/Monad/Error/Lens.hs b/src/Control/Monad/Error/Lens.hs --- a/src/Control/Monad/Error/Lens.hs +++ b/src/Control/Monad/Error/Lens.hs @@ -49,7 +49,7 @@ -- 'catching' :: 'MonadError' e m => 'Getter' e a -> m r -> (a -> m r) -> m r -- 'catching' :: 'MonadError' e m => 'Fold' e a -> m r -> (a -> m r) -> m r -- @ -catching :: MonadError e m => Getting (First a) e t a b -> m r -> (a -> m r) -> m r +catching :: MonadError e m => Getting (First a) e a -> m r -> (a -> m r) -> m r catching l = catchJust (preview l) {-# INLINE catching #-} @@ -66,7 +66,7 @@ -- 'catching_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r -- 'catching_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r -- @ -catching_ :: MonadError e m => Getting (First a) e t a b -> m r -> m r -> m r +catching_ :: MonadError e m => Getting (First a) e a -> m r -> m r -> m r catching_ l a b = catchJust (preview l) a (const b) {-# INLINE catching_ #-} @@ -85,7 +85,7 @@ -- 'handling' :: 'MonadError' e m => 'Fold' e a -> (a -> m r) -> m r -> m r -- 'handling' :: 'MonadError' e m => 'Getter' e a -> (a -> m r) -> m r -> m r -- @ -handling :: MonadError e m => Getting (First a) e t a b -> (a -> m r) -> m r -> m r +handling :: MonadError e m => Getting (First a) e a -> (a -> m r) -> m r -> m r handling l = flip (catching l) {-# INLINE handling #-} @@ -100,7 +100,7 @@ -- 'handling_' :: 'MonadError' e m => 'Getter' e a -> m r -> m r -> m r -- 'handling_' :: 'MonadError' e m => 'Fold' e a -> m r -> m r -> m r -- @ -handling_ :: MonadError e m => Getting (First a) e t a b -> m r -> m r -> m r +handling_ :: MonadError e m => Getting (First a) e a -> m r -> m r -> m r handling_ l = flip (catching_ l) {-# INLINE handling_ #-} @@ -119,7 +119,7 @@ -- 'trying' :: 'MonadError' e m => 'Getter' e a -> m r -> m ('Either' a r) -- 'trying' :: 'MonadError' e m => 'Fold' e a -> m r -> m ('Either' a r) -- @ -trying :: MonadError e m => Getting (First a) e t a b -> m r -> m (Either a r) +trying :: MonadError e m => Getting (First a) e a -> m r -> m (Either a r) trying l m = catching l (liftM Right m) (return . Left) ------------------------------------------------------------------------------ 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 @@ -21,6 +21,6 @@ -- 'Getter' or 'Fold' according to the given strategy. -- -- @'seqFoldable' = 'seqOf' 'folded'@ -seqOf :: Getting (Endo [a]) s t a b -> Strategy a -> Strategy s +seqOf :: Getting (Endo [a]) s a -> Strategy a -> Strategy s seqOf l s = seqList s . toListOf l {-# INLINE seqOf #-} diff --git a/src/Data/Complex/Lens.hs b/src/Data/Complex/Lens.hs --- a/src/Data/Complex/Lens.hs +++ b/src/Data/Complex/Lens.hs @@ -129,5 +129,5 @@ -- >>> (mkPolar 10.0 2.0 ^. _conjugate . _phase) ≈ (-2.0) -- True _conjugate :: RealFloat a => Iso' (Complex a) (Complex a) -_conjugate = iso conjugate conjugate +_conjugate = involuted conjugate {-# INLINE _conjugate #-} diff --git a/src/Data/HashSet/Lens.hs b/src/Data/HashSet/Lens.hs --- a/src/Data/HashSet/Lens.hs +++ b/src/Data/HashSet/Lens.hs @@ -46,6 +46,6 @@ -- 'setOf' :: 'Hashable' a => 'Lens'' s a -> s -> 'HashSet' a -- 'setOf' :: ('Eq' a, 'Hashable' a) => 'Traversal'' s a -> s -> 'HashSet' a -- @ -setOf :: Hashable a => Getting (HashSet a) s t a b -> s -> HashSet a +setOf :: Hashable a => Getting (HashSet a) s a -> s -> HashSet a setOf l = views l HashSet.singleton {-# INLINE setOf #-} 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 @@ -58,6 +58,6 @@ -- 'setOf' :: 'Lens'' s 'Int' -> s -> 'IntSet' -- 'setOf' :: 'Traversal'' s 'Int' -> s -> 'IntSet' -- @ -setOf :: Getting IntSet s t Int b -> s -> IntSet +setOf :: Getting IntSet s Int -> s -> IntSet setOf l = views l IntSet.singleton {-# INLINE setOf #-} diff --git a/src/Data/List/Split/Lens.hs b/src/Data/List/Split/Lens.hs --- a/src/Data/List/Split/Lens.hs +++ b/src/Data/List/Split/Lens.hs @@ -44,9 +44,9 @@ -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' according to the given splitting strategy. -- -- @ --- 'splitting' :: 'Splitter' a -> 'Fold' i s a -> 'Fold' [i] s [a] +-- 'splitting' :: 'Splitter' a -> 'Fold' s a -> 'Fold' s [a] -- @ -splitting :: Splitter a -> Getting (Endo [a]) s s a a -> Fold s [a] +splitting :: Splitter a -> Getting (Endo [a]) s a -> Fold s [a] splitting s l f = coerce . traverse f . split s . toListOf l {-# INLINE splitting #-} @@ -57,7 +57,7 @@ -- @ -- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ -splittingOn :: Eq a => [a] -> Getting (Endo [a]) s s a a -> Fold s [a] +splittingOn :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] splittingOn s l f = coerce . traverse f . splitOn s . toListOf l {-# INLINE splittingOn #-} @@ -68,7 +68,7 @@ -- @ -- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ -splittingOneOf :: Eq a => [a] -> Getting (Endo [a]) s s a a -> Fold s [a] +splittingOneOf :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] splittingOneOf s l f = coerce . traverse f . splitOneOf s . toListOf l {-# INLINE splittingOneOf #-} @@ -77,9 +77,9 @@ -- Equivalent to @'splitting' '.' 'dropDelims' '.' 'whenElt'@. -- -- @ --- 'splittingOn' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] +-- 'splittingWhen' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] -- @ -splittingWhen :: Eq a => (a -> Bool) -> Getting (Endo [a]) s s a a -> Fold s [a] +splittingWhen :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] splittingWhen s l f = coerce . traverse f . splitWhen s . toListOf l {-# INLINE splittingWhen #-} @@ -90,7 +90,7 @@ -- @ -- 'endingBy' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ -endingBy :: Eq a => [a] -> Getting (Endo [a]) s s a a -> Fold s [a] +endingBy :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] endingBy s l f = coerce . traverse f . endBy s . toListOf l {-# INLINE endingBy #-} @@ -101,7 +101,7 @@ -- @ -- 'endingByOneOf' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] -- @ -endingByOneOf :: Eq a => [a] -> Getting (Endo [a]) s s a a -> Fold s [a] +endingByOneOf :: Eq a => [a] -> Getting (Endo [a]) s a -> Fold s [a] endingByOneOf s l f = coerce . traverse f . endByOneOf s . toListOf l {-# INLINE endingByOneOf #-} @@ -110,9 +110,9 @@ -- Equivalent to @'splitting' '.' 'dropBlanks' '.' 'dropDelims' '.' 'whenElt'@. -- -- @ --- 'wordingBy' :: (a -> 'Bool') -> 'Fold' a -> 'Fold' s [a] +-- 'wordingBy' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] -- @ -wordingBy :: Eq a => (a -> Bool) -> Getting (Endo [a]) s s a a -> Fold s [a] +wordingBy :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] wordingBy s l f = coerce . traverse f . wordsBy s . toListOf l {-# INLINE wordingBy #-} @@ -123,17 +123,17 @@ -- @ -- 'liningBy' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] -- @ -liningBy :: Eq a => (a -> Bool) -> Getting (Endo [a]) s s a a -> Fold s [a] +liningBy :: (a -> Bool) -> Getting (Endo [a]) s a -> Fold s [a] liningBy s l f = coerce . traverse f . linesBy s . toListOf l {-# INLINE liningBy #-} -- | Obtain a 'Fold' by splitting another 'Fold', 'Lens', 'Getter' or 'Traversal' into length-@n@ pieces. -- -- @ --- 'chunkingOf' :: 'Int' -> 'Fold' s a -> 'Fold' s [a] +-- 'chunking' :: 'Int' -> 'Fold' s a -> 'Fold' s [a] -- @ chunking :: Int -- ^ @n@ - -> Getting (Endo [a]) s s a a -> Fold s [a] + -> Getting (Endo [a]) s a -> Fold s [a] chunking s l f = coerce . traverse f . chunksOf s . toListOf l {-# INLINE chunking #-} @@ -142,7 +142,7 @@ -- @ -- 'splittingPlaces' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] -- @ -splittingPlaces :: Integral n => [n] -> Getting (Endo [a]) s s a a -> Fold s [a] +splittingPlaces :: Integral n => [n] -> Getting (Endo [a]) s a -> Fold s [a] splittingPlaces s l f = coerce . traverse f . splitPlaces s . toListOf l {-# INLINE splittingPlaces #-} @@ -151,7 +151,7 @@ -- @ -- 'splittingPlacesBlanks' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] -- @ -splittingPlacesBlanks :: Integral n => [n] -> Getting (Endo [a]) s s a a -> Fold s [a] +splittingPlacesBlanks :: Integral n => [n] -> Getting (Endo [a]) s a -> Fold s [a] splittingPlacesBlanks s l f = coerce . traverse f . splitPlacesBlanks s . toListOf l {-# INLINE splittingPlacesBlanks #-} 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 @@ -51,6 +51,6 @@ -- 'setOf' :: 'Lens'' s a -> s -> 'Set' a -- 'setOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Set' a -- @ -setOf :: Getting (Set a) s t a b -> s -> Set a +setOf :: Getting (Set a) s a -> s -> Set a setOf l = views l Set.singleton {-# INLINE setOf #-} diff --git a/src/Data/Vector/Generic/Lens.hs b/src/Data/Vector/Generic/Lens.hs --- a/src/Data/Vector/Generic/Lens.hs +++ b/src/Data/Vector/Generic/Lens.hs @@ -24,7 +24,6 @@ , asStream , asStreamR , cloned - , reversed -- * Lenses , sliced -- * Traversal of individual indices @@ -68,7 +67,7 @@ -- -- >>> toVectorOf both (8,15) :: Vector.Vector Int -- fromList [8,15] -toVectorOf :: Vector v a => Getting (Endo [a]) s t a b -> s -> v a +toVectorOf :: Vector v a => Getting (Endo [a]) s a -> s -> v a toVectorOf l s = fromList (toListOf l s) {-# INLINE toVectorOf #-} @@ -103,17 +102,8 @@ -- | Convert a 'Vector' to a version that doesn't retain any extra -- memory. forced :: Vector v a => Iso' (v a) (v a) -forced = iso force force +forced = involuted force {-# INLINE forced #-} - --- | Convert a 'Vector' to a version with all the elements in the --- reverse order. --- --- >>> Vector.fromList [1,2,3] ^. reversed --- fromList [3,2,1] -reversed :: Vector v a => Iso' (v a) (v a) -reversed = iso reverse reverse -{-# INLINE reversed #-} -- | This 'Traversal' will ignore any duplicates in the supplied list -- of indices. diff --git a/src/Data/Vector/Lens.hs b/src/Data/Vector/Lens.hs --- a/src/Data/Vector/Lens.hs +++ b/src/Data/Vector/Lens.hs @@ -21,7 +21,6 @@ ( toVectorOf -- * Isomorphisms , vector - , reversed , forced -- * Lenses , sliced @@ -60,7 +59,7 @@ -- -- >>> toVectorOf both (8,15) -- fromList [8,15] -toVectorOf :: Getting (Endo [a]) s t a b -> s -> Vector a +toVectorOf :: Getting (Endo [a]) s a -> s -> Vector a toVectorOf l s = fromList (toListOf l s) {-# INLINE toVectorOf #-} @@ -77,15 +76,6 @@ vector :: Iso [a] [b] (Vector a) (Vector b) vector = iso fromList toList {-# INLINE vector #-} - --- | Convert a 'Vector' to a version with all the elements in the --- reverse order. --- --- >>> Vector.fromList [1,2,3] ^. reversed --- fromList [3,2,1] -reversed :: Iso (Vector a) (Vector b) (Vector a) (Vector b) -reversed = iso reverse reverse -{-# INLINE reversed #-} -- | Convert a 'Vector' to a version that doesn't retain any extra -- memory. diff --git a/src/Numeric/Lens.hs b/src/Numeric/Lens.hs --- a/src/Numeric/Lens.hs +++ b/src/Numeric/Lens.hs @@ -8,7 +8,15 @@ -- Stability : provisional -- Portability : portable ------------------------------------------------------------------------------- -module Numeric.Lens (base, integral) where +module Numeric.Lens + ( base + , integral + -- * Predefined bases + , binary + , octal + , decimal + , hex + ) where import Control.Lens import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit) @@ -36,15 +44,15 @@ -- -- >>> 1767707668033969 ^. re (base 36) -- "helloworld" -base :: Integral a => a -> Prism' String a +base :: Integral a => Int -> Prism' String a base b - | b < 2 || b > 36 = error ("base: Invalid base " ++ show (toInteger b)) + | b < 2 || b > 36 = error ("base: Invalid base " ++ show b) | otherwise = prism intShow intRead where intShow n = showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) "" intRead s = - case readSigned' (readInt b (isDigit' b) digitToInt') s of + case readSigned' (readInt (fromIntegral b) (isDigit' b) digitToInt') s of [(n,"")] -> Right n _ -> Left s {-# INLINE base #-} @@ -70,9 +78,9 @@ | otherwise = Nothing -- | Select digits that fall into the given base -isDigit' :: Integral a => a -> Char -> Bool +isDigit' :: Int -> Char -> Bool isDigit' b c = case digitToIntMay c of - Just i | fromIntegral i < b -> True + Just i -> i < b _ -> False -- | A simpler variant of 'Numeric.showSigned' that only prepends a dash and @@ -87,3 +95,19 @@ readSigned' :: Real a => ReadS a -> ReadS a readSigned' f ('-':xs) = f xs & mapped . _1 %~ negate readSigned' f xs = f xs + +-- | @'binary' = 'base' 2@ +binary :: Integral a => Prism' String a +binary = base 2 + +-- | @'octal' = 'base' 8@ +octal :: Integral a => Prism' String a +octal = base 8 + +-- | @'decimal' = 'base' 10@ +decimal :: Integral a => Prism' String a +decimal = base 10 + +-- | @'hex' = 'base' 16@ +hex :: Integral a => Prism' String a +hex = base 16 diff --git a/tests/doctests.hsc b/tests/doctests.hsc --- a/tests/doctests.hsc +++ b/tests/doctests.hsc @@ -23,6 +23,7 @@ import System.FilePath import Test.DocTest +##if defined(mingw32_HOST_OS) ##if defined(i386_HOST_ARCH) ##define USE_CP import Control.Applicative @@ -30,13 +31,14 @@ import Foreign.C.Types foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt -##elif defined(x64_64_HOST_ARCH) +##elif defined(x86_64_HOST_ARCH) ##define USE_CP import Control.Applicative import Control.Exception import Foreign.C.Types foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt +##endif ##endif -- | Run in a modified codepage where we can print UTF-8 values on Windows.