diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,5 @@ tags wip .DS_Store +.*.swp +.*.swo diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,21 @@ +3.3 +--- +* Redefined `simple` and moved it to `Control.Lens.Iso`. Instead of using `simple l` you can now compose `l.simple` or `simple.l` providing more nuanced control and a more compositional API. +* Moved the various `foo#` combinators used to emit cleaner core into an unexported module, `Control.Lens.Unsafe`. This removes `MagicHash` from the public API. +* Removed the `bazaar#` and `runBazaar#` coercions that caused issues on GHC HEAD. +* Changed the default definition of `plate` to `uniplate` from `ignored`. +* Added `Data.Vector.Lens` and instances for `Data.Vector`. +* Added support for the `split` package, which is now part of the Haskell platform. +* Removed redundant `Data.List.traverseList`. Use `itraversed` or `traverse` instead. +* Moved `(:<->)` to `Control.Lens.Simple`. +* Fixed a bug in `Control.Lens.TH` that was causing `makeIso` not to work. +* Added `lifted` to `Control.Lens.Setter` for mapping over monads. +* Added `beside` to `Control.Lens.Traversal`. +* Removed the operators from `Data.List.Lens`, they broke the overall pattern of the rest of the API, and were terrible clutter. +* Fixed a bug that caused `resultAt` to give wrong answers most of the time. +* Changed `resultAt` to an `IndexedLens` and moved it to `Control.Lens.IndexedLens` +* Changed `ignored` to an `IndexedTraversal` and moved it to `Control.Lens.IndexedTraversal` + 3.2 --- * Made `elementOf` lazier and moved it from `Control.Lens.Traversal` to `Control.Lens.Plated`. diff --git a/benchmarks/unsafe.hs b/benchmarks/unsafe.hs new file mode 100644 --- /dev/null +++ b/benchmarks/unsafe.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Control.Lens +import Control.Lens.Internal +import Control.Exception + +import Criterion.Main +import Criterion.Config + +import GHC.Exts + +overS :: Setting s t a b -> (a -> b) -> s -> t +overS l f = runMutator . l (Mutator . f) +{-# INLINE overS #-} + +mappedS :: Setting [a] [b] a b +mappedS f = Mutator . map (runMutator . f) +{-# INLINE mappedS #-} + +overU :: Setting s t a b -> (a -> b) -> s -> t +overU = over +{-# INLINE overU #-} + +mappedU :: Setting [a] [b] a b +mappedU = mapped +{-# INLINE mappedU #-} + + +-- Need to eta-expand for full inlining in the NOINLINE cases? +-- Doesn't seem to make a difference, though. + +mapSN :: (a -> b) -> [a] -> [b] +mapSN f l = overS mappedS f l +{-# NOINLINE mapSN #-} + +mapSI :: (a -> b) -> [a] -> [b] +mapSI f = overS mappedS f +{-# INLINE mapSI #-} + +mapUN :: (a -> b) -> [a] -> [b] +mapUN f l = overU mappedU f l +{-# NOINLINE mapUN #-} + +mapUI :: (a -> b) -> [a] -> [b] +mapUI f = overU mappedU f +{-# INLINE mapUI #-} + +main :: IO () +main = do + let n = 1000 + l = replicate n "hi"; f = length + --l = replicate n (); f = (\ _ -> ()) + --l = replicate n (); f = (\ !_ -> ()) -- strange results + --l = replicate n (); f = lazy (\_ -> ()) + defaultMainWith config (return ()) + [ bench "map safe noinline" $ nf (mapSN f) l + , bench "map safe inline" $ nf (mapSI f) l + , bench "map unsafe noinline" $ nf (mapUN f) l + , bench "map unsafe inline" $ nf (mapUI f) l + ] + where + config = defaultConfig { cfgSamples = ljust 1000 } 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.2 +version: 3.3 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -37,7 +37,7 @@ . The core of this hierarchy looks like: . - <> + <> . You can compose any two elements of the hierarchy above using (.) from the Prelude, and you can use any element of the hierarchy as any type it links to above it. @@ -82,7 +82,7 @@ exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms). build-type: Simple -tested-with: GHC == 7.4.1, GHC == 7.6.0, GHC == 7.7.20120822, GHC == 7.7.20120830 +tested-with: GHC == 7.4.1, GHC == 7.6.1 extra-source-files: .travis.yml .ghci @@ -151,9 +151,12 @@ hashable == 1.1.*, mtl >= 2.1.1 && < 2.2, semigroups >= 0.8.4 && < 0.9, + split == 0.2.*, text >= 0.11 && < 0.12, transformers >= 0.3 && < 0.4, - unordered-containers >= 0.2 && < 0.3 + unordered-containers >= 0.2 && < 0.3, + vector >= 0.9 && < 0.11, + void >= 0.5 && < 0.6 exposed-modules: Control.Exception.Lens @@ -193,6 +196,7 @@ Data.HashSet.Lens Data.IntSet.Lens Data.List.Lens + Data.List.Split.Lens Data.Monoid.Lens Data.Sequence.Lens Data.Set.Lens @@ -201,7 +205,12 @@ Data.Text.Lazy.Lens Data.Tree.Lens Data.Typeable.Lens + Data.Vector.Lens + Data.Vector.Generic.Lens + other-modules: + Control.Lens.Unsafe + if flag(template-haskell) build-depends: template-haskell >= 2.4 && < 2.9 exposed-modules: Control.Lens.TH Language.Haskell.TH.Lens @@ -310,6 +319,22 @@ benchmark alongside type: exitcode-stdio-1.0 main-is: alongside.hs + build-depends: + base, + comonad, + comonads-fd, + criterion, + deepseq, + ghc-prim, + lens, + transformers + ghc-options: -w -O2 -threaded -fdicts-cheap -funbox-strict-fields + hs-source-dirs: benchmarks + +-- Basic benchmarks for the uniplate-style combinators +benchmark unsafe + type: exitcode-stdio-1.0 + main-is: unsafe.hs build-depends: base, comonad, diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -41,7 +41,7 @@ -- -- -- --- <> +-- <> ---------------------------------------------------------------------------- module Control.Lens ( module Control.Lens.Type 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- @@ -30,6 +31,7 @@ import Control.Applicative import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Monad.Trans.Class -- $setup @@ -58,12 +60,12 @@ -- -- > perform = flip (^!) perform :: Monad m => Acting m a s t a b -> s -> m a -perform l = getEffect . l (Effect . return) +perform l = getEffect# (l (effect# return)) {-# INLINE perform #-} -- | Perform an 'Action' and modify the result. performs :: Monad m => Acting m e s t a b -> (a -> e) -> s -> m e -performs l f = getEffect . l (Effect . return . f) +performs l f = getEffect# (l (effect# (return . f))) -- | Perform an 'Action' -- @@ -71,7 +73,7 @@ -- hello -- world (^!) :: Monad m => s -> Acting m a s t a b -> m a -a ^! l = getEffect (l (Effect . return) a) +a ^! l = getEffect (l (effect# return) a) {-# INLINE (^!) #-} -- | Construct an 'Action' from a monadic side-effect 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 @@ -81,6 +81,7 @@ import Control.Applicative.Backwards import Control.Lens.Getter import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Lens.Type import Control.Monad import Data.Foldable as Foldable @@ -183,8 +184,8 @@ {-# INLINE filtered #-} -- | This allows you to traverse the elements of a 'Control.Lens.Traversal.Traversal' or 'Fold' in the opposite order. --- This will demote an 'Control.Lens.IndexedTraversal.IndexedTraversal' or 'Control.Lens.IndexedFold.IndexedFold' to a regular 'Control.Lens.Traversal.Traversal' or 'Fold'; --- to preserve the indices, use 'Control.Lens.IndexedFold.ibackwards' instead. +-- This will demote an 'Control.Lens.IndexedTraversal.IndexedTraversal' or 'Control.Lens.IndexedFold.IndexedFold' to a regular 'Control.Lens.Traversal.Traversal' or 'Fold', +-- repectively; to preserve the indices, use 'Control.Lens.IndexedFold.ibackwards' instead. -- -- Note: 'backwards' should have no impact on a 'Getter', 'Control.Lens.Setter.Setter', 'Lens' or 'Control.Lens.Iso.Iso'. -- @@ -336,6 +337,7 @@ -- @ (^..) :: s -> Getting [a] s t a b -> [a] s ^.. l = foldMapOf l return s +{-# INLINE (^..) #-} -- | Returns 'True' if every target of a 'Fold' is 'True'. -- 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 @@ -67,6 +67,7 @@ ) where import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Monad.Reader.Class as Reader import Control.Monad.State.Class as State diff --git a/src/Control/Lens/IndexedFold.hs b/src/Control/Lens/IndexedFold.hs --- a/src/Control/Lens/IndexedFold.hs +++ b/src/Control/Lens/IndexedFold.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -45,6 +46,17 @@ , ibackwards , itakingWhile , idroppingWhile + , isplitting + , isplittingOn + , isplittingOneOf + , isplittingWhen + , iendingBy + , iendingByOneOf + , iwordingBy + , iliningBy + , ichunkingOf + , isplittingPlaces + , isplittingPlacesBlanks -- * Storing Indexed Folds , ReifiedIndexedFold(..) @@ -52,12 +64,16 @@ import Control.Applicative import Control.Applicative.Backwards +import Data.Traversable (traverse) import Control.Lens.Indexed import Control.Lens.IndexedGetter import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Lens.Type +import Control.Lens.Fold (toListOf) import Control.Monad import Data.Monoid +import Data.List.Split ------------------------------------------------------------------------------ -- Indexed Folds @@ -81,7 +97,7 @@ -- 'ifoldMapOf' :: 'Monoid' m => 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i a s -> (i -> s -> m) -> a -> m -- @ ifoldMapOf :: IndexedGetting i m s t a b -> (i -> a -> m) -> s -> m -ifoldMapOf l f = runAccessor . withIndex l (\i -> Accessor . f i) +ifoldMapOf l f = runAccessor# (withIndex l (\i -> accessor# (f i))) {-# INLINE ifoldMapOf #-} -- | @@ -99,7 +115,7 @@ -- 'ifoldrOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' 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 l f z t = appEndo (ifoldMapOf l (\i -> Endo . f i) t) z +ifoldrOf l f z t = appEndo (ifoldMapOf l (\i -> endo# (f i)) t) z {-# INLINE ifoldrOf #-} -- | @@ -117,7 +133,7 @@ -- 'ifoldlOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' 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 l f z t = appEndo (getDual (ifoldMapOf l (\i -> Dual . Endo . flip (f i)) t)) z +ifoldlOf l f z t = appEndo (getDual (ifoldMapOf l (\i -> dual# (endo# (flip (f i)))) t)) z {-# INLINE ifoldlOf #-} -- | @@ -135,7 +151,7 @@ -- 'ianyOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ ianyOf :: IndexedGetting i Any s t a b -> (i -> a -> Bool) -> s -> Bool -ianyOf l f = getAny . ifoldMapOf l (\i -> Any . f i) +ianyOf l f = getAny# (ifoldMapOf l (\i -> any# (f i))) {-# INLINE ianyOf #-} -- | @@ -153,7 +169,7 @@ -- 'iallOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' -- @ iallOf :: IndexedGetting i All s t a b -> (i -> a -> Bool) -> s -> Bool -iallOf l f = getAll . ifoldMapOf l (\i -> All . f i) +iallOf l f = getAll# (ifoldMapOf l (\i -> all# (f i))) {-# INLINE iallOf #-} -- | @@ -170,7 +186,7 @@ -- 'itraverseOf_' :: 'Applicative' f => 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> f r) -> s -> f () -- @ itraverseOf_ :: Functor f => IndexedGetting i (Traversed f) s t a b -> (i -> a -> f r) -> s -> f () -itraverseOf_ l f = getTraversed . ifoldMapOf l (\i -> Traversed . void . f i) +itraverseOf_ l f = getTraversed# (ifoldMapOf l (\i -> traversed# (void . f i))) {-# INLINE itraverseOf_ #-} -- | @@ -208,7 +224,7 @@ -- 'imapMOf_' :: 'Monad' m => 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' i s a -> (i -> a -> m r) -> s -> m () -- @ imapMOf_ :: Monad m => IndexedGetting i (Sequenced m) s t a b -> (i -> a -> m r) -> s -> m () -imapMOf_ l f = getSequenced . ifoldMapOf l (\i -> Sequenced . liftM skip . f i) +imapMOf_ l f = getSequenced# (ifoldMapOf l (\i -> sequenced# (liftM skip . f i))) {-# INLINE imapMOf_ #-} skip :: a -> () @@ -271,7 +287,7 @@ -- 'ifindOf' :: 'Control.Lens.IndexedTraversal.SimpleIndexedTraversal' s a -> (i -> a -> 'Bool') -> s -> 'Maybe' (i, a) -- @ ifindOf :: IndexedGetting i (First (i, a)) s t a b -> (i -> a -> Bool) -> s -> Maybe (i, a) -ifindOf l p = getFirst . ifoldMapOf l step where +ifindOf l p = getFirst# (ifoldMapOf l step) where step i a | p i a = First $ Just (i, a) | otherwise = First Nothing @@ -373,7 +389,7 @@ -- 'withIndicesOf' :: 'SimpleIndexedTraversal' i s a -> 'Fold' s (i, a) -- @ -- --- All 'Fold' operations are safe, and comply with the laws. However, +-- All 'Fold' operations are safe, and comply with the laws. However: -- -- Passing this an 'IndexedTraversal' will still allow many -- 'Traversal' combinators to type check on the result, but the result @@ -415,7 +431,7 @@ -- | Reverse the order of the elements of an 'IndexedFold' or 'Control.Lens.IndexedTraversal.IndexedTraversal'. -- This has no effect on an 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter', or 'Control.Lens.IndexedSetter.IndexedSetter'. ibackwards :: Indexed i k => Index i (a -> (Backwards f) b) (s -> (Backwards f) t) -> k (a -> f b) (s -> f t) -ibackwards l = index $ \ f -> fmap forwards . withIndex l $ \ i -> Backwards . f i +ibackwards l = index $ \ f -> fmap forwards . withIndex l $ \ i -> backwards# (f i) {-# INLINE ibackwards #-} -- | Obtain an 'IndexedFold' by taking elements from another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' while a predicate holds. @@ -432,8 +448,122 @@ => (i -> a -> Bool) -> IndexedGetting i (Endo (f s, f s)) s s a a -> k (a -> f a) (s -> f s) -idroppingWhile p l = index $ \f -> fst . ifoldrOf l (\i a r -> let s = f i a *> snd r in if p i a then (fst r, s) else (s, s)) (noEffect, noEffect) +idroppingWhile p l = index $ \ f -> fst . ifoldrOf l (\i a r -> let s = f i a *> snd r in if p i a then (fst r, s) else (s, s)) (noEffect, noEffect) {-# INLINE idroppingWhile #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' according to the given splitting strategy. +-- +-- @ +-- 'isplitting' :: 'Splitter' (i, a) -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +isplitting :: (Applicative f, Gettable f, Indexed [i] k) => Splitter (i, a) -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +isplitting s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . split s . toListOf (withIndicesOf l) +{-# INLINE isplitting #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' on the given delimiter. +-- +-- Equivalent to @'isplitting' '.' 'dropDelims' '.' 'onSublist'@. +-- +-- @ +-- 'isplittingOn' :: ('Eq' i, 'Eq' a) => [(i, a)] -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +isplittingOn :: (Applicative f, Gettable f, Indexed [i] k, Eq i, Eq a) => [(i, a)] -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +isplittingOn s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . splitOn s . toListOf (withIndicesOf l) +{-# INLINE isplittingOn #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' on any of the given elements. +-- +-- Equivalent to @'isplitting' '.' 'dropDelims' '.' 'oneOf'@. +-- +-- @ +-- 'isplittingOneOf' :: ('Eq' i, 'Eq' a) => [(i, a)] -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +isplittingOneOf :: (Applicative f, Gettable f, Indexed [i] k, Eq i, Eq a) => [(i, a)] -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +isplittingOneOf s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . splitOneOf s . toListOf (withIndicesOf l) +{-# INLINE isplittingOneOf #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' on elements satisfying the given predicate. +-- +-- Equivalent to @'isplitting' '.' 'dropDelims' '.' 'whenElt' '.' 'uncurry'@. +-- +-- @ +-- 'isplittingWhen' :: (i -> a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +isplittingWhen :: (Applicative f, Gettable f, Indexed [i] k) => (i -> a -> Bool) -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +isplittingWhen s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . splitWhen (uncurry s) . toListOf (withIndicesOf l) +{-# INLINE isplittingWhen #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' into chunks terminated by the given delimiter. +-- +-- Equivalent to @'isplitting' '.' 'dropDelims' '.' 'onSublist'@. +-- +-- @ +-- 'iendingBy' :: ('Eq' i, 'Eq' a) => [(i, a)] -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +iendingBy :: (Applicative f, Gettable f, Indexed [i] k, Eq i, Eq a) => [(i, a)] -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +iendingBy s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . endBy s . toListOf (withIndicesOf l) +{-# INLINE iendingBy #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' into chunks terminated by any of the given elements. +-- +-- Equivalent to @'isplitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'oneOf'@. +-- +-- @ +-- 'iendingByOneOf' :: ('Eq' i, 'Eq' a) => [(i, a)] -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +iendingByOneOf :: (Applicative f, Gettable f, Indexed [i] k, Eq i, Eq a) => [(i, a)] -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +iendingByOneOf s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . endByOneOf s . toListOf (withIndicesOf l) +{-# INLINE iendingByOneOf #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' into "words", with word boundaries indicated by the given predicate. +-- +-- Equivalent to @'isplitting' '.' 'dropBlanks' '.' 'dropDelims' '.' 'whenElt' '.' 'uncurry'@. +-- +-- @ +-- 'iwordingBy' :: (i -> a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +iwordingBy :: (Applicative f, Gettable f, Indexed [i] k) => (i -> a -> Bool) -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +iwordingBy s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . wordsBy (uncurry s) . toListOf (withIndicesOf l) +{-# INLINE iwordingBy #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' into "lines", with line boundaries indicated by the given predicate. +-- +-- Equivalent to @'isplitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'whenElt' '.' 'uncurry'@. +-- +-- @ +-- 'iliningBy' :: (i -> a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +iliningBy :: (Applicative f, Gettable f, Indexed [i] k) => (i -> a -> Bool) -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +iliningBy s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . linesBy (uncurry s) . toListOf (withIndicesOf l) +{-# INLINE iliningBy #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' into length-@n@ pieces. +-- +-- @ +-- 'ichunkingOf' :: 'Int' -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +ichunkingOf :: (Applicative f, Gettable f, Indexed [i] k) => Int -- ^ @n@ + -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +ichunkingOf s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . chunksOf s . toListOf (withIndicesOf l) +{-# INLINE ichunkingOf #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' into chunks of the given lengths. +-- +-- @ +-- 'isplittingPlaces' :: 'Integral' n => [n] -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +isplittingPlaces :: (Applicative f, Gettable f, Indexed [i] k, Integral n) => [n] -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +isplittingPlaces s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . splitPlaces s . toListOf (withIndicesOf l) +{-# INLINE isplittingPlaces #-} + +-- | Obtain an 'IndexedFold' by splitting another 'IndexedFold', 'Control.Lens.IndexedLens.IndexedLens', 'IndexedGetter' or 'Control.Lens.IndexedTraversal.IndexedTraversal' into chunks of the given lengths. Unlike 'isplittingPlaces', the output 'IndexedFold' will always be the same length as the first input argument. +-- +-- @ +-- 'isplittingPlacesBlanks' :: 'Integral' n => [n] -> 'IndexedFold' i s a -> 'IndexedFold' [i] s [a] +-- @ +isplittingPlacesBlanks :: (Applicative f, Gettable f, Indexed [i] k, Integral n) => [n] -> IndexedGetting i [(i, a)] s s a a -> k ([a] -> f [a]) (s -> f s) +isplittingPlacesBlanks s l = index $ \ f -> coerce . traverse (uncurry f . unzip) . splitPlacesBlanks s . toListOf (withIndicesOf l) +{-# INLINE isplittingPlacesBlanks #-} ------------------------------------------------------------------------------ -- Reifying Indexed Folds diff --git a/src/Control/Lens/IndexedLens.hs b/src/Control/Lens/IndexedLens.hs --- a/src/Control/Lens/IndexedLens.hs +++ b/src/Control/Lens/IndexedLens.hs @@ -30,6 +30,7 @@ -- * Common Indexed Lenses , At(..) , Contains(..) + , resultAt -- * Indexed Lens Combinators , (%%@~) , (<%@~) @@ -186,6 +187,15 @@ instance (Eq k, Hashable k) => Contains k (HashSet k) where contains k = index $ \ f s -> (\b -> if b then HashSet.insert k s else HashSet.delete k s) <$> f k (HashSet.member k s) {-# INLINE contains #-} + +-- | This lens can be used to change the result of a function but only where +-- the arguments match the key given. +-- +-- >>> let f = (+1) % resultAt 3 .~ 8 in (f 2, f 3) +-- (3,8) +resultAt :: Eq e => e -> SimpleIndexedLens e (e -> a) a +resultAt e = index $ \ g f -> (\a' e' -> if e == e' then a' else f e') <$> g e (f e) +{-# INLINE resultAt #-} ------------------------------------------------------------------------------ -- Reifying Indexed Lenses diff --git a/src/Control/Lens/IndexedSetter.hs b/src/Control/Lens/IndexedSetter.hs --- a/src/Control/Lens/IndexedSetter.hs +++ b/src/Control/Lens/IndexedSetter.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -28,9 +29,9 @@ , SimpleReifiedIndexedSetter ) where -import Control.Applicative import Control.Lens.Indexed import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Lens.Type import Control.Monad.State.Class as State @@ -58,7 +59,7 @@ -- 'imapOf' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ imapOf :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t -imapOf l f = runMutator . withIndex l (\i -> Mutator . f i) +imapOf l f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE imapOf #-} -- | Map with index. This is an alias for 'imapOf'. @@ -73,7 +74,7 @@ -- 'iover' :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ iover :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t -iover l f = runMutator . withIndex l (\i -> Mutator . f i) +iover l f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE iover #-} -- | Build an 'IndexedSetter' from an 'imap'-like function. @@ -95,7 +96,7 @@ -- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. isets :: ((i -> a -> b) -> s -> t) -> IndexedSetter i s t a b -isets f = index $ \ g -> pure . f (\i -> untainted . g i) +isets f = index $ \ g -> tainted# (f (\i -> untainted# (g i))) {-# INLINE isets #-} -- | Adjust every target of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal' @@ -113,7 +114,7 @@ -- ('%@~') :: 'Control.Lens.IndexedTraversal.IndexedTraversal' i s t a b -> (i -> a -> b) -> s -> t -- @ (%@~) :: Overloaded (Index i) Mutator s t a b -> (i -> a -> b) -> s -> t -l %@~ f = runMutator . withIndex l (\i -> Mutator . f i) +l %@~ f = runMutator# (withIndex l (\i -> mutator# (f i))) {-# INLINE (%@~) #-} -- | Adjust every target in the current state of an 'IndexedSetter', 'Control.Lens.IndexedLens.IndexedLens' or 'Control.Lens.IndexedTraversal.IndexedTraversal' diff --git a/src/Control/Lens/IndexedTraversal.hs b/src/Control/Lens/IndexedTraversal.hs --- a/src/Control/Lens/IndexedTraversal.hs +++ b/src/Control/Lens/IndexedTraversal.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-} @@ -32,6 +33,7 @@ , traverseAt , iwhereOf , value + , ignored , TraverseMin(..) , TraverseMax(..) @@ -60,6 +62,7 @@ import Data.Traversable import Data.IntMap as IntMap import Data.Map as Map +import Data.Void -- $setup -- >>> import Control.Lens @@ -209,6 +212,16 @@ value :: (k -> Bool) -> SimpleIndexedTraversal k (k, v) v value p = index $ \ f kv@(k,v) -> if p k then (,) k <$> f k v else pure kv {-# INLINE value #-} + +-- | This is the trivial empty traversal. +-- +-- @'ignored' :: 'IndexedTraversal' 'Void' s s a b +-- +-- @'ignored' ≡ 'const' 'pure'@ +ignored :: forall s a b k f. (Indexed Void k, Applicative f) => Overloaded k f s s a b +ignored = index $ \ (_ :: Void -> a -> f b) s -> pure s :: f s +{-# INLINE ignored #-} + -- | Allows 'IndexedTraversal' the value at the smallest index. class Ord k => TraverseMin k m | m -> k where diff --git a/src/Control/Lens/Internal.hs b/src/Control/Lens/Internal.hs --- a/src/Control/Lens/Internal.hs +++ b/src/Control/Lens/Internal.hs @@ -45,174 +45,6 @@ import Data.Traversable import Unsafe.Coerce -const# :: (a -> b) -> a -> Const b r -const# = unsafeCoerce - -getConst# :: (a -> Const b r) -> a -> b -getConst# = unsafeCoerce - -zipList# :: (a -> [b]) -> a -> ZipList b -zipList# = unsafeCoerce - -getZipList# :: (a -> ZipList b) -> a -> [b] -getZipList# = unsafeCoerce - -wrapMonad# :: (a -> m b) -> a -> WrappedMonad m b -wrapMonad# = unsafeCoerce - -unwrapMonad# :: (a -> WrappedMonad m b) -> a -> m b -unwrapMonad# = unsafeCoerce - -last# :: (a -> Maybe b) -> a -> Last b -last# = unsafeCoerce - -getLast# :: (a -> Last b) -> a -> Maybe b -getLast# = unsafeCoerce - -first# :: (a -> Maybe b) -> a -> First b -first# = unsafeCoerce - -getFirst# :: (a -> First b) -> a -> Maybe b -getFirst# = unsafeCoerce - -product# :: (a -> b) -> a -> Product b -product# = unsafeCoerce - -getProduct# :: (a -> Product b) -> a -> b -getProduct# = unsafeCoerce - -sum# :: (a -> b) -> a -> Sum b -sum# = unsafeCoerce - -getSum# :: (a -> Sum b) -> a -> b -getSum# = unsafeCoerce - -any# :: (a -> Bool) -> a -> Any -any# = unsafeCoerce - -getAny# :: (a -> Any) -> a -> Bool -getAny# = unsafeCoerce - -all# :: (a -> Bool) -> a -> All -all# = unsafeCoerce - -getAll# :: (a -> All) -> a -> Bool -getAll# = unsafeCoerce - -dual# :: (a -> b) -> a -> Dual b -dual# = unsafeCoerce - -getDual# :: (a -> Dual b) -> a -> b -getDual# = unsafeCoerce - -endo# :: (a -> b -> b) -> a -> Endo b -endo# = unsafeCoerce - -appEndo# :: (a -> Endo b) -> a -> b -> b -appEndo# = unsafeCoerce - -may# :: (a -> Maybe b) -> a -> May b -may# = unsafeCoerce - -getMay# :: (a -> May b) -> a -> Maybe b -getMay# = unsafeCoerce - -folding# :: (a -> f b) -> a -> Folding f b -folding# = unsafeCoerce - -getFolding# :: (a -> Folding f b) -> a -> f b -getFolding# = unsafeCoerce - -effect# :: (a -> m r) -> a -> Effect m r b -effect# = unsafeCoerce - -getEffect# :: (a -> Effect m r b) -> a -> m r -getEffect# = unsafeCoerce - -effectRWS# :: (a -> st -> m (s, st, w)) -> a -> EffectRWS w st m s b -effectRWS# = unsafeCoerce - -getEffectRWS# :: (a -> EffectRWS w st m s b) -> a -> st -> m (s, st, w) -getEffectRWS# = unsafeCoerce - -accessor# :: (a -> r) -> a -> Accessor r b -accessor# = unsafeCoerce - -runAccessor# :: (a -> Accessor r b) -> a -> r -runAccessor# = unsafeCoerce - -err# :: (a -> Either e b) -> a -> Err e b -err# = unsafeCoerce - -getErr# :: (a -> Err e b) -> a -> Either e b -getErr# = unsafeCoerce - -traversed# :: (a -> f ()) -> a -> Traversed f -traversed# = unsafeCoerce - -getTraversed# :: (a -> Traversed f) -> a -> f () -getTraversed# = unsafeCoerce - -sequenced# :: (a -> f ()) -> a -> Sequenced f -sequenced# = unsafeCoerce - -getSequenced# :: (a -> Sequenced f) -> a -> f () -getSequenced# = unsafeCoerce - -focusing# :: (a -> m (s, b)) -> a -> Focusing m s b -focusing# = unsafeCoerce - -unfocusing# :: (a -> Focusing m s b) -> a -> m (s, b) -unfocusing# = unsafeCoerce - -focusingWith# :: (a -> m (s, b, w)) -> a -> FocusingWith w m s b -focusingWith# = unsafeCoerce - -unfocusingWith# :: (a -> FocusingWith w m s b) -> a -> m (s, b, w) -unfocusingWith# = unsafeCoerce - -focusingPlus# :: (a -> k (s, w) b) -> a -> FocusingPlus w k s b -focusingPlus# = unsafeCoerce - -unfocusingPlus# :: (a -> FocusingPlus w k s b) -> a -> k (s, w) b -unfocusingPlus# = unsafeCoerce - -focusingOn# :: (a -> k (f s) b) -> a -> FocusingOn f k s b -focusingOn# = unsafeCoerce - -unfocusingOn# :: (a -> FocusingOn f k s b) -> a -> k (f s) b -unfocusingOn# = unsafeCoerce - -focusingMay# :: (a -> k (May s) b) -> a -> FocusingMay k s b -focusingMay# = unsafeCoerce - -unfocusingMay# :: (a -> FocusingMay k s b) -> a -> k (May s) b -unfocusingMay# = unsafeCoerce - -focusingErr# :: (a -> k (Err e s) b) -> a -> FocusingErr e k s b -focusingErr# = unsafeCoerce - -unfocusingErr# :: (a -> FocusingErr e k s b) -> a -> k (Err e s) b -unfocusingErr# = unsafeCoerce - -bazaar# :: (forall f. Applicative f => a -> (c -> f d) -> f t) -> a -> Bazaar c d t -bazaar# = unsafeCoerce - -runBazaar# :: Applicative f => (a -> Bazaar c d t) -> a -> (c -> f d) -> f t -runBazaar# = unsafeCoerce - -mutator# :: (a -> b) -> a -> Mutator b -mutator# = unsafeCoerce - -runMutator# :: (a -> Mutator b) -> a -> b -runMutator# = unsafeCoerce - -backwards# :: (a -> f b) -> a -> Backwards f b -backwards# = unsafeCoerce - -forwards# :: (a -> Backwards f b) -> a -> f b -forwards# = unsafeCoerce - ----------------------------------------------------------------------------- -- Functors ----------------------------------------------------------------------------- @@ -586,14 +418,19 @@ class Applicative f => Settable f where untainted :: f a -> a - untainted# :: (b -> f a) -> b -> a + untainted# :: (a -> f b) -> a -> b untainted# f = untainted . f + tainted# :: (a -> b) -> a -> f b + tainted# f = pure . f + -- | so you can pass our a 'Control.Lens.Setter.Setter' into combinators from other lens libraries instance Settable Identity where untainted = runIdentity untainted# = unsafeCoerce {-# INLINE untainted #-} + tainted# = unsafeCoerce + {-# INLINE tainted# #-} -- | 'Control.Lens.Fold.backwards' instance Settable f => Settable (Backwards f) where @@ -610,6 +447,8 @@ untainted = runMutator untainted# = unsafeCoerce {-# INLINE untainted #-} + tainted# = unsafeCoerce + {-# INLINE tainted# #-} -- | 'Mutator' is just a renamed 'Identity' functor to give better error -- messages when someone attempts to use a getter as a setter. @@ -691,7 +530,7 @@ fmap f (Level n ls a rs) = Level n (f <$> ls) (f a) (f <$> rs) instance Foldable Level where - foldMap f = foldMap f . rezipLevel + foldMap f (Level _ ls a rs) = foldMap f (Prelude.reverse ls) <> f a <> foldMap f rs instance Traversable Level where traverse f (Level n ls a rs) = Level n <$> forwards (traverse (Backwards . f) ls) <*> f a <*> traverse f rs 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 @@ -14,7 +14,6 @@ ( -- * Isomorphism Lenses Iso - , (:<->) , iso , isos , ala @@ -28,6 +27,7 @@ -- ** Common Isomorphisms , _const , identity + , simple -- * Storing Isomorphisms , ReifiedIso(..) -- * Simplicity @@ -48,13 +48,11 @@ -- $setup -- >>> import Control.Lens -infixr 0 :<-> - ----------------------------------------------------------------------------- -- Isomorphisms families as Lenses ----------------------------------------------------------------------------- --- | Isomorphim families can be composed with other lenses using either ('.') and 'id' +-- | Isomorphism families can be composed with other lenses using either ('.') and 'id' -- from the Prelude or from Control.Category. However, if you compose them -- with each other using ('.') from the Prelude, they will be dumbed down to a -- mere 'Lens'. @@ -71,8 +69,6 @@ -- @type 'SimpleIso' = 'Control.Lens.Type.Simple' 'Iso'@ type SimpleIso s a = Iso s s a a --- | An commonly used infix alias for @'Control.Lens.Type.Simple' 'Iso'@ -type s :<-> a = Iso s s a a -- | Build an isomorphism family from two pairs of inverse functions -- @@ -81,7 +77,6 @@ -- 'view' ('from' ('isos' sa as tb bt)) ≡ as -- 'set' ('isos' sa as tb bt) ab ≡ bt '.' ab '.' sa -- 'set' ('from' ('isos' ac ca bd db')) ab ≡ bd '.' ab '.' ca --- 'set' ('from' ('isos' sa as tb bt')) s t ≡ tb '.' st '.' as -- @ -- -- @isos :: (s -> a) -> (a -> s) -> (t -> b) -> (b -> t) -> 'Iso' s t a b@ @@ -156,6 +151,14 @@ _const :: Iso a b (Const a c) (Const b d) _const = isos Const getConst Const getConst {-# INLINE _const #-} + + +-- | Composition with this isomorphism is occasionally useful when your 'Lens', +-- 'Control.Lens.Traversal.Traversal' or 'Iso' has a constraint on an unused +-- argument to force that argument to agree with the +-- type of a used argument and avoid @ScopedTypeVariables@ or other ugliness. +simple :: Iso a b a b +simple = isos id id id id ----------------------------------------------------------------------------- -- Reifying Isomorphisms 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 @@ -90,6 +90,8 @@ import Control.Lens.Traversal import Control.Lens.Type import Data.Tree +import Data.Data +import Data.Data.Lens -- | A 'Plated' type is one where we know how to extract its immediate self-similar children. -- @@ -182,7 +184,8 @@ -- -- The default definition finds no children. plate :: Simple Traversal a a - plate = ignored + default plate :: Data a => Simple Traversal a a + plate = uniplate instance Plated [a] where plate f (x:xs) = (x:) <$> f xs @@ -786,7 +789,7 @@ -- 'partsOf' :: 'Simple' 'Traversal' s a -> 'Simple' 'Lens' s [a] -- @ partsOf :: LensLike (Bazaar a a) s t a a -> Lens s t [a] [a] -partsOf l f a = outs b <$> f (ins b) where b = l sell a +partsOf l f s = outs b <$> f (ins b) where b = l sell s {-# INLINE partsOf #-} -- | 'unsafePartsOf' turns a 'Traversal' into a @uniplate@ (or @biplate@) family. @@ -806,7 +809,7 @@ -- 'unsafePartsOf' :: 'Traversal' s t a b -> 'Lens' s t [a] [b] -- @ unsafePartsOf :: LensLike (Bazaar a b) s t a b -> Lens s t [a] [b] -unsafePartsOf l f a = unsafeOuts b <$> f (ins b) where b = l sell a +unsafePartsOf l f s = unsafeOuts b <$> f (ins b) where b = l sell s {-# INLINE unsafePartsOf #-} ------------------------------------------------------------------------------ @@ -836,20 +839,20 @@ ------------------------------------------------------------------------------- ins :: Bazaar a b t -> [a] -ins (Bazaar m) = getConst (m (Const . return)) +ins = toListOf bazaar {-# INLINE ins #-} -unsafeUncons :: [a] -> (a,[a]) -unsafeUncons ~(a:as) = (a,as) -{-# INLINE unsafeUncons #-} +unconsWithDefault :: a -> [a] -> (a,[a]) +unconsWithDefault d [] = (d,[]) +unconsWithDefault _ (x:xs) = (x,xs) +{-# INLINE unconsWithDefault #-} outs :: Bazaar a a t -> [a] -> t -outs (Bazaar m) = evalState $ m $ \c -> state $ \cs -> case cs of - [] -> (c,[]) - (d:ds) -> (d,ds) +outs = evalState . bazaar (\oldVal -> state (unconsWithDefault oldVal)) {-# INLINE outs #-} unsafeOuts :: Bazaar a b t -> [b] -> t -unsafeOuts (Bazaar m) = evalState (m $ \_ -> state unsafeUncons) +unsafeOuts = evalState . bazaar (\_ -> state (unconsWithDefault fakeVal)) + where fakeVal = error "unsafePartsOf: not enough elements were supplied" {-# INLINE unsafeOuts #-} diff --git a/src/Control/Lens/Representable.hs b/src/Control/Lens/Representable.hs --- a/src/Control/Lens/Representable.hs +++ b/src/Control/Lens/Representable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- @@ -89,10 +90,12 @@ import Control.Lens.Type import Control.Lens.Getter import Control.Lens.Indexed -import Control.Lens.IndexedSetter import Control.Lens.IndexedFold +import Control.Lens.IndexedLens +import Control.Lens.IndexedSetter import Control.Lens.IndexedTraversal import Control.Lens.Internal +import Control.Lens.Unsafe import Data.Foldable as Foldable import Data.Functor.Identity import Data.Monoid @@ -299,12 +302,12 @@ -- | An 'IndexedSetter' that walks an 'Representable' 'Functor' using a 'Path' for an index. rmapped :: Representable f => IndexedSetter (Path f) (f a) (f b) a b -rmapped = index $ \f -> pure . rmap (\i -> untainted . f (Path i)) +rmapped = index $ \f -> tainted# (rmap (\i -> untainted# (f (Path i)))) {-# INLINE rmapped #-} -- | An 'IndexedFold' that walks an 'Foldable' 'Representable' 'Functor' using a 'Path' for an index. rfolded :: (Representable f, Foldable f) => IndexedFold (Path f) (f a) a -rfolded = index $ \f -> coerce . getFolding . rfoldMap (\i -> Folding . f (Path i)) +rfolded = index $ \f -> coerce . getFolding . rfoldMap (\i -> folding# (f (Path i))) {-# INLINE rfolded #-} -- | An 'IndexedTraversal' for a 'Traversable' 'Representable' 'Functor'. diff --git a/src/Control/Lens/Setter.hs b/src/Control/Lens/Setter.hs --- a/src/Control/Lens/Setter.hs +++ b/src/Control/Lens/Setter.hs @@ -30,6 +30,7 @@ , sets -- * Common Setters , mapped + , lifted -- * Functional Combinators , over , mapOf @@ -54,8 +55,9 @@ , Mutator ) where -import Control.Applicative import Control.Lens.Internal +import Control.Lens.Unsafe +import Control.Monad (liftM) import Control.Monad.State.Class as State -- $setup @@ -72,7 +74,7 @@ -- | -- The only 'Control.Lens.Type.Lens'-like law that can apply to a 'Setter' @l@ is that -- --- @'set' l y ('set' l x a) ≡ 'set' l x a@ +-- @'set' l y ('set' l x a) ≡ 'set' l y a@ -- -- You can't 'view' a 'Setter' in general, so the other two laws are irrelevant. -- @@ -149,6 +151,21 @@ mapped = sets fmap {-# INLINE mapped #-} +-- | This setter can be used to modify all of the values in a 'Monad'. +-- +-- You sometimes have to use this, rather than 'mapped', because due to +-- temporary insanity 'Functor' is not a superclass of 'Monad'. +-- +-- @ +-- 'liftM' ≡ 'over' 'lifted' +-- @ +-- +-- >>> over lifted (+1) [1,2,3] +-- [2,3,4] +lifted :: Monad m => Setter (m a) (m b) a b +lifted = sets liftM +{-# INLINE lifted #-} + -- | Build a Setter from a map-like function. -- -- Your supplied function @f@ is required to satisfy: @@ -168,7 +185,7 @@ -- Another way to view 'sets' is that it takes a \"semantic editor combinator\" -- and transforms it into a 'Setter'. sets :: ((a -> b) -> s -> t) -> Setter s t a b -sets f g = pure . f (untainted# g) +sets f g = tainted# (f (untainted# g)) {-# INLINE sets #-} ----------------------------------------------------------------------------- diff --git a/src/Control/Lens/Simple.hs b/src/Control/Lens/Simple.hs --- a/src/Control/Lens/Simple.hs +++ b/src/Control/Lens/Simple.hs @@ -15,14 +15,19 @@ module Control.Lens.Simple ( (:->) , (:=>) + , (:<->) ) where import Control.Applicative +import Control.Lens.Iso -infixr 0 :=>, :-> +infixr 0 :=>, :->, :<-> -- | This is a commonly used infix alias for a @'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens'@. type s :-> a = forall f. Functor f => (a -> f a) -> s -> f s -- | This is a commonly-used infix alias for a @'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal'@. type s :=> a = forall f. Applicative f => (a -> f a) -> s -> f s + +-- | This is a commonly-used infix alias for a @'Control.Lens.Type.Simple' 'Iso'@ +type s :<-> a = Iso s s a a 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 @@ -209,6 +209,7 @@ -- | Rules for making an isomorphism from a data type isoRules :: LensRules isoRules = defaultRules + % handleSingletons .~ True % singletonRequired .~ True % singletonAndField .~ True 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 @@ -41,10 +41,10 @@ -- * Common Traversals , Traversable(traverse) - , ignored , traverseLeft , traverseRight , both + , beside , taking , dropping @@ -61,6 +61,7 @@ import Control.Applicative.Backwards import Control.Lens.Fold import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Lens.Type import Control.Monad.State.Class as State import Control.Monad.Trans.State.Lazy as Lazy @@ -300,15 +301,6 @@ -- Traversals ------------------------------------------------------------------------------ --- | This is the trivial empty traversal. --- --- @'ignored' :: 'Applicative' f => (a -> f b) -> s -> f s@ --- --- @'ignored' ≡ 'const' 'pure'@ -ignored :: Traversal s s a b -ignored _ = pure -{-# INLINE ignored #-} - -- | Traverse both parts of a tuple with matching types. -- -- >>> both *~ 10 $ (1,2) @@ -318,8 +310,16 @@ -- >>> ("hello","world")^.both -- "helloworld" both :: Traversal (a,a) (b,b) a b -both f (a,a') = (,) <$> f a <*> f a' +both f ~(a,a') = (,) <$> f a <*> f a' {-# INLINE both #-} + +-- | Apply a different 'Traversal' or 'Control.Lens.Fold.Fold' to each side of a tuple. +-- +-- >>> ("hello",["world","!!!"])^..beside id traverse +-- ["hello","world","!!!"] +beside :: Applicative f => LensLike f s t a b -> LensLike f s' t' a b -> LensLike f (s,s') (t,t') a b +beside l r f ~(s,s') = (,) <$> l f s <*> r f s' +{-# INLINE beside #-} -- | A traversal for tweaking the left-hand value of an 'Either': -- 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 @@ -58,12 +58,9 @@ , Simple , lens - , simple , (%%~) , (%%=) - , resultAt - -- * Lateral Composition , choosing , chosen @@ -182,12 +179,6 @@ lens sa sbt afb s = sbt s <$> afb (sa s) {-# INLINE lens #-} --- | This is occasionally useful when your 'Lens' (or 'Control.Lens.Traversal.Traversal') --- has a constraint on an unused argument to force that argument to agree with the --- type of a used argument and avoid @ScopedTypeVariables@ or other ugliness. -simple :: SimpleLensLike f s a -> SimpleLensLike f s a -simple l = l - ------------------------------------------------------------------------------- -- LensLike ------------------------------------------------------------------------------- @@ -270,15 +261,6 @@ ------------------------------------------------------------------------------- -- Common Lenses ------------------------------------------------------------------------------- - --- | This lens can be used to change the result of a function but only where --- the arguments match the key given. -resultAt :: Eq e => e -> Simple Lens (e -> a) a -resultAt e afa ea = go <$> afa a where - a = ea e - go a' e' | e == e' = a' - | otherwise = a -{-# INLINE resultAt #-} -- | Merge two lenses, getters, setters, folds or traversals. -- diff --git a/src/Control/Lens/Unsafe.hs b/src/Control/Lens/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Unsafe.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MagicHash #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Unsafe +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +-- These horrible unexported combinators are useful for producing more +-- efficient core. See . +-- +---------------------------------------------------------------------------- +module Control.Lens.Unsafe + ( const#, getConst# + , zipList#, getZipList# + , wrapMonad#, unwrapMonad# + , last#, getLast# + , first#, getFirst# + , product#, getProduct# + , sum#, getSum# + , any#, getAny# + , all#, getAll# + , dual#, getDual# + , endo#, appEndo# + , may#, getMay# + , folding#, getFolding# + , effect#, getEffect# + , effectRWS#, getEffectRWS# + , accessor#, runAccessor# + , err#, getErr# + , traversed#, getTraversed# + , sequenced#, getSequenced# + , focusing#, unfocusing# + , focusingWith#, unfocusingWith# + , focusingPlus#, unfocusingPlus# + , focusingOn#, unfocusingOn# + , focusingMay#, unfocusingMay# + , focusingErr#, unfocusingErr# + , mutator#, runMutator# + , backwards#, forwards# + ) where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Lens.Internal +import Data.Monoid +import Unsafe.Coerce + +const# :: (a -> b) -> a -> Const b r +const# = unsafeCoerce + +getConst# :: (a -> Const b r) -> a -> b +getConst# = unsafeCoerce + +zipList# :: (a -> [b]) -> a -> ZipList b +zipList# = unsafeCoerce + +getZipList# :: (a -> ZipList b) -> a -> [b] +getZipList# = unsafeCoerce + +wrapMonad# :: (a -> m b) -> a -> WrappedMonad m b +wrapMonad# = unsafeCoerce + +unwrapMonad# :: (a -> WrappedMonad m b) -> a -> m b +unwrapMonad# = unsafeCoerce + +last# :: (a -> Maybe b) -> a -> Last b +last# = unsafeCoerce + +getLast# :: (a -> Last b) -> a -> Maybe b +getLast# = unsafeCoerce + +first# :: (a -> Maybe b) -> a -> First b +first# = unsafeCoerce + +getFirst# :: (a -> First b) -> a -> Maybe b +getFirst# = unsafeCoerce + +product# :: (a -> b) -> a -> Product b +product# = unsafeCoerce + +getProduct# :: (a -> Product b) -> a -> b +getProduct# = unsafeCoerce + +sum# :: (a -> b) -> a -> Sum b +sum# = unsafeCoerce + +getSum# :: (a -> Sum b) -> a -> b +getSum# = unsafeCoerce + +any# :: (a -> Bool) -> a -> Any +any# = unsafeCoerce + +getAny# :: (a -> Any) -> a -> Bool +getAny# = unsafeCoerce + +all# :: (a -> Bool) -> a -> All +all# = unsafeCoerce + +getAll# :: (a -> All) -> a -> Bool +getAll# = unsafeCoerce + +dual# :: (a -> b) -> a -> Dual b +dual# = unsafeCoerce + +getDual# :: (a -> Dual b) -> a -> b +getDual# = unsafeCoerce + +endo# :: (a -> b -> b) -> a -> Endo b +endo# = unsafeCoerce + +appEndo# :: (a -> Endo b) -> a -> b -> b +appEndo# = unsafeCoerce + +may# :: (a -> Maybe b) -> a -> May b +may# = unsafeCoerce + +getMay# :: (a -> May b) -> a -> Maybe b +getMay# = unsafeCoerce + +folding# :: (a -> f b) -> a -> Folding f b +folding# = unsafeCoerce + +getFolding# :: (a -> Folding f b) -> a -> f b +getFolding# = unsafeCoerce + +effect# :: (a -> m r) -> a -> Effect m r b +effect# = unsafeCoerce + +getEffect# :: (a -> Effect m r b) -> a -> m r +getEffect# = unsafeCoerce + +effectRWS# :: (a -> st -> m (s, st, w)) -> a -> EffectRWS w st m s b +effectRWS# = unsafeCoerce + +getEffectRWS# :: (a -> EffectRWS w st m s b) -> a -> st -> m (s, st, w) +getEffectRWS# = unsafeCoerce + +accessor# :: (a -> r) -> a -> Accessor r b +accessor# = unsafeCoerce + +runAccessor# :: (a -> Accessor r b) -> a -> r +runAccessor# = unsafeCoerce + +err# :: (a -> Either e b) -> a -> Err e b +err# = unsafeCoerce + +getErr# :: (a -> Err e b) -> a -> Either e b +getErr# = unsafeCoerce + +traversed# :: (a -> f ()) -> a -> Traversed f +traversed# = unsafeCoerce + +getTraversed# :: (a -> Traversed f) -> a -> f () +getTraversed# = unsafeCoerce + +sequenced# :: (a -> f ()) -> a -> Sequenced f +sequenced# = unsafeCoerce + +getSequenced# :: (a -> Sequenced f) -> a -> f () +getSequenced# = unsafeCoerce + +focusing# :: (a -> m (s, b)) -> a -> Focusing m s b +focusing# = unsafeCoerce + +unfocusing# :: (a -> Focusing m s b) -> a -> m (s, b) +unfocusing# = unsafeCoerce + +focusingWith# :: (a -> m (s, b, w)) -> a -> FocusingWith w m s b +focusingWith# = unsafeCoerce + +unfocusingWith# :: (a -> FocusingWith w m s b) -> a -> m (s, b, w) +unfocusingWith# = unsafeCoerce + +focusingPlus# :: (a -> k (s, w) b) -> a -> FocusingPlus w k s b +focusingPlus# = unsafeCoerce + +unfocusingPlus# :: (a -> FocusingPlus w k s b) -> a -> k (s, w) b +unfocusingPlus# = unsafeCoerce + +focusingOn# :: (a -> k (f s) b) -> a -> FocusingOn f k s b +focusingOn# = unsafeCoerce + +unfocusingOn# :: (a -> FocusingOn f k s b) -> a -> k (f s) b +unfocusingOn# = unsafeCoerce + +focusingMay# :: (a -> k (May s) b) -> a -> FocusingMay k s b +focusingMay# = unsafeCoerce + +unfocusingMay# :: (a -> FocusingMay k s b) -> a -> k (May s) b +unfocusingMay# = unsafeCoerce + +focusingErr# :: (a -> k (Err e s) b) -> a -> FocusingErr e k s b +focusingErr# = unsafeCoerce + +unfocusingErr# :: (a -> FocusingErr e k s b) -> a -> k (Err e s) b +unfocusingErr# = unsafeCoerce + +mutator# :: (a -> b) -> a -> Mutator b +mutator# = unsafeCoerce + +runMutator# :: (a -> Mutator b) -> a -> b +runMutator# = unsafeCoerce + +backwards# :: (a -> f b) -> a -> Backwards f b +backwards# = unsafeCoerce + +forwards# :: (a -> Backwards f b) -> a -> f b +forwards# = unsafeCoerce + diff --git a/src/Control/Lens/WithIndex.hs b/src/Control/Lens/WithIndex.hs --- a/src/Control/Lens/WithIndex.hs +++ b/src/Control/Lens/WithIndex.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} @@ -63,6 +64,7 @@ import Control.Monad.Trans.State.Lazy as Lazy import Control.Lens.Fold import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Lens.Indexed import Control.Lens.IndexedSetter import Control.Lens.IndexedFold @@ -75,6 +77,8 @@ import Data.Monoid import Data.Sequence hiding (index) import Data.Traversable +import Data.Vector (Vector) +import qualified Data.Vector as V -- $setup -- >>> import Control.Lens @@ -132,7 +136,7 @@ -- -- @'Data.Foldable.foldr' ≡ 'ifoldr' '.' 'const'@ ifoldr :: (i -> a -> b -> b) -> b -> f a -> b - ifoldr f z t = appEndo (ifoldMap (\i -> Endo . f i) t) z + ifoldr f z t = appEndo (ifoldMap (\i -> endo# (f i)) t) z -- | -- Left-associative fold of an indexed container with access to the index @i@. @@ -141,7 +145,7 @@ -- -- @'foldl' ≡ 'ifoldl' '.' 'const'@ ifoldl :: (i -> b -> a -> b) -> b -> f a -> b - ifoldl f z t = appEndo (getDual (ifoldMap (\i -> Dual . Endo . flip (f i)) t)) z + ifoldl f z t = appEndo (getDual (ifoldMap (\i -> dual# (endo# (flip (f i)))) t)) z -- | /Strictly/ fold right over the elements of a structure with access to the index @i@. -- @@ -170,7 +174,7 @@ -- | The 'IndexedFold' of a 'FoldableWithIndex' container. ifolded :: FoldableWithIndex i f => IndexedFold i (f a) a -ifolded = index $ \ f -> coerce . getFolding . ifoldMap (\i -> Folding . f i) +ifolded = index $ \ f -> coerce . getFolding . ifoldMap (\i -> folding# (f i)) {-# INLINE ifolded #-} -- | Obtain a 'Fold' by lifting an operation that returns a foldable result. @@ -187,7 +191,7 @@ -- -- @'any' = 'iany' '.' 'const'@ iany :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool -iany f = getAny . ifoldMap (\i -> Any . f i) +iany f = getAny# (ifoldMap (\i -> any# (f i))) {-# INLINE iany #-} -- | @@ -197,7 +201,7 @@ -- -- @'all' ≡ 'iall' '.' 'const'@ iall :: FoldableWithIndex i f => (i -> a -> Bool) -> f a -> Bool -iall f = getAll . ifoldMap (\i -> All . f i) +iall f = getAll# (ifoldMap (\i -> all# (f i))) {-# INLINE iall #-} -- | @@ -207,7 +211,7 @@ -- -- @'traverse_' l = 'itraverse' '.' 'const'@ itraverse_ :: (FoldableWithIndex i t, Applicative f) => (i -> a -> f b) -> t a -> f () -itraverse_ f = getTraversed . ifoldMap (\i -> Traversed . void . f i) +itraverse_ f = getTraversed# (ifoldMap (\i -> traversed# (void . f i))) {-# INLINE itraverse_ #-} -- | @@ -230,7 +234,7 @@ -- -- @'mapM_' ≡ 'imapM' '.' 'const'@ imapM_ :: (FoldableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m () -imapM_ f = getSequenced . ifoldMap (\i -> Sequenced . liftM skip . f i) +imapM_ f = getSequenced# (ifoldMap (\i -> sequenced# (liftM skip . f i))) {-# INLINE imapM_ #-} -- | @@ -312,7 +316,7 @@ -- | Fold a container with indices returning only the indices. indices :: FoldableWithIndex i f => Fold (f a) i -indices f = coerce . getFolding . ifoldMap (const . Folding . f) +indices f = coerce . getFolding# (ifoldMap (const . folding# f)) {-# INLINE indices #-} ------------------------------------------------------------------------------- @@ -360,7 +364,7 @@ -- -- @'mapM' ≡ 'imapM' '.' 'const'@ imapM :: (TraversableWithIndex i t, Monad m) => (i -> a -> m b) -> t a -> m (t b) -imapM f = unwrapMonad . itraverse (\i -> WrapMonad . f i) +imapM f = unwrapMonad# (itraverse (\i -> wrapMonad# (f i))) {-# INLINE imapM #-} -- | Map each element of a structure to a monadic action, @@ -420,6 +424,17 @@ ifoldMap = ifoldMapOf itraversed instance TraversableWithIndex Int Seq where itraverse = withIndex (indexed traverse) + +instance FunctorWithIndex Int Vector where + imap = V.imap +instance FoldableWithIndex Int Vector where + ifoldMap = ifoldMapOf itraversed + ifoldr = V.ifoldr + ifoldl = V.ifoldl . flip + ifoldr' = V.ifoldr' + ifoldl' = V.ifoldl' . flip +instance TraversableWithIndex Int Vector where + itraverse f = sequenceA . V.imap f instance FunctorWithIndex Int IntMap where imap = imapOf itraversed diff --git a/src/Control/Lens/Zipper.hs b/src/Control/Lens/Zipper.hs --- a/src/Control/Lens/Zipper.hs +++ b/src/Control/Lens/Zipper.hs @@ -103,7 +103,7 @@ -- used in website navigation. Each breadcrumb in the trail represents a level you -- can move up to. -- --- This type operator associates to the right, so you can use a type like +-- This type operator associates to the left, so you can use a type like -- -- @'Top' ':>' ('String','Double') ':>' 'String' ':>' 'Char'@ -- @@ -285,7 +285,7 @@ -- -- You can reason about this function as if the definition was: -- --- @'fromWithin' l ≡ 'fromJust ' '.' 'within' l@ +-- @'fromWithin' l ≡ 'fromJust' '.' 'within' l@ -- -- but it is lazier in such a way that if this invariant is violated, some code -- can still succeed if it is lazy enough in the use of the focused value. 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-} @@ -26,6 +27,7 @@ ) where import Control.Lens.Internal +import Control.Lens.Unsafe import Control.Lens.Type import Control.Lens.Getter import Control.Monad @@ -71,11 +73,11 @@ zoom :: Monad m => SimpleLensLike (k c) t s -> m c -> n c instance Monad z => Zoom (Strict.StateT s z) (Strict.StateT t z) (Focusing z) s t where - zoom l (Strict.StateT m) = Strict.StateT $ unfocusing . l (Focusing . m) + zoom l (Strict.StateT m) = Strict.StateT $ unfocusing# (l (focusing# m)) {-# INLINE zoom #-} instance Monad z => Zoom (Lazy.StateT s z) (Lazy.StateT t z) (Focusing z) s t where - zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing . l (Focusing . m) + zoom l (Lazy.StateT m) = Lazy.StateT $ unfocusing# (l (focusing# m)) {-# INLINE zoom #-} instance Zoom m n k s t => Zoom (ReaderT e m) (ReaderT e n) k s t where @@ -87,31 +89,31 @@ {-# INLINE zoom #-} instance (Monoid w, Monad z) => Zoom (Strict.RWST r w s z) (Strict.RWST r w t z) (FocusingWith w z) s t where - zoom l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith . l (FocusingWith . m r) + zoom l (Strict.RWST m) = Strict.RWST $ \r -> unfocusingWith# (l (focusingWith# (m r))) {-# INLINE zoom #-} instance (Monoid w, Monad z) => Zoom (Lazy.RWST r w s z) (Lazy.RWST r w t z) (FocusingWith w z) s t where - zoom l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith . l (FocusingWith . m r) + zoom l (Lazy.RWST m) = Lazy.RWST $ \r -> unfocusingWith# (l (focusingWith# (m r))) {-# INLINE zoom #-} instance (Monoid w, Zoom m n k s t) => Zoom (Strict.WriterT w m) (Strict.WriterT w n) (FocusingPlus w k) s t where - zoom l = Strict.WriterT . zoom (\cfd -> unfocusingPlus . l (FocusingPlus . cfd)) . Strict.runWriterT + zoom l = Strict.WriterT . zoom (\afb -> unfocusingPlus# (l (focusingPlus# afb))) . Strict.runWriterT {-# INLINE zoom #-} instance (Monoid w, Zoom m n k s t) => Zoom (Lazy.WriterT w m) (Lazy.WriterT w n) (FocusingPlus w k) s t where - zoom l = Lazy.WriterT . zoom (\cfd -> unfocusingPlus . l (FocusingPlus . cfd)) . Lazy.runWriterT + zoom l = Lazy.WriterT . zoom (\afb -> unfocusingPlus# (l (focusingPlus# afb))) . Lazy.runWriterT {-# INLINE zoom #-} instance Zoom m n k s t => Zoom (ListT m) (ListT n) (FocusingOn [] k) s t where - zoom l = ListT . zoom (\cfd -> unfocusingOn . l (FocusingOn . cfd)) . runListT + zoom l = ListT . zoom (\afb -> unfocusingOn . l (FocusingOn . afb)) . runListT {-# INLINE zoom #-} instance Zoom m n k s t => Zoom (MaybeT m) (MaybeT n) (FocusingMay k) s t where - zoom l = MaybeT . liftM getMay . zoom (\cfd -> unfocusingMay . l (FocusingMay . cfd)) . liftM May . runMaybeT + zoom l = MaybeT . liftM getMay . zoom (\afb -> unfocusingMay# (l (focusingMay# afb))) . liftM May . runMaybeT {-# INLINE zoom #-} instance (Error e, Zoom m n k s t) => Zoom (ErrorT e m) (ErrorT e n) (FocusingErr e k) s t where - zoom l = ErrorT . liftM getErr . zoom (\cfd -> unfocusingErr . l (FocusingErr . cfd)) . liftM Err . runErrorT + zoom l = ErrorT . liftM getErr . zoom (\afb -> unfocusingErr# (l (focusingErr# afb))) . liftM Err . runErrorT {-# INLINE zoom #-} -- TODO: instance Zoom m m k a a => Zoom (ContT r m) (ContT r m) k a a where @@ -140,7 +142,7 @@ magnify :: ((b -> k c b) -> a -> k c a) -> m c -> n c instance Monad m => Magnify (ReaderT b m) (ReaderT a m) (Effect m) b a where - magnify l (ReaderT m) = ReaderT $ getEffect . l (Effect . m) + magnify l (ReaderT m) = ReaderT $ getEffect# (l (effect# m)) {-# INLINE magnify #-} -- | @'magnify' = 'views'@ @@ -149,11 +151,11 @@ {-# INLINE magnify #-} instance (Monad m, Monoid w) => Magnify (Strict.RWST b w s m) (Strict.RWST a w s m) (EffectRWS w s m) b a where - magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS . l (EffectRWS . m) + magnify l (Strict.RWST m) = Strict.RWST $ getEffectRWS# (l (effectRWS# m)) {-# INLINE magnify #-} instance (Monad m, Monoid w) => Magnify (Lazy.RWST b w s m) (Lazy.RWST a w s m) (EffectRWS w s m) b a where - magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS . l (EffectRWS . m) + magnify l (Lazy.RWST m) = Lazy.RWST $ getEffectRWS# (l (effectRWS# m)) {-# INLINE magnify #-} instance Magnify m n k b a => Magnify (IdentityT m) (IdentityT n) k b a where diff --git a/src/Data/ByteString/Lazy/Lens.hs b/src/Data/ByteString/Lazy/Lens.hs --- a/src/Data/ByteString/Lazy/Lens.hs +++ b/src/Data/ByteString/Lazy/Lens.hs @@ -18,7 +18,6 @@ import Control.Lens import Data.ByteString.Lazy as Words import Data.ByteString.Lazy.Char8 as Char8 -import Data.List.Lens import Data.Word (Word8) -- | 'Data.ByteString.Lazy.pack' (or 'Data.ByteString.Lazy.unpack') a list of bytes into a 'ByteString' @@ -32,11 +31,11 @@ -- | Traverse the individual bytes in a 'ByteString' -- --- @'bytes' = 'from' 'packedBytes' . 'traverseList'@ +-- @'bytes' = 'from' 'packedBytes' . 'itraversed'@ -- -- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@ bytes :: SimpleIndexedTraversal Int ByteString Word8 -bytes = from packedBytes .> traverseList +bytes = from packedBytes .> itraversed {-# INLINE bytes #-} -- | 'Data.ByteString.Lazy.Char8.pack' (or 'Data.ByteString.Lazy.Char8.unpack') a list of characters into a 'ByteString' @@ -56,9 +55,9 @@ -- When writing back to the 'ByteString' it is assumed that every 'Char' -- lies between '\x00' and '\xff'. -- --- @'chars' = 'from' 'packedChars' '.>' 'traverseList'@ +-- @'chars' = 'from' 'packedChars' '.>' 'itraversed'@ -- -- @'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'@ chars :: SimpleIndexedTraversal Int ByteString Char -chars = from packedChars .> traverseList +chars = from packedChars .> itraversed {-# INLINE chars #-} diff --git a/src/Data/ByteString/Strict/Lens.hs b/src/Data/ByteString/Strict/Lens.hs --- a/src/Data/ByteString/Strict/Lens.hs +++ b/src/Data/ByteString/Strict/Lens.hs @@ -17,7 +17,6 @@ import Control.Lens import Data.ByteString as Words import Data.ByteString.Char8 as Char8 -import Data.List.Lens import Data.Word (Word8) -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' @@ -31,11 +30,11 @@ -- | Traverse each 'Word8' in a 'ByteString' -- --- @'bytes' = 'from' 'packedBytes' '.>' 'traverseList'@ +-- @'bytes' = 'from' 'packedBytes' '.>' 'itraversed'@ -- -- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@ bytes :: SimpleIndexedTraversal Int ByteString Word8 -bytes = from packedBytes .> traverseList +bytes = from packedBytes .> itraversed {-# INLINE bytes #-} -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of characters into a 'ByteString' @@ -59,5 +58,5 @@ -- -- @'anyOf' 'chars' ('==' \'c\') :: 'ByteString' -> 'Bool'@ chars :: SimpleIndexedTraversal Int ByteString Char -chars = from packedChars .> traverseList +chars = from packedChars .> itraversed {-# INLINE chars #-} diff --git a/src/Data/Data/Lens.hs b/src/Data/Data/Lens.hs --- a/src/Data/Data/Lens.hs +++ b/src/Data/Data/Lens.hs @@ -35,7 +35,8 @@ import Control.Applicative import Control.Arrow ((&&&)) import Control.Exception as E -import Control.Lens +import Control.Lens.Traversal +import Control.Lens.Type import Data.Data import Data.Foldable import qualified Data.HashMap.Strict as M 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 @@ -15,7 +15,6 @@ ) where import Control.Lens.Getter -import Control.Lens.Internal import Control.Lens.Setter import Data.HashSet as HashSet import Data.Hashable @@ -48,5 +47,5 @@ -- 'setOf' :: ('Eq' a, 'Hashable' a) => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'HashSet' a -- @ setOf :: Hashable a => Getting (HashSet a) s t a b -> s -> HashSet a -setOf l = runAccessor . l (Accessor . HashSet.singleton) +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 @@ -16,7 +16,6 @@ ) where import Control.Lens -import Control.Lens.Internal import Data.IntSet as IntSet -- $setup @@ -56,5 +55,5 @@ -- 'setOf' :: 'Simple' 'Traversal' s 'Int' -> s -> 'IntSet' -- @ setOf :: Getting IntSet s t Int b -> s -> IntSet -setOf l = runAccessor . l (Accessor . IntSet.singleton) +setOf l = views l IntSet.singleton {-# INLINE setOf #-} diff --git a/src/Data/List/Lens.hs b/src/Data/List/Lens.hs --- a/src/Data/List/Lens.hs +++ b/src/Data/List/Lens.hs @@ -15,36 +15,25 @@ -- ---------------------------------------------------------------------------- module Data.List.Lens - ( _head + ( + -- * Partial Lenses + _head , _tail , _last , _init - , interspersed - , intercalated -- * Traversals - , traverseList , traverseHead , traverseTail , traverseInit , traverseLast - , (~:), (=:) - , (<~:), (<=:) - , (++~), (<++~) - , (++=), (<++=) ) where import Control.Applicative import Control.Lens -import Control.Monad.State as State (MonadState, modify) -import Data.List -infixr 4 ++~, <++~ -infixl 4 ~:, <~: -infix 4 =:, <=:, ++=, <++= - --- | A lens reading and writing to the head of a /non-empty/ list. +-- | A partial 'Lens' reading and writing to the 'head' of a /non-empty/ list. -- --- Attempting to read or write to the head of an /empty/ list will result in an 'error'. +-- Attempting to read or write to the 'head' of an /empty/ list will result in an 'error'. -- -- >>> [1,2,3]^._head -- 1 @@ -53,9 +42,9 @@ _head f (a:as) = (:as) <$> f a {-# INLINE _head #-} --- | A lens reading and writing to the tail of a /non-empty/ list +-- | A partial 'Lens' reading and writing to the 'tail' of a /non-empty/ list -- --- Attempting to read or write to the tail of an /empty/ list will result in an 'error'. +-- Attempting to read or write to the 'tail' of an /empty/ list will result in an 'error'. -- -- >>> _tail .~ [3,4,5] $ [1,2] -- [1,3,4,5] @@ -64,7 +53,7 @@ _tail f (a:as) = (a:) <$> f as {-# INLINE _tail #-} --- | A lens reading and writing to the last element of a /non-empty/ list +-- | A partial 'Lens' reading and writing to the last element of a /non-empty/ list -- -- Attempting to read or write to the last element of an /empty/ list will result in an 'error'. -- @@ -76,7 +65,7 @@ _last f (a:as) = (a:) <$> _last f as {-# INLINE _last #-} --- | A lens reading and replacing all but the a last element of a /non-empty/ list +-- | A partial 'Lens' reading and replacing all but the a last element of a /non-empty/ list -- -- Attempting to read or write to all but the last element of an /empty/ list will result in an 'error'. -- @@ -87,28 +76,6 @@ _init f as = (++ [Prelude.last as]) <$> f (Prelude.init as) {-# INLINE _init #-} --- | Obtain a version of the list with the supplied value interspersed. --- --- >>> "abcde"^.interspersed ',' --- "a,b,c,d,e" --- --- > xs^.interspersed a = intersperse a xs -interspersed :: a -> Getter [a] [a] -interspersed = to . intersperse -{-# INLINE interspersed #-} - --- | Obtain a version of the list with the supplied value intercalated. -intercalated :: [a] -> Getter [[a]] [a] -intercalated = to . intercalate -{-# INLINE intercalated #-} - --- | Indexed traversal of a list. The position in the list is available as the index. -traverseList :: IndexedTraversal Int [a] [b] a b -traverseList = index $ go (0::Int) where - go !n f (x:xs) = (:) <$> f n x <*> go (n + 1) f xs - go _ _ [] = pure [] -{-# INLINE traverseList #-} - -- | A traversal for reading and writing to the head of a list -- -- The position of the head in the original list (0) is available as the index. @@ -134,7 +101,7 @@ traverseTail :: SimpleIndexedTraversal Int [a] a traverseTail = index $ \f aas -> case aas of [] -> pure [] - (a:as) -> (a:) <$> withIndex traverseList (f . (+1)) as + (a:as) -> (a:) <$> itraverse (f . (+1)) as {-# INLINE traverseTail #-} -- | A traversal the last element in a list @@ -164,119 +131,5 @@ traverseInit :: SimpleIndexedTraversal Int [a] a traverseInit = index $ \f aas -> case aas of [] -> pure [] - as -> (++ [Prelude.last as]) <$> withIndex traverseList f (Prelude.init as) + as -> (++ [Prelude.last as]) <$> itraverse f (Prelude.init as) {-# INLINE traverseInit #-} - --- | Cons onto the list(s) referenced by a 'Setter'. --- --- >>> 'h' ~: _1 $ ("ello","world") --- ("hello","world") --- --- @ --- ('~:') :: b -> 'Simple' 'Setter' s [a] -> s -> s --- ('~:') :: b -> 'Simple' 'Traversal' s [a] -> s -> s --- ('~:') :: b -> 'Simple' 'Lens' s [a] -> s -> s --- ('~:') :: b -> 'Simple' 'Iso' s [a] -> s -> s --- @ -(~:) :: a -> Setting s t [a] [a] -> s -> t -n ~: l = over l (n :) -{-# INLINE (~:) #-} - --- | Cons onto the list(s) referenced by a 'Setter' in your monad state --- --- @ --- ('=:') :: 'MonadState' s m => a -> 'Simple' 'Setter' s [a] -> m () --- ('=:') :: 'MonadState' s m => a -> 'Simple' 'Traversal' s [a] -> m () --- ('=:') :: 'MonadState' s m => a -> 'Simple' 'Lens' s [a] -> m () --- ('=:') :: 'MonadState' s m => a -> 'Simple' 'Iso' s [a] -> m () --- @ -(=:) :: MonadState s m => a -> SimpleSetting s [a] -> m () -n =: l = modify (n ~: l) -{-# INLINE (=:) #-} - --- | Cons onto the list(s) referenced by a 'Lens' (or 'Traversal'), returning the result. --- --- If you use this with a 'Traversal' you will receive back the concatenation of all of --- the resulting lists instead of an individual result. --- --- >>> 'h' <~: _1 $ ("ello","world") --- ("hello",("hello","world")) --- --- @ --- ('<~:') :: b -> 'Simple' 'Lens' s [a] -> s -> ([a], s) --- ('<~:') :: b -> 'Simple' 'Iso' s [a] -> s -> ([a], s) --- ('<~:') :: b -> 'Simple' 'Traversal' s [a] -> s -> ([a], s) --- @ -(<~:) :: a -> LensLike ((,)[a]) s t [a] [a] -> s -> ([a], t) -n <~: l = l <%~ (n :) -{-# INLINE (<~:) #-} - --- | Cons onto the list(s) referenced by a 'Lens' (or 'Traversal') into your monad state, --- returning the result. --- --- If you use this with a 'Traversal', you will receive back the concatenation of all --- of the resulting lists instead of an individual result. --- --- @ --- ('<=:') :: 'MonadState' s m => 'Simple' 'Lens' s [a] -> a -> m [a] --- ('<=:') :: 'MonadState' s m => 'Simple' 'Iso' s [a] -> a -> m [a] --- ('<=:') :: 'MonadState' s m => 'Simple' 'Traversal' s [a] -> a -> m [a] --- @ -(<=:) :: MonadState s m => a -> SimpleLensLike ((,)[a]) s [a] -> m [a] -n <=: l = l <%= (n :) -{-# INLINE (<=:) #-} - - --- | Append to the target of a list-valued setter by appending to it with ('++'). --- --- ('Data.Monoid.<>~') generalizes this operation to an arbitrary 'Monoid'. --- --- >>> :m + Control.Lens --- >>> both ++~ "!!!" $ ("hello","world") --- ("hello!!!","world!!!") --- --- @ --- ('++~') :: 'Simple' 'Setter' s [a] -> [a] -> s -> s --- ('++~') :: 'Simple' 'Iso' s [a] -> [a] -> s -> s --- ('++~') :: 'Simple' 'Lens' s [a] -> [a] -> s -> s --- ('++~') :: 'Simple' 'Traversal' s [a] -> [a] -> s -> s --- @ -(++~) :: Setting s t [a] [a] -> [a] -> s -> t -l ++~ n = over l (++ n) -{-# INLINE (++~) #-} - --- | Append to the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' with ('++') in the current state. --- --- ('Data.Monoid.<>=') generalizes this operation to an arbitrary 'Monoid'. --- --- @ --- ('++=') :: 'MonadState' s m => 'Simple' 'Setter' s [a] -> [a] -> m () --- ('++=') :: 'MonadState' s m => 'Simple' 'Iso' s [a] -> [a] -> m () --- ('++=') :: 'MonadState' s m => 'Simple' 'Lens' s [a] -> [a] -> m () --- ('++=') :: 'MonadState' s m => 'Simple' 'Traversal' s [a] -> [a] -> m () --- @ -(++=) :: MonadState s m => SimpleSetting s [a] -> [a] -> m () -l ++= b = State.modify (l ++~ b) -{-# INLINE (++=) #-} - --- | Append onto the end of the list targeted by a 'Lens' and return the result. --- --- ('Data.Monoid.<<>~') generalizes this operation to an arbitrary 'Monoid'. --- --- When using a 'Traversal', the result returned is actually the concatenation of all of the results. --- --- When you do not need the result of the operation, ('++~') is more flexible. -(<++~) :: LensLike ((,)[a]) s t [a] [a] -> [a] -> s -> ([a], t) -l <++~ m = l <%~ (++ m) -{-# INLINE (<++~) #-} - --- | Append onto the end of the list targeted by a 'Lens' into the current monadic state, and return the result. --- --- ('Data.Monoid.<<>=') generalizes this operation to an arbitrary 'Monoid'. --- --- When using a 'Traversal', the result returned is actually the concatenation of all of the results. --- --- When you do not need the result of the operation, ('++=') is more flexible. -(<++=) :: MonadState s m => SimpleLensLike ((,)[a]) s [a] -> [a] -> m [a] -l <++= m = l <%= (++ m) -{-# INLINE (<++=) #-} diff --git a/src/Data/List/Split/Lens.hs b/src/Data/List/Split/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Split/Lens.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +---------------------------------------------------------------------------- +-- | +-- Module : Data.List.Split.Lens +-- Copyright : (C) 2012 Edward Kmett, Alexander Altman +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +-- Lenses for working with Data.List.Split +-- +---------------------------------------------------------------------------- +module Data.List.Split.Lens + ( + -- * Splitting Folds + splitting + , splittingOn + , splittingOneOf + , splittingWhen + , endingBy + , endingByOneOf + , wordingBy + , liningBy + , chunking + , splittingPlaces + , splittingPlacesBlanks + -- * Lenses for 'Splitter' Internals + , delimiters + , delimiting + , condensing + , keepInitialBlanks + , keepFinalBlanks + ) where + +import Control.Applicative +import Control.Lens +import Control.Lens.Internal +import Data.List.Split +import Data.List.Split.Internals + +-- $setup +-- >>> import Control.Lens + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' according to the given splitting strategy. +-- +-- @ +-- 'splitting' :: 'Splitter' a -> 'Fold' i s a -> 'Fold' [i] s [a] +-- @ +splitting :: (Applicative f, Gettable f) => Splitter a -> Getting [a] s s a a -> LensLike f s s [a] [a] +splitting s l f = coerce . traverse f . split s . toListOf l +{-# INLINE splitting #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' on the given delimiter. +-- +-- Equivalent to @'splitting' '.' 'dropDelims' '.' 'onSublist'@. +-- +-- @ +-- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] +-- @ +splittingOn :: (Applicative f, Gettable f, Eq a) => [a] -> Getting [a] s s a a -> LensLike f s s [a] [a] +splittingOn s l f = coerce . traverse f . splitOn s . toListOf l +{-# INLINE splittingOn #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' on any of the given elements. +-- +-- Equivalent to @'splitting' '.' 'dropDelims' '.' 'oneOf'@. +-- +-- @ +-- 'splittingOn' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] +-- @ +splittingOneOf :: (Applicative f, Gettable f, Eq a) => [a] -> Getting [a] s s a a -> LensLike f s s [a] [a] +splittingOneOf s l f = coerce . traverse f . splitOneOf s . toListOf l +{-# INLINE splittingOneOf #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' on elements satisfying the given predicate. +-- +-- Equivalent to @'splitting' '.' 'dropDelims' '.' 'whenElt'@. +-- +-- @ +-- 'splittingOn' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] +-- @ +splittingWhen :: (Applicative f, Gettable f, Eq a) => (a -> Bool) -> Getting [a] s s a a -> LensLike f s s [a] [a] +splittingWhen s l f = coerce . traverse f . splitWhen s . toListOf l +{-# INLINE splittingWhen #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' into chunks terminated by the given delimiter. +-- +-- Equivalent to @'splitting' '.' 'dropDelims' '.' 'onSublist'@. +-- +-- @ +-- 'endingBy' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] +-- @ +endingBy :: (Applicative f, Gettable f, Eq a) => [a] -> Getting [a] s s a a -> LensLike f s s [a] [a] +endingBy s l f = coerce . traverse f . endBy s . toListOf l +{-# INLINE endingBy #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' into chunks terminated by any of the given elements. +-- +-- Equivalent to @'splitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'oneOf'@. +-- +-- @ +-- 'endingByOneOf' :: 'Eq' a => [a] -> 'Fold' s a -> 'Fold' s [a] +-- @ +endingByOneOf :: (Applicative f, Gettable f, Eq a) => [a] -> Getting [a] s s a a -> LensLike f s s [a] [a] +endingByOneOf s l f = coerce . traverse f . endByOneOf s . toListOf l +{-# INLINE endingByOneOf #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' into "words", with word boundaries indicated by the given predicate. +-- +-- Equivalent to @'splitting' '.' 'dropBlanks' '.' 'dropDelims' '.' 'whenElt'@. +-- +-- @ +-- 'wordingBy' :: (a -> 'Bool') -> 'Fold' a -> 'Fold' s [a] +-- @ +wordingBy :: (Applicative f, Gettable f, Eq a) => (a -> Bool) -> Getting [a] s s a a -> LensLike f s s [a] [a] +wordingBy s l f = coerce . traverse f . wordsBy s . toListOf l +{-# INLINE wordingBy #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' into "lines", with line boundaries indicated by the given predicate. +-- +-- Equivalent to @'splitting' '.' 'dropFinalBlank' '.' 'dropDelims' '.' 'whenElt'@. +-- +-- @ +-- 'liningBy' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s [a] +-- @ +liningBy :: (Applicative f, Gettable f, Eq a) => (a -> Bool) -> Getting [a] s s a a -> LensLike f s s [a] [a] +liningBy s l f = coerce . traverse f . linesBy s . toListOf l +{-# INLINE liningBy #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' into length-@n@ pieces. +-- +-- @ +-- 'chunkingOf' :: 'Int' -> 'Fold' s a -> 'Fold' s [a] +-- @ +chunking :: (Applicative f, Gettable f) => Int -- ^ @n@ + -> Getting [a] s s a a -> LensLike f s s [a] [a] +chunking s l f = coerce . traverse f . chunksOf s . toListOf l +{-# INLINE chunking #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' into chunks of the given lengths, . +-- +-- @ +-- 'splittingPlaces' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] +-- @ +splittingPlaces :: (Applicative f, Gettable f, Integral n) => [n] -> Getting [a] s s a a -> LensLike f s s [a] [a] +splittingPlaces s l f = coerce . traverse f . splitPlaces s . toListOf l +{-# INLINE splittingPlaces #-} + +-- | Obtain a 'Fold' by splitting another 'Fold', 'Control.Lens.Type.Lens', 'Getter' or 'Control.Lens.Traversal.Traversal' into chunks of the given lengths. Unlike 'splittingPlaces', the output 'Fold' will always be the same length as the first input argument. +-- +-- @ +-- 'splittingPlacesBlanks' :: 'Integral' n => [n] -> 'Fold' s a -> 'Fold' s [a] +-- @ +splittingPlacesBlanks :: (Applicative f, Gettable f, Integral n) => [n] -> Getting [a] s s a a -> LensLike f s s [a] [a] +splittingPlacesBlanks s l f = coerce . traverse f . splitPlacesBlanks s . toListOf l +{-# INLINE splittingPlacesBlanks #-} + + +-- | Modify or retrieve the list of delimiters for a 'Splitter'. +delimiters :: Lens (Splitter a) (Splitter b) [a -> Bool] [b -> Bool] +delimiters f s@Splitter { delimiter = Delimiter ds } = (\ds' -> s { delimiter = Delimiter ds' }) <$> f ds + +-- | Modify or retrieve the policy for what a 'Splitter' to do with delimiters. +delimiting :: Simple Lens (Splitter a) DelimPolicy +delimiting f s@Splitter { delimPolicy = p } = (\p' -> s { delimPolicy = p' }) <$> f p + +-- | Modify or retrieve the policy for what a 'Splitter' should about consecutive delimiters. +condensing :: Simple Lens (Splitter a) Bool +condensing f s@Splitter { condensePolicy = p } = (\p' -> s { condensePolicy = i p' }) <$> f (o p) where + i True = Condense + i False = KeepBlankFields + o Condense = True + o KeepBlankFields = False + +-- | Modify or retrieve the policy for whether a 'Splitter' should drop an initial blank. +keepInitialBlanks :: Simple Lens (Splitter a) Bool +keepInitialBlanks f s@Splitter { initBlankPolicy = p } = (\p' -> s { initBlankPolicy = end p' }) <$> f (keeps p) + +-- | Modify or retrieve the policy for whether a 'Splitter' should drop a final blank. +keepFinalBlanks :: Simple Lens (Splitter a) Bool +keepFinalBlanks f s@Splitter { finalBlankPolicy = p } = (\p' -> s { finalBlankPolicy = end p' }) <$> f (keeps p) + +-- utilities + +end :: Bool -> EndPolicy +end True = KeepBlank +end False = DropBlank + +keeps :: EndPolicy -> Bool +keeps KeepBlank = True +keeps DropBlank = False 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 @@ -15,7 +15,6 @@ ) where import Control.Lens.Getter -import Control.Lens.Internal import Control.Lens.Setter import Data.Set as Set @@ -47,5 +46,5 @@ -- 'setOf' :: 'Ord' a => 'Control.Lens.Type.Simple' 'Control.Lens.Traversal.Traversal' s a -> s -> 'Set' a -- @ setOf :: Getting (Set a) s t a b -> s -> Set a -setOf l = runAccessor . l (Accessor . Set.singleton) +setOf l = views l Set.singleton {-# INLINE setOf #-} diff --git a/src/Data/Tree/Lens.hs b/src/Data/Tree/Lens.hs --- a/src/Data/Tree/Lens.hs +++ b/src/Data/Tree/Lens.hs @@ -17,7 +17,6 @@ import Control.Lens import Data.Functor -import Data.List.Lens import Data.Tree -- | A 'Lens' that focuses on the root of a 'Tree'. @@ -33,5 +32,5 @@ -- -- @'toListOf' 'branches' ≡ 'subForest'@ branches :: SimpleIndexedTraversal Int (Tree a) (Tree a) -branches = index $ \ f (Node a as) -> Node a <$> withIndex traverseList f as +branches = index $ \ f (Node a as) -> Node a <$> itraverse f as {-# INLINE branches #-} diff --git a/src/Data/Vector/Generic/Lens.hs b/src/Data/Vector/Generic/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Generic/Lens.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE MultiParamTypeClasses #-} +------------------------------------------------------------------------------- +-- | +-- Module : Data.Vector.Generic.Lens +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : non-portable +-- +-- This module provides lenses and traversals for working with generic vectors. +------------------------------------------------------------------------------- +module Data.Vector.Generic.Lens + ( toVectorOf + -- * Isomorphisms + , forced + , vector + , asStream + , asStreamR + , cloned + , reversed + -- * Lenses + , _head + , _tail + , _last + , _init + , sliced + -- * Traversal of individual indices + , atIndex + , atIndices + ) where + +import Control.Applicative +import Control.Lens +import Data.Vector.Generic as V hiding (zip, filter) +import Data.Vector.Fusion.Stream (Stream) +import Data.Vector.Generic.New (New) +import Prelude hiding ((++), length, head, tail, init, last, map, reverse) +import Data.List (nub) + +-- $setup +-- >>> import Data.Vector as Vector + +-- | A lens reading and writing to the 'head' of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to the 'head' of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> Vector.fromList [1,2,3]^._head +-- 1 +_head :: Vector v a => SimpleLens (v a) a +_head f v = (\a -> v // [(0,a)]) <$> f (head v) +{-# INLINE _head #-} + +-- | A 'Lens' reading and writing to the 'last' element of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to the 'last' element of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> Vector.fromList [1,2]^._last +-- 2 +_last :: Vector v a => SimpleLens (v a) a +_last f v = (\a -> v // [(length v - 1, a)]) <$> f (last v) +{-# INLINE _last #-} + +-- | A lens reading and writing to the 'tail' of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to the 'tail' of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> _tail .~ Vector.fromList [3,4,5] $ Vector.fromList [1,2] +-- fromList [1,3,4,5] +_tail :: Vector v a => SimpleLens (v a) (v a) +_tail f v = cons (head v) <$> f (tail v) +{-# INLINE _tail #-} + +-- | A 'Lens' reading and replacing all but the a 'last' element of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to all but the 'last' element of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> Vector.fromList [1,2,3,4]^._init +-- fromList [1,2,3] +_init :: Vector v a => SimpleLens (v a) (v a) +_init f v = (`snoc` last v) <$> f (init v) +{-# INLINE _init #-} + +-- | @sliced i n@ provides a lens that edits the @n@ elements starting at index @i@ from a lens. +-- +-- This is only a valid lens if you do not change the length of the resulting 'Vector'. +-- +-- Attempting to return a longer or shorter vector will result in violations of the 'Lens' laws. +sliced :: Vector v a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> SimpleLens (v a) (v a) +sliced i n f v = (\ v0 -> v // zip [i..i+n-1] (V.toList v0)) <$> f (slice i n v) +{-# INLINE sliced #-} + +-- | Similar to 'toListOf', but returning a 'Vector'. +toVectorOf :: Vector v a => Getting [a] s t a b -> s -> v a +toVectorOf l s = fromList (toListOf l s) +{-# INLINE toVectorOf #-} + +-- | Convert a list to a 'Vector' (or back) +vector :: Vector v a => Simple Iso [a] (v a) +vector = iso fromList V.toList +{-# INLINE vector #-} + +-- | Convert a 'Vector' to a finite 'Stream' (or back) +asStream :: Vector v a => Simple Iso (v a) (Stream a) +asStream = iso stream unstream +{-# INLINE asStream #-} + +-- | Convert a 'Vector' to a finite 'Stream' from right to left (or back) +asStreamR :: Vector v a => Simple Iso (v a) (Stream a) +asStreamR = iso streamR unstreamR +{-# INLINE asStreamR #-} + +-- | Convert a 'Vector' back and forth to an initializer that when run produces a copy of the 'Vector'. +cloned :: Vector v a => Simple Iso (v a) (New v a) +cloned = iso clone new +{-# INLINE cloned #-} + +-- | Convert a 'Vector' to a version that doesn't retain any extra memory. +forced :: Vector v a => Simple Iso (v a) (v a) +forced = iso force force +{-# INLINE forced #-} + +-- | Convert a 'Vector' to a version with all the elements in the reverse order +reversed :: Vector v a => Simple Iso (v a) (v a) +reversed = iso reverse reverse +{-# INLINE reversed #-} + +-- | This is a more efficient version of 'element' that works for any 'Vector'. +-- +-- @atIndex n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. +atIndex :: Vector v a => Int -> SimpleIndexedLens Int (v a) a +atIndex i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) +{-# INLINE atIndex #-} + +-- | This 'Traversal' will ignore any duplicates in the supplied list of indices. +-- +-- >>> toListOf (atIndices [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] +-- [4,8,6,12,20,22] +atIndices :: Vector v a => [Int] -> SimpleIndexedTraversal Int (v a) a +atIndices is = index $ \ f v -> let + l = length v + is' = nub $ filter ( +-- Stability : provisional +-- Portability : non-portable +-- +-- This module provides lenses and traversals for working with generic vectors. +------------------------------------------------------------------------------- +module Data.Vector.Lens + ( toVectorOf + -- * Isomorphisms + , vector + , reversed + , forced + -- * Lenses + , _head + , _tail + , _last + , _init + , sliced + -- * Traversal of individual indices + , atIndex + , atIndices + ) where + +import Control.Applicative +import Control.Lens +import Data.Vector as Vector hiding (zip, filter) +import Prelude hiding ((++), length, head, tail, init, last, map, reverse) +import Data.List (nub) + +-- | A lens reading and writing to the 'head' of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to the 'head' of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> Vector.fromList [1,2,3]^._head +-- 1 +_head :: SimpleLens (Vector a) a +_head f v = (\a -> v // [(0,a)]) <$> f (head v) +{-# INLINE _head #-} + +-- | A 'Lens' reading and writing to the 'last' element of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to the 'last' element of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> Vector.fromList [1,2]^._last +-- 2 +_last :: SimpleLens (Vector a) a +_last f v = (\a -> v // [(length v - 1, a)]) <$> f (last v) +{-# INLINE _last #-} + +-- | A lens reading and writing to the 'tail' of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to the 'tail' of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> _tail .~ Vector.fromList [3,4,5] $ Vector.fromList [1,2] +-- fromList [1,3,4,5] +_tail :: SimpleLens (Vector a) (Vector a) +_tail f v = cons (head v) <$> f (tail v) +{-# INLINE _tail #-} + +-- | A 'Lens' reading and replacing all but the a 'last' element of a /non-empty/ 'Vector' +-- +-- Attempting to read or write to all but the 'last' element of an /empty/ 'Vector' will result in an 'error'. +-- +-- >>> Vector.fromList [1,2,3,4]^._init +-- fromList [1,2,3] +_init :: SimpleLens (Vector a) (Vector a) +_init f v = (`snoc` last v) <$> f (init v) +{-# INLINE _init #-} + +-- | @sliced i n@ provides a lens that edits the @n@ elements starting at index @i@ from a lens. +-- +-- This is only a valid lens if you do not change the length of the resulting 'Vector'. +-- +-- Attempting to return a longer or shorter vector will result in violations of the 'Lens' laws. +sliced :: Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> SimpleLens (Vector a) (Vector a) +sliced i n f v = (\ v0 -> v // zip [i..i+n-1] (toList v0)) <$> f (slice i n v) +{-# INLINE sliced #-} + +-- | Similar to 'toListOf', but returning a 'Vector'. +toVectorOf :: Getting [a] s t a b -> s -> Vector a +toVectorOf l s = fromList (toListOf l s) +{-# INLINE toVectorOf #-} + +-- | Convert a list to a 'Vector' (or back) +vector :: Iso [a] [b] (Vector a) (Vector b) +vector = isos fromList toList fromList toList +{-# INLINE vector #-} + +-- | Convert a 'Vector' to a version with all the elements in the reverse order +reversed :: Iso (Vector a) (Vector b) (Vector a) (Vector b) +reversed = isos reverse reverse reverse reverse +{-# INLINE reversed #-} + +-- | Convert a 'Vector' to a version that doesn't retain any extra memory. +forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b) +forced = isos force force force force +{-# INLINE forced #-} + +-- | This is a more efficient version of 'element' that works for any 'Vector'. +-- +-- @atIndex n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. +atIndex :: Int -> SimpleIndexedLens Int (Vector a) a +atIndex i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) +{-# INLINE atIndex #-} + +-- | This 'Traversal' will ignore any duplicates in the supplied list of indices. +-- +-- >>> toListOf (atIndices [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] +-- [4,8,6,12,20,22] +atIndices :: [Int] -> SimpleIndexedTraversal Int (Vector a) a +atIndices is = index $ \ f v -> let + l = length v + is' = nub $ filter (~ [ origin ]) + @?= trig { _points = (trig % _points) <> [ origin ] } case_append_to_state_record_field = do runState test trig @?= ((), trig') where - test = points ++= [ origin ] - trig' = trig { _points = (trig % _points) ++ [ origin ] } + test = points <>= [ origin ] + trig' = trig { _points = (trig % _points) <> [ origin ] } case_append_to_record_field_and_access_new_value = - (trig % points <++~ [ origin ]) - @?= (_points trig ++ [ origin ], trig { _points = (trig % _points) ++ [ origin ] }) + (trig % points <<>~ [ origin ]) + @?= (_points trig <> [ origin ], trig { _points = (trig % _points) <> [ origin ] }) case_append_to_state_record_field_and_access_new_value = do - runState test trig @?= (_points trig ++ [ origin ], trig') + runState test trig @?= (_points trig <> [ origin ], trig') where - test = points <++= [ origin ] - trig' = trig { _points = (trig % _points) ++ [ origin ] } + test = points <<>= [ origin ] + trig' = trig { _points = (trig % _points) <> [ origin ] } case_append_to_record_field_and_access_old_value = - (trig % points <<%~ (++[origin])) - @?= (_points trig, trig { _points = (trig % _points) ++ [ origin ] }) + (trig % points <<%~ (<>[origin])) + @?= (_points trig, trig { _points = (trig % _points) <> [ origin ] }) case_append_to_state_record_field_and_access_old_value = do runState test trig @?= (_points trig, trig') where - test = points <<%= (++[origin]) - trig' = trig { _points = (trig % _points) ++ [ origin ] } + test = points <<%= (<>[origin]) + trig' = trig { _points = (trig % _points) <> [ origin ] } case_read_maybe_map_entry = trig^.labels.at origin @?= Just "Origin"