packages feed

optics-core (empty) → 0.1

raw patch · 77 files changed

+10105/−0 lines, 77 filesdep +arraydep +basedep +containerssetup-changedbinary-added

Dependencies added: array, base, containers, transformers

Files

+ LICENSE view
@@ -0,0 +1,97 @@+Copyright (c) 2017-2019, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++This software incorporates code from the lens package (available from+https://hackage.haskell.org/package/lens) under the following license:+++Copyright 2012-2016 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+++This software incorporates code from the profunctors package (available from+https://hackage.haskell.org/package/profunctors) under the following license:++Copyright 2011-2015 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ diagrams/AffineFold.png view

binary file changed (absent → 30607 bytes)

+ diagrams/AffineTraversal.png view

binary file changed (absent → 30213 bytes)

+ diagrams/Fold.png view

binary file changed (absent → 30867 bytes)

+ diagrams/Getter.png view

binary file changed (absent → 28989 bytes)

+ diagrams/Iso.png view

binary file changed (absent → 31991 bytes)

+ diagrams/Lens.png view

binary file changed (absent → 29467 bytes)

+ diagrams/Prism.png view

binary file changed (absent → 29356 bytes)

+ diagrams/ReversedLens.png view

binary file changed (absent → 26733 bytes)

+ diagrams/ReversedPrism.png view

binary file changed (absent → 28707 bytes)

+ diagrams/Review.png view

binary file changed (absent → 27108 bytes)

+ diagrams/Setter.png view

binary file changed (absent → 29145 bytes)

+ diagrams/Traversal.png view

binary file changed (absent → 29464 bytes)

+ diagrams/reoptics.png view

binary file changed (absent → 24123 bytes)

+ optics-core.cabal view
@@ -0,0 +1,126 @@+name:          optics-core+version:       0.1+license:       BSD3+license-file:  LICENSE+build-type:    Simple+cabal-version: 1.24+maintainer:    optics@well-typed.com+author:        Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus+tested-with:   GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1, GHCJS ==8.4+synopsis:      Optics as an abstract interface: core definitions+category:      Data, Optics, Lenses+description:+  This package makes it possible to define and use Lenses, Traversals, Prisms+  and other optics, using an abstract interface.+  .+  This variant provides core definitions with a minimal dependency footprint.+  See the @optics@ package (and its dependencies) for documentation and the+  "batteries-included" variant.++extra-doc-files:+  diagrams/*.png++bug-reports:   https://github.com/well-typed/optics/issues+source-repository head+  type:     git+  location: https://github.com/well-typed/optics.git+  subdir:   optics-core++library+  default-language: Haskell2010+  hs-source-dirs:   src+  ghc-options:      -Wall++  build-depends: base                   >= 4.9        && <5+               , array                  >= 0.5.1.1    && <0.6+               , containers             >= 0.5.7.1    && <0.7+               , transformers           >= 0.5        && <0.6++  exposed-modules: Optics.Core++                   -- main optic type+                   Optics.Optic++                   -- optic kinds+                   Optics.AffineFold+                   Optics.AffineTraversal+                   Optics.Fold+                   Optics.Getter+                   Optics.Iso+                   Optics.IxAffineFold+                   Optics.IxAffineTraversal+                   Optics.IxFold+                   Optics.IxGetter+                   Optics.IxLens+                   Optics.IxSetter+                   Optics.IxTraversal+                   Optics.Lens+                   Optics.Prism+                   Optics.ReversedLens+                   Optics.ReversedPrism+                   Optics.Review+                   Optics.Setter+                   Optics.Traversal++                   -- optic utilities+                   Optics.Arrow+                   Optics.At.Core+                   Optics.Coerce+                   Optics.Cons.Core+                   Optics.Each.Core+                   Optics.Empty.Core+                   Optics.Indexed.Core+                   Optics.Label+                   Optics.Operators+                   Optics.Re+                   Optics.ReadOnly++                   -- optics for data types+                   Data.Either.Optics+                   Data.IntMap.Optics+                   Data.IntSet.Optics+                   Data.List.Optics+                   Data.Map.Optics+                   Data.Maybe.Optics+                   Data.Sequence.Optics+                   Data.Set.Optics+                   Data.Tree.Optics+                   Data.Tuple.Optics+                   Data.Typeable.Optics+                   GHC.Generics.Optics+                   Numeric.Optics++                   -- internal modules+                   Optics.Internal.Bi+                   Optics.Internal.Concrete+                   Optics.Internal.Fold+                   Optics.Internal.Indexed+                   Optics.Internal.IxFold+                   Optics.Internal.IxSetter+                   Optics.Internal.IxTraversal+                   Optics.Internal.Optic+                   Optics.Internal.Optic.Subtyping+                   Optics.Internal.Optic.TypeLevel+                   Optics.Internal.Optic.Types+                   Optics.Internal.Profunctor+                   Optics.Internal.Setter+                   Optics.Internal.Tagged+                   Optics.Internal.Traversal+                   Optics.Internal.Utils++  default-extensions: BangPatterns+                      DefaultSignatures+                      DeriveFunctor+                      FlexibleContexts+                      FlexibleInstances+                      FunctionalDependencies+                      GADTs+                      InstanceSigs+                      LambdaCase+                      MultiParamTypeClasses+                      RankNTypes+                      ScopedTypeVariables+                      TupleSections+                      TypeApplications+                      TypeFamilies+                      TypeOperators
+ src/Data/Either/Optics.hs view
@@ -0,0 +1,35 @@+-- | Module: Data.Either.Optics+-- Description: 'Prism's for the 'Either' datatype.+--+-- This module defines 'Prism's for the constructors of the 'Either' datatype.+module Data.Either.Optics+  ( _Left+  , _Right+  )+  where++import Optics.Prism++-- | A 'Prism' that matches on the 'Left' constructor of 'Either'.+_Left :: Prism (Either a b) (Either c b) a c+_Left =+  prism+    Left+    (\ x ->+      case x of+        Left y  -> Right y+        Right y -> Left (Right y)+    )+{-# INLINE _Left #-}++-- | A 'Prism' that matches on the 'Right' constructor of 'Either'.+_Right :: Prism (Either a b) (Either a c) b c+_Right =+  prism+    Right+    (\ x ->+      case x of+        Left y  -> Left (Left y)+        Right y -> Right y+    )+{-# INLINE _Right #-}
+ src/Data/IntMap/Optics.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP #-}+-- | 'IntMap' is an instance of 'Optics.At.Core.At' and provides+-- 'Optics.At.Core.at' as a lens on values at keys:+--+-- >>> IntMap.fromList [(1, "world")] ^. at 1+-- Just "world"+--+-- >>> IntMap.empty & at 1 .~ Just "world"+-- fromList [(1,"world")]+--+-- >>> IntMap.empty & at 0 .~ Just "hello"+-- fromList [(0,"hello")]+--+-- We can traverse, fold over, and map over key-value pairs in a 'IntMap',+-- thanks to indexed traversals, folds and setters.+--+-- >>> iover imapped const $ IntMap.fromList [(1, "Venus")]+-- fromList [(1,1)]+--+-- >>> ifoldMapOf ifolded (\i _ -> Sum i) $ IntMap.fromList [(2, "Earth"), (3, "Mars")]+-- Sum {getSum = 5}+--+-- >>> itraverseOf_ ifolded (curry print) $ IntMap.fromList [(4, "Jupiter")]+-- (4,"Jupiter")+--+-- >>> itoListOf ifolded $ IntMap.fromList [(5, "Saturn")]+-- [(5,"Saturn")]+--+-- A related class, 'Optics.At.Core.Ixed', allows us to use 'Optics.At.Core.ix' to+-- traverse a value at a particular key.+--+-- >>> IntMap.fromList [(2, "Earth")] & ix 2 %~ ("New " ++)+-- fromList [(2,"New Earth")]+--+-- >>> preview (ix 8) IntMap.empty+-- Nothing+--+module Data.IntMap.Optics+  ( toMapOf+  , lt+  , gt+  , le+  , ge+  ) where++import Data.IntMap as IntMap++import Optics.IxAffineTraversal+import Optics.IxFold+import Optics.Optic++-- | Construct a map from an 'IxFold'.+--+-- The construction is left-biased (see 'IntMap.union'), i.e. the first occurences of+-- keys in the fold or traversal order are preferred.+--+-- >>> toMapOf ifolded ["hello", "world"]+-- fromList [(0,"hello"),(1,"world")]+--+-- >>> toMapOf (folded % ifolded) [(1,"alpha"),(2, "beta")]+-- fromList [(1,"alpha"),(2,"beta")]+--+-- >>> toMapOf (icompose (\a b -> 10*a+b) $ ifolded % ifolded) ["foo", "bar"]+-- fromList [(0,'f'),(1,'o'),(2,'o'),(10,'b'),(11,'a'),(12,'r')]+--+-- >>> toMapOf (folded % ifolded) [(1, "hello"), (2, "world"), (1, "dummy")]+-- fromList [(1,"hello"),(2,"world")]+--+toMapOf+  :: (Is k A_Fold, is `HasSingleIndex` Int)+  => Optic' k is s a -> s -> IntMap a+toMapOf o = ifoldMapOf o IntMap.singleton+{-# INLINE toMapOf #-}++-- | Focus on the largest key smaller than the given one and its corresponding+-- value.+--+-- >>> IntMap.fromList [(1, "hi"), (2, "there")] & over (lt 2) (++ "!")+-- fromList [(1,"hi!"),(2,"there")]+--+-- >>> ipreview (lt 1) $ IntMap.fromList [(1, 'x'), (2, 'y')]+-- Nothing+lt :: Int -> IxAffineTraversal' Int (IntMap v) v+lt k = iatraversalVL $ \point f s ->+  case lookupLT k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s+{-# INLINE lt #-}++-- | Focus on the smallest key greater than the given one and its corresponding+-- value.+--+-- >>> IntMap.fromList [(1, "hi"), (2, "there")] & over (gt 2) (++ "!")+-- fromList [(1,"hi"),(2,"there")]+--+-- >>> ipreview (gt 1) $ IntMap.fromList [(1, 'x'), (2, 'y')]+-- Just (2,'y')+gt :: Int -> IxAffineTraversal' Int (IntMap v) v+gt k = iatraversalVL $ \point f s ->+  case lookupGT k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s+{-# INLINE gt #-}++-- | Focus on the largest key smaller or equal than the given one and its+-- corresponding value.+--+-- >>> IntMap.fromList [(1, "hi"), (2, "there")] & over (le 2) (++ "!")+-- fromList [(1,"hi"),(2,"there!")]+--+-- >>> ipreview (le 1) $ IntMap.fromList [(1, 'x'), (2, 'y')]+-- Just (1,'x')+le :: Int -> IxAffineTraversal' Int (IntMap v) v+le k = iatraversalVL $ \point f s ->+  case lookupLE k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s+{-# INLINE le #-}++-- | Focus on the smallest key greater or equal than the given one and its+-- corresponding value.+--+-- >>> IntMap.fromList [(1, "hi"), (3, "there")] & over (ge 2) (++ "!")+-- fromList [(1,"hi"),(3,"there!")]+--+-- >>> ipreview (ge 2) $ IntMap.fromList [(1, 'x'), (3, 'y')]+-- Just (3,'y')+ge :: Int -> IxAffineTraversal' Int (IntMap v) v+ge k = iatraversalVL $ \point f s ->+  case lookupGE k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s+{-# INLINE ge #-}++-- $setup+-- >>> import Data.Monoid+-- >>> import Optics.Core
+ src/Data/IntSet/Optics.hs view
@@ -0,0 +1,53 @@+-- |+-- Module: Data.IntSet.Optics+-- Description: Optics for working with 'IntSet's.+--+-- This module defines optics for constructing and manipulating finite 'IntSet's.+--+module Data.IntSet.Optics+  ( members+  , setmapped+  , setOf+  ) where++import Data.IntSet as IntSet++import Optics.Fold+import Optics.Optic+import Optics.Setter++-- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of+-- an 'IntSet'.+--+-- >>> sumOf members $ setOf folded [1,2,3,4]+-- 10+members :: Fold IntSet Int+members = folding IntSet.toAscList+{-# INLINE members #-}++-- | This 'Setter' can be used to change the type of a 'IntSet' by mapping the+-- elements to new values.+--+-- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for an 'IntSet',+-- but you can manipulate it by reading using 'Optics.Fold.folded' and+-- reindexing it via 'setmapped'.+--+-- >>> over setmapped (+1) (fromList [1,2,3,4])+-- fromList [2,3,4,5]+setmapped :: Setter' IntSet Int+setmapped = sets IntSet.map+{-# INLINE setmapped #-}++-- | Construct an 'IntSet' from a fold.+--+-- >>> setOf folded [1,2,3,4]+-- fromList [1,2,3,4]+--+-- >>> setOf (folded % _2) [("hello",1),("world",2),("!!!",3)]+-- fromList [1,2,3]+setOf :: Is k A_Fold => Optic' k is s Int -> s -> IntSet+setOf l = foldMapOf l IntSet.singleton+{-# INLINE setOf #-}++-- $setup+-- >>> import Optics.Core
+ src/Data/List/Optics.hs view
@@ -0,0 +1,123 @@+-- |+-- Module:  Data.List.Optics+-- Description: Traversals for manipulating parts of a list.+--+-- Additional optics for manipulating lists are present more generically in this+-- package.+--+-- The 'Optics.At.Core.Ixed' class allows traversing the element at a specific+-- list index.+--+-- >>> [0..10] ^? ix 4+-- Just 4+--+-- >>> [0..5] & ix 4 .~ 2+-- [0,1,2,3,2,5]+--+-- >>> [0..10] ^? ix 14+-- Nothing+--+-- >>> [0..5] & ix 14 .~ 2+-- [0,1,2,3,4,5]+--+-- The 'Optics.Cons.Core.Cons' and 'Optics.Empty.Core.AsEmpty' classes provide+-- 'Optics.Prism.Prism's for list constructors.+--+-- >>> [1..10] ^? _Cons+-- Just (1,[2,3,4,5,6,7,8,9,10])+--+-- >>> [] ^? _Cons+-- Nothing+--+-- >>> [] ^? _Empty+-- Just ()+--+-- >>> _Cons # (1, _Empty # ()) :: [Int]+-- [1]+--+-- Additionally, 'Optics.Cons.Core.Snoc' provides a 'Optics.Prism.Prism' for+-- accessing the end of a list. Note that this 'Optics.Prism.Prism' always will+-- need to traverse the whole list.+--+-- >>> [1..5] ^? _Snoc+-- Just ([1,2,3,4],5)+--+-- >>> _Snoc # ([1,2],5)+-- [1,2,5]+--+-- Finally, it's possible to traverse, fold over, and map over index-value pairs+-- thanks to instances of 'Optics.Indexed.Core.TraversableWithIndex',+-- 'Optics.Indexed.Core.FoldableWithIndex', and+-- 'Optics.Indexed.Core.FunctorWithIndex'.+--+-- >>> imap (,) "Hello"+-- [(0,'H'),(1,'e'),(2,'l'),(3,'l'),(4,'o')]+--+-- >>> ifoldMap replicate "Hello"+-- "ellllloooo"+--+-- >>> itraverse_ (curry print) "Hello"+-- (0,'H')+-- (1,'e')+-- (2,'l')+-- (3,'l')+-- (4,'o')+--+----------------------------------------------------------------------------+module Data.List.Optics+  ( prefixed+  , suffixed+  ) where++import Control.Monad (guard)+import Data.List++import Optics.Prism++-- | A 'Prism' stripping a prefix from a list when used as a+-- 'Optics.Traversal.Traversal', or prepending that prefix when run backwards:+--+-- >>> "preview" ^? prefixed "pre"+-- Just "view"+--+-- >>> "review" ^? prefixed "pre"+-- Nothing+--+-- >>> prefixed "pre" # "amble"+-- "preamble"+prefixed :: Eq a => [a] -> Prism' [a] [a]+prefixed ps = prism' (ps ++) (stripPrefix ps)+{-# INLINE prefixed #-}++-- | A 'Prism' stripping a suffix from a list when used as a+-- 'Optics.Traversal.Traversal', or appending that suffix when run backwards:+--+-- >>> "review" ^? suffixed "view"+-- Just "re"+--+-- >>> "review" ^? suffixed "tire"+-- Nothing+--+-- >>> suffixed ".o" # "hello"+-- "hello.o"+suffixed :: Eq a => [a] -> Prism' [a] [a]+suffixed qs = prism' (++ qs) (stripSuffix qs)+{-# INLINE suffixed #-}++----------------------------------------+-- Internal++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix qs xs0 = go xs0 zs+  where+    zs = drp qs xs0+    drp (_:ps) (_:xs) = drp ps xs+    drp [] xs = xs+    drp _  [] = []+    go (_:xs) (_:ys) = go xs ys+    go xs [] = zipWith const xs0 zs <$ guard (xs == qs)+    go [] _  = Nothing -- impossible+{-# INLINE stripSuffix #-}++-- $setup+-- >>> import Optics.Core
+ src/Data/Map/Optics.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: Data.Map.Optics+-- Description: Optics for working with 'Data.Map.Map's.+--+-- This module exists to provide documentation for lenses for working with+-- 'Map', which might otherwise be obscured by their genericity.+--+-- 'Map' is an instance of 'Optics.At.Core.At' and provides 'Optics.At.Core.at'+-- as a lens on values at keys:+--+-- >>> Map.fromList [(1, "world")] ^. at 1+-- Just "world"+--+-- >>> Map.empty & at 1 .~ Just "world"+-- fromList [(1,"world")]+--+-- >>> Map.empty & at 0 .~ Just "hello"+-- fromList [(0,"hello")]+--+-- We can traverse, fold over, and map over key-value pairs in a 'Map',+-- thanks to indexed traversals, folds and setters.+--+-- >>> iover imapped const $ Map.fromList [(1, "Venus")]+-- fromList [(1,1)]+--+-- >>> ifoldMapOf ifolded (\i _ -> Sum i) $ Map.fromList [(2, "Earth"), (3, "Mars")]+-- Sum {getSum = 5}+--+-- >>> itraverseOf_ ifolded (curry print) $ Map.fromList [(4, "Jupiter")]+-- (4,"Jupiter")+--+-- >>> itoListOf ifolded $ Map.fromList [(5, "Saturn")]+-- [(5,"Saturn")]+--+-- A related class, 'Optics.At.Core.Ixed', allows us to use 'Optics.At.Core.ix' to+-- traverse a value at a particular key.+--+-- >>> Map.fromList [(2, "Earth")] & ix 2 %~ ("New " ++)+-- fromList [(2,"New Earth")]+--+-- >>> preview (ix 8) Map.empty+-- Nothing+--+module Data.Map.Optics+  ( toMapOf+  , lt+  , gt+  , le+  , ge+  ) where++import Data.Map as Map++import Optics.IxAffineTraversal+import Optics.IxFold+import Optics.Optic++-- | Construct a map from an 'IxFold'.+--+-- The construction is left-biased (see 'Map.union'), i.e. the first+-- occurences of keys in the fold or traversal order are preferred.+--+-- >>> toMapOf ifolded ["hello", "world"]+-- fromList [(0,"hello"),(1,"world")]+--+-- >>> toMapOf (folded % ifolded) [('a',"alpha"),('b', "beta")]+-- fromList [('a',"alpha"),('b',"beta")]+--+-- >>> toMapOf (ifolded <%> ifolded) ["foo", "bar"]+-- fromList [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')]+--+-- >>> toMapOf (folded % ifolded) [('a', "hello"), ('b', "world"), ('a', "dummy")]+-- fromList [('a',"hello"),('b',"world")]+--+toMapOf+  :: (Is k A_Fold, is `HasSingleIndex` i, Ord i)+  => Optic' k is s a -> s -> Map i a+toMapOf o = ifoldMapOf o Map.singleton+{-# INLINE toMapOf #-}++-- | Focus on the largest key smaller than the given one and its corresponding+-- value.+--+-- >>> Map.fromList [('a', "hi"), ('b', "there")] & over (lt 'b') (++ "!")+-- fromList [('a',"hi!"),('b',"there")]+--+-- >>> ipreview (lt 'a') $ Map.fromList [('a', 'x'), ('b', 'y')]+-- Nothing+lt :: Ord k => k -> IxAffineTraversal' k (Map k v) v+lt k = iatraversalVL $ \point f s ->+  case lookupLT k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s+{-# INLINE lt #-}++-- | Focus on the smallest key greater than the given one and its corresponding+-- value.+--+-- >>> Map.fromList [('a', "hi"), ('b', "there")] & over (gt 'b') (++ "!")+-- fromList [('a',"hi"),('b',"there")]+--+-- >>> ipreview (gt 'a') $ Map.fromList [('a', 'x'), ('b', 'y')]+-- Just ('b','y')+gt :: Ord k => k -> IxAffineTraversal' k (Map k v) v+gt k = iatraversalVL $ \point f s ->+  case lookupGT k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s+{-# INLINE gt #-}++-- | Focus on the largest key smaller or equal than the given one and its+-- corresponding value.+--+-- >>> Map.fromList [('a', "hi"), ('b', "there")] & over (le 'b') (++ "!")+-- fromList [('a',"hi"),('b',"there!")]+--+-- >>> ipreview (le 'a') $ Map.fromList [('a', 'x'), ('b', 'y')]+-- Just ('a','x')+le :: Ord k => k -> IxAffineTraversal' k (Map k v) v+le k = iatraversalVL $ \point f s ->+  case lookupLE k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s+{-# INLINE le #-}++-- | Focus on the smallest key greater or equal than the given one and its+-- corresponding value.+--+-- >>> Map.fromList [('a', "hi"), ('c', "there")] & over (ge 'b') (++ "!")+-- fromList [('a',"hi"),('c',"there!")]+--+-- >>> ipreview (ge 'b') $ Map.fromList [('a', 'x'), ('c', 'y')]+-- Just ('c','y')+ge :: Ord k => k -> IxAffineTraversal' k (Map k v) v+ge k = iatraversalVL $ \point f s ->+  case lookupGE k s of+    Nothing      -> point s+    Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s+{-# INLINE ge #-}++-- $setup+-- >>> import Data.Monoid+-- >>> import Optics.Core
+ src/Data/Maybe/Optics.hs view
@@ -0,0 +1,36 @@+-- |+-- Module: Data.Maybe.Optics+-- Description: 'Prism's for the 'Maybe' datatype.+--+-- This module defines 'Prism's for the constructors of the 'Maybe' datatype.+module Data.Maybe.Optics+  ( _Nothing+  , _Just+  )+  where++import Optics.Prism++-- | A 'Prism' that matches on the 'Nothing' constructor of 'Maybe'.+_Nothing :: Prism' (Maybe a) ()+_Nothing =+  prism+    (\ () -> Nothing)+    (\ x ->+      case x of+        Nothing -> Right ()+        Just y  -> Left (Just y)+    )+{-# INLINE _Nothing #-}++-- | A 'Prism' that matches on the 'Just' constructor of 'Maybe'.+_Just :: Prism (Maybe a) (Maybe b) a b+_Just =+  prism+    Just+    (\ x ->+      case x of+        Nothing -> Left Nothing+        Just y  -> Right y+    )+{-# INLINE _Just #-}
+ src/Data/Sequence/Optics.hs view
@@ -0,0 +1,140 @@+-- |+-- Module:  Data.Sequence.Optics+-- Description: Optics for working with 'Seq's.+--+-- This module defines optics for constructing and manipulating finite 'Seq's.+--+module Data.Sequence.Optics+  ( viewL, viewR+  , sliced, slicedTo, slicedFrom+  , seqOf+  ) where++import Data.Sequence as Seq++import Optics.Internal.Indexed+import Optics.Fold+import Optics.Iso+import Optics.IxTraversal+import Optics.Optic+import Optics.Traversal++-- * Sequence isomorphisms++-- | A 'Seq' is isomorphic to a 'ViewL'+--+-- @'viewl' m ≡ m 'Optics.Operators.^.' 'viewL'@+--+-- >>> Seq.fromList [1,2,3] ^. viewL+-- 1 :< fromList [2,3]+--+-- >>> Seq.empty ^. viewL+-- EmptyL+--+-- >>> EmptyL ^. re viewL+-- fromList []+--+-- >>> review viewL $ 1 Seq.:< fromList [2,3]+-- fromList [1,2,3]+viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b)+viewL = iso viewl $ \xs -> case xs of+  EmptyL      -> mempty+  a Seq.:< as -> a Seq.<| as+{-# INLINE viewL #-}++-- | A 'Seq' is isomorphic to a 'ViewR'+--+-- @'viewr' m ≡ m 'Optics.Operators.^.' 'viewR'@+--+-- >>> Seq.fromList [1,2,3] ^. viewR+-- fromList [1,2] :> 3+--+-- >>> Seq.empty ^. viewR+-- EmptyR+--+-- >>> EmptyR ^. re viewR+-- fromList []+--+-- >>> review viewR $ fromList [1,2] Seq.:> 3+-- fromList [1,2,3]+viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b)+viewR = iso viewr $ \xs -> case xs of+  EmptyR      -> mempty+  as Seq.:> a -> as Seq.|> a+{-# INLINE viewR #-}++-- | Traverse the first @n@ elements of a 'Seq'+--+-- >>> fromList [1,2,3,4,5] ^.. slicedTo 2+-- [1,2]+--+-- >>> fromList [1,2,3,4,5] & slicedTo 2 %~ (*10)+-- fromList [10,20,3,4,5]+--+-- >>> fromList [1,2,4,5,6] & slicedTo 10 .~ 0+-- fromList [0,0,0,0,0]+slicedTo :: Int -> IxTraversal' Int (Seq a) a+slicedTo n = conjoined noix ix+  where+    noix = traversalVL $ \f m -> case Seq.splitAt n m of+      (l, r) -> (>< r) <$> traverse f l++    ix = itraversalVL $ \f m -> case Seq.splitAt n m of+      (l, r) -> (>< r) <$> itraverse f l+{-# INLINE slicedTo #-}++-- | Traverse all but the first @n@ elements of a 'Seq'+--+-- >>> fromList [1,2,3,4,5] ^.. slicedFrom 2+-- [3,4,5]+--+-- >>> fromList [1,2,3,4,5] & slicedFrom 2 %~ (*10)+-- fromList [1,2,30,40,50]+--+-- >>> fromList [1,2,3,4,5] & slicedFrom 10 .~ 0+-- fromList [1,2,3,4,5]+slicedFrom :: Int -> IxTraversal' Int (Seq a) a+slicedFrom n = conjoined noix ix+  where+    noix = traversalVL $ \f m -> case Seq.splitAt n m of+      (l, r) -> (l ><) <$> traverse f r++    ix = itraversalVL $ \f m -> case Seq.splitAt n m of+      (l, r) -> (l ><) <$> itraverse (f . (+n)) r+{-# INLINE slicedFrom #-}++-- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq'+--+-- >>> fromList [1,2,3,4,5] & sliced 1 3 %~ (*10)+-- fromList [1,20,30,4,5]+--+-- >>> fromList [1,2,3,4,5] ^.. sliced 1 3+-- [2,3]+--+-- >>> fromList [1,2,3,4,5] & sliced 1 3 .~ 0+-- fromList [1,0,0,4,5]+sliced :: Int -> Int -> IxTraversal' Int (Seq a) a+sliced i j = conjoined noix ix+  where+    noix = traversalVL $ \f s -> case Seq.splitAt i s of+      (l, mr) -> case Seq.splitAt (j-i) mr of+        (m, r) -> traverse f m <&> \n -> l >< n >< r++    ix = itraversalVL $ \f s -> case Seq.splitAt i s of+      (l, mr) -> case Seq.splitAt (j-i) mr of+        (m, r) -> itraverse (f . (+i)) m <&> \n -> l >< n >< r+{-# INLINE sliced #-}++-- | Construct a 'Seq' from a fold.+--+-- >>> seqOf folded ["hello","world"]+-- fromList ["hello","world"]+--+-- >>> seqOf (folded % _2) [("hello",1),("world",2),("!!!",3)]+-- fromList [1,2,3]+seqOf :: Is k A_Fold => Optic' k is s a -> s -> Seq a+seqOf l = foldMapOf l Seq.singleton+{-# INLINE seqOf #-}++-- $setup+-- >>> import Optics.Core
+ src/Data/Set/Optics.hs view
@@ -0,0 +1,43 @@+-- |+-- Module: Data.Set.Optics+-- Description: Optics for working with 'Set's.+--+-- This module defines optics for constructing and manipulating finite 'Set's.+--+module Data.Set.Optics+  ( setmapped+  , setOf+  ) where++import Data.Set as Set++import Optics.Fold+import Optics.Optic+import Optics.Setter++-- | This 'Setter' can be used to change the type of a 'Set' by mapping the+-- elements to new values.+--+-- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for a 'Set', but+-- you can manipulate it by reading using 'Optics.Fold.folded' and reindexing it+-- via 'setmapped'.+--+-- >>> over setmapped (+1) (fromList [1,2,3,4])+-- fromList [2,3,4,5]+setmapped :: Ord b => Setter (Set a) (Set b) a b+setmapped = sets Set.map+{-# INLINE setmapped #-}++-- | Construct a set from a fold.+--+-- >>> setOf folded ["hello","world"]+-- fromList ["hello","world"]+--+-- >>> setOf (folded % _2) [("hello",1),("world",2),("!!!",3)]+-- fromList [1,2,3]+setOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Set a+setOf l = foldMapOf l Set.singleton+{-# INLINE setOf #-}++-- $setup+-- >>> import Optics.Core
+ src/Data/Tree/Optics.hs view
@@ -0,0 +1,32 @@+-- |+-- Module: Data.Tree.Optics+-- Description: Optics for working with 'Tree's.+--+-- This module defines optics for manipulating 'Tree's.+--+module Data.Tree.Optics+  ( root+  , branches+  ) where++import Data.Tree++import Optics.Lens++-- | A 'Lens' that focuses on the root of a 'Tree'.+--+-- >>> view root $ Node 42 []+-- 42+root :: Lens' (Tree a) a+root = lensVL $ \f (Node a as) -> (`Node` as) <$> f a+{-# INLINE root #-}++-- | A 'Lens' returning the direct descendants of the root of a 'Tree'+--+-- @'Optics.Getter.view' 'branches' ≡ 'subForest'@+branches :: Lens' (Tree a) [Tree a]+branches = lensVL $ \f (Node a as) -> Node a <$> f as+{-# INLINE branches #-}++-- $setup+-- >>> import Optics.Core
+ src/Data/Tuple/Optics.hs view
@@ -0,0 +1,519 @@+-- |+-- Module: Data.Tuple.Optics+-- Description: 'Lens'es for tuple types.+--+-- This module defines 'Lens'es for the fields of tuple types.  These are+-- overloaded using the 'Field1' to 'Field9' typeclasses, so that '_1' can be+-- used as a 'Lens' for the first field of a tuple with any number of fields (up+-- to the maximum supported tuple size, which is currently 9).  For example:+--+-- >>> view _1 ('a','b','c')+-- 'a'+--+-- >>> set _3 True ('a','b','c')+-- ('a','b',True)+--+-- If a single-constructor datatype has a 'Generic' instance, the corresponding+-- @FieldN@ instances can be defined using their default methods:+--+-- >>> :set -XDeriveGeneric+-- >>> data T a = MkT Int a deriving (Generic, Show)+-- >>> instance Field1 (T a) (T a) Int Int+-- >>> instance Field2 (T a) (T b) a b+--+-- >>> set _2 'x' (MkT 1 False)+-- MkT 1 'x'+--+{-# LANGUAGE UndecidableInstances   #-}+module Data.Tuple.Optics+  (+  -- * Tuples+    Field1(..)+  , Field2(..)+  , Field3(..)+  , Field4(..)+  , Field5(..)+  , Field6(..)+  , Field7(..)+  , Field8(..)+  , Field9(..)+  -- * Strict variations+  , _1', _2', _3', _4', _5', _6', _7', _8', _9'+  ) where++import Data.Functor.Identity+import Data.Functor.Product+import Data.Proxy+import GHC.Generics ((:*:)(..), Generic(..), K1, M1, U1)++import GHC.Generics.Optics+import Optics.Lens+import Optics.Optic++-- | Provides access to 1st field of a tuple.+class Field1 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 1st field of a tuple (and possibly change its type).+  --+  -- >>> (1,2) ^. _1+  -- 1+  --+  -- >>> (1,2) & _1 .~ "hello"+  -- ("hello",2)+  --+  -- >>> traverseOf _1 putStrLn ("hello","world")+  -- hello+  -- ((),"world")+  --+  -- This can also be used on larger tuples as well:+  --+  -- >>> (1,2,3,4,5) & _1 %~ (+41)+  -- (42,2,3,4,5)+  _1 :: Lens s t a b+  default _1 :: (Generic s, Generic t, GIxed N0 (Rep s) (Rep t) a b)+             => Lens s t a b+  _1 = ix proxyN0+  {-# INLINE[1] _1 #-}++instance Field1 (Identity a) (Identity b) a b where+  _1 = lensVL $ \f (Identity a) -> Identity <$> f a+  {-# INLINE[1] _1 #-}++instance Field1 (Product f g a) (Product f' g a) (f a) (f' a) where+  _1 = lensVL $ \f ~(Pair a b) -> flip Pair b <$> f a+  {-# INLINE[1] _1 #-}++instance Field1 ((f :*: g) p) ((f' :*: g) p) (f p) (f' p) where+  _1 = lensVL $ \f ~(l :*: r) -> (:*: r) <$> f l+  {-# INLINE[1] _1 #-}++instance Field1 (a,b) (a',b) a a' where+  _1 = lensVL $ \k ~(a,b) -> k a <&> \a' -> (a',b)+  {-# INLINE[1] _1 #-}++instance Field1 (a,b,c) (a',b,c) a a' where+  _1 = lensVL $ \k ~(a,b,c) -> k a <&> \a' -> (a',b,c)+  {-# INLINE[1] _1 #-}++instance Field1 (a,b,c,d) (a',b,c,d) a a' where+  _1 = lensVL $ \k ~(a,b,c,d) -> k a <&> \a' -> (a',b,c,d)+  {-# INLINE[1] _1 #-}++instance Field1 (a,b,c,d,e) (a',b,c,d,e) a a' where+  _1 = lensVL $ \k ~(a,b,c,d,e) -> k a <&> \a' -> (a',b,c,d,e)+  {-# INLINE[1] _1 #-}++instance Field1 (a,b,c,d,e,f) (a',b,c,d,e,f) a a' where+  _1 = lensVL $ \k ~(a,b,c,d,e,f) -> k a <&> \a' -> (a',b,c,d,e,f)+  {-# INLINE[1] _1 #-}++instance Field1 (a,b,c,d,e,f,g) (a',b,c,d,e,f,g) a a' where+  _1 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k a <&> \a' -> (a',b,c,d,e,f,g)+  {-# INLINE[1] _1 #-}++instance Field1 (a,b,c,d,e,f,g,h) (a',b,c,d,e,f,g,h) a a' where+  _1 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k a <&> \a' -> (a',b,c,d,e,f,g,h)+  {-# INLINE[1] _1 #-}++instance Field1 (a,b,c,d,e,f,g,h,i) (a',b,c,d,e,f,g,h,i) a a' where+  _1 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k a <&> \a' -> (a',b,c,d,e,f,g,h,i)+  {-# INLINE[1] _1 #-}++-- | Provides access to the 2nd field of a tuple.+class Field2 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 2nd field of a tuple.+  --+  -- >>> _2 .~ "hello" $ (1,(),3,4)+  -- (1,"hello",3,4)+  --+  -- >>> (1,2,3,4) & _2 %~ (*3)+  -- (1,6,3,4)+  --+  -- >>> traverseOf _2 print (1,2)+  -- 2+  -- (1,())+  _2 :: Lens s t a b+  default _2 :: (Generic s, Generic t, GIxed N1 (Rep s) (Rep t) a b)+             => Lens s t a b+  _2 = ix proxyN1+  {-# INLINE[1] _2 #-}++instance Field2 (Product f g a) (Product f g' a) (g a) (g' a) where+  _2 = lensVL $ \f ~(Pair a b) -> Pair a <$> f b+  {-# INLINE[1] _2 #-}++instance Field2 ((f :*: g) p) ((f :*: g') p) (g p) (g' p) where+  _2 = lensVL $ \f ~(l :*: r) -> (l :*:) <$> f r+  {-# INLINE[1] _2 #-}++instance Field2 (a,b) (a,b') b b' where+  _2 = lensVL $ \k ~(a,b) -> k b <&> \b' -> (a,b')+  {-# INLINE[1] _2 #-}++instance Field2 (a,b,c) (a,b',c) b b' where+  _2 = lensVL $ \k ~(a,b,c) -> k b <&> \b' -> (a,b',c)+  {-# INLINE[1] _2 #-}++instance Field2 (a,b,c,d) (a,b',c,d) b b' where+  _2 = lensVL $ \k ~(a,b,c,d) -> k b <&> \b' -> (a,b',c,d)+  {-# INLINE[1] _2 #-}++instance Field2 (a,b,c,d,e) (a,b',c,d,e) b b' where+  _2 = lensVL $ \k ~(a,b,c,d,e) -> k b <&> \b' -> (a,b',c,d,e)+  {-# INLINE[1] _2 #-}++instance Field2 (a,b,c,d,e,f) (a,b',c,d,e,f) b b' where+  _2 = lensVL $ \k ~(a,b,c,d,e,f) -> k b <&> \b' -> (a,b',c,d,e,f)+  {-# INLINE[1] _2 #-}++instance Field2 (a,b,c,d,e,f,g) (a,b',c,d,e,f,g) b b' where+  _2 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k b <&> \b' -> (a,b',c,d,e,f,g)+  {-# INLINE[1] _2 #-}++instance Field2 (a,b,c,d,e,f,g,h) (a,b',c,d,e,f,g,h) b b' where+  _2 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k b <&> \b' -> (a,b',c,d,e,f,g,h)+  {-# INLINE[1] _2 #-}++instance Field2 (a,b,c,d,e,f,g,h,i) (a,b',c,d,e,f,g,h,i) b b' where+  _2 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k b <&> \b' -> (a,b',c,d,e,f,g,h,i)+  {-# INLINE[1] _2 #-}++-- | Provides access to the 3rd field of a tuple.+class Field3 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 3rd field of a tuple.+  _3 :: Lens s t a b+  default _3 :: (Generic s, Generic t, GIxed N2 (Rep s) (Rep t) a b)+             => Lens s t a b+  _3 = ix proxyN2+  {-# INLINE[1] _3 #-}++instance Field3 (a,b,c) (a,b,c') c c' where+  _3 = lensVL $ \k ~(a,b,c) -> k c <&> \c' -> (a,b,c')+  {-# INLINE[1] _3 #-}++instance Field3 (a,b,c,d) (a,b,c',d) c c' where+  _3 = lensVL $ \k ~(a,b,c,d) -> k c <&> \c' -> (a,b,c',d)+  {-# INLINE[1] _3 #-}++instance Field3 (a,b,c,d,e) (a,b,c',d,e) c c' where+  _3 = lensVL $ \k ~(a,b,c,d,e) -> k c <&> \c' -> (a,b,c',d,e)+  {-# INLINE[1] _3 #-}++instance Field3 (a,b,c,d,e,f) (a,b,c',d,e,f) c c' where+  _3 = lensVL $ \k ~(a,b,c,d,e,f) -> k c <&> \c' -> (a,b,c',d,e,f)+  {-# INLINE[1] _3 #-}++instance Field3 (a,b,c,d,e,f,g) (a,b,c',d,e,f,g) c c' where+  _3 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k c <&> \c' -> (a,b,c',d,e,f,g)+  {-# INLINE[1] _3 #-}++instance Field3 (a,b,c,d,e,f,g,h) (a,b,c',d,e,f,g,h) c c' where+  _3 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k c <&> \c' -> (a,b,c',d,e,f,g,h)+  {-# INLINE[1] _3 #-}++instance Field3 (a,b,c,d,e,f,g,h,i) (a,b,c',d,e,f,g,h,i) c c' where+  _3 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k c <&> \c' -> (a,b,c',d,e,f,g,h,i)+  {-# INLINE[1] _3 #-}++-- | Provide access to the 4th field of a tuple.+class Field4 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 4th field of a tuple.+  _4 :: Lens s t a b+  default _4 :: (Generic s, Generic t, GIxed N3 (Rep s) (Rep t) a b)+             => Lens s t a b+  _4 = ix proxyN3+  {-# INLINE[1] _4 #-}++instance Field4 (a,b,c,d) (a,b,c,d') d d' where+  _4 = lensVL $ \k ~(a,b,c,d) -> k d <&> \d' -> (a,b,c,d')+  {-# INLINE[1] _4 #-}++instance Field4 (a,b,c,d,e) (a,b,c,d',e) d d' where+  _4 = lensVL $ \k ~(a,b,c,d,e) -> k d <&> \d' -> (a,b,c,d',e)+  {-# INLINE[1] _4 #-}++instance Field4 (a,b,c,d,e,f) (a,b,c,d',e,f) d d' where+  _4 = lensVL $ \k ~(a,b,c,d,e,f) -> k d <&> \d' -> (a,b,c,d',e,f)+  {-# INLINE[1] _4 #-}++instance Field4 (a,b,c,d,e,f,g) (a,b,c,d',e,f,g) d d' where+  _4 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k d <&> \d' -> (a,b,c,d',e,f,g)+  {-# INLINE[1] _4 #-}++instance Field4 (a,b,c,d,e,f,g,h) (a,b,c,d',e,f,g,h) d d' where+  _4 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k d <&> \d' -> (a,b,c,d',e,f,g,h)+  {-# INLINE[1] _4 #-}++instance Field4 (a,b,c,d,e,f,g,h,i) (a,b,c,d',e,f,g,h,i) d d' where+  _4 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k d <&> \d' -> (a,b,c,d',e,f,g,h,i)+  {-# INLINE[1] _4 #-}++-- | Provides access to the 5th field of a tuple.+class Field5 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 5th field of a tuple.+  _5 :: Lens s t a b+  default _5 :: (Generic s, Generic t, GIxed N4 (Rep s) (Rep t) a b)+             => Lens s t a b+  _5 = ix proxyN4+  {-# INLINE[1] _5 #-}++instance Field5 (a,b,c,d,e) (a,b,c,d,e') e e' where+  _5 = lensVL $ \k ~(a,b,c,d,e) -> k e <&> \e' -> (a,b,c,d,e')+  {-# INLINE[1] _5 #-}++instance Field5 (a,b,c,d,e,f) (a,b,c,d,e',f) e e' where+  _5 = lensVL $ \k ~(a,b,c,d,e,f) -> k e <&> \e' -> (a,b,c,d,e',f)+  {-# INLINE[1] _5 #-}++instance Field5 (a,b,c,d,e,f,g) (a,b,c,d,e',f,g) e e' where+  _5 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k e <&> \e' -> (a,b,c,d,e',f,g)+  {-# INLINE[1] _5 #-}++instance Field5 (a,b,c,d,e,f,g,h) (a,b,c,d,e',f,g,h) e e' where+  _5 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k e <&> \e' -> (a,b,c,d,e',f,g,h)+  {-# INLINE[1] _5 #-}++instance Field5 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e',f,g,h,i) e e' where+  _5 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k e <&> \e' -> (a,b,c,d,e',f,g,h,i)+  {-# INLINE[1] _5 #-}++-- | Provides access to the 6th element of a tuple.+class Field6 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 6th field of a tuple.+  _6 :: Lens s t a b+  default _6 :: (Generic s, Generic t, GIxed N5 (Rep s) (Rep t) a b)+             => Lens s t a b+  _6 = ix proxyN5+  {-# INLINE[1] _6 #-}++instance Field6 (a,b,c,d,e,f) (a,b,c,d,e,f') f f' where+  _6 = lensVL $ \k ~(a,b,c,d,e,f) -> k f <&> \f' -> (a,b,c,d,e,f')+  {-# INLINE[1] _6 #-}++instance Field6 (a,b,c,d,e,f,g) (a,b,c,d,e,f',g) f f' where+  _6 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k f <&> \f' -> (a,b,c,d,e,f',g)+  {-# INLINE[1] _6 #-}++instance Field6 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f',g,h) f f' where+  _6 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k f <&> \f' -> (a,b,c,d,e,f',g,h)+  {-# INLINE[1] _6 #-}++instance Field6 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f',g,h,i) f f' where+  _6 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k f <&> \f' -> (a,b,c,d,e,f',g,h,i)+  {-# INLINE[1] _6 #-}++-- | Provide access to the 7th field of a tuple.+class Field7 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 7th field of a tuple.+  _7 :: Lens s t a b+  default _7 :: (Generic s, Generic t, GIxed N6 (Rep s) (Rep t) a b)+             => Lens s t a b+  _7 = ix proxyN6+  {-# INLINE[1] _7 #-}++instance Field7 (a,b,c,d,e,f,g) (a,b,c,d,e,f,g') g g' where+  _7 = lensVL $ \k ~(a,b,c,d,e,f,g) -> k g <&> \g' -> (a,b,c,d,e,f,g')+  {-# INLINE[1] _7 #-}++instance Field7 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g',h) g g' where+  _7 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k g <&> \g' -> (a,b,c,d,e,f,g',h)+  {-# INLINE[1] _7 #-}++instance Field7 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g',h,i) g g' where+  _7 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k g <&> \g' -> (a,b,c,d,e,f,g',h,i)+  {-# INLINE[1] _7 #-}++-- | Provide access to the 8th field of a tuple.+class Field8 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 8th field of a tuple.+  _8 :: Lens s t a b+  default _8 :: (Generic s, Generic t, GIxed N7 (Rep s) (Rep t) a b)+             => Lens s t a b+  _8 = ix proxyN7+  {-# INLINE[1] _8 #-}++instance Field8 (a,b,c,d,e,f,g,h) (a,b,c,d,e,f,g,h') h h' where+  _8 = lensVL $ \k ~(a,b,c,d,e,f,g,h) -> k h <&> \h' -> (a,b,c,d,e,f,g,h')+  {-# INLINE[1] _8 #-}++instance Field8 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h',i) h h' where+  _8 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k h <&> \h' -> (a,b,c,d,e,f,g,h',i)+  {-# INLINE[1] _8 #-}++-- | Provides access to the 9th field of a tuple.+class Field9 s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- | Access the 9th field of a tuple.+  _9 :: Lens s t a b+  default _9 :: (Generic s, Generic t, GIxed N8 (Rep s) (Rep t) a b)+             => Lens s t a b+  _9 = ix proxyN8+  {-# INLINE[1] _9 #-}++instance Field9 (a,b,c,d,e,f,g,h,i) (a,b,c,d,e,f,g,h,i') i i' where+  _9 = lensVL $ \k ~(a,b,c,d,e,f,g,h,i) -> k i <&> \i' -> (a,b,c,d,e,f,g,h,i')+  {-# INLINE[1] _9 #-}++-- Strict versions of the _1 .. _9 operations++-- | Strict version of '_1'+_1' :: Field1 s t a b => Lens s t a b+_1' = equality' % _1+{-# INLINE _1' #-}++-- | Strict version of '_2'+_2' :: Field2 s t a b => Lens s t a b+_2' = equality' % _2+{-# INLINE _2' #-}++-- | Strict version of '_3'+_3' :: Field3 s t a b => Lens s t a b+_3' = equality' % _3+{-# INLINE _3' #-}++-- | Strict version of '_4'+_4' :: Field4 s t a b => Lens s t a b+_4' = equality' % _4+{-# INLINE _4' #-}++-- | Strict version of '_5'+_5' :: Field5 s t a b => Lens s t a b+_5' = equality' % _5+{-# INLINE _5' #-}++-- | Strict version of '_6'+_6' :: Field6 s t a b => Lens s t a b+_6' = equality' % _6+{-# INLINE _6' #-}++-- | Strict version of '_7'+_7' :: Field7 s t a b => Lens s t a b+_7' = equality' % _7+{-# INLINE _7' #-}++-- | Strict version of '_8'+_8' :: Field8 s t a b => Lens s t a b+_8' = equality' % _8+{-# INLINE _8' #-}++-- | Strict version of '_9'+_9' :: Field9 s t a b => Lens s t a b+_9' = equality' % _9+{-# INLINE _9' #-}++ix :: (Generic s, Generic t, GIxed n (Rep s) (Rep t) a b) => f n -> Lens s t a b+ix n = generic % gix n+{-# INLINE ix #-}++-- TODO: this can be replaced by generic-optics position+type family GSize (f :: * -> *)+type instance GSize U1 = Z+type instance GSize (K1 i c) = S Z+type instance GSize (M1 i c f) = GSize f+type instance GSize (a :*: b) = Add (GSize a) (GSize b)++class GIxed n s t a b | n s -> a, n t -> b, n s b -> t, n t a -> s where+  gix :: f n -> Lens (s x) (t x) a b++instance GIxed N0 (K1 i a) (K1 i b) a b where+  gix _ = castOptic _K1+  {-# INLINE gix #-}++instance GIxed n s t a b => GIxed n (M1 i c s) (M1 i c t) a b where+  gix n = _M1 % gix n+  {-# INLINE gix #-}++instance (p ~ GT (GSize s) n,+          p ~ GT (GSize t) n,+          GIxed' p n s s' t t' a b)+      => GIxed n (s :*: s') (t :*: t') a b where+  gix = gix' (Proxy @p)+  {-# INLINE gix #-}++class (p ~ GT (GSize s) n,+       p ~ GT (GSize t) n)+   => GIxed' p n s s' t t' a b | p n s s' -> a+                               , p n t t' -> b+                               , p n s s' b -> t t'+                               , p n t t' a -> s s' where+  gix' :: f p -> g n -> Lens ((s :*: s') x) ((t :*: t') x) a b++instance (GT (GSize s) n ~ T,+          GT (GSize t) n ~ T,+          GIxed n s t a b)+      => GIxed' T n s s' t s' a b where+  gix' _ n = _1 % gix n+  {-# INLINE gix' #-}++instance (GT (GSize s) n ~ F,+          n' ~ Subtract (GSize s) n,+          GIxed n' s' t' a b)+      => GIxed' F n s s' s t' a b where+  gix' _ _ = _2 % gix (Proxy @n')+  {-# INLINE gix' #-}++data Z+data S a++data T+data F++type family Add x y+type instance Add Z y = y+type instance Add (S x) y = S (Add x y)++type family Subtract x y+type instance Subtract Z x = x+type instance Subtract (S x) (S y) = Subtract x y++type family GT x y+type instance GT Z x = F+type instance GT (S x) Z = T+type instance GT (S x) (S y) = GT x y++type N0 = Z+type N1 = S N0+type N2 = S N1+type N3 = S N2+type N4 = S N3+type N5 = S N4+type N6 = S N5+type N7 = S N6+type N8 = S N7++proxyN0 :: Proxy N0+proxyN0 = Proxy+{-# INLINE proxyN0 #-}++proxyN1 :: Proxy N1+proxyN1 = Proxy+{-# INLINE proxyN1 #-}++proxyN2 :: Proxy N2+proxyN2 = Proxy+{-# INLINE proxyN2 #-}++proxyN3 :: Proxy N3+proxyN3 = Proxy+{-# INLINE proxyN3 #-}++proxyN4 :: Proxy N4+proxyN4 = Proxy+{-# INLINE proxyN4 #-}++proxyN5 :: Proxy N5+proxyN5 = Proxy+{-# INLINE proxyN5 #-}++proxyN6 :: Proxy N6+proxyN6 = Proxy+{-# INLINE proxyN6 #-}++proxyN7 :: Proxy N7+proxyN7 = Proxy+{-# INLINE proxyN7 #-}++proxyN8 :: Proxy N8+proxyN8 = Proxy+{-# INLINE proxyN8 #-}++-- $setup+-- >>> import Optics.Core
+ src/Data/Typeable/Optics.hs view
@@ -0,0 +1,27 @@+-- |+-- Module: Data.Typeable.Optics+-- Description: Optics for working with 'Typeable'.+--+module Data.Typeable.Optics+  ( _cast+  , _gcast+  ) where++import Data.Typeable+import Data.Maybe++import Optics.AffineTraversal++-- | An 'AffineTraversal'' for working with a 'cast' of a 'Typeable' value.+_cast :: (Typeable s, Typeable a) => AffineTraversal' s a+_cast = atraversalVL $ \point f s -> case cast s of+  Just a  -> fromMaybe (error "_cast: recast failed") . cast <$> f a+  Nothing -> point s+{-# INLINE _cast #-}++-- | An 'AffineTraversal'' for working with a 'gcast' of a 'Typeable' value.+_gcast :: (Typeable s, Typeable a) => AffineTraversal' (c s) (c a)+_gcast = atraversalVL $ \point f s -> case gcast s of+  Just a  -> fromMaybe (error "_gcast: recast failed") . gcast <$> f a+  Nothing -> point s+{-# INLINE _gcast #-}
+ src/GHC/Generics/Optics.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE PolyKinds #-}+-- |+-- Module: GHC.Generics.Optics+-- Description: Optics for types defined in "GHC.Generics".+--+-- Note: "GHC.Generics" exports a number of names that collide with "Optics"+-- (at least 'GHC.Generics.to').+--+-- You can use hiding or imports to mitigate this to an extent, and the+-- following imports, represent a fair compromise for user code:+--+-- @+-- import "Optics"+-- import "GHC.Generics" hiding (to)+-- import "GHC.Generics.Optics"+-- @+--+-- You can use 'generic' to replace 'GHC.Generics.from' and 'GHC.Generics.to'+-- from "GHC.Generics".+--+module GHC.Generics.Optics+  ( generic+  , generic1+  , _V1+  , _U1+  , _Par1+  , _Rec1+  , _K1+  , _M1+  , _L1+  , _R1+  ) where++import qualified GHC.Generics as GHC (to, from, to1, from1)+import GHC.Generics (Generic, Rep, Generic1, Rep1, (:+:) (..), V1, U1 (..),+                     K1 (..), M1 (..), Par1 (..), Rec1 (..))++import Optics.Iso+import Optics.Lens+import Optics.Prism++-- | Convert from the data type to its representation (or back)+--+-- >>> view (generic % re generic) "hello" :: String+-- "hello"+--+generic :: (Generic a, Generic b) => Iso a b (Rep a c) (Rep b c)+generic = iso GHC.from GHC.to+{-# INLINE generic #-}++-- | Convert from the data type to its representation (or back)+generic1 :: Generic1 f => Iso (f a) (f b) (Rep1 f a) (Rep1 f b)+generic1 = iso GHC.from1 GHC.to1+{-# INLINE generic1 #-}++_V1 :: Lens (V1 s) (V1 t) a b+_V1 = lens absurd absurd where+  absurd !_a = undefined+{-# INLINE _V1 #-}++_U1 :: Iso (U1 p) (U1 q) () ()+_U1 = iso (const ()) (const U1)+{-# INLINE _U1 #-}++_Par1 :: Iso (Par1 p) (Par1 q) p q+_Par1 = iso unPar1 Par1+{-# INLINE _Par1 #-}++_Rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q)+_Rec1 = iso unRec1 Rec1+{-# INLINE _Rec1 #-}++_K1 :: Iso (K1 i c p) (K1 j d q) c d+_K1 = iso unK1 K1+{-# INLINE _K1 #-}++_M1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q)+_M1 = iso unM1 M1+{-# INLINE _M1 #-}++_L1 :: Prism ((a :+: c) t) ((b :+: c) t) (a t) (b t)+_L1 = prism L1 reviewer+  where+  reviewer (L1 v) = Right v+  reviewer (R1 v) = Left (R1 v)+{-# INLINE _L1 #-}++_R1 :: Prism ((c :+: a) t) ((c :+: b) t) (a t) (b t)+_R1 = prism R1 reviewer+  where+  reviewer (R1 v) = Right v+  reviewer (L1 v) = Left (L1 v)+{-# INLINE _R1 #-}++-- $setup+-- >>> import Optics.Core
+ src/Numeric/Optics.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module: Numeric.Optics+-- Description: Optics for working with numeric types.+--+module Numeric.Optics+  ( base+  , integral+    -- * Predefined bases+  , binary+  , octal+  , decimal+  , hex+    -- * Arithmetic lenses+  , adding+  , subtracting+  , multiplying+  , dividing+  , exponentiating+  , negated+  , pattern Integral+  ) where++import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit)+import Data.Maybe (fromMaybe)+import GHC.Stack+import Numeric (readInt, showIntAtBase)++import Data.Tuple.Optics+import Optics.AffineFold+import Optics.Iso+import Optics.Optic+import Optics.Prism+import Optics.Review+import Optics.Setter++-- | This 'Prism' can be used to model the fact that every 'Prelude.Integral'+-- type is a subset of 'Integer'.+--+-- Embedding through the 'Prism' only succeeds if the 'Integer' would pass+-- through unmodified when re-extracted.+integral :: (Integral a, Integral b) => Prism Integer Integer a b+integral = prism toInteger $ \i -> let a = fromInteger i in+  if toInteger a == i+  then Right a+  else Left i+{-# INLINE integral #-}++-- | Pattern synonym that can be used to construct or pattern match on an+-- 'Integer' as if it were of any 'Prelude.Integral' type.+pattern Integral :: forall a. Integral a => a -> Integer+pattern Integral a <- (preview integral -> Just a) where+  Integral a = review integral a++-- | A prism that shows and reads integers in base-2 through base-36+--+-- Note: This is an improper prism, since leading 0s are stripped when reading.+--+-- >>> "100" ^? base 16+-- Just 256+--+-- >>> 1767707668033969 ^. re (base 36)+-- "helloworld"+base :: (HasCallStack, Integral a) => Int -> Prism' String a+base b+  | b < 2 || b > 36 = error ("base: Invalid base " ++ show b)+  | otherwise       = prism intShow intRead+  where+    intShow n = showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) ""++    intRead s =+      case readSigned' (readInt (fromIntegral b) (isDigit' b) digitToInt') s of+        [(n,"")] -> Right n+        _ -> Left s+{-# INLINE base #-}++-- | Like 'Data.Char.intToDigit', but handles up to base-36+intToDigit' :: HasCallStack => Int -> Char+intToDigit' i+  | i >= 0  && i < 10 = chr (ord '0' + i)+  | i >= 10 && i < 36 = chr (ord 'a' + i - 10)+  | otherwise = error ("intToDigit': Invalid int " ++ show i)+{-# INLINE intToDigit' #-}++-- | Like 'Data.Char.digitToInt', but handles up to base-36+digitToInt' :: HasCallStack => Char -> Int+digitToInt' c = fromMaybe (error ("digitToInt': Invalid digit " ++ show c))+                          (digitToIntMay c)+{-# INLINE digitToInt' #-}++-- | A safe variant of 'digitToInt''+digitToIntMay :: Char -> Maybe Int+digitToIntMay c+  | isDigit c      = Just (ord c - ord '0')+  | isAsciiLower c = Just (ord c - ord 'a' + 10)+  | isAsciiUpper c = Just (ord c - ord 'A' + 10)+  | otherwise = Nothing+{-# INLINE digitToIntMay #-}++-- | Select digits that fall into the given base+isDigit' :: Int -> Char -> Bool+isDigit' b c = case digitToIntMay c of+  Just i -> i < b+  _ -> False+{-# INLINE isDigit' #-}++-- | A simpler variant of 'Numeric.showSigned' that only prepends a dash and+-- doesn't know about parentheses+showSigned' :: Real a => (a -> ShowS) -> a -> ShowS+showSigned' f n+  | n < 0     = showChar '-' . f (negate n)+  | otherwise = f n+{-# INLINE showSigned' #-}++-- | A simpler variant of 'Numeric.readSigned' that supports any base, only+-- recognizes an initial dash and doesn't know about parentheses+readSigned' :: Real a => ReadS a -> ReadS a+readSigned' f ('-':xs) = f xs <&> over _1 negate+readSigned' f xs       = f xs+{-# INLINE readSigned' #-}++-- | @'binary' = 'base' 2@+binary :: Integral a => Prism' String a+binary = base 2+{-# INLINE binary #-}++-- | @'octal' = 'base' 8@+octal :: Integral a => Prism' String a+octal = base 8+{-# INLINE octal #-}++-- | @'decimal' = 'base' 10@+decimal :: Integral a => Prism' String a+decimal = base 10+{-# INLINE decimal #-}++-- | @'hex' = 'base' 16@+hex :: Integral a => Prism' String a+hex = base 16+{-# INLINE hex #-}++-- | @'adding' n = 'iso' (+n) (subtract n)@+--+-- >>> [1..3] ^.. traversed % adding 1000+-- [1001,1002,1003]+adding :: Num a => a -> Iso' a a+adding n = iso (+n) (subtract n)+{-# INLINE adding #-}++-- | @+-- 'subtracting' n = 'iso' (subtract n) ((+n)+-- 'subtracting' n = 'Optics.Re.re' ('adding' n)+-- @+subtracting :: Num a => a -> Iso' a a+subtracting n = iso (subtract n) (+n)+{-# INLINE subtracting #-}++-- | @'multiplying' n = iso (*n) (/n)@+--+-- Note: This errors for n = 0+--+-- >>> 5 & multiplying 1000 %~ (+3)+-- 5.003+--+-- >>> let fahrenheit = multiplying (9/5) % adding 32 in 230 ^. re fahrenheit+-- 110.0+multiplying :: (Fractional a, Eq a) => a -> Iso' a a+multiplying 0 = error "Numeric.Optics.multiplying: factor 0"+multiplying n = iso (*n) (/n)+{-# INLINE multiplying #-}++-- | @+-- 'dividing' n = 'iso' (/n) (*n)+-- 'dividing' n = 'Optics.Re.re' ('multiplying' n)@+--+-- Note: This errors for n = 0+dividing :: (Fractional a, Eq a) => a -> Iso' a a+dividing 0 = error "Numeric.Optics.dividing: divisor 0"+dividing n = iso (/n) (*n)+{-# INLINE dividing #-}++-- | @'exponentiating' n = 'iso' (**n) (**recip n)@+--+-- Note: This errors for n = 0+--+-- >>> au (coerced1 @Sum % re (exponentiating 2)) (foldMapOf each) (3,4) == 5+-- True+exponentiating :: (Floating a, Eq a) => a -> Iso' a a+exponentiating 0 = error "Numeric.Optics.exponentiating: exponent 0"+exponentiating n = iso (**n) (**recip n)+{-# INLINE exponentiating #-}++-- | @'negated' = 'iso' 'negate' 'negate'@+--+-- >>> au (coerced1 @Sum % negated) (foldMapOf each) (3,4) == 7+-- True+--+-- >>> au (coerced1 @Sum) (foldMapOf (each % negated)) (3,4) == -7+-- True+negated :: Num a => Iso' a a+negated = iso negate negate+{-# INLINE negated #-}++-- $setup+-- >>> import Data.Monoid+-- >>> import Optics.Core
+ src/Optics/AffineFold.hs view
@@ -0,0 +1,114 @@+-- |+-- Module: Optics.AffineFold+-- Description: A 'Optics.Fold.Fold' that contains at most one element.+--+-- An 'AffineFold' is a 'Optics.Fold.Fold' that contains at most one+-- element, or a 'Optics.Getter.Getter' where the function may be+-- partial.+--+module Optics.AffineFold+  (+  -- * Formation+    AffineFold++  -- * Introduction+  , afolding++  -- * Elimination+  , preview+  , previews++  -- * Computation+  -- |+  --+  -- @+  -- 'preview' ('afolding' f) ≡ f+  -- @++  -- * Additional introduction forms+  , filtered++  -- * Additional elimination forms+  , isn't++    -- * Semigroup structure+  , afailing++  -- * Subtyping+  , An_AffineFold+  -- | <<diagrams/AffineFold.png AffineFold in the optics hierarchy>>+  ) where++import Data.Maybe++import Optics.Internal.Bi+import Optics.Internal.Profunctor+import Optics.Internal.Optic++-- | Type synonym for an affine fold.+type AffineFold s a = Optic' An_AffineFold NoIx s a++-- | Retrieve the value targeted by an 'AffineFold'.+--+-- >>> let _Right = prism Right $ either (Left . Left) Right+--+-- >>> preview _Right (Right 'x')+-- Just 'x'+--+-- >>> preview _Right (Left 'y')+-- Nothing+--+preview :: Is k An_AffineFold => Optic' k is s a -> s -> Maybe a+preview o = previews o id+{-# INLINE preview #-}++-- | Retrieve a function of the value targeted by an 'AffineFold'.+previews :: Is k An_AffineFold => Optic' k is s a -> (a -> r) -> s -> Maybe r+previews o = \f -> runForgetM $+  getOptic (castOptic @An_AffineFold o) $ ForgetM (Just . f)+{-# INLINE previews #-}++-- | Create an 'AffineFold' from a partial function.+--+-- >>> preview (afolding listToMaybe) "foo"+-- Just 'f'+--+afolding :: (s -> Maybe a) -> AffineFold s a+afolding f = Optic (contrabimap (\s -> maybe (Left s) Right (f s)) Left . right')+{-# INLINE afolding #-}++-- | Filter result(s) of a fold that don't satisfy a predicate.+filtered :: (a -> Bool) -> AffineFold a a+filtered p = Optic (visit (\point f a -> if p a then f a else point a))+{-# INLINE filtered #-}++-- | Try the first 'AffineFold'. If it returns no entry, try the second one.+--+-- >>> preview (ix 1 % re _Left `afailing` ix 2 % re _Right) [0,1,2,3]+-- Just (Left 1)+--+-- >>> preview (ix 42 % re _Left `afailing` ix 2 % re _Right) [0,1,2,3]+-- Just (Right 2)+--+-- /Note:/ There is no 'Optics.Fold.summing' equivalent, because @asumming = afailing@.+--+afailing+  :: (Is k An_AffineFold, Is l An_AffineFold)+  => Optic' k is s a+  -> Optic' l js s a+  -> AffineFold s a+afailing a b = afolding $ \s -> maybe (preview b s) Just (preview a s)+infixl 3 `afailing` -- Same as (<|>)+{-# INLINE afailing #-}++-- | Check to see if this 'AffineFold' doesn't match.+--+-- >>> isn't _Just Nothing+-- True+--+isn't :: Is k An_AffineFold => Optic' k is s a -> s -> Bool+isn't k s = not (isJust (preview k s))+{-# INLINE isn't #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/AffineTraversal.hs view
@@ -0,0 +1,188 @@+-- |+-- Module: Optics.AffineTraversal+-- Description: A 'Optics.Traversal.Traversal' that applies to at most one element.+--+-- An 'AffineTraversal' is a 'Optics.Traversal.Traversal' that+-- applies to at most one element.+--+-- These arise most frequently as the composition of a+-- 'Optics.Lens.Lens' with a 'Optics.Prism.Prism'.+--+module Optics.AffineTraversal+  (+  -- * Formation+    AffineTraversal+  , AffineTraversal'++  -- * Introduction+  , atraversal++  -- * Elimination+  -- | An 'AffineTraversal' is in particular an 'Optics.AffineFold.AffineFold'+  -- and a 'Optics.Setter.Setter', therefore you can specialise types to obtain:+  --+  -- @+  -- 'Optics.AffineFold.preview' :: 'AffineTraversal' s t a b -> s -> Maybe a+  -- @+  --+  -- @+  -- 'Optics.Setter.over'    :: 'AffineTraversal' s t a b -> (a -> b) -> s -> t+  -- 'Optics.Setter.set'     :: 'AffineTraversal' s t a b ->       b  -> s -> t+  -- @+  , matching++  -- * Computation+  -- |+  --+  -- @+  -- 'matching' ('atraversal' f g) ≡ f+  -- 'Data.Either.isRight' (f s)  =>  'Optics.Setter.set' ('atraversal' f g) b s ≡ g s b+  -- @++  -- * Additional introduction forms+  -- | See 'Optics.Cons.Core._head', 'Optics.Cons.Core._tail',+  -- 'Optics.Cons.Core._init' and 'Optics.Cons.Core._last' for+  -- 'AffineTraversal's for container types.+  , unsafeFiltered++  -- * Additional elimination forms+  , withAffineTraversal++  -- * Subtyping+  , An_AffineTraversal+  -- | <<diagrams/AffineTraversal.png AffineTraversal in the optics hierarchy>>++  -- * van Laarhoven encoding+  , AffineTraversalVL+  , AffineTraversalVL'+  , atraversalVL+  , toAtraversalVL+  )+  where++import Optics.Internal.Concrete+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for a type-modifying affine traversal.+type AffineTraversal s t a b = Optic An_AffineTraversal NoIx s t a b++-- | Type synonym for a type-preserving affine traversal.+type AffineTraversal' s a = Optic' An_AffineTraversal NoIx s a++-- | Type synonym for a type-modifying van Laarhoven affine traversal.+--+-- Note: this isn't exactly van Laarhoven representation as there is+-- no @Pointed@ class (which would be a superclass of 'Applicative'+-- that contains 'pure' but not '<*>'). You can interpret the first+-- argument as a dictionary of @Pointed@ that supplies the @point@+-- function (i.e. the implementation of 'pure').+--+-- A 'Optics.Traversal.TraversalVL' has 'Applicative' available and+-- hence can combine the effects arising from multiple elements using+-- '<*>'. In contrast, an 'AffineTraversalVL' has no way to combine+-- effects from multiple elements, so it must act on at most one+-- element.  (It can act on none at all thanks to the availability of+-- @point@.)+--+type AffineTraversalVL s t a b =+  forall f. Functor f => (forall r. r -> f r) -> (a -> f b) -> s -> f t++-- | Type synonym for a type-preserving van Laarhoven affine traversal.+type AffineTraversalVL' s a = AffineTraversalVL s s a a++-- | Build an affine traversal from a matcher and an updater.+--+-- If you want to build an 'AffineTraversal' from the van Laarhoven+-- representation, use 'atraversalVL'.+atraversal :: (s -> Either t a) -> (s -> b -> t) -> AffineTraversal s t a b+atraversal match update = Optic $+  -- Do not define atraversal in terms of atraversalVL, mixing profunctor-style+  -- definitions with VL style implementation can lead to subpar generated code.+  dimap (\s -> (match s, update s))+        (\(etb, f) -> either id f etb)+  . first'+  . right'+{-# INLINE atraversal #-}++-- | Work with an affine traversal as a matcher and an updater.+withAffineTraversal+  :: Is k An_AffineTraversal+  => Optic k is s t a b+  -> ((s -> Either t a) -> (s -> b -> t) -> r)+  -> r+withAffineTraversal o = \k ->+  case getOptic (castOptic @An_AffineTraversal o) (AffineMarket (\_ b -> b) Right) of+    AffineMarket update match -> k match update+{-# INLINE withAffineTraversal #-}++-- | Build an affine traversal from the van Laarhoven representation.+--+-- Example:+--+-- >>> :{+-- azSnd = atraversalVL $ \point f ab@(a, b) ->+--   if a >= 'a' && a <= 'z'+--   then (a, ) <$> f b+--   else point ab+-- :}+--+-- >>> preview azSnd ('a', "Hi")+-- Just "Hi"+--+-- >>> preview azSnd ('@', "Hi")+-- Nothing+--+-- >>> over azSnd (++ "!!!") ('f', "Hi")+-- ('f',"Hi!!!")+--+-- >>> set azSnd "Bye" ('Y', "Hi")+-- ('Y',"Hi")+--+atraversalVL :: AffineTraversalVL s t a b -> AffineTraversal s t a b+atraversalVL f = Optic (visit f)+{-# INLINE atraversalVL #-}++-- | Convert an affine traversal to its van Laarhoven representation.+toAtraversalVL+  :: Is k An_AffineTraversal+  => Optic k is s t a b+  -> AffineTraversalVL s t a b+toAtraversalVL o point =+  runStarA . getOptic (castOptic @An_AffineTraversal o) . StarA point+{-# INLINE toAtraversalVL #-}++-- | Retrieve the value targeted by an 'AffineTraversal' or return the original+-- value while allowing the type to change if it does not match.+--+-- @+-- 'Optics.AffineFold.preview' o ≡ 'either' ('const' 'Nothing') 'id' . 'matching' o+-- @+matching :: Is k An_AffineTraversal => Optic k is s t a b -> s -> Either t a+matching o = withAffineTraversal o $ \match _ -> match+{-# INLINE matching #-}++-- | Filter result(s) of a traversal that don't satisfy a predicate.+--+-- /Note:/ This is /not/ a legal 'Optics.Traversal.Traversal', unless you are+-- very careful not to invalidate the predicate on the target.+--+-- As a counter example, consider that given @evens = 'unsafeFiltered' 'even'@+-- the second 'Optics.Traversal.Traversal' law is violated:+--+-- @+-- 'Optics.Setter.over' evens 'succ' '.' 'Optics.over' evens 'succ' '/=' 'Optics.Setter.over' evens ('succ' '.' 'succ')+-- @+--+-- So, in order for this to qualify as a legal 'Optics.Traversal.Traversal' you+-- can only use it for actions that preserve the result of the predicate!+--+-- For a safe variant see 'Optics.IxTraversal.indices' (or+-- 'Optics.AffineFold.filtered' for read-only optics).+--+unsafeFiltered :: (a -> Bool) -> AffineTraversal' a a+unsafeFiltered p = atraversalVL (\point f a -> if p a then f a else point a)+{-# INLINE unsafeFiltered #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Arrow.hs view
@@ -0,0 +1,119 @@+-- |+-- Module: Optics.Arrow+-- Description: Turn optics into arrow transformers.+module Optics.Arrow+  ( ArrowOptic(..)+  , assignA+  ) where++import Control.Arrow+import Data.Coerce+import qualified Control.Category as C++import Optics.AffineTraversal+import Optics.Prism+import Optics.Setter+import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Utils++newtype WrappedArrow p i a b = WrapArrow { unwrapArrow :: p a b }++instance C.Category p => C.Category (WrappedArrow p i) where+  WrapArrow f . WrapArrow g = WrapArrow (f C.. g)+  id                        = WrapArrow C.id+  {-# INLINE (.) #-}+  {-# INLINE id #-}++instance Arrow p => Arrow (WrappedArrow p i) where+  arr                         = WrapArrow #. arr+  first                       = WrapArrow #. first  .# unwrapArrow+  second                      = WrapArrow #. second .# unwrapArrow+  WrapArrow a *** WrapArrow b = WrapArrow (a *** b)+  WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b)+  {-# INLINE arr #-}+  {-# INLINE first #-}+  {-# INLINE second #-}+  {-# INLINE (***) #-}+  {-# INLINE (&&&) #-}++instance Arrow p => Profunctor (WrappedArrow p) where+  dimap f g k = arr f >>> k >>> arr g+  lmap  f   k = arr f >>> k+  rmap    g k =           k >>> arr g+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  lcoerce' = lmap coerce+  rcoerce' = rmap coerce+  {-# INLINE lcoerce' #-}+  {-# INLINE rcoerce' #-}++instance Arrow p => Strong (WrappedArrow p) where+  first'  (WrapArrow k) = WrapArrow (first k)+  second' (WrapArrow k) = WrapArrow (second k)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++instance ArrowChoice p => Choice (WrappedArrow p) where+  left'  (WrapArrow k) = WrapArrow (left k)+  right' (WrapArrow k) = WrapArrow (right k)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance ArrowChoice p => Visiting (WrappedArrow p)++class Arrow arr => ArrowOptic k arr where+  -- | Turn an optic into an arrow transformer.+  overA :: Optic k is s t a b -> arr a b -> arr s t++instance Arrow arr => ArrowOptic An_Iso arr where+  overA = overA__+  {-# INLINE overA #-}++instance Arrow arr => ArrowOptic A_Lens arr where+  overA = overA__+  {-# INLINE overA #-}++instance ArrowChoice arr => ArrowOptic A_Prism arr where+  overA = overA__+  {-# INLINE overA #-}++instance ArrowChoice arr => ArrowOptic An_AffineTraversal arr where+  overA = overA__+  {-# INLINE overA #-}++-- | Run an arrow command and use the output to set all the targets of an optic+-- to the result.+--+-- @+-- runKleisli action ((), (), ()) where+--   action =      assignA _1 (Kleisli (const getVal1))+--            \>>> assignA _2 (Kleisli (const getVal2))+--            \>>> assignA _3 (Kleisli (const getVal3))+--   getVal1 :: Either String Int+--   getVal1 = ...+--   getVal2 :: Either String Bool+--   getVal2 = ...+--   getVal3 :: Either String Char+--   getVal3 = ...+-- @+--+-- has the type @'Either' 'String' ('Int', 'Bool', 'Char')@+assignA+  :: (Is k A_Setter, Arrow arr)+  => Optic k is s t a b+  -> arr s b -> arr s t+assignA o p = arr (flip $ set o) &&& p >>> arr (uncurry id)+{-# INLINE assignA #-}++----------------------------------------++-- | Internal implementation of overA.+overA__+  :: (p ~ WrappedArrow arr, Profunctor p, Constraints k p)+  => Optic k is s t a b+  -> arr a b -> arr s t+overA__ o = unwrapArrow #. getOptic o .# WrapArrow+{-# INLINE overA__ #-}
+ src/Optics/At/Core.hs view
@@ -0,0 +1,485 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: Optics.At.Core+-- Description: Optics for 'Map' and 'Set'-like containers.+--+-- This module provides optics for 'Map' and 'Set'-like containers, including an+-- 'AffineTraversal' to traverse a key in a map or an element of a sequence:+--+-- >>> preview (ix 1) ['a','b','c']+-- Just 'b'+--+-- a 'Lens' to get, set or delete a key in a map:+--+-- >>> set (at 0) (Just 'b') (Map.fromList [(0, 'a')])+-- fromList [(0,'b')]+--+-- and a 'Lens' to insert or remove an element of a set:+--+-- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False+-- fromList [1,2,4]+--+-- The @Optics.At@ module from @optics-extra@ provides additional instances of+-- the classes defined here.+--+module Optics.At.Core+  (+    -- * Type families+    Index+  , IxValue++    -- * Ixed+  , Ixed(..)+  , ixAt++    -- * At+  , At(..)+  , at'+  , sans++  -- * Contains+  , Contains(..)+  ) where++import Data.Array.IArray as Array+import Data.Array.Unboxed+import Data.Complex+import Data.Functor.Identity+import Data.IntMap as IntMap+import Data.IntSet as IntSet+import Data.List.NonEmpty as NonEmpty+import Data.Map as Map+import Data.Sequence as Seq+import Data.Set as Set+import Data.Tree++import Data.Maybe.Optics+import Optics.AffineTraversal+import Optics.Iso+import Optics.Lens+import Optics.Optic+import Optics.Setter++-- | Type family that takes a key-value container type and returns the type of+-- keys (indices) into the container, for example @'Index' ('Map' k a) ~ k@.+-- This is shared by 'Ixed', 'At' and 'Contains'.+type family Index (s :: *) :: *+type instance Index (e -> a) = e+type instance Index IntSet = Int+type instance Index (Set a) = a+type instance Index [a] = Int+type instance Index (NonEmpty a) = Int+type instance Index (Seq a) = Int+type instance Index (a,b) = Int+type instance Index (a,b,c) = Int+type instance Index (a,b,c,d) = Int+type instance Index (a,b,c,d,e) = Int+type instance Index (a,b,c,d,e,f) = Int+type instance Index (a,b,c,d,e,f,g) = Int+type instance Index (a,b,c,d,e,f,g,h) = Int+type instance Index (a,b,c,d,e,f,g,h,i) = Int+type instance Index (IntMap a) = Int+type instance Index (Map k a) = k+type instance Index (Array.Array i e) = i+type instance Index (UArray i e) = i+type instance Index (Complex a) = Int+type instance Index (Identity a) = ()+type instance Index (Maybe a) = ()+type instance Index (Tree a) = [Int]++-- | This class provides a simple 'Lens' that lets you view (and modify)+-- information about whether or not a container contains a given 'Index'.+-- Instances are provided for 'Set'-like containers only.+class Contains m where+  -- |+  -- >>> IntSet.fromList [1,2,3,4] ^. contains 3+  -- True+  --+  -- >>> IntSet.fromList [1,2,3,4] ^. contains 5+  -- False+  --+  -- >>> IntSet.fromList [1,2,3,4] & contains 3 .~ False+  -- fromList [1,2,4]+  contains :: Index m -> Lens' m Bool++instance Contains IntSet where+  contains k = lensVL $ \f s -> f (IntSet.member k s) <&> \b ->+    if b then IntSet.insert k s else IntSet.delete k s+  {-# INLINE contains #-}++instance Ord a => Contains (Set a) where+  contains k = lensVL $ \f s -> f (Set.member k s) <&> \b ->+    if b then Set.insert k s else Set.delete k s+  {-# INLINE contains #-}++-- | Type family that takes a key-value container type and returns the type of+-- values stored in the container, for example @'IxValue' ('Map' k a) ~ a@. This+-- is shared by both 'Ixed' and 'At'.+type family IxValue (m :: *) :: *++-- | Provides a simple 'AffineTraversal' lets you traverse the value at a given+-- key in a 'Map' or element at an ordinal position in a list or 'Seq'.+class Ixed m where+  -- | /NB:/ Setting the value of this 'AffineTraversal' will only set the value+  -- in 'at' if it is already present.+  --+  -- If you want to be able to insert /missing/ values, you want 'at'.+  --+  -- >>> [1,2,3,4] & ix 2 %~ (*10)+  -- [1,2,30,4]+  --+  -- >>> "abcd" & ix 2 .~ 'e'+  -- "abed"+  --+  -- >>> "abcd" ^? ix 2+  -- Just 'c'+  --+  -- >>> [] ^? ix 2+  -- Nothing+  ix :: Index m -> AffineTraversal' m (IxValue m)+  default ix :: At m => Index m -> AffineTraversal' m (IxValue m)+  ix = ixAt+  {-# INLINE ix #-}++-- | A definition of 'ix' for types with an 'At' instance. This is the default+-- if you don't specify a definition for 'ix'.+ixAt :: At m => Index m -> AffineTraversal' m (IxValue m)+ixAt = \i -> at i % _Just+{-# INLINE ixAt #-}++type instance IxValue (e -> a) = a+instance Eq e => Ixed (e -> a) where+  ix e = atraversalVL $ \_ p f -> p (f e) <&> \a e' -> if e == e' then a else f e'+  {-# INLINE ix #-}++type instance IxValue (Maybe a) = a+instance Ixed (Maybe a) where+  ix () = castOptic @An_AffineTraversal _Just+  {-# INLINE ix #-}++type instance IxValue [a] = a+instance Ixed [a] where+  ix k = atraversalVL (ixListVL k)+  {-# INLINE ix #-}++type instance IxValue (NonEmpty a) = a+instance Ixed (NonEmpty a) where+  ix k = atraversalVL $ \point f xs0 ->+    if k < 0+    then point xs0+    else let go (a:|as) 0 = f a <&> (:|as)+             go (a:|as) i = (a:|) <$> ixListVL (i - 1) point f as+         in go xs0 k+  {-# INLINE ix #-}++type instance IxValue (Identity a) = a+instance Ixed (Identity a) where+  ix () = atraversalVL $ \_ f (Identity a) -> Identity <$> f a+  {-# INLINE ix #-}++type instance IxValue (Tree a) = a+instance Ixed (Tree a) where+  ix xs0 = atraversalVL $ \point f ->+    let go [] (Node a as) = f a <&> \a' -> Node a' as+        go (i:is) t@(Node a as)+          | i < 0     = point t+          | otherwise = Node a <$> ixListVL i point (go is) as+    in go xs0+  {-# INLINE ix #-}++type instance IxValue (Seq a) = a+instance Ixed (Seq a) where+  ix i = atraversalVL $ \point f m ->+    if 0 <= i && i < Seq.length m+    then f (Seq.index m i) <&> \a -> Seq.update i a m+    else point m+  {-# INLINE ix #-}++type instance IxValue (IntMap a) = a+-- Default implementation uses IntMap.alterF+instance Ixed (IntMap a)++type instance IxValue (Map k a) = a+-- Default implementation uses Map.alterF+instance Ord k => Ixed (Map k a)++type instance IxValue (Set k) = ()+instance Ord k => Ixed (Set k) where+  ix k = atraversalVL $ \point f m ->+    if Set.member k m+    then f () <&> \() -> Set.insert k m+    else point m+  {-# INLINE ix #-}++type instance IxValue IntSet = ()+instance Ixed IntSet where+  ix k = atraversalVL $ \point f m ->+    if IntSet.member k m+    then f () <&> \() -> IntSet.insert k m+    else point m+  {-# INLINE ix #-}++type instance IxValue (Array.Array i e) = e+-- |+-- @+-- arr 'Array.!' i ≡ arr 'Optics.Operators.^.' 'ix' i+-- arr '//' [(i,e)] ≡ 'ix' i 'Optics.Operators..~' e '$' arr+-- @+instance Ix i => Ixed (Array.Array i e) where+  ix i = atraversalVL $ \point f arr ->+    if inRange (bounds arr) i+    then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]+    else point arr+  {-# INLINE ix #-}++type instance IxValue (UArray i e) = e+-- |+-- @+-- arr 'Array.!' i ≡ arr 'Optics.Operators.^.' 'ix' i+-- arr '//' [(i,e)] ≡ 'ix' i 'Optics.Operators..~' e '$' arr+-- @+instance (IArray UArray e, Ix i) => Ixed (UArray i e) where+  ix i = atraversalVL $ \point f arr ->+    if inRange (bounds arr) i+    then f (arr Array.! i) <&> \e -> arr Array.// [(i,e)]+    else point arr+  {-# INLINE ix #-}++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a) a@+type instance IxValue (a0, a2) = a0+instance (a0 ~ a1) => Ixed (a0, a1) where+  ix i = atraversalVL $ \point f ~s@(a0, a1) ->+    case i of+      0 -> (,a1) <$> f a0+      1 -> (a0,) <$> f a1+      _ -> point s++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a) a@+type instance IxValue (a0, a1, a2) = a0+instance (a0 ~ a1, a0 ~ a2) => Ixed (a0, a1, a2) where+  ix i = atraversalVL $ \point f ~s@(a0, a1, a2) ->+    case i of+      0 -> (,a1,a2) <$> f a0+      1 -> (a0,,a2) <$> f a1+      2 -> (a0,a1,) <$> f a2+      _ -> point s++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a) a@+type instance IxValue (a0, a1, a2, a3) = a0+instance (a0 ~ a1, a0 ~ a2, a0 ~ a3) => Ixed (a0, a1, a2, a3) where+  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3) ->+    case i of+      0 -> (,a1,a2,a3) <$> f a0+      1 -> (a0,,a2,a3) <$> f a1+      2 -> (a0,a1,,a3) <$> f a2+      3 -> (a0,a1,a2,) <$> f a3+      _ -> point s++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a) a@+type instance IxValue (a0, a1, a2, a3, a4) = a0+instance (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4) => Ixed (a0, a1, a2, a3, a4) where+  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4) ->+    case i of+      0 -> (,a1,a2,a3,a4) <$> f a0+      1 -> (a0,,a2,a3,a4) <$> f a1+      2 -> (a0,a1,,a3,a4) <$> f a2+      3 -> (a0,a1,a2,,a4) <$> f a3+      4 -> (a0,a1,a2,a3,) <$> f a4+      _ -> point s++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a) a@+type instance IxValue (a0, a1, a2, a3, a4, a5) = a0+instance+  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5+  ) => Ixed (a0, a1, a2, a3, a4, a5) where+  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5) ->+    case i of+      0 -> (,a1,a2,a3,a4,a5) <$> f a0+      1 -> (a0,,a2,a3,a4,a5) <$> f a1+      2 -> (a0,a1,,a3,a4,a5) <$> f a2+      3 -> (a0,a1,a2,,a4,a5) <$> f a3+      4 -> (a0,a1,a2,a3,,a5) <$> f a4+      5 -> (a0,a1,a2,a3,a4,) <$> f a5+      _ -> point s++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a) a@+type instance IxValue (a0, a1, a2, a3, a4, a5, a6) = a0+instance+  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6+  ) => Ixed (a0, a1, a2, a3, a4, a5, a6) where+  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6) ->+    case i of+      0 -> (,a1,a2,a3,a4,a5,a6) <$> f a0+      1 -> (a0,,a2,a3,a4,a5,a6) <$> f a1+      2 -> (a0,a1,,a3,a4,a5,a6) <$> f a2+      3 -> (a0,a1,a2,,a4,a5,a6) <$> f a3+      4 -> (a0,a1,a2,a3,,a5,a6) <$> f a4+      5 -> (a0,a1,a2,a3,a4,,a6) <$> f a5+      6 -> (a0,a1,a2,a3,a4,a5,) <$> f a6+      _ -> point s++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a, a) a@+type instance IxValue (a0, a1, a2, a3, a4, a5, a6, a7) = a0+instance+  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6, a0 ~ a7+  ) => Ixed (a0, a1, a2, a3, a4, a5, a6, a7) where+  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6, a7) ->+    case i of+      0 -> (,a1,a2,a3,a4,a5,a6,a7) <$> f a0+      1 -> (a0,,a2,a3,a4,a5,a6,a7) <$> f a1+      2 -> (a0,a1,,a3,a4,a5,a6,a7) <$> f a2+      3 -> (a0,a1,a2,,a4,a5,a6,a7) <$> f a3+      4 -> (a0,a1,a2,a3,,a5,a6,a7) <$> f a4+      5 -> (a0,a1,a2,a3,a4,,a6,a7) <$> f a5+      6 -> (a0,a1,a2,a3,a4,a5,,a7) <$> f a6+      7 -> (a0,a1,a2,a3,a4,a5,a6,) <$> f a7+      _ -> point s++-- | @'ix' :: 'Int' -> 'AffineTraversal'' (a, a, a, a, a, a, a, a, a) a@+type instance IxValue (a0, a1, a2, a3, a4, a5, a6, a7, a8) = a0+instance+  (a0 ~ a1, a0 ~ a2, a0 ~ a3, a0 ~ a4, a0 ~ a5, a0 ~ a6, a0 ~ a7, a0 ~ a8+  ) => Ixed (a0, a1, a2, a3, a4, a5, a6, a7, a8) where+  ix i = atraversalVL $ \point f ~s@(a0, a1, a2, a3, a4, a5, a6, a7, a8) ->+    case i of+      0 -> (,a1,a2,a3,a4,a5,a6,a7,a8) <$> f a0+      1 -> (a0,,a2,a3,a4,a5,a6,a7,a8) <$> f a1+      2 -> (a0,a1,,a3,a4,a5,a6,a7,a8) <$> f a2+      3 -> (a0,a1,a2,,a4,a5,a6,a7,a8) <$> f a3+      4 -> (a0,a1,a2,a3,,a5,a6,a7,a8) <$> f a4+      5 -> (a0,a1,a2,a3,a4,,a6,a7,a8) <$> f a5+      6 -> (a0,a1,a2,a3,a4,a5,,a7,a8) <$> f a6+      7 -> (a0,a1,a2,a3,a4,a5,a6,,a8) <$> f a7+      8 -> (a0,a1,a2,a3,a4,a5,a6,a7,) <$> f a8+      _ -> point s++-- | 'At' provides a 'Lens' that can be used to read, write or delete the value+-- associated with a key in a 'Map'-like container on an ad hoc basis.+--+-- An instance of 'At' should satisfy:+--+-- @+-- 'ix' k ≡ 'at' k '%' '_Just'+-- @+class Ixed m => At m where+  -- |+  -- >>> Map.fromList [(1,"world")] ^. at 1+  -- Just "world"+  --+  -- >>> at 1 ?~ "hello" $ Map.empty+  -- fromList [(1,"hello")]+  --+  -- /Note:/ Usage of this function might introduce space leaks if you're not+  -- careful to make sure that values put inside the 'Just' constructor are+  -- evaluated. To force the values and avoid such leaks, use 'at'' instead.+  --+  -- /Note:/ 'Map'-like containers form a reasonable instance, but not+  -- 'Array'-like ones, where you cannot satisfy the 'Lens' laws.+  at :: Index m -> Lens' m (Maybe (IxValue m))++-- | Version of 'at' strict in the value inside the `Just` constructor.+--+-- Example:+--+-- >>> (at () .~ Just (error "oops") $ Nothing) `seq` ()+-- ()+--+-- >>> (at' () .~ Just (error "oops") $ Nothing) `seq` ()+-- *** Exception: oops+-- ...+--+-- >>> view (at ()) (Just $ error "oops") `seq` ()+-- ()+--+-- >>> view (at' ()) (Just $ error "oops") `seq` ()+-- *** Exception: oops+-- ...+--+-- It also works as expected for other data structures:+--+-- >>> (at 1 .~ Just (error "oops") $ Map.empty) `seq` ()+-- ()+--+-- >>> (at' 1 .~ Just (error "oops") $ Map.empty) `seq` ()+-- *** Exception: oops+-- ...+at' :: At m => Index m -> Lens' m (Maybe (IxValue m))+at' k = at k % iso f f+  where+    f = \case+      Just !x -> Just x+      Nothing -> Nothing+{-# INLINE at' #-}++-- | Delete the value associated with a key in a 'Map'-like container+--+-- @+-- 'sans' k = 'at' k 'Optics.Operators..~' Nothing+-- @+sans :: At m => Index m -> m -> m+sans k = set (at k) Nothing+{-# INLINE sans #-}++instance At (Maybe a) where+  at () = lensVL id+  {-# INLINE at #-}++instance At (IntMap a) where+#if MIN_VERSION_containers(0,5,8)+  at k = lensVL $ \f -> IntMap.alterF f k+#else+  at k = lensVL $ \f m ->+    let mv = IntMap.lookup k m+    in f mv <&> \r -> case r of+      Nothing -> maybe m (const (IntMap.delete k m)) mv+      Just v' -> IntMap.insert k v' m+#endif+  {-# INLINE at #-}++instance Ord k => At (Map k a) where+#if MIN_VERSION_containers(0,5,8)+  at k = lensVL $ \f -> Map.alterF f k+#else+  at k = lensVL $ \f m ->+    let mv = Map.lookup k m+    in f mv <&> \r -> case r of+      Nothing -> maybe m (const (Map.delete k m)) mv+      Just v' -> Map.insert k v' m+#endif+  {-# INLINE at #-}++instance At IntSet where+  at k = lensVL $ \f m ->+    let mv = if IntSet.member k m+             then Just ()+             else Nothing+    in f mv <&> \r -> case r of+      Nothing -> maybe m (const (IntSet.delete k m)) mv+      Just () -> IntSet.insert k m+  {-# INLINE at #-}++instance Ord k => At (Set k) where+  at k = lensVL $ \f m ->+    let mv = if Set.member k m+             then Just ()+             else Nothing+    in f mv <&> \r -> case r of+      Nothing -> maybe m (const (Set.delete k m)) mv+      Just () -> Set.insert k m+  {-# INLINE at #-}++----------------------------------------+-- Internal++ixListVL :: Int -> AffineTraversalVL' [a] a+ixListVL k point f xs0 =+  if k < 0+  then point xs0+  else let go [] _ = point []+           go (a:as) 0 = f a <&> (:as)+           go (a:as) i = (a:) <$> (go as $! i - 1)+       in go xs0 k+{-# INLINE ixListVL #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Coerce.hs view
@@ -0,0 +1,60 @@+-- |+-- Module: Optics.Coerce+-- Description: Operators to 'coerce' the type parameters of 'Optic'.+--+-- This module defines operations to 'coerce' the type parameters of optics to+-- a representationally equal type.  For example, if we have+--+-- > newtype MkInt = MkInt Int+--+-- and+--+-- > l :: Lens' S Int+--+-- then+--+-- > coerceA @Int @MkInt l :: Lens' S MkInt+--+module Optics.Coerce+  ( coerceS+  , coerceT+  , coerceA+  , coerceB+  ) where++import Data.Coerce++import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Lift 'coerce' to the @s@ parameter of an optic.+coerceS+  :: Coercible s s'+  => Optic k is s  t a b+  -> Optic k is s' t a b+coerceS = \(Optic o) -> Optic (lcoerce . o)+{-# INLINE coerceS #-}++-- | Lift 'coerce' to the @t@ parameter of an optic.+coerceT+  :: Coercible t t'+  => Optic k is s t  a b+  -> Optic k is s t' a b+coerceT = \(Optic o) -> Optic (rcoerce . o)+{-# INLINE coerceT #-}++-- | Lift 'coerce' to the @a@ parameter of an optic.+coerceA+  :: Coercible a a'+  => Optic k is s t a  b+  -> Optic k is s t a' b+coerceA = \(Optic o) -> Optic (o . lcoerce)+{-# INLINE coerceA #-}++-- | Lift 'coerce' to the @b@ parameter of an optic.+coerceB+  :: Coercible b b'+  => Optic k is s t a b+  -> Optic k is s t a b'+coerceB = \(Optic o) -> Optic (o . rcoerce)+{-# INLINE coerceB #-}
+ src/Optics/Cons/Core.hs view
@@ -0,0 +1,338 @@+-- |+-- Module: Optics.Cons.Core+-- Description: Optics to access the left or right element of a container.+--+-- This module defines the 'Cons' and 'Snoc' classes, which provide 'Prism's for+-- the leftmost and rightmost elements of a container, respectively.+--+-- Note that orphan instances for these classes are defined in the @Optics.Cons@+-- module from @optics-extra@, so if you are not simply depending on @optics@+-- you may wish to import that module instead.+--+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module Optics.Cons.Core+  (+  -- * Cons+    Cons(..)+  , (<|)+  , cons+  , uncons+  , _head, _tail+  , pattern (:<)+  -- * Snoc+  , Snoc(..)+  , (|>)+  , snoc+  , unsnoc+  , _init, _last+  , pattern (:>)+  ) where++import Control.Applicative (ZipList(..))+import Data.Coerce+import Data.Sequence hiding ((<|), (|>), (:<), (:>))+import qualified Data.Sequence as Seq++import Data.Tuple.Optics+import Optics.AffineFold+import Optics.AffineTraversal+import Optics.Coerce+import Optics.Optic+import Optics.Prism+import Optics.Review++infixr 5 <|, `cons`+infixl 5 |>, `snoc`++-- | Pattern synonym for matching on the leftmost element of a structure.+--+-- >>> case ['a','b','c'] of (x :< _) -> x+-- 'a'+--+pattern (:<) :: forall s a. Cons s s a a => a -> s -> s+pattern (:<) a s <- (preview _Cons -> Just (a, s)) where+  (:<) a s = review _Cons (a, s)++infixr 5 :<+infixl 5 :>++-- | Pattern synonym for matching on the rightmost element of a structure.+--+-- >>> case ['a','b','c'] of (_ :> x) -> x+-- 'c'+--+pattern (:>) :: forall s a. Snoc s s a a => s -> a -> s+pattern (:>) s a <- (preview _Snoc -> Just (s, a)) where+  (:>) a s = review _Snoc (a, s)++------------------------------------------------------------------------------+-- Cons+------------------------------------------------------------------------------++-- | This class provides a way to attach or detach elements on the left+-- side of a structure in a flexible manner.+class Cons s t a b | s -> a, t -> b, s b -> t, t a -> s where+  -- |+  --+  -- @+  -- '_Cons' :: 'Prism' [a] [b] (a, [a]) (b, [b])+  -- '_Cons' :: 'Prism' ('Seq' a) ('Seq' b) (a, 'Seq' a) (b, 'Seq' b)+  -- '_Cons' :: 'Prism' (Vector a) (Vector b) (a, Vector a) (b, Vector b)+  -- '_Cons' :: 'Prism'' 'String' ('Char', 'String')+  -- '_Cons' :: 'Prism'' Text ('Char', Text)+  -- '_Cons' :: 'Prism'' ByteString ('Data.Word.Word8', ByteString)+  -- @+  _Cons :: Prism s t (a, s) (b, t)++instance Cons [a] [b] a b where+  _Cons = prism (uncurry (:)) $ \ aas -> case aas of+    (a:as) -> Right (a, as)+    []     -> Left  []+  {-# INLINE _Cons #-}++instance Cons (ZipList a) (ZipList b) a b where+  _Cons = coerceS . coerceT . coerceA . coerceB $ listCons+    where+      listCons :: Prism [a] [b] (a, [a]) (b, [b])+      listCons = _Cons++  {-# INLINE _Cons #-}++instance Cons (Seq a) (Seq b) a b where+  _Cons = prism (uncurry (Seq.<|)) $ \aas -> case viewl aas of+    a Seq.:< as -> Right (a, as)+    EmptyL  -> Left mempty+  {-# INLINE _Cons #-}++-- | 'cons' an element onto a container.+--+-- This is an infix alias for 'cons'.+--+-- >>> 1 <| []+-- [1]+--+-- >>> 'a' <| "bc"+-- "abc"+--+-- >>> 1 <| []+-- [1]+--+-- >>> 1 <| [2, 3]+-- [1,2,3]+(<|) :: Cons s s a a => a -> s -> s+(<|) = curry (review _Cons)+{-# INLINE (<|) #-}++-- | 'cons' an element onto a container.+--+-- >>> cons 'a' ""+-- "a"+--+-- >>> cons 'a' "bc"+-- "abc"+cons :: Cons s s a a => a -> s -> s+cons = curry (review _Cons)+{-# INLINE cons #-}++-- | Attempt to extract the left-most element from a container, and a version of+-- the container without that element.+--+-- >>> uncons []+-- Nothing+--+-- >>> uncons [1, 2, 3]+-- Just (1,[2,3])+uncons :: Cons s s a a => s -> Maybe (a, s)+uncons = preview _Cons+{-# INLINE uncons #-}++-- | An 'AffineTraversal' reading and writing to the 'head' of a /non-empty/+-- container.+--+-- >>> "abc" ^? _head+-- Just 'a'+--+-- >>> "abc" & _head .~ 'd'+-- "dbc"+--+-- >>> [1,2,3] & _head %~ (*10)+-- [10,2,3]+--+-- >>> [] & _head %~ absurd+-- []+--+-- >>> [1,2,3] ^? _head+-- Just 1+--+-- >>> [] ^? _head+-- Nothing+--+-- >>> [1,2] ^? _head+-- Just 1+--+-- >>> [] & _head .~ 1+-- []+--+-- >>> [0] & _head .~ 2+-- [2]+--+-- >>> [0,1] & _head .~ 2+-- [2,1]+_head :: Cons s s a a => AffineTraversal' s a+_head = _Cons % _1+{-# INLINE _head #-}++-- | An 'AffineTraversal' reading and writing to the 'tail' of a /non-empty/+-- container.+--+-- >>> "ab" & _tail .~ "cde"+-- "acde"+--+-- >>> [] & _tail .~ [1,2]+-- []+--+-- >>> [1,2,3,4,5] & _tail % traversed %~ (*10)+-- [1,20,30,40,50]+--+-- >>> [1,2] & _tail .~ [3,4,5]+-- [1,3,4,5]+--+-- >>> [] & _tail .~ [1,2]+-- []+--+-- >>> "abc" ^? _tail+-- Just "bc"+--+-- >>> "hello" ^? _tail+-- Just "ello"+--+-- >>> "" ^? _tail+-- Nothing+_tail :: Cons s s a a => AffineTraversal' s s+_tail = _Cons % _2+{-# INLINE _tail #-}++------------------------------------------------------------------------------+-- Snoc+------------------------------------------------------------------------------++-- | This class provides a way to attach or detach elements on the right side of+-- a structure in a flexible manner.+class Snoc s t a b | s -> a, t -> b, s b -> t, t a -> s where+  _Snoc :: Prism s t (s, a) (t, b)++instance Snoc [a] [b] a b where+  _Snoc = prism (\(as,a) -> as Prelude.++ [a]) $ \aas -> if Prelude.null aas+    then Left []+    else Right (Prelude.init aas, Prelude.last aas)+  {-# INLINE _Snoc #-}++instance Snoc (ZipList a) (ZipList b) a b where+  _Snoc = withPrism listSnoc $ \listReview listPreview ->+    prism (coerce listReview) (coerce listPreview) where++    listSnoc :: Prism [a] [b] ([a], a) ([b], b)+    listSnoc = _Snoc++  {-# INLINE _Snoc #-}++instance Snoc (Seq a) (Seq b) a b where+  _Snoc = prism (uncurry (Seq.|>)) $ \aas -> case viewr aas of+    as Seq.:> a -> Right (as, a)+    EmptyR  -> Left mempty+  {-# INLINE _Snoc #-}++-- | An 'AffineTraversal' reading and replacing all but the a last element of a+-- /non-empty/ container.+--+-- >>> "abcd" ^? _init+-- Just "abc"+--+-- >>> "" ^? _init+-- Nothing+--+-- >>> "ab" & _init .~ "cde"+-- "cdeb"+--+-- >>> [] & _init .~ [1,2]+-- []+--+-- >>> [1,2,3,4] & _init % traversed %~ (*10)+-- [10,20,30,4]+--+-- >>> [1,2,3] ^? _init+-- Just [1,2]+--+-- >>> "hello" ^? _init+-- Just "hell"+--+-- >>> [] ^? _init+-- Nothing+_init :: Snoc s s a a => AffineTraversal' s s+_init = _Snoc % _1+{-# INLINE _init #-}++-- | An 'AffineTraversal' reading and writing to the last element of a+-- /non-empty/ container.+--+-- >>> "abc" ^? _last+-- Just 'c'+--+-- >>> "" ^? _last+-- Nothing+--+-- >>> [1,2,3] & _last %~ (+1)+-- [1,2,4]+--+-- >>> [1,2] ^? _last+-- Just 2+--+-- >>> [] & _last .~ 1+-- []+--+-- >>> [0] & _last .~ 2+-- [2]+--+-- >>> [0,1] & _last .~ 2+-- [0,2]+_last :: Snoc s s a a => AffineTraversal' s a+_last = _Snoc % _2+{-# INLINE _last #-}++-- | 'snoc' an element onto the end of a container.+--+-- This is an infix alias for 'snoc'.+--+-- >>> "" |> 'a'+-- "a"+--+-- >>> "bc" |> 'a'+-- "bca"+(|>) :: Snoc s s a a => s -> a -> s+(|>) = curry (review _Snoc)+{-# INLINE (|>) #-}++-- | 'snoc' an element onto the end of a container.+--+-- >>> snoc "hello" '!'+-- "hello!"+snoc  :: Snoc s s a a => s -> a -> s+snoc = curry (review _Snoc)+{-# INLINE snoc #-}++-- | Attempt to extract the right-most element from a container, and a version+-- of the container without that element.+--+-- >>> unsnoc "hello!"+-- Just ("hello",'!')+--+-- >>> unsnoc ""+-- Nothing+unsnoc :: Snoc s s a a => s -> Maybe (s, a)+unsnoc s = preview _Snoc s+{-# INLINE unsnoc #-}++-- $setup+-- >>> import Data.Void+-- >>> import Optics.Core
+ src/Optics/Core.hs view
@@ -0,0 +1,68 @@+-- |+--+-- Module: Optics.Core+-- Description: The core optics functionality re-exported.+--+-- See the @Optics@ module in the main @optics@ package for overview+-- documentation.+--+module Optics.Core+  (+  -- * Basic definitions+    module Optics.Optic++  -- * Kinds of optic+  , module O++  -- * Indexed optics+  , module I++  -- * Overloaded labels+  , module Optics.Label++  -- * Combinators+  , module P++  -- * Optics for basic data types+  , module D+  )+  where++import Optics.AffineFold                       as O+import Optics.AffineTraversal                  as O+import Optics.Fold                             as O+import Optics.Getter                           as O+import Optics.Iso                              as O+import Optics.IxAffineFold                     as O+import Optics.IxAffineTraversal                as O+import Optics.IxFold                           as O+import Optics.IxGetter                         as O+import Optics.IxLens                           as O+import Optics.IxSetter                         as O+import Optics.IxTraversal                      as O+import Optics.Lens                             as O+import Optics.ReversedLens                     as O+import Optics.Prism                            as O+import Optics.ReversedPrism                    as O+import Optics.Review                           as O+import Optics.Setter                           as O+import Optics.Traversal                        as O++import Optics.Indexed.Core                     as I++import Optics.Arrow                            as P+import Optics.At.Core                          as P+import Optics.Coerce                           as P+import Optics.Cons.Core                        as P+import Optics.Each.Core                        as P+import Optics.Empty.Core                       as P+import Optics.Operators                        as P+import Optics.Re                               as P+import Optics.ReadOnly                         as P++import Optics.Label+import Optics.Optic++import Data.Either.Optics                      as D+import Data.Maybe.Optics                       as D+import Data.Tuple.Optics                       as D
+ src/Optics/Each/Core.hs view
@@ -0,0 +1,196 @@+-- |+-- Module: Optics.Each.Core+-- Description: An 'IxTraversal' for each element of a (potentially monomorphic) container.+--+-- This module defines the 'Each' class, which provides an 'IxTraversal' that+-- extracts 'each' element of a (potentially monomorphic) container.+--+-- Note that orphan instances for this class are defined in the @Optics.Each@+-- module from @optics-extra@, so if you are not simply depending on @optics@+-- you may wish to import that module instead.+--+{-# LANGUAGE UndecidableInstances #-}+module Optics.Each.Core+  (+  -- * Each+    Each(..)+  ) where++import Data.Array+import Data.Complex+import Data.Functor.Identity+import Data.IntMap as IntMap+import Data.List.NonEmpty+import Data.Map as Map+import Data.Sequence as Seq+import Data.Tree as Tree++import Optics.IxTraversal++-- | Extract 'each' element of a (potentially monomorphic) container.+--+-- >>> over each (*10) (1,2,3)+-- (10,20,30)+--+-- >>> iover each (\i a -> a*10 + succ i) (1,2,3)+-- (11,22,33)+--+class Each i s t a b | s -> i a, t -> i b, s b -> t, t a -> s where+  each :: IxTraversal i s t a b++  default each+    :: (TraversableWithIndex i g, s ~ g a, t ~ g b)+    => IxTraversal i s t a b+  each = itraversed+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a) (b, b) a b@+instance+  (a ~ a1,+   b ~ b1+  ) => Each Int (a, a1)+                (b, b1) a b where+  each = itraversalVL $ \f (a0, a1) ->+    (,) <$> f 0 a0 <*> f 1 a1+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a) (b, b, b) a b@+instance+  (a ~ a1, a ~ a2,+   b ~ b1, b ~ b2+  ) => Each Int (a, a1, a2)+                (b, b1, b2) a b where+  each = itraversalVL $ \f (a0, a1, a2) ->+    (,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a) (b, b, b, b) a b@+instance+  (a ~ a1, a ~ a2, a ~ a3,+   b ~ b1, b ~ b2, b ~ b3+  ) => Each Int (a, a1, a2, a3)+                (b, b1, b2, b3) a b where+  each = itraversalVL $ \f (a0, a1, a2, a3) ->+    (,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a) (b, b, b, b, b) a b@+instance+  (a ~ a1, a ~ a2, a ~ a3, a ~ a4,+   b ~ b1, b ~ b2, b ~ b3, b ~ b4+  ) => Each Int (a, a1, a2, a3, a4)+                (b, b1, b2, b3, b4) a b where+  each = itraversalVL $ \f (a0, a1, a2, a3, a4) ->+    (,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a) (b, b, b, b, b, b) a b@+instance+  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5,+   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5+  ) => Each Int (a, a1, a2, a3, a4, a5)+                (b, b1, b2, b3, b4, b5) a b where+  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5) ->+    (,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4+            <*> f 5 a5+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a) (b, b, b, b, b, b, b)+-- a b@+instance+  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6,+   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6+  ) => Each Int (a, a1, a2, a3, a4, a5, a6)+                (b, b1, b2, b3, b4, b5, b6) a b where+  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6) ->+    (,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4+             <*> f 5 a5 <*> f 6 a6+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a) (b, b, b, b, b, b,+-- b, b) a b@+instance+  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7,+   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7+  ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7)+                (b, b1, b2, b3, b4, b5, b6, b7) a b where+  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7) ->+    (,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4+              <*> f 5 a5 <*> f 6 a6 <*> f 7 a7+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a, a) (b, b, b, b, b,+-- b, b, b, b) a b@+instance+  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7, a ~ a8,+   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7, b ~ b8+  ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7, a8)+                (b, b1, b2, b3, b4, b5, b6, b7, b8) a b where+  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7, a8) ->+    (,,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4+               <*> f 5 a5 <*> f 6 a6 <*> f 7 a7 <*> f 8 a8+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' (a, a, a, a, a, a, a, a, a, a) (b, b, b, b,+-- b, b, b, b, b, b) a b@+instance+  (a ~ a1, a ~ a2, a ~ a3, a ~ a4, a ~ a5, a ~ a6, a ~ a7, a ~ a8, a ~ a9,+   b ~ b1, b ~ b2, b ~ b3, b ~ b4, b ~ b5, b ~ b6, b ~ b7, b ~ b8, b ~ b9+  ) => Each Int (a, a1, a2, a3, a4, a5, a6, a7, a8, a9)+                (b, b1, b2, b3, b4, b5, b6, b7, b8, b9) a b where+  each = itraversalVL $ \f (a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) ->+    (,,,,,,,,,) <$> f 0 a0 <*> f 1 a1 <*> f 2 a2 <*> f 3 a3 <*> f 4 a4+                <*> f 5 a5 <*> f 6 a6 <*> f 7 a7 <*> f 8 a8 <*> f 9 a9+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' ('Either' () ()) ('Either' a a) ('Either' b b) a+-- b@+instance+  (a ~ a', b ~ b'+  ) => Each (Either () ()) (Either a a') (Either b b') a b where+  each = itraversalVL $ \f -> \case+    Left  a -> Left  <$> f (Left ())  a+    Right a -> Right <$> f (Right ()) a+  {-# INLINE[1] each #-}++-- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'IxTraversal' (Either () ())+-- ('Complex' a) ('Complex' b) a b@+instance Each (Either () ()) (Complex a) (Complex b) a b where+  each = itraversalVL $ \f (a :+ b) -> (:+) <$> f (Left ()) a <*> f (Right ()) b+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' k ('Map' k a) ('Map' k b) a b@+instance k ~ k' => Each k (Map k a) (Map k' b) a b where+  -- traverseWithKey has best performance for all flavours for some reason.+  each = itraversalVL Map.traverseWithKey+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' ('IntMap' a) ('IntMap' b) a b@+instance Each Int (IntMap a) (IntMap b) a b where+  -- traverseWithKey has best performance for all flavours for some reason.+  each = itraversalVL IntMap.traverseWithKey+  {-# INLINE[1] each #-}++-- | @'each' :: 'IxTraversal' 'Int' [a] [b] a b@+instance Each Int [a] [b] a b++-- | @'each' :: 'IxTraversal' 'Int' (NonEmpty a) (NonEmpty b) a b@+instance Each Int (NonEmpty a) (NonEmpty b) a b++-- | @'each' :: 'IxTraversal' () ('Identity' a) ('Identity' b) a b@+instance Each () (Identity a) (Identity b) a b++-- | @'each' :: 'IxTraversal' () ('Maybe' a) ('Maybe' b) a b@+instance Each () (Maybe a) (Maybe b) a b++-- | @'each' :: 'IxTraversal' 'Int' ('Seq' a) ('Seq' b) a b@+instance Each Int (Seq a) (Seq b) a b++-- | @'each' :: 'IxTraversal' [Int] ('Tree' a) ('Tree' b) a b@+instance Each [Int] (Tree a) (Tree b) a b++-- | @'each' :: 'Ix' i => 'IxTraversal' i ('Array' i a) ('Array' i b) a b@+instance (Ix i, i ~ j) => Each i (Array i a) (Array j b) a b++-- $setup+-- >>> import Optics.Core
+ src/Optics/Empty/Core.hs view
@@ -0,0 +1,147 @@+-- |+-- Module: Optics.Empty.Core+-- Description: A 'Prism' for a type that may be '_Empty'.+--+-- This module defines the 'AsEmpty' class, which provides a 'Prism' for a type+-- that may be '_Empty'.+--+-- Note that orphan instances for this class are defined in the @Optics.Empty@+-- module from @optics-extra@, so if you are not simply depending on @optics@+-- you may wish to import that module instead.+--+-- >>> isn't _Empty [1,2,3]+-- True+--+-- >>> case Nothing of { Empty -> True; _ -> False }+-- True+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module Optics.Empty.Core+  ( AsEmpty(..)+  , pattern Empty+  ) where++import Control.Applicative (ZipList(..))+import Data.IntMap as IntMap+import Data.IntSet as IntSet+import Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Set as Set+import qualified Data.Sequence as Seq++import Data.Maybe.Optics+import Optics.AffineTraversal+import Optics.Internal.Utils+import Optics.Iso+import Optics.Fold+import Optics.Optic+import Optics.Prism+import Optics.Review++#if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS)+import GHC.Event+#endif++-- | Class for types that may be '_Empty'.+--+class AsEmpty a where+  -- |+  --+  -- >>> isn't _Empty [1,2,3]+  -- True+  _Empty :: Prism' a ()+  default _Empty :: (Monoid a, Eq a) => Prism' a ()+  _Empty = only mempty+  {-# INLINE _Empty #-}++-- | Pattern synonym for matching on any type with an 'AsEmpty' instance.+--+-- >>> case Nothing of { Empty -> True; _ -> False }+-- True+--+pattern Empty :: forall a. AsEmpty a => a+pattern Empty <- (has _Empty -> True) where+  Empty = review _Empty ()++{- Default Monoid instances -}+instance AsEmpty Ordering+instance AsEmpty ()+instance AsEmpty Any+instance AsEmpty All+#if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS)+instance AsEmpty Event+#endif+instance (Eq a, Num a) => AsEmpty (Product a)+instance (Eq a, Num a) => AsEmpty (Sum a)++instance AsEmpty (Maybe a) where+  _Empty = _Nothing+  {-# INLINE _Empty #-}++instance AsEmpty (Last a) where+  _Empty = nearly (Last Nothing) (isNothing .# getLast)+  {-# INLINE _Empty #-}++instance AsEmpty (First a) where+  _Empty = nearly (First Nothing) (isNothing .# getFirst)+  {-# INLINE _Empty #-}++instance AsEmpty a => AsEmpty (Dual a) where+  _Empty = iso getDual Dual % _Empty+  {-# INLINE _Empty #-}++instance (AsEmpty a, AsEmpty b) => AsEmpty (a, b) where+  _Empty = prism'+    (\() -> (review _Empty (), review _Empty ()))+    (\(s, s') -> case matching _Empty s of+        Right () -> case matching _Empty s' of+          Right () -> Just ()+          Left _   -> Nothing+        Left _   -> Nothing)+  {-# INLINE _Empty #-}++instance (AsEmpty a, AsEmpty b, AsEmpty c) => AsEmpty (a, b, c) where+  _Empty = prism'+    (\() -> (review _Empty (), review _Empty (), review _Empty ()))+    (\(s, s', s'') -> case matching _Empty s of+        Right () -> case matching _Empty s' of+          Right () -> case matching _Empty s'' of+            Right () -> Just ()+            Left _   -> Nothing+          Left _   -> Nothing+        Left _   -> Nothing)+  {-# INLINE _Empty #-}++instance AsEmpty [a] where+  _Empty = nearly [] Prelude.null+  {-# INLINE _Empty #-}++instance AsEmpty (ZipList a) where+  _Empty = nearly (ZipList []) (Prelude.null . getZipList)+  {-# INLINE _Empty #-}++instance AsEmpty (Map k a) where+  _Empty = nearly Map.empty Map.null+  {-# INLINE _Empty #-}++instance AsEmpty (IntMap a) where+  _Empty = nearly IntMap.empty IntMap.null+  {-# INLINE _Empty #-}++instance AsEmpty (Set a) where+  _Empty = nearly Set.empty Set.null+  {-# INLINE _Empty #-}++instance AsEmpty IntSet where+  _Empty = nearly IntSet.empty IntSet.null+  {-# INLINE _Empty #-}++instance AsEmpty (Seq.Seq a) where+  _Empty = nearly Seq.empty Seq.null+  {-# INLINE _Empty #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Fold.hs view
@@ -0,0 +1,652 @@+-- |+-- Module: Optics.Fold+-- Description: Extracts elements from a container.+--+-- A @'Fold' S A@ has the ability to extract some number of elements of type @A@+-- from a container of type @S@.  For example, 'toListOf' can be used to obtain+-- the contained elements as a list. Unlike a 'Optics.Traversal.Traversal',+-- there is no way to set or update elements.+--+-- This can be seen as a generalisation of 'traverse_', where the type @S@ does+-- not need to be a type constructor with @A@ as the last parameter.+--+-- A close relative is the 'Optics.AffineFold.AffineFold', which is a 'Fold'+-- that contains at most one element.+--+module Optics.Fold+  (+  -- * Formation+    Fold++  -- * Introduction+  , foldVL++  -- * Elimination+  , foldOf+  , foldMapOf+  , foldrOf+  , foldlOf'+  , toListOf+  , sequenceOf_+  , traverseOf_+  , forOf_++  -- * Computation+  --+  -- |+  --+  -- @+  -- 'traverseOf_' ('foldVL' f) ≡ f+  -- @++  -- * Additional introduction forms+  , folded+  , folding+  , foldring+  , unfolded++  -- * Additional elimination forms+  -- | See also 'Data.Set.Optics.setOf', which constructs a 'Data.Set.Set' from a 'Fold'.+  , has+  , hasn't+  , headOf+  , lastOf+  , andOf+  , orOf+  , allOf+  , anyOf+  , noneOf+  , productOf+  , sumOf+  , asumOf+  , msumOf+  , elemOf+  , notElemOf+  , lengthOf+  , maximumOf+  , minimumOf+  , maximumByOf+  , minimumByOf+  , findOf+  , findMOf+  , lookupOf++  -- * Combinators+  , pre+  , backwards_++  -- * Semigroup structure+  , summing+  , failing++  -- * Subtyping+  , A_Fold+  -- | <<diagrams/Fold.png Fold in the optics hierarchy>>+  )+  where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Monad+import Data.Foldable+import Data.Function+import Data.Monoid++import Optics.Internal.Bi+import Optics.Internal.Fold+import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Utils+import Optics.AffineFold++-- | Type synonym for a fold.+type Fold s a = Optic' A_Fold NoIx s a++-- | Obtain a 'Fold' by lifting 'traverse_' like function.+--+-- @+-- 'foldVL' '.' 'traverseOf_' ≡ 'id'+-- 'traverseOf_' '.' 'foldVL' ≡ 'id'+-- @+foldVL+  :: (forall f. Applicative f => (a -> f u) -> s -> f v)+  -> Fold s a+foldVL f = Optic (foldVL__ f)+{-# INLINE foldVL #-}++-- | Combine the results of a fold using a monoid.+foldOf :: (Is k A_Fold, Monoid a) => Optic' k is s a -> s -> a+foldOf o = foldMapOf o id+{-# INLINE foldOf #-}++-- | Fold via embedding into a monoid.+foldMapOf :: (Is k A_Fold, Monoid m) => Optic' k is s a -> (a -> m) -> s -> m+foldMapOf o = runForget #. getOptic (castOptic @A_Fold o) .# Forget+{-# INLINE foldMapOf #-}++-- | Fold right-associatively.+foldrOf :: Is k A_Fold => Optic' k is s a -> (a -> r -> r) -> r -> s -> r+foldrOf o = \arr r s -> (\e -> appEndo e r) $ foldMapOf o (Endo #. arr) s+{-# INLINE foldrOf #-}++-- | Fold left-associatively, and strictly.+foldlOf' :: Is k A_Fold => Optic' k is s a -> (r -> a -> r) -> r -> s -> r+foldlOf' o = \rar r0 s -> foldrOf o (\a rr r -> rr $! rar r a) id s r0+{-# INLINE foldlOf' #-}++-- | Fold to a list.+toListOf :: Is k A_Fold => Optic' k is s a -> s -> [a]+toListOf o = foldrOf o (:) []+{-# INLINE toListOf #-}++----------------------------------------++-- | Traverse over all of the targets of a 'Fold', computing an+-- 'Applicative'-based answer, but unlike 'Optics.Traversal.traverseOf' do not+-- construct a new structure. 'traverseOf_' generalizes+-- 'Data.Foldable.traverse_' to work over any 'Fold'.+--+-- >>> traverseOf_ each putStrLn ("hello","world")+-- hello+-- world+--+-- @+-- 'Data.Foldable.traverse_' ≡ 'traverseOf_' 'folded'+-- @+traverseOf_+  :: (Is k A_Fold, Applicative f)+  => Optic' k is s a+  -> (a -> f r) -> s -> f ()+traverseOf_ o = \f -> runTraversed . foldMapOf o (Traversed #. f)+{-# INLINE traverseOf_ #-}++-- | A version of 'traverseOf_' with the arguments flipped.+forOf_+  :: (Is k A_Fold, Applicative f)+  => Optic' k is s a+  -> s -> (a -> f r) -> f ()+forOf_ = flip . traverseOf_+{-# INLINE forOf_ #-}++-- | Evaluate each action in observed by a 'Fold' on a structure from left to+-- right, ignoring the results.+--+-- @+-- 'sequenceA_' ≡ 'sequenceOf_' 'folded'+-- @+--+-- >>> sequenceOf_ each (putStrLn "hello",putStrLn "world")+-- hello+-- world+sequenceOf_+  :: (Is k A_Fold, Applicative f)+  => Optic' k is s (f a)+  -> s -> f ()+sequenceOf_ o = runTraversed . foldMapOf o Traversed+{-# INLINE sequenceOf_ #-}++----------------------------------------++-- | Fold via the 'Foldable' class.+folded :: Foldable f => Fold (f a) a+folded = Optic folded__+{-# INLINE folded #-}++-- | Obtain a 'Fold' by lifting an operation that returns a 'Foldable' result.+--+-- This can be useful to lift operations from @Data.List@ and elsewhere into a+-- 'Fold'.+--+-- >>> toListOf (folding tail) [1,2,3,4]+-- [2,3,4]+folding :: Foldable f => (s -> f a) -> Fold s a+folding f = Optic (contrafirst f . foldVL__ traverse_)+{-# INLINE folding #-}++-- | Obtain a 'Fold' by lifting 'foldr' like function.+--+-- >>> toListOf (foldring foldr) [1,2,3,4]+-- [1,2,3,4]+foldring+  :: (forall f. Applicative f => (a -> f u -> f u) -> f v -> s -> f w)+  -> Fold s a+foldring fr = Optic (foldring__ fr)+{-# INLINE foldring #-}++-- | Build a 'Fold' that unfolds its values from a seed.+--+-- @+-- 'Prelude.unfoldr' ≡ 'toListOf' '.' 'unfolded'+-- @+--+-- >>> toListOf (unfolded $ \b -> if b == 0 then Nothing else Just (b, b - 1)) 10+-- [10,9,8,7,6,5,4,3,2,1]+unfolded :: (s -> Maybe (a, s)) -> Fold s a+unfolded step = foldVL $ \f -> fix $ \loop b ->+  case step b of+    Just (a, b') -> f a *> loop b'+    Nothing      -> pure ()+{-# INLINE unfolded #-}++-- | Convert a fold to an 'AffineFold' that visits the first element of the+-- original fold.+pre :: Is k A_Fold => Optic' k is s a -> AffineFold s a+pre = afolding . headOf+{-# INLINE pre #-}++-- | This allows you to traverse the elements of a 'Fold' in the opposite order.+backwards_+  :: Is k A_Fold+  => Optic' k is s a+  -> Fold s a+backwards_ o = foldVL $ \f -> forwards #. traverseOf_ o (Backwards #. f)+{-# INLINE backwards_ #-}++-- | Return entries of the first 'Fold', then the second one.+--+-- >>> toListOf (_1 % ix 0 `summing` _2 % ix 1) ([1,2], [4,7,1])+-- [1,7]+--+summing+  :: (Is k A_Fold, Is l A_Fold)+  => Optic' k is s a+  -> Optic' l js s a+  -> Fold s a+summing a b = foldVL $ \f s -> traverseOf_ a f s *> traverseOf_ b f s+infixr 6 `summing` -- Same as (<>)+{-# INLINE summing #-}++-- | Try the first 'Fold'. If it returns no entries, try the second one.+failing+  :: (Is k A_Fold, Is l A_Fold)+  => Optic' k is s a+  -> Optic' l js s a+  -> Fold s a+failing a b = foldVL $ \f s ->+  let OrT visited fu = traverseOf_ a (wrapOrT . f) s+  in if visited+     then fu+     else traverseOf_ b f s+infixl 3 `failing` -- Same as (<|>)+{-# INLINE failing #-}++----------------------------------------+-- Special folds++-- | Check to see if this optic matches 1 or more entries.+--+-- >>> has _Left (Left 12)+-- True+--+-- >>> has _Right (Left 12)+-- False+--+-- This will always return 'True' for a 'Optics.Lens.Lens' or+-- 'Optics.Getter.Getter'.+--+-- >>> has _1 ("hello","world")+-- True+has :: Is k A_Fold => Optic' k is s a -> s -> Bool+has o = getAny #. foldMapOf o (\_ -> Any True)+{-# INLINE has #-}++-- | Check to see if this 'Fold' or 'Optics.Traversal.Traversal' has+-- no matches.+--+-- >>> hasn't _Left (Right 12)+-- True+--+-- >>> hasn't _Left (Left 12)+-- False+hasn't :: Is k A_Fold => Optic' k is s a -> s -> Bool+hasn't o = getAll #. foldMapOf o (\_ -> All False)+{-# INLINE hasn't #-}++-- | Retrieve the first entry of a 'Fold'.+--+-- >>> headOf folded [1..10]+-- Just 1+--+-- >>> headOf each (1,2)+-- Just 1+headOf :: Is k A_Fold => Optic' k is s a -> s -> Maybe a+headOf o = getLeftmost . foldMapOf o LLeaf+{-# INLINE headOf #-}++-- | Retrieve the last entry of a 'Fold'.+--+-- >>> lastOf folded [1..10]+-- Just 10+--+-- >>> lastOf each (1,2)+-- Just 2+lastOf :: Is k A_Fold => Optic' k is s a -> s -> Maybe a+lastOf o = getRightmost . foldMapOf o RLeaf+{-# INLINE lastOf #-}++-- | Returns 'True' if every target of a 'Fold' is 'True'.+--+-- >>> andOf each (True, False)+-- False+-- >>> andOf each (True, True)+-- True+--+-- @+-- 'Data.Foldable.and' ≡ 'andOf' 'folded'+-- @+andOf :: Is k A_Fold => Optic' k is s Bool -> s -> Bool+andOf o = getAll #. foldMapOf o All+{-# INLINE andOf #-}++-- | Returns 'True' if any target of a 'Fold' is 'True'.+--+-- >>> orOf each (True, False)+-- True+-- >>> orOf each (False, False)+-- False+--+-- @+-- 'Data.Foldable.or' ≡ 'orOf' 'folded'+-- @+orOf :: Is k A_Fold => Optic' k is s Bool -> s -> Bool+orOf o = getAny #. foldMapOf o Any+{-# INLINE orOf #-}++-- | Returns 'True' if any target of a 'Fold' satisfies a predicate.+--+-- >>> anyOf each (=='x') ('x','y')+-- True+anyOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Bool+anyOf o = \f -> getAny #. foldMapOf o (Any #. f)+{-# INLINE anyOf #-}++-- | Returns 'True' if every target of a 'Fold' satisfies a predicate.+--+-- >>> allOf each (>=3) (4,5)+-- True+-- >>> allOf folded (>=2) [1..10]+-- False+--+-- @+-- 'Data.Foldable.all' ≡ 'allOf' 'folded'+-- @+allOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Bool+allOf o = \f -> getAll #. foldMapOf o (All #. f)+{-# INLINE allOf #-}++-- | Returns 'True' only if no targets of a 'Fold' satisfy a predicate.+--+-- >>> noneOf each (not . isn't _Nothing) (Just 3, Just 4, Just 5)+-- True+-- >>> noneOf (folded % folded) (<10) [[13,99,20],[3,71,42]]+-- False+noneOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Bool+noneOf o = \f -> not . anyOf o f+{-# INLINE noneOf #-}++-- | Calculate the 'Product' of every number targeted by a 'Fold'.+--+-- >>> productOf each (4,5)+-- 20+-- >>> productOf folded [1,2,3,4,5]+-- 120+--+-- @+-- 'Data.Foldable.product' ≡ 'productOf' 'folded'+-- @+--+-- This operation may be more strict than you would expect. If you want a lazier+-- version use @\\o -> 'getProduct' '.' 'foldMapOf' o 'Product'@.+productOf :: (Is k A_Fold, Num a) => Optic' k is s a -> s -> a+productOf o = foldlOf' o (*) 1+{-# INLINE productOf #-}++-- | Calculate the 'Sum' of every number targeted by a 'Fold'.+--+-- >>> sumOf each (5,6)+-- 11+-- >>> sumOf folded [1,2,3,4]+-- 10+-- >>> sumOf (folded % each) [(1,2),(3,4)]+-- 10+--+-- @+-- 'Data.Foldable.sum' ≡ 'sumOf' 'folded'+-- @+--+-- This operation may be more strict than you would expect. If you want a lazier+-- version use @\\o -> 'getSum' '.' 'foldMapOf' o 'Sum'@+sumOf :: (Is k A_Fold, Num a) => Optic' k is s a -> s -> a+sumOf o = foldlOf' o (+) 0+{-# INLINE sumOf #-}++-- | The sum of a collection of actions.+--+-- >>> asumOf each ("hello","world")+-- "helloworld"+--+-- >>> asumOf each (Nothing, Just "hello", Nothing)+-- Just "hello"+--+-- @+-- 'asum' ≡ 'asumOf' 'folded'+-- @+asumOf :: (Is k A_Fold, Alternative f) => Optic' k is s (f a) -> s -> f a+asumOf o = foldrOf o (<|>) empty+{-# INLINE asumOf #-}++-- | The sum of a collection of actions.+--+-- >>> msumOf each ("hello","world")+-- "helloworld"+--+-- >>> msumOf each (Nothing, Just "hello", Nothing)+-- Just "hello"+--+-- @+-- 'msum' ≡ 'msumOf' 'folded'+-- @+msumOf :: (Is k A_Fold, MonadPlus m) => Optic' k is s (m a) -> s -> m a+msumOf o = foldrOf o mplus mzero+{-# INLINE msumOf #-}++-- | Does the element occur anywhere within a given 'Fold' of the structure?+--+-- >>> elemOf each "hello" ("hello","world")+-- True+--+-- @+-- 'elem' ≡ 'elemOf' 'folded'+-- @+elemOf :: (Is k A_Fold, Eq a) => Optic' k is s a -> a -> s -> Bool+elemOf o = anyOf o . (==)+{-# INLINE elemOf #-}++-- | Does the element not occur anywhere within a given 'Fold' of the structure?+--+-- >>> notElemOf each 'd' ('a','b','c')+-- True+--+-- >>> notElemOf each 'a' ('a','b','c')+-- False+--+-- @+-- 'notElem' ≡ 'notElemOf' 'folded'+-- @+notElemOf :: (Is k A_Fold, Eq a) => Optic' k is s a -> a -> s -> Bool+notElemOf o = allOf o . (/=)+{-# INLINE notElemOf #-}++-- | Calculate the number of targets there are for a 'Fold' in a given+-- container.+--+-- /Note:/ This can be rather inefficient for large containers and just like+-- 'length', this will not terminate for infinite folds.+--+-- @+-- 'length' ≡ 'lengthOf' 'folded'+-- @+--+-- >>> lengthOf _1 ("hello",())+-- 1+--+-- >>> lengthOf folded [1..10]+-- 10+--+-- >>> lengthOf (folded % folded) [[1,2],[3,4],[5,6]]+-- 6+lengthOf :: Is k A_Fold => Optic' k is s a -> s -> Int+lengthOf o = foldlOf' o (\ n _ -> 1 + n) 0+{-# INLINE lengthOf #-}++-- | Obtain the maximum element (if any) targeted by a 'Fold' safely.+--+-- Note: 'maximumOf' on a valid 'Optics.Iso.Iso', 'Optics.Lens.Lens'+-- or 'Optics.Getter.Getter' will always return 'Just' a value.+--+-- >>> maximumOf folded [1..10]+-- Just 10+--+-- >>> maximumOf folded []+-- Nothing+--+-- >>> maximumOf (folded % filtered even) [1,4,3,6,7,9,2]+-- Just 6+--+-- @+-- 'maximum' ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'maximumOf' 'folded'+-- @+--+-- In the interest of efficiency, This operation has semantics more strict than+-- strictly necessary.  @\\o -> 'Data.Semigroup.getMax' . 'foldMapOf' o 'Data.Semigroup.Max'@ has lazier+-- semantics but could leak memory.+maximumOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Maybe a+maximumOf o = foldlOf' o mf Nothing where+  mf Nothing y  = Just $! y+  mf (Just x) y = Just $! max x y+{-# INLINE maximumOf #-}++-- | Obtain the minimum element (if any) targeted by a 'Fold' safely.+--+-- Note: 'minimumOf' on a valid 'Optics.Iso.Iso', 'Optics.Lens.Lens'+-- or 'Optics.Getter.Getter' will always return 'Just' a value.+--+-- >>> minimumOf folded [1..10]+-- Just 1+--+-- >>> minimumOf folded []+-- Nothing+--+-- >>> minimumOf (folded % filtered even) [1,4,3,6,7,9,2]+-- Just 2+--+-- @+-- 'minimum' ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumOf' 'folded'+-- @+--+-- In the interest of efficiency, This operation has semantics more strict than+-- strictly necessary.  @\\o -> 'Data.Semigroup.getMin' . 'foldMapOf' o 'Data.Semigroup.Min'@ has lazier+-- semantics but could leak memory.+minimumOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Maybe a+minimumOf o = foldlOf' o mf Nothing where+  mf Nothing y = Just $! y+  mf (Just x) y = Just $! min x y+{-# INLINE minimumOf #-}++-- | Obtain the maximum element (if any) targeted by a 'Fold' according to a+-- user supplied 'Ordering'.+--+-- >>> maximumByOf folded (compare `on` length) ["mustard","relish","ham"]+-- Just "mustard"+--+-- In the interest of efficiency, This operation has semantics more strict than+-- strictly necessary.+--+-- @+-- 'Data.Foldable.maximumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'maximumByOf' 'folded' cmp+-- @+maximumByOf :: Is k A_Fold => Optic' k is s a -> (a -> a -> Ordering) -> s -> Maybe a+maximumByOf o = \cmp ->+  let mf Nothing y  = Just $! y+      mf (Just x) y = Just $! if cmp x y == GT then x else y+  in foldlOf' o mf Nothing+{-# INLINE maximumByOf #-}++-- | Obtain the minimum element (if any) targeted by a 'Fold' according to a+-- user supplied 'Ordering'.+--+-- In the interest of efficiency, This operation has semantics more strict than+-- strictly necessary.+--+-- >>> minimumByOf folded (compare `on` length) ["mustard","relish","ham"]+-- Just "ham"+--+-- @+-- 'minimumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumByOf' 'folded' cmp+-- @+minimumByOf :: Is k A_Fold => Optic' k is s a -> (a -> a -> Ordering) -> s -> Maybe a+minimumByOf o = \cmp ->+  let mf Nothing y  = Just $! y+      mf (Just x) y = Just $! if cmp x y == GT then y else x+  in foldlOf' o mf Nothing+{-# INLINE minimumByOf #-}++-- | The 'findOf' function takes a 'Fold', a predicate and a structure and+-- returns the leftmost element of the structure matching the predicate, or+-- 'Nothing' if there is no such element.+--+-- >>> findOf each even (1,3,4,6)+-- Just 4+--+-- >>> findOf folded even [1,3,5,7]+-- Nothing+--+-- @+-- 'Data.Foldable.find' ≡ 'findOf' 'folded'+-- @+findOf :: Is k A_Fold => Optic' k is s a -> (a -> Bool) -> s -> Maybe a+findOf o = \f -> foldrOf o (\a y -> if f a then Just a else y) Nothing+{-# INLINE findOf #-}++-- | The 'findMOf' function takes a 'Fold', a monadic predicate and a structure+-- and returns in the monad the leftmost element of the structure matching the+-- predicate, or 'Nothing' if there is no such element.+--+-- >>> findMOf each (\x -> print ("Checking " ++ show x) >> return (even x)) (1,3,4,6)+-- "Checking 1"+-- "Checking 3"+-- "Checking 4"+-- Just 4+--+-- >>> findMOf each (\x -> print ("Checking " ++ show x) >> return (even x)) (1,3,5,7)+-- "Checking 1"+-- "Checking 3"+-- "Checking 5"+-- "Checking 7"+-- Nothing+--+-- @+-- 'findMOf' 'folded' :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m (Maybe a)+-- @+findMOf :: (Is k A_Fold, Monad m) => Optic' k is s a -> (a -> m Bool) -> s -> m (Maybe a)+findMOf o = \f -> foldrOf o+  (\a y -> f a >>= \r -> if r then pure (Just a) else y)+  (pure Nothing)+{-# INLINE findMOf #-}++-- | The 'lookupOf' function takes a 'Fold', a key, and a structure containing+-- key/value pairs.  It returns the first value corresponding to the given+-- key. This function generalizes 'lookup' to work on an arbitrary 'Fold'+-- instead of lists.+--+-- >>> lookupOf folded 4 [(2, 'a'), (4, 'b'), (4, 'c')]+-- Just 'b'+--+-- >>> lookupOf folded 2 [(2, 'a'), (4, 'b'), (4, 'c')]+-- Just 'a'+lookupOf :: (Is k A_Fold, Eq a) => Optic' k is s (a, v) -> a -> s -> Maybe v+lookupOf o a = foldrOf o (\(a', v) next -> if a == a' then Just v else next) Nothing+{-# INLINE lookupOf #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Getter.hs view
@@ -0,0 +1,62 @@+-- |+-- Module: Optics.Getter+-- Description: A function considered as an 'Optic'.+--+-- A 'Getter' is simply a function considered as an 'Optic'.+--+-- Given a function @f :: S -> A@, we can convert it into a+-- @'Getter' S A@ using 'to', and convert back to a function using 'view'.+--+-- This is typically useful not when you have functions/'Getter's+-- alone, but when you are composing multiple 'Optic's to produce a+-- 'Getter'.+--+module Optics.Getter+  (+  -- * Formation+   Getter++  -- * Introduction+  , to++  -- * Elimination+  , view+  , views++  -- * Computation+  -- |+  --+  -- @+  -- 'view' ('to' f) ≡ f+  -- @++  -- * Well-formedness+  -- | A 'Getter' is not subject to any laws.++  -- * Subtyping+  , A_Getter+  -- | <<diagrams/Getter.png Getter in the optics hierarchy>>+  )+  where++import Optics.Internal.Bi+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for a getter.+type Getter s a = Optic' A_Getter NoIx s a++-- | View the value pointed to by a getter.+view :: Is k A_Getter => Optic' k is s a -> s -> a+view o = views o id+{-# INLINE view #-}++-- | View the function of the value pointed to by a getter.+views :: Is k A_Getter => Optic' k is s a -> (a -> r) -> s -> r+views o = \f -> runForget $ getOptic (castOptic @A_Getter o) (Forget f)+{-# INLINE views #-}++-- | Build a getter from a function.+to :: (s -> a) -> Getter s a+to f = Optic (lmap f . rphantom)+{-# INLINE to #-}
+ src/Optics/Indexed/Core.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE DataKinds #-}+-- |+-- Module: Optics.Indexed.Core+-- Description: Core definitions for indexed optics.+--+-- This module defines basic functionality for indexed optics.  See the "Indexed+-- optics" section of the overview documentation in the @Optics@ module of the+-- main @optics@ package for more details.+--+module Optics.Indexed.Core+  (+  -- * Class for optic kinds that can be indexed+    IxOptic(..)++  , conjoined++  -- * Composition of indexed optics+  , (%)+  , (<%>)+  , (%>)+  , (<%)+  , reindexed+  , icompose+  , icompose3+  , icompose4+  , icompose5+  , icomposeN++    -- * Indexed optic flavours+  , module Optics.IxAffineFold+  , module Optics.IxAffineTraversal+  , module Optics.IxFold+  , module Optics.IxGetter+  , module Optics.IxLens+  , module Optics.IxSetter+  , module Optics.IxTraversal++  -- * Functors with index+  , FunctorWithIndex (..)+  -- ** Foldable with index+  , FoldableWithIndex (..)+  , itraverse_+  , ifor_+  -- ** Traversable with index+  , TraversableWithIndex (..)+  , ifor+  ) where++import Optics.Internal.Indexed+import Optics.Internal.Optic+import Optics.Internal.Profunctor++import Optics.AffineFold+import Optics.AffineTraversal+import Optics.Fold+import Optics.Getter+import Optics.IxAffineFold+import Optics.IxAffineTraversal+import Optics.IxFold+import Optics.IxGetter+import Optics.IxLens+import Optics.IxSetter+import Optics.IxTraversal+import Optics.Lens+import Optics.Setter+import Optics.Traversal++-- | Compose two indexed optics. Their indices are composed as a pair.+--+-- >>> itoListOf (ifolded <%> ifolded) ["foo", "bar"]+-- [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')]+--+infixl 9 <%>+(<%>)+  :: (m ~ Join k l, Is k m, Is l m, IxOptic m s t a b,+      is `HasSingleIndex` i, js `HasSingleIndex` j)+  => Optic k is              s t u v+  -> Optic l js              u v a b+  -> Optic m (WithIx (i, j)) s t a b+o <%> o' = icompose (,) (o % o')+{-# INLINE (<%>) #-}++-- | Compose two indexed optics and drop indices of the left one. (If you want+-- to compose a non-indexed and an indexed optic, you can just use ('%').)+--+-- >>> itoListOf (ifolded %> ifolded) ["foo", "bar"]+-- [(0,'f'),(1,'o'),(2,'o'),(0,'b'),(1,'a'),(2,'r')]+--+infixl 9 %>+(%>)+  :: (m ~ Join k l, Is k m, Is l m, IxOptic k s t u v, NonEmptyIndices is)+  => Optic k is s t u v+  -> Optic l js u v a b+  -> Optic m js s t a b+o %> o' = noIx o % o'+{-# INLINE (%>) #-}++-- | Compose two indexed optics and drop indices of the right one. (If you want+-- to compose an indexed and a non-indexed optic, you can just use ('%').)+--+-- >>> itoListOf (ifolded <% ifolded) ["foo", "bar"]+-- [(0,'f'),(0,'o'),(0,'o'),(1,'b'),(1,'a'),(1,'r')]+--+infixl 9 <%+(<%)+  :: (m ~ Join k l, Is l m, Is k m, IxOptic l u v a b, NonEmptyIndices js)+  => Optic k is s t u v+  -> Optic l js u v a b+  -> Optic m is s t a b+o <% o' = o % noIx o'+{-# INLINE (<%) #-}++-- | Remap the index.+--+-- >>> itoListOf (reindexed succ ifolded) "foo"+-- [(1,'f'),(2,'o'),(3,'o')]+--+-- >>> itoListOf (ifolded %& reindexed succ) "foo"+-- [(1,'f'),(2,'o'),(3,'o')]+--+reindexed+  :: is `HasSingleIndex` i+  => (i -> j)+  -> Optic k is         s t a b+  -> Optic k (WithIx j) s t a b+reindexed = icomposeN+{-# INLINE reindexed #-}++-- | Flatten indices obtained from two indexed optics.+--+-- >>> itoListOf (ifolded % ifolded %& icompose (,)) ["foo","bar"]+-- [((0,0),'f'),((0,1),'o'),((0,2),'o'),((1,0),'b'),((1,1),'a'),((1,2),'r')]+--+icompose+  :: (i -> j -> ix)+  -> Optic k '[i, j]     s t a b+  -> Optic k (WithIx ix) s t a b+icompose = icomposeN+{-# INLINE icompose #-}++-- | Flatten indices obtained from three indexed optics.+--+-- >>> itoListOf (ifolded % ifolded % ifolded %& icompose3 (,,)) [["foo","bar"],["xyz"]]+-- [((0,0,0),'f'),((0,0,1),'o'),((0,0,2),'o'),((0,1,0),'b'),((0,1,1),'a'),((0,1,2),'r'),((1,0,0),'x'),((1,0,1),'y'),((1,0,2),'z')]+--+icompose3+  :: (i1 -> i2 -> i3 -> ix)+  -> Optic k '[i1, i2, i3] s t a b+  -> Optic k (WithIx ix)   s t a b+icompose3 = icomposeN+{-# INLINE icompose3 #-}++-- | Flatten indices obtained from four indexed optics.+icompose4+  :: (i1 -> i2 -> i3 -> i4 -> ix)+  -> Optic k '[i1, i2, i3, i4] s t a b+  -> Optic k (WithIx ix)       s t a b+icompose4 = icomposeN+{-# INLINE icompose4 #-}++-- | Flatten indices obtained from five indexed optics.+icompose5+  :: (i1 -> i2 -> i3 -> i4 -> i5 -> ix)+  -> Optic k '[i1, i2, i3, i4, i5] s t a b+  -> Optic k (WithIx ix)           s t a b+icompose5 = icomposeN+{-# INLINE icompose5 #-}++-- | Flatten indices obtained from arbitrary number of indexed optics.+icomposeN+  :: forall k i is s t a b+  . (CurryCompose is, NonEmptyIndices is)+  => Curry is i+  -> Optic k is         s t a b+  -> Optic k (WithIx i) s t a b+icomposeN f (Optic o) = Optic (ixcontramap (\ij -> composeN @is ij f) . o)+{-# INLINE icomposeN #-}++----------------------------------------+-- IxOptic++-- | Class for optic kinds that can have indices.+class IxOptic k s t a b where+  -- | Convert an indexed optic to its unindexed equivalent.+  noIx+    :: NonEmptyIndices is+    => Optic k is   s t a b+    -> Optic k NoIx s t a b++instance (s ~ t, a ~ b) => IxOptic A_Getter s t a b where+  noIx o = to (view o)+  {-# INLINE noIx #-}++instance IxOptic A_Lens s t a b where+  noIx o = lensVL (toLensVL o)+  {-# INLINE noIx #-}++instance IxOptic An_AffineTraversal s t a b where+  noIx o = atraversalVL (toAtraversalVL o)+  {-# INLINE noIx #-}++instance (s ~ t, a ~ b) => IxOptic An_AffineFold s t a b where+  noIx o = afolding (preview o)+  {-# INLINE noIx #-}++instance IxOptic A_Traversal s t a b where+  noIx o = traversalVL (traverseOf o)+  {-# INLINE noIx #-}++instance (s ~ t, a ~ b) => IxOptic A_Fold s t a b where+  noIx o = foldVL (traverseOf_ o)+  {-# INLINE noIx #-}++instance IxOptic A_Setter s t a b where+  noIx o = sets (over o)+  {-# INLINE noIx #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Internal/Bi.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Classes for co- and contravariant bifunctors.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Bi where++import Data.Void++import Optics.Internal.Profunctor++-- | Class for (covariant) bifunctors.+class Bifunctor p where+  bimap  :: (a -> b) -> (c -> d) -> p i a c -> p i b d+  first  :: (a -> b)             -> p i a c -> p i b c+  second ::             (c -> d) -> p i a c -> p i a d++-- | Class for contravariant bifunctors.+class Bicontravariant p where+  contrabimap  :: (b -> a) -> (d -> c) -> p i a c -> p i b d+  contrafirst  :: (b -> a)             -> p i a c -> p i b c+  contrasecond ::             (c -> b) -> p i a b -> p i a c++instance Bicontravariant (Forget r) where+  contrabimap  f _g (Forget k) = Forget (k . f)+  contrafirst  f    (Forget k) = Forget (k . f)+  contrasecond   _g (Forget k) = Forget k+  {-# INLINE contrabimap #-}+  {-# INLINE contrafirst #-}+  {-# INLINE contrasecond #-}++instance Bicontravariant (ForgetM r) where+  contrabimap  f _g (ForgetM k) = ForgetM (k . f)+  contrafirst  f    (ForgetM k) = ForgetM (k . f)+  contrasecond   _g (ForgetM k) = ForgetM k+  {-# INLINE contrabimap #-}+  {-# INLINE contrafirst #-}+  {-# INLINE contrasecond #-}++instance Bicontravariant (IxForget r) where+  contrabimap  f _g (IxForget k) = IxForget (\i -> k i . f)+  contrafirst  f    (IxForget k) = IxForget (\i -> k i . f)+  contrasecond   _g (IxForget k) = IxForget k+  {-# INLINE contrabimap #-}+  {-# INLINE contrafirst #-}+  {-# INLINE contrasecond #-}++instance Bicontravariant (IxForgetM r) where+  contrabimap  f _g (IxForgetM k) = IxForgetM (\i -> k i . f)+  contrafirst  f    (IxForgetM k) = IxForgetM (\i -> k i . f)+  contrasecond   _g (IxForgetM k) = IxForgetM k+  {-# INLINE contrabimap #-}+  {-# INLINE contrafirst #-}+  {-# INLINE contrasecond #-}++----------------------------------------++-- | If @p@ is a 'Profunctor' and a 'Bifunctor' then its left parameter must be+-- phantom.+lphantom :: (Profunctor p, Bifunctor p) => p i a c -> p i b c+lphantom = first absurd . lmap absurd+{-# INLINE lphantom #-}++-- | If @p@ is a 'Profunctor' and 'Bicontravariant' then its right parameter+-- must be phantom.+rphantom :: (Profunctor p, Bicontravariant p) => p i c a -> p i c b+rphantom = rmap absurd . contrasecond absurd+{-# INLINE rphantom #-}
+ src/Optics/Internal/Concrete.hs view
@@ -0,0 +1,117 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Concrete representation types for certain optics.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Concrete+  ( Exchange(..)+  , Store(..)+  , Market(..)+  , AffineMarket(..)+  ) where++import Data.Bifunctor++import Optics.Internal.Profunctor++-- | Type to represent the components of an isomorphism.+data Exchange a b i s t =+  Exchange (s -> a) (b -> t)++instance Profunctor (Exchange a b) where+  dimap ss tt (Exchange sa bt) = Exchange (sa . ss) (tt . bt)+  lmap  ss    (Exchange sa bt) = Exchange (sa . ss) bt+  rmap     tt (Exchange sa bt) = Exchange sa        (tt . bt)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++-- | Type to represent the components of a lens.+data Store a b i s t = Store (s -> a) (s -> b -> t)++instance Profunctor (Store a b) where+  dimap f g (Store get set) = Store (get . f) (\s -> g . set (f s))+  lmap  f   (Store get set) = Store (get . f) (\s -> set (f s))+  rmap    g (Store get set) = Store get       (\s -> g . set s)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Strong (Store a b) where+  first' (Store get set) = Store (get . fst) (\(s, c) b -> (set s b, c))+  second' (Store get set) = Store (get . snd) (\(c, s) b -> (c, set s b))+  {-# INLINE first' #-}+  {-# INLINE second' #-}++-- | Type to represent the components of a prism.+data Market a b i s t = Market (b -> t) (s -> Either t a)++instance Functor (Market a b i s) where+  fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)+  {-# INLINE fmap #-}++instance Profunctor (Market a b) where+  dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)+  lmap  f   (Market bt seta) = Market bt (seta . f)+  rmap    g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Choice (Market a b) where+  left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of+    Left s -> case seta s of+      Left t -> Left (Left t)+      Right a -> Right a+    Right c -> Left (Right c)+  right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of+    Left c -> Left (Left c)+    Right s -> case seta s of+      Left t -> Left (Right t)+      Right a -> Right a+  {-# INLINE left' #-}+  {-# INLINE right' #-}++-- | Type to represent the components of an affine traversal.+data AffineMarket a b i s t = AffineMarket (s -> b -> t) (s -> Either t a)++instance Profunctor (AffineMarket a b) where+  dimap f g (AffineMarket sbt seta) = AffineMarket+    (\s b -> g (sbt (f s) b))+    (either (Left . g) Right . seta . f)+  lmap f (AffineMarket sbt seta) = AffineMarket+    (\s b -> sbt (f s) b)+    (seta . f)+  rmap g (AffineMarket sbt seta) = AffineMarket+    (\s b -> g (sbt s b))+    (either (Left . g) Right . seta)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Choice (AffineMarket a b) where+  left' (AffineMarket sbt seta) = AffineMarket+    (\e b -> bimap (flip sbt b) id e)+    (\sc -> case sc of+      Left s -> bimap Left id (seta s)+      Right c -> Left (Right c))+  right' (AffineMarket sbt seta) = AffineMarket+    (\e b -> bimap id (flip sbt b) e)+    (\sc -> case sc of+      Left c -> Left (Left c)+      Right s -> bimap Right id (seta s))+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Strong (AffineMarket a b) where+  first' (AffineMarket sbt seta) = AffineMarket+    (\(a, c) b -> (sbt a b, c))+    (\(a, c) -> bimap (,c) id (seta a))+  second' (AffineMarket sbt seta) = AffineMarket+    (\(c, a) b -> (c, sbt a b))+    (\(c, a) -> bimap (c,) id (seta a))+  {-# INLINE first' #-}+  {-# INLINE second' #-}++instance Visiting (AffineMarket a b)
+ src/Optics/Internal/Fold.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Internal implementation details of folds.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Fold where++import Data.Functor+import Data.Foldable+import Data.Maybe+import qualified Data.Semigroup as SG++import Optics.Internal.Bi+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Internal implementation of 'Optics.Fold.foldVL'.+foldVL__+  :: (Bicontravariant p, Traversing p)+  => (forall f. Applicative f => (a -> f u) -> s -> f v)+  -> Optic__ p i i s t a b+foldVL__ f = rphantom . wander f . rphantom+{-# INLINE foldVL__ #-}++-- | Internal implementation of 'Optics.Fold.folded'.+folded__+  :: (Bicontravariant p, Traversing p, Foldable f)+  => Optic__ p i i (f a) (f b) a b+folded__ = foldVL__ traverse_+{-# INLINE folded__ #-}++-- | Internal implementation of 'Optics.Fold.foldring'.+foldring__+  :: (Bicontravariant p, Traversing p)+  => (forall f. Applicative f => (a -> f u -> f u) -> f v -> s -> f w)+  -> Optic__ p i i s t a b+foldring__ fr = foldVL__ $ \f -> void . fr (\a -> (f a *>)) (pure v)+  where+    v = error "foldring__: value used"+{-# INLINE foldring__ #-}++------------------------------------------------------------------------------+-- Leftmost and Rightmost+------------------------------------------------------------------------------++-- | Used for 'Optics.Fold.headOf' and 'Optics.IxFold.iheadOf'.+data Leftmost a = LPure | LLeaf a | LStep (Leftmost a)++instance SG.Semigroup (Leftmost a) where+  x <> y = LStep $ case x of+    LPure    -> y+    LLeaf _  -> x+    LStep x' -> case y of+      -- The last two cases make headOf produce a Just as soon as any element is+      -- encountered, and possibly serve as a micro-optimisation; this behaviour+      -- can be disabled by replacing them with _ -> mappend x y'.  Note that+      -- this means that firstOf (backwards folded) [1..] is Just _|_.+      LPure    -> x'+      LLeaf a  -> LLeaf $ fromMaybe a (getLeftmost x')+      LStep y' -> x' SG.<> y'++instance Monoid (Leftmost a) where+  mempty  = LPure+  mappend = (SG.<>)+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}++-- | Extract the 'Leftmost' element. This will fairly eagerly determine that it+-- can return 'Just' the moment it sees any element at all.+getLeftmost :: Leftmost a -> Maybe a+getLeftmost LPure     = Nothing+getLeftmost (LLeaf a) = Just a+getLeftmost (LStep x) = go x+  where+    -- Make getLeftmost non-recursive so it might be inlined for LPure/LLeaf.+    go LPure     = Nothing+    go (LLeaf a) = Just a+    go (LStep a) = go a++-- | Used for 'Optics.Fold.lastOf' and 'Optics.IxFold.ilastOf'.+data Rightmost a = RPure | RLeaf a | RStep (Rightmost a)++instance SG.Semigroup (Rightmost a) where+  x <> y = RStep $ case y of+    RPure    -> x+    RLeaf _  -> y+    RStep y' -> case x of+      -- The last two cases make lastOf produce a Just as soon as any element is+      -- encountered, and possibly serve as a micro-optimisation; this behaviour+      -- can be disabled by replacing them with _ -> mappend x y'.  Note that+      -- this means that lastOf folded [1..] is Just _|_.+      RPure    -> y'+      RLeaf a  -> RLeaf $ fromMaybe a (getRightmost y')+      RStep x' -> mappend x' y'++instance Monoid (Rightmost a) where+  mempty  = RPure+  mappend = (SG.<>)+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}++-- | Extract the 'Rightmost' element. This will fairly eagerly determine that it+-- can return 'Just' the moment it sees any element at all.+getRightmost :: Rightmost a -> Maybe a+getRightmost RPure     = Nothing+getRightmost (RLeaf a) = Just a+getRightmost (RStep x) = go x+  where+    -- Make getRightmost non-recursive so it might be inlined for RPure/RLeaf.+    go RPure     = Nothing+    go (RLeaf a) = Just a+    go (RStep a) = go a
+ src/Optics/Internal/Indexed.hs view
@@ -0,0 +1,604 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Internal implementation details of indexed optics.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Indexed where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Reader+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Functor.Product+import Data.Functor.Reverse+import Data.Functor.Sum+import Data.Ix+import Data.List.NonEmpty+import Data.Monoid hiding (Product, Sum)+import Data.Proxy+import Data.Tree+import Data.Void+import GHC.Generics+import GHC.TypeLits+import qualified Data.Array as Array+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Sequence as Seq++import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Utils++-- | Show useful error message when a function expects optics without indices.+class is ~ NoIx => AcceptsEmptyIndices (f :: Symbol) (is :: [*])++instance+  ( TypeError+    ('Text "‘" ':<>: 'Text f ':<>: 'Text "’ accepts only optics with no indices")+  , (x ': xs) ~ NoIx+  ) => AcceptsEmptyIndices f (x ': xs)++instance AcceptsEmptyIndices f '[]++-- | Check whether a list of indices is not empty and generate sensible error+-- message if it's not.+class NonEmptyIndices (is :: [*])++instance+  ( TypeError+    ('Text "Indexed optic is expected")+  ) => NonEmptyIndices '[]++instance NonEmptyIndices (x ': xs)++-- | Generate sensible error messages in case a user tries to pass either an+-- unindexed optic or indexed optic with unflattened indices where indexed optic+-- with a single index is expected.+class is ~ '[i] => HasSingleIndex (is :: [*]) (i :: *)++instance HasSingleIndex '[i] i++instance+  ( TypeError+    ('Text "Indexed optic is expected")+  , '[] ~ '[i]+  ) => HasSingleIndex '[] i++instance+  ( TypeError+    ('Text "Use (<%>) or icompose to combine indices of type "+     ':<>: ShowTypes is)+  , is ~ '[i1, i2]+  , is ~ '[i]+  ) => HasSingleIndex '[i1, i2] i++instance+  ( TypeError+    ('Text "Use icompose3 to combine indices of type "+     ':<>: ShowTypes is)+  , is ~ '[i1, i2, i3]+  , is ~ '[i]+  ) => HasSingleIndex [i1, i2, i3] i++instance+  ( TypeError+    ('Text "Use icompose4 to combine indices of type "+     ':<>: ShowTypes is)+  , is ~ '[i1, i2, i3, i4]+  , is ~ '[i]+  ) => HasSingleIndex '[i1, i2, i3, i4] i++instance+  ( TypeError+    ('Text "Use icompose5 to flatten indices of type "+     ':<>: ShowTypes is)+  , is ~ '[i1, i2, i3, i4, i5]+  , is ~ '[i]+  ) => HasSingleIndex '[i1, i2, i3, i4, i5] i++instance+  ( TypeError+    ('Text "Use icomposeN to flatten indices of type "+     ':<>: ShowTypes is)+  , is ~ (i1 ': i2 ': i3 ': i4 ': i5 ': i6 : is')+  , is ~ '[i]+  ) => HasSingleIndex (i1 ': i2 ': i3 ': i4 ': i5 ': i6 ': is') i++----------------------------------------+-- Helpers for HasSingleIndex++type family ShowTypes (types :: [*]) :: ErrorMessage where+  ShowTypes '[i]      = QuoteType i+  ShowTypes '[i, j]   = QuoteType i ':<>: 'Text " and " ':<>: QuoteType j+  ShowTypes (i ': is) = QuoteType i ':<>: 'Text ", " ':<>: ShowTypes is++----------------------------------------++data IntT f a = IntT {-# UNPACK #-} !Int (f a)++unIntT :: IntT f a -> f a+unIntT (IntT _ fa) = fa++newtype Indexing f a = Indexing { runIndexing :: Int -> IntT f a }++instance Functor f => Functor (Indexing f) where+  fmap f (Indexing m) = Indexing $ \i -> case m i of+    IntT j x -> IntT j (fmap f x)+  {-# INLINE fmap #-}++instance Applicative f => Applicative (Indexing f) where+  pure x = Indexing $ \i -> IntT i (pure x)+  {-# INLINE pure #-}+  Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of+    IntT j ff -> case ma j of+       IntT k fa -> IntT k (ff <*> fa)+  {-# INLINE (<*>) #-}++-- | Index a traversal by position of visited elements.+indexing+  :: ((a -> Indexing f b) -> s -> Indexing f t)+  -> ((Int -> a -> f b) -> s -> f t)+indexing l iafb s =+  unIntT $ runIndexing (l (\a -> Indexing (\i -> IntT (i + 1) (iafb i a))) s) 0+{-# INLINE indexing #-}++----------------------------------------++-- | Construct a conjoined indexed optic that provides a separate code path when+-- used without indices. Useful for defining indexed optics that are as+-- efficient as their unindexed equivalents when used without indices.+--+-- /Note:/ @'conjoined' f g@ is well-defined if and only if @f ≡+-- 'Optics.Indexed.Core.noIx' g@.+conjoined+  :: is `HasSingleIndex` i+  => Optic k NoIx s t a b+  -> Optic k is   s t a b+  -> Optic k is   s t a b+conjoined (Optic f) (Optic g) = Optic (conjoined__ f g)+{-# INLINE conjoined #-}++----------------------------------------++-- | Class for 'Functor's that have an additional read-only index available.+class Functor f => FunctorWithIndex i f | f -> i where+  imap :: (i -> a -> b) -> f a -> f b+  default imap+    :: TraversableWithIndex i f => (i -> a -> b) -> f a -> f b+  imap f = runIxFunArrow (iwander itraverse (IxFunArrow f)) id+  {-# INLINE imap #-}++-- | Class for 'Foldable's that have an additional read-only index available.+class (FunctorWithIndex i f, Foldable f+      ) => FoldableWithIndex i f | f -> i where+  ifoldMap :: Monoid m => (i -> a -> m) -> f a -> m+  default ifoldMap+    :: (TraversableWithIndex i f, Monoid m) => (i -> a -> m) -> f a -> m+  ifoldMap f = runIxForget (iwander itraverse (IxForget f)) id+  {-# INLINE ifoldMap #-}++  ifoldr :: (i -> a -> b -> b) -> b -> f a -> b+  ifoldr iabb b0 = (\e -> appEndo e b0) . ifoldMap (\i -> Endo #. iabb i)+  {-# INLINE ifoldr #-}++  ifoldl' :: (i -> b -> a -> b) -> b -> f a -> b+  ifoldl' ibab b0 s = ifoldr (\i a bb b -> bb $! ibab i b a) id s b0+  {-# INLINE ifoldl' #-}++-- | Traverse 'FoldableWithIndex' ignoring the results.+itraverse_ :: (FoldableWithIndex i t, Applicative f) => (i -> a -> f b) -> t a -> f ()+itraverse_ f = runTraversed . ifoldMap (\i -> Traversed #. f i)+{-# INLINE itraverse_ #-}++-- | Flipped 'itraverse_'.+ifor_ :: (FoldableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f ()+ifor_ = flip itraverse_+{-# INLINE ifor_ #-}++-- | Class for 'Traversable's that have an additional read-only index available.+class (FoldableWithIndex i t, Traversable t+      ) => TraversableWithIndex i t | t -> i where+  itraverse :: Applicative f => (i -> a -> f b) -> t a -> f (t b)++-- | Flipped 'itraverse'+ifor :: (TraversableWithIndex i t, Applicative f) => t a -> (i -> a -> f b) -> f (t b)+ifor = flip itraverse+{-# INLINE ifor #-}++----------------------------------------+-- Instances++-- Identity++instance FunctorWithIndex () Identity where+  imap f (Identity a) = Identity (f () a)+  {-# INLINE imap #-}++instance FoldableWithIndex () Identity where+  ifoldMap f (Identity a) = f () a+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex () Identity where+  itraverse f (Identity a) = Identity <$> f () a+  {-# INLINE itraverse #-}++-- (,) k++instance FunctorWithIndex k ((,) k) where+  imap f (k, a) = (k, f k a)+  {-# INLINE imap #-}++instance FoldableWithIndex k ((,) k) where+  ifoldMap = uncurry+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex k ((,) k) where+  itraverse f (k, a) = (,) k <$> f k a+  {-# INLINE itraverse #-}++-- (->) r++instance FunctorWithIndex r ((->) r) where+  imap f g x = f x (g x)+  {-# INLINE imap #-}++-- []++instance FunctorWithIndex Int []+instance FoldableWithIndex Int []+instance TraversableWithIndex Int [] where+  -- Faster than @indexing traverse@, also best for folds and setters.+  itraverse f = traverse (uncurry f) . Prelude.zip [0..]+  {-# INLINE itraverse #-}++-- ZipList++instance FunctorWithIndex Int ZipList+instance FoldableWithIndex Int ZipList+instance TraversableWithIndex Int ZipList where+  itraverse f (ZipList xs) = ZipList <$> itraverse f xs+  {-# INLINE itraverse #-}++-- NonEmpty++instance FunctorWithIndex Int NonEmpty+instance FoldableWithIndex Int NonEmpty+instance TraversableWithIndex Int NonEmpty where+  itraverse f ~(a :| as) =+    (:|) <$> f 0 a <*> traverse (uncurry f) (Prelude.zip [1..] as)+  {-# INLINE itraverse #-}++-- Maybe++instance FunctorWithIndex () Maybe where+  imap f = fmap (f ())+  {-# INLINE imap #-}+instance FoldableWithIndex () Maybe where+  ifoldMap f = foldMap (f ())+  {-# INLINE ifoldMap #-}+instance TraversableWithIndex () Maybe where+  itraverse f = traverse (f ())+  {-# INLINE itraverse #-}++-- Seq++-- | The position in the 'Seq.Seq' is available as the index.+instance FunctorWithIndex Int Seq.Seq where+  imap = Seq.mapWithIndex+  {-# INLINE imap #-}+instance FoldableWithIndex Int Seq.Seq where+#if MIN_VERSION_containers(0,5,8)+  ifoldMap = Seq.foldMapWithIndex+#else+  ifoldMap f = ifoldr (\i -> mappend . f i) mempty+#endif+  {-# INLINE ifoldMap #-}++  ifoldr = Seq.foldrWithIndex+  {-# INLINE ifoldr #-}++instance TraversableWithIndex Int Seq.Seq where+  -- This is much faster than Seq.traverseWithIndex. wut?+  itraverse f = sequenceA . Seq.mapWithIndex f+  {-# INLINE itraverse #-}++-- IntMap++instance FunctorWithIndex Int IntMap.IntMap where+  imap = IntMap.mapWithKey+  {-# INLINE imap #-}+instance FoldableWithIndex Int IntMap.IntMap where+  ifoldMap = IntMap.foldMapWithKey+  ifoldr   = IntMap.foldrWithKey+  ifoldl'  = IntMap.foldlWithKey' . flip+  {-# INLINE ifoldMap #-}+  {-# INLINE ifoldr #-}+  {-# INLINE ifoldl' #-}+instance TraversableWithIndex Int IntMap.IntMap where+  itraverse = IntMap.traverseWithKey+  {-# INLINE itraverse #-}++-- Map++instance FunctorWithIndex k (Map.Map k) where+  imap = Map.mapWithKey+  {-# INLINE imap #-}+instance FoldableWithIndex k (Map.Map k) where+  ifoldMap = Map.foldMapWithKey+  ifoldr   = Map.foldrWithKey+  ifoldl'  = Map.foldlWithKey' . flip+  {-# INLINE ifoldMap #-}+  {-# INLINE ifoldr #-}+  {-# INLINE ifoldl' #-}+instance TraversableWithIndex k (Map.Map k) where+  itraverse = Map.traverseWithKey+  {-# INLINE itraverse #-}++-- Array++instance Ix i => FunctorWithIndex i (Array.Array i) where+  imap f arr = Array.listArray (Array.bounds arr)+    . fmap (uncurry f) $ Array.assocs arr+  {-# INLINE imap #-}++instance Ix i => FoldableWithIndex i (Array.Array i) where+  ifoldMap f = foldMap (uncurry f) . Array.assocs+  {-# INLINE ifoldMap #-}++instance Ix i => TraversableWithIndex i (Array.Array i) where+  itraverse f arr = Array.listArray (Array.bounds arr)+    <$> traverse (uncurry f) (Array.assocs arr)+  {-# INLINE itraverse #-}++-- Compose++instance (FunctorWithIndex i f, FunctorWithIndex j g+         ) => FunctorWithIndex (i, j) (Compose f g) where+  imap f (Compose fg) = Compose $ imap (\k -> imap (f . (,) k)) fg+  {-# INLINE imap #-}++instance (FoldableWithIndex i f, FoldableWithIndex j g+         ) => FoldableWithIndex (i, j) (Compose f g) where+  ifoldMap f (Compose fg) = ifoldMap (\k -> ifoldMap (f . (,) k)) fg+  {-# INLINE ifoldMap #-}++instance (TraversableWithIndex i f, TraversableWithIndex j g+         ) => TraversableWithIndex (i, j) (Compose f g) where+  itraverse f (Compose fg) =+    Compose <$> itraverse (\k -> itraverse (f . (,) k)) fg+  {-# INLINE itraverse #-}++-- Sum++instance (FunctorWithIndex i f, FunctorWithIndex j g+         ) => FunctorWithIndex (Either i j) (Sum f g) where+  imap q (InL fa) = InL (imap (q . Left)  fa)+  imap q (InR ga) = InR (imap (q . Right) ga)+  {-# INLINE imap #-}++instance (FoldableWithIndex i f, FoldableWithIndex j g+         ) => FoldableWithIndex (Either i j) (Sum f g) where+  ifoldMap q (InL fa) = ifoldMap (q . Left)  fa+  ifoldMap q (InR ga) = ifoldMap (q . Right) ga+  {-# INLINE ifoldMap #-}++instance (TraversableWithIndex i f, TraversableWithIndex j g+         ) => TraversableWithIndex (Either i j) (Sum f g) where+  itraverse q (InL fa) = InL <$> itraverse (q . Left)  fa+  itraverse q (InR ga) = InR <$> itraverse (q . Right) ga+  {-# INLINE itraverse #-}++-- Product++instance (FunctorWithIndex i f, FunctorWithIndex j g+         ) => FunctorWithIndex (Either i j) (Product f g) where+  imap f (Pair a b) = Pair (imap (f . Left) a) (imap (f . Right) b)+  {-# INLINE imap #-}++instance (FoldableWithIndex i f, FoldableWithIndex j g+         ) => FoldableWithIndex (Either i j) (Product f g) where+  ifoldMap f (Pair a b) =+    ifoldMap (f . Left) a `mappend` ifoldMap (f . Right) b+  {-# INLINE ifoldMap #-}++instance (TraversableWithIndex i f, TraversableWithIndex j g+         ) => TraversableWithIndex (Either i j) (Product f g) where+  itraverse f (Pair a b) =+    Pair <$> itraverse (f . Left) a <*> itraverse (f . Right) b+  {-# INLINE itraverse #-}++-- Tree++instance FunctorWithIndex [Int] Tree where+  imap f (Node a as) = Node (f [] a) $ imap (\i -> imap (f . (:) i)) as+  {-# INLINE imap #-}++instance FoldableWithIndex [Int] Tree where+  ifoldMap f (Node a as) =+    f [] a `mappend` ifoldMap (\i -> ifoldMap (f . (:) i)) as+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex [Int] Tree where+  itraverse f (Node a as) =+    Node <$> f [] a <*> itraverse (\i -> itraverse (f . (:) i)) as+  {-# INLINE itraverse #-}++-- Proxy++instance FunctorWithIndex Void Proxy where+  imap _ Proxy = Proxy+  {-# INLINE imap #-}++instance FoldableWithIndex Void Proxy where+  ifoldMap _ _ = mempty+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex Void Proxy where+  itraverse _ _ = pure Proxy+  {-# INLINE itraverse #-}++-- Backwards++instance FunctorWithIndex i f => FunctorWithIndex i (Backwards f) where+  imap f  = Backwards . imap f . forwards+  {-# INLINE imap #-}++instance FoldableWithIndex i f => FoldableWithIndex i (Backwards f) where+  ifoldMap f = ifoldMap f . forwards+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex i f => TraversableWithIndex i (Backwards f) where+  itraverse f = fmap Backwards . itraverse f . forwards+  {-# INLINE itraverse #-}++-- Reverse++instance FunctorWithIndex i f => FunctorWithIndex i (Reverse f) where+  imap f = Reverse . imap f . getReverse+  {-# INLINE imap #-}++instance FoldableWithIndex i f => FoldableWithIndex i (Reverse f) where+  ifoldMap f = getDual . ifoldMap (\i -> Dual #. f i) . getReverse+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex i f => TraversableWithIndex i (Reverse f) where+  itraverse f =+    fmap Reverse . forwards . itraverse (\i -> Backwards . f i) . getReverse+  {-# INLINE itraverse #-}++-- IdentityT++instance FunctorWithIndex i m => FunctorWithIndex i (IdentityT m) where+  imap f (IdentityT m) = IdentityT $ imap f m+  {-# INLINE imap #-}++instance FoldableWithIndex i m => FoldableWithIndex i (IdentityT m) where+  ifoldMap f (IdentityT m) = ifoldMap f m+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex i m => TraversableWithIndex i (IdentityT m) where+  itraverse f (IdentityT m) = IdentityT <$> itraverse f m+  {-# INLINE itraverse #-}++-- ReaderT++instance FunctorWithIndex i m => FunctorWithIndex (e, i) (ReaderT e m) where+  imap f (ReaderT m) = ReaderT $ \k -> imap (f . (,) k) (m k)+  {-# INLINE imap #-}++-- Generics++instance FunctorWithIndex Void V1 where+  imap _ v = v `seq` undefined+  {-# INLINE imap #-}++instance FoldableWithIndex Void V1 where+  ifoldMap _ v = v `seq` undefined++instance TraversableWithIndex Void V1 where+  itraverse _ v = v `seq` undefined++instance FunctorWithIndex Void U1 where+  imap _ U1 = U1+  {-# INLINE imap #-}++instance FoldableWithIndex Void U1 where+  ifoldMap _ _ = mempty+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex Void U1 where+  itraverse _ U1 = pure U1+  {-# INLINE itraverse #-}++instance FunctorWithIndex () Par1 where+  imap f = fmap (f ())+  {-# INLINE imap #-}++instance FoldableWithIndex () Par1 where+  ifoldMap f (Par1 a) = f () a+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex () Par1 where+  itraverse f (Par1 a) = Par1 <$> f () a+  {-# INLINE itraverse #-}++instance (FunctorWithIndex i f, FunctorWithIndex j g+         ) => FunctorWithIndex (i, j) (f :.: g) where+  imap q (Comp1 fga) = Comp1 (imap (\k -> imap (q . (,) k)) fga)+  {-# INLINE imap #-}++instance (FoldableWithIndex i f, FoldableWithIndex j g+         ) => FoldableWithIndex (i, j) (f :.: g) where+  ifoldMap q (Comp1 fga) = ifoldMap (\k -> ifoldMap (q . (,) k)) fga+  {-# INLINE ifoldMap #-}++instance (TraversableWithIndex i f, TraversableWithIndex j g+         ) => TraversableWithIndex (i, j) (f :.: g) where+  itraverse q (Comp1 fga) =+    Comp1 <$> itraverse (\k -> itraverse (q . (,) k)) fga+  {-# INLINE itraverse #-}++instance (FunctorWithIndex i f, FunctorWithIndex j g+         ) => FunctorWithIndex (Either i j) (f :*: g) where+  imap q (fa :*: ga) = imap (q . Left) fa :*: imap (q . Right) ga+  {-# INLINE imap #-}++instance (FoldableWithIndex i f, FoldableWithIndex j g+         ) => FoldableWithIndex (Either i j) (f :*: g) where+  ifoldMap q (fa :*: ga) =+    ifoldMap (q . Left) fa `mappend` ifoldMap (q . Right) ga+  {-# INLINE ifoldMap #-}++instance (TraversableWithIndex i f, TraversableWithIndex j g+         ) => TraversableWithIndex (Either i j) (f :*: g) where+  itraverse q (fa :*: ga) =+    (:*:) <$> itraverse (q . Left) fa <*> itraverse (q . Right) ga+  {-# INLINE itraverse #-}++instance (FunctorWithIndex i f, FunctorWithIndex j g+         ) => FunctorWithIndex (Either i j) (f :+: g) where+  imap q (L1 fa) = L1 (imap (q . Left) fa)+  imap q (R1 ga) = R1 (imap (q . Right) ga)+  {-# INLINE imap #-}++instance (FoldableWithIndex i f, FoldableWithIndex j g+         ) => FoldableWithIndex (Either i j) (f :+: g) where+  ifoldMap q (L1 fa) = ifoldMap (q . Left) fa+  ifoldMap q (R1 ga) = ifoldMap (q . Right) ga+  {-# INLINE ifoldMap #-}++instance (TraversableWithIndex i f, TraversableWithIndex j g+         ) => TraversableWithIndex (Either i j) (f :+: g) where+  itraverse q (L1 fa) = L1 <$> itraverse (q . Left) fa+  itraverse q (R1 ga) = R1 <$> itraverse (q . Right) ga+  {-# INLINE itraverse #-}++instance FunctorWithIndex i f => FunctorWithIndex i (Rec1 f) where+  imap q (Rec1 f) = Rec1 (imap q f)+  {-# INLINE imap #-}++instance FoldableWithIndex i f => FoldableWithIndex i (Rec1 f) where+  ifoldMap q (Rec1 f) = ifoldMap q f+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex i f => TraversableWithIndex i (Rec1 f) where+  itraverse q (Rec1 f) = Rec1 <$> itraverse q f+  {-# INLINE itraverse #-}++instance FunctorWithIndex Void (K1 i c) where+  imap _ (K1 c) = K1 c+  {-# INLINE imap #-}++instance FoldableWithIndex Void (K1 i c) where+  ifoldMap _ _ = mempty+  {-# INLINE ifoldMap #-}++instance TraversableWithIndex Void (K1 i c) where+  itraverse _ (K1 a) = pure (K1 a)+  {-# INLINE itraverse #-}
+ src/Optics/Internal/IxFold.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Internal implementation details of indexed folds.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.IxFold where++import Data.Functor+import Data.Foldable++import Optics.Internal.Bi+import Optics.Internal.Indexed+import Optics.Internal.Profunctor+import Optics.Internal.Optic+import Optics.Internal.Fold++-- | Internal implementation of 'Optics.IxFold.ifoldVL'.+ifoldVL__+  :: (Bicontravariant p, Traversing p)+  => (forall f. Applicative f => (i -> a -> f u) -> s -> f v)+  -> Optic__ p j (i -> j) s t a b+ifoldVL__ f = rphantom . iwander f . rphantom+{-# INLINE ifoldVL__ #-}++-- | Internal implementation of 'Optics.IxFold.ifolded'.+ifolded__+  :: (Bicontravariant p, Traversing p, FoldableWithIndex i f)+  => Optic__ p j (i -> j) (f a) t a b+ifolded__ = conjoined__ (foldVL__ traverse_) (ifoldVL__ itraverse_)+{-# INLINE ifolded__ #-}++-- | Internal implementation of 'Optics.IxFold.ifoldring'.+ifoldring__+  :: (Bicontravariant p, Traversing p)+  => (forall f. Applicative f => (i -> a -> f u -> f u) -> f v -> s -> f w)+  -> Optic__ p j (i -> j) s t a b+ifoldring__ fr = ifoldVL__ $ \f -> void . fr (\i a -> (f i a *>)) (pure v)+  where+    v = error "ifoldring__: value used"+{-# INLINE ifoldring__ #-}
+ src/Optics/Internal/IxSetter.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Internal implementation details of indexed setters.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.IxSetter where++import Optics.Internal.Indexed+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Internal implementation of 'Optics.IxSetter.imapped'.+imapped__+  :: (Mapping p, FunctorWithIndex i f)+  => Optic__ p j (i -> j) (f a) (f b) a b+imapped__ = conjoined__ (roam fmap) (iroam imap)+{-# INLINE imapped__ #-}
+ src/Optics/Internal/IxTraversal.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Internal implementation details of indexed traversals.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.IxTraversal where++import Optics.Internal.Fold+import Optics.Internal.Indexed+import Optics.Internal.IxFold+import Optics.Internal.IxSetter+import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Setter++-- | Internal implementation of 'Optics.IxTraversal.itraversed'.+itraversed__+  :: (Traversing p, TraversableWithIndex i f)+  => Optic__ p j (i -> j) (f a) (f b) a b+itraversed__ = conjoined__ (wander traverse) (iwander itraverse)+{-# INLINE [0] itraversed__ #-}++-- Because itraversed__ inlines late, GHC needs rewrite rules for all cases in+-- order to generate optimal code for each of them. The ones that rewrite+-- traversal into a traversal correspond to an early inline.++{-# RULES++"itraversed__ -> wander traverse"+  forall (o :: Star g j a b). itraversed__ o = wander traverse (reStar o)+    :: TraversableWithIndex i f => Star g (i -> j) (f a) (f b)++"itraversed__ -> folded__"+  forall (o :: Forget r j a b). itraversed__ o = folded__ (reForget o)+    :: FoldableWithIndex i f => Forget r (i -> j) (f a) (f b)++"itraversed__ -> mapped__"+  forall (o :: FunArrow j a b). itraversed__ o = mapped__ (reFunArrow o)+    :: FunctorWithIndex i f => FunArrow (i -> j) (f a) (f b)++"itraversed__ -> itraverse"+  forall (o :: IxStar g j a b). itraversed__ o = iwander itraverse o+    :: TraversableWithIndex i f => IxStar g (i -> j) (f a) (f b)++"itraversed__ -> ifolded__"+  forall (o :: IxForget r j a b). itraversed__ o = ifolded__ o+    :: FoldableWithIndex i f => IxForget r (i -> j) (f a) (f b)++"itraversed__ -> imapped__"+  forall (o :: IxFunArrow j a b). itraversed__ o = imapped__ o+    :: FunctorWithIndex i f => IxFunArrow (i -> j) (f a) (f b)++#-}
+ src/Optics/Internal/Optic.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Core optic types and subtyping machinery.+--+-- This module contains the core 'Optic' types, and the underlying+-- machinery that we need in order to implement the subtyping between+-- various different flavours of optics.+--+-- The composition operator for optics is also defined here.+--+-- This module is intended for internal use only, and may change without+-- warning in subsequent releases.+--+module Optics.Internal.Optic+  ( Optic(..)+  , Optic'+  , Optic_+  , Optic__+  , NoIx+  , WithIx+  , castOptic+  , (%)+  , (%%)+  , (%&)+  , IsProxy(..)+  -- * Labels+  , LabelOptic(..)+  , LabelOptic'+  -- * Re-exports+  , module Optics.Internal.Optic.Subtyping+  , module Optics.Internal.Optic.Types+  , module Optics.Internal.Optic.TypeLevel+  ) where++import Data.Function ((&))+import Data.Proxy (Proxy (..))+import Data.Type.Equality+import GHC.OverloadedLabels+import GHC.TypeLits++import Optics.Internal.Optic.Subtyping+import Optics.Internal.Optic.TypeLevel+import Optics.Internal.Optic.Types+import Optics.Internal.Profunctor++-- to make %% simpler+import Unsafe.Coerce (unsafeCoerce)++-- | An alias for an empty index-list+type NoIx = '[]++-- | Singleton index list+type WithIx i = '[i]++-- | Wrapper newtype for the whole family of optics.+--+-- The first parameter @k@ identifies the particular optic kind (e.g. 'A_Lens'+-- or 'A_Traversal').+--+-- The parameter @is@ is a list of types available as indices.  This will+-- typically be 'NoIx' for unindexed optics, or 'WithIx' for optics with a+-- single index. See the "Indexed optics" section of the overview documentation+-- in the @Optics@ module of the main @optics@ package for more details.+--+-- The parameters @s@ and @t@ represent the "big" structure,+-- whereas @a@ and @b@ represent the "small" structure.+--+newtype Optic (k :: *) (is :: [*]) s t a b = Optic+  { getOptic :: forall p i. Profunctor p+             => Optic_ k p i (Curry is i) s t a b+  }++-- | Common special case of 'Optic' where source and target types are equal.+--+-- Here, we need only one "big" and one "small" type. For lenses, this+-- means that in the restricted form we cannot do type-changing updates.+--+type Optic' k is s a = Optic k is s s a a++-- | Type representing the various kinds of optics.+--+-- The tag parameter @k@ is translated into constraints on @p@+-- via the type family 'Constraints'.+--+type Optic_ k p i j s t a b = Constraints k p => Optic__ p i j s t a b++-- | Optic internally as a profunctor transformation.+type Optic__ p i j s t a b = p i a b -> p j s t++-- | Proxy type for use as an argument to 'implies'.+--+data IsProxy (k :: *) (l :: *) (p :: * -> * -> * -> *) =+  IsProxy++-- | Explicit cast from one optic flavour to another.+--+-- The resulting optic kind is given in the first type argument, so you can use+-- TypeApplications to set it. For example+--+-- @+--  'castOptic' @'A_Lens' o+-- @+--+-- turns @o@ into a 'Optics.Lens.Lens'.+--+-- This is the identity function, modulo some constraint jiggery-pokery.+--+castOptic+  :: forall destKind srcKind is s t a b+  .  Is srcKind destKind+  => Optic srcKind  is s t a b+  -> Optic destKind is s t a b+castOptic (Optic o) = Optic (implies' o)+  where+    implies'+      :: forall p i+      .  Optic_ srcKind  p i (Curry is i) s t a b+      -> Optic_ destKind p i (Curry is i) s t a b+    implies' x = implies (IsProxy :: IsProxy srcKind destKind p) x+{-# INLINE castOptic #-}++-- | Compose two optics of compatible flavours.+--+-- Returns an optic of the appropriate supertype.  If either or both optics are+-- indexed, the composition preserves all the indices.+--+infixl 9 %+(%) :: (Is k m, Is l m, m ~ Join k l, ks ~ Append is js)+    => Optic k is s t u v+    -> Optic l js u v a b+    -> Optic m ks s t a b+o % o' = castOptic o %% castOptic o'+{-# INLINE (%) #-}++-- | Compose two optics of the same flavour.+--+-- Normally you can simply use ('%') instead, but this may be useful to help+-- type inference if the type of one of the optics is otherwise+-- under-constrained.+infixl 9 %%+(%%) :: forall k is js ks s t u v a b. ks ~ Append is js+     => Optic k is s t u v+     -> Optic k js u v a b+     -> Optic k ks s t a b+Optic o %% Optic o' = Optic oo+  where+    -- unsafeCoerce to the rescue, for a proof see below.+    oo :: forall p i. Profunctor p => Optic_ k p i (Curry ks i) s t a b+    oo = (unsafeCoerce+           :: Optic_ k p i (Curry is (Curry js i)) s t a b+           -> Optic_ k p i (Curry ks i           ) s t a b)+      (o . o')+{-# INLINE (%%) #-}++-- | Flipped function application, specialised to optics and binding tightly.+--+-- Useful for post-composing optics transformations:+--+-- >>> toListOf (ifolded %& ifiltered (\i s -> length s <= i)) ["", "a","abc"]+-- ["","a"]+--+infixl 9 %&+(%&) :: Optic k is s t a b+     -> (Optic k is s t a b -> Optic l js s' t' a' b')+     -> Optic l js s' t' a' b'+(%&) = (&)+{-# INLINE (%&) #-}+++-- |+--+-- 'AppendProof' is a very simple class which provides a witness+--+-- @+-- foldr f (foldr f init xs) ys = foldr f init (ys ++ xs)+--    where f = (->)+-- @+--+-- It shows that usage of 'unsafeCoerce' in '(%%)' is, in fact, safe.+--+class Append xs ys ~ zs => AppendProof (xs :: [*]) (ys :: [*]) (zs :: [*])+  | xs ys -> zs, zs xs -> ys {- , zs ys -> xs -} where+  appendProof :: Proxy i -> Curry xs (Curry ys i) :~: Curry zs i++instance ys ~ zs => AppendProof '[] ys zs where+  appendProof _ = Refl++instance+  (Append (x : xs) ys ~ (x : zs), AppendProof xs ys zs+  ) => AppendProof (x ': xs) ys (x ': zs) where+  appendProof+    :: forall i. Proxy i+    -> Curry (x ': xs) (Curry ys i) :~: Curry (x ': zs) i+  appendProof i = case appendProof @xs @ys @zs i of+    Refl -> Refl++----------------------------------------+-- Labels++-- | Support for overloaded labels as optics. An overloaded label @#foo@ can be+-- used as an optic if there is an instance of @'LabelOptic' "foo" k s t a b@.+--+-- See "Optics.Label" for examples and further details.+--+class LabelOptic (name :: Symbol) k s t a b | name s -> k a+                                            , name t -> k b+                                            , name s b -> t+                                            , name t a -> s where+  -- | Used to interpret overloaded label syntax.  An overloaded label @#foo@+  -- corresponds to @'labelOptic' \@"foo"@.+  labelOptic :: Optic k NoIx s t a b++-- | If no instance matches, GHC tends to bury error messages "No instance for+-- LabelOptic..." within a ton of other error messages about ambiguous type+-- variables and overlapping instances which are irrelevant and confusing. Use+-- overlappable instance providing a custom type error to cut its efforts short.+instance {-# OVERLAPPABLE #-}+  (LabelOptic name k s t a b,+   TypeError+   ('Text "No instance for LabelOptic " ':<>: 'ShowType name+    ':<>: 'Text " " ':<>: QuoteType k+    ':<>: 'Text " " ':<>: QuoteType s+    ':<>: 'Text " " ':<>: QuoteType t+    ':<>: 'Text " " ':<>: QuoteType a+    ':<>: 'Text " " ':<>: QuoteType b+    ':$$: 'Text "  (maybe you forgot to define it or misspelled a name?)")+  ) => LabelOptic name k s t a b where+  labelOptic = error "unreachable"++-- | Type synonym for a type-preserving optic as overloaded label.+type LabelOptic' name k s a = LabelOptic name k s s a a++instance+  (LabelOptic name k s t a b, is ~ NoIx+  ) => IsLabel name (Optic k is s t a b) where+#if __GLASGOW_HASKELL__ >= 802+  fromLabel = labelOptic @name @k @s @t @a @b+#else+  fromLabel _ = labelOptic @name @k @s @t @a @b+#endif++-- $setup+-- >>> import Optics.Core
+ src/Optics/Internal/Optic/Subtyping.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Instances to implement the subtyping hierarchy between optics.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Optic.Subtyping where++import GHC.TypeLits (ErrorMessage(..), TypeError)++import Optics.Internal.Optic.Types++-- | Subtyping relationship between kinds of optics.+--+-- An instance of @'Is' k l@ means that any @'Optics.Optic.Optic' k@ can be used+-- as an @'Optics.Optic.Optic' l@. For example, we have an @'Is' 'A_Lens'+-- 'A_Traversal'@ instance, but not @'Is' 'A_Traversal' 'A_Lens'@.+--+-- This class needs instances for all possible combinations of tags.+--+class Is k l where+  -- | Witness of the subtyping relationship.+  implies ::+    proxy k l p -> (Constraints k p => r) -> (Constraints l p => r)++-- | Overlappable instance for a custom type error.+instance {-# OVERLAPPABLE #-} TypeError ('ShowType k+                                         ':<>: 'Text " cannot be used as "+                                         ':<>: 'ShowType l+                                        ) => Is k l where+  implies = error "unreachable"++-- | Every kind of optic can be used as itself.+instance Is k k where+  implies _ = id++----------------------------------------++-- BEGIN GENERATED CONTENT++-- An_Iso+instance Is An_Iso             A_ReversedLens     where implies _ = id+instance Is An_Iso             A_ReversedPrism    where implies _ = id+instance Is An_Iso             A_Prism            where implies _ = id+instance Is An_Iso             A_Review           where implies _ = id+instance Is An_Iso             A_Lens             where implies _ = id+instance Is An_Iso             A_Getter           where implies _ = id+instance Is An_Iso             An_AffineTraversal where implies _ = id+instance Is An_Iso             An_AffineFold      where implies _ = id+instance Is An_Iso             A_Traversal        where implies _ = id+instance Is An_Iso             A_Fold             where implies _ = id+instance Is An_Iso             A_Setter           where implies _ = id+-- A_ReversedLens+instance Is A_ReversedLens     A_Review           where implies _ = id+-- A_ReversedPrism+instance Is A_ReversedPrism    A_Getter           where implies _ = id+instance Is A_ReversedPrism    An_AffineFold      where implies _ = id+instance Is A_ReversedPrism    A_Fold             where implies _ = id+-- A_Prism+instance Is A_Prism            A_Review           where implies _ = id+instance Is A_Prism            An_AffineTraversal where implies _ = id+instance Is A_Prism            An_AffineFold      where implies _ = id+instance Is A_Prism            A_Traversal        where implies _ = id+instance Is A_Prism            A_Fold             where implies _ = id+instance Is A_Prism            A_Setter           where implies _ = id+-- A_Lens+instance Is A_Lens             A_Getter           where implies _ = id+instance Is A_Lens             An_AffineTraversal where implies _ = id+instance Is A_Lens             An_AffineFold      where implies _ = id+instance Is A_Lens             A_Traversal        where implies _ = id+instance Is A_Lens             A_Fold             where implies _ = id+instance Is A_Lens             A_Setter           where implies _ = id+-- A_Getter+instance Is A_Getter           An_AffineFold      where implies _ = id+instance Is A_Getter           A_Fold             where implies _ = id+-- An_AffineTraversal+instance Is An_AffineTraversal An_AffineFold      where implies _ = id+instance Is An_AffineTraversal A_Traversal        where implies _ = id+instance Is An_AffineTraversal A_Fold             where implies _ = id+instance Is An_AffineTraversal A_Setter           where implies _ = id+-- An_AffineFold+instance Is An_AffineFold      A_Fold             where implies _ = id+-- A_Traversal+instance Is A_Traversal        A_Fold             where implies _ = id+instance Is A_Traversal        A_Setter           where implies _ = id++-- END GENERATED CONTENT++----------------------------------------++-- | Computes the least upper bound of two optics kinds.+--+-- @Join k l@ represents the least upper bound of an @Optic k@ and an @Optic+-- l@. This means in particular that composition of an @Optic k@ and an @Optic+-- k@ will yield an @Optic (Join k l)@.+--+type family Join (k :: *) (l :: *) where+  -- BEGIN GENERATED CONTENT+  -- An_Iso-----+  Join An_Iso             A_ReversedLens     = A_ReversedLens+  Join An_Iso             A_ReversedPrism    = A_ReversedPrism+  Join An_Iso             A_Prism            = A_Prism+  Join An_Iso             A_Review           = A_Review+  Join An_Iso             A_Lens             = A_Lens+  Join An_Iso             A_Getter           = A_Getter+  Join An_Iso             An_AffineTraversal = An_AffineTraversal+  Join An_Iso             An_AffineFold      = An_AffineFold+  Join An_Iso             A_Traversal        = A_Traversal+  Join An_Iso             A_Fold             = A_Fold+  Join An_Iso             A_Setter           = A_Setter++  -- A_ReversedLens-----+  Join A_ReversedLens     An_Iso             = A_ReversedLens+  -- no Join with         A_ReversedPrism+  Join A_ReversedLens     A_Prism            = A_Review+  Join A_ReversedLens     A_Review           = A_Review+  -- no Join with         A_Lens+  -- no Join with         A_Getter+  -- no Join with         An_AffineTraversal+  -- no Join with         An_AffineFold+  -- no Join with         A_Traversal+  -- no Join with         A_Fold+  -- no Join with         A_Setter++  -- A_ReversedPrism-----+  Join A_ReversedPrism    An_Iso             = A_ReversedPrism+  -- no Join with         A_ReversedLens+  Join A_ReversedPrism    A_Prism            = An_AffineFold+  -- no Join with         A_Review+  Join A_ReversedPrism    A_Lens             = A_Getter+  Join A_ReversedPrism    A_Getter           = A_Getter+  Join A_ReversedPrism    An_AffineTraversal = An_AffineFold+  Join A_ReversedPrism    An_AffineFold      = An_AffineFold+  Join A_ReversedPrism    A_Traversal        = A_Fold+  Join A_ReversedPrism    A_Fold             = A_Fold+  -- no Join with         A_Setter++  -- A_Prism-----+  Join A_Prism            An_Iso             = A_Prism+  Join A_Prism            A_ReversedLens     = A_Review+  Join A_Prism            A_ReversedPrism    = An_AffineFold+  Join A_Prism            A_Review           = A_Review+  Join A_Prism            A_Lens             = An_AffineTraversal+  Join A_Prism            A_Getter           = An_AffineFold+  Join A_Prism            An_AffineTraversal = An_AffineTraversal+  Join A_Prism            An_AffineFold      = An_AffineFold+  Join A_Prism            A_Traversal        = A_Traversal+  Join A_Prism            A_Fold             = A_Fold+  Join A_Prism            A_Setter           = A_Setter++  -- A_Review-----+  Join A_Review           An_Iso             = A_Review+  Join A_Review           A_ReversedLens     = A_Review+  -- no Join with         A_ReversedPrism+  Join A_Review           A_Prism            = A_Review+  -- no Join with         A_Lens+  -- no Join with         A_Getter+  -- no Join with         An_AffineTraversal+  -- no Join with         An_AffineFold+  -- no Join with         A_Traversal+  -- no Join with         A_Fold+  -- no Join with         A_Setter++  -- A_Lens-----+  Join A_Lens             An_Iso             = A_Lens+  -- no Join with         A_ReversedLens+  Join A_Lens             A_ReversedPrism    = A_Getter+  Join A_Lens             A_Prism            = An_AffineTraversal+  -- no Join with         A_Review+  Join A_Lens             A_Getter           = A_Getter+  Join A_Lens             An_AffineTraversal = An_AffineTraversal+  Join A_Lens             An_AffineFold      = An_AffineFold+  Join A_Lens             A_Traversal        = A_Traversal+  Join A_Lens             A_Fold             = A_Fold+  Join A_Lens             A_Setter           = A_Setter++  -- A_Getter-----+  Join A_Getter           An_Iso             = A_Getter+  -- no Join with         A_ReversedLens+  Join A_Getter           A_ReversedPrism    = A_Getter+  Join A_Getter           A_Prism            = An_AffineFold+  -- no Join with         A_Review+  Join A_Getter           A_Lens             = A_Getter+  Join A_Getter           An_AffineTraversal = An_AffineFold+  Join A_Getter           An_AffineFold      = An_AffineFold+  Join A_Getter           A_Traversal        = A_Fold+  Join A_Getter           A_Fold             = A_Fold+  -- no Join with         A_Setter++  -- An_AffineTraversal-----+  Join An_AffineTraversal An_Iso             = An_AffineTraversal+  -- no Join with         A_ReversedLens+  Join An_AffineTraversal A_ReversedPrism    = An_AffineFold+  Join An_AffineTraversal A_Prism            = An_AffineTraversal+  -- no Join with         A_Review+  Join An_AffineTraversal A_Lens             = An_AffineTraversal+  Join An_AffineTraversal A_Getter           = An_AffineFold+  Join An_AffineTraversal An_AffineFold      = An_AffineFold+  Join An_AffineTraversal A_Traversal        = A_Traversal+  Join An_AffineTraversal A_Fold             = A_Fold+  Join An_AffineTraversal A_Setter           = A_Setter++  -- An_AffineFold-----+  Join An_AffineFold      An_Iso             = An_AffineFold+  -- no Join with         A_ReversedLens+  Join An_AffineFold      A_ReversedPrism    = An_AffineFold+  Join An_AffineFold      A_Prism            = An_AffineFold+  -- no Join with         A_Review+  Join An_AffineFold      A_Lens             = An_AffineFold+  Join An_AffineFold      A_Getter           = An_AffineFold+  Join An_AffineFold      An_AffineTraversal = An_AffineFold+  Join An_AffineFold      A_Traversal        = A_Fold+  Join An_AffineFold      A_Fold             = A_Fold+  -- no Join with         A_Setter++  -- A_Traversal-----+  Join A_Traversal        An_Iso             = A_Traversal+  -- no Join with         A_ReversedLens+  Join A_Traversal        A_ReversedPrism    = A_Fold+  Join A_Traversal        A_Prism            = A_Traversal+  -- no Join with         A_Review+  Join A_Traversal        A_Lens             = A_Traversal+  Join A_Traversal        A_Getter           = A_Fold+  Join A_Traversal        An_AffineTraversal = A_Traversal+  Join A_Traversal        An_AffineFold      = A_Fold+  Join A_Traversal        A_Fold             = A_Fold+  Join A_Traversal        A_Setter           = A_Setter++  -- A_Fold-----+  Join A_Fold             An_Iso             = A_Fold+  -- no Join with         A_ReversedLens+  Join A_Fold             A_ReversedPrism    = A_Fold+  Join A_Fold             A_Prism            = A_Fold+  -- no Join with         A_Review+  Join A_Fold             A_Lens             = A_Fold+  Join A_Fold             A_Getter           = A_Fold+  Join A_Fold             An_AffineTraversal = A_Fold+  Join A_Fold             An_AffineFold      = A_Fold+  Join A_Fold             A_Traversal        = A_Fold+  -- no Join with         A_Setter++  -- A_Setter-----+  Join A_Setter           An_Iso             = A_Setter+  -- no Join with         A_ReversedLens+  -- no Join with         A_ReversedPrism+  Join A_Setter           A_Prism            = A_Setter+  -- no Join with         A_Review+  Join A_Setter           A_Lens             = A_Setter+  -- no Join with         A_Getter+  Join A_Setter           An_AffineTraversal = A_Setter+  -- no Join with         An_AffineFold+  Join A_Setter           A_Traversal        = A_Setter+  -- no Join with         A_Fold++  -- END GENERATED CONTENT++  -- Every optic kinds can be joined with itself.+  Join k k = k++  -- Everything else is a type error.+  Join k l = TypeError ('ShowType k+                        ':<>: 'Text " cannot be composed with "+                        ':<>: 'ShowType l)
+ src/Optics/Internal/Optic/TypeLevel.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | This module is intended for internal use only, and may change without+-- warning in subsequent releases.+module Optics.Internal.Optic.TypeLevel where++import GHC.TypeLits++-- | Show a type surrounded by quote marks.+type family QuoteType (x :: *) :: ErrorMessage where+  QuoteType x = 'Text "‘" ':<>: 'ShowType x ':<>: 'Text "’"++-- | Curry a type-level list.+--+-- In pseudo (dependent-)Haskell:+--+-- @+-- 'Curry' xs y = 'foldr' (->) y xs+-- @+type family Curry (xs :: [*]) (y :: *) :: * where+  Curry '[]       y = y+  Curry (x ': xs) y = x -> Curry xs y++-- | Append two type-level lists together.+type family Append (xs :: [*]) (ys :: [*]) :: [*] where+  Append '[]       ys  = ys -- needed for (<%>) and (%>)+  Append xs        '[] = xs -- needed for (<%)+  Append (x ': xs) ys  = x ': Append xs ys++-- | Class that is inhabited by all type-level lists @xs@, providing the ability+-- to compose a function under @'Curry' xs@.+class CurryCompose xs where+  -- | Compose a function under @'Curry' xs@.  This generalises @('.')@ (aka+  -- 'fmap' for @(->)@) to work for curried functions with one argument for each+  -- type in the list.+  composeN :: (i -> j) -> Curry xs i -> Curry xs j++instance CurryCompose '[] where+  composeN = id+  {-# INLINE composeN #-}++instance CurryCompose xs => CurryCompose (x ': xs) where+  composeN ij f = composeN @xs ij . f+  {-# INLINE composeN #-}
+ src/Optics/Internal/Optic/Types.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | This module is intended for internal use only, and may change without+-- warning in subsequent releases.+module Optics.Internal.Optic.Types where++import GHC.Exts (Constraint)++import Optics.Internal.Bi+import Optics.Internal.Profunctor++-- | Tag for an iso.+data An_Iso+-- | Tag for a lens.+data A_Lens+-- | Tag for a prism.+data A_Prism+-- | Tag for an affine traversal.+data An_AffineTraversal+-- | Tag for a traversal.+data A_Traversal+-- | Tag for a setter.+data A_Setter+-- | Tag for a reversed prism.+data A_ReversedPrism+-- | Tag for a getter.+data A_Getter+-- | Tag for an affine fold.+data An_AffineFold+-- | Tag for a fold.+data A_Fold+-- | Tag for a reversed lens.+data A_ReversedLens+-- | Tag for a review.+data A_Review++-- | Mapping tag types @k@ to constraints on @p@.+--+-- Using this type family we define the constraints that the various flavours of+-- optics have to fulfill.+--+type family Constraints (k :: *) (p :: * -> * -> * -> *) :: Constraint where+  Constraints An_Iso             p = Profunctor p+  Constraints A_Lens             p = Strong p+  Constraints A_ReversedLens     p = Costrong p+  Constraints A_Prism            p = Choice p+  Constraints A_ReversedPrism    p = Cochoice p+  Constraints An_AffineTraversal p = Visiting p+  Constraints A_Traversal        p = Traversing p+  Constraints A_Setter           p = Mapping p+  Constraints A_Getter           p = (Bicontravariant p, Cochoice p, Strong p)+  Constraints An_AffineFold      p = (Bicontravariant p, Cochoice p, Visiting p)+  Constraints A_Fold             p = (Bicontravariant p, Cochoice p, Traversing p)+  Constraints A_Review           p = (Bifunctor p, Choice p, Costrong p)
+ src/Optics/Internal/Profunctor.hs view
@@ -0,0 +1,705 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Definitions of concrete profunctors and profunctor classes.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Profunctor where++import Data.Coerce (Coercible, coerce)+import Data.Functor.Const+import Data.Functor.Identity++import Optics.Internal.Utils++----------------------------------------+-- Concrete profunctors++-- | Needed for traversals.+newtype Star f i a b = Star { runStar :: a -> f b }++-- | Needed for getters and folds.+newtype Forget r i a b = Forget { runForget :: a -> r }++-- | Needed for affine folds.+newtype ForgetM r i a b = ForgetM { runForgetM :: a -> Maybe r }++-- | Needed for setters.+newtype FunArrow i a b = FunArrow { runFunArrow :: a -> b }++-- | Needed for indexed traversals.+newtype IxStar f i a b = IxStar { runIxStar :: i -> a -> f b }++-- | Needed for indexed folds.+newtype IxForget r i a b = IxForget { runIxForget :: i -> a -> r }++-- | Needed for indexed affine folds.+newtype IxForgetM r i a b = IxForgetM { runIxForgetM :: i -> a -> Maybe r }++-- | Needed for indexed setters.+newtype IxFunArrow i a b = IxFunArrow { runIxFunArrow :: i -> a -> b }++----------------------------------------+-- Utils++-- Needed for strict application of (indexed) setters.+--+-- Credit for this goes to Eric Mertens, see+-- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.+data Identity' a = Identity' {-# UNPACK #-} !() a+  deriving Functor++instance Applicative Identity' where+  pure a = Identity' () a+  {-# INLINE pure #-}+  Identity' () f <*> Identity' () x = Identity' () (f x)+  {-# INLINE (<*>) #-}++-- | Mark a value for evaluation to whnf.+--+-- This allows us to, when applying a setter to a structure, evaluate only the+-- parts that we modify. If an optic focuses on multiple targets, Applicative+-- instance of Identity' makes sure that we force evaluation of all of them, but+-- we leave anything else alone.+--+wrapIdentity' :: a -> Identity' a+wrapIdentity' a = Identity' (a `seq` ()) a+{-# INLINE wrapIdentity' #-}++unwrapIdentity' :: Identity' a -> a+unwrapIdentity' (Identity' () a) = a+{-# INLINE unwrapIdentity' #-}++----------------------------------------++-- | Needed for conversion of affine traversal back to its VL representation.+data StarA f i a b = StarA (forall r. r -> f r) (a -> f b)++-- | Unwrap 'StarA'.+runStarA :: StarA f i a b -> a -> f b+runStarA (StarA _ k) = k+{-# INLINE runStarA #-}++-- | Needed for conversion of indexed affine traversal back to its VL+-- representation.+data IxStarA f i a b = IxStarA (forall r. r -> f r) (i -> a -> f b)++-- | Unwrap 'StarA'.+runIxStarA :: IxStarA f i a b -> i -> a -> f b+runIxStarA (IxStarA _ k) = k+{-# INLINE runIxStarA #-}++----------------------------------------++-- | Repack 'Star' to change its index type.+reStar :: Star f i a b -> Star f j a b+reStar (Star k) = Star k+{-# INLINE reStar #-}++-- | Repack 'Forget' to change its index type.+reForget :: Forget r i a b -> Forget r j a b+reForget (Forget k) = Forget k+{-# INLINE reForget #-}++-- | Repack 'FunArrow' to change its index type.+reFunArrow :: FunArrow i a b -> FunArrow j a b+reFunArrow (FunArrow k) = FunArrow k+{-# INLINE reFunArrow #-}++----------------------------------------+-- Classes and instances++class Profunctor p where+  dimap :: (a -> b) -> (c -> d) -> p i b c -> p i a d+  lmap  :: (a -> b)             -> p i b c -> p i a c+  rmap  ::             (c -> d) -> p i b c -> p i b d++  lcoerce' :: Coercible a b => p i a c -> p i b c+  default lcoerce'+    :: Coercible (p i a c) (p i b c)+    => p i a c+    -> p i b c+  lcoerce' = coerce+  {-# INLINE lcoerce' #-}++  rcoerce' :: Coercible a b => p i c a -> p i c b+  default rcoerce'+    :: Coercible (p i c a) (p i c b)+    => p i c a+    -> p i c b+  rcoerce' = coerce+  {-# INLINE rcoerce' #-}++  conjoined__+    :: (p i a b -> p i s t)+    -> (p i a b -> p j s t)+    -> (p i a b -> p j s t)+  default conjoined__+    :: Coercible (p i s t) (p j s t)+    => (p i a b -> p i s t)+    -> (p i a b -> p j s t)+    -> (p i a b -> p j s t)+  conjoined__ f _ = coerce . f+  {-# INLINE conjoined__ #-}++  ixcontramap :: (j -> i) -> p i a b -> p j a b+  default ixcontramap+    :: Coercible (p i a b) (p j a b)+    => (j -> i)+    -> p i a b+    -> p j a b+  ixcontramap _ = coerce+  {-# INLINE ixcontramap #-}++-- | 'rcoerce'' with type arguments rearranged for TypeApplications.+rcoerce :: (Coercible a b, Profunctor p) => p i c a -> p i c b+rcoerce = rcoerce'+{-# INLINE rcoerce #-}++-- | 'lcoerce'' with type arguments rearranged for TypeApplications.+lcoerce :: (Coercible a b, Profunctor p) => p i a c -> p i b c+lcoerce = lcoerce'+{-# INLINE lcoerce #-}++instance Functor f => Profunctor (StarA f) where+  dimap f g (StarA point k) = StarA point (fmap g . k . f)+  lmap  f   (StarA point k) = StarA point (k . f)+  rmap    g (StarA point k) = StarA point (fmap g . k)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++instance Functor f => Profunctor (Star f) where+  dimap f g (Star k) = Star (fmap g . k . f)+  lmap  f   (Star k) = Star (k . f)+  rmap    g (Star k) = Star (fmap g . k)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++instance Profunctor (Forget r) where+  dimap f _ (Forget k) = Forget (k . f)+  lmap  f   (Forget k) = Forget (k . f)+  rmap   _g (Forget k) = Forget k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Profunctor (ForgetM r) where+  dimap f _ (ForgetM k) = ForgetM (k . f)+  lmap  f   (ForgetM k) = ForgetM (k . f)+  rmap   _g (ForgetM k) = ForgetM k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Profunctor FunArrow where+  dimap f g (FunArrow k) = FunArrow (g . k . f)+  lmap  f   (FunArrow k) = FunArrow (k . f)+  rmap    g (FunArrow k) = FunArrow (g . k)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Functor f => Profunctor (IxStarA f) where+  dimap f g (IxStarA point k) = IxStarA point (\i -> fmap g . k i . f)+  lmap  f   (IxStarA point k) = IxStarA point (\i -> k i . f)+  rmap    g (IxStarA point k) = IxStarA point (\i -> fmap g . k i)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++  conjoined__ _ f = f+  ixcontramap ij (IxStarA point k) = IxStarA point $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Functor f => Profunctor (IxStar f) where+  dimap f g (IxStar k) = IxStar (\i -> fmap g . k i . f)+  lmap  f   (IxStar k) = IxStar (\i -> k i . f)+  rmap    g (IxStar k) = IxStar (\i -> fmap g . k i)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++  conjoined__ _ f = f+  ixcontramap ij (IxStar k) = IxStar $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Profunctor (IxForget r) where+  dimap f _ (IxForget k) = IxForget (\i -> k i . f)+  lmap  f   (IxForget k) = IxForget (\i -> k i . f)+  rmap   _g (IxForget k) = IxForget k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  conjoined__ _ f = f+  ixcontramap ij (IxForget k) = IxForget $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Profunctor (IxForgetM r) where+  dimap f _ (IxForgetM k) = IxForgetM (\i -> k i . f)+  lmap  f   (IxForgetM k) = IxForgetM (\i -> k i . f)+  rmap   _g (IxForgetM k) = IxForgetM k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  conjoined__ _ f = f+  ixcontramap ij (IxForgetM k) = IxForgetM $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Profunctor IxFunArrow where+  dimap f g (IxFunArrow k) = IxFunArrow (\i -> g . k i . f)+  lmap  f   (IxFunArrow k) = IxFunArrow (\i -> k i . f)+  rmap    g (IxFunArrow k) = IxFunArrow (\i -> g . k i)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  conjoined__ _ f = f+  ixcontramap ij (IxFunArrow k) = IxFunArrow $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++----------------------------------------++class Profunctor p => Strong p where+  first'  :: p i a b -> p i (a, c) (b, c)+  second' :: p i a b -> p i (c, a) (c, b)++  -- There are a few places where default implementation is good enough.+  linear+    :: (forall f. Functor f => (a -> f b) -> s -> f t)+    -> p i a b+    -> p i s t+  linear f = dimap+    ((\(Context bt a) -> (a, bt)) . f (Context id))+    (\(b, bt) -> bt b)+    . first'+  {-# INLINE linear #-}++  -- There are a few places where default implementation is good enough.+  ilinear+    :: (forall f. Functor f => (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  default ilinear+    :: Coercible (p j s t) (p (i -> j) s t)+    => (forall f. Functor f => (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  ilinear f = coerce . linear (\afb -> f $ \_ -> afb)+  {-# INLINE ilinear #-}++instance Functor f => Strong (StarA f) where+  first'  (StarA point k) = StarA point $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a+  second' (StarA point k) = StarA point $ \ ~(c, a) -> (,) c <$> k a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (StarA point k) = StarA point (f k)+  {-# INLINE linear #-}++instance Functor f => Strong (Star f) where+  first'  (Star k) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a+  second' (Star k) = Star $ \ ~(c, a) -> (,) c <$> k a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (Star k) = Star (f k)+  {-# INLINE linear #-}++instance Strong (Forget r) where+  first'  (Forget k) = Forget (k . fst)+  second' (Forget k) = Forget (k . snd)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (Forget k) = Forget (getConst #. f (Const #. k))+  {-# INLINE linear #-}++instance Strong (ForgetM r) where+  first'  (ForgetM k) = ForgetM (k . fst)+  second' (ForgetM k) = ForgetM (k . snd)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (ForgetM k) = ForgetM (getConst #. f (Const #. k))+  {-# INLINE linear #-}++instance Strong FunArrow where+  first'  (FunArrow k) = FunArrow $ \ ~(a, c) -> (k a, c)+  second' (FunArrow k) = FunArrow $ \ ~(c, a) -> (c, k a)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k)+  {-# INLINE linear #-}++instance Functor f => Strong (IxStarA f) where+  first'  (IxStarA point k) = IxStarA point $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a+  second' (IxStarA point k) = IxStarA point $ \i ~(c, a) -> (,) c <$> k i a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxStarA point k) = IxStarA point $ \i -> f (k i)+  ilinear f (IxStarA point k) = IxStarA point $ \ij -> f $ \i -> k (ij i)+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Functor f => Strong (IxStar f) where+  first'  (IxStar k) = IxStar $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a+  second' (IxStar k) = IxStar $ \i ~(c, a) -> (,) c <$> k i a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxStar k) = IxStar $ \i -> f (k i)+  ilinear f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i)+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Strong (IxForget r) where+  first'  (IxForget k) = IxForget $ \i -> k i . fst+  second' (IxForget k) = IxForget $ \i -> k i . snd+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxForget k) = IxForget $ \i -> getConst #. f (Const #. k i)+  ilinear f (IxForget k) = IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i))+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Strong (IxForgetM r) where+  first'  (IxForgetM k) = IxForgetM $ \i -> k i . fst+  second' (IxForgetM k) = IxForgetM $ \i -> k i . snd+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxForgetM k) = IxForgetM $ \i -> getConst #. f (Const #. k i)+  ilinear f (IxForgetM k) = IxForgetM $ \ij -> getConst #. f (\i -> Const #. k (ij i))+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Strong IxFunArrow where+  first'  (IxFunArrow k) = IxFunArrow $ \i ~(a, c) -> (k i a, c)+  second' (IxFunArrow k) = IxFunArrow $ \i ~(c, a) -> (c, k i a)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxFunArrow k) = IxFunArrow $ \i ->+    runIdentity #. f (Identity #. k i)+  ilinear f (IxFunArrow k) = IxFunArrow $ \ij ->+    runIdentity #. f (\i -> Identity #. k (ij i))+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++----------------------------------------++class Profunctor p => Costrong p where+  unfirst  :: p i (a, d) (b, d) -> p i a b+  unsecond :: p i (d, a) (d, b) -> p i a b++----------------------------------------++class Profunctor p => Choice p where+  left'  :: p i a b -> p i (Either a c) (Either b c)+  right' :: p i a b -> p i (Either c a) (Either c b)++instance Functor f => Choice (StarA f) where+  left'  (StarA point k) = StarA point $ either (fmap Left . k) (point . Right)+  right' (StarA point k) = StarA point $ either (point . Left) (fmap Right . k)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Applicative f => Choice (Star f) where+  left'  (Star k) = Star $ either (fmap Left . k) (pure . Right)+  right' (Star k) = Star $ either (pure . Left) (fmap Right . k)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Monoid r => Choice (Forget r) where+  left'  (Forget k) = Forget $ either k (const mempty)+  right' (Forget k) = Forget $ either (const mempty) k+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice (ForgetM r) where+  left'  (ForgetM k) = ForgetM $ either k (const Nothing)+  right' (ForgetM k) = ForgetM $ either (const Nothing) k+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice FunArrow where+  left'  (FunArrow k) = FunArrow $ either (Left . k) Right+  right' (FunArrow k) = FunArrow $ either Left (Right . k)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Functor f => Choice (IxStarA f) where+  left'  (IxStarA point k) =+    IxStarA point $ \i -> either (fmap Left . k i) (point . Right)+  right' (IxStarA point k) =+    IxStarA point $ \i -> either (point . Left) (fmap Right . k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Applicative f => Choice (IxStar f) where+  left'  (IxStar k) = IxStar $ \i -> either (fmap Left . k i) (pure . Right)+  right' (IxStar k) = IxStar $ \i -> either (pure . Left) (fmap Right . k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Monoid r => Choice (IxForget r) where+  left'  (IxForget k) = IxForget $ \i -> either (k i) (const mempty)+  right' (IxForget k) = IxForget $ \i -> either (const mempty) (k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice (IxForgetM r) where+  left'  (IxForgetM k) = IxForgetM $ \i -> either (k i) (const Nothing)+  right' (IxForgetM k) = IxForgetM $ \i -> either (const Nothing) (k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice IxFunArrow where+  left'  (IxFunArrow k) = IxFunArrow $ \i -> either (Left . k i) Right+  right' (IxFunArrow k) = IxFunArrow $ \i -> either Left (Right . k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++----------------------------------------++class Profunctor p => Cochoice p where+  unleft  :: p i (Either a d) (Either b d) -> p i a b+  unright :: p i (Either d a) (Either d b) -> p i a b++instance Cochoice (Forget r) where+  unleft  (Forget k) = Forget (k . Left)+  unright (Forget k) = Forget (k . Right)+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++instance Cochoice (ForgetM r) where+  unleft  (ForgetM k) = ForgetM (k . Left)+  unright (ForgetM k) = ForgetM (k . Right)+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++instance Cochoice (IxForget r) where+  unleft  (IxForget k) = IxForget $ \i -> k i . Left+  unright (IxForget k) = IxForget $ \i -> k i . Right+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++instance Cochoice (IxForgetM r) where+  unleft  (IxForgetM k) = IxForgetM (\i -> k i . Left)+  unright (IxForgetM k) = IxForgetM (\i -> k i . Right)+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++----------------------------------------++class (Choice p, Strong p) => Visiting p where+  visit+    :: forall i s t a b+    . (forall f. Functor f => (forall r. r -> f r) -> (a -> f b) -> s -> f t)+    -> p i a b+    -> p i s t+  visit f =+    let match :: s -> Either a t+        match s = f Right Left s+        update :: s -> b -> t+        update s b = runIdentity $ f Identity (\_ -> Identity b) s+    in dimap (\s -> (match s, s))+             (\(ebt, s) -> either (update s) id ebt)+       . first'+       . left'+  {-# INLINE visit #-}++  ivisit+    :: (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  default ivisit+    :: Coercible (p j s t) (p (i -> j) s t)+    => (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  ivisit f = coerce . visit (\point afb -> f point $ \_ -> afb)+  {-# INLINE ivisit #-}+++instance Functor f => Visiting (StarA f) where+  visit  f (StarA point k) = StarA point $ f point k+  ivisit f (StarA point k) = StarA point $ f point (\_ -> k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Applicative f => Visiting (Star f) where+  visit  f (Star k) = Star $ f pure k+  ivisit f (Star k) = Star $ f pure (\_ -> k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Monoid r => Visiting (Forget r) where+  visit  f (Forget k) = Forget $ getConst #. f pure (Const #. k)+  ivisit f (Forget k) = Forget $ getConst #. f pure (\_ -> Const #. k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting (ForgetM r) where+  visit  f (ForgetM k) =+    ForgetM $ getConst #. f (\_ -> Const Nothing) (Const #. k)+  ivisit f (ForgetM k) =+    ForgetM $ getConst #. f (\_ -> Const Nothing) (\_ -> Const #. k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting FunArrow where+  visit  f (FunArrow k) = FunArrow $ runIdentity #. f pure (Identity #. k)+  ivisit f (FunArrow k) = FunArrow $ runIdentity #. f pure (\_ -> Identity #. k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Functor f => Visiting (IxStarA f) where+  visit  f (IxStarA point k) = IxStarA point $ \i  -> f point (k i)+  ivisit f (IxStarA point k) = IxStarA point $ \ij -> f point $ \i -> k (ij i)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Applicative f => Visiting (IxStar f) where+  visit  f (IxStar k) = IxStar $ \i  -> f pure (k i)+  ivisit f (IxStar k) = IxStar $ \ij -> f pure $ \i -> k (ij i)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Monoid r => Visiting (IxForget r) where+  visit  f (IxForget k) =+    IxForget $ \i  -> getConst #. f pure (Const #. k i)+  ivisit f (IxForget k) =+    IxForget $ \ij -> getConst #. f pure (\i -> Const #. k (ij i))+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting (IxForgetM r) where+  visit  f (IxForgetM k) =+    IxForgetM $ \i  -> getConst #. f (\_ -> Const Nothing) (Const #. k i)+  ivisit f (IxForgetM k) =+    IxForgetM $ \ij -> getConst #. f (\_ -> Const Nothing) (\i -> Const #. k (ij i))+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting IxFunArrow where+  visit  f (IxFunArrow k) =+    IxFunArrow $ \i  -> runIdentity #. f pure (Identity #. k i)+  ivisit f (IxFunArrow k) =+    IxFunArrow $ \ij -> runIdentity #. f pure (\i -> Identity #. k (ij i))+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++----------------------------------------++class Visiting p => Traversing p where+  wander+    :: (forall f. Applicative f => (a -> f b) -> s -> f t)+    -> p i a b+    -> p i s t+  iwander+    :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t++instance Applicative f => Traversing (Star f) where+  wander  f (Star k) = Star $ f k+  iwander f (Star k) = Star $ f (\_ -> k)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Monoid r => Traversing (Forget r) where+  wander  f (Forget k) = Forget $ getConst #. f (Const #. k)+  iwander f (Forget k) = Forget $ getConst #. f (\_ -> Const #. k)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Traversing FunArrow where+  wander  f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k)+  iwander f (FunArrow k) = FunArrow $ runIdentity #. f (\_ -> Identity #. k)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Applicative f => Traversing (IxStar f) where+  wander  f (IxStar k) = IxStar $ \i -> f (k i)+  iwander f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Monoid r => Traversing (IxForget r) where+  wander  f (IxForget k) =+    IxForget $ \i -> getConst #. f (Const #. k i)+  iwander f (IxForget k) =+    IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i))+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Traversing IxFunArrow where+  wander  f (IxFunArrow k) =+    IxFunArrow $ \i -> runIdentity #. f (Identity #. k i)+  iwander f (IxFunArrow k) =+    IxFunArrow $ \ij -> runIdentity #. f (\i -> Identity #. k (ij i))+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++----------------------------------------++class Traversing p => Mapping p where+  roam+    :: ((a -> b) -> s -> t)+    -> p i a b+    -> p i s t+  iroam+    :: ((i -> a -> b) -> s -> t)+    -> p       j  a b+    -> p (i -> j) s t++instance Mapping (Star Identity') where+  roam  f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k)+  iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k)+  {-# INLINE roam #-}+  {-# INLINE iroam #-}++instance Mapping FunArrow where+  roam  f (FunArrow k) = FunArrow $ f k+  iroam f (FunArrow k) = FunArrow $ f (const k)+  {-# INLINE roam #-}+  {-# INLINE iroam #-}++instance Mapping (IxStar Identity') where+  roam  f (IxStar k) =+    IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i)+  iroam f (IxStar k) =+    IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij i))+  {-# INLINE roam #-}+  {-# INLINE iroam #-}++instance Mapping IxFunArrow where+  roam  f (IxFunArrow k) = IxFunArrow $ \i -> f (k i)+  iroam f (IxFunArrow k) = IxFunArrow $ \ij -> f $ \i -> k (ij i)+  {-# INLINE roam #-}+  {-# INLINE iroam #-}
+ src/Optics/Internal/Setter.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Internal implementation details of setters.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Setter where++import Optics.Internal.Profunctor+import Optics.Internal.Optic++-- | Internal implementation of 'Optics.Setter.mapped'.+mapped__+  :: (Mapping p, Functor f)+  => Optic__ p i i (f a) (f b) a b+mapped__ = roam fmap+{-# INLINE mapped__ #-}
+ src/Optics/Internal/Tagged.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Based on the @tagged@ package.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+--+module Optics.Internal.Tagged where++import Data.Coerce++import Optics.Internal.Bi+import Optics.Internal.Profunctor+import Optics.Internal.Utils++-- | Tag a value with not one but two phantom type parameters (so that 'Tagged'+-- can be used as an indexed profunctor).+newtype Tagged i a b = Tagged { unTagged :: b }++instance Functor (Tagged i a) where+  fmap f = Tagged #. f .# unTagged+  {-# INLINE fmap #-}++instance Bifunctor Tagged where+  bimap  _f g = Tagged #. g .# unTagged+  first  _f   = coerce+  second    g = Tagged #. g .# unTagged+  {-# INLINE bimap #-}+  {-# INLINE first #-}+  {-# INLINE second #-}++instance Profunctor Tagged where+  dimap _f g = Tagged #. g .# unTagged+  lmap  _f   = coerce+  rmap     g = Tagged #. g .# unTagged+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Choice Tagged where+  left'  = Tagged #. Left  .# unTagged+  right' = Tagged #. Right .# unTagged+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Costrong Tagged where+  unfirst (Tagged bd) = Tagged (fst bd)+  unsecond (Tagged db) = Tagged (snd db)+  {-# INLINE unfirst #-}+  {-# INLINE unsecond #-}
+ src/Optics/Internal/Traversal.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Internal implementation details of traversals.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Traversal where++import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Fold+import Optics.Internal.Setter++-- | Internal implementation of 'Optics.Traversal.traversed'.+traversed__+  :: (Traversing p, Traversable f)+  => Optic__ p i i (f a) (f b) a b+traversed__ = wander traverse+{-# INLINE [0] traversed__ #-}++-- Because traversed__ inlines late, GHC needs rewrite rules for all cases in+-- order to generate optimal code for each of them. The one that rewrites+-- traversal into a traversal correspond to an early inline.++{-# RULES++"traversed__ -> wander traverse"+  forall (o :: Star g i a b). traversed__ o = wander traverse o+    :: Traversable f => Star g i (f a) (f b)++"traversed__ -> folded__"+  forall (o :: Forget r i a b). traversed__ o = folded__ o+    :: Foldable f => Forget r i (f a) (f b)++"traversed__ -> mapped__"+  forall (o :: FunArrow i a b). traversed__ o = mapped__ o+    :: Functor f => FunArrow i (f a) (f b)++#-}
+ src/Optics/Internal/Utils.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Optics.Internal.Utils where++import Data.Coerce+import qualified Data.Semigroup as SG++data Context a b t = Context (b -> t) a+  deriving Functor++-- | Composition operator where the first argument must be an identity+-- function up to representational equivalence (e.g. a newtype wrapper+-- or unwrapper), and will be ignored at runtime.+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)+(#.) _f = coerce+infixl 8 .#+{-# INLINE (#.) #-}++-- | Composition operator where the second argument must be an+-- identity function up to representational equivalence (e.g. a+-- newtype wrapper or unwrapper), and will be ignored at runtime.+(.#) :: Coercible a b => (b -> c) -> (a -> b) -> (a -> c)+(.#) f _g = coerce f+infixr 9 #.+{-# INLINE (.#) #-}++----------------------------------------++-- | Helper for 'Optics.Fold.traverseOf_' and the like for better+-- efficiency than the foldr-based version.+--+-- Note that the argument @a@ of the result should not be used.+newtype Traversed f a = Traversed (f a)++runTraversed :: Functor f => Traversed f a -> f ()+runTraversed (Traversed fa) = () <$ fa+{-# INLINE runTraversed #-}++instance Applicative f => SG.Semigroup (Traversed f a) where+  Traversed ma <> Traversed mb = Traversed (ma *> mb)+  {-# INLINE (<>) #-}++instance Applicative f => Monoid (Traversed f a) where+  mempty = Traversed (pure (error "Traversed: value used"))+  mappend = (SG.<>)+  {-# INLINE mempty #-}+  {-# INLINE mappend #-}++----------------------------------------++-- | Helper for 'Optics.Fold.failing' family to visit the first fold only once.+data OrT f a = OrT !Bool (f a)+  deriving Functor++instance Applicative f => Applicative (OrT f) where+  pure = OrT False . pure+  OrT a f <*> OrT b x = OrT (a || b) (f <*> x)+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}++-- | Wrap the applicative action in 'OrT' so that we know later that it was+-- executed.+wrapOrT :: f a -> OrT f a+wrapOrT = OrT True+{-# INLINE wrapOrT #-}
+ src/Optics/Iso.hs view
@@ -0,0 +1,274 @@+-- |+-- Module: Optics.Iso+-- Description: Translates between types with the same structure.+--+-- An 'Iso'morphism expresses the fact that two types have the+-- same structure, and hence can be converted from one to the other in+-- either direction.+--+module Optics.Iso+  (+  -- * Formation+    Iso+  , Iso'++  -- * Introduction+  , iso++  -- * Elimination+  -- | An 'Iso' is in particular a 'Optics.Getter.Getter', a+  -- 'Optics.Review.Review' and a 'Optics.Setter.Setter', therefore you can+  -- specialise types to obtain:+  --+  -- @+  -- 'Optics.Getter.view'   :: 'Iso' s t a b -> s -> a+  -- 'Optics.Review.review' :: 'Iso' s t a b -> b -> t+  -- @+  --+  -- @+  -- 'Optics.Setter.over'   :: 'Iso' s t a b -> (a -> b) -> s -> t+  -- 'Optics.Setter.set'    :: 'Iso' s t a b ->       b  -> s -> t+  -- @++  -- * Computation+  -- |+  --+  -- @+  -- 'Optics.Getter.view'   ('iso' f g) ≡ f+  -- 'Optics.Review.review' ('iso' f g) ≡ g+  -- @++  -- * Well-formedness+  -- | The functions translating back and forth must be mutually inverse:+  --+  -- @+  -- 'Optics.Getter.view' i . 'Optics.Getter.review' i ≡ 'id'+  -- 'Optics.Getter.review' i . 'Optics.Getter.view' i ≡ 'id'+  -- @++  -- * Additional introduction forms+  , equality+  , simple+  , coerced+  , coercedTo+  , coerced1+  , curried+  , uncurried+  , flipped+  , involuted+  , Swapped(..)++  -- * Additional elimination forms+  , withIso+  , au+  , under++  -- * Combinators+  -- | The 'Optics.Re.re' combinator can be used to reverse an 'Iso':+  --+  -- @+  -- 'Optics.Re.re' :: 'Iso' s t a b -> 'Iso' b a t s+  -- @+  , mapping++  -- * Subtyping+  , An_Iso+  -- | <<diagrams/Iso.png Iso in the optics hierarchy>>+  )+  where++import Data.Tuple+import Data.Bifunctor+import Data.Coerce++import Optics.Internal.Concrete+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for a type-modifying iso.+type Iso s t a b = Optic An_Iso NoIx s t a b++-- | Type synonym for a type-preserving iso.+type Iso' s a = Optic' An_Iso NoIx s a++-- | Build an iso from a pair of inverse functions.+--+-- If you want to build an 'Iso' from the van Laarhoven representation, use+-- @isoVL@ from the @optics-vl@ package.+iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso f g = Optic (dimap f g)+{-# INLINE iso #-}++-- | Extract the two components of an isomorphism.+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r+withIso o k = case getOptic o (Exchange id id) of+  Exchange sa bt -> k sa bt+{-# INLINE withIso #-}++-- | Based on @ala@ from Conor McBride's work on Epigram.+--+-- This version is generalized to accept any 'Iso', not just a @newtype@.+--+-- >>> au (coerced1 @Sum) foldMap [1,2,3,4]+-- 10+--+-- You may want to think of this combinator as having the following, simpler+-- type:+--+-- @+-- au :: 'Iso' s t a b -> ((b -> t) -> e -> s) -> e -> a+-- @+au :: Functor f => Iso s t a b -> ((b -> t) -> f s) -> f a+au k = withIso k $ \sa bt f -> sa <$> f bt+{-# INLINE au #-}++-- | The opposite of working 'Optics.Setter.over' a 'Optics.Setter.Setter' is+-- working 'under' an isomorphism.+--+-- @+-- 'under' ≡ 'Optics.Setter.over' '.' 'Optics.Re.re'+-- @+under :: Iso s t a b -> (t -> s) -> b -> a+under k = withIso k $ \sa bt ts -> sa . ts . bt+{-# INLINE under #-}++----------------------------------------+-- Isomorphisms++-- | This can be used to lift any 'Iso' into an arbitrary 'Functor'.+mapping+  :: (Functor f, Functor g)+  => Iso    s     t     a     b+  -> Iso (f s) (g t) (f a) (g b)+mapping k = withIso k $ \sa bt -> iso (fmap sa) (fmap bt)+{-# INLINE mapping #-}++-- | Capture type constraints as an isomorphism.+--+-- /Note:/ This is the identity optic:+--+-- >>> :t view equality+-- view equality :: a -> a+equality :: (s ~ a, t ~ b) => Iso s t a b+equality = Optic id+{-# INLINE equality #-}++-- | Proof of reflexivity.+simple :: Iso' a a+simple = Optic id+{-# INLINE simple #-}++-- | Data types that are representationally equal are isomorphic.+--+-- >>> view coerced 'x' :: Identity Char+-- Identity 'x'+--+coerced :: (Coercible s a, Coercible t b) => Iso s t a b+coerced = Optic (lcoerce' . rcoerce')+{-# INLINE coerced #-}++-- | Type-preserving version of 'coerced' with type parameters rearranged for+-- TypeApplications.+--+-- >>> newtype MkInt = MkInt Int deriving Show+--+-- >>> over (coercedTo @Int) (*3) (MkInt 2)+-- MkInt 6+--+coercedTo :: forall a s. Coercible s a => Iso' s a+coercedTo = Optic (lcoerce' . rcoerce')+{-# INLINE coercedTo #-}++-- | Special case of 'coerced' for trivial newtype wrappers.+--+-- >>> over (coerced1 @Identity) (++ "bar") (Identity "foo")+-- Identity "foobar"+--+coerced1+  :: forall f s a. (Coercible s (f s), Coercible a (f a))+  => Iso (f s) (f a) s a+coerced1 = Optic (lcoerce' . rcoerce')+{-# INLINE coerced1 #-}++-- | The canonical isomorphism for currying and uncurrying a function.+--+-- @+-- 'curried' = 'iso' 'curry' 'uncurry'+-- @+--+-- >>> view curried fst 3 4+-- 3+--+curried :: Iso ((a, b) -> c) ((d, e) -> f) (a -> b -> c) (d -> e -> f)+curried = iso curry uncurry+{-# INLINE curried #-}++-- | The canonical isomorphism for uncurrying and currying a function.+--+-- @+-- 'uncurried' = 'iso' 'uncurry' 'curry'+-- @+--+-- @+-- 'uncurried' = 'Optics.Re.re' 'curried'+-- @+--+-- >>> (view uncurried (+)) (1,2)+-- 3+--+uncurried :: Iso (a -> b -> c) (d -> e -> f) ((a, b) -> c) ((d, e) -> f)+uncurried = iso uncurry curry+{-# INLINE uncurried #-}++-- | The isomorphism for flipping a function.+--+-- >>> (view flipped (,)) 1 2+-- (2,1)+--+flipped :: Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c')+flipped = iso flip flip+{-# INLINE flipped #-}++-- | Given a function that is its own inverse, this gives you an 'Iso' using it+-- in both directions.+--+-- @+-- 'involuted' ≡ 'Control.Monad.join' 'iso'+-- @+--+-- >>> "live" ^. involuted reverse+-- "evil"+--+-- >>> "live" & involuted reverse %~ ('d':)+-- "lived"+involuted :: (a -> a) -> Iso' a a+involuted a = iso a a+{-# INLINE involuted #-}++-- | This class provides for symmetric bifunctors.+class Bifunctor p => Swapped p where+  -- |+  -- @+  -- 'swapped' '.' 'swapped' ≡ 'id'+  -- 'first' f '.' 'swapped' = 'swapped' '.' 'second' f+  -- 'second' g '.' 'swapped' = 'swapped' '.' 'first' g+  -- 'bimap' f g '.' 'swapped' = 'swapped' '.' 'bimap' g f+  -- @+  --+  -- >>> view swapped (1,2)+  -- (2,1)+  --+  swapped :: Iso (p a b) (p c d) (p b a) (p d c)++instance Swapped (,) where+  swapped = iso swap swap+  {-# INLINE swapped #-}++instance Swapped Either where+  swapped = iso (either Right Left) (either Right Left)+  {-# INLINE swapped #-}++-- $setup+-- >>> import Data.Functor.Identity+-- >>> import Data.Monoid+-- >>> import Optics.Core
+ src/Optics/IxAffineFold.hs view
@@ -0,0 +1,83 @@+-- |+-- Module: Optics.IxAffineFold+-- Description: An indexed version of an 'Optics.AffineFold.AffineFold'.+--+-- An 'IxAffineFold' is an indexed version of an 'Optics.AffineFold.AffineFold'.+-- See the "Indexed optics" section of the overview documentation in the+-- @Optics@ module of the main @optics@ package for more details on indexed+-- optics.+--+module Optics.IxAffineFold+  (+  -- * Formation+    IxAffineFold++  -- * Introduction+  , iafolding++  -- * Elimination+  , ipreview+  , ipreviews++  -- * Computation+  -- |+  --+  -- @+  -- 'ipreview' ('iafolding' f) ≡ f+  -- @++  -- * Semigroup structure+  , iafailing++  -- * Subtyping+  , An_AffineFold+  ) where++import Optics.AffineFold+import Optics.Internal.Bi+import Optics.Internal.Indexed+import Optics.Internal.Profunctor+import Optics.Internal.Optic++-- | Type synonym for an indexed affine fold.+type IxAffineFold i s a = Optic' An_AffineFold (WithIx i) s a++-- | Retrieve the value along with its index targeted by an 'IxAffineFold'.+ipreview+  :: (Is k An_AffineFold, is `HasSingleIndex` i)+  => Optic' k is s a+  -> s -> Maybe (i, a)+ipreview o = ipreviews o (,)+{-# INLINE ipreview #-}++-- | Retrieve a function of the value and its index targeted by an+-- 'IxAffineFold'.+ipreviews+  :: (Is k An_AffineFold, is `HasSingleIndex` i)+  => Optic' k is s a+  -> (i -> a -> r) -> s -> Maybe r+ipreviews o = \f -> runIxForgetM+  (getOptic (castOptic @An_AffineFold o) . IxForgetM $ \i -> Just . f i)+  id+{-# INLINE ipreviews #-}++-- | Create an 'IxAffineFold' from a partial function.+iafolding :: (s -> Maybe (i, a)) -> IxAffineFold i s a+iafolding g = Optic+  $ ivisit (\point f s -> maybe (point s) (uncurry f) $ g s)+  . rphantom+{-# INLINE iafolding #-}++-- | Try the first 'IxAffineFold'. If it returns no entry, try the second one.+--+-- /Note:/ There is no 'Optics.IxFold.isumming' equivalent, because @iasumming = iafailing@.+iafailing+  :: (Is k An_AffineFold, Is l An_AffineFold,+      is1 `HasSingleIndex` i, is2 `HasSingleIndex` i)+  => Optic' k is1 s a+  -> Optic' l is2 s a+  -> IxAffineFold i s a+iafailing a b = conjoined (afailing a b) $ iafolding $ \s ->+  maybe (ipreview b s) Just (ipreview a s)+infixl 3 `iafailing` -- Same as (<|>)+{-# INLINE iafailing #-}
+ src/Optics/IxAffineTraversal.hs view
@@ -0,0 +1,88 @@+-- |+-- Module: Optics.IxAffineTraversal+-- Description: An indexed version of an 'Optics.AffineTraversal.AffineTraversal'.+--+-- An 'IxAffineTraversal' is an indexed version of an+-- 'Optics.AffineTraversal.AffineTraversal'.  See the "Indexed optics" section+-- of the overview documentation in the @Optics@ module of the main @optics@+-- package for more details on indexed optics.+--+module Optics.IxAffineTraversal+  (+  -- * Formation+    IxAffineTraversal+  , IxAffineTraversal'++  -- * Introduction+  , iatraversal++  -- * Elimination+  -- | An 'IxAffineTraversal' is in particular an+  -- 'Optics.IxAffineFold.IxAffineFold' and an 'Optics.IxSetter.IxSetter',+  -- therefore you can specialise types to obtain:+  --+  -- @+  -- 'Optics.IxAffineFold.ipreview' :: 'IxAffineTraversal' i s t a b -> s -> Maybe (i, a)+  -- @+  --+  -- @+  -- 'Optics.IxSetter.iover'    :: 'IxAffineTraversal' i s t a b -> (i -> a -> b) -> s -> t+  -- 'Optics.IxSetter.iset'     :: 'IxAffineTraversal' i s t a b -> (i      -> b) -> s -> t+  -- @++  -- * Subtyping+  , An_AffineTraversal++  -- * van Laarhoven encoding+  , IxAffineTraversalVL+  , IxAffineTraversalVL'+  , iatraversalVL+  , toIxAtraversalVL+  ) where++import Optics.Internal.Indexed+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for a type-modifying indexed affine traversal.+type IxAffineTraversal i s t a b = Optic An_AffineTraversal (WithIx i) s t a b++-- | Type synonym for a type-preserving indexed affine traversal.+type IxAffineTraversal' i s a = Optic' An_AffineTraversal (WithIx i) s a++-- | Type synonym for a type-modifying van Laarhoven indexed affine traversal.+--+-- Note: this isn't exactly van Laarhoven representation as there is no+-- @Pointed@ class (which would be a superclass of 'Applicative' that contains+-- 'pure' but not '<*>'). You can interpret the first argument as a dictionary+-- of @Pointed@ that supplies the @point@ function (i.e. the implementation of+-- 'pure').+--+type IxAffineTraversalVL i s t a b =+  forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t++-- | Type synonym for a type-preserving van Laarhoven indexed affine traversal.+type IxAffineTraversalVL' i s a = IxAffineTraversalVL i s s a a++-- | Build an indexed affine traversal from a matcher and an updater.+--+-- If you want to build an 'IxAffineTraversal' from the van Laarhoven+-- representation, use 'iatraversalVL'.+iatraversal :: (s -> Either t (i, a)) -> (s -> b -> t) -> IxAffineTraversal i s t a b+iatraversal match update = iatraversalVL $ \point f s ->+  either point (\a -> update s <$> uncurry f a) (match s)+{-# INLINE iatraversal #-}++-- | Build an indexed affine traversal from the van Laarhoven representation.+iatraversalVL :: IxAffineTraversalVL i s t a b -> IxAffineTraversal i s t a b+iatraversalVL f = Optic (ivisit f)+{-# INLINE iatraversalVL #-}++-- | Convert an indexed affine traversal to its van Laarhoven representation.+toIxAtraversalVL+  :: (Is k An_AffineTraversal, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> IxAffineTraversalVL i s t a b+toIxAtraversalVL o point = \f ->+  runIxStarA (getOptic (castOptic @An_AffineTraversal o) (IxStarA point f)) id+{-# INLINE toIxAtraversalVL #-}
+ src/Optics/IxFold.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+-- |+-- Module: Optics.IxFold+-- Description: An indexed version of an 'Optics.Fold.Fold'.+--+-- An 'IxFold' is an indexed version of an 'Optics.Fold.Fold'. See the "Indexed+-- optics" section of the overview documentation in the @Optics@ module of the+-- main @optics@ package for more details on indexed optics.+--+module Optics.IxFold+  (+  -- * Formation+    IxFold++  -- * Introduction+  , ifoldVL++  -- * Elimination+  , ifoldMapOf+  , ifoldrOf+  , ifoldlOf'+  , itoListOf+  , itraverseOf_+  , iforOf_++  -- * Additional introduction forms+  , ifolded+  , ifolding+  , ifoldring++  -- * Additional elimination forms+  -- | See also 'Data.Map.Optics.toMapOf', which constructs a 'Data.Map.Map' from an 'IxFold'.+  , iheadOf+  , ilastOf+  , ianyOf+  , iallOf+  , inoneOf+  , ifindOf+  , ifindMOf++  -- * Combinators+  , ipre+  , ifiltered+  , ibackwards_++  -- * Semigroup structure+  , isumming+  , ifailing++  -- * Subtyping+  , A_Fold++  -- * Re-exports+  , FoldableWithIndex(..)+  ) where++import Control.Applicative.Backwards+import Data.Monoid++import Optics.Internal.Bi+import Optics.Internal.Indexed+import Optics.Internal.Fold+import Optics.Internal.IxFold+import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Utils+import Optics.IxAffineFold+import Optics.Fold++-- | Type synonym for an indexed fold.+type IxFold i s a = Optic' A_Fold (WithIx i) s a++-- | Obtain an indexed fold by lifting 'itraverse_' like function.+--+-- @+-- 'ifoldVL' '.' 'itraverseOf_' ≡ 'id'+-- 'itraverseOf_' '.' 'ifoldVL' ≡ 'id'+-- @+ifoldVL+  :: (forall f. Applicative f => (i -> a -> f u) -> s -> f v)+  -> IxFold i s a+ifoldVL f = Optic (ifoldVL__ f)+{-# INLINE ifoldVL #-}++-- | Fold with index via embedding into a monoid.+ifoldMapOf+  :: (Is k A_Fold, Monoid m, is `HasSingleIndex` i)+  => Optic' k is s a+  -> (i -> a -> m) -> s -> m+ifoldMapOf o = \f -> runIxForget (getOptic (castOptic @A_Fold o) (IxForget f)) id+{-# INLINE ifoldMapOf #-}++-- | Fold with index right-associatively.+ifoldrOf+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a+  -> (i -> a -> r -> r) -> r -> s -> r+ifoldrOf o = \iarr r0 s -> (\e -> appEndo e r0) $ ifoldMapOf o (\i -> Endo #. iarr i) s+{-# INLINE ifoldrOf #-}++-- | Fold with index left-associatively, and strictly.+ifoldlOf'+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a+  -> (i -> r -> a -> r) -> r -> s -> r+ifoldlOf' o = \irar r0 s -> ifoldrOf o (\i a rr r -> rr $! irar i r a) id s r0+{-# INLINE ifoldlOf' #-}++-- | Fold with index to a list.+--+-- >>> itoListOf (folded % ifolded) ["abc", "def"]+-- [(0,'a'),(1,'b'),(2,'c'),(0,'d'),(1,'e'),(2,'f')]+--+-- /Note:/ currently indexed optics can be used as non-indexed.+--+-- >>> toListOf (folded % ifolded) ["abc", "def"]+-- "abcdef"+--+itoListOf+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a+  -> s -> [(i, a)]+itoListOf o = ifoldrOf o (\i -> (:) . (i, )) []+{-# INLINE itoListOf #-}++----------------------------------------++-- | Traverse over all of the targets of an 'IxFold', computing an+-- 'Applicative'-based answer, but unlike 'Optics.IxTraversal.itraverseOf' do+-- not construct a new structure.+--+-- >>> itraverseOf_ each (curry print) ("hello","world")+-- (0,"hello")+-- (1,"world")+--+itraverseOf_+  :: (Is k A_Fold, Applicative f, is `HasSingleIndex` i)+  => Optic' k is s a+  -> (i -> a -> f r) -> s -> f ()+#if __GLASGOW_HASKELL__ == 802+-- GHC 8.2.2 needs this to optimize away profunctors when f is not supplied.+itraverseOf_ o = \f ->+#else+itraverseOf_ o f =+#endif+  runTraversed . ifoldMapOf o (\i -> Traversed #. f i)+{-# INLINE itraverseOf_ #-}++-- | A version of 'itraverseOf_' with the arguments flipped.+iforOf_+  :: (Is k A_Fold, Applicative f, is `HasSingleIndex` i)+  => Optic' k is s a+  -> s -> (i -> a -> f r) -> f ()+iforOf_ = flip . itraverseOf_+{-# INLINE iforOf_ #-}++----------------------------------------++-- | Indexed fold via 'FoldableWithIndex' class.+ifolded :: FoldableWithIndex i f => IxFold i (f a) a+ifolded = Optic ifolded__+{-# INLINE ifolded #-}++-- | Obtain an 'IxFold' by lifting an operation that returns a+-- 'FoldableWithIndex' result.+--+-- This can be useful to lift operations from @Data.List@ and elsewhere into an+-- 'IxFold'.+--+-- >>> itoListOf (ifolding words) "how are you"+-- [(0,"how"),(1,"are"),(2,"you")]+ifolding :: FoldableWithIndex i f => (s -> f a) -> IxFold i s a+ifolding f = Optic $ contrafirst f . ifolded__+{-# INLINE ifolding #-}++-- | Obtain an 'IxFold' by lifting 'ifoldr' like function.+--+-- >>> itoListOf (ifoldring ifoldr) "hello"+-- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')]+ifoldring+  :: (forall f. Applicative f => (i -> a -> f u -> f u) -> f v -> s -> f w)+  -> IxFold i s a+ifoldring fr = Optic (ifoldring__ fr)+{-# INLINE ifoldring #-}++-- | Convert an indexed fold to an 'IxAffineFold' that visits the first element+-- of the original fold.+ipre+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a+  -> IxAffineFold i s a+ipre = iafolding . iheadOf+{-# INLINE ipre #-}++-- | Filter results of an 'IxFold' that don't satisfy a predicate.+--+-- >>> toListOf (ifolded %& ifiltered (>)) [3,2,1,0]+-- [1,0]+--+ifiltered+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => (i -> a -> Bool)+  -> Optic' k is s a+  -> IxFold i s a+ifiltered p o = ifoldVL $ \f ->+  itraverseOf_ o (\i a -> if p i a then f i a else pure ())+{-# INLINE ifiltered #-}+-- Note: technically this should be defined per optic kind:+--+-- ifiltered :: _ -> IxFold i s a       -> IxFold i s a+-- ifiltered :: _ -> IxGetter i s a     -> IxAffineFold i s a+-- ifiltered :: _ -> IxAffineFold i s a -> IxAffineFold i s a+--+-- and similarly for (non-existent) unsafeIFiltered.++-- | This allows you to traverse the elements of an 'IxFold' in the opposite+-- order.+ibackwards_+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a+  -> IxFold i s a+ibackwards_ o = conjoined (backwards_ o) $ ifoldVL $ \f ->+  forwards #. itraverseOf_ o (\i -> Backwards #. f i)+{-# INLINE ibackwards_ #-}++-- | Return entries of the first 'IxFold', then the second one.+isumming+  :: (Is k A_Fold, Is l A_Fold,+      is1 `HasSingleIndex` i, is2 `HasSingleIndex` i)+  => Optic' k is1 s a+  -> Optic' l is2 s a+  -> IxFold i s a+isumming a b = conjoined (summing a b) $ ifoldVL $ \f s ->+  itraverseOf_ a f s *> itraverseOf_ b f s+infixr 6 `isumming` -- Same as (<>)+{-# INLINE isumming #-}++-- | Try the first 'IxFold'. If it returns no entries, try the second one.+ifailing+  :: (Is k A_Fold, Is l A_Fold, is1 `HasSingleIndex` i, is2 `HasSingleIndex` i)+  => Optic' k is1 s a+  -> Optic' l is2 s a+  -> IxFold i s a+ifailing a b = conjoined (failing a b) $ ifoldVL $ \f s ->+  let OrT visited fu = itraverseOf_ a (\i -> wrapOrT . f i) s+  in if visited+     then fu+     else itraverseOf_ b f s+infixl 3 `ifailing` -- Same as (<|>)+{-# INLINE ifailing #-}++----------------------------------------+-- Special folds++-- | Retrieve the first entry of an 'IxFold' along with its index.+--+-- >>> iheadOf ifolded [1..10]+-- Just (0,1)+iheadOf+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a -> s -> Maybe (i, a)+iheadOf o = getLeftmost . ifoldMapOf o (\i -> LLeaf . (i, ))+{-# INLINE iheadOf #-}++-- | Retrieve the last entry of an 'IxFold' along with its index.+--+-- >>> ilastOf ifolded [1..10]+-- Just (9,10)+ilastOf+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a -> s -> Maybe (i, a)+ilastOf o = getRightmost . ifoldMapOf o (\i -> RLeaf . (i, ))+{-# INLINE ilastOf #-}++-- | Return whether or not any element viewed through an 'IxFold' satisfies a+-- predicate, with access to the @i@.+--+-- When you don't need access to the index then 'anyOf' is more flexible in what+-- it accepts.+--+-- @+-- 'anyOf' o ≡ 'ianyOf' o '.' 'const'+-- @+ianyOf+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a -> (i -> a -> Bool) -> s -> Bool+ianyOf o = \f -> getAny #. ifoldMapOf o (\i -> Any #. f i)+{-# INLINE ianyOf #-}++-- | Return whether or not all elements viewed through an 'IxFold' satisfy a+-- predicate, with access to the @i@.+--+-- When you don't need access to the index then 'allOf' is more flexible in what+-- it accepts.+--+-- @+-- 'allOf' o ≡ 'iallOf' o '.' 'const'+-- @+iallOf+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a -> (i -> a -> Bool) -> s -> Bool+iallOf o = \f -> getAll #. ifoldMapOf o (\i -> All #. f i)+{-# INLINE iallOf #-}++-- | Return whether or not none of the elements viewed through an 'IxFold'+-- satisfy a predicate, with access to the @i@.+--+-- When you don't need access to the index then 'noneOf' is more flexible in+-- what it accepts.+--+-- @+-- 'noneOf' o ≡ 'inoneOf' o '.' 'const'+-- @+inoneOf+  :: (Is k A_Fold, is `HasSingleIndex` i)+  => Optic' k is s a -> (i -> a -> Bool) -> s -> Bool+inoneOf o = \f -> not . ianyOf o f+{-# INLINE inoneOf #-}++-- | The 'ifindOf' function takes an 'IxFold', a predicate that is also supplied+-- the index, a structure and returns the left-most element of the structure+-- along with its index matching the predicate, or 'Nothing' if there is no such+-- element.+--+-- When you don't need access to the index then 'findOf' is more flexible in+-- what it accepts.+ifindOf+ :: (Is k A_Fold, is `HasSingleIndex` i)+ => Optic' k is s a -> (i -> a -> Bool) -> s -> Maybe (i, a)+ifindOf o = \p -> iheadOf (ifiltered p o)+{-# INLINE ifindOf #-}++-- | The 'ifindMOf' function takes an 'IxFold', a monadic predicate that is also+-- supplied the index, a structure and returns in the monad the left-most+-- element of the structure matching the predicate, or 'Nothing' if there is no+-- such element.+--+-- When you don't need access to the index then 'findMOf' is more flexible in+-- what it accepts.+ifindMOf+  :: (Is k A_Fold, Monad m, is `HasSingleIndex` i)+  => Optic' k is s a -> (i -> a -> m Bool) -> s -> m (Maybe (i, a))+ifindMOf o = \f -> ifoldrOf o+  (\i a y -> f i a >>= \r -> if r then pure (Just (i, a)) else y)+  (pure Nothing)+{-# INLINE ifindMOf #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/IxGetter.hs view
@@ -0,0 +1,61 @@+-- |+-- Module: Optics.IxGetter+-- Description: An indexed version of an 'Optics.Getter.Getter'.+--+-- An 'IxGetter' is an indexed version of an 'Optics.Getter.Getter'. See the+-- "Indexed optics" section of the overview documentation in the @Optics@ module+-- of the main @optics@ package for more details on indexed optics.+--+module Optics.IxGetter+  (+  -- * Formation+    IxGetter++  -- * Introduction+  , ito+  , selfIndex++  -- * Elimination+  , iview+  , iviews++  -- * Subtyping+  , A_Getter+  ) where++import Optics.Internal.Bi+import Optics.Internal.Indexed+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for an indexed getter.+type IxGetter i s a = Optic' A_Getter (WithIx i) s a++-- | Build an indexed getter from a function.+--+-- >>> iview (ito id) ('i', 'x')+-- ('i','x')+ito :: (s -> (i, a)) -> IxGetter i s a+ito f = Optic (lmap f . ilinear uncurry . rphantom)+{-# INLINE ito #-}++-- | Use a value itself as its own index. This is essentially an indexed version+-- of 'Optics.Iso.equality'.+selfIndex :: IxGetter a a a+selfIndex = ito (\a -> (a, a))+{-# INLINE selfIndex #-}++-- | View the value pointed to by an indexed getter.+iview+  :: (Is k A_Getter, is `HasSingleIndex` i)+  => Optic' k is s a -> s -> (i, a)+iview o = iviews o (,)+{-# INLINE iview #-}++-- | View the function of the value pointed to by an indexed getter.+iviews+  :: (Is k A_Getter,  is `HasSingleIndex` i)+  => Optic' k is s a -> (i -> a -> r) -> s -> r+iviews o = \f ->+  runIxForget (getOptic (castOptic @A_Getter o) (IxForget f)) id+{-# INLINE iviews #-}
+ src/Optics/IxLens.hs view
@@ -0,0 +1,111 @@+-- |+-- Module: Optics.IxLens+-- Description: An indexed version of an 'Optics.Lens.Lens'.+--+-- An 'IxLens' is an indexed version of an 'Optics.Lens.Lens'. See the "Indexed+-- optics" section of the overview documentation in the @Optics@ module of the+-- main @optics@ package for more details on indexed optics.+--+module Optics.IxLens+  (+  -- * Formation+    IxLens+  , IxLens'++  -- * Introduction+  , ilens++  -- * Elimination+  -- | An 'IxLens' is in particular an 'Optics.IxGetter.IxGetter' and an+  -- 'Optics.IxSetter.IxSetter', therefore you can specialise types to obtain:+  --+  -- @+  -- 'Optics.IxGetter.iview' :: 'IxLens' i s t a b -> s -> (i, a)+  -- @+  --+  -- @+  -- 'Optics.IxSetter.iover' :: 'IxLens' i s t a b -> (i -> a -> b) -> s -> t+  -- 'Optics.IxSetter.iset'  :: 'IxLens' i s t a b -> (i      -> b) -> s -> t+  -- @++  -- * Additional introduction forms+  , devoid++  -- * Subtyping+  , A_Lens++  -- * van Laarhoven encoding+  , IxLensVL+  , IxLensVL'+  , ilensVL+  , toIxLensVL+  , withIxLensVL+  ) where++import Data.Void++import Optics.Internal.Indexed+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for a type-modifying indexed lens.+type IxLens i s t a b = Optic A_Lens (WithIx i) s t a b++-- | Type synonym for a type-preserving indexed lens.+type IxLens' i s a = Optic' A_Lens (WithIx i) s a++-- | Type synonym for a type-modifying van Laarhoven indexed lens.+type IxLensVL i s t a b =+  forall f. Functor f => (i -> a -> f b) -> s -> f t++-- | Type synonym for a type-preserving van Laarhoven indexed lens.+type IxLensVL' i s a = IxLensVL i s s a a++-- | Build an indexed lens from a getter and a setter.+--+-- If you want to build an 'IxLens' from the van Laarhoven representation, use+-- 'ilensVL'.+ilens :: (s -> (i, a)) -> (s -> b -> t) -> IxLens i s t a b+ilens get set = ilensVL $ \f s -> set s <$> uncurry f (get s)+{-# INLINE ilens #-}++-- | Build an indexed lens from the van Laarhoven representation.+ilensVL :: IxLensVL i s t a b -> IxLens i s t a b+ilensVL f = Optic (ilinear f)+{-# INLINE ilensVL #-}++-- | Convert an indexed lens to its van Laarhoven representation.+toIxLensVL+  :: (Is k A_Lens, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> IxLensVL i s t a b+toIxLensVL o = \f ->+  runIxStar (getOptic (castOptic @A_Lens o) (IxStar f)) id+{-# INLINE toIxLensVL #-}++-- | Work with an indexed lens in the van Laarhoven representation.+withIxLensVL+  :: (Is k A_Lens, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (IxLensVL i s t a b -> r)+  -> r+withIxLensVL o k = k (toIxLensVL o)+{-# INLINE withIxLensVL #-}++----------------------------------------+-- Lenses++-- | There is an indexed field for every type in the 'Void'.+--+-- >>> set (mapped % devoid) 1 []+-- []+--+-- >>> over (_Just % devoid) abs Nothing+-- Nothing+--+devoid :: IxLens' i Void a+devoid = ilens absurd const+{-# INLINE devoid #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/IxSetter.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds #-}+-- |+-- Module: Optics.IxSetter+-- Description: An indexed version of an 'Optics.Setter.Setter'.+--+-- An 'IxSetter' is an indexed version of an 'Optics.Setter.Setter'. See the+-- "Indexed optics" section of the overview documentation in the @Optics@ module+-- of the main @optics@ package for more details on indexed optics.+--+module Optics.IxSetter+  (+  -- * Formation+    IxSetter+  , IxSetter'++  -- * Introduction+  , isets++  -- * Elimination+  , iover++  -- * Computation+  -- |+  --+  -- @+  -- 'iover' ('isets' f) ≡ f+  -- @++  -- * Well-formedness+  -- |+  --+  -- * __PutPut__: Setting twice is the same as setting once:+  --+  --     @+  --     'Optics.Setter.iset' l v' ('Optics.Setter.iset' l v s) ≡ 'Optics.Setter.iset' l v' s+  --     @+  --+  -- * __Functoriality__: 'IxSetter's must preserve identities and composition:+  --+  --     @+  --     'iover' s ('const' 'id') ≡ 'id'+  --     'iover' s f '.' 'iover' s g ≡ 'iover' s (\i -> f i '.' g i)+  --     @++  -- * Additional introduction forms+  , imapped++  -- * Additional elimination forms+  , iset+  , iset'+  , iover'++  -- * Subtyping+  , A_Setter++  -- * Re-exports+  , FunctorWithIndex(..)+  ) where++import Optics.Internal.Indexed+import Optics.Internal.IxSetter+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for a type-modifying indexed setter.+type IxSetter i s t a b = Optic A_Setter (WithIx i) s t a b++-- | Type synonym for a type-preserving indexed setter.+type IxSetter' i s a = Optic' A_Setter (WithIx i) s a++-- | Apply an indexed setter as a modifier.+iover+  :: (Is k A_Setter, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> a -> b) -> s -> t+iover o = \f -> runIxFunArrow (getOptic (castOptic @A_Setter o) (IxFunArrow f)) id+{-# INLINE iover #-}++-- | Apply an indexed setter as a modifier, strictly.+iover'+  :: (Is k A_Setter, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> a -> b) -> s -> t+iover' o = \f ->+  let star = getOptic (castOptic @A_Setter o) $ IxStar (\i -> wrapIdentity' . f i)+  in unwrapIdentity' . runIxStar star id++{-# INLINE iover' #-}++-- | Apply an indexed setter.+--+-- @+-- 'iset' o f ≡ 'iover' o (\i _ -> f i)+-- @+--+iset+  :: (Is k A_Setter, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> b) -> s -> t+iset o = \f -> iover o (\i _ -> f i)+{-# INLINE iset #-}++-- | Apply an indexed setter, strictly.+iset'+  :: (Is k A_Setter, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> b) -> s -> t+iset' o = \f -> iover' o (\i _ -> f i)+{-# INLINE iset' #-}++-- | Build an indexed setter from a function to modify the element(s).+isets+  :: ((i -> a -> b) -> s -> t)+  -> IxSetter i s t a b+isets f = Optic (iroam f)+{-# INLINE isets #-}++-- | Indexed setter via the 'FunctorWithIndex' class.+--+-- @+-- 'iover' 'imapped' ≡ 'imap'+-- @+imapped :: FunctorWithIndex i f => IxSetter i (f a) (f b) a b+imapped = Optic imapped__+{-# INLINE imapped #-}
+ src/Optics/IxTraversal.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE DataKinds #-}+-- |+-- Module: Optics.IxTraversal+-- Description: An indexed version of an 'Optics.Traversal.Traversal'.+--+-- An 'IxTraversal' is an indexed version of an 'Optics.Traversal.Traversal'.+-- See the "Indexed optics" section of the overview documentation in the+-- @Optics@ module of the main @optics@ package for more details on indexed+-- optics.+--+module Optics.IxTraversal+  (+  -- * Formation+    IxTraversal+  , IxTraversal'++  -- * Introduction+  , itraversalVL++  -- * Elimination+  , itraverseOf++  -- * Computation+  -- |+  --+  -- @+  -- 'itraverseOf' ('itraversalVL' f) ≡ f+  -- @++  -- * Well-formedness+  -- |+  --+  -- @+  -- 'itraverseOf' o ('const' 'pure') ≡ 'pure'+  -- 'fmap' ('itraverseOf' o f) . 'itraverseOf' o g ≡ 'Data.Functor.Compose.getCompose' . 'itraverseOf' o (\\ i -> 'Data.Functor.Compose.Compose' . 'fmap' (f i) . g i)+  -- @+  --++  -- * Additional introduction forms+  -- | See also 'Optics.Each.Core.each', which is an 'IxTraversal' over each element of a (potentially monomorphic) container.+  , itraversed+  , ignored+  , elementsOf+  , elements+  , elementOf+  , element++  -- * Additional elimination forms+  , iforOf+  , imapAccumLOf+  , imapAccumROf+  , iscanl1Of+  , iscanr1Of+  , ifailover+  , ifailover'++  -- * Combinators+  , indices+  , ibackwards+  , ipartsOf++  -- * Subtyping+  , A_Traversal++  -- * van Laarhoven encoding+  -- | The van Laarhoven representation of an 'IxTraversal' directly expresses+  -- how it lifts an effectful operation @I -> A -> F B@ on elements and their+  -- indices to act on structures @S -> F T@.  Thus 'itraverseOf' converts an+  -- 'IxTraversal' to a 'IxTraversalVL'.+  , IxTraversalVL+  , IxTraversalVL'++  -- * Re-exports+  , TraversableWithIndex(..)+  ) where++import Control.Applicative.Backwards+import Control.Monad.Trans.State+import Data.Functor.Identity++import Optics.Internal.Indexed+import Optics.Internal.IxTraversal+import Optics.Internal.Profunctor+import Optics.Internal.Optic+import Optics.Internal.Utils+import Optics.IxLens+import Optics.IxFold+import Optics.ReadOnly+import Optics.Traversal++-- | Type synonym for a type-modifying indexed traversal.+type IxTraversal i s t a b = Optic A_Traversal (WithIx i) s t a b++-- | Type synonym for a type-preserving indexed traversal.+type IxTraversal' i s a = Optic' A_Traversal (WithIx i) s a++-- | Type synonym for a type-modifying van Laarhoven indexed traversal.+type IxTraversalVL i s t a b =+  forall f. Applicative f => (i -> a -> f b) -> s -> f t++-- | Type synonym for a type-preserving van Laarhoven indexed traversal.+type IxTraversalVL' i s a = IxTraversalVL i s s a a++-- | Build an indexed traversal from the van Laarhoven representation.+--+-- @+-- 'itraversalVL' '.' 'itraverseOf' ≡ 'id'+-- 'itraverseOf' '.' 'itraversalVL' ≡ 'id'+-- @+itraversalVL :: IxTraversalVL i s t a b -> IxTraversal i s t a b+itraversalVL t = Optic (iwander t)+{-# INLINE itraversalVL #-}++----------------------------------------++-- | Map each element of a structure targeted by a 'IxTraversal' (supplying the+-- index), evaluate these actions from left to right, and collect the results.+--+-- This yields the van Laarhoven representation of an indexed traversal.+itraverseOf+  :: (Is k A_Traversal, Applicative f, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> a -> f b) -> s -> f t+itraverseOf o = \f ->+  runIxStar (getOptic (castOptic @A_Traversal o) (IxStar f)) id+{-# INLINE itraverseOf #-}++-- | A version of 'itraverseOf' with the arguments flipped.+iforOf+  :: (Is k A_Traversal, Applicative f, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> s -> (i -> a -> f b) -> f t+iforOf = flip . itraverseOf+{-# INLINE iforOf #-}++-- | Generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'IxTraversal'.+--+-- 'imapAccumLOf' accumulates state from left to right.+--+-- @+-- 'Optics.Traversal.mapAccumLOf' o ≡ 'imapAccumLOf' o '.' 'const'+-- @+imapAccumLOf+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> acc -> a -> (b, acc)) -> acc -> s -> (t, acc)+imapAccumLOf o = \f acc0 s ->+  let g i a = state $ \acc -> f i acc a+  in runState (itraverseOf o g s) acc0+{-# INLINE imapAccumLOf #-}++-- | Generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'IxTraversal'.+--+-- 'imapAccumROf' accumulates state from right to left.+--+-- @+-- 'Optics.Traversal.mapAccumROf' o ≡ 'imapAccumROf' o '.' 'const'+-- @+imapAccumROf+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> acc -> a -> (b, acc)) -> acc -> s -> (t, acc)+imapAccumROf = imapAccumLOf . ibackwards+{-# INLINE imapAccumROf #-}++-- | This permits the use of 'scanl1' over an arbitrary 'IxTraversal'.+iscanl1Of+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a a+  -> (i -> a -> a -> a) -> s -> t+iscanl1Of o = \f ->+  let step i ms a = case ms of+        Nothing -> (a, Just a)+        Just s  -> let r = f i s a in (r, Just r)+  in fst . imapAccumLOf o step Nothing+{-# INLINE iscanl1Of #-}++-- | This permits the use of 'scanr1' over an arbitrary 'IxTraversal'.+iscanr1Of+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a a+  -> (i -> a -> a -> a) -> s -> t+iscanr1Of o f = fst . imapAccumROf o step Nothing+  where+    step i ms a = case ms of+      Nothing -> (a, Just a)+      Just s  -> let r = f i a s in (r, Just r)+{-# INLINE iscanr1Of #-}++-- | Try to map a function which uses the index over this 'IxTraversal',+-- returning 'Nothing' if the 'IxTraversal' has no targets.+ifailover+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> a -> b) -> s -> Maybe t+ifailover o = \f s ->+  let OrT visited t = itraverseOf o (\i -> wrapOrT . Identity #. f i) s+  in if visited+     then Just (runIdentity t)+     else Nothing+{-# INLINE ifailover #-}++-- | Version of 'ifailover' strict in the application of the function.+ifailover'+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> (i -> a -> b) -> s -> Maybe t+ifailover' o = \f s ->+  let OrT visited t = itraverseOf o (\i -> wrapOrT . wrapIdentity' . f i) s+  in if visited+     then Just (unwrapIdentity' t)+     else Nothing+{-# INLINE ifailover' #-}++----------------------------------------+-- Traversals++-- | Indexed traversal via the 'TraversableWithIndex' class.+--+-- @+-- 'itraverseOf' 'itraversed' ≡ 'itraverse'+-- @+--+-- >>> iover (itraversed <%> itraversed) (,) ["ab", "cd"]+-- [[((0,0),'a'),((0,1),'b')],[((1,0),'c'),((1,1),'d')]]+--+itraversed+  :: TraversableWithIndex i f+  => IxTraversal i (f a) (f b) a b+itraversed = Optic itraversed__+{-# INLINE itraversed #-}++-- | This is the trivial empty 'IxTraversal'.+--+-- >>> 6 & ignored %~ absurd+-- 6+ignored :: IxTraversal i s s a b+ignored = itraversalVL $ \_ -> pure++----------------------------------------+-- Traversal combinators++-- | Filter results of an 'IxTraversal' that don't satisfy a predicate on the+-- indices.+--+-- >>> toListOf (itraversed %& indices even) "foobar"+-- "foa"+--+indices+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => (i -> Bool)+  -> Optic k is s t a a+  -> IxTraversal i s t a a+indices p o = itraversalVL $ \f ->+  itraverseOf o $ \i a -> if p i then f i a else pure a+{-# INLINE indices #-}++-- | This allows you to 'traverse' the elements of an indexed traversal in the+-- opposite order.+ibackwards+  :: (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a b+  -> IxTraversal i s t a b+ibackwards o = conjoined (backwards o) $ itraversalVL $ \f ->+  forwards #. itraverseOf o (\i -> Backwards #. f i)+{-# INLINE ibackwards #-}++-- | Traverse selected elements of a 'Traversal' where their ordinal positions+-- match a predicate.+elementsOf+  :: Is k A_Traversal+  => Optic k is s t a a+  -> (Int -> Bool)+  -> IxTraversal Int s t a a+elementsOf o = \p -> itraversalVL $ \f ->+  indexing (traverseOf o) $ \i a -> if p i then f i a else pure a+{-# INLINE elementsOf #-}++-- | Traverse elements of a 'Traversable' container where their ordinal+-- positions match a predicate.+--+-- @+-- 'elements' ≡ 'elementsOf' 'traverse'+-- @+elements :: Traversable f => (Int -> Bool) -> IxTraversal' Int (f a) a+elements = elementsOf traversed+{-# INLINE elements #-}++-- | Traverse the /nth/ element of a 'Traversal' if it exists.+--+-- TODO: the result ideally should be an indexed affine traversal.+elementOf+  :: Is k A_Traversal+  => Optic k is s t a a+  -> Int+  -> IxTraversal Int s t a a+elementOf o = \i -> elementsOf o (== i)+{-# INLINE elementOf #-}++-- | Traverse the /nth/ element of a 'Traversable' container.+--+-- @+-- 'element' ≡ 'elementOf' 'traversed'+-- @+element :: Traversable f => Int -> IxTraversal' Int (f a) a+element = elementOf traversed+{-# INLINE element #-}++-- | An indexed version of 'partsOf' that receives the entire list of indices as+-- its indices.+ipartsOf+  :: forall k is i s t a. (Is k A_Traversal, is `HasSingleIndex` i)+  => Optic k is s t a a+  -> IxLens [i] s t [a] [a]+ipartsOf o = conjoined (partsOf o) $ ilensVL $ \f s ->+  evalState (traverseOf o update s)+    <$> uncurry f (unzip $ itoListOf (getting $ castOptic @A_Traversal o) s)+  where+    update a = get >>= \case+      []       ->            pure a+      a' : as' -> put as' >> pure a'+{-# INLINE ipartsOf #-}++-- $setup+-- >>> import Data.Void+-- >>> import Optics.Core
+ src/Optics/Label.hs view
@@ -0,0 +1,201 @@+-- |+-- Module: Optics.Label+-- Description: Overloaded labels as optics+--+-- Overloaded labels are a solution to Haskell's namespace problem for records.+-- The @-XOverloadedLabels@ extension allows a new expression syntax for labels,+-- a prefix @#@ sign followed by an identifier, e.g. @#foo@.  These expressions+-- can then be given an interpretation that depends on the type at which they+-- are used and the text of the label.+--+-- The following example shows how overloaded labels can be used as optics.+--+-- == Example+--+-- Consider the following:+--+-- >>> :set -XDataKinds+-- >>> :set -XFlexibleContexts+-- >>> :set -XFlexibleInstances+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XOverloadedLabels+-- >>> :set -XTypeFamilies+-- >>> :set -XUndecidableInstances+-- >>> :{+-- data Human = Human+--   { humanName :: String+--   , humanAge  :: Integer+--   , humanPets :: [Pet]+--   } deriving Show+-- data Pet+--   = Cat  { petName :: String, petAge :: Int, petLazy :: Bool }+--   | Fish { petName :: String, petAge :: Int }+--   deriving Show+-- :}+--+-- The following instances can be generated by @makeFieldLabels@ from+-- @Optics.TH@ in the @optics-th@ package:+--+-- >>> :{+-- instance (a ~ String, b ~ String) => LabelOptic "name" A_Lens Human Human a b where+--   labelOptic = lensVL $ \f s -> (\v -> s { humanName = v }) <$> f (humanName s)+-- instance (a ~ Integer, b ~ Integer) => LabelOptic "age" A_Lens Human Human a b where+--   labelOptic = lensVL $ \f s -> (\v -> s { humanAge = v }) <$> f (humanAge s)+-- instance (a ~ [Pet], b ~ [Pet]) => LabelOptic "pets" A_Lens Human Human a b where+--   labelOptic = lensVL $ \f s -> (\v -> s { humanPets = v }) <$> f (humanPets s)+-- instance (a ~ String, b ~ String) => LabelOptic "name" A_Lens Pet Pet a b where+--   labelOptic = lensVL $ \f s -> (\v -> s { petName = v }) <$> f (petName s)+-- instance (a ~ Int, b ~ Int) => LabelOptic "age" A_Lens Pet Pet a b where+--   labelOptic = lensVL $ \f s -> (\v -> s { petAge = v }) <$> f (petAge s)+-- instance (a ~ Bool, b ~ Bool) => LabelOptic "lazy" An_AffineTraversal Pet Pet a b where+--   labelOptic = atraversalVL $ \point f s -> case s of+--     Cat name age lazy -> (\lazy' -> Cat name age lazy') <$> f lazy+--     _                 -> point s+-- :}+--+-- Here is some test data:+--+-- >>> :{+-- peter :: Human+-- peter = Human "Peter" 13 [ Fish "Goldie" 1+--                          , Cat  "Loopy"  3 False+--                          , Cat  "Sparky" 2 True+--                          ]+-- :}+--+-- Now we can ask for Peter's name:+--+-- >>> view #name peter+-- "Peter"+--+-- or for names of his pets:+--+-- >>> toListOf (#pets % folded % #name) peter+-- ["Goldie","Loopy","Sparky"]+--+-- We can check whether any of his pets is lazy:+--+-- >>> orOf (#pets % folded % #lazy) peter+-- True+--+-- or how things might be be a year from now:+--+-- >>> peter & over #age (+1) & over (#pets % mapped % #age) (+1)+-- Human {humanName = "Peter", humanAge = 14, humanPets = [Fish {petName = "Goldie", petAge = 2},Cat {petName = "Loopy", petAge = 4, petLazy = False},Cat {petName = "Sparky", petAge = 3, petLazy = True}]}+--+-- Perhaps Peter is going on vacation and needs to leave his pets at home:+--+-- >>> peter & set #pets []+-- Human {humanName = "Peter", humanAge = 13, humanPets = []}+--+--+-- == Structure of 'LabelOptic' instances+--+-- You might wonder why instances above are written in form+--+-- @+-- instance (a ~ [Pet], b ~ [Pet]) => LabelOptic "pets" A_Lens Human Human a b where+-- @+--+-- instead of+--+-- @+-- instance LabelOptic "pets" A_Lens Human Human [Pet] [Pet] where+-- @+--+-- The reason is that using the first form ensures that GHC always matches on+-- the instance if either @s@ or @t@ is known and verifies type equalities+-- later, which not only makes type inference better, but also allows it to+-- generate good error messages.+--+-- For example, if you try to write @peter & set #pets []@ with the appropriate+-- LabelOptic instance in the second form, you get the following:+--+-- @+-- <interactive>:16:1: error:+--    • No instance for LabelOptic "pets" ‘A_Lens’ ‘Human’ ‘()’ ‘[Pet]’ ‘[a0]’+--        (maybe you forgot to define it or misspelled a name?)+--    • In the first argument of ‘print’, namely ‘it’+--      In a stmt of an interactive GHCi command: print it+-- @+--+-- That's because empty list doesn't have type @[Pet]@, it has type @[r]@ and+-- GHC doesn't have enough information to match on the instance we+-- provided. We'd need to either annotate the list: @peter & set #pets+-- ([]::[Pet])@ or the result type: @peter & set #pets [] :: Human@, which is+-- suboptimal.+--+-- Here are more examples of confusing error messages if the instance for+-- @LabelOptic "age"@ is written without type equalities:+--+-- @+-- λ> view #age peter :: Char+--+-- <interactive>:28:6: error:+--     • No instance for LabelOptic "age" ‘k0’ ‘Human’ ‘Human’ ‘Char’ ‘Char’+--         (maybe you forgot to define it or misspelled a name?)+--     • In the first argument of ‘view’, namely ‘#age’+--       In the expression: view #age peter :: Char+--       In an equation for ‘it’: it = view #age peter :: Char+-- λ> peter & set #age "hi"+--+-- <interactive>:29:1: error:+--     • No instance for LabelOptic "age" ‘k’ ‘Human’ ‘b’ ‘a’ ‘[Char]’+--         (maybe you forgot to define it or misspelled a name?)+--     • When checking the inferred type+--         it :: forall k b a. ((TypeError ...), Is k A_Setter) => b+-- @+--+-- If we use the first form, error messages become more accurate:+--+-- @+-- λ> view #age peter :: Char+-- <interactive>:31:6: error:+--     • Couldn't match type ‘Char’ with ‘Integer’+--         arising from the overloaded label ‘#age’+--     • In the first argument of ‘view’, namely ‘#age’+--       In the expression: view #age peter :: Char+--       In an equation for ‘it’: it = view #age peter :: Char+-- λ> peter & set #age "hi"+--+-- <interactive>:32:13: error:+--     • Couldn't match type ‘[Char]’ with ‘Integer’+--         arising from the overloaded label ‘#age’+--     • In the first argument of ‘set’, namely ‘#age’+--       In the second argument of ‘(&)’, namely ‘set #age "hi"’+--       In the expression: peter & set #age "hi"+-- @+--+-- == Limitations arising from functional dependencies+--+-- Functional dependencies guarantee good type inference, but also+-- create limitations. We can split them into two groups:+--+-- - @name s -> k a@, @name t -> k b@+--+-- - @name s b -> t@, @name t a -> s@+--+-- The first group ensures that when we compose two optics, the middle type is+-- unambiguous. The consequence is that it's not possible to create label optics+-- with @a@ or @b@ referencing type variables not referenced in @s@ or @t@,+-- i.e. getters for fields of rank 2 type or reviews for constructors with+-- existentially quantified types inside.+--+-- The second group ensures that when we perform a chain of updates, the middle+-- type is unambiguous. The consequence is that it's not possible to define+-- label optics that:+--+-- - Modify phantom type parameters of type @s@ or @t@.+--+-- - Modify type parameters of type @s@ or @t@ if @a@ or @b@ contain ambiguous+--   applications of type families to these type parameters.+--+module Optics.Label+  ( LabelOptic(..)+  , LabelOptic'+  ) where++import Optics.Internal.Optic++-- $setup+-- >>> import Optics.Core
+ src/Optics/Lens.hs view
@@ -0,0 +1,226 @@+-- |+-- Module: Optics.Lens+-- Description: A generalised or first-class field.+--+-- A 'Lens' is a generalised or first-class field.+--+-- If we have a value @s :: S@, and a @l :: 'Lens'' S A@, we can /get/+-- the "field value" of type @A@ using @'Optics.Getter.view' l s@.  We+-- can also /update/ (or /put/ or /set/) the value using+-- 'Optics.Setter.over' (or 'Optics.Setter.set').+--+-- For example, given the following definitions:+--+-- >>> data Human = Human { _name :: String, _location :: String } deriving Show+-- >>> let human = Human "Bob" "London"+--+-- we can make a 'Lens' for @_name@ field:+--+-- >>> let name = lens _name $ \s x -> s { _name = x }+--+-- which we can use as a 'Optics.Getter.Getter':+--+-- >>> view name human+-- "Bob"+--+-- or a 'Optics.Setter.Setter':+--+-- >>> set name "Robert" human+-- Human {_name = "Robert", _location = "London"}+--+module Optics.Lens+  (+  -- * Formation+    Lens+  , Lens'++  -- * Introduction+  , lens++  -- * Elimination+  -- | A 'Lens' is in particular a 'Optics.Getter.Getter' and a+  -- 'Optics.Setter.Setter', therefore you can specialise types to obtain:+  --+  -- @+  -- 'Optics.Getter.view' :: 'Lens' s t a b -> s -> a+  -- @+  --+  -- @+  -- 'Optics.Setter.over' :: 'Lens' s t a b -> (a -> b) -> s -> t+  -- 'Optics.Setter.set'  :: 'Lens' s t a b ->       b  -> s -> t+  -- @+  --++  -- * Computation+  -- |+  --+  -- @+  -- 'Optics.Getter.view' ('lens' f g)   s ≡ f s+  -- 'Optics.Setter.set'  ('lens' f g) a s ≡ g s a+  -- @++  -- * Well-formedness+  -- |+  --+  -- * __GetPut__: You get back what you put in:+  --+  --     @+  --     'Optics.Getter.view' l ('Optics.Setter.set' l v s) ≡ v+  --     @+  --+  -- * __PutGet__: Putting back what you got doesn’t change anything:+  --+  --     @+  --     'Optics.Setter.set' l ('Optics.Getter.view' l s) s ≡ s+  --     @+  --+  -- * __PutPut__: Setting twice is the same as setting once:+  --+  --     @+  --     'Optics.Setter.set' l v' ('Optics.Setter.set' l v s) ≡ 'Optics.Setter.set' l v' s+  --     @+  --++  -- * Additional introduction forms+  -- | See "Data.Tuple.Optics" for 'Lens'es for tuples.+  , equality'+  , chosen+  , alongside+  , united++  -- * Additional elimination forms+  , withLens++  -- * Subtyping+  , A_Lens+  -- | <<diagrams/Lens.png Lens in the optics hierarchy>>++  -- * van Laarhoven encoding+  -- | The van Laarhoven encoding of lenses is isomorphic to the profunctor+  -- encoding used internally by @optics@, but converting back and forth may+  -- have a performance penalty.+  , LensVL+  , LensVL'+  , lensVL+  , toLensVL+  , withLensVL+  )+  where++import Optics.Internal.Concrete+import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Utils++-- | Type synonym for a type-modifying lens.+type Lens s t a b = Optic A_Lens NoIx s t a b++-- | Type synonym for a type-preserving lens.+type Lens' s a = Optic' A_Lens NoIx s a++-- | Type synonym for a type-modifying van Laarhoven lens.+type LensVL s t a b = forall f. Functor f => (a -> f b) -> s -> f t++-- | Type synonym for a type-preserving van Laarhoven lens.+type LensVL' s a = LensVL s s a a++-- | Build a lens from a getter and a setter, which must respect the+-- well-formedness laws.+--+-- If you want to build a 'Lens' from the van Laarhoven representation, use+-- 'lensVL'.+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens get set = Optic $+  -- Do not define lens in terms of lensVL, mixing profunctor-style definitions+  -- with VL style implementation can lead to subpar generated code,+  -- i.e. updating often gets and then sets as opposed to updating in place.+  dimap (\s -> (get s, s))+        (\(b, s) -> set s b)+  . first'+{-# INLINE lens #-}++-- | Work with a lens as a getter and a setter.+--+-- @+-- 'withLens' ('lens' f g) k ≡ k f g+-- @+withLens+  :: Is k A_Lens+  => Optic k is s t a b+  -> ((s -> a) -> (s -> b -> t) -> r)+  -> r+withLens o k = case getOptic (castOptic @A_Lens o) $ Store id (\_ -> id) of+  Store get set -> k get set+{-# INLINE withLens #-}++-- | Build a lens from the van Laarhoven representation.+lensVL :: LensVL s t a b -> Lens s t a b+lensVL l = Optic (linear l)+{-# INLINE lensVL #-}++-- | Convert a lens to the van Laarhoven representation.+toLensVL :: Is k A_Lens => Optic k is s t a b -> LensVL s t a b+toLensVL o = runStar #. getOptic (castOptic @A_Lens o) .# Star+{-# INLINE toLensVL #-}++-- | Work with a lens in the van Laarhoven representation.+withLensVL+  :: Is k A_Lens+  => Optic k is s t a b+  -> (LensVL s t a b -> r)+  -> r+withLensVL o k = k (toLensVL o)+{-# INLINE withLensVL #-}++----------------------------------------+-- Lenses++-- | Strict version of 'Optics.Iso.equality'.+--+-- Useful for strictifying optics with lazy (irrefutable) pattern matching by+-- precomposition, e.g.+--+-- @+-- 'Data.Tuple.Optics._1'' = 'equality'' % 'Data.Tuple.Optics._1'+-- @+equality' :: Lens a b a b+equality' = lensVL ($!)+{-# INLINE equality' #-}++-- | Focus on both sides of an 'Either'.+chosen :: Lens (Either a a) (Either b b) a b+chosen = lensVL $ \f -> either (fmap Left . f) (fmap Right . f)+{-# INLINE chosen #-}++-- | Make a 'Lens' from two other lenses by executing them on their respective+-- halves of a product.+--+-- >>> (Left 'a', Right 'b') ^. alongside chosen chosen+-- ('a','b')+--+-- >>> (Left 'a', Right 'b') & alongside chosen chosen .~ ('c','d')+-- (Left 'c',Right 'd')+alongside+  :: (Is k A_Lens, Is l A_Lens)+  => Optic k is s  t  a  b+  -> Optic l js s' t' a' b'+  -> Lens (s, s') (t, t') (a, a') (b, b')+alongside l r = withLens l $ \getl setl ->+                withLens r $ \getr setr ->+  lens (\(s, s')         -> (getl s,   getr s'   ))+       (\(s, s') (b, b') -> (setl s b, setr s' b'))+{-# INLINE alongside #-}++-- | We can always retrieve a @()@ from any type.+--+-- >>> view united "hello"+-- ()+--+-- >>> set united () "hello"+-- "hello"+united :: Lens' a ()+united  = lens (const ()) const+{-# INLINE united #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Operators.hs view
@@ -0,0 +1,114 @@+-- |+-- Module: Optics.Operators+-- Description: Definitions of infix operators for optics.+--+-- Defines some infix operators for optics operations. This is a deliberately+-- small collection.+--+-- If you like operators, you may also wish to import @Optics.State.Operators@+-- from the @optics-extra@ package.+--+module Optics.Operators+  ( (^.)+  , (^..)+  , (^?)+  , (#)+  , (%~)+  , (%!~)+  , (.~)+  , (!~)+  , (?~)+  , (?!~)+  )+  where++import Optics.AffineFold+import Optics.Fold+import Optics.Getter+import Optics.Optic+import Optics.Review+import Optics.Setter++-- | Flipped infix version of 'view'.+(^.) :: Is k A_Getter => s -> Optic' k is s a -> a+(^.) = flip view+{-# INLINE (^.) #-}++infixl 8 ^.++-- | Flipped infix version of 'preview'.+(^?) :: Is k An_AffineFold => s -> Optic' k is s a -> Maybe a+(^?) = flip preview+{-# INLINE (^?) #-}++infixl 8 ^?++-- | Flipped infix version of 'toListOf'.+(^..) :: Is k A_Fold => s -> Optic' k is s a -> [a]+(^..) = flip toListOf+{-# INLINE (^..) #-}++infixl 8 ^..++-- | Flipped infix version of 'review'.+(#) :: Is k A_Review => Optic' k is t b -> b -> t+(#) = review+{-# INLINE (#) #-}++infixr 8 #++-- | Infix version of 'over'.+(%~) :: Is k A_Setter => Optic k is s t a b -> (a -> b) -> s -> t+(%~) = over+{-# INLINE (%~) #-}++infixr 4 %~++-- | Infix version of 'over''.+(%!~) :: Is k A_Setter => Optic k is s t a b -> (a -> b) -> s -> t+(%!~) = over'+{-# INLINE (%!~) #-}++infixr 4 %!~++-- | Infix version of 'set'.+(.~) :: Is k A_Setter => Optic k is s t a b -> b -> s -> t+(.~) = set+{-# INLINE (.~) #-}++infixr 4 .~++-- | Infix version of 'set''.+(!~) :: Is k A_Setter => Optic k is s t a b -> b -> s -> t+(!~) = set'+{-# INLINE (!~) #-}++infixr 4 !~++-- | Set the target of a 'Setter' to 'Just' a value.+--+-- @+-- o '?~' b ≡ 'set' o ('Just' b)+-- @+--+-- >>> Nothing & equality ?~ 'x'+-- Just 'x'+--+-- >>> Map.empty & at 3 ?~ 'x'+-- fromList [(3,'x')]+(?~) :: Is k A_Setter => Optic k is s t a (Maybe b) -> b -> s -> t+(?~) = \o -> set o . Just+{-# INLINE (?~) #-}++infixr 4 ?~++-- | Strict version of ('?~').+(?!~) :: Is k A_Setter => Optic k is s t a (Maybe b) -> b -> s -> t+(?!~) = \o !b -> set' o (Just b)+{-# INLINE (?!~) #-}++infixr 4 ?!~++-- $setup+-- >>> import qualified Data.Map as Map+-- >>> import Optics.Core
+ src/Optics/Optic.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: Optics.Optic+-- Description: Common abstraction for all kinds of optics.+--+-- This module provides core definitions:+--+-- * an opaque 'Optic' type, which is parameterised over a type representing an+--   optic kind (instantiated with tag types such as 'A_Lens');+--+-- * the optic composition operator ('%');+--+-- * the subtyping relation 'Is' with an accompanying 'castOptic' function to+--   convert an optic kind;+--+-- * the 'Join' operation used to find the optic kind resulting from a+--   composition.+--+-- Each optic kind is identified by a "tag type" (such as 'A_Lens'), which is an+-- empty data type.  The type of the actual optics (such as 'Optics.Lens.Lens')+-- is obtained by applying 'Optic' to the tag type.+--+-- See the @Optics@ module in the main @optics@ package for overview+-- documentation.+--+module Optics.Optic+  ( Optic+  , Optic'++  -- * Subtyping+  , castOptic+  , Is+  , Join++  -- * Composition+  , (%)+  , (%%)+  , (%&)++  -- * Indexed optics+  , NoIx+  , WithIx+  , Append+  , NonEmptyIndices+  , HasSingleIndex+  , AcceptsEmptyIndices++    -- * Base re-exports+  , (&)+  , (<&>)+  )+  where++import Data.Function++import Optics.Internal.Indexed+import Optics.Internal.Optic++#if MIN_VERSION_base(4,11,0)+import Data.Functor ((<&>))+#else+-- | Infix flipped 'fmap'.+--+-- @+-- ('<&>') = 'flip' 'fmap'+-- @+(<&>) :: Functor f => f a -> (a -> b) -> f b+as <&> f = f <$> as+{-# INLINE (<&>) #-}+infixl 1 <&>+#endif
+ src/Optics/Prism.hs view
@@ -0,0 +1,188 @@+-- |+-- Module: Optics.Prism+-- Description: A generalised or first-class constructor.+--+-- A 'Prism' generalises the notion of a constructor (just as a+-- 'Optics.Lens.Lens' generalises the notion of a field).+--+module Optics.Prism+  (+  -- * Formation+    Prism+  , Prism'++  -- * Introduction+  , prism++  -- * Elimination+  -- | A 'Prism' is in particular an 'Optics.AffineFold.AffineFold', a+  -- 'Optics.Review.Review' and a 'Optics.Setter.Setter', therefore you can+  -- specialise types to obtain:+  --+  -- @+  -- 'Optics.AffineFold.preview' :: 'Prism' s t a b -> s -> Maybe a+  -- 'Optics.Review.review'  :: 'Prism' s t a b -> b -> t+  -- @+  --+  -- @+  -- 'Optics.Setter.over'    :: 'Prism' s t a b -> (a -> b) -> s -> t+  -- 'Optics.Setter.set'     :: 'Prism' s t a b ->       b  -> s -> t+  -- @++  -- * Computation+  -- |+  --+  -- @+  -- 'Optics.Review.review'   ('prism' f g) ≡ f+  -- 'Optics.AffineTraversal.matching' ('prism' f g) ≡ g+  -- @++  -- * Well-formedness+  -- |+  --+  -- @+  -- 'Optics.AffineTraversal.matching' o ('Optics.Review.review' o b) ≡ 'Right' b+  -- 'Optics.AffineTraversal.matching' o s ≡ 'Right' a  =>  'Optics.Review.review' o a ≡ s+  -- @++  -- * Additional introduction forms+  -- | See "Data.Maybe.Optics" and "Data.Either.Optics" for 'Prism's for the+  -- corresponding types, and 'Optics.Cons.Core._Cons', 'Optics.Cons.Core._Snoc'+  -- and 'Optics.Empty.Core._Empty' for 'Prism's for container types.+  , prism'+  , only+  , nearly++  -- * Additional elimination forms+  , withPrism++  -- * Combinators+  , aside+  , without+  , below++  -- * Subtyping+  , A_Prism+  -- | <<diagrams/Prism.png Prism in the optics hierarchy>>+  )+  where++import Control.Monad+import Data.Bifunctor++import Optics.Internal.Concrete+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Type synonym for a type-modifying prism.+type Prism s t a b = Optic A_Prism NoIx s t a b++-- | Type synonym for a type-preserving prism.+type Prism' s a = Optic' A_Prism NoIx s a++-- | Build a prism from a constructor and a matcher, which must respect the+-- well-formedness laws.+--+-- If you want to build a 'Prism' from the van Laarhoven representation, use+-- @prismVL@ from the @optics-vl@ package.+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism construct match = Optic $ dimap match (either id construct) . right'+{-# INLINE prism #-}++-- | This is usually used to build a 'Prism'', when you have to use an operation+-- like 'Data.Typeable.cast' which already returns a 'Maybe'.+prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b+prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))+{-# INLINE prism' #-}++-- | Work with a 'Prism' as a constructor and a matcher.+withPrism+  :: Is k A_Prism+  => Optic k is s t a b+  -> ((b -> t) -> (s -> Either t a) -> r)+  -> r+withPrism o k = case getOptic (castOptic @A_Prism o) (Market id Right) of+  Market construct match -> k construct match+{-# INLINE withPrism #-}++----------------------------------------++-- | Use a 'Prism' to work over part of a structure.+aside :: Is k A_Prism => Optic k is s t a b -> Prism (e, s) (e, t) (e, a) (e, b)+aside k =+  withPrism k     $ \bt seta ->+  prism (fmap bt) $ \(e,s) ->+  case seta s of+    Left t  -> Left  (e,t)+    Right a -> Right (e,a)+{-# INLINE aside #-}++-- | Given a pair of prisms, project sums.+--+-- Viewing a 'Prism' as a co-'Optics.Lens.Lens', this combinator can be seen to+-- be dual to 'Optics.Lens.alongside'.+without+  :: (Is k A_Prism, Is l A_Prism)+  => Optic k is s t a b+  -> Optic l is u v c d+  -> Prism (Either s u) (Either t v) (Either a c) (Either b d)+without k =+  withPrism k         $ \bt seta k' ->+  withPrism k'        $ \dv uevc    ->+  prism (bimap bt dv) $ \su ->+  case su of+    Left s  -> bimap Left Left (seta s)+    Right u -> bimap Right Right (uevc u)+{-# INLINE without #-}++-- | Lift a 'Prism' through a 'Traversable' functor, giving a 'Prism' that+-- matches only if all the elements of the container match the 'Prism'.+below+  :: (Is k A_Prism, Traversable f)+  => Optic' k is s a+  -> Prism' (f s) (f a)+below k =+  withPrism k     $ \bt seta ->+  prism (fmap bt) $ \s ->+  case traverse seta s of+    Left _  -> Left s+    Right t -> Right t+{-# INLINE below #-}++-- | This 'Prism' compares for exact equality with a given value.+--+-- >>> only 4 # ()+-- 4+--+-- >>> 5 ^? only 4+-- Nothing+only :: Eq a => a -> Prism' a ()+only a = prism' (\() -> a) $ guard . (a ==)+{-# INLINE only #-}++-- | This 'Prism' compares for approximate equality with a given value and a+-- predicate for testing, an example where the value is the empty list and the+-- predicate checks that a list is empty (same as 'Optics.Empty._Empty' with the+-- 'Optics.Empty.AsEmpty' list instance):+--+-- >>> nearly [] null # ()+-- []+-- >>> [1,2,3,4] ^? nearly [] null+-- Nothing+--+-- @'nearly' [] 'Prelude.null' :: 'Prism'' [a] ()@+--+-- To comply with the 'Prism' laws the arguments you supply to @nearly a p@ are+-- somewhat constrained.+--+-- We assume @p x@ holds iff @x ≡ a@. Under that assumption then this is a valid+-- 'Prism'.+--+-- This is useful when working with a type where you can test equality for only+-- a subset of its values, and the prism selects such a value.+nearly :: a -> (a -> Bool) -> Prism' a ()+nearly a p = prism' (\() -> a) $ guard . p+{-# INLINE nearly #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Re.hs view
@@ -0,0 +1,170 @@+-- |+-- Module: Optics.Re+-- Description: The 're' operator allows some optics to be reversed.+--+-- Some optics can be reversed with 're'.  This is mainly useful to invert+-- 'Optics.Iso.Iso's:+--+-- >>> let _Identity = iso runIdentity Identity+-- >>> view (_1 % re _Identity) ('x', "yz")+-- Identity 'x'+--+-- Yet we can use a 'Optics.Lens.Lens' as a 'Optics.Review.Review' too:+--+-- >>> review (re _1) ('x', "yz")+-- 'x'+--+-- In the following diagram, red arrows illustrate how 're' transforms optics.+-- The 'Optics.ReversedLens.ReversedLens' and+-- 'Optics.ReversedPrism.ReversedPrism' optic kinds are backwards versions of+-- 'Optics.Lens.Lens' and 'Optics.Prism.Prism' respectively, and are present so+-- that @'re' . 're'@ does not change the optic kind.+--+-- <<diagrams/reoptics.png Reversed Optics>>+--+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilyDependencies #-}+module Optics.Re+  ( ReversibleOptic(..)+  ) where++import Data.Coerce++import Optics.Internal.Bi+import Optics.Internal.Indexed+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Class for optics that can be 're'versed.+class ReversibleOptic k where+  -- | Injective type family that maps an optic kind to the optic kind produced+  -- by 're'versing it.+  --+  -- @+  -- 'ReversedOptic' 'An_Iso'            = 'An_Iso'+  -- 'ReversedOptic' 'A_Prism'           = 'A_ReversedPrism'+  -- 'ReversedOptic' 'A_ReversedPrism'   = 'A_Prism'+  -- 'ReversedOptic' 'A_Lens'            = 'A_ReversedLens'+  -- 'ReversedOptic' 'A_ReversedLens'    = 'A_Lens'+  -- 'ReversedOptic' 'A_Getter'          = 'A_Review'+  -- 'ReversedOptic' 'A_Review'          = 'A_Getter'+  -- @+  type ReversedOptic k = r | r -> k+  -- | Reverses optics, turning around 'Optics.Iso.Iso' into 'Optics.Iso.Iso',+  -- 'Optics.Prism.Prism' into 'Optics.ReversedPrism.ReversedPrism' (and+  -- back), 'Optics.Lens.Lens' into 'Optics.ReversedLens.ReversedLens' (and back)+  -- and 'Optics.Getter.Getter' into 'Optics.Review.Review' (and back).+  re+    :: "re" `AcceptsEmptyIndices` is+    => Optic                k  is s t a b+    -> Optic (ReversedOptic k) is b a t s++instance ReversibleOptic An_Iso where+  type ReversedOptic An_Iso = An_Iso+  re o = Optic (re__ o)+  {-# INLINE re #-}++instance ReversibleOptic A_Prism where+  type ReversedOptic A_Prism = A_ReversedPrism+  re o = Optic (re__ o)+  {-# INLINE re #-}++instance ReversibleOptic A_ReversedPrism where+  type ReversedOptic A_ReversedPrism = A_Prism+  re o = Optic (re__ o)+  {-# INLINE re #-}++instance ReversibleOptic A_Lens where+  type ReversedOptic A_Lens = A_ReversedLens+  re o = Optic (re__ o)+  {-# INLINE re #-}++instance ReversibleOptic A_ReversedLens where+  type ReversedOptic A_ReversedLens = A_Lens+  re o = Optic (re__ o)+  {-# INLINE re #-}++instance ReversibleOptic A_Getter where+  type ReversedOptic A_Getter = A_Review+  re o = Optic (re__ o)+  {-# INLINE re #-}++instance ReversibleOptic A_Review where+  type ReversedOptic A_Review = A_Getter+  re o = Optic (re__ o)+  {-# INLINE re #-}++-- | Internal implementation of re.+re__+  :: (Profunctor p, Constraints k (Re p a b))+  => Optic k  NoIx s t a b+  -> Optic__ p i i b a t s+re__ o = unRe (getOptic o (Re id))+{-# INLINE re__ #-}++----------------------------------------++-- | Helper for reversing optics.+newtype Re p s t i a b = Re { unRe :: p i b a -> p i t s }++instance Profunctor p => Profunctor (Re p s t) where+  dimap f g (Re p) = Re (p . dimap g f)+  lmap  f   (Re p) = Re (p . rmap f)+  rmap    g (Re p) = Re (p . lmap g)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  lcoerce' = lmap coerce+  rcoerce' = rmap coerce+  {-# INLINE lcoerce' #-}+  {-# INLINE rcoerce' #-}++  conjoined__ = error "conjoined__(Re) shouldn't be reachable"+  ixcontramap = error "ixcontramap(Re) shouldn't be reachable"++instance Bicontravariant p => Bifunctor (Re p s t) where+  bimap  f g (Re p) = Re (p . contrabimap g f)+  first  f   (Re p) = Re (p . contrasecond f)+  second   g (Re p) = Re (p . contrafirst g)+  {-# INLINE bimap #-}+  {-# INLINE first #-}+  {-# INLINE second #-}++instance Bifunctor p => Bicontravariant (Re p s t) where+  contrabimap  f g (Re p) = Re (p . bimap g f)+  contrafirst  f   (Re p) = Re (p . second f)+  contrasecond   g (Re p) = Re (p . first g)+  {-# INLINE contrabimap #-}+  {-# INLINE contrafirst #-}+  {-# INLINE contrasecond #-}++instance Strong p => Costrong (Re p s t) where+  unfirst  (Re p) = Re (p . first')+  unsecond (Re p) = Re (p . second')+  {-# INLINE unfirst #-}+  {-# INLINE unsecond #-}++instance Costrong p => Strong (Re p s t) where+  first'  (Re p) = Re (p . unfirst)+  second' (Re p) = Re (p . unsecond)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  ilinear _ = error "ilinear(Re) shouldn't be reachable"++instance Choice p => Cochoice (Re p s t) where+  unleft  (Re p) = Re (p . left')+  unright (Re p) = Re (p . right')+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++instance Cochoice p => Choice (Re p s t) where+  left'  (Re p) = Re (p . unleft)+  right' (Re p) = Re (p . unright)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++-- $setup+-- >>> import Data.Functor.Identity+-- >>> import Optics.Core
+ src/Optics/ReadOnly.hs view
@@ -0,0 +1,85 @@+-- |+-- Module: Optics.ReadOnly+-- Description: Converting read-write optics into their read-only counterparts.+--+-- This module defines 'getting', which turns a read-write optic into its+-- read-only counterpart.+--+module Optics.ReadOnly+  ( ToReadOnly(..)+  ) where++import Optics.Internal.Bi+import Optics.Internal.Optic+import Optics.Internal.Profunctor++-- | Class for read-write optics that have their read-only counterparts.+class ToReadOnly k s t a b where+  -- | Turn read-write optic into its read-only counterpart (or leave read-only+  -- optics as-is).+  --+  -- This is useful when you have an @optic :: 'Optic' k is s t a b@ of read-write+  -- kind @k@ such that @s@, @t@, @a@, @b@ are rigid, there is no evidence that+  -- @s ~ t@ and @a ~ b@ and you want to pass @optic@ to one of the functions+  -- that accept read-only optic kinds.+  --+  -- Example:+  --+  -- @+  -- λ> let fstIntToChar = _1 :: Lens (Int, r) (Char, r) Int Char+  -- λ> :t view fstIntToChar+  --+  -- <interactive>:1:6: error:+  --     • Couldn't match type ‘Char’ with ‘Int’+  --       Expected type: Optic' A_Lens NoIx (Int, r) Int+  --         Actual type: Lens (Int, r) (Char, r) Int Char+  --     • In the first argument of ‘view’, namely ‘fstIntToChar’+  --       In the expression: view fstIntToChar+  -- λ> :t view (getting fstIntToChar)+  -- view (getting fstIntToChar) :: (Int, r) -> Int+  -- @+  getting :: Optic k is s t a b -> Optic' (Join A_Getter k) is s a++instance ToReadOnly An_Iso s t a b where+  getting o = Optic (getting__ o)+  {-# INLINE getting #-}++instance ToReadOnly A_Lens s t a b where+  getting o = Optic (getting__ o)+  {-# INLINE getting #-}++instance ToReadOnly A_Prism s t a b where+  getting o = Optic (getting__ o)+  {-# INLINE getting #-}++instance ToReadOnly An_AffineTraversal s t a b where+  getting o = Optic (getting__ o)+  {-# INLINE getting #-}++instance ToReadOnly A_Traversal s t a b where+  getting o = Optic (getting__ o)+  {-# INLINE getting #-}++instance ToReadOnly A_ReversedPrism s t a b where+  getting o = Optic (getting__ o)+  {-# INLINE getting #-}++instance (s ~ t, a ~ b) => ToReadOnly A_Getter s t a b where+  getting = id+  {-# INLINE getting #-}++instance (s ~ t, a ~ b) => ToReadOnly An_AffineFold s t a b where+  getting = id+  {-# INLINE getting #-}++instance (s ~ t, a ~ b) => ToReadOnly A_Fold s t a b where+  getting = id+  {-# INLINE getting #-}++-- | Internal implementation of 'getting'.+getting__+  :: (Profunctor p, Bicontravariant p, Constraints k p)+  => Optic k            is    s t a b+  -> Optic__ p i (Curry is i) s s a a+getting__ (Optic o) = rphantom . o . rphantom+{-# INLINE getting__ #-}
+ src/Optics/ReversedLens.hs view
@@ -0,0 +1,63 @@+-- |+-- Module: Optics.ReversedLens+-- Description: A backwards 'Optics.Lens.Lens'.+--+-- A 'ReversedLens' is a backwards 'Optics.Lens.Lens', i.e. a @'ReversedLens' s t+-- a b@ is equivalent to a @'Optics.Lens.Lens' b a t s@.  These are typically+-- produced by calling 'Optics.Re.re' on a 'Optics.Lens.Lens'.  They are+-- distinguished from a 'Optics.Review.Review' so that @'Optics.Re.re'+-- . 'Optics.Re.re'@ on a 'Optics.Lens.Lens' returns a 'Optics.Lens.Lens'.+--+module Optics.ReversedLens+  (+  -- * Formation+    ReversedLens+  , ReversedLens'++  -- * Introduction+  -- |+  --+  -- There is no canonical introduction form for 'ReversedLens', but you can use+  -- 'Optics.Re.re' to construct one from a 'Optics.Lens.Lens':+  --+  -- @+  -- (\\ f g -> 'Optics.Re.re' ('Optics.Lens.lens' f g)) :: (b -> t) -> (b -> s -> a) -> 'ReversedLens' s t a b+  -- @++  -- * Elimination+  -- |+  --+  -- A 'ReversedLens' is a 'Optics.Review.Review', so you can specialise types to obtain:+  --+  -- @+  -- 'Optics.Review.review' :: 'ReversedLens'' s a -> a -> s+  -- @+  --+  -- There is no corresponding optic kind for a backwards+  -- 'Optics.Setter.Setter', but a reversed 'Optics.Setter.set' is definable+  -- using 'Optics.Re.re':+  --+  -- @+  -- 'Optics.Setter.set' . 'Optics.Re.re' :: 'ReversedLens' s t a b -> s -> b -> a+  -- @++  -- * Computation+  -- |+  --+  -- @+  -- 'Optics.Review.review'   $ 'Optics.Re.re' ('Optics.Lens.lens' f g) ≡ f+  -- 'Optics.Setter.set' . 'Optics.Re.re' $ 'Optics.Re.re' ('Optics.Lens.lens' f g) ≡ g+  -- @++  -- * Subtyping+  , A_ReversedLens+  -- | <<diagrams/ReversedLens.png ReversedLens in the optics hierarchy>>+  ) where++import Optics.Internal.Optic++-- | Type synonym for a type-modifying reversed lens.+type ReversedLens s t a b = Optic A_ReversedLens NoIx s t a b++-- | Type synonym for a type-preserving reversed lens.+type ReversedLens' t b = Optic' A_ReversedLens NoIx t b
+ src/Optics/ReversedPrism.hs view
@@ -0,0 +1,63 @@+-- |+-- Module: Optics.ReversedPrism+-- Description: A backwards 'Optics.Prism.Prism'.+--+-- A 'ReversedPrism' is a backwards 'Optics.Prism.Prism', i.e. a+-- @'ReversedPrism' s t a b@ is equivalent to a @'Optics.Prism.Prism' b a t+-- s@.  These are typically produced by calling 'Optics.Re.re' on a+-- 'Optics.Prism.Prism'.  They are distinguished from a 'Optics.Getter.Getter'+-- so that @'Optics.Re.re' . 'Optics.Re.re'@ on a 'Optics.Prism.Prism' returns a+-- 'Optics.Prism.Prism'.+--+module Optics.ReversedPrism+  ( -- * Formation+    ReversedPrism+  , ReversedPrism'++  -- * Introduction+  -- |+  --+  -- There is no canonical introduction form for 'ReversedPrism', but you can+  -- use 'Optics.Re.re' to construct one from a 'Optics.Prism.Prism':+  --+  -- @+  -- (\\ f g -> 'Optics.Re.re' ('Optics.Prism.prism' f g)) :: (s -> a) -> (b -> Either a t) -> 'ReversedPrism' s t a b+  -- @++  -- * Elimination+  -- |+  --+  -- A 'ReversedPrism' is a 'Optics.Getter.Getter', so you can specialise+  -- types to obtain:+  --+  -- @+  -- 'Optics.Getter.view' :: 'ReversedPrism'' s a -> s -> a+  -- @+  --+  -- There is no reversed 'Optics.AffineTraversal.matching' defined, but it is+  -- definable using 'Optics.Re.re':+  --+  -- @+  -- 'Optics.AffineTraversal.matching' . 'Optics.Re.re' :: 'ReversedPrism' s t a b -> b -> Either a t+  -- @++  -- * Computation+  -- |+  --+  -- @+  -- 'Optics.Getter.view'          $ 'Optics.Re.re' ('Optics.Prism.prism' f g) ≡ f+  -- 'Optics.AffineTraversal.matching' . 'Optics.Re.re' $ 'Optics.Re.re' ('Optics.Prism.prism' f g) ≡ g+  -- @++  -- * Subtyping+  , A_ReversedPrism+  -- | <<diagrams/ReversedPrism.png ReversedPrism in the optics hierarchy>>+  ) where++import Optics.Internal.Optic++-- | Type synonym for a type-modifying reversed prism.+type ReversedPrism s t a b = Optic A_ReversedPrism NoIx s t a b++-- | Type synonym for a type-preserving reversed prism.+type ReversedPrism' s a = Optic' A_ReversedPrism NoIx s a
+ src/Optics/Review.hs view
@@ -0,0 +1,55 @@+-- |+-- Module: Optics.Review+-- Description: A backwards 'Optics.Getter.Getter', i.e. a function.+--+-- A 'Review' is a backwards 'Optics.Getter.Getter', i.e. a+-- @'Review' T B@ is just a function @B -> T@.+--+module Optics.Review+  (+  -- * Formation+    Review++  -- * Introduction+  , unto++  -- * Elimination+  , review++  -- * Computation+  -- |+  --+  -- @+  -- 'review' ('unto' f) = f+  -- @++  -- * Subtyping+  , A_Review+  -- | <<diagrams/Review.png Review in the optics hierarchy>>+  )+  where++import Optics.Internal.Bi+import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Tagged+import Optics.Internal.Utils++-- | Type synonym for a review.+type Review t b = Optic' A_Review NoIx t b++-- | Retrieve the value targeted by a 'Review'.+--+-- >>> review _Left "hi"+-- Left "hi"+review :: Is k A_Review => Optic' k is t b -> b -> t+review o = unTagged #. getOptic (castOptic @A_Review o) .# Tagged+{-# INLINE review #-}++-- | An analogue of 'Optics.Getter.to' for reviews.+unto :: (b -> t) -> Review t b+unto f = Optic (lphantom . rmap f)+{-# INLINE unto #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Setter.hs view
@@ -0,0 +1,155 @@+-- |+-- Module: Optics.Setter+-- Description: Applies an update to all contained values.+--+-- A @'Setter' S T A B@ has the ability to lift a function of type+-- @A -> B@ 'over' a function of type @S -> T@, applying the function+-- to update all the @A@s contained in @S@.  This can be used to 'set'+-- all the @A@s to a single value (by lifting a constant function).+--+-- This can be seen as a generalisation of 'fmap', where the type @S@+-- does not need to be a type constructor with @A@ as its last+-- parameter.+--+module Optics.Setter+  (+  -- * Formation+    Setter+  , Setter'++  -- * Introduction+  , sets++  -- * Elimination+  , over++  -- * Computation+  -- |+  --+  -- @+  -- 'over' ('sets' f) ≡ f+  -- @++  -- * Well-formedness+  -- |+  --+  -- * __PutPut__: Setting twice is the same as setting once:+  --+  --     @+  --     'Optics.Setter.set' l v' ('Optics.Setter.set' l v s) ≡ 'Optics.Setter.set' l v' s+  --     @+  --+  -- * __Functoriality__: 'Setter's must preserve identities and composition:+  --+  --     @+  --     'over' s 'id' ≡ 'id'+  --     'over' s f '.' 'over' s g ≡ 'over' s (f '.' g)+  --     @++  -- * Additional introduction forms+  -- | See also 'Data.Set.Optics.setmapped', which changes the elements of a 'Data.Set.Set'.+  , mapped++  -- * Additional elimination forms+  , set+  , set'+  , over'++  -- * Subtyping+  , A_Setter+  -- | <<diagrams/Setter.png Setter in the optics hierarchy>>+  ) where++import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Setter++-- | Type synonym for a type-modifying setter.+type Setter s t a b = Optic A_Setter NoIx s t a b++-- | Type synonym for a type-preserving setter.+type Setter' s a = Optic' A_Setter NoIx s a++-- | Apply a setter as a modifier.+over+  :: Is k A_Setter+  => Optic k is s t a b+  -> (a -> b) -> s -> t+over o = \f -> runFunArrow $ getOptic (castOptic @A_Setter o) (FunArrow f)+{-# INLINE over #-}++-- | Apply a setter as a modifier, strictly.+--+-- TODO DOC: what exactly is the strictness property?+--+-- Example:+--+-- @+--  f :: Int -> (Int, a) -> (Int, a)+--  f k acc+--    | k > 0     = f (k - 1) $ 'over'' 'Data.Tuple.Optics._1' (+1) acc+--    | otherwise = acc+-- @+--+-- runs in constant space, but would result in a space leak if used with 'over'.+--+-- Note that replacing '$' with '$!' or 'Data.Tuple.Optics._1' with+-- 'Data.Tuple.Optics._1'' (which amount to the same thing) doesn't help when+-- 'over' is used, because the first coordinate of a pair is never forced.+--+over'+  :: Is k A_Setter+  => Optic k is s t a b+  -> (a -> b) -> s -> t+over' o = \f ->+  let star = getOptic (castOptic @A_Setter o) $ Star (wrapIdentity' . f)+  in unwrapIdentity' . runStar star+{-# INLINE over' #-}++-- | Apply a setter.+--+-- @+-- 'set' o v ≡ 'over' o ('const' v)+-- @+--+-- >>> set _1 'x' ('y', 'z')+-- ('x','z')+--+set+  :: Is k A_Setter+  => Optic k is s t a b+  -> b -> s -> t+set o = over o . const+{-# INLINE set #-}++-- | Apply a setter, strictly.+--+-- TODO DOC: what exactly is the strictness property?+--+set'+  :: Is k A_Setter+  => Optic k is s t a b+  -> b -> s -> t+set' o = over' o . const+{-# INLINE set' #-}++-- | Build a setter from a function to modify the element(s), which must respect+-- the well-formedness laws.+sets+  :: ((a -> b) -> s -> t)+  -> Setter s t a b+sets f = Optic (roam f)+{-# INLINE sets #-}++-- | Create a 'Setter' for a 'Functor'.+--+-- @+-- 'over' 'mapped' ≡ 'fmap'+-- @+--+mapped :: Functor f => Setter (f a) (f b) a b+mapped = Optic mapped__+{-# INLINE mapped #-}++-- $setup+-- >>> import Optics.Core
+ src/Optics/Traversal.hs view
@@ -0,0 +1,322 @@+-- |+-- Module: Optics.Traversal+-- Description: Lifts an effectful operation on elements to act on structures.+--+-- A 'Traversal' lifts an effectful operation on elements to act on structures+-- containing those elements.+--+-- That is, given a function @op :: A -> F B@ where @F@ is 'Applicative', a+-- @'Traversal' S T A B@ can produce a function @S -> F T@ that applies @op@ to+-- all the @A@s contained in the @S@.+--+-- This can be seen as a generalisation of 'traverse', where the type @S@ does+-- not need to be a type constructor with @A@ as the last parameter.+--+-- A 'Lens' is a 'Traversal' that acts on a single value.+--+-- A close relative is the 'Optics.AffineTraversal.AffineTraversal', which is a+-- 'Traversal' that acts on at most one value.+--+module Optics.Traversal+  (+  -- * Formation+    Traversal+  , Traversal'++  -- * Introduction+  , traversalVL++  -- * Elimination+  , traverseOf++  -- * Computation+  -- |+  --+  -- @+  -- 'traverseOf' ('traversalVL' f) ≡ f+  -- @++  -- * Well-formedness+  -- |+  --+  -- @+  -- 'traverseOf' o 'pure' ≡ 'pure'+  -- 'fmap' ('traverseOf' o f) . 'traverseOf' o g ≡ 'Data.Functor.Compose.getCompose' . 'traverseOf' o ('Data.Functor.Compose.Compose' . 'fmap' f . g)+  -- @++  -- * Additional introduction forms+  , traversed++  -- * Additional elimination forms+  , forOf+  , sequenceOf+  , transposeOf+  , mapAccumROf+  , mapAccumLOf+  , scanr1Of+  , scanl1Of+  , failover+  , failover'++    -- * Combinators+  , backwards+  , partsOf++  -- * Subtyping+  , A_Traversal+  -- | <<diagrams/Traversal.png Traversal in the optics hierarchy>>++  -- * van Laarhoven encoding+  -- | The van Laarhoven representation of a 'Traversal' directly expresses how+  -- it lifts an effectful operation @A -> F B@ on elements to act on structures+  -- @S -> F T@.  Thus 'traverseOf' converts a 'Traversal' to a 'TraversalVL'.+  , TraversalVL+  , TraversalVL'+  )+  where++import Control.Applicative+import Control.Applicative.Backwards+import Control.Monad.Trans.State+import Data.Functor.Identity++import Optics.Internal.Optic+import Optics.Internal.Profunctor+import Optics.Internal.Traversal+import Optics.Internal.Utils+import Optics.Lens+import Optics.Fold+import Optics.ReadOnly++-- | Type synonym for a type-modifying traversal.+type Traversal s t a b = Optic A_Traversal NoIx s t a b++-- | Type synonym for a type-preserving traversal.+type Traversal' s a = Optic' A_Traversal NoIx s a++-- | Type synonym for a type-modifying van Laarhoven traversal.+type TraversalVL s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++-- | Type synonym for a type-preserving van Laarhoven traversal.+type TraversalVL' s a = TraversalVL s s a a++-- | Build a traversal from the van Laarhoven representation.+--+-- @+-- 'traversalVL' '.' 'traverseOf' ≡ 'id'+-- 'traverseOf' '.' 'traversalVL' ≡ 'id'+-- @+traversalVL :: TraversalVL s t a b -> Traversal s t a b+traversalVL t = Optic (wander t)+{-# INLINE traversalVL #-}++-- | Map each element of a structure targeted by a 'Traversal', evaluate these+-- actions from left to right, and collect the results.+traverseOf+  :: (Is k A_Traversal, Applicative f)+  => Optic k is s t a b+  -> (a -> f b) -> s -> f t+traverseOf o = \f -> runStar $ getOptic (castOptic @A_Traversal o) (Star f)+{-# INLINE traverseOf #-}++-- | A version of 'traverseOf' with the arguments flipped.+forOf+  :: (Is k A_Traversal, Applicative f)+  => Optic k is s t a b+  -> s -> (a -> f b) -> f t+forOf = flip . traverseOf+{-# INLINE forOf #-}++-- | Evaluate each action in the structure from left to right, and collect the+-- results.+--+-- >>> sequenceOf each ([1,2],[3,4])+-- [(1,3),(1,4),(2,3),(2,4)]+--+-- @+-- 'sequence' ≡ 'sequenceOf' 'traversed' ≡ 'traverse' 'id'+-- 'sequenceOf' o ≡ 'traverseOf' o 'id'+-- @+sequenceOf+  :: (Is k A_Traversal, Applicative f)+  => Optic k is s t (f b) b+  -> s -> f t+sequenceOf o = traverseOf o id+{-# INLINE sequenceOf #-}++-- | This generalizes 'Data.List.transpose' to an arbitrary 'Traversal'.+--+-- Note: 'Data.List.transpose' handles ragged inputs more intelligently, but for+-- non-ragged inputs:+--+-- >>> transposeOf traversed [[1,2,3],[4,5,6]]+-- [[1,4],[2,5],[3,6]]+--+-- @+-- 'Data.List.transpose' ≡ 'transposeOf' 'traverse'+-- @+transposeOf+  :: Is k A_Traversal+  => Optic k is s t [a] a+  -> s -> [t]+transposeOf o = getZipList #. traverseOf o ZipList+{-# INLINE transposeOf #-}++-- | This generalizes 'Data.Traversable.mapAccumL' to an arbitrary 'Traversal'.+--+-- @+-- 'Data.Traversable.mapAccumL' ≡ 'mapAccumLOf' 'traverse'+-- @+--+-- 'mapAccumLOf' accumulates 'State' from left to right.+mapAccumLOf+  :: Is k A_Traversal+  => Optic k is s t a b+  -> (acc -> a -> (b, acc)) -> acc -> s -> (t, acc)+mapAccumLOf o = \f acc0 s ->+  let g a = state $ \acc -> f acc a+  in runState (traverseOf o g s) acc0++{-# INLINE mapAccumLOf #-}++-- | This generalizes 'Data.Traversable.mapAccumR' to an arbitrary 'Traversal'.+--+-- @+-- 'Data.Traversable.mapAccumR' ≡ 'mapAccumROf' 'traversed'+-- @+--+-- 'mapAccumROf' accumulates 'State' from right to left.+mapAccumROf+  :: Is k A_Traversal+  => Optic k is s t a b+  -> (acc -> a -> (b, acc)) -> acc -> s -> (t, acc)+mapAccumROf = mapAccumLOf . backwards+{-# INLINE mapAccumROf #-}++-- | This permits the use of 'scanl1' over an arbitrary 'Traversal'.+--+-- @+-- 'scanl1' ≡ 'scanl1Of' 'traversed'+-- @+scanl1Of+  :: Is k A_Traversal+  => Optic k is s t a a+  -> (a -> a -> a) -> s -> t+scanl1Of o = \f ->+  let step Nothing a  = (a, Just a)+      step (Just s) a = let r = f s a in (r, Just r)+  in fst . mapAccumLOf o step Nothing+{-# INLINE scanl1Of #-}++-- | This permits the use of 'scanr1' over an arbitrary 'Traversal'.+--+-- @+-- 'scanr1' ≡ 'scanr1Of' 'traversed'+-- @+scanr1Of+  :: Is k A_Traversal+  => Optic k is s t a a+  -> (a -> a -> a) -> s -> t+scanr1Of o = \f ->+  let step Nothing a  = (a, Just a)+      step (Just s) a = let r = f a s in (r, Just r)+  in fst . mapAccumROf o step Nothing+{-# INLINE scanr1Of #-}++-- | Try to map a function over this 'Traversal', returning Nothing if the+-- traversal has no targets.+--+-- >>> failover (element 3) (*2) [1,2]+-- Nothing+--+-- >>> failover _Left (*2) (Right 4)+-- Nothing+--+-- >>> failover _Right (*2) (Right 4)+-- Just (Right 8)+--+failover+  :: Is k A_Traversal+  => Optic k is s t a b+  -> (a -> b) -> s -> Maybe t+failover o = \f s ->+  let OrT visited t = traverseOf o (wrapOrT . Identity #. f) s+  in if visited+     then Just (runIdentity t)+     else Nothing+{-# INLINE failover #-}++-- | Version of 'failover' strict in the application of @f@.+failover'+  :: Is k A_Traversal+  => Optic k is s t a b+  -> (a -> b) -> s -> Maybe t+failover' o = \f s ->+  let OrT visited t = traverseOf o (wrapOrT . wrapIdentity' . f) s+  in if visited+     then Just (unwrapIdentity' t)+     else Nothing+{-# INLINE failover' #-}++----------------------------------------+-- Traversals++-- | Construct a 'Traversal' via the 'Traversable' class.+--+-- @+-- 'traverseOf' 'traversed' = 'traverse'+-- @+--+traversed :: Traversable t => Traversal (t a) (t b) a b+traversed = Optic traversed__+{-# INLINE traversed #-}++----------------------------------------+-- Traversal combinators++-- | This allows you to 'traverse' the elements of a traversal in the opposite+-- order.+backwards+  :: Is k A_Traversal+  => Optic k is s t a b+  -> Traversal s t a b+backwards o = traversalVL $ \f -> forwards #. traverseOf o (Backwards #. f)+{-# INLINE backwards #-}++-- | 'partsOf' turns a 'Traversal' into a 'Lens'.+--+-- /Note:/ You should really try to maintain the invariant of the number of+-- children in the list.+--+-- >>> ('a','b','c') & partsOf each .~ ['x','y','z']+-- ('x','y','z')+--+-- Any extras will be lost. If you do not supply enough, then the remainder will+-- come from the original structure.+--+-- >>> ('a','b','c') & partsOf each .~ ['w','x','y','z']+-- ('w','x','y')+--+-- >>> ('a','b','c') & partsOf each .~ ['x','y']+-- ('x','y','c')+--+-- >>> ('b', 'a', 'd', 'c') & partsOf each %~ sort+-- ('a','b','c','d')+--+-- So technically, this is only a 'Lens' if you do not change the number of+-- results it returns.+partsOf+  :: forall k is s t a. Is k A_Traversal+  => Optic k is s t a a+  -> Lens s t [a] [a]+partsOf o = lensVL $ \f s -> evalState (traverseOf o update s)+  <$> f (toListOf (getting $ castOptic @A_Traversal o) s)+  where+    update a = get >>= \case+      a' : as' -> put as' >> pure a'+      []       ->            pure a+{-# INLINE partsOf #-}++-- $setup+-- >>> import Data.List+-- >>> import Optics.Core