summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdamGundry <>2019-09-02 08:17:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-09-02 08:17:00 (GMT)
commit69814fa24383c7285fae3f79b0a26c8b26bf8399 (patch)
treef736e8025cc73a0999b14e5cfed8a8339329fb57
version 0.10.1
-rw-r--r--LICENSE97
-rw-r--r--Setup.hs4
-rw-r--r--diagrams/AffineFold.pngbin0 -> 30607 bytes
-rw-r--r--diagrams/AffineTraversal.pngbin0 -> 30213 bytes
-rw-r--r--diagrams/Fold.pngbin0 -> 30867 bytes
-rw-r--r--diagrams/Getter.pngbin0 -> 28989 bytes
-rw-r--r--diagrams/Iso.pngbin0 -> 31991 bytes
-rw-r--r--diagrams/Lens.pngbin0 -> 29467 bytes
-rw-r--r--diagrams/Prism.pngbin0 -> 29356 bytes
-rw-r--r--diagrams/ReversedLens.pngbin0 -> 26733 bytes
-rw-r--r--diagrams/ReversedPrism.pngbin0 -> 28707 bytes
-rw-r--r--diagrams/Review.pngbin0 -> 27108 bytes
-rw-r--r--diagrams/Setter.pngbin0 -> 29145 bytes
-rw-r--r--diagrams/Traversal.pngbin0 -> 29464 bytes
-rw-r--r--diagrams/reoptics.pngbin0 -> 24123 bytes
-rw-r--r--optics-core.cabal126
-rw-r--r--src/Data/Either/Optics.hs35
-rw-r--r--src/Data/IntMap/Optics.hs137
-rw-r--r--src/Data/IntSet/Optics.hs53
-rw-r--r--src/Data/List/Optics.hs123
-rw-r--r--src/Data/Map/Optics.hs144
-rw-r--r--src/Data/Maybe/Optics.hs36
-rw-r--r--src/Data/Sequence/Optics.hs140
-rw-r--r--src/Data/Set/Optics.hs43
-rw-r--r--src/Data/Tree/Optics.hs32
-rw-r--r--src/Data/Tuple/Optics.hs519
-rw-r--r--src/Data/Typeable/Optics.hs27
-rw-r--r--src/GHC/Generics/Optics.hs96
-rw-r--r--src/Numeric/Optics.hs207
-rw-r--r--src/Optics/AffineFold.hs114
-rw-r--r--src/Optics/AffineTraversal.hs188
-rw-r--r--src/Optics/Arrow.hs119
-rw-r--r--src/Optics/At/Core.hs485
-rw-r--r--src/Optics/Coerce.hs60
-rw-r--r--src/Optics/Cons/Core.hs338
-rw-r--r--src/Optics/Core.hs68
-rw-r--r--src/Optics/Each/Core.hs196
-rw-r--r--src/Optics/Empty/Core.hs147
-rw-r--r--src/Optics/Fold.hs652
-rw-r--r--src/Optics/Getter.hs62
-rw-r--r--src/Optics/Indexed/Core.hs219
-rw-r--r--src/Optics/Internal/Bi.hs69
-rw-r--r--src/Optics/Internal/Concrete.hs117
-rw-r--r--src/Optics/Internal/Fold.hs113
-rw-r--r--src/Optics/Internal/Indexed.hs604
-rw-r--r--src/Optics/Internal/IxFold.hs41
-rw-r--r--src/Optics/Internal/IxSetter.hs18
-rw-r--r--src/Optics/Internal/IxTraversal.hs54
-rw-r--r--src/Optics/Internal/Optic.hs248
-rw-r--r--src/Optics/Internal/Optic/Subtyping.hs265
-rw-r--r--src/Optics/Internal/Optic/TypeLevel.hs46
-rw-r--r--src/Optics/Internal/Optic/Types.hs54
-rw-r--r--src/Optics/Internal/Profunctor.hs705
-rw-r--r--src/Optics/Internal/Setter.hs17
-rw-r--r--src/Optics/Internal/Tagged.hs50
-rw-r--r--src/Optics/Internal/Traversal.hs39
-rw-r--r--src/Optics/Internal/Utils.hs67
-rw-r--r--src/Optics/Iso.hs274
-rw-r--r--src/Optics/IxAffineFold.hs83
-rw-r--r--src/Optics/IxAffineTraversal.hs88
-rw-r--r--src/Optics/IxFold.hs350
-rw-r--r--src/Optics/IxGetter.hs61
-rw-r--r--src/Optics/IxLens.hs111
-rw-r--r--src/Optics/IxSetter.hs125
-rw-r--r--src/Optics/IxTraversal.hs326
-rw-r--r--src/Optics/Label.hs201
-rw-r--r--src/Optics/Lens.hs226
-rw-r--r--src/Optics/Operators.hs114
-rw-r--r--src/Optics/Optic.hs71
-rw-r--r--src/Optics/Prism.hs188
-rw-r--r--src/Optics/Re.hs170
-rw-r--r--src/Optics/ReadOnly.hs85
-rw-r--r--src/Optics/ReversedLens.hs63
-rw-r--r--src/Optics/ReversedPrism.hs63
-rw-r--r--src/Optics/Review.hs55
-rw-r--r--src/Optics/Setter.hs155
-rw-r--r--src/Optics/Traversal.hs322
77 files changed, 10105 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..9503551
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..00bfe1f
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/diagrams/AffineFold.png b/diagrams/AffineFold.png
new file mode 100644
index 0000000..8130f36
--- /dev/null
+++ b/diagrams/AffineFold.png
Binary files differ
diff --git a/diagrams/AffineTraversal.png b/diagrams/AffineTraversal.png
new file mode 100644
index 0000000..f79d46e
--- /dev/null
+++ b/diagrams/AffineTraversal.png
Binary files differ
diff --git a/diagrams/Fold.png b/diagrams/Fold.png
new file mode 100644
index 0000000..142ad5d
--- /dev/null
+++ b/diagrams/Fold.png
Binary files differ
diff --git a/diagrams/Getter.png b/diagrams/Getter.png
new file mode 100644
index 0000000..3bce305
--- /dev/null
+++ b/diagrams/Getter.png
Binary files differ
diff --git a/diagrams/Iso.png b/diagrams/Iso.png
new file mode 100644
index 0000000..75f593d
--- /dev/null
+++ b/diagrams/Iso.png
Binary files differ
diff --git a/diagrams/Lens.png b/diagrams/Lens.png
new file mode 100644
index 0000000..b594a77
--- /dev/null
+++ b/diagrams/Lens.png
Binary files differ
diff --git a/diagrams/Prism.png b/diagrams/Prism.png
new file mode 100644
index 0000000..9ffc283
--- /dev/null
+++ b/diagrams/Prism.png
Binary files differ
diff --git a/diagrams/ReversedLens.png b/diagrams/ReversedLens.png
new file mode 100644
index 0000000..fefdb6e
--- /dev/null
+++ b/diagrams/ReversedLens.png
Binary files differ
diff --git a/diagrams/ReversedPrism.png b/diagrams/ReversedPrism.png
new file mode 100644
index 0000000..61e6856
--- /dev/null
+++ b/diagrams/ReversedPrism.png
Binary files differ
diff --git a/diagrams/Review.png b/diagrams/Review.png
new file mode 100644
index 0000000..5c0cdd2
--- /dev/null
+++ b/diagrams/Review.png
Binary files differ
diff --git a/diagrams/Setter.png b/diagrams/Setter.png
new file mode 100644
index 0000000..3d62cd6
--- /dev/null
+++ b/diagrams/Setter.png
Binary files differ
diff --git a/diagrams/Traversal.png b/diagrams/Traversal.png
new file mode 100644
index 0000000..c669d88
--- /dev/null
+++ b/diagrams/Traversal.png
Binary files differ
diff --git a/diagrams/reoptics.png b/diagrams/reoptics.png
new file mode 100644
index 0000000..8b1aad0
--- /dev/null
+++ b/diagrams/reoptics.png
Binary files differ
diff --git a/optics-core.cabal b/optics-core.cabal
new file mode 100644
index 0000000..84f4d47
--- /dev/null
+++ b/optics-core.cabal
@@ -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
diff --git a/src/Data/Either/Optics.hs b/src/Data/Either/Optics.hs
new file mode 100644
index 0000000..3f0fa53
--- /dev/null
+++ b/src/Data/Either/Optics.hs
@@ -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 #-}
diff --git a/src/Data/IntMap/Optics.hs b/src/Data/IntMap/Optics.hs
new file mode 100644
index 0000000..c1f4132
--- /dev/null
+++ b/src/Data/IntMap/Optics.hs
@@ -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
diff --git a/src/Data/IntSet/Optics.hs b/src/Data/IntSet/Optics.hs
new file mode 100644
index 0000000..fdf6c0c
--- /dev/null
+++ b/src/Data/IntSet/Optics.hs
@@ -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
diff --git a/src/Data/List/Optics.hs b/src/Data/List/Optics.hs
new file mode 100644
index 0000000..dd7bc07
--- /dev/null
+++ b/src/Data/List/Optics.hs
@@ -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
diff --git a/src/Data/Map/Optics.hs b/src/Data/Map/Optics.hs
new file mode 100644
index 0000000..ea2b554
--- /dev/null
+++ b/src/Data/Map/Optics.hs
@@ -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
diff --git a/src/Data/Maybe/Optics.hs b/src/Data/Maybe/Optics.hs
new file mode 100644
index 0000000..be2f6b9
--- /dev/null
+++ b/src/Data/Maybe/Optics.hs
@@ -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 #-}
diff --git a/src/Data/Sequence/Optics.hs b/src/Data/Sequence/Optics.hs
new file mode 100644
index 0000000..b326ae0
--- /dev/null
+++ b/src/Data/Sequence/Optics.hs
@@ -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
diff --git a/src/Data/Set/Optics.hs b/src/Data/Set/Optics.hs
new file mode 100644
index 0000000..83eef25
--- /dev/null
+++ b/src/Data/Set/Optics.hs
@@ -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
diff --git a/src/Data/Tree/Optics.hs b/src/Data/Tree/Optics.hs
new file mode 100644
index 0000000..1903bc3
--- /dev/null
+++ b/src/Data/Tree/Optics.hs
@@ -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
diff --git a/src/Data/Tuple/Optics.hs b/src/Data/Tuple/Optics.hs
new file mode 100644
index 0000000..441a2a7
--- /dev/null
+++ b/src/Data/Tuple/Optics.hs
@@ -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
diff --git a/src/Data/Typeable/Optics.hs b/src/Data/Typeable/Optics.hs
new file mode 100644
index 0000000..a8d23d9
--- /dev/null
+++ b/src/Data/Typeable/Optics.hs
@@ -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 #-}
diff --git a/src/GHC/Generics/Optics.hs b/src/GHC/Generics/Optics.hs
new file mode 100644
index 0000000..0e2b7df
--- /dev/null
+++ b/src/GHC/Generics/Optics.hs
@@ -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
diff --git a/src/Numeric/Optics.hs b/src/Numeric/Optics.hs
new file mode 100644
index 0000000..d448f1d
--- /dev/null
+++ b/src/Numeric/Optics.hs
@@ -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
diff --git a/src/Optics/AffineFold.hs b/src/Optics/AffineFold.hs
new file mode 100644
index 0000000..2ac0630
--- /dev/null
+++ b/src/Optics/AffineFold.hs
@@ -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
diff --git a/src/Optics/AffineTraversal.hs b/src/Optics/AffineTraversal.hs
new file mode 100644
index 0000000..16998e7
--- /dev/null
+++ b/src/Optics/AffineTraversal.hs
@@ -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
diff --git a/src/Optics/Arrow.hs b/src/Optics/Arrow.hs
new file mode 100644
index 0000000..141a196
--- /dev/null
+++ b/src/Optics/Arrow.hs
@@ -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__ #-}
diff --git a/src/Optics/At/Core.hs b/src/Optics/At/Core.hs
new file mode 100644
index 0000000..6cac7b1
--- /dev/null
+++ b/src/Optics/At/Core.hs
@@ -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
diff --git a/src/Optics/Coerce.hs b/src/Optics/Coerce.hs
new file mode 100644
index 0000000..572d37d
--- /dev/null
+++ b/src/Optics/Coerce.hs
@@ -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 #-}
diff --git a/src/Optics/Cons/Core.hs b/src/Optics/Cons/Core.hs
new file mode 100644
index 0000000..cefd896
--- /dev/null
+++ b/src/Optics/Cons/Core.hs
@@ -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
diff --git a/src/Optics/Core.hs b/src/Optics/Core.hs
new file mode 100644
index 0000000..6db9233
--- /dev/null
+++ b/src/Optics/Core.hs
@@ -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
diff --git a/src/Optics/Each/Core.hs b/src/Optics/Each/Core.hs
new file mode 100644
index 0000000..cbc9bdc
--- /dev/null
+++ b/src/Optics/Each/Core.hs
@@ -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
diff --git a/src/Optics/Empty/Core.hs b/src/Optics/Empty/Core.hs
new file mode 100644
index 0000000..2e73a62
--- /dev/null
+++ b/src/Optics/Empty/Core.hs
@@ -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
diff --git a/src/Optics/Fold.hs b/src/Optics/Fold.hs
new file mode 100644
index 0000000..3b7a977
--- /dev/null
+++ b/src/Optics/Fold.hs
@@ -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
diff --git a/src/Optics/Getter.hs b/src/Optics/Getter.hs
new file mode 100644
index 0000000..5c1ce8d
--- /dev/null
+++ b/src/Optics/Getter.hs
@@ -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 #-}
diff --git a/src/Optics/Indexed/Core.hs b/src/Optics/Indexed/Core.hs
new file mode 100644
index 0000000..3f0c9d2
--- /dev/null
+++ b/src/Optics/Indexed/Core.hs
@@ -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
diff --git a/src/Optics/Internal/Bi.hs b/src/Optics/Internal/Bi.hs
new file mode 100644
index 0000000..0127e7b
--- /dev/null
+++ b/src/Optics/Internal/Bi.hs
@@ -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 #-}
diff --git a/src/Optics/Internal/Concrete.hs b/src/Optics/Internal/Concrete.hs
new file mode 100644
index 0000000..a1b16b3
--- /dev/null
+++ b/src/Optics/Internal/Concrete.hs
@@ -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)
diff --git a/src/Optics/Internal/Fold.hs b/src/Optics/Internal/Fold.hs
new file mode 100644
index 0000000..01e4af9
--- /dev/null
+++ b/src/Optics/Internal/Fold.hs
@@ -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
diff --git a/src/Optics/Internal/Indexed.hs b/src/Optics/Internal/Indexed.hs
new file mode 100644
index 0000000..650ea91
--- /dev/null
+++ b/src/Optics/Internal/Indexed.hs
@@ -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 #-}
diff --git a/src/Optics/Internal/IxFold.hs b/src/Optics/Internal/IxFold.hs
new file mode 100644
index 0000000..e59ffdd
--- /dev/null
+++ b/src/Optics/Internal/IxFold.hs
@@ -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__ #-}
diff --git a/src/Optics/Internal/IxSetter.hs b/src/Optics/Internal/IxSetter.hs
new file mode 100644
index 0000000..8bb3318
--- /dev/null
+++ b/src/Optics/Internal/IxSetter.hs
@@ -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__ #-}
diff --git a/src/Optics/Internal/IxTraversal.hs b/src/Optics/Internal/IxTraversal.hs
new file mode 100644
index 0000000..e759373
--- /dev/null
+++ b/src/Optics/Internal/IxTraversal.hs
@@ -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)
+
+#-}
diff --git a/src/Optics/Internal/Optic.hs b/src/Optics/Internal/Optic.hs
new file mode 100644
index 0000000..2ce40f8
--- /dev/null
+++ b/src/Optics/Internal/Optic.hs
@@ -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
diff --git a/src/Optics/Internal/Optic/Subtyping.hs b/src/Optics/Internal/Optic/Subtyping.hs
new file mode 100644
index 0000000..bc83c88
--- /dev/null
+++ b/src/Optics/Internal/Optic/Subtyping.hs
@@ -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)
diff --git a/src/Optics/Internal/Optic/TypeLevel.hs b/src/Optics/Internal/Optic/TypeLevel.hs
new file mode 100644
index 0000000..9c47125
--- /dev/null
+++ b/src/Optics/Internal/Optic/TypeLevel.hs
@@ -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 #-}
diff --git a/src/Optics/Internal/Optic/Types.hs b/src/Optics/Internal/Optic/Types.hs
new file mode 100644
index 0000000..55dac49
--- /dev/null
+++ b/src/Optics/Internal/Optic/Types.hs
@@ -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)
diff --git a/src/Optics/Internal/Profunctor.hs b/src/Optics/Internal/Profunctor.hs
new file mode 100644
index 0000000..7382331
--- /dev/null
+++ b/src/Optics/Internal/Profunctor.hs
@@ -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 #-}
diff --git a/src/Optics/Internal/Setter.hs b/src/Optics/Internal/Setter.hs
new file mode 100644
index 0000000..0b793f5
--- /dev/null
+++ b/src/Optics/Internal/Setter.hs
@@ -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__ #-}
diff --git a/src/Optics/Internal/Tagged.hs b/src/Optics/Internal/Tagged.hs
new file mode 100644
index 0000000..f2b9d91
--- /dev/null
+++ b/src/Optics/Internal/Tagged.hs
@@ -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 #-}
diff --git a/src/Optics/Internal/Traversal.hs b/src/Optics/Internal/Traversal.hs
new file mode 100644
index 0000000..0d843a9
--- /dev/null
+++ b/src/Optics/Internal/Traversal.hs
@@ -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)
+
+#-}
diff --git a/src/Optics/Internal/Utils.hs b/src/Optics/Internal/Utils.hs
new file mode 100644
index 0000000..a73f4ca
--- /dev/null
+++ b/src/Optics/Internal/Utils.hs
@@ -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 #-}
diff --git a/src/Optics/Iso.hs b/src/Optics/Iso.hs
new file mode 100644
index 0000000..48647ac
--- /dev/null
+++ b/src/Optics/Iso.hs
@@ -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
diff --git a/src/Optics/IxAffineFold.hs b/src/Optics/IxAffineFold.hs
new file mode 100644
index 0000000..1deb79f
--- /dev/null
+++ b/src/Optics/IxAffineFold.hs
@@ -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 #-}
diff --git a/src/Optics/IxAffineTraversal.hs b/src/Optics/IxAffineTraversal.hs
new file mode 100644
index 0000000..22a3ba9
--- /dev/null
+++ b/src/Optics/IxAffineTraversal.hs
@@ -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 #-}
diff --git a/src/Optics/IxFold.hs b/src/Optics/IxFold.hs
new file mode 100644
index 0000000..8e3b872
--- /dev/null
+++ b/src/Optics/IxFold.hs
@@ -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
diff --git a/src/Optics/IxGetter.hs b/src/Optics/IxGetter.hs
new file mode 100644
index 0000000..8e45386
--- /dev/null
+++ b/src/Optics/IxGetter.hs
@@ -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 #-}
diff --git a/src/Optics/IxLens.hs b/src/Optics/IxLens.hs
new file mode 100644
index 0000000..f862138
--- /dev/null
+++ b/src/Optics/IxLens.hs
@@ -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
diff --git a/src/Optics/IxSetter.hs b/src/Optics/IxSetter.hs
new file mode 100644
index 0000000..f99392c
--- /dev/null
+++ b/src/Optics/IxSetter.hs
@@ -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 #-}
diff --git a/src/Optics/IxTraversal.hs b/src/Optics/IxTraversal.hs
new file mode 100644
index 0000000..44a96b8
--- /dev/null
+++ b/src/Optics/IxTraversal.hs
@@ -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
diff --git a/src/Optics/Label.hs b/src/Optics/Label.hs
new file mode 100644
index 0000000..04498a9
--- /dev/null
+++ b/src/Optics/Label.hs
@@ -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
diff --git a/src/Optics/Lens.hs b/src/Optics/Lens.hs
new file mode 100644
index 0000000..9ac09a2
--- /dev/null
+++ b/src/Optics/Lens.hs
@@ -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
diff --git a/src/Optics/Operators.hs b/src/Optics/Operators.hs
new file mode 100644
index 0000000..ec8658f
--- /dev/null
+++ b/src/Optics/Operators.hs
@@ -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
diff --git a/src/Optics/Optic.hs b/src/Optics/Optic.hs
new file mode 100644
index 0000000..7d2f92c
--- /dev/null
+++ b/src/Optics/Optic.hs
@@ -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
diff --git a/src/Optics/Prism.hs b/src/Optics/Prism.hs
new file mode 100644
index 0000000..38a831f
--- /dev/null
+++ b/src/Optics/Prism.hs
@@ -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
diff --git a/src/Optics/Re.hs b/src/Optics/Re.hs
new file mode 100644
index 0000000..bc1de1e
--- /dev/null
+++ b/src/Optics/Re.hs
@@ -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
diff --git a/src/Optics/ReadOnly.hs b/src/Optics/ReadOnly.hs
new file mode 100644
index 0000000..67738f2
--- /dev/null
+++ b/src/Optics/ReadOnly.hs
@@ -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__ #-}
diff --git a/src/Optics/ReversedLens.hs b/src/Optics/ReversedLens.hs
new file mode 100644
index 0000000..c7f4bcd
--- /dev/null
+++ b/src/Optics/ReversedLens.hs
@@ -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
diff --git a/src/Optics/ReversedPrism.hs b/src/Optics/ReversedPrism.hs
new file mode 100644
index 0000000..f9d3361
--- /dev/null
+++ b/src/Optics/ReversedPrism.hs
@@ -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
diff --git a/src/Optics/Review.hs b/src/Optics/Review.hs
new file mode 100644
index 0000000..4ef85f7
--- /dev/null
+++ b/src/Optics/Review.hs
@@ -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
diff --git a/src/Optics/Setter.hs b/src/Optics/Setter.hs
new file mode 100644
index 0000000..dde9c13
--- /dev/null
+++ b/src/Optics/Setter.hs
@@ -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
diff --git a/src/Optics/Traversal.hs b/src/Optics/Traversal.hs
new file mode 100644
index 0000000..042a497
--- /dev/null
+++ b/src/Optics/Traversal.hs
@@ -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