1{-# LANGUAGE CPP #-} 2{-# LANGUAGE GADTs #-} 3{-# LANGUAGE Rank2Types #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE FunctionalDependencies #-} 7{-# LANGUAGE ScopedTypeVariables #-} 8{-# LANGUAGE Trustworthy #-} 9{-# LANGUAGE ConstraintKinds #-} 10 11#include "lens-common.h" 12 13----------------------------------------------------------------------------- 14-- | 15-- Module : Control.Lens.Traversal 16-- Copyright : (C) 2012-16 Edward Kmett 17-- License : BSD-style (see the file LICENSE) 18-- Maintainer : Edward Kmett <ekmett@gmail.com> 19-- Stability : provisional 20-- Portability : Rank2Types 21-- 22-- A @'Traversal' s t a b@ is a generalization of 'traverse' from 23-- 'Traversable'. It allows you to 'traverse' over a structure and change out 24-- its contents with monadic or 'Applicative' side-effects. Starting from 25-- 26-- @ 27-- 'traverse' :: ('Traversable' t, 'Applicative' f) => (a -> f b) -> t a -> f (t b) 28-- @ 29-- 30-- we monomorphize the contents and result to obtain 31-- 32-- @ 33-- type 'Traversal' s t a b = forall f. 'Applicative' f => (a -> f b) -> s -> f t 34-- @ 35-- 36-- A 'Traversal' can be used as a 'Fold'. 37-- Any 'Traversal' can be used for 'Control.Lens.Getter.Getting' like a 'Fold', 38-- because given a 'Data.Monoid.Monoid' @m@, we have an 'Applicative' for 39-- @('Const' m)@. Everything you know how to do with a 'Traversable' container, 40-- you can with a 'Traversal', and here we provide combinators that generalize 41-- the usual 'Traversable' operations. 42---------------------------------------------------------------------------- 43module Control.Lens.Traversal 44 ( 45 -- * Traversals 46 Traversal, Traversal' 47 , Traversal1, Traversal1' 48 , IndexedTraversal, IndexedTraversal' 49 , IndexedTraversal1, IndexedTraversal1' 50 , ATraversal, ATraversal' 51 , ATraversal1, ATraversal1' 52 , AnIndexedTraversal, AnIndexedTraversal' 53 , AnIndexedTraversal1, AnIndexedTraversal1' 54 , Traversing, Traversing' 55 , Traversing1, Traversing1' 56 57 -- * Traversing and Lensing 58 , traverseOf, forOf, sequenceAOf 59 , mapMOf, forMOf, sequenceOf 60 , transposeOf 61 , mapAccumLOf, mapAccumROf 62 , scanr1Of, scanl1Of 63 , failover, ifailover 64 65 -- * Monomorphic Traversals 66 , cloneTraversal 67 , cloneIndexPreservingTraversal 68 , cloneIndexedTraversal 69 , cloneTraversal1 70 , cloneIndexPreservingTraversal1 71 , cloneIndexedTraversal1 72 73 -- * Parts and Holes 74 , partsOf, partsOf' 75 , unsafePartsOf, unsafePartsOf' 76 , holesOf, holes1Of 77 , singular, unsafeSingular 78 79 -- * Common Traversals 80 , Traversable(traverse) 81 , Traversable1(traverse1) 82 , both, both1 83 , beside 84 , taking 85 , dropping 86 , failing 87 , deepOf 88 89 -- * Indexed Traversals 90 91 -- ** Common 92 , ignored 93 , TraverseMin(..) 94 , TraverseMax(..) 95 , traversed 96 , traversed1 97 , traversed64 98 , elementOf 99 , element 100 , elementsOf 101 , elements 102 103 -- ** Combinators 104 , ipartsOf 105 , ipartsOf' 106 , iunsafePartsOf 107 , iunsafePartsOf' 108 , itraverseOf 109 , iforOf 110 , imapMOf 111 , iforMOf 112 , imapAccumROf 113 , imapAccumLOf 114 115 -- * Reflection 116 , traverseBy 117 , traverseByOf 118 , sequenceBy 119 , sequenceByOf 120 121 -- * Implementation Details 122 , Bazaar(..), Bazaar' 123 , Bazaar1(..), Bazaar1' 124 , loci 125 , iloci 126 127 -- * Fusion 128 , confusing 129 ) where 130 131import Prelude () 132 133import Control.Applicative.Backwards 134import qualified Control.Category as C 135import Control.Comonad 136import Control.Lens.Fold 137import Control.Lens.Getter (Getting, IndexedGetting, getting) 138import Control.Lens.Internal.Bazaar 139import Control.Lens.Internal.Context 140import Control.Lens.Internal.Fold 141import Control.Lens.Internal.Indexed 142import Control.Lens.Internal.Prelude 143import Control.Lens.Lens 144import Control.Lens.Setter (ASetter, AnIndexedSetter, isets, sets) 145import Control.Lens.Type 146import Control.Monad.Trans.State.Lazy 147import Data.Bitraversable 148import Data.CallStack 149import Data.Functor.Apply 150import Data.Functor.Day.Curried 151import Data.Functor.Yoneda 152import Data.Int 153import qualified Data.IntMap as IntMap 154import qualified Data.Map as Map 155import Data.Map (Map) 156import Data.Monoid (Any (..)) 157import Data.Sequence (Seq, mapWithIndex) 158import Data.Vector as Vector (Vector, imap) 159import Data.Profunctor.Rep (Representable (..)) 160import Data.Reflection 161import Data.Semigroup.Traversable 162import Data.Semigroup.Bitraversable 163import Data.Tuple (swap) 164import GHC.Magic (inline) 165 166-- $setup 167-- >>> :set -XNoOverloadedStrings -XFlexibleContexts 168-- >>> import Data.Char (toUpper) 169-- >>> import Control.Lens 170-- >>> import Control.DeepSeq (NFData (..), force) 171-- >>> import Control.Exception (evaluate,try,ErrorCall(..)) 172-- >>> import Data.Maybe (fromMaybe) 173-- >>> import Debug.SimpleReflect.Vars 174-- >>> import Data.Void 175-- >>> import Data.List (sort) 176-- >>> import System.Timeout (timeout) 177-- >>> import qualified Data.List.NonEmpty as NonEmpty 178-- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force 179 180------------------------------------------------------------------------------ 181-- Traversals 182------------------------------------------------------------------------------ 183 184-- | When you see this as an argument to a function, it expects a 'Traversal'. 185type ATraversal s t a b = LensLike (Bazaar (->) a b) s t a b 186 187-- | @ 188-- type 'ATraversal'' = 'Simple' 'ATraversal' 189-- @ 190type ATraversal' s a = ATraversal s s a a 191 192 193-- | When you see this as an argument to a function, it expects a 'Traversal1'. 194type ATraversal1 s t a b = LensLike (Bazaar1 (->) a b) s t a b 195 196-- | @ 197-- type 'ATraversal1'' = 'Simple' 'ATraversal1' 198-- @ 199type ATraversal1' s a = ATraversal1 s s a a 200 201-- | When you see this as an argument to a function, it expects an 'IndexedTraversal'. 202type AnIndexedTraversal i s t a b = Over (Indexed i) (Bazaar (Indexed i) a b) s t a b 203 204-- | When you see this as an argument to a function, it expects an 'IndexedTraversal1'. 205type AnIndexedTraversal1 i s t a b = Over (Indexed i) (Bazaar1 (Indexed i) a b) s t a b 206 207-- | @ 208-- type 'AnIndexedTraversal'' = 'Simple' ('AnIndexedTraversal' i) 209-- @ 210type AnIndexedTraversal' i s a = AnIndexedTraversal i s s a a 211 212-- | @ 213-- type 'AnIndexedTraversal1'' = 'Simple' ('AnIndexedTraversal1' i) 214-- @ 215type AnIndexedTraversal1' i s a = AnIndexedTraversal1 i s s a a 216 217 218-- | When you see this as an argument to a function, it expects 219-- 220-- * to be indexed if @p@ is an instance of 'Indexed' i, 221-- 222-- * to be unindexed if @p@ is @(->)@, 223-- 224-- * a 'Traversal' if @f@ is 'Applicative', 225-- 226-- * a 'Getter' if @f@ is only a 'Functor' and 'Data.Functor.Contravariant.Contravariant', 227-- 228-- * a 'Lens' if @f@ is only a 'Functor', 229-- 230-- * a 'Fold' if @f@ is 'Applicative' and 'Data.Functor.Contravariant.Contravariant'. 231type Traversing p f s t a b = Over p (BazaarT p f a b) s t a b 232 233type Traversing1 p f s t a b = Over p (BazaarT1 p f a b) s t a b 234 235-- | @ 236-- type 'Traversing'' f = 'Simple' ('Traversing' f) 237-- @ 238type Traversing' p f s a = Traversing p f s s a a 239type Traversing1' p f s a = Traversing1 p f s s a a 240 241-------------------------- 242-- Traversal Combinators 243-------------------------- 244 245-- | Map each element of a structure targeted by a 'Lens' or 'Traversal', 246-- evaluate these actions from left to right, and collect the results. 247-- 248-- This function is only provided for consistency, 'id' is strictly more general. 249-- 250-- >>> traverseOf each print (1,2,3) 251-- 1 252-- 2 253-- 3 254-- ((),(),()) 255-- 256-- @ 257-- 'traverseOf' ≡ 'id' 258-- 'itraverseOf' l ≡ 'traverseOf' l '.' 'Indexed' 259-- 'itraverseOf' 'itraversed' ≡ 'itraverse' 260-- @ 261-- 262-- 263-- This yields the obvious law: 264-- 265-- @ 266-- 'traverse' ≡ 'traverseOf' 'traverse' 267-- @ 268-- 269-- @ 270-- 'traverseOf' :: 'Functor' f => 'Iso' s t a b -> (a -> f b) -> s -> f t 271-- 'traverseOf' :: 'Functor' f => 'Lens' s t a b -> (a -> f b) -> s -> f t 272-- 'traverseOf' :: 'Apply' f => 'Traversal1' s t a b -> (a -> f b) -> s -> f t 273-- 'traverseOf' :: 'Applicative' f => 'Traversal' s t a b -> (a -> f b) -> s -> f t 274-- @ 275traverseOf :: LensLike f s t a b -> (a -> f b) -> s -> f t 276traverseOf = id 277{-# INLINE traverseOf #-} 278 279-- | A version of 'traverseOf' with the arguments flipped, such that: 280-- 281-- >>> forOf each (1,2,3) print 282-- 1 283-- 2 284-- 3 285-- ((),(),()) 286-- 287-- This function is only provided for consistency, 'flip' is strictly more general. 288-- 289-- @ 290-- 'forOf' ≡ 'flip' 291-- 'forOf' ≡ 'flip' . 'traverseOf' 292-- @ 293-- 294-- @ 295-- 'for' ≡ 'forOf' 'traverse' 296-- 'Control.Lens.Indexed.ifor' l s ≡ 'for' l s '.' 'Indexed' 297-- @ 298-- 299-- @ 300-- 'forOf' :: 'Functor' f => 'Iso' s t a b -> s -> (a -> f b) -> f t 301-- 'forOf' :: 'Functor' f => 'Lens' s t a b -> s -> (a -> f b) -> f t 302-- 'forOf' :: 'Applicative' f => 'Traversal' s t a b -> s -> (a -> f b) -> f t 303-- @ 304forOf :: LensLike f s t a b -> s -> (a -> f b) -> f t 305forOf = flip 306{-# INLINE forOf #-} 307 308-- | Evaluate each action in the structure from left to right, and collect 309-- the results. 310-- 311-- >>> sequenceAOf both ([1,2],[3,4]) 312-- [(1,3),(1,4),(2,3),(2,4)] 313-- 314-- @ 315-- 'sequenceA' ≡ 'sequenceAOf' 'traverse' ≡ 'traverse' 'id' 316-- 'sequenceAOf' l ≡ 'traverseOf' l 'id' ≡ l 'id' 317-- @ 318-- 319-- @ 320-- 'sequenceAOf' :: 'Functor' f => 'Iso' s t (f b) b -> s -> f t 321-- 'sequenceAOf' :: 'Functor' f => 'Lens' s t (f b) b -> s -> f t 322-- 'sequenceAOf' :: 'Applicative' f => 'Traversal' s t (f b) b -> s -> f t 323-- @ 324sequenceAOf :: LensLike f s t (f b) b -> s -> f t 325sequenceAOf l = l id 326{-# INLINE sequenceAOf #-} 327 328-- | Map each element of a structure targeted by a 'Lens' to a monadic action, 329-- evaluate these actions from left to right, and collect the results. 330-- 331-- >>> mapMOf both (\x -> [x, x + 1]) (1,3) 332-- [(1,3),(1,4),(2,3),(2,4)] 333-- 334-- @ 335-- 'mapM' ≡ 'mapMOf' 'traverse' 336-- 'imapMOf' l ≡ 'forM' l '.' 'Indexed' 337-- @ 338-- 339-- @ 340-- 'mapMOf' :: 'Monad' m => 'Iso' s t a b -> (a -> m b) -> s -> m t 341-- 'mapMOf' :: 'Monad' m => 'Lens' s t a b -> (a -> m b) -> s -> m t 342-- 'mapMOf' :: 'Monad' m => 'Traversal' s t a b -> (a -> m b) -> s -> m t 343-- @ 344mapMOf :: LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t 345mapMOf l cmd = unwrapMonad #. l (WrapMonad #. cmd) 346{-# INLINE mapMOf #-} 347 348-- | 'forMOf' is a flipped version of 'mapMOf', consistent with the definition of 'forM'. 349-- 350-- >>> forMOf both (1,3) $ \x -> [x, x + 1] 351-- [(1,3),(1,4),(2,3),(2,4)] 352-- 353-- @ 354-- 'forM' ≡ 'forMOf' 'traverse' 355-- 'forMOf' l ≡ 'flip' ('mapMOf' l) 356-- 'iforMOf' l s ≡ 'forM' l s '.' 'Indexed' 357-- @ 358-- 359-- @ 360-- 'forMOf' :: 'Monad' m => 'Iso' s t a b -> s -> (a -> m b) -> m t 361-- 'forMOf' :: 'Monad' m => 'Lens' s t a b -> s -> (a -> m b) -> m t 362-- 'forMOf' :: 'Monad' m => 'Traversal' s t a b -> s -> (a -> m b) -> m t 363-- @ 364forMOf :: LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t 365forMOf l a cmd = unwrapMonad (l (WrapMonad #. cmd) a) 366{-# INLINE forMOf #-} 367 368-- | Sequence the (monadic) effects targeted by a 'Lens' in a container from left to right. 369-- 370-- >>> sequenceOf each ([1,2],[3,4],[5,6]) 371-- [(1,3,5),(1,3,6),(1,4,5),(1,4,6),(2,3,5),(2,3,6),(2,4,5),(2,4,6)] 372-- 373-- @ 374-- 'sequence' ≡ 'sequenceOf' 'traverse' 375-- 'sequenceOf' l ≡ 'mapMOf' l 'id' 376-- 'sequenceOf' l ≡ 'unwrapMonad' '.' l 'WrapMonad' 377-- @ 378-- 379-- @ 380-- 'sequenceOf' :: 'Monad' m => 'Iso' s t (m b) b -> s -> m t 381-- 'sequenceOf' :: 'Monad' m => 'Lens' s t (m b) b -> s -> m t 382-- 'sequenceOf' :: 'Monad' m => 'Traversal' s t (m b) b -> s -> m t 383-- @ 384sequenceOf :: LensLike (WrappedMonad m) s t (m b) b -> s -> m t 385sequenceOf l = unwrapMonad #. l WrapMonad 386{-# INLINE sequenceOf #-} 387 388-- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'. 389-- 390-- Note: 'Data.List.transpose' handles ragged inputs more intelligently, but for non-ragged inputs: 391-- 392-- >>> transposeOf traverse [[1,2,3],[4,5,6]] 393-- [[1,4],[2,5],[3,6]] 394-- 395-- @ 396-- 'Data.List.transpose' ≡ 'transposeOf' 'traverse' 397-- @ 398-- 399-- Since every 'Lens' is a 'Traversal', we can use this as a form of 400-- monadic strength as well: 401-- 402-- @ 403-- 'transposeOf' 'Control.Lens.Tuple._2' :: (b, [a]) -> [(b, a)] 404-- @ 405transposeOf :: LensLike ZipList s t [a] a -> s -> [t] 406transposeOf l = getZipList #. l ZipList 407{-# INLINE transposeOf #-} 408 409-- | This generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'. 410-- 411-- @ 412-- 'mapAccumR' ≡ 'mapAccumROf' 'traverse' 413-- @ 414-- 415-- 'mapAccumROf' accumulates 'State' from right to left. 416-- 417-- @ 418-- 'mapAccumROf' :: 'Iso' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 419-- 'mapAccumROf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 420-- 'mapAccumROf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 421-- @ 422-- 423-- @ 424-- 'mapAccumROf' :: 'LensLike' ('Backwards' ('State' acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 425-- @ 426mapAccumROf :: LensLike (Backwards (State acc)) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 427mapAccumROf = mapAccumLOf . backwards 428{-# INLINE mapAccumROf #-} 429 430-- | This generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'. 431-- 432-- @ 433-- 'mapAccumL' ≡ 'mapAccumLOf' 'traverse' 434-- @ 435-- 436-- 'mapAccumLOf' accumulates 'State' from left to right. 437-- 438-- @ 439-- 'mapAccumLOf' :: 'Iso' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 440-- 'mapAccumLOf' :: 'Lens' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 441-- 'mapAccumLOf' :: 'Traversal' s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 442-- @ 443-- 444-- @ 445-- 'mapAccumLOf' :: 'LensLike' ('State' acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 446-- 'mapAccumLOf' l f acc0 s = 'swap' ('runState' (l (\a -> 'state' (\acc -> 'swap' (f acc a))) s) acc0) 447-- @ 448-- 449mapAccumLOf :: LensLike (State acc) s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 450mapAccumLOf l f acc0 s = swap (runState (l g s) acc0) where 451 g a = state $ \acc -> swap (f acc a) 452-- This would be much cleaner if the argument order for the function was swapped. 453{-# INLINE mapAccumLOf #-} 454 455-- | This permits the use of 'scanr1' over an arbitrary 'Traversal' or 'Lens'. 456-- 457-- @ 458-- 'scanr1' ≡ 'scanr1Of' 'traverse' 459-- @ 460-- 461-- @ 462-- 'scanr1Of' :: 'Iso' s t a a -> (a -> a -> a) -> s -> t 463-- 'scanr1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t 464-- 'scanr1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t 465-- @ 466scanr1Of :: LensLike (Backwards (State (Maybe a))) s t a a -> (a -> a -> a) -> s -> t 467scanr1Of l f = snd . mapAccumROf l step Nothing where 468 step Nothing a = (Just a, a) 469 step (Just s) a = (Just r, r) where r = f a s 470{-# INLINE scanr1Of #-} 471 472-- | This permits the use of 'scanl1' over an arbitrary 'Traversal' or 'Lens'. 473-- 474-- @ 475-- 'scanl1' ≡ 'scanl1Of' 'traverse' 476-- @ 477-- 478-- @ 479-- 'scanl1Of' :: 'Iso' s t a a -> (a -> a -> a) -> s -> t 480-- 'scanl1Of' :: 'Lens' s t a a -> (a -> a -> a) -> s -> t 481-- 'scanl1Of' :: 'Traversal' s t a a -> (a -> a -> a) -> s -> t 482-- @ 483scanl1Of :: LensLike (State (Maybe a)) s t a a -> (a -> a -> a) -> s -> t 484scanl1Of l f = snd . mapAccumLOf l step Nothing where 485 step Nothing a = (Just a, a) 486 step (Just s) a = (Just r, r) where r = f s a 487{-# INLINE scanl1Of #-} 488 489-- | This 'Traversal' allows you to 'traverse' the individual stores in a 'Bazaar'. 490loci :: Traversal (Bazaar (->) a c s) (Bazaar (->) b c s) a b 491loci f w = getCompose (runBazaar w (Compose #. fmap sell . f)) 492{-# INLINE loci #-} 493 494-- | This 'IndexedTraversal' allows you to 'traverse' the individual stores in 495-- a 'Bazaar' with access to their indices. 496iloci :: IndexedTraversal i (Bazaar (Indexed i) a c s) (Bazaar (Indexed i) b c s) a b 497iloci f w = getCompose (runBazaar w (Compose #. Indexed (\i -> fmap (indexed sell i) . indexed f i))) 498{-# INLINE iloci #-} 499 500------------------------------------------------------------------------------- 501-- Parts 502------------------------------------------------------------------------------- 503 504-- | 'partsOf' turns a 'Traversal' into a 'Lens' that resembles an early version of the 'Data.Data.Lens.uniplate' (or 'Data.Data.Lens.biplate') type. 505-- 506-- /Note:/ You should really try to maintain the invariant of the number of children in the list. 507-- 508-- >>> (a,b,c) & partsOf each .~ [x,y,z] 509-- (x,y,z) 510-- 511-- Any extras will be lost. If you do not supply enough, then the remainder will come from the original structure. 512-- 513-- >>> (a,b,c) & partsOf each .~ [w,x,y,z] 514-- (w,x,y) 515-- 516-- >>> (a,b,c) & partsOf each .~ [x,y] 517-- (x,y,c) 518-- 519-- >>> ('b', 'a', 'd', 'c') & partsOf each %~ sort 520-- ('a','b','c','d') 521-- 522-- So technically, this is only a 'Lens' if you do not change the number of results it returns. 523-- 524-- When applied to a 'Fold' the result is merely a 'Getter'. 525-- 526-- @ 527-- 'partsOf' :: 'Iso'' s a -> 'Lens'' s [a] 528-- 'partsOf' :: 'Lens'' s a -> 'Lens'' s [a] 529-- 'partsOf' :: 'Traversal'' s a -> 'Lens'' s [a] 530-- 'partsOf' :: 'Fold' s a -> 'Getter' s [a] 531-- 'partsOf' :: 'Getter' s a -> 'Getter' s [a] 532-- @ 533partsOf :: Functor f => Traversing (->) f s t a a -> LensLike f s t [a] [a] 534partsOf l f s = outs b <$> f (ins b) where b = l sell s 535{-# INLINE partsOf #-} 536 537-- | An indexed version of 'partsOf' that receives the entire list of indices as its index. 538ipartsOf :: forall i p f s t a. (Indexable [i] p, Functor f) => Traversing (Indexed i) f s t a a -> Over p f s t [a] [a] 539ipartsOf l = conjoined 540 (\f s -> let b = inline l sell s in outs b <$> f (wins b)) 541 (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in outs b <$> indexed f (is :: [i]) as) 542{-# INLINE ipartsOf #-} 543 544-- | A type-restricted version of 'partsOf' that can only be used with a 'Traversal'. 545partsOf' :: ATraversal s t a a -> Lens s t [a] [a] 546partsOf' l f s = outs b <$> f (ins b) where b = l sell s 547{-# INLINE partsOf' #-} 548 549-- | A type-restricted version of 'ipartsOf' that can only be used with an 'IndexedTraversal'. 550ipartsOf' :: forall i p f s t a. (Indexable [i] p, Functor f) => Over (Indexed i) (Bazaar' (Indexed i) a) s t a a -> Over p f s t [a] [a] 551ipartsOf' l = conjoined 552 (\f s -> let b = inline l sell s in outs b <$> f (wins b)) 553 (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in outs b <$> indexed f (is :: [i]) as) 554{-# INLINE ipartsOf' #-} 555 556-- | 'unsafePartsOf' turns a 'Traversal' into a 'Data.Data.Lens.uniplate' (or 'Data.Data.Lens.biplate') family. 557-- 558-- If you do not need the types of @s@ and @t@ to be different, it is recommended that 559-- you use 'partsOf'. 560-- 561-- It is generally safer to traverse with the 'Bazaar' rather than use this 562-- combinator. However, it is sometimes convenient. 563-- 564-- This is unsafe because if you don't supply at least as many @b@'s as you were 565-- given @a@'s, then the reconstruction of @t@ /will/ result in an error! 566-- 567-- When applied to a 'Fold' the result is merely a 'Getter' (and becomes safe). 568-- 569-- @ 570-- 'unsafePartsOf' :: 'Iso' s t a b -> 'Lens' s t [a] [b] 571-- 'unsafePartsOf' :: 'Lens' s t a b -> 'Lens' s t [a] [b] 572-- 'unsafePartsOf' :: 'Traversal' s t a b -> 'Lens' s t [a] [b] 573-- 'unsafePartsOf' :: 'Fold' s a -> 'Getter' s [a] 574-- 'unsafePartsOf' :: 'Getter' s a -> 'Getter' s [a] 575-- @ 576unsafePartsOf :: Functor f => Traversing (->) f s t a b -> LensLike f s t [a] [b] 577unsafePartsOf l f s = unsafeOuts b <$> f (ins b) where b = l sell s 578{-# INLINE unsafePartsOf #-} 579 580-- | An indexed version of 'unsafePartsOf' that receives the entire list of indices as its index. 581iunsafePartsOf :: forall i p f s t a b. (Indexable [i] p, Functor f) => Traversing (Indexed i) f s t a b -> Over p f s t [a] [b] 582iunsafePartsOf l = conjoined 583 (\f s -> let b = inline l sell s in unsafeOuts b <$> f (wins b)) 584 (\f s -> let b = inline l sell s; (is,as) = unzip (pins b) in unsafeOuts b <$> indexed f (is :: [i]) as) 585{-# INLINE iunsafePartsOf #-} 586 587unsafePartsOf' :: ATraversal s t a b -> Lens s t [a] [b] 588unsafePartsOf' l f s = unsafeOuts b <$> f (ins b) where b = l sell s 589{-# INLINE unsafePartsOf' #-} 590 591iunsafePartsOf' :: forall i s t a b. Over (Indexed i) (Bazaar (Indexed i) a b) s t a b -> IndexedLens [i] s t [a] [b] 592iunsafePartsOf' l = conjoined 593 (\f s -> let b = inline l sell s in unsafeOuts b <$> f (wins b)) 594 (\f s -> let b = inline l sell s; (is, as) = unzip (pins b) in unsafeOuts b <$> indexed f (is :: [i]) as) 595{-# INLINE iunsafePartsOf' #-} 596 597 598-- | This converts a 'Traversal' that you \"know\" will target one or more elements to a 'Lens'. It can 599-- also be used to transform a non-empty 'Fold' into a 'Getter'. 600-- 601-- The resulting 'Lens' or 'Getter' will be partial if the supplied 'Traversal' returns 602-- no results. 603-- 604-- >>> [1,2,3] ^. singular _head 605-- 1 606-- 607-- >>> Left (ErrorCall "singular: empty traversal") <- try (evaluate ([] ^. singular _head)) :: IO (Either ErrorCall ()) 608-- 609-- >>> Left 4 ^. singular _Left 610-- 4 611-- 612-- >>> [1..10] ^. singular (ix 7) 613-- 8 614-- 615-- >>> [] & singular traverse .~ 0 616-- [] 617-- 618-- @ 619-- 'singular' :: 'Traversal' s t a a -> 'Lens' s t a a 620-- 'singular' :: 'Fold' s a -> 'Getter' s a 621-- 'singular' :: 'IndexedTraversal' i s t a a -> 'IndexedLens' i s t a a 622-- 'singular' :: 'IndexedFold' i s a -> 'IndexedGetter' i s a 623-- @ 624singular :: (HasCallStack, Conjoined p, Functor f) 625 => Traversing p f s t a a 626 -> Over p f s t a a 627singular l = conjoined 628 (\afb s -> let b = l sell s in case ins b of 629 (w:ws) -> unsafeOuts b . (:ws) <$> afb w 630 [] -> unsafeOuts b . return <$> afb (error "singular: empty traversal")) 631 (\pafb s -> let b = l sell s in case pins b of 632 (w:ws) -> unsafeOuts b . (:map extract ws) <$> cosieve pafb w 633 [] -> unsafeOuts b . return <$> cosieve pafb (error "singular: empty traversal")) 634{-# INLINE singular #-} 635 636-- | This converts a 'Traversal' that you \"know\" will target only one element to a 'Lens'. It can also be 637-- used to transform a 'Fold' into a 'Getter'. 638-- 639-- The resulting 'Lens' or 'Getter' will be partial if the 'Traversal' targets nothing 640-- or more than one element. 641-- 642-- >>> Left (ErrorCall "unsafeSingular: empty traversal") <- try (evaluate ([] & unsafeSingular traverse .~ 0)) :: IO (Either ErrorCall [Integer]) 643-- 644-- @ 645-- 'unsafeSingular' :: 'Traversal' s t a b -> 'Lens' s t a b 646-- 'unsafeSingular' :: 'Fold' s a -> 'Getter' s a 647-- 'unsafeSingular' :: 'IndexedTraversal' i s t a b -> 'IndexedLens' i s t a b 648-- 'unsafeSingular' :: 'IndexedFold' i s a -> 'IndexedGetter' i s a 649-- @ 650unsafeSingular :: (HasCallStack, Conjoined p, Functor f) 651 => Traversing p f s t a b 652 -> Over p f s t a b 653unsafeSingular l = conjoined 654 (\afb s -> let b = inline l sell s in case ins b of 655 [w] -> unsafeOuts b . return <$> afb w 656 [] -> error "unsafeSingular: empty traversal" 657 _ -> error "unsafeSingular: traversing multiple results") 658 (\pafb s -> let b = inline l sell s in case pins b of 659 [w] -> unsafeOuts b . return <$> cosieve pafb w 660 [] -> error "unsafeSingular: empty traversal" 661 _ -> error "unsafeSingular: traversing multiple results") 662{-# INLINE unsafeSingular #-} 663 664------------------------------------------------------------------------------ 665-- Internal functions used by 'partsOf', etc. 666------------------------------------------------------------------------------ 667 668ins :: Bizarre (->) w => w a b t -> [a] 669ins = toListOf (getting bazaar) 670{-# INLINE ins #-} 671 672wins :: (Bizarre p w, Corepresentable p, Comonad (Corep p)) => w a b t -> [a] 673wins = getConst #. bazaar (cotabulate $ \ra -> Const [extract ra]) 674{-# INLINE wins #-} 675 676pins :: (Bizarre p w, Corepresentable p) => w a b t -> [Corep p a] 677pins = getConst #. bazaar (cotabulate $ \ra -> Const [ra]) 678{-# INLINE pins #-} 679 680parr :: (Profunctor p, C.Category p) => (a -> b) -> p a b 681parr f = lmap f C.id 682{-# INLINE parr #-} 683 684outs :: (Bizarre p w, C.Category p) => w a a t -> [a] -> t 685outs = evalState `rmap` bazaar (parr (state . unconsWithDefault)) 686{-# INLINE outs #-} 687 688unsafeOuts :: (Bizarre p w, Corepresentable p) => w a b t -> [b] -> t 689unsafeOuts = evalState `rmap` bazaar (cotabulate (\_ -> state (unconsWithDefault fakeVal))) 690 where fakeVal = error "unsafePartsOf': not enough elements were supplied" 691{-# INLINE unsafeOuts #-} 692 693unconsWithDefault :: a -> [a] -> (a,[a]) 694unconsWithDefault d [] = (d,[]) 695unconsWithDefault _ (x:xs) = (x,xs) 696{-# INLINE unconsWithDefault #-} 697 698 699------------------------------------------------------------------------------- 700-- Holes 701------------------------------------------------------------------------------- 702 703-- | The one-level version of 'Control.Lens.Plated.contextsOf'. This extracts a 704-- list of the immediate children according to a given 'Traversal' as editable 705-- contexts. 706-- 707-- Given a context you can use 'Control.Comonad.Store.Class.pos' to see the 708-- values, 'Control.Comonad.Store.Class.peek' at what the structure would be 709-- like with an edited result, or simply 'extract' the original structure. 710-- 711-- @ 712-- propChildren l x = 'toListOf' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holesOf' l x) 713-- propId l x = 'all' ('==' x) ['extract' w | w <- 'holesOf' l x] 714-- @ 715-- 716-- @ 717-- 'holesOf' :: 'Iso'' s a -> s -> ['Pretext'' (->) a s] 718-- 'holesOf' :: 'Lens'' s a -> s -> ['Pretext'' (->) a s] 719-- 'holesOf' :: 'Traversal'' s a -> s -> ['Pretext'' (->) a s] 720-- 'holesOf' :: 'IndexedLens'' i s a -> s -> ['Pretext'' ('Indexed' i) a s] 721-- 'holesOf' :: 'IndexedTraversal'' i s a -> s -> ['Pretext'' ('Indexed' i) a s] 722-- @ 723holesOf :: Conjoined p 724 => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t] 725holesOf f xs = flip appEndo [] . fst $ 726 runHoles (runBazaar (f sell xs) (cotabulate holeInOne)) id 727{-# INLINE holesOf #-} 728 729holeInOne :: (Corepresentable p, Comonad (Corep p)) 730 => Corep p a -> Holes t (Endo [Pretext p a a t]) a 731holeInOne x = Holes $ \xt -> 732 ( Endo (fmap xt (cosieve sell x) :) 733 , extract x) 734{-# INLINABLE holeInOne #-} 735 736-- | The non-empty version of 'holesOf'. 737-- This extract a non-empty list of immediate children accroding to a given 738-- 'Traversal1' as editable contexts. 739-- 740-- >>> let head1 f s = runPretext (NonEmpty.head $ holes1Of traversed1 s) f 741-- >>> ('a' :| "bc") ^. head1 742-- 'a' 743-- 744-- >>> ('a' :| "bc") & head1 %~ toUpper 745-- 'A' :| "bc" 746-- 747-- @ 748-- 'holes1Of' :: 'Iso'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s) 749-- 'holes1Of' :: 'Lens'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s) 750-- 'holes1Of' :: 'Traversal1'' s a -> s -> 'NonEmpty' ('Pretext'' (->) a s) 751-- 'holes1Of' :: 'IndexedLens'' i s a -> s -> 'NonEmpty' ('Pretext'' ('Indexed' i) a s) 752-- 'holes1Of' :: 'IndexedTraversal1'' i s a -> s -> 'NonEmpty' ('Pretext'' ('Indexed' i) a s) 753-- @ 754holes1Of :: Conjoined p 755 => Over p (Bazaar1 p a a) s t a a -> s -> NonEmpty (Pretext p a a t) 756holes1Of f xs = flip getNonEmptyDList [] . fst $ 757 runHoles (runBazaar1 (f sell xs) (cotabulate holeInOne1)) id 758{-# INLINE holes1Of #-} 759 760holeInOne1 :: forall p a t. (Corepresentable p, C.Category p) 761 => Corep p a -> Holes t (NonEmptyDList (Pretext p a a t)) a 762holeInOne1 x = Holes $ \xt -> 763 ( NonEmptyDList (fmap xt (cosieve sell x) :|) 764 , cosieve (C.id :: p a a) x) 765 766-- We are very careful to share as much structure as possible among 767-- the results (in the common case where the traversal allows for such). 768-- Note in particular the recursive knot in the implementation of <*> 769-- for Holes. This sharing magic was inspired by Noah "Rampion" Easterly's 770-- implementation of a related holes function: see 771-- https://stackoverflow.com/a/49001904/1477667. The Holes type is 772-- inspired by Roman Cheplyaka's answer to that same question. 773 774newtype Holes t m x = Holes { runHoles :: (x -> t) -> (m, x) } 775 776instance Functor (Holes t m) where 777 fmap f xs = Holes $ \xt -> 778 let 779 (qf, qv) = runHoles xs (xt . f) 780 in (qf, f qv) 781 782instance Semigroup m => Apply (Holes t m) where 783 fs <.> xs = Holes $ \xt -> 784 let 785 (pf, pv) = runHoles fs (xt . ($ qv)) 786 (qf, qv) = runHoles xs (xt . pv) 787 in (pf <> qf, pv qv) 788 789instance Monoid m => Applicative (Holes t m) where 790 pure x = Holes $ \_ -> (mempty, x) 791 792 fs <*> xs = Holes $ \xt -> 793 let 794 (pf, pv) = runHoles fs (xt . ($ qv)) 795 (qf, qv) = runHoles xs (xt . pv) 796 in (pf `mappend` qf, pv qv) 797 798#if MIN_VERSION_base(4,10,0) 799 liftA2 f xs ys = Holes $ \xt -> 800 let 801 (pf, pv) = runHoles xs (xt . flip f qv) 802 (qf, qv) = runHoles ys (xt . f pv) 803 in (pf `mappend` qf, f pv qv) 804#endif 805 806 807------------------------------------------------------------------------------ 808-- Traversals 809------------------------------------------------------------------------------ 810 811-- | Traverse both parts of a 'Bitraversable' container with matching types. 812-- 813-- Usually that type will be a pair. Use 'Control.Lens.Each.each' to traverse 814-- the elements of arbitrary homogeneous tuples. 815-- 816-- >>> (1,2) & both *~ 10 817-- (10,20) 818-- 819-- >>> over both length ("hello","world") 820-- (5,5) 821-- 822-- >>> ("hello","world")^.both 823-- "helloworld" 824-- 825-- @ 826-- 'both' :: 'Traversal' (a, a) (b, b) a b 827-- 'both' :: 'Traversal' ('Either' a a) ('Either' b b) a b 828-- @ 829both :: Bitraversable r => Traversal (r a a) (r b b) a b 830both f = bitraverse f f 831{-# INLINE both #-} 832 833-- | Traverse both parts of a 'Bitraversable1' container with matching types. 834-- 835-- Usually that type will be a pair. 836-- 837-- @ 838-- 'both1' :: 'Traversal1' (a, a) (b, b) a b 839-- 'both1' :: 'Traversal1' ('Either' a a) ('Either' b b) a b 840-- @ 841both1 :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b 842both1 f = bitraverse1 f f 843{-# INLINE both1 #-} 844 845-- | Apply a different 'Traversal' or 'Fold' to each side of a 'Bitraversable' container. 846-- 847-- @ 848-- 'beside' :: 'Traversal' s t a b -> 'Traversal' s' t' a b -> 'Traversal' (r s s') (r t t') a b 849-- 'beside' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s' t' a b -> 'IndexedTraversal' i (r s s') (r t t') a b 850-- 'beside' :: 'IndexPreservingTraversal' s t a b -> 'IndexPreservingTraversal' s' t' a b -> 'IndexPreservingTraversal' (r s s') (r t t') a b 851-- @ 852-- 853-- @ 854-- 'beside' :: 'Traversal' s t a b -> 'Traversal' s' t' a b -> 'Traversal' (s,s') (t,t') a b 855-- 'beside' :: 'Lens' s t a b -> 'Lens' s' t' a b -> 'Traversal' (s,s') (t,t') a b 856-- 'beside' :: 'Fold' s a -> 'Fold' s' a -> 'Fold' (s,s') a 857-- 'beside' :: 'Getter' s a -> 'Getter' s' a -> 'Fold' (s,s') a 858-- @ 859-- 860-- @ 861-- 'beside' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s' t' a b -> 'IndexedTraversal' i (s,s') (t,t') a b 862-- 'beside' :: 'IndexedLens' i s t a b -> 'IndexedLens' i s' t' a b -> 'IndexedTraversal' i (s,s') (t,t') a b 863-- 'beside' :: 'IndexedFold' i s a -> 'IndexedFold' i s' a -> 'IndexedFold' i (s,s') a 864-- 'beside' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s' a -> 'IndexedFold' i (s,s') a 865-- @ 866-- 867-- @ 868-- 'beside' :: 'IndexPreservingTraversal' s t a b -> 'IndexPreservingTraversal' s' t' a b -> 'IndexPreservingTraversal' (s,s') (t,t') a b 869-- 'beside' :: 'IndexPreservingLens' s t a b -> 'IndexPreservingLens' s' t' a b -> 'IndexPreservingTraversal' (s,s') (t,t') a b 870-- 'beside' :: 'IndexPreservingFold' s a -> 'IndexPreservingFold' s' a -> 'IndexPreservingFold' (s,s') a 871-- 'beside' :: 'IndexPreservingGetter' s a -> 'IndexPreservingGetter' s' a -> 'IndexPreservingFold' (s,s') a 872-- @ 873-- 874-- >>> ("hello",["world","!!!"])^..beside id traverse 875-- ["hello","world","!!!"] 876beside :: (Representable q, Applicative (Rep q), Applicative f, Bitraversable r) 877 => Optical p q f s t a b 878 -> Optical p q f s' t' a b 879 -> Optical p q f (r s s') (r t t') a b 880beside l r f = tabulate $ getCompose #. bitraverse (Compose #. sieve (l f)) (Compose #. sieve (r f)) 881{-# INLINE beside #-} 882 883-- | Visit the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'. 884-- 885-- >>> [("hello","world"),("!!!","!!!")]^.. taking 2 (traverse.both) 886-- ["hello","world"] 887-- 888-- >>> timingOut $ [1..] ^.. taking 3 traverse 889-- [1,2,3] 890-- 891-- >>> over (taking 5 traverse) succ "hello world" 892-- "ifmmp world" 893-- 894-- @ 895-- 'taking' :: 'Int' -> 'Traversal'' s a -> 'Traversal'' s a 896-- 'taking' :: 'Int' -> 'Lens'' s a -> 'Traversal'' s a 897-- 'taking' :: 'Int' -> 'Iso'' s a -> 'Traversal'' s a 898-- 'taking' :: 'Int' -> 'Prism'' s a -> 'Traversal'' s a 899-- 'taking' :: 'Int' -> 'Getter' s a -> 'Fold' s a 900-- 'taking' :: 'Int' -> 'Fold' s a -> 'Fold' s a 901-- 'taking' :: 'Int' -> 'IndexedTraversal'' i s a -> 'IndexedTraversal'' i s a 902-- 'taking' :: 'Int' -> 'IndexedLens'' i s a -> 'IndexedTraversal'' i s a 903-- 'taking' :: 'Int' -> 'IndexedGetter' i s a -> 'IndexedFold' i s a 904-- 'taking' :: 'Int' -> 'IndexedFold' i s a -> 'IndexedFold' i s a 905-- @ 906taking :: (Conjoined p, Applicative f) 907 => Int 908 -> Traversing p f s t a a 909 -> Over p f s t a a 910taking n l = conjoined 911 (\ afb s -> let b = inline l sell s in outs b <$> traverse afb (take n $ ins b)) 912 (\ pafb s -> let b = inline l sell s in outs b <$> traverse (cosieve pafb) (take n $ pins b)) 913{-# INLINE taking #-} 914 915-- | Visit all but the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'. 916-- 917-- >>> ("hello","world") ^? dropping 1 both 918-- Just "world" 919-- 920-- Dropping works on infinite traversals as well: 921-- 922-- >>> [1..] ^? dropping 1 folded 923-- Just 2 924-- 925-- @ 926-- 'dropping' :: 'Int' -> 'Traversal'' s a -> 'Traversal'' s a 927-- 'dropping' :: 'Int' -> 'Lens'' s a -> 'Traversal'' s a 928-- 'dropping' :: 'Int' -> 'Iso'' s a -> 'Traversal'' s a 929-- 'dropping' :: 'Int' -> 'Prism'' s a -> 'Traversal'' s a 930-- 'dropping' :: 'Int' -> 'Getter' s a -> 'Fold' s a 931-- 'dropping' :: 'Int' -> 'Fold' s a -> 'Fold' s a 932-- 'dropping' :: 'Int' -> 'IndexedTraversal'' i s a -> 'IndexedTraversal'' i s a 933-- 'dropping' :: 'Int' -> 'IndexedLens'' i s a -> 'IndexedTraversal'' i s a 934-- 'dropping' :: 'Int' -> 'IndexedGetter' i s a -> 'IndexedFold' i s a 935-- 'dropping' :: 'Int' -> 'IndexedFold' i s a -> 'IndexedFold' i s a 936-- @ 937dropping :: (Conjoined p, Applicative f) => Int -> Over p (Indexing f) s t a a -> Over p f s t a a 938dropping n l pafb s = snd $ runIndexing (l paifb s) 0 where 939 paifb = cotabulate $ \wa -> Indexing $ \i -> let i' = i + 1 in i' `seq` (i', if i < n then pure (extract wa) else cosieve pafb wa) 940{-# INLINE dropping #-} 941 942------------------------------------------------------------------------------ 943-- Cloning Traversals 944------------------------------------------------------------------------------ 945 946-- | A 'Traversal' is completely characterized by its behavior on a 'Bazaar'. 947-- 948-- Cloning a 'Traversal' is one way to make sure you aren't given 949-- something weaker, such as a 'Fold' and can be 950-- used as a way to pass around traversals that have to be monomorphic in @f@. 951-- 952-- Note: This only accepts a proper 'Traversal' (or 'Lens'). To clone a 'Lens' 953-- as such, use 'Control.Lens.Lens.cloneLens'. 954-- 955-- Note: It is usually better to use 'Control.Lens.Reified.ReifiedTraversal' and 956-- 'Control.Lens.Reified.runTraversal' than to 'cloneTraversal'. The 957-- former can execute at full speed, while the latter needs to round trip through 958-- the 'Bazaar'. 959-- 960-- >>> let foo l a = (view (getting (cloneTraversal l)) a, set (cloneTraversal l) 10 a) 961-- >>> foo both ("hello","world") 962-- ("helloworld",(10,10)) 963-- 964-- @ 965-- 'cloneTraversal' :: 'LensLike' ('Bazaar' (->) a b) s t a b -> 'Traversal' s t a b 966-- @ 967cloneTraversal :: ATraversal s t a b -> Traversal s t a b 968cloneTraversal l f = bazaar f . l sell 969{-# INLINE cloneTraversal #-} 970 971-- | Clone a 'Traversal' yielding an 'IndexPreservingTraversal' that passes through 972-- whatever index it is composed with. 973cloneIndexPreservingTraversal :: ATraversal s t a b -> IndexPreservingTraversal s t a b 974cloneIndexPreservingTraversal l pafb = cotabulate $ \ws -> runBazaar (l sell (extract ws)) $ \a -> cosieve pafb (a <$ ws) 975{-# INLINE cloneIndexPreservingTraversal #-} 976 977-- | Clone an 'IndexedTraversal' yielding an 'IndexedTraversal' with the same index. 978cloneIndexedTraversal :: AnIndexedTraversal i s t a b -> IndexedTraversal i s t a b 979cloneIndexedTraversal l f = bazaar (Indexed (indexed f)) . l sell 980{-# INLINE cloneIndexedTraversal #-} 981 982-- | A 'Traversal1' is completely characterized by its behavior on a 'Bazaar1'. 983cloneTraversal1 :: ATraversal1 s t a b -> Traversal1 s t a b 984cloneTraversal1 l f = bazaar1 f . l sell 985{-# INLINE cloneTraversal1 #-} 986 987-- | Clone a 'Traversal1' yielding an 'IndexPreservingTraversal1' that passes through 988-- whatever index it is composed with. 989cloneIndexPreservingTraversal1 :: ATraversal1 s t a b -> IndexPreservingTraversal1 s t a b 990cloneIndexPreservingTraversal1 l pafb = cotabulate $ \ws -> runBazaar1 (l sell (extract ws)) $ \a -> cosieve pafb (a <$ ws) 991{-# INLINE cloneIndexPreservingTraversal1 #-} 992 993-- | Clone an 'IndexedTraversal1' yielding an 'IndexedTraversal1' with the same index. 994cloneIndexedTraversal1 :: AnIndexedTraversal1 i s t a b -> IndexedTraversal1 i s t a b 995cloneIndexedTraversal1 l f = bazaar1 (Indexed (indexed f)) . l sell 996{-# INLINE cloneIndexedTraversal1 #-} 997 998------------------------------------------------------------------------------ 999-- Indexed Traversals 1000------------------------------------------------------------------------------ 1001 1002-- | Traversal with an index. 1003-- 1004-- /NB:/ When you don't need access to the index then you can just apply your 'IndexedTraversal' 1005-- directly as a function! 1006-- 1007-- @ 1008-- 'itraverseOf' ≡ 'Control.Lens.Indexed.withIndex' 1009-- 'Control.Lens.Traversal.traverseOf' l = 'itraverseOf' l '.' 'const' = 'id' 1010-- @ 1011-- 1012-- @ 1013-- 'itraverseOf' :: 'Functor' f => 'IndexedLens' i s t a b -> (i -> a -> f b) -> s -> f t 1014-- 'itraverseOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> (i -> a -> f b) -> s -> f t 1015-- 'itraverseOf' :: 'Apply' f => 'IndexedTraversal1' i s t a b -> (i -> a -> f b) -> s -> f t 1016-- @ 1017itraverseOf :: (Indexed i a (f b) -> s -> f t) -> (i -> a -> f b) -> s -> f t 1018itraverseOf l = l .# Indexed 1019{-# INLINE itraverseOf #-} 1020 1021-- | Traverse with an index (and the arguments flipped). 1022-- 1023-- @ 1024-- 'Control.Lens.Traversal.forOf' l a ≡ 'iforOf' l a '.' 'const' 1025-- 'iforOf' ≡ 'flip' '.' 'itraverseOf' 1026-- @ 1027-- 1028-- @ 1029-- 'iforOf' :: 'Functor' f => 'IndexedLens' i s t a b -> s -> (i -> a -> f b) -> f t 1030-- 'iforOf' :: 'Applicative' f => 'IndexedTraversal' i s t a b -> s -> (i -> a -> f b) -> f t 1031-- 'iforOf' :: 'Apply' f => 'IndexedTraversal1' i s t a b -> s -> (i -> a -> f b) -> f t 1032-- @ 1033iforOf :: (Indexed i a (f b) -> s -> f t) -> s -> (i -> a -> f b) -> f t 1034iforOf = flip . itraverseOf 1035{-# INLINE iforOf #-} 1036 1037-- | Map each element of a structure targeted by a 'Lens' to a monadic action, 1038-- evaluate these actions from left to right, and collect the results, with access 1039-- its position. 1040-- 1041-- When you don't need access to the index 'mapMOf' is more liberal in what it can accept. 1042-- 1043-- @ 1044-- 'Control.Lens.Traversal.mapMOf' l ≡ 'imapMOf' l '.' 'const' 1045-- @ 1046-- 1047-- @ 1048-- 'imapMOf' :: 'Monad' m => 'IndexedLens' i s t a b -> (i -> a -> m b) -> s -> m t 1049-- 'imapMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> (i -> a -> m b) -> s -> m t 1050-- 'imapMOf' :: 'Bind' m => 'IndexedTraversal1' i s t a b -> (i -> a -> m b) -> s -> m t 1051-- @ 1052imapMOf :: Over (Indexed i) (WrappedMonad m) s t a b -> (i -> a -> m b) -> s -> m t 1053imapMOf l cmd = unwrapMonad #. l (WrapMonad #. Indexed cmd) 1054{-# INLINE imapMOf #-} 1055 1056-- | Map each element of a structure targeted by a 'Lens' to a monadic action, 1057-- evaluate these actions from left to right, and collect the results, with access 1058-- its position (and the arguments flipped). 1059-- 1060-- @ 1061-- 'Control.Lens.Traversal.forMOf' l a ≡ 'iforMOf' l a '.' 'const' 1062-- 'iforMOf' ≡ 'flip' '.' 'imapMOf' 1063-- @ 1064-- 1065-- @ 1066-- 'iforMOf' :: 'Monad' m => 'IndexedLens' i s t a b -> s -> (i -> a -> m b) -> m t 1067-- 'iforMOf' :: 'Monad' m => 'IndexedTraversal' i s t a b -> s -> (i -> a -> m b) -> m t 1068-- @ 1069iforMOf :: (Indexed i a (WrappedMonad m b) -> s -> WrappedMonad m t) -> s -> (i -> a -> m b) -> m t 1070iforMOf = flip . imapMOf 1071{-# INLINE iforMOf #-} 1072 1073-- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'IndexedTraversal' with access to the index. 1074-- 1075-- 'imapAccumROf' accumulates state from right to left. 1076-- 1077-- @ 1078-- 'Control.Lens.Traversal.mapAccumROf' l ≡ 'imapAccumROf' l '.' 'const' 1079-- @ 1080-- 1081-- @ 1082-- 'imapAccumROf' :: 'IndexedLens' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 1083-- 'imapAccumROf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 1084-- @ 1085imapAccumROf :: Over (Indexed i) (Backwards (State acc)) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 1086imapAccumROf = imapAccumLOf . backwards 1087{-# INLINE imapAccumROf #-} 1088 1089-- | Generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'IndexedTraversal' with access to the index. 1090-- 1091-- 'imapAccumLOf' accumulates state from left to right. 1092-- 1093-- @ 1094-- 'Control.Lens.Traversal.mapAccumLOf' l ≡ 'imapAccumLOf' l '.' 'const' 1095-- @ 1096-- 1097-- @ 1098-- 'imapAccumLOf' :: 'IndexedLens' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 1099-- 'imapAccumLOf' :: 'IndexedTraversal' i s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 1100-- @ 1101imapAccumLOf :: Over (Indexed i) (State acc) s t a b -> (i -> acc -> a -> (acc, b)) -> acc -> s -> (acc, t) 1102imapAccumLOf l f acc0 s = swap (runState (l (Indexed g) s) acc0) where 1103 g i a = state $ \acc -> swap (f i acc a) 1104{-# INLINE imapAccumLOf #-} 1105 1106------------------------------------------------------------------------------ 1107-- Common Indexed Traversals 1108------------------------------------------------------------------------------ 1109 1110-- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. 1111traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b 1112traversed = conjoined traverse (indexing traverse) 1113{-# INLINE [0] traversed #-} 1114 1115imapList :: (Int -> a -> b) -> [a] -> [b] 1116imapList f = go 0 1117 where 1118 go i (x:xs) = f i x : go (i+1) xs 1119 go _ [] = [] 1120{-# INLINE imapList #-} 1121 1122{-# RULES 1123"traversed -> mapped" traversed = sets fmap :: Functor f => ASetter (f a) (f b) a b; 1124"traversed -> folded" traversed = folded :: Foldable f => Getting (Endo r) (f a) a; 1125"traversed -> ifolded" traversed = folded :: Foldable f => IndexedGetting Int (Endo r) (f a) a; 1126"traversed -> imapList" traversed = isets imapList :: AnIndexedSetter Int [a] [b] a b; 1127"traversed -> imapSeq" traversed = isets mapWithIndex :: AnIndexedSetter Int (Seq a) (Seq b) a b; 1128"traversed -> imapVector" traversed = isets Vector.imap :: AnIndexedSetter Int (Vector a) (Vector b) a b; 1129 #-} 1130 1131-- | Traverse any 'Traversable1' container. This is an 'IndexedTraversal1' that is indexed by ordinal position. 1132traversed1 :: Traversable1 f => IndexedTraversal1 Int (f a) (f b) a b 1133traversed1 = conjoined traverse1 (indexing traverse1) 1134{-# INLINE traversed1 #-} 1135 1136-- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. 1137traversed64 :: Traversable f => IndexedTraversal Int64 (f a) (f b) a b 1138traversed64 = conjoined traverse (indexing64 traverse) 1139{-# INLINE traversed64 #-} 1140 1141-- | This is the trivial empty 'Traversal'. 1142-- 1143-- @ 1144-- 'ignored' :: 'IndexedTraversal' i s s a b 1145-- @ 1146-- 1147-- @ 1148-- 'ignored' ≡ 'const' 'pure' 1149-- @ 1150-- 1151-- >>> 6 & ignored %~ absurd 1152-- 6 1153ignored :: Applicative f => pafb -> s -> f s 1154ignored _ = pure 1155{-# INLINE ignored #-} 1156 1157-- | Allows 'IndexedTraversal' the value at the smallest index. 1158class Ord k => TraverseMin k m | m -> k where 1159 -- | 'IndexedTraversal' of the element with the smallest index. 1160 traverseMin :: IndexedTraversal' k (m v) v 1161 1162instance TraverseMin Int IntMap.IntMap where 1163 traverseMin f m = case IntMap.minViewWithKey m of 1164#if MIN_VERSION_containers(0,5,0) 1165 Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const (Just v)) m 1166#else 1167 Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMin (const v) m 1168#endif 1169 Nothing -> pure m 1170 {-# INLINE traverseMin #-} 1171 1172instance Ord k => TraverseMin k (Map k) where 1173 traverseMin f m = case Map.minViewWithKey m of 1174 Just ((k, a), _) -> indexed f k a <&> \v -> Map.updateMin (const (Just v)) m 1175 Nothing -> pure m 1176 {-# INLINE traverseMin #-} 1177 1178-- | Allows 'IndexedTraversal' of the value at the largest index. 1179class Ord k => TraverseMax k m | m -> k where 1180 -- | 'IndexedTraversal' of the element at the largest index. 1181 traverseMax :: IndexedTraversal' k (m v) v 1182 1183instance TraverseMax Int IntMap.IntMap where 1184 traverseMax f m = case IntMap.maxViewWithKey m of 1185#if MIN_VERSION_containers(0,5,0) 1186 Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const (Just v)) m 1187#else 1188 Just ((k,a), _) -> indexed f k a <&> \v -> IntMap.updateMax (const v) m 1189#endif 1190 Nothing -> pure m 1191 {-# INLINE traverseMax #-} 1192 1193instance Ord k => TraverseMax k (Map k) where 1194 traverseMax f m = case Map.maxViewWithKey m of 1195 Just ((k, a), _) -> indexed f k a <&> \v -> Map.updateMax (const (Just v)) m 1196 Nothing -> pure m 1197 {-# INLINE traverseMax #-} 1198 1199-- | Traverse the /nth/ 'elementOf' a 'Traversal', 'Lens' or 1200-- 'Iso' if it exists. 1201-- 1202-- >>> [[1],[3,4]] & elementOf (traverse.traverse) 1 .~ 5 1203-- [[1],[5,4]] 1204-- 1205-- >>> [[1],[3,4]] ^? elementOf (folded.folded) 1 1206-- Just 3 1207-- 1208-- >>> timingOut $ ['a'..] ^?! elementOf folded 5 1209-- 'f' 1210-- 1211-- >>> timingOut $ take 10 $ elementOf traverse 3 .~ 16 $ [0..] 1212-- [0,1,2,16,4,5,6,7,8,9] 1213-- 1214-- @ 1215-- 'elementOf' :: 'Traversal'' s a -> 'Int' -> 'IndexedTraversal'' 'Int' s a 1216-- 'elementOf' :: 'Fold' s a -> 'Int' -> 'IndexedFold' 'Int' s a 1217-- @ 1218elementOf :: Applicative f 1219 => LensLike (Indexing f) s t a a 1220 -> Int 1221 -> IndexedLensLike Int f s t a a 1222elementOf l p = elementsOf l (p ==) 1223{-# INLINE elementOf #-} 1224 1225-- | Traverse the /nth/ element of a 'Traversable' container. 1226-- 1227-- @ 1228-- 'element' ≡ 'elementOf' 'traverse' 1229-- @ 1230element :: Traversable t => Int -> IndexedTraversal' Int (t a) a 1231element = elementOf traverse 1232{-# INLINE element #-} 1233 1234-- | Traverse (or fold) selected elements of a 'Traversal' (or 'Fold') where their ordinal positions match a predicate. 1235-- 1236-- @ 1237-- 'elementsOf' :: 'Traversal'' s a -> ('Int' -> 'Bool') -> 'IndexedTraversal'' 'Int' s a 1238-- 'elementsOf' :: 'Fold' s a -> ('Int' -> 'Bool') -> 'IndexedFold' 'Int' s a 1239-- @ 1240elementsOf :: Applicative f 1241 => LensLike (Indexing f) s t a a 1242 -> (Int -> Bool) 1243 -> IndexedLensLike Int f s t a a 1244elementsOf l p iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, if p i then indexed iafb i a else pure a))) s) 0 1245{-# INLINE elementsOf #-} 1246 1247-- | Traverse elements of a 'Traversable' container where their ordinal positions match a predicate. 1248-- 1249-- @ 1250-- 'elements' ≡ 'elementsOf' 'traverse' 1251-- @ 1252elements :: Traversable t => (Int -> Bool) -> IndexedTraversal' Int (t a) a 1253elements = elementsOf traverse 1254{-# INLINE elements #-} 1255 1256-- | Try to map a function over this 'Traversal', failing if the 'Traversal' has no targets. 1257-- 1258-- >>> failover (element 3) (*2) [1,2] :: Maybe [Int] 1259-- Nothing 1260-- 1261-- >>> failover _Left (*2) (Right 4) :: Maybe (Either Int Int) 1262-- Nothing 1263-- 1264-- >>> failover _Right (*2) (Right 4) :: Maybe (Either Int Int) 1265-- Just (Right 8) 1266-- 1267-- @ 1268-- 'failover' :: Alternative m => Traversal s t a b -> (a -> b) -> s -> m t 1269-- @ 1270failover :: Alternative m => LensLike ((,) Any) s t a b -> (a -> b) -> s -> m t 1271failover l afb s = case l ((,) (Any True) . afb) s of 1272 (Any True, t) -> pure t 1273 (Any False, _) -> empty 1274{-# INLINE failover #-} 1275 1276-- | Try to map a function which uses the index over this 'IndexedTraversal', failing if the 'IndexedTraversal' has no targets. 1277-- 1278-- @ 1279-- 'ifailover' :: Alternative m => IndexedTraversal i s t a b -> (i -> a -> b) -> s -> m t 1280-- @ 1281ifailover :: Alternative m => Over (Indexed i) ((,) Any) s t a b -> (i -> a -> b) -> s -> m t 1282ifailover l iafb s = case l ((,) (Any True) `rmap` Indexed iafb) s of 1283 (Any True, t) -> pure t 1284 (Any False, _) -> empty 1285{-# INLINE ifailover #-} 1286 1287-- | Try the first 'Traversal' (or 'Fold'), falling back on the second 'Traversal' (or 'Fold') if it returns no entries. 1288-- 1289-- This is only a valid 'Traversal' if the second 'Traversal' is disjoint from the result of the first or returns 1290-- exactly the same results. These conditions are trivially met when given a 'Lens', 'Iso', 'Getter', 'Prism' or \"affine\" Traversal -- one that 1291-- has 0 or 1 target. 1292-- 1293-- Mutatis mutandis for 'Fold'. 1294-- 1295-- >>> [0,1,2,3] ^? failing (ix 1) (ix 2) 1296-- Just 1 1297-- 1298-- >>> [0,1,2,3] ^? failing (ix 42) (ix 2) 1299-- Just 2 1300-- 1301-- @ 1302-- 'failing' :: 'Traversal' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b 1303-- 'failing' :: 'Prism' s t a b -> 'Prism' s t a b -> 'Traversal' s t a b 1304-- 'failing' :: 'Fold' s a -> 'Fold' s a -> 'Fold' s a 1305-- @ 1306-- 1307-- These cases are also supported, trivially, but are boring, because the left hand side always succeeds. 1308-- 1309-- @ 1310-- 'failing' :: 'Lens' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b 1311-- 'failing' :: 'Iso' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b 1312-- 'failing' :: 'Equality' s t a b -> 'Traversal' s t a b -> 'Traversal' s t a b 1313-- 'failing' :: 'Getter' s a -> 'Fold' s a -> 'Fold' s a 1314-- @ 1315-- 1316-- If both of the inputs are indexed, the result is also indexed, so you can apply this to a pair of indexed 1317-- traversals or indexed folds, obtaining an indexed traversal or indexed fold. 1318-- 1319-- @ 1320-- 'failing' :: 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b 1321-- 'failing' :: 'IndexedFold' i s a -> 'IndexedFold' i s a -> 'IndexedFold' i s a 1322-- @ 1323-- 1324-- These cases are also supported, trivially, but are boring, because the left hand side always succeeds. 1325-- 1326-- @ 1327-- 'failing' :: 'IndexedLens' i s t a b -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b 1328-- 'failing' :: 'IndexedGetter' i s a -> 'IndexedGetter' i s a -> 'IndexedFold' i s a 1329-- @ 1330failing :: (Conjoined p, Applicative f) => Traversing p f s t a b -> Over p f s t a b -> Over p f s t a b 1331failing l r pafb s = case pins b of 1332 [] -> r pafb s 1333 _ -> bazaar pafb b 1334 where b = l sell s 1335 1336infixl 5 `failing` 1337 1338-- | Try the second traversal. If it returns no entries, try again with all entries from the first traversal, recursively. 1339-- 1340-- @ 1341-- 'deepOf' :: 'Fold' s s -> 'Fold' s a -> 'Fold' s a 1342-- 'deepOf' :: 'Traversal'' s s -> 'Traversal'' s a -> 'Traversal'' s a 1343-- 'deepOf' :: 'Traversal' s t s t -> 'Traversal' s t a b -> 'Traversal' s t a b 1344-- 'deepOf' :: 'Fold' s s -> 'IndexedFold' i s a -> 'IndexedFold' i s a 1345-- 'deepOf' :: 'Traversal' s t s t -> 'IndexedTraversal' i s t a b -> 'IndexedTraversal' i s t a b 1346-- @ 1347deepOf :: (Conjoined p, Applicative f) => LensLike f s t s t -> Traversing p f s t a b -> Over p f s t a b 1348deepOf r l = failing l (r . deepOf r l) 1349 1350-- | "Fuse" a 'Traversal' by reassociating all of the @('<*>')@ operations to the 1351-- left and fusing all of the 'fmap' calls into one. This is particularly 1352-- useful when constructing a 'Traversal' using operations from "GHC.Generics". 1353-- 1354-- Given a pair of 'Traversal's 'foo' and 'bar', 1355-- 1356-- @ 1357-- 'confusing' (foo.bar) = foo.bar 1358-- @ 1359-- 1360-- However, @foo@ and @bar@ are each going to use the 'Applicative' they are given. 1361-- 1362-- 'confusing' exploits the 'Yoneda' lemma to merge their separate uses of 'fmap' into a single 'fmap'. 1363-- and it further exploits an interesting property of the right Kan lift (or 'Curried') to left associate 1364-- all of the uses of @('<*>')@ to make it possible to fuse together more fmaps. 1365-- 1366-- This is particularly effective when the choice of functor 'f' is unknown at compile 1367-- time or when the 'Traversal' @foo.bar@ in the above description is recursive or complex 1368-- enough to prevent inlining. 1369-- 1370-- 'Control.Lens.Lens.fusing' is a version of this combinator suitable for fusing lenses. 1371-- 1372-- @ 1373-- 'confusing' :: 'Traversal' s t a b -> 'Traversal' s t a b 1374-- @ 1375confusing :: Applicative f => LensLike (Curried (Yoneda f) (Yoneda f)) s t a b -> LensLike f s t a b 1376confusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f) 1377 where 1378 liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) (Yoneda f) a 1379 liftCurriedYoneda fa = Curried (`yap` fa) 1380 {-# INLINE liftCurriedYoneda #-} 1381 1382 yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b 1383 yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa) 1384 {-# INLINE yap #-} 1385 1386{-# INLINE confusing #-} 1387 1388-- | Traverse a container using a specified 'Applicative'. 1389-- 1390-- This is like 'traverseBy' where the 'Traversable' instance can be specified by any 'Traversal' 1391-- 1392-- @ 1393-- 'traverseByOf' 'traverse' ≡ 'traverseBy' 1394-- @ 1395traverseByOf :: Traversal s t a b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> (a -> f b) -> s -> f t 1396traverseByOf l pur app f = reifyApplicative pur app (l (ReflectedApplicative #. f)) 1397 1398-- | Sequence a container using a specified 'Applicative'. 1399-- 1400-- This is like 'traverseBy' where the 'Traversable' instance can be specified by any 'Traversal' 1401-- 1402-- @ 1403-- 'sequenceByOf' 'traverse' ≡ 'sequenceBy' 1404-- @ 1405sequenceByOf :: Traversal s t (f b) b -> (forall x. x -> f x) -> (forall x y. f (x -> y) -> f x -> f y) -> s -> f t 1406sequenceByOf l pur app = reifyApplicative pur app (l ReflectedApplicative) 1407