optics (empty) → 0.1
raw patch · 15 files changed
+2625/−0 lines, 15 filesdep +arraydep +basedep +bytestringbinary-added
Dependencies added: array, base, bytestring, containers, criterion, inspection-testing, lens, mtl, optics, optics-core, optics-extra, optics-th, random, tasty, tasty-hunit, template-haskell, transformers, unordered-containers, vector
Files
- LICENSE +62/−0
- benchmarks/folds.hs +212/−0
- benchmarks/traversals.hs +447/−0
- diagrams/indexedoptics.png binary
- diagrams/optics.png binary
- diagrams/reoptics.png binary
- optics.cabal +178/−0
- src/Optics.hs +856/−0
- tests/Optics/Tests.hs +51/−0
- tests/Optics/Tests/Computation.hs +64/−0
- tests/Optics/Tests/Core.hs +319/−0
- tests/Optics/Tests/Eta.hs +123/−0
- tests/Optics/Tests/Labels.hs +195/−0
- tests/Optics/Tests/Misc.hs +39/−0
- tests/Optics/Tests/Utils.hs +79/−0
+ LICENSE view
@@ -0,0 +1,62 @@+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.
+ benchmarks/folds.hs view
@@ -0,0 +1,212 @@+module Main where++import Criterion.Main+import Criterion.Types+import qualified Control.Lens as L+import qualified Data.ByteString.Lens as L+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Foldable as F+import qualified Data.IntMap as IM+import qualified Data.HashMap.Lazy as HM+import qualified Data.Map as M+import qualified Data.Sequence as S+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U++import Data.ByteString.Optics+import Optics++itoList :: FoldableWithIndex i f => f a -> [(i, a)]+itoList = ifoldr (\i c -> ((i, c) :)) []++main :: IO ()+main = defaultMainWith config+ [ bgroup "vector"+ [ bgroup "toList"+ [ bench "native" $ nf V.toList v+ , bench "each" $ nf (toListOf each) v+ , bench "each/lens" $ nf (L.toListOf L.each) v+ , bench "itraversed" $ nf (toListOf itraversed) v+ , bench "itraversed/lens" $ nf (L.toListOf L.itraversed) v+ , bench "ifolded" $ nf (toListOf ifolded) v+ , bench "ifolded/lens" $ nf (L.toListOf L.ifolded) v+ ]+ , bgroup "itoList"+ [ bench "native" $ nf (V.toList . V.indexed) v+ , bench "itoList" $ nf itoList v+ , bench "itoList/lens" $ nf L.itoList v+ , bench "each" $ nf (itoListOf each) v+ , bench "itraversed" $ nf (itoListOf itraversed) v+ , bench "itraversed/lens" $ nf (L.itoListOf L.itraversed) v+ , bench "ifolded" $ nf (itoListOf ifolded) v+ , bench "ifolded/lens" $ nf (L.itoListOf L.ifolded) v+ ]+ ]+ , bgroup "unboxed-vector"+ [ bgroup "toList"+ [ bench "native" $ nf U.toList u+ , bench "each" $ nf (toListOf each) u+ , bench "each/lens" $ nf (L.toListOf L.each) u+ ]+ , bgroup "itoList"+ [ bench "native" $ nf (U.toList . U.indexed) u+ , bench "each" $ nf (itoListOf each) u+ ]+ ]+ , bgroup "sequence"+ [ bgroup "toList"+ [ bench "native" $ nf F.toList s+ , bench "each" $ nf (toListOf each) s+ , bench "each/lens" $ nf (L.toListOf L.each) s+ , bench "itraversed" $ nf (toListOf itraversed) s+ , bench "itraversed/lens" $ nf (L.toListOf L.itraversed) s+ , bench "ifolded" $ nf (toListOf ifolded) s+ , bench "ifolded/lens" $ nf (L.toListOf L.ifolded) s+ ]+ , bgroup "itoList"+ [ bench "native" $ nf (F.toList . S.mapWithIndex (,)) s+ , bench "itoList" $ nf itoList s+ , bench "itoList/lens" $ nf L.itoList s+ , bench "each" $ nf (itoListOf each) s+ , bench "itraversed" $ nf (itoListOf itraversed) s+ , bench "itraversed/lens" $ nf (L.itoListOf L.itraversed) s+ , bench "ifolded" $ nf (itoListOf ifolded) s+ , bench "ifolded/lens" $ nf (L.itoListOf L.ifolded) s+ ]+ ]+ , bgroup "bytestring"+ [ bgroup "toList"+ [ bench "native" $ nf BS.unpack b+ , bench "bytes" $ nf (toListOf bytes) b+ , bench "bytes/lens" $ nf (L.toListOf L.bytes) b+ , bench "each" $ nf (toListOf each) b+ , bench "each/lens" $ nf (L.toListOf L.each) b+ ]+ , bgroup "itoList"+ [ bench "native" $ nf (zip [(0::Int)..] . BS.unpack) b+ , bench "bytes" $ nf (itoListOf bytes) b+ , bench "bytes/lens" $ nf (L.itoListOf L.bytes) b+ , bench "each" $ nf (itoListOf each) b+ ]+ ]+ , bgroup "bytestring lazy"+ [ bgroup "toList"+ [ bench "native" $ nf BSL.unpack bl+ , bench "bytes" $ nf (toListOf bytes) bl+ , bench "bytes/lens" $ nf (L.toListOf L.bytes) bl+ , bench "each" $ nf (toListOf each) bl+ , bench "each/lens" $ nf (L.toListOf L.each) bl+ ]+ , bgroup "itoList"+ [ bench "native" $ nf (zip [(0::Int)..] . BSL.unpack) bl+ , bench "bytes" $ nf (itoListOf bytes) bl+ , bench "bytes/lens" $ nf (L.itoListOf L.bytes) bl+ , bench "each" $ nf (itoListOf each) bl+ ]+ ]+ , bgroup "list"+ [ bgroup "toList"+ [ bench "native" $ nf F.toList l+ , bench "each" $ nf (toListOf each) l+ , bench "each/lens" $ nf (L.toListOf L.each) l+ , bench "itraversed" $ nf (toListOf itraversed) l+ , bench "itraversed/lens" $ nf (L.toListOf L.itraversed) l+ , bench "ifolded" $ nf (toListOf ifolded) l+ , bench "ifolded/lens" $ nf (L.toListOf L.ifolded) l+ ]+ , bgroup "itoList"+ [ bench "native" $ nf (zip [(0::Int)..]) l+ , bench "itoList" $ nf itoList l+ , bench "itoList/lens" $ nf L.itoList l+ , bench "each" $ nf (itoListOf each) l+ , bench "itraversed" $ nf (itoListOf itraversed) l+ , bench "itraversed/lens" $ nf (L.itoListOf L.itraversed) l+ , bench "ifolded" $ nf (itoListOf ifolded) l+ , bench "ifolded/lens" $ nf (L.itoListOf L.ifolded) l+ ]+ ]+ , bgroup "intmap"+ [ bgroup "toList"+ [ bench "native" $ nf F.toList im+ , bench "each" $ nf (toListOf each) im+ , bench "each/lens" $ nf (L.toListOf L.each) im+ , bench "itraversed" $ nf (toListOf itraversed) im+ , bench "itraversed/lens" $ nf (L.toListOf L.itraversed) im+ , bench "ifolded" $ nf (toListOf ifolded) im+ , bench "ifolded/lens" $ nf (L.toListOf L.ifolded) im+ ]+ , bgroup "itoList"+ [ bench "native" $ nf IM.toList im+ , bench "itoList" $ nf itoList im+ , bench "itoList/lens" $ nf L.itoList im+ , bench "each" $ nf (itoListOf each) im+ , bench "itraversed" $ nf (itoListOf itraversed) im+ , bench "itraversed/lens" $ nf (L.itoListOf L.itraversed) im+ , bench "ifolded" $ nf (itoListOf ifolded) im+ , bench "ifolded/lens" $ nf (L.itoListOf L.ifolded) im+ ]+ ]+ , bgroup "map"+ [ bgroup "toList"+ [ bench "native" $ nf F.toList m+ , bench "each" $ nf (toListOf each) m+ , bench "each/lens" $ nf (L.toListOf L.each) m+ , bench "itraversed" $ nf (toListOf itraversed) m+ , bench "itraversed/lens" $ nf (L.toListOf L.itraversed) m+ , bench "ifolded" $ nf (toListOf ifolded) m+ , bench "ifolded/lens" $ nf (L.toListOf L.ifolded) m+ ]+ , bgroup "itoList"+ [ bench "native" $ nf M.toList m+ , bench "itoList" $ nf itoList m+ , bench "itoList/lens" $ nf L.itoList m+ , bench "each" $ nf (itoListOf each) m+ , bench "itraversed" $ nf (itoListOf itraversed) m+ , bench "itraversed/lens" $ nf (L.itoListOf L.itraversed) m+ , bench "ifolded" $ nf (itoListOf ifolded) m+ , bench "ifolded/lens" $ nf (L.itoListOf L.ifolded) m+ ]+ ]+ , bgroup "hash map"+ [ bgroup "toList"+ [ bench "native" $ nf HM.keys h+ , bench "each" $ nf (toListOf each) h+ , bench "each/lens" $ nf (L.toListOf L.each) h+ , bench "itraversed" $ nf (toListOf itraversed) h+ , bench "itraversed/lens" $ nf (L.toListOf L.itraversed) h+ , bench "ifolded" $ nf (toListOf ifolded) h+ , bench "ifolded/lens" $ nf (L.toListOf L.ifolded) h+ ]+ , bgroup "itoList"+ [ bench "native" $ nf HM.toList h+ , bench "itoList" $ nf itoList h+ , bench "itoList/lens" $ nf L.itoList h+ , bench "each" $ nf (itoListOf each) h+ , bench "itraversed" $ nf (itoListOf itraversed) h+ , bench "itraversed/lens" $ nf (L.itoListOf L.itraversed) h+ , bench "ifolded" $ nf (itoListOf ifolded) h+ , bench "ifolded/lens" $ nf (L.itoListOf L.ifolded) h+ ]+ , bgroup "sum"+ [ bench "native" $ nf (sum . F.toList) h+ , bench "each" $ nf (sumOf each) h+ , bench "each/lens" $ nf (L.sumOf L.each) h+ , bench "itraversed" $ nf (sumOf itraversed) h+ , bench "itraversed/lens" $ nf (L.sumOf L.itraversed) h+ , bench "ifolded" $ nf (sumOf ifolded) h+ , bench "ifolded/lens" $ nf (L.sumOf L.ifolded) h+ ]+ ]+ ]+ where+ config = defaultConfig { timeLimit = 1 }+ l = [0..10000] :: [Int]+ b = BS.pack $ map fromIntegral l+ bl = BSL.pack $ map fromIntegral [0..1000000::Int]+ h = HM.fromList $ zip l l+ m = M.fromList $ zip l l+ im = IM.fromList $ zip l l+ s = S.fromList l+ u = U.fromList l+ v = V.fromList l
+ benchmarks/traversals.hs view
@@ -0,0 +1,447 @@+{-# LANGUAGE CPP #-}+module Main where++import Criterion.Main+import Criterion.Types+import Data.Char+import qualified Control.Lens as L+import qualified Control.Monad.Trans.State as S+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL8+import qualified Data.ByteString.Lens as L+import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Sequence as S+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U++import Data.ByteString.Optics+import Optics++seqTraverseWithIndex+ :: Applicative f => (Int -> a -> f b) -> S.Seq a -> f (S.Seq b)+seqTraverseWithIndex f =+#if MIN_VERSION_containers(0,5,8)+ S.traverseWithIndex f+#else+ sequenceA . S.mapWithIndex f+#endif++main :: IO ()+main = defaultMainWith config+ [ bgroup "vector"+ [ bgroup "traverse"+ [ bench "native" $+ nf (\x -> S.execState (traverse (S.modify' . (+)) x) 0) v+ , bench "each" $+ nf (\x -> S.execState (traverseOf each (S.modify' . (+)) x) 0) v+ , bench "each/lens" $+ nf (\x -> S.execState (L.traverseOf L.each (S.modify' . (+)) x) 0) v+ , bench "itraversed" $+ nf (\x -> S.execState (traverseOf itraversed (S.modify' . (+)) x) 0) v+ , bench "itraversed/lens" $+ nf (\x -> S.execState (L.traverseOf L.itraversed (S.modify' . (+)) x) 0) v+ ]+ , bgroup "itraverse"+ [ bench "native" $ nf (\x -> S.execState (traverse (\(i, a) -> S.modify' $ (i + a +)) $ V.indexed x) 0) v+ , bench "itraverse" $ nf (\x -> S.execState (itraverse (\i a -> S.modify' $ (i + a +)) x) 0) v+ , bench "itraverse/lens" $ nf (\x -> S.execState (L.itraverse (\i a -> S.modify' $ (i + a +)) x) 0) v+ , bench "each" $ nf (\x -> S.execState (itraverseOf each (\i a -> S.modify' $ (i + a +)) x) 0) v+ , bench "itraversed" $ nf (\x -> S.execState (itraverseOf itraversed (\i a -> S.modify' $ (i + a +)) x) 0) v+ , bench "itraversed/lens" $ nf (\x -> S.execState (L.itraverseOf L.itraversed (\i a -> S.modify' $ (i + a +)) x) 0) v+ ]+ , bgroup "map"+ [ bench "native" $ nf (V.map (+100)) v+ , bench "each" $ nf (over each (+100)) v+ , bench "each/lens" $ nf (L.over L.each (+100)) v+ , bench "itraversed" $ nf (over itraversed (+100)) v+ , bench "itraversed/lens" $ nf (L.over L.itraversed (+100)) v+ , bench "imapped" $ nf (over imapped (+100)) v+ , bench "imapped/lens" $ nf (L.over L.imapped (+100)) v+ ]+ , bgroup "imap"+ [ bench "native" $ nf (V.imap (\i x -> x + i +100)) v+ , bench "imap" $ nf (imap (\i x -> x + i +100)) v+ , bench "imap/lens" $ nf (L.imap (\i x -> x + i +100)) v+ , bench "each" $ nf (iover each (\i x -> x + i +100)) v+ , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) v+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (\i x -> x + i +100)) v+ , bench "imapped" $ nf (iover imapped (\i x -> x + i +100)) v+ , bench "imapped/lens" $ nf (L.iover L.imapped (\i x -> x + i +100)) v+ ]+ , bgroup "elements"+ [ bench "itraversed" $ nf (iover itraversed (+)) v+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (+)) v+ , bench "elements" $ nf (iover (elements $ const True) (+)) v+ , bench "elements/lens" $ nf (L.iover (L.elements $ const True) (+)) v+ ]+ , bgroup "partsOf"+ [ bench "partsOf" $ nf (over (partsOf traversed) reverse) v+ , bench "partsOf/lens" $ nf (L.over (L.partsOf traverse) reverse) v+ , bench "ipartsOf" $ nf (iover (ipartsOf itraversed) (\is -> reverse . zipWith (+) is)) v+ , bench "ipartsOf/lens" $ nf (L.iover (L.ipartsOf L.itraversed) (\is -> reverse . zipWith (+) is)) v+ ]+ , bgroup "indices"+ [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) v+ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) v+ ]+ ]+ , bgroup "unboxed-vector"+ [ bgroup "map"+ [ bench "native" $ nf (U.map (+100)) u+ , bench "each" $ nf (over each (+100)) u+ , bench "each/lens" $ nf (L.over L.each (+100)) u+ ]+ , bgroup "imap"+ [ bench "native" $ nf (U.imap (\i x -> x + i +100)) u+ , bench "each" $ nf (iover each (\i x -> x + i)) u+ ]+ ]+ , bgroup "sequence"+ [ bgroup "traverse"+ [ bench "native" $+ nf (\x -> S.execState (traverse (S.modify' . (+)) x) 0) s+ , bench "each" $+ nf (\x -> S.execState (traverseOf each (S.modify' . (+)) x) 0) s+ , bench "each/lens" $+ nf (\x -> S.execState (L.traverseOf L.each (S.modify' . (+)) x) 0) s+ , bench "itraversed" $+ nf (\x -> S.execState (traverseOf itraversed (S.modify' . (+)) x) 0) s+ , bench "itraversed/lens" $+ nf (\x -> S.execState (L.traverseOf L.itraversed (S.modify' . (+)) x) 0) s+ ]+ , bgroup "itraverse"+ [ bench "native" $ nf (\x -> S.execState (seqTraverseWithIndex (\i a -> S.modify' $ (i + a +)) x) 0) s+ , bench "itraverse " $ nf (\x -> S.execState (itraverse (\i a -> S.modify' $ (i + a +)) x) 0) s+ , bench "itraverse/lens" $ nf (\x -> S.execState (L.itraverse (\i a -> S.modify' $ (i + a +)) x) 0) s+ , bench "each" $ nf (\x -> S.execState (itraverseOf each (\i a -> S.modify' $ (i + a +)) x) 0) s+ , bench "itraversed" $ nf (\x -> S.execState (itraverseOf itraversed (\i a -> S.modify' $ (i + a +)) x) 0) s+ , bench "itraversed/lens" $ nf (\x -> S.execState (L.itraverseOf L.itraversed (\i a -> S.modify' $ (i + a +)) x) 0) s+ ]+ , bgroup "map"+ [ bench "native" $ nf (fmap (+100)) s+ , bench "each" $ nf (over each (+100)) s+ , bench "each/lens" $ nf (L.over L.each (+100)) s+ , bench "itraversed" $ nf (over itraversed (+100)) s+ , bench "itraversed/lens" $ nf (L.over L.itraversed (+100)) s+ , bench "imapped" $ nf (over imapped (+100)) s+ , bench "imapped/lens" $ nf (L.over L.imapped (+100)) s+ ]+ , bgroup "imap"+ [ bench "native" $ nf (S.mapWithIndex (\i x -> x + i +100)) s+ , bench "imap" $ nf (imap (\i x -> x + i +100)) s+ , bench "imap/lens" $ nf (L.imap (\i x -> x + i +100)) s+ , bench "each" $ nf (iover each (\i x -> x + i +100)) s+ , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) s+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (\i x -> x + i +100)) s+ , bench "imapped" $ nf (iover imapped (\i x -> x + i +100)) s+ , bench "imapped/lens" $ nf (L.iover L.imapped (\i x -> x + i +100)) s+ ]+ , bgroup "elements"+ [ bench "itraversed" $ nf (iover itraversed (+)) s+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (+)) s+ , bench "elements" $ nf (iover (elements $ const True) (+)) s+ , bench "elements/lens" $ nf (L.iover (L.elements $ const True) (+)) s+ ]+ , bgroup "partsOf"+ [ bench "partsOf" $ nf (over (partsOf traversed) reverse) s+ , bench "partsOf/lens" $ nf (L.over (L.partsOf traverse) reverse) s+ , bench "ipartsOf" $ nf (iover (ipartsOf itraversed) (\is -> reverse . zipWith (+) is)) s+ , bench "ipartsOf/lens" $ nf (L.iover (L.ipartsOf L.itraversed) (\is -> reverse . zipWith (+) is)) s+ ]+ , bgroup "indices"+ [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) s+ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) s+ ]+ ]+ , bgroup "bytestring"+ [ bgroup "map"+ [ bench "native" $ nf (BS.map (+100)) b+ , bench "each" $ nf (over each (+100)) b+ , bench "each/lens" $ nf (L.over L.each (+100)) b+ ]+ , bgroup "imap"+ [ bench "bytes" $ nf (iover bytes (\i x -> x + fromIntegral i)) b+ , bench "bytes/lens" $ nf (L.iover L.bytes (\i x -> x + fromIntegral i)) b+ ]+ ]+ , bgroup "bytestring char8"+ [ bgroup "map"+ [ bench "native" $ nf (BS8.map (chr . (+100) . ord)) b+ , bench "chars" $ nf (over chars (chr . (+100) . ord)) b+ , bench "chars/lens" $ nf (L.over L.chars (chr . (+100) . ord)) b+ ]+ , bgroup "imap"+ [ bench "chars" $ nf+ (iover chars (\i x -> chr $ ord x + fromIntegral (i `mod` 256))) b+ , bench "chars/lens" $ nf+ (L.iover L.chars (\i x -> chr $ ord x + fromIntegral (i `mod` 256))) b+ ]+ ]+ , bgroup "bytestring lazy"+ [ bgroup "map"+ [ bench "native" $ nf (BSL.map (+100)) bl+ , bench "each" $ nf (over each (+100)) bl+ , bench "each/lens" $ nf (L.over L.each (+100)) bl+ ]+ , bgroup "imap"+ [ bench "bytes" $ nf (iover bytes (\i x -> x + fromIntegral i)) bl+ , bench "bytes/lens" $ nf (L.iover L.bytes (\i x -> x + fromIntegral i)) bl+ ]+ ]+ , bgroup "bytestring lazy char8"+ [ bgroup "map"+ [ bench "native" $ nf (BSL8.map (chr . (+100) . ord)) bl+ , bench "chars" $ nf (over chars (chr . (+100) . ord)) bl+ , bench "chars/lens" $ nf (L.over L.chars (chr . (+100) . ord)) bl+ ]+ , bgroup "imap"+ [ bench "chars" $ nf+ (iover chars (\i x -> chr $ ord x + fromIntegral (i `mod` 256))) bl+ , bench "chars/lens" $ nf+ (L.iover L.chars (\i x -> chr $ ord x + fromIntegral (i `mod` 256))) bl+ ]+ ]+ , bgroup "list"+ [ bgroup "traverse"+ [ bench "native" $+ nf (\x -> S.execState (traverse (S.modify' . (+)) x) 0) l+ , bench "each" $+ nf (\x -> S.execState (traverseOf each (S.modify' . (+)) x) 0) l+ , bench "each/lens" $+ nf (\x -> S.execState (L.traverseOf L.each (S.modify' . (+)) x) 0) l+ , bench "itraversed" $+ nf (\x -> S.execState (traverseOf itraversed (S.modify' . (+)) x) 0) l+ , bench "itraversed/lens" $+ nf (\x -> S.execState (L.traverseOf L.itraversed (S.modify' . (+)) x) 0) l+ ]+ , bgroup "itraverse"+ [ bench "native" $ nf (\x -> S.execState (traverse (\(i, a) -> S.modify' $ (i + a +)) (zip [0..] x)) 0) l+ , bench "itraverse" $ nf (\x -> S.execState (itraverse (\i a -> S.modify' $ (i + a +)) x) 0) l+ , bench "itraverse/lens" $ nf (\x -> S.execState (L.itraverse (\i a -> S.modify' $ (i + a +)) x) 0) l+ , bench "each" $ nf (\x -> S.execState (itraverseOf each (\i a -> S.modify' $ (i + a +)) x) 0) l+ , bench "itraversed" $ nf (\x -> S.execState (itraverseOf itraversed (\i a -> S.modify' $ (i + a +)) x) 0) l+ , bench "itraversed/lens" $ nf (\x -> S.execState (L.itraverseOf L.itraversed (\i a -> S.modify' $ (i + a +)) x) 0) l+ ]+ , bgroup "map"+ [ bench "native" $ nf (map (+100)) l+ , bench "each" $ nf (over each (+100)) l+ , bench "each/lens" $ nf (L.over L.each (+100)) l+ , bench "itraversed" $ nf (over itraversed (+100)) l+ , bench "itraversed/lens" $ nf (L.over L.itraversed (+100)) l+ , bench "imapped" $ nf (over imapped (+100)) l+ , bench "imapped/lens" $ nf (L.over L.imapped (+100)) l+ ]+ , bgroup "imap"+ [ bench "imap" $ nf (imap (\i x -> x + i +100)) l+ , bench "imap/lens" $ nf (L.imap (\i x -> x + i +100)) l+ , bench "each" $ nf (iover each (\i x -> x + i +100)) l+ , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) l+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (\i x -> x + i +100)) l+ , bench "imapped" $ nf (iover imapped (\i x -> x + i +100)) l+ , bench "imapped/lens" $ nf (L.iover L.imapped (\i x -> x + i +100)) l+ ]+ , bgroup "elements"+ [ bench "itraversed" $ nf (iover itraversed (+)) l+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (+)) l+ , bench "elements" $ nf (iover (elements $ const True) (+)) l+ , bench "elements/lens" $ nf (L.iover (L.elements $ const True) (+)) l+ ]+ , bgroup "partsOf"+ [ bench "partsOf" $ nf (over (partsOf traversed) reverse) l+ , bench "partsOf/lens" $ nf (L.over (L.partsOf traverse) reverse) l+ , bench "ipartsOf" $ nf (iover (ipartsOf itraversed) (\is -> reverse . zipWith (+) is)) l+ , bench "ipartsOf/lens" $ nf (L.iover (L.ipartsOf L.itraversed) (\is -> reverse . zipWith (+) is)) l+ ]+ , bgroup "indices"+ [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) l+ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) l+ ]+ ]+ , bgroup "intmap"+ [ bgroup "traverse"+ [ bench "native" $+ nf (\x -> S.execState (traverse (S.modify' . (+)) x) 0) im+ , bench "each" $+ nf (\x -> S.execState (traverseOf each (S.modify' . (+)) x) 0) im+ , bench "each/lens" $+ nf (\x -> S.execState (L.traverseOf L.each (S.modify' . (+)) x) 0) im+ , bench "itraversed" $+ nf (\x -> S.execState (traverseOf itraversed (S.modify' . (+)) x) 0) im+ , bench "itraversed/lens" $+ nf (\x -> S.execState (L.traverseOf L.itraversed (S.modify' . (+)) x) 0) im+ ]+ , bgroup "itraverse"+ [ bench "native" $ nf (\x -> S.execState (IM.traverseWithKey (\i a -> S.modify' $ (i + a +)) x) 0) im+ , bench "itraverse" $ nf (\x -> S.execState (itraverse (\i a -> S.modify' $ (i + a +)) x) 0) im+ , bench "itraverse/lens" $ nf (\x -> S.execState (L.itraverse (\i a -> S.modify' $ (i + a +)) x) 0) im+ , bench "each" $ nf (\x -> S.execState (itraverseOf each (\i a -> S.modify' $ (i + a +)) x) 0) im+ , bench "itraversed" $ nf (\x -> S.execState (itraverseOf itraversed (\i a -> S.modify' $ (i + a +)) x) 0) im+ , bench "itraversed/lens" $ nf (\x -> S.execState (L.itraverseOf L.itraversed (\i a -> S.modify' $ (i + a +)) x) 0) im+ ]+ , bgroup "map"+ [ bench "native" $ nf (fmap (+100)) im+ , bench "each" $ nf (over each (+100)) im+ , bench "each/lens" $ nf (L.over L.each (+100)) im+ , bench "itraversed" $ nf (over itraversed (+100)) im+ , bench "itraversed/lens" $ nf (L.over L.itraversed (+100)) im+ , bench "imapped" $ nf (over imapped (+100)) im+ , bench "imapped/lens" $ nf (L.over L.imapped (+100)) im+ ]+ , bgroup "imap"+ [ bench "native" $ nf (IM.mapWithKey (\i x -> x + i +100)) im+ , bench "imap" $ nf (imap (\i x -> x + i +100)) im+ , bench "imap/lens" $ nf (L.imap (\i x -> x + i +100)) im+ , bench "each" $ nf (iover each (\i x -> x + i +100)) im+ , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) im+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (\i x -> x + i +100)) im+ , bench "imapped" $ nf (iover imapped (\i x -> x + i +100)) im+ , bench "imapped/lens" $ nf (L.iover L.imapped (\i x -> x + i +100)) im+ ]+ , bgroup "elements"+ [ bench "itraversed" $ nf (iover itraversed (+)) im+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (+)) im+ , bench "elements" $ nf (iover (elements $ const True) (+)) im+ , bench "elements/lens" $ nf (L.iover (L.elements $ const True) (+)) im+ ]+ , bgroup "partsOf"+ [ bench "partsOf" $ nf (over (partsOf traversed) reverse) im+ , bench "partsOf/lens" $ nf (L.over (L.partsOf traverse) reverse) im+ , bench "ipartsOf" $ nf (iover (ipartsOf itraversed) (\is -> reverse . zipWith (+) is)) im+ , bench "ipartsOf/lens" $ nf (L.iover (L.ipartsOf L.itraversed) (\is -> reverse . zipWith (+) is)) im+ ]+ , bgroup "indices"+ [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) im+ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) im+ ]+ ]+ , bgroup "map"+ [ bgroup "traverse"+ [ bench "native" $+ nf (\x -> S.execState (traverse (S.modify' . (+)) x) 0) m+ , bench "each" $+ nf (\x -> S.execState (traverseOf each (S.modify' . (+)) x) 0) m+ , bench "each/lens" $+ nf (\x -> S.execState (L.traverseOf L.each (S.modify' . (+)) x) 0) m+ , bench "itraversed" $+ nf (\x -> S.execState (traverseOf itraversed (S.modify' . (+)) x) 0) m+ , bench "itraversed/lens" $+ nf (\x -> S.execState (L.traverseOf L.itraversed (S.modify' . (+)) x) 0) m+ ]+ , bgroup "itraverse"+ [ bench "native" $ nf (\x -> S.execState (M.traverseWithKey (\i a -> S.modify' $ (i + a +)) x) 0) m+ , bench "itraverse" $ nf (\x -> S.execState (itraverse (\i a -> S.modify' $ (i + a +)) x) 0) m+ , bench "itraverse/lens" $ nf (\x -> S.execState (L.itraverse (\i a -> S.modify' $ (i + a +)) x) 0) m+ , bench "each" $ nf (\x -> S.execState (itraverseOf each (\i a -> S.modify' $ (i + a +)) x) 0) m+ , bench "itraversed" $ nf (\x -> S.execState (itraverseOf itraversed (\i a -> S.modify' $ (i + a +)) x) 0) m+ , bench "itraversed/lens" $ nf (\x -> S.execState (L.itraverseOf L.itraversed (\i a -> S.modify' $ (i + a +)) x) 0) m+ ]+ , bgroup "map"+ [ bench "native" $ nf (fmap (+100)) m+ , bench "each" $ nf (over each (+100)) m+ , bench "each/lens" $ nf (L.over L.each (+100)) m+ , bench "itraversed" $ nf (over itraversed (+100)) m+ , bench "itraversed/lens" $ nf (L.over L.itraversed (+100)) m+ , bench "imapped" $ nf (over imapped (+100)) m+ , bench "imapped/lens" $ nf (L.over L.imapped (+100)) m+ ]+ , bgroup "imap"+ [ bench "native" $ nf (M.mapWithKey (\i x -> x + i +100)) m+ , bench "imap" $ nf (imap (\i x -> x + i +100)) m+ , bench "imap/lens" $ nf (L.imap (\i x -> x + i +100)) m+ , bench "each" $ nf (iover each (\i x -> x + i +100)) m+ , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) m+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (\i x -> x + i +100)) m+ , bench "imapped" $ nf (iover imapped (\i x -> x + i +100)) m+ , bench "imapped/lens" $ nf (L.iover L.imapped (\i x -> x + i +100)) m+ ]+ , bgroup "elements"+ [ bench "itraversed" $ nf (iover itraversed (+)) m+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (+)) m+ , bench "elements" $ nf (iover (elements $ const True) (+)) m+ , bench "elements/lens" $ nf (L.iover (L.elements $ const True) (+)) m+ ]+ , bgroup "partsOf"+ [ bench "partsOf" $ nf (over (partsOf traversed) reverse) m+ , bench "partsOf/lens" $ nf (L.over (L.partsOf traverse) reverse) m+ , bench "ipartsOf" $ nf (iover (ipartsOf itraversed) (\is -> reverse . zipWith (+) is)) m+ , bench "ipartsOf/lens" $ nf (L.iover (L.ipartsOf L.itraversed) (\is -> reverse . zipWith (+) is)) m+ ]+ , bgroup "indices"+ [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) m+ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) m+ ]+ ]+ , bgroup "hash map"+ [ bgroup "traverse"+ [ bench "native" $+ nf (\x -> S.execState (traverse (S.modify' . (+)) x) 0) h+ , bench "each" $+ nf (\x -> S.execState (traverseOf each (S.modify' . (+)) x) 0) h+ , bench "each/lens" $+ nf (\x -> S.execState (L.traverseOf L.each (S.modify' . (+)) x) 0) h+ , bench "itraversed" $+ nf (\x -> S.execState (traverseOf itraversed (S.modify' . (+)) x) 0) h+ , bench "itraversed/lens" $+ nf (\x -> S.execState (L.traverseOf L.itraversed (S.modify' . (+)) x) 0) h+ ]+ , bgroup "itraverse"+ [ bench "native" $ nf (\x -> S.execState (HM.traverseWithKey (\i a -> S.modify' $ (i + a +)) x) 0) h+ , bench "itraverse" $ nf (\x -> S.execState (itraverse (\i a -> S.modify' $ (i + a +)) x) 0) h+ , bench "itraverse/lens" $ nf (\x -> S.execState (L.itraverse (\i a -> S.modify' $ (i + a +)) x) 0) h+ , bench "each" $ nf (\x -> S.execState (itraverseOf each (\i a -> S.modify' $ (i + a +)) x) 0) h+ , bench "itraversed" $ nf (\x -> S.execState (itraverseOf itraversed (\i a -> S.modify' $ (i + a +)) x) 0) h+ , bench "itraversed/lens" $ nf (\x -> S.execState (L.itraverseOf L.itraversed (\i a -> S.modify' $ (i + a +)) x) 0) h+ ]+ , bgroup "map"+ [ bench "native" $ nf (HM.map (+100)) h+ , bench "each" $ nf (over each (+100)) h+ , bench "each/lens" $ nf (L.over L.each (+100)) h+ , bench "itraversed" $ nf (over itraversed (+100)) h+ , bench "itraversed/lens" $ nf (L.over L.itraversed (+100)) h+ , bench "imapped" $ nf (over imapped (+100)) h+ , bench "imapped/lens" $ nf (L.over L.imapped (+100)) h+ ]+ , bgroup "imap"+ [ bench "native" $ nf (HM.mapWithKey (\i x -> x + i +100)) h+ , bench "imap" $ nf (imap (\i x -> x + i +100)) h+ , bench "imap/lens" $ nf (L.imap (\i x -> x + i +100)) h+ , bench "each" $ nf (iover each (\i x -> x + i +100)) h+ , bench "itraversed" $ nf (iover itraversed (\i x -> x + i +100)) h+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (\i x -> x + i +100)) h+ , bench "imapped" $ nf (iover imapped (\i x -> x + i +100)) h+ , bench "imapped/lens" $ nf (L.iover L.imapped (\i x -> x + i +100)) h+ ]+ , bgroup "elements"+ [ bench "itraversed" $ nf (iover itraversed (+)) h+ , bench "itraversed/lens" $ nf (L.iover L.itraversed (+)) h+ , bench "elements" $ nf (iover (elements $ const True) (+)) h+ , bench "elements/lens" $ nf (L.iover (L.elements $ const True) (+)) h+ ]+ , bgroup "partsOf"+ [ bench "partsOf" $ nf (over (partsOf traversed) reverse) h+ , bench "partsOf/lens" $ nf (L.over (L.partsOf traverse) reverse) h+ , bench "ipartsOf" $ nf (iover (ipartsOf itraversed) (\is -> reverse . zipWith (+) is)) h+ , bench "ipartsOf/lens" $ nf (L.iover (L.ipartsOf L.itraversed) (\is -> reverse . zipWith (+) is)) h+ ]+ , bgroup "indices"+ [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) h+ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) h+ ]+ ]+ ]+ where+ config = defaultConfig { timeLimit = 1 }+ l = [0..10000] :: [Int]+ xl = [0..100000] :: [Int]+ b = BS.pack $ map fromIntegral xl+ bl = BSL.pack $ map fromIntegral [0..1000000::Int]+ h = HM.fromList $ zip l l+ m = M.fromList $ zip l l+ im = IM.fromList $ zip l l+ s = S.fromList l+ u = U.fromList xl+ v = V.fromList l
+ diagrams/indexedoptics.png view
binary file changed (absent → 43159 bytes)
+ diagrams/optics.png view
binary file changed (absent → 21245 bytes)
+ diagrams/reoptics.png view
binary file changed (absent → 24123 bytes)
+ optics.cabal view
@@ -0,0 +1,178 @@+name: optics+version: 0.1+license: BSD3+license-file: LICENSE+build-type: Simple+maintainer: optics@well-typed.com+author: Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus+cabal-version: 1.24+tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1+synopsis: Optics as an abstract interface+category: Data, Optics, Lenses+description:+ This package makes it possible to define and use Lenses, Traversals, Prisms+ and other optics, using an abstract interface. See the main module "Optics"+ for the documentation.+ .+ This is the "batteries-included" variant with many dependencies; see the+ @optics-core@ package and other @optics-*@ dependencies if you need a more+ limited dependency footprint.++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++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+ , mtl >= 2.2.2 && <2.3+ , optics-core >= 0.1 && <1+ , optics-extra >= 0.1 && <1+ , optics-th >= 0.1 && <1+ , transformers >= 0.5 && <0.6++ -- main module to land with repl+ exposed-modules: Optics++ -- main optic type+ reexported-modules: Optics.Optic++ -- optic flavours+ reexported-modules: 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++ -- optics utilities+ reexported-modules: Optics.Arrow+ , Optics.At+ , Optics.Coerce+ , Optics.Cons+ , Optics.Each+ , Optics.Empty+ , Optics.Indexed+ , Optics.Label+ , Optics.Operators+ , Optics.Passthrough+ , Optics.Re+ , Optics.ReadOnly+ , Optics.State+ , Optics.State.Operators+ , Optics.View+ , Optics.Zoom++ -- template haskell support+ reexported-modules: Optics.TH++ -- data specific optics+ reexported-modules: Data.ByteString.Lazy.Optics+ , Data.ByteString.Optics+ , Data.ByteString.Strict.Optics+ , Data.Either.Optics+ , Data.HashMap.Optics+ , Data.HashSet.Optics+ , Data.IntMap.Optics+ , Data.IntSet.Optics+ , Data.List.Optics+ , Data.Map.Optics+ , Data.Maybe.Optics+ , Data.Sequence.Optics+ , Data.Set.Optics+ , Data.Text.Lazy.Optics+ , Data.Text.Optics+ , Data.Text.Strict.Optics+ , Data.Tree.Optics+ , Data.Tuple.Optics+ , Data.Typeable.Optics+ , Data.Vector.Generic.Optics+ , Data.Vector.Optics+ , GHC.Generics.Optics+ , Numeric.Optics++test-suite optics-tests+ default-language: Haskell2010+ hs-source-dirs: tests+ ghc-options: -Wall++ build-depends: base+ , containers+ , inspection-testing >= 0.4.1.1 && <0.5+ , mtl+ , optics+ , optics-core+ , random+ , tasty+ , tasty-hunit+ , template-haskell++ type: exitcode-stdio-1.0+ main-is: Optics/Tests.hs++ other-modules: Optics.Tests.Computation+ Optics.Tests.Core+ Optics.Tests.Eta+ Optics.Tests.Labels+ Optics.Tests.Misc+ Optics.Tests.Utils++-- Benchmarking folds+benchmark folds+ default-language: Haskell2010+ hs-source-dirs: benchmarks+ ghc-options: -Wall -threaded++ build-depends: base+ , bytestring+ , containers+ , criterion+ , lens+ , optics+ , unordered-containers+ , vector++ type: exitcode-stdio-1.0+ main-is: folds.hs++-- Benchmarking traversals+benchmark traversals+ default-language: Haskell2010+ hs-source-dirs: benchmarks+ ghc-options: -Wall -threaded++ build-depends: base+ , bytestring+ , containers+ , criterion+ , lens+ , optics+ , transformers+ , unordered-containers+ , vector++ type: exitcode-stdio-1.0+ main-is: traversals.hs
+ src/Optics.hs view
@@ -0,0 +1,856 @@+-- |+--+-- Module: Optics+-- Description: The main module, usually you only need to import this one.+--+-- This library makes it possible to define and use 'Lens'es, 'Traversal's,+-- 'Prism's and other /optics/, using an /abstract interface/.+--+module Optics+ (+ -- * Introduction+ -- $introduction++ -- ** What are optics?+ -- $what++ -- ** What is the abstract interface?+ -- $abstract++ -- ** Comparison with @lens@+ -- $lens_comparison++ -- ** Other resources+ -- $otherresources++ -- * Using the library+ -- $basicusage+ module Optics.Optic++ -- ** Optic kinds #optickinds#+ , module O++ -- ** Optic operators+ , module Optics.Operators++ -- * Optics utilities++ -- ** At++ -- | 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]+ --+ , module Optics.At++ -- ** Cons++ -- | 'Prism's to match on the left or right side of a list, vector or other+ -- sequential structure:+ --+ -- >>> preview _Cons "abc"+ -- Just ('a',"bc")+ --+ -- >>> preview _Snoc "abc"+ -- Just ("ab",'c')+ --+ , module Optics.Cons++ -- ** Each++ -- | An 'IxTraversal' for each element of a (potentially monomorphic) container.+ --+ -- >>> over each (*10) (1,2,3)+ -- (10,20,30)+ --+ , module Optics.Each++ -- ** Empty++ -- | A 'Prism' for a container type that may be empty.+ --+ -- >>> isn't _Empty [1,2,3]+ -- True+ --+ , module Optics.Empty++ -- ** Re++ -- | Some optics can be reversed with 're'. This is mainly useful to invert+ -- 'Iso's:+ --+ -- >>> let _Identity = iso runIdentity Identity+ -- >>> view (_1 % re _Identity) ('x', "yz")+ -- Identity 'x'+ --+ -- Yet we can use a 'Lens' as a 'Review' too:+ --+ -- >>> review (re _1) ('x', "yz")+ -- 'x'+ --+ -- In the following diagram, red arrows illustrate how 're' transforms optics.+ -- The 'ReversedLens' and 'ReversedPrism' optic kinds are backwards versions+ -- of 'Lens' and 'Prism' respectively, and are present so that @'re' . 're'@+ -- does not change the optic kind.+ --+ -- <<diagrams/reoptics.png Reversed Optics>>+ --+ , module Optics.Re++ -- ** ReadOnly++ -- | Defines 'getting', which turns a read-write optic into its read-only+ -- counterpart.+ , module Optics.ReadOnly++ -- ** 'Setter' utilities for working in 'Control.Monad.State.MonadState'.+ , module Optics.State++ -- ** View++ -- | A generalized view function 'gview', which returns a single result (like+ -- 'view') if the optic is a 'Getter', a 'Maybe' result (like 'preview') if+ -- the optic is an 'AffineFold', or a monoidal summary of results (like+ -- 'foldOf') if the optic is a 'Fold'. In addition, it works for any+ -- 'Control.Monad.Reader.MonadReader', not just @(->)@.+ --+ -- >>> gview _1 ('x','y')+ -- 'x'+ --+ -- >>> gview _Left (Left 'x')+ -- Just 'x'+ --+ -- >>> gview folded ["a", "b"]+ -- "ab"+ --+ -- >>> runReaderT (gview _1) ('x','y') :: IO Char+ -- 'x'+ --+ -- This module is experimental. Using the more type-restricted variants is+ -- encouraged where possible.+ --+ , module Optics.View++ -- ** Zoom++ -- | A class to 'zoom' in, changing the 'Control.Monad.State.State' supplied+ -- by many different monad transformers, potentially quite deep in a monad+ -- transformer stack.+ --+ -- >>> flip execState ('a','b') $ zoom _1 $ equality .= 'c'+ -- ('c','b')+ --+ , module Optics.Zoom++ -- * Indexed optics+ -- $indexed+ , module Optics.Indexed++ -- * Generation of optics+ -- ** ...with Template Haskell+ , module Optics.TH+ -- ** ...with @OverloadedLabels@+ , module Optics.Label++ -- * Optics for concrete base types+ , module P+ )+ where++-- Core optics functionality++-- for some reason haddock reverses the list...++import Optics.Optic++import Optics.Traversal as O+import Optics.Setter as O+import Optics.Review as O+import Optics.ReversedPrism as O+import Optics.Prism as O+import Optics.ReversedLens as O+import Optics.Lens as O+import Optics.IxTraversal as O+import Optics.IxSetter as O+import Optics.IxFold as O+import Optics.IxAffineTraversal as O+import Optics.IxAffineFold as O+import Optics.IxGetter as O+import Optics.IxLens as O+import Optics.Iso as O+import Optics.Getter as O+import Optics.Fold as O+import Optics.AffineTraversal as O+import Optics.AffineFold as O++-- Optics utilities+import Optics.At+import Optics.Cons+import Optics.Each+import Optics.Empty+import Optics.Indexed+import Optics.Operators+import Optics.Re+import Optics.ReadOnly+import Optics.State+import Optics.View+import Optics.Zoom++-- Overloaded labels support+import Optics.Label++-- Template Haskell support+import Optics.TH++-- Optics for concrete base types++import Data.Tuple.Optics as P+import Data.Maybe.Optics as P+import Data.Either.Optics as P++-- $introduction+--+-- Read on for a general introduction to the notion of optics, or if you are+-- familiar with them already, you may wish to jump ahead to the "What is the+-- abstract interface?" section below in "Optics#abstract".++-- $what+--+-- An optic is a first-class, composable /notion of substructure/. As a highly+-- abstract concept, the idea can be approached by considering several examples+-- of optics and understanding their common features. What are the possible+-- relationships between some "outer" type @S@ and some "inner" type @A@?+--+-- (For simplicity we will initially ignore the possibility of type-changing+-- update operations, which change @A@ to some other type @B@ and hence change+-- @S@ to some other type @T@. These are fully supported by the library, at the+-- cost of some extra type parameters.)+--+-- === "Optics.Iso": isomorphisms+--+-- First, @S@ and @A@ may be /isomorphic/, i.e. there exist mutually inverse+-- functions to convert @S -> A@ and @A -> S@. This is a somewhat trivial+-- notion of substructure: @A@ is just another way to represent "all of @S@".+--+-- An @'Iso'' S A@ is an isomorphism between @S@ and @A@, with the conversion+-- functions given by 'view' and 'review'. For example, given+--+-- @+-- newtype Age = Age Int+-- @+--+-- there is an isomorphism between the newtype and its representation:+--+-- @+-- 'coerced' :: 'Iso'' Age 'Int'+-- 'view' 'coerced' :: Age -> 'Int'+-- 'review' 'coerced' :: 'Int' -> Age+-- @+--+-- === "Optics.Lens": generalised fields+--+-- If @S@ is a simple product type (i.e. it has a single constructor with one or+-- more fields), @A@ may be a single field of @S@. More generally, @A@ may be+-- "part of @S@" in the sense that @S@ is isomorphic to the pair @(A,C)@ for+-- some type @C@ representing the other fields. In this case, there is a+-- /projection/ function @S -> A@ for getting the value of the field, but the+-- /update/ function (setting the value of the field) requires the "rest of @S@"+-- and so has type @A -> S -> S@.+--+-- A @'Lens'' S A@ captures the structure of @A@ being a field of @S@, with the+-- projection function given by 'view' and the update function by 'set'. For+-- example, for the pair type @(X,Y)@ there are lenses for each component:+--+-- @+-- '_1' :: 'Lens'' (X,Y) X+-- '_2' :: 'Lens'' (X,Y) Y+-- 'view' '_1' :: (X,Y) -> X+-- 'set' '_2' :: Y -> (X,Y) -> (X,Y)+-- @+--+-- (Note that the update function could arguably have the more precise type @A+-- -> C -> S@, since we do not expect the result of setting a field to depend on+-- the previous value of the field. However, making @C@ explicit turns out to+-- be awkward, so instead we impose /laws/ to require that the result of setting+-- the field depends only on @C@, and, more generally, that the lens behaves as+-- we would expect.)+--+-- === "Optics.Prism": generalised constructors+--+-- If @S@ is a simple sum type (i.e. it has one or more constructors, each with+-- a single field), @A@ may be the type of the field for a single constructor of+-- @S@. More generally, @S@ may be isomorphic to the disjoint union @Either D+-- A@ for some type @D@ representing the other constructors. In this case,+-- projecting out @A@ from @S@ (pattern-matching on the constructor) may fail,+-- so it has type @S -> Maybe A@. In the reverse direction we have a function+-- of type @A -> S@ representing the constructor itself.+--+-- A @'Prism'' S A@ captures the structure of @A@ being a constructor of @S@,+-- with the partial projection function given by 'preview' and the constructor+-- function given by 'review'. For example, for the type @'Either' X Y@ there+-- is a prism for each constructor:+--+-- @+-- '_Left' :: 'Prism'' ('Either' X Y) X+-- '_Right' :: 'Prism'' ('Either' X Y) Y+-- 'preview' '_Left' :: 'Either' X Y -> 'Maybe' X+-- 'review' '_Right' :: Y -> 'Either' X Y+-- @+--+-- === "Optics.Traversal": multiple substructures+--+-- Alternatively, @S@ may "contain" the substructure @A@ a variable number of+-- times. In this case, the projection function extracts the (possibly zero or+-- many) elements so has type @S -> [A]@, while the update function may take+-- different values for different elements so has type @(A -> A) -> S -> S@+-- (though in fact more general formulations are possible).+--+-- A @'Traversal'' S A@ captures the structure of @A@ being contained in @S@+-- perhaps multiple times, with the list of values given by 'toListOf' and the+-- update function given by 'over' . For example, for the type @Maybe X@ there+-- is a traversal that may return zero or one element:+--+-- @+-- 'traversed' :: 'Traversal'' ('Maybe' X) X+-- 'toListOf' 'traversed' :: 'Maybe' X -> [X]+-- 'over' 'traversed' :: (X -> X) -> 'Maybe' X -> 'Maybe' X+-- @+--+-- (In fact, traversals of at most one element are known as /affine/ traversals,+-- see "Optics.AffineTraversal".)+--+--+-- === In general+--+-- So far we have seen four different kinds of optic or "notions of+-- substructure", and many more are possible. Observe the important properties+-- they have in common:+--+-- * There are subtyping relationships between different optic kinds. Any+-- isomorphism is trivially a lens and a prism (with no other fields or+-- constructors, respectively). Any lens is a traversal (where the list of+-- elements is always a singleton list), and any prism is also a traversal+-- (where there will be zero or one element depending on whether the+-- constructor matches). This was implicit in the fact that we used that we+-- used the same operators in multiple cases: 'view' gives the projection+-- function of both an isomorphism and a lens, but cannot be applied to a+-- traversal.+--+-- * Optics can be composed. If @S@ is isomorphic to @U@ and @U@ is isomorphic+-- to @A@ then @S@ is isomorphic to @A@, and similarly for other optic kinds.+--+-- * Composition and subtyping interact: a lens and a prism can be composed, by+-- first thinking of them as traverals using the subtyping relationship. That+-- is, if @S@ has a field @U@, and @U@ has a constructor @A@, then @S@+-- contains zero or one @A@s that we can pick out with a traversal (but in+-- general there is neither a lens from @S@ to @A@ nor a prism).+--+-- * Each optic kind can be described by certain operations it enables. For+-- example lenses support projection and update, while prisms support partial+-- projection and construction.+--+-- * Optics are subject to laws, which are necessary for the operations to make+-- sense.+--+-- The point of the @optics@ library is to capture this common pattern.+++-- $abstract #abstract#+--+-- A key principle behind this library is the belief that optics are useful as+-- an abstract concept, and that the purpose of types is to capture abstract+-- concepts and make them useful. The programmer using optics should be able to+-- think in terms of the abstract interface, rather than the details of the+-- implementation, and implementation choices should (as far as possible) not+-- dictate the interface.+--+-- 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 'Lens') is obtained+-- by applying the 'Optic' newtype wrapper to the tag type.+--+-- @+-- type 'Lens' s t a b = 'Optic' 'A_Lens' 'NoIx' s t a b+-- type 'Lens'' s a = 'Optic'' 'A_Lens' 'NoIx' s a+-- @+--+-- 'NoIx' as the second parameter to 'Optic' indicates that the optic is not+-- indexed. See the "Indexed optics" section below in "Optics#indexed" for+-- further discussion of indexed optics.+--+-- The details of the internal implementation of 'Optic' are hidden behind an+-- abstraction boundary, so that the library can be used without needing to+-- think about the particular implementation choices.+--+--+-- === Specification of optics interfaces+--+-- Each different kind of optic is documented in a separate module describing+-- its abstract interface, in a standard format with at least /formation/,+-- /introduction/, /elimination/, and /well-formedness/ sections. See "Optic+-- kinds" below in "Optics#optickinds" for a list of these modules.+--+-- * The __formation__ sections contain type definitions. For example+-- "Optics.Lens" defines:+--+-- @+-- -- Type synonym for a type-modifying lens.+-- type 'Lens' s t a b = 'Optic' 'A_Lens' 'NoIx' s t a b+-- @+--+-- * The __introduction__ sections describe the canonical way to construct each+-- particular optic. Continuing with a 'Lens' example:+--+-- @+-- -- Build a lens from a getter and a setter.+-- 'lens' :: (s -> a) -> (s -> b -> t) :: 'Lens' s t a b+-- @+--+-- * Correspondingly, the __elimination__ sections show how you can destruct the+-- optic into the pieces from which it was constructed.+--+-- @+-- -- A 'Lens' is a 'Setter' and a 'Getter', therefore you can specialise types to obtain+-- 'view' :: 'Lens' s t a b -> s -> a+-- 'set' :: 'Lens' s t a b -> b -> s -> t+-- @+--+-- * The __computation__ rules tie introduction and elimination forms+-- together. These rules are automatically fulfilled by the library (for+-- well-formed optics).+--+-- @+-- 'view' ('lens' f g) s ≡ f s+-- 'set' ('lens' f g) a s ≡ g s a+-- @+--+-- * The __well-formedness__ sections describe the laws that each optic should+-- obey. As far as possible, all optics provided by the library are+-- well-formed, but in some cases this depends on invariants that cannot be+-- expressed in types. Ill-formed optics /might/ behave differently from what+-- the computation rules specify.+--+-- For example, a 'Lens' should obey three laws, known as /GetPut/, /PutGet/+-- and /PutPut/. See the "Optics.Lens" module for their definitions. The+-- user of the 'lens' introduction form must ensure that these laws are+-- satisfied.+--+-- * Some optic kinds have __additional introduction forms__,+-- __additional elimination forms__ or __combinators__ sections, which give+-- alternative ways to create and use optics of that kind. In principle these+-- are expressible in terms of the canonical introduction and elimination+-- rules.+--+-- * The __subtyping__ section gives the "tag type" (such as 'A_Lens'), which in+-- particular is accompanied by 'Is' instances that define the subtyping+-- relationship discussed in the following section.+--+--+-- === Subtyping+--+-- There is a subtyping relationship between optics, implemented using+-- typeclasses. The 'Is' typeclass captures the property that one optic kind+-- can be used as another, and the 'castOptic' function can be used to+-- explicitly cast between optic kinds. 'Is' forms a partial order, represented+-- in the graph below. For example, a lens can be used as a traversal, so there+-- are arrows from 'Lens' to 'Traversal' (via 'AffineTraversal') and there is an+-- instance of @'Is' 'A_Lens' 'A_Traversal'@.+--+-- Introduction forms (constructors) return a concrete optic kind, while+-- elimination forms (destructors) are generally polymorphic in the optic kind+-- they accept. This means that it is not normally necessary to explicitly cast+-- between optic kinds. For example, we have+--+-- @+-- 'view' :: 'Is' k 'A_Getter' => 'Optic'' k is s a -> s -> a+-- @+--+-- so 'view' can be used with isomorphisms or lenses, as these can be converted+-- to a 'Getter'.+--+-- If an explicit cast is needed, you can use 'castOptic'. This arises when you+-- use optics of different kinds in a context that requires them to have the+-- same type. For example @['folded', 'traversed']@ gives a type error (since+-- 'A_Traversal' is not 'A_Fold') but @['folded', 'castOptic' 'traversed']@+-- works.+--+-- The optic kind module (e.g. "Optics.Lens") does not list all ways to+-- construct or use particular the optic kind. For example, since a 'Lens' is+-- also a 'Traversal', a 'Fold' etc, so you can use 'traverseOf', 'preview' and+-- many other combinators with lenses.+--+--+-- ==== Subtype hierarchy+--+-- This graph gives an overview of the optic kinds and their subtype+-- relationships:+--+-- <<diagrams/optics.png Optics hierarchy>>+--+-- In addition to the optic kinds included in the diagram, there are also+-- indexed variants such as 'IxLens', 'IxGetter', 'IxAffineTraversal',+-- 'IxTraversal', 'IxAffineFold', 'IxFold' and 'IxSetter'. These are explained+-- in more detail in the "Indexed optics" section below in "Optics#indexed".+--+--+-- === Composition+--+-- Since /optics are not functions/, they cannot be composed with the ('.')+-- operator. Instead there is a separate composition operator ('%'). The+-- composition operator returns the common supertype of its arguments, or+-- generates a type error if the composition does not make sense.+--+-- The optic kind resulting from a composition is the least upper bound (join)+-- of the optic kinds being composed, if it exists. The 'Join' type family+-- computes the least upper bound given two optic kind tags. For example the+-- 'Join' of a 'Lens' and a 'Prism' is an 'AffineTraversal'.+--+-- >>> :kind! Join A_Lens A_Prism+-- Join A_Lens A_Prism :: *+-- = An_AffineTraversal+--+-- The join does not exist for some pairs of optic kinds, which means that they+-- cannot be composed. For example there is no optic kind above both 'Setter'+-- and 'Fold':+--+-- >>> :kind! Join A_Setter A_Fold+-- Join A_Setter A_Fold :: *+-- = (TypeError ...)+--+-- >>> :t mapped % folded+-- ...+-- ...A_Setter cannot be composed with A_Fold+-- ...++-- $lens_comparison+--+-- The @lens@ package is the best known Haskell library for optics, and+-- established many of the foundations on which the @optics@ package builds (not+-- least in quite a bit of code having been directly ported). It defines optics+-- based on the /van Laarhoven/ representation, where each optic kind is+-- introduced as a /transparent/ type synonym for a complex polymorphic type,+-- for example:+--+-- @+-- type Lens s t a b = forall f. 'Functor' f => (a -> f b) -> s -> f t+-- @+--+-- In contrast, @optics@ tries to preserve an abstraction boundary between the+-- interface of optics and their implementation. Optic kinds are expressed+-- directly in the types, as 'Optic' is an /opaque/ newtype:+--+-- @+-- type 'Lens' s t a b = 'Optic' 'A_Lens' 'NoIx' s t a b+-- @+--+-- The choice of representation of 'Optic' is then an implementation detail, not+-- essential for understanding the library. (In fact, @optics@ uses the+-- /profunctor/ representation rather than the /van Laarhoven/ representation;+-- this affects the optic kinds and operations that can be conveniently+-- supported, but not the essence of the design.)+--+-- Our design choice to use /opaque/ rather than /transparent/ abstractions+-- leads to various consequences, both positive and negative, which are explored+-- in the following subsections.+--+-- == Advantages of the opaque design+--+-- Since the interface is deliberately chosen rather than to some extent+-- determined by the implementation, we are free to choose a more restricted+-- interface where doing so leads to conceptual simplicity. For example, in+-- @lens@, the 'view' function can be used with a 'Fold' provided the result+-- type has a 'Monoid' instance, and the multiple targets of the 'Fold' will be+-- combined monoidally. This behaviour can be confusing, so in @optics@ a+-- 'Fold' cannot be silently used as a 'Getter', and we prefer to have 'view'+-- work on 'Getter's and define a separate 'foldOf' operator for use on+-- 'Fold's. (But the 'gview' function is available for users who may prefer+-- otherwise.)+--+-- In general, opaque abstractions lead to better results from type inference+-- (the optic kind is preserved in the inferred type):+--+-- >>> :t traversed % to not+-- traversed % to not+-- :: Traversable t => Optic A_Fold '[] (t Bool) (t Bool) Bool Bool+--+-- Error messages are domain-specific:+--+-- >>> set (to fst)+-- ...+-- ...A_Getter cannot be used as A_Setter+-- ...+--+-- Composing incompatible optics yields a sensible error:+--+-- >>> sets map % to not+-- ...+-- ...A_Setter cannot be composed with A_Getter+-- ...+--+-- Since 'Optic' is a rank-1 type, it is easy to store optics in a+-- datastructure:+--+-- >>> :t [folded, backwards_ folded]+-- [folded, backwards_ folded] :: Foldable f => [Fold (f a) a]+--+-- It is possible to define aliases for optics without the monomorphism+-- restriction spoiling the fun:+--+-- >>> let { myoptic = _1; p = ('x','y') } in (view myoptic p, set myoptic 'c' p)+-- ('x',('c','y'))+--+-- Finally, having an abstract interface gives more freedom of choice in the+-- internal implementation. If there is a compelling reason to switch to an+-- alternative representation, one can in principle do so without changing the+-- interface.+--+--+-- == Disadvantages of the opaque design+--+-- Since 'Optic' is a newtype, other libraries that wish to define optics must+-- depend upon its definition. In contrast, with a transparent representation,+-- and since the van Laarhoven representations of lenses and traversals depend+-- only on definitions from @base@, it is possible for libraries to define them+-- without any extra library dependencies (although this does not hold for more+-- advanced optic kinds such as prisms or indexed optics). To address this, the+-- present library is split into a package @optics-core@, which has a minimal+-- dependency footprint intended for use in libraries, and the+-- \"batteries-included\" @optics@ package for use in applications.+--+-- It is something of an amazing fact that the composition operator for+-- transparent optics is just function composition. Moreover, since Haskell+-- uses ('.') for function composition, @lens@ is able to support a pseudo-OOP+-- syntax. In contrast, @optics@ must use a different composition operator+-- ('%'). 'Optic' does not quite form a 'Control.Category.Category', thanks to+-- type-changing optics.+--+-- Rather than emerging naturally from the definitions, opportunities for+-- polymorphism have to be identified in advance and explicitly introduced using+-- type classes. Similarly, the set of optic kinds and the subtyping+-- relationships between them must be fixed in advance, and cannot be added to+-- in downstream libraries. Thus in a sense the opaque approach is more+-- restrictive than the transparent one. There are cases in @lens@ where the+-- types work out nicely and permit abstraction-breaking-but-convenient+-- shortcuts, such as applying a 'Traversal' as a 'traverse'-like function,+-- whereas @optics@ requires a call to 'traverseOf'.+--+--+-- == More specific differences+--+-- The sections above set out the major conceptual differences from the @lens@+-- package, and their advantages and disadvantages. Some more specific design+-- differences, which may be useful for comparison or porting code between the+-- libraries. This list is no doubt incomplete.+--+-- * The composition operator is ('%') rather than ('.') and is defined as+-- @infixl 9@ instead of @infixr 9@.+--+-- * Fewer operators are provided, and some of them are not exported from the+-- main "Optics" module. Import "Optics.State.Operators" if you want them.+--+-- * The 'view' function and corresponding ('Optics.Operators.^.') operator work+-- only for 'Getter's and have a more restricted type. The equivalent for+-- 'Fold's is 'foldOf', and you can use 'preview' for+-- 'AffineFold's. Alternatively you can use 'gview' which is more compatible+-- with @view@ from @lens@, but it uses a type class to choose between 'view',+-- 'preview' and 'foldOf'.+--+-- * Indexed optics are rather different, as described in the "Indexed optics"+-- section below in "Optics#indexed". All ordinary optics are+-- "index-preserving", so there is no separate notion of an index-preserving+-- optic.+--+-- * 'Each' provides indexed traversals.+--+-- * @firstOf@ from @lens@ is replaced by 'headOf'.+--+-- * @concatOf@ from @lens@ is omitted in favour of the more general 'foldOf'.+--+-- * 'set'' is a strict version of 'set', not 'set' for type-preserving optics.+--+-- * Numbered lenses for accessing fields of tuples positionally are provided+-- only up to '_9', rather than @_19@.+--+-- * There are four variants of @backwards@ for (indexed) 'Traversal's and+-- 'Fold's: 'backwards', 'backwards_', 'ibackwards' and 'ibackwards_'.+--+-- * There is no @Traversal1@ and @Fold1@.+--+-- * There are affine variants of (indexed) traversals and folds+-- ('AffineTraversal', 'AffineFold', 'IxAffineTraversal' and 'IxAffineFold').+-- An affine optic targets at most one value. Composing a 'Lens' with a+-- 'Prism' produces an 'AffineTraversal', so for example @'matching' ('_1' '%'+-- '_Left')@ is well-typed.+--+-- * Functions 'ifiltered' and 'indices' are defined as optic combinators due to+-- restrictions of internal representation.+--+-- * We can't use 'traverse' as an optic directly. Instead there is a+-- 'Traversal' called 'traversed'. Similarly 'traverseOf' must be used to+-- apply a 'Traversal', rather than simply using it as a function.+--+-- * The 're' combinator produces a different optic kind depending on the kind+-- of the input 'Iso', for example 'Review' reverses to 'Getter' while a+-- reversed 'Iso' is still an 'Iso'. Thus there is no separate @from@+-- combinator for reversing 'Iso's.+++-- $otherresources+--+-- * <https://skillsmatter.com/skillscasts/10692-through-a-glass-abstractly-lenses-and-the-power-of-abstraction Through a Glass, Abstractly: Lenses and the Power of Abstraction> a talk on the principles behind this library with <https://github.com/well-typed/optics/raw/master/Talk.pdf accompanying slides> by Adam Gundry (but note that the design details of @optics@ have changed substantially since this talk was given)+--+-- * <https://skillsmatter.com/skillscasts/12360-profunctors-and-data-accessors Profunctors and Data Accessors> a talk on basics of profunctors and how they relate to data accessors such as lenses, prisms and traversals by Andrzej Rybczak+--+-- * <https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf Profunctor Optics: Modular Data Accessors> a paper by Matthew Pickering, Jeremy Gibbons and Nicolas Wu+--+-- * <https://oleg.fi/gists/posts/2017-04-18-glassery.html Glassery> and <https://oleg.fi/gists/posts/2017-04-26-indexed-poptics.html Indexed Profunctor optics>, blog posts by Oleg Grenrus+--+-- * The <https://hackage.haskell.org/package/lens lens> package by Edward Kmett and contributors+++-- $basicusage+--+-- To get started, you can just add @optics@ as a dependency to your @.cabal@+-- file, and then:+--+-- @+-- import "Optics"+-- @+--+-- If you are writing a library for which it is important to keep the dependency+-- footprint minimal, you may wish to depend upon @optics-core@ instead (and+-- perhaps @optics-extra@ or @optics-th@), and then:+--+-- @+-- import "Optics.Core"+-- @++-- $indexed #indexed#+--+-- The @optics@ library also provides indexed optics, which provide+-- an additional /index/ value in mappings:+--+-- @+-- 'over' :: 'Setter' s t a b -> (a -> b) -> s -> t+-- 'iover' :: 'IxSetter' i s t a b -> (i -> a -> b) -> s -> t+-- @+--+-- Note that there aren't any laws about indices.+-- Especially in compositions the same index may occur multiple times.+--+-- The machinery builds on indexed variants of 'Functor', 'Foldable', and 'Traversable' classes:+-- 'FunctorWithIndex', 'FoldableWithIndex' and 'TraversableWithIndex' respectively.+-- There are instances for types in the boot libraries.+--+-- @+-- class ('FoldableWithIndex' i t, 'Traversable' t)+-- => 'TraversableWithIndex' i t | t -> i where+-- 'itraverse' :: 'Applicative' f => (i -> a -> f b) -> t a -> f (t b)+-- @+--+-- Indexed optics /can/ be used as regular ones, i.e. indexed optics+-- gracefully downgrade to regular ones.+--+-- >>> toListOf ifolded "foo"+-- "foo"+--+-- >>> itoListOf ifolded "foo"+-- [(0,'f'),(1,'o'),(2,'o')]+--+-- But there is also a combinator 'noIx' to explicitly erase indices:+--+-- >>> :t (ifolded % simple)+-- (ifolded % simple)+-- :: FoldableWithIndex i f => Optic A_Fold '[i] (f b) (f b) b b+--+-- >>> :t noIx (ifolded % simple)+-- noIx (ifolded % simple)+-- :: FoldableWithIndex i f => Optic A_Fold NoIx (f b) (f b) b b+--+-- @+-- λ> :t noIx (ifolded % ifolded)+-- noIx (ifolded % ifolded)+-- :: (FoldableWithIndex i1 f1, FoldableWithIndex i2 f2) =>+-- Optic A_Fold NoIx (f1 (f2 b)) (f1 (f2 b)) b b+-- @+--+-- As the example above illustrates, regular and indexed optics have the same+-- tag in the first parameter of 'Optic', in this case 'A_Fold'. Regular optics+-- simply don't have any indices. The provided type aliases 'IxLens',+-- 'IxGetter', 'IxAffineTraversal', 'IxAffineFold', 'IxTraversal', 'IxFold' and+-- 'IxSetter' are variants with a single index. In general, the second parameter+-- of the 'Optic' newtype is a type-level list of indices, which will typically+-- be 'NoIx' (the empty index list) or @('WithIx' i)@ (a singleton list).+--+-- When two optics are composed with ('%'), the index lists are concatenated.+-- Thus composing an unindexed optic with an indexed optic preserves the+-- indices, or composing two indexed optics retains both indices:+--+-- @+-- λ> :t (ifolded % ifolded)+-- (ifolded % ifolded)+-- :: (FoldableWithIndex i1 f1, FoldableWithIndex i2 f2) =>+-- Optic A_Fold '[i1, i2] (f1 (f2 b)) (f1 (f2 b)) b b+-- @+--+-- In order to use such an optic, it is necessary to flatten the indices into a+-- single index using 'icompose' or a similar function:+--+-- @+-- λ> :t icompose (,) (ifolded % ifolded)+-- icompose (,) (ifolded % ifolded)+-- :: (FoldableWithIndex i1 f1, FoldableWithIndex i2 f2) =>+-- Optic A_Fold (WithIx (i1, i2)) (f1 (f2 b)) (f1 (f2 b)) b b+-- @+--+-- For example:+--+-- >>> itoListOf (icompose (,) (ifolded % ifolded)) [['a','b'], ['c', 'd']]+-- [((0,0),'a'),((0,1),'b'),((1,0),'c'),((1,1),'d')]+--+-- Alternatively, you can use one of the ('<%') or ('%>') operators to compose+-- indexed optics and pick the index to retain, or the ('<%>') operator to+-- retain a pair of indices:+--+-- >>> itoListOf (ifolded <% ifolded) [['a','b'], ['c', 'd']]+-- [(0,'a'),(0,'b'),(1,'c'),(1,'d')]+--+-- >>> itoListOf (ifolded %> ifolded) [['a','b'], ['c', 'd']]+-- [(0,'a'),(1,'b'),(0,'c'),(1,'d')]+--+-- >>> itoListOf (ifolded <%> ifolded) [['a','b'], ['c', 'd']]+-- [((0,0),'a'),((0,1),'b'),((1,0),'c'),((1,1),'d')]+--+-- In the diagram below, the optics hierachy is amended with these (singly) indexed variants (in blue).+-- Orange arrows mean+-- "can be used as one, assuming it's composed with any optic below the+-- orange arrow first". For example. '_1' is not an indexed fold, but+-- @'itraversed' % '_1'@ is, because it's an indexed traversal, so it's+-- also an indexed fold.+--+-- >>> let fst' = _1 :: Lens (a, c) (b, c) a b+-- >>> :t fst' % itraversed+-- fst' % itraversed+-- :: TraversableWithIndex i f =>+-- Optic A_Traversal '[i] (f a, c) (f b, c) a b+--+-- <<diagrams/indexedoptics.png Indexed Optics>>++-- $setup+-- >>> import Control.Monad.Reader+-- >>> import Control.Monad.State+-- >>> import Data.Functor.Identity+-- >>> import qualified Data.IntSet as IntSet+-- >>> import qualified Data.Map as Map+-- >>> import Optics.State.Operators
+ tests/Optics/Tests.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Main (main) where++import Test.Tasty++import Optics+import Optics.Tests.Computation+import Optics.Tests.Core+import Optics.Tests.Eta+import Optics.Tests.Labels+import Optics.Tests.Misc++-- | Composing a lens and a traversal yields a traversal+_comp1 :: Traversable t => Optic A_Traversal NoIx (t a, y) (t b, y) a b+_comp1 = _1 % traversed++-- | Composing two lenses yields a lens+_comp2 :: Optic A_Lens NoIx ((a, y), y1) ((b, y), y1) a b+_comp2 = _1 % _1++-- | Composing a getter and a lens yields a getter+_comp3 :: Optic A_Getter NoIx ((b, y), b1) ((b, y), b1) b b+_comp3 = to fst % _1++-- | Composing a prism and a lens yields a traversal+_comp4 :: Optic An_AffineTraversal NoIx (Either c (a, y)) (Either c (b, y)) a b+_comp4 = _Right % _1++-- | An iso can be used as a getter+_eg1 :: Int+_eg1 = view (iso (+ 1) (\ x -> x - 1)) 5++-- | A lens can be used as a getter+_eg2 :: (a, b) -> a+_eg2 = view _1++-- These don't typecheck, as one would expect:+-- to fst % mapped -- Cannot compose a getter with a setter+-- toLens (to fst) -- Cannot use a getter as a lens++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ testGroup "Inspection"+ [ coreTests+ , etaTests+ , labelsTests+ , miscTests+ ]+ , computationTests+ ]
+ tests/Optics/Tests/Computation.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Optics.Tests.Computation (computationTests) where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Inspection++import Optics+import Optics.Tests.Utils++computationTests :: TestTree+computationTests = testGroup "computation"+ [ testGroup "Lens"+ [ testCase "view (lens f g) = f" $+ assertSuccess $(inspectTest $ 'lens1lhs === 'lens1rhs)+ , testCase "set (lens f g) = g" $+ assertSuccess $(inspectTest $ 'lens2lhs === 'lens2rhs)+ ]+ , testGroup "AffineTraversal"+ -- this doesn't hold definitionally: we need law here+ [ testCase "withAffineTraversal (atraversal f g) (\\ _ g' -> g') /= g" $+ assertFailure' $(inspectTest $ 'atraversal1lhs === 'atraversal1rhs)+ , testCase "withAffineTraversal (atraversal f g) (\\ _ g' -> g') = ..." $+ assertSuccess $(inspectTest $ 'atraversal1lhs === 'atraversal1rhs_)+ , testCase "withAffineTraversal (atraversal f g) (\\ f' _ -> f') = f" $+ assertSuccess $(inspectTest $ 'atraversal2lhs === 'atraversal2rhs)+ ]+ , testGroup "AffineFold"+ [ testCase "preview (afolding f) = f" $+ assertSuccess $(inspectTest $ 'afold1lhs === 'afold1rhs)+ ]+ , testGroup "Setter"+ [ testCase "over (sets f) = f" $+ assertSuccess $(inspectTest $ 'setter1lhs === 'setter1rhs)+ ]+ ]++lens1lhs, lens1rhs :: (s -> a) -> (s -> a -> s) -> (s -> a)+lens1lhs f g s = view (lens f g) s+lens1rhs f _ s = f s++lens2lhs, lens2rhs :: (s -> a) -> (s -> b -> t) -> (s -> b -> t)+lens2lhs f g s b = set (lens f g) b s+lens2rhs _ g s b = g s b++atraversal1lhs, atraversal1rhs, atraversal1rhs_+ :: (s -> Either t a) -> (s -> b -> t) -> (s -> b -> t)+atraversal1lhs f g s b = withAffineTraversal (atraversal f g) (\_ g' -> g') s b+atraversal1rhs _ g s b = g s b+atraversal1rhs_ f g s b = either id (\_ -> g s b) (f s)++atraversal2lhs, atraversal2rhs+ :: (s -> Either t a) -> (s -> b -> t) -> (s -> Either t a)+atraversal2lhs f g s = withAffineTraversal (atraversal f g) (\f' _ -> f') s+atraversal2rhs f _ s = f s++afold1lhs, afold1rhs :: (s -> Maybe a) -> s -> Maybe a+afold1lhs sma s = preview (afolding sma) s+afold1rhs sma s = sma s++setter1lhs, setter1rhs :: ((a -> b) -> s -> t) -> ((a -> b) -> s -> t)+setter1lhs f ab s = over (sets f) ab s+setter1rhs f ab s = f ab s
+ tests/Optics/Tests/Core.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Optics.Tests.Core (coreTests) where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Inspection++import Optics+import Optics.Tests.Utils++coreTests :: TestTree+coreTests = testGroup "Core"+ [ testCase "traverseOf traversed = traverse" $+ assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)+ , testCase "optimized lhs01a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs01a)+ , testCase "traverseOf (traversed % traversed) = traverse . traverse" $+ assertSuccess $(inspectTest $ 'lhs02 === 'rhs02)+ , testCase "optimized lhs02a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs02a)+ , testCase "traverseOf (traversed % traversed) = traverseOf (itraversed % itraversed)" $+ assertSuccess $(inspectTest $ 'lhs03 === 'rhs03)+ , testCase "optimized lhs03" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs03)+ , testCase "optimized rhs03" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs03)+ , testCase "traverseOf_ (folded % folded) = traverseOf_ (ifolded % ifolded)" $+ assertSuccess $(inspectTest $ 'lhs04 === 'rhs04)+ , testCase "optimized lhs04" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs04)+ , testCase "optimized rhs04" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs04)+ , testCase "over (noIx (imapped % imapped)) = over (mapped % mapped)" $+ assertSuccess $(inspectTest $ 'lhs05 === 'rhs05)+ , testCase "over (imapped % imapped) = over (mapped % mapped)" $+ assertSuccess $(inspectTest $ 'lhs05b === 'rhs05)+ , testCase "optimized lhs05" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs05)+ , testCase "optimized rhs05" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs05)+ , testCase "traverseOf_ (_Left % itraversed % _1 % ifolded) = traverseOf_ ..." $+ -- GHC >= 8.6 gives different order of let bindings+ ghcGE86failure $(inspectTest $ 'lhs06 === 'rhs06)+ , testCase "optimized lhs06" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs06)+ , testCase "optimized rhs06" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs06)+ , testCase "itraverseOf (itraversed %> itraversed) = itraverseOf (traversed % itraversed)" $+ assertSuccess $(inspectTest $ 'lhs07 === 'rhs07)+ , testCase "optimized lhs07a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs07a)+ , testCase "optimized rhs07a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs07a)+ , testCase "itraverseOf_ (ifolded %> ifolded) ==- itraverseOf (folded % ifolded)" $+ -- Same code modulo coercions.+ assertSuccess $(inspectTest $ 'lhs08 ==- 'rhs08)+ , testCase "optimized lhs08a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs08a)+ , testCase "optimized rhs08a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs08a)+ , testCase "iover (imapped <% imapped) = iover (imapped % mapped)" $+ -- Code is the same on GHC 8.0.2 modulo names of parameters.+ ghc80failure $(inspectTest $ 'lhs09 === 'rhs09)+ , testCase "optimized lhs09" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs09)+ , testCase "optimized rhs09" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs09)+ , testCase "itraverseOf_ itraversed = itraverseOf_ ifolded" $+ assertSuccess $(inspectTest $ 'lhs10 === 'rhs10)+ , testCase "optimized lhs10a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs10a)+ , testCase "optimized rhs10a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs10a)+ , testCase "iover (itraversed..itraversed) = iover (imapped..imapped)" $+ assertSuccess $(inspectTest $ 'lhs11 === 'rhs11)+ , testCase "optimized lhs11" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs11)+ , testCase "optimized rhs11" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs11)+ , testCase "traverseOf_ traversed = traverseOf_ folded" $+ assertSuccess $(inspectTest $ 'lhs12 === 'rhs12)+ , testCase "optimized lhs12a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs12a)+ , testCase "optimized rhs12a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs12a)+ , testCase "over (traversed..) = over (mapped..)" $+ assertSuccess $(inspectTest $ 'lhs13 === 'rhs13)+ , testCase "optimized lhs13" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs13)+ , testCase "optimized rhs13" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs13)+ , testCase "traverseOf_ itraversed = traverseOf_ folded" $+ assertSuccess $(inspectTest $ 'lhs14 === 'rhs14)+ , testCase "optimized lhs14a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs14a)+ , testCase "optimized rhs14a" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs14a)+ , testCase "over (itraversed..) = over (mapped..)" $+ assertSuccess $(inspectTest $ 'lhs15 === 'rhs15)+ , testCase "optimized lhs15" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs15)+ , testCase "optimized rhs15" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs15)+ , testCase "iset (itraversed..) = iset (imapped..)" $+ -- GHC >= 8.2 && =< 8.6 has additional let in generated core, but the+ -- difference is trivial.+ ghc82to86failure $(inspectTest $ 'lhs16 === 'rhs16)+ , testCase "optimized lhs16" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs16)+ , testCase "optimized rhs16" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs16)+ , testCase "iset (_1 % itraversed) = iset (_1 % imapped)" $+ assertSuccess $(inspectTest $ 'lhs17 === 'rhs17)+ , testCase "optimized lhs17" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs17)+ , testCase "optimized rhs17" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs17)+ , testCase "iset (each %> itraversed) = iset (each %> imapped)" $+ assertSuccess $(inspectTest $ 'lhs18 === 'rhs18)+ , testCase "optimized lhs18" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs18)+ , testCase "optimized rhs18" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs18)+ , testCase "optimized failover" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'failoverCheck)+ , testCase "optimized failover'" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'failover'Check)+ , testCase "optimized ifailover" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'ifailoverCheck)+ , testCase "optimized ifailover'" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'ifailover'Check)+ ]++-- Sometimes we need to eta expand, as without it pretty much equivalent code is+-- produced, but somewhat rearranged. Expanding allows us to get rid of these+-- differences to satisfy the check. However, when we do that we also need to+-- check whether the form that is not eta-expanded optimizes away internal+-- representation correctly.++lhs01, rhs01, lhs01a+ :: (Applicative f, Traversable t)+ => (a -> f b) -> t a -> f (t b)+lhs01 f = traverseOf traversed f+rhs01 f = traverse f+lhs01a = traverseOf traversed++lhs02, rhs02, lhs02a+ :: (Applicative f, Traversable t, Traversable s)+ => (a -> f b) -> t (s a) -> f (t (s b))+lhs02 f = traverseOf (traversed % traversed) f+rhs02 f = traverse . traverse $ f+lhs02a = traverseOf (traversed % traversed)++lhs03, rhs03+ :: (Applicative f, TraversableWithIndex i t, TraversableWithIndex j s)+ => (a -> f b) -> t (s a) -> f (t (s b))+lhs03 = traverseOf (traversed % traversed)+rhs03 = traverseOf (itraversed % itraversed)++lhs04, rhs04+ :: (Applicative f, FoldableWithIndex i t, FoldableWithIndex j s)+ => (a -> f r) -> t (s a) -> f ()+lhs04 = traverseOf_ (folded % folded)+rhs04 = traverseOf_ (ifolded % ifolded)++lhs05, lhs05b, rhs05+ :: (FunctorWithIndex i f, FunctorWithIndex j g) => (a -> b) -> f (g a) -> f (g b)+lhs05 = over (noIx (imapped % imapped))+lhs05b = over (imapped % imapped)+rhs05 = over (mapped % mapped)++lhs06, rhs06+ :: (Applicative f, TraversableWithIndex i t, FoldableWithIndex j f)+ => (a -> f r)+ -> (Either (t (f a, c)) b)+ -> f ()+lhs06 = traverseOf_ (_Left % ifolded % _1 % ifolded)+rhs06 = traverseOf_ (_Left % folded % _1 % folded)++lhs07, rhs07, lhs07a, rhs07a+ :: (Applicative f, TraversableWithIndex i t, TraversableWithIndex j s)+ => (j -> a -> f b)+ -> t (s a)+ -> f (t (s b))+lhs07 f = itraverseOf (itraversed %> itraversed) f+rhs07 f = itraverseOf (traversed % itraversed) f+lhs07a = itraverseOf (itraversed %> itraversed)+rhs07a = itraverseOf (traversed % itraversed)++lhs08, rhs08, lhs08a, rhs08a+ :: (Applicative f, FoldableWithIndex i t, FoldableWithIndex j s)+ => (j -> a -> f ())+ -> t (s a)+ -> f ()+lhs08 f = itraverseOf_ (ifolded %> ifolded) f+rhs08 f = itraverseOf_ (folded % ifolded) f+lhs08a = itraverseOf_ (ifolded %> ifolded)+rhs08a = itraverseOf_ (folded % ifolded)++lhs09, rhs09+ :: (FunctorWithIndex i t, FunctorWithIndex j s)+ => (i -> a -> b)+ -> t (s a)+ -> t (s b)+lhs09 = iover (imapped <% imapped)+rhs09 = iover (imapped % mapped)++-- Rewrite rule "itraversed__ -> ifolded__"+lhs10, rhs10, lhs10a, rhs10a+ :: (Applicative f, TraversableWithIndex i s, TraversableWithIndex j t)+ => ((i, j) -> a -> f r)+ -> s (Either (t a) b)+ -> f ()+lhs10 f s = itraverseOf_ (icompose (,) $ itraversed % _Left % itraversed) f s+rhs10 f s = itraverseOf_ (icompose (,) $ ifolded % _Left % ifolded) f s+lhs10a = itraverseOf_ (icompose (,) $ itraversed % _Left % itraversed)+rhs10a = itraverseOf_ (icompose (,) $ ifolded % _Left % ifolded)++-- Rewrite rule "itraversed__ -> imapped__"+lhs11, rhs11+ :: (TraversableWithIndex i s, TraversableWithIndex j t)+ => ((i, j) -> a -> b)+ -> s (Either c (t a))+ -> s (Either c (t b))+lhs11 = iover (icompose (,) $ itraversed % _Right % itraversed)+rhs11 = iover (icompose (,) $ imapped % _Right % imapped)++-- Rewrite rule "traversed__ -> folded__"+lhs12, rhs12, lhs12a, rhs12a+ :: (Applicative f, Traversable s, Traversable t)+ => (a -> f r)+ -> s (Either (t a) b)+ -> f ()+lhs12 f = traverseOf_ (traversed % _Left % traversed) f+rhs12 f = traverseOf_ (folded % _Left % folded) f+lhs12a = traverseOf_ (traversed % _Left % traversed)+rhs12a = traverseOf_ (folded % _Left % folded)++-- Rewrite rule "traversed__ -> mapped__"+lhs13, rhs13+ :: Traversable s+ => (a -> b)+ -> s (Either c a)+ -> s (Either c b)+lhs13 = over (traversed % _Right)+rhs13 = over (mapped % _Right)++-- Rewrite rule "itraversed__ -> folded__"+lhs14, rhs14, lhs14a, rhs14a+ :: (Applicative f, TraversableWithIndex i s, Traversable t)+ => (a -> f r)+ -> s (Either (t a) b)+ -> f ()+lhs14 f = traverseOf_ (itraversed % _Left % traversed) f+rhs14 f = traverseOf_ (folded % _Left % folded) f+lhs14a = traverseOf_ (itraversed % _Left % traversed)+rhs14a = traverseOf_ (folded % _Left % folded)++-- Rewrite rule "itraversed__ -> mapped__"+lhs15, rhs15+ :: TraversableWithIndex i s+ => (a -> b)+ -> s (Either c a)+ -> s (Either c b)+lhs15 = over (itraversed % _Right)+rhs15 = over (mapped % _Right)++lhs16, rhs16+ :: (TraversableWithIndex i s, TraversableWithIndex j t)+ => ((i, j) -> b)+ -> s (Either c (t a))+ -> s (Either c (t b))+lhs16 = iset (icompose (,) $ itraversed % _Right % itraversed)+rhs16 = iset (icompose (,) $ imapped % _Right % imapped)++lhs17, rhs17+ :: (TraversableWithIndex i s)+ => (i -> b)+ -> (s a, r)+ -> (s b, r)+lhs17 = iset (_1 % itraversed)+rhs17 = iset (_1 % imapped)++lhs18, rhs18+ :: (TraversableWithIndex i s)+ => (i -> a)+ -> [s a]+ -> [s a]+lhs18 = iset (each %> itraversed)+rhs18 = iset (each %> imapped)++failoverCheck+ :: (TraversableWithIndex i s, TraversableWithIndex j t)+ => (a -> b)+ -> s (Either c (t a))+ -> Maybe (s (Either c (t b)))+failoverCheck = failover (traversed % _Right % traversed)++failover'Check+ :: (TraversableWithIndex i s, TraversableWithIndex j t)+ => (a -> b)+ -> s (Either c (t a))+ -> Maybe (s (Either c (t b)))+failover'Check = failover' (traversed % _Right % traversed)++ifailoverCheck+ :: (TraversableWithIndex i s, TraversableWithIndex j t)+ => ((i, j) -> a -> b)+ -> s (Either c (t a))+ -> Maybe (s (Either c (t b)))+ifailoverCheck = ifailover (icompose (,) $ itraversed % _Right % itraversed)++ifailover'Check+ :: (TraversableWithIndex i s, TraversableWithIndex j t)+ => ((i, j) -> a -> b)+ -> s (Either c (t a))+ -> Maybe (s (Either c (t b)))+ifailover'Check = ifailover' (icompose (,) $ itraversed % _Right % itraversed)
+ tests/Optics/Tests/Eta.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Optics.Tests.Eta (etaTests) where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Inspection++import Optics+import Optics.Tests.Utils++etaTests :: TestTree+etaTests = testGroup "Eta expansion"+ [ testCase "toListOf folded = \\s -> toListOf folded s" $+ assertSuccess $(inspectTest $ 'eta1lhs === 'eta1rhs)+ , testCase "optimized eta1lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta1lhs)+ , testCase "itoListOf ifolded = \\s -> itoListOf ifolded s" $+ assertSuccess $(inspectTest $ 'eta2lhs === 'eta2rhs)+ , testCase "optimized eta2lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta2lhs)+ , testCase "traverseOf traversed = \\f -> traverseOf traversed f" $+ assertSuccess $(inspectTest $ 'eta3lhs === 'eta3rhs)+ , testCase "optimized eta3lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta3lhs)+ , testCase "itraverseOf itraversed = \\f -> itraverseOf itraversed f" $+ assertSuccess $(inspectTest $ 'eta4lhs === 'eta4rhs)+ , testCase "optimized eta4lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta4lhs)+ , testCase "traverseOf_ folded = \\f -> traverseOf_ folded f" $+ assertSuccess $(inspectTest $ 'eta5lhs === 'eta5rhs)+ , testCase "optimized eta5lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta5lhs)+ , testCase "itraverseOf_ ifolded = \\f -> itraverseOf_ ifolded f" $+ -- See the definition of itraverseOf_ for details.+ ghc82failure $(inspectTest $ 'eta6lhs === 'eta6rhs)+ , testCase "optimized eta6lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta6lhs)+ , testCase "over mapped = \\f -> over mapped f" $+ assertSuccess $(inspectTest $ 'eta7lhs === 'eta7rhs)+ , testCase "optimized eta7lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta7lhs)+ , testCase "over' mapped = \\f -> over' mapped f" $+ assertSuccess $(inspectTest $ 'eta8lhs === 'eta8rhs)+ , testCase "optimized eta8lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta8lhs)+ , testCase "iover imapped = \\f -> iover imapped f" $+ assertSuccess $(inspectTest $ 'eta9lhs === 'eta9rhs)+ , testCase "optimized eta9lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta9lhs)+ , testCase "iover' imapped = \\f -> iover' imapped f" $+ assertSuccess $(inspectTest $ 'eta10lhs === 'eta10rhs)+ , testCase "optimized eta10lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta10lhs)+ , testCase "iset imapped = \\f -> iset imapped f" $+ assertSuccess $(inspectTest $ 'eta11lhs === 'eta11rhs)+ , testCase "optimized eta11lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta11lhs)+ , testCase "iset' imapped = \\f -> iset' imapped f" $+ assertSuccess $(inspectTest $ 'eta12lhs === 'eta12rhs)+ , testCase "optimized eta12lhs" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'eta12lhs)+ ]++eta1lhs, eta1rhs :: Foldable f => f a -> [a]+eta1lhs = toListOf folded+eta1rhs s = toListOf folded s++eta2lhs, eta2rhs :: FoldableWithIndex i f => f a -> [(i, a)]+eta2lhs = itoListOf ifolded+eta2rhs s = itoListOf ifolded s++eta3lhs, eta3rhs+ :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)+eta3lhs = traverseOf traversed+eta3rhs f = traverseOf traversed f++eta4lhs, eta4rhs+ :: (Applicative f, TraversableWithIndex i t) => (i -> a -> f b) -> t a -> f (t b)+eta4lhs = itraverseOf itraversed+eta4rhs f = itraverseOf itraversed f++eta5lhs, eta5rhs+ :: (Applicative f, Foldable t) => (a -> f r) -> t a -> f ()+eta5lhs = traverseOf_ folded+eta5rhs f = traverseOf_ folded f++eta6lhs, eta6rhs+ :: (Applicative f, FoldableWithIndex i t) => (i -> a -> f r) -> t a -> f ()+eta6lhs = itraverseOf_ ifolded+eta6rhs f = itraverseOf_ ifolded f++eta7lhs, eta7rhs+ :: Functor f => (a -> b) -> f a -> f b+eta7lhs = over mapped+eta7rhs f = over mapped f++eta8lhs, eta8rhs+ :: Functor f => (a -> b) -> f a -> f b+eta8lhs = over' mapped+eta8rhs f = over' mapped f++eta9lhs, eta9rhs+ :: FunctorWithIndex i f => (i -> a -> b) -> f a -> f b+eta9lhs = iover imapped+eta9rhs f = iover imapped f++eta10lhs, eta10rhs+ :: FunctorWithIndex i f => (i -> a -> b) -> f a -> f b+eta10lhs = iover' imapped+eta10rhs f = iover' imapped f++eta11lhs, eta11rhs+ :: (FunctorWithIndex i f, FunctorWithIndex j g)+ => ((i, j) -> b) -> f (g a) -> f (g b)+eta11lhs = iset (imapped <%> imapped)+eta11rhs f = iset (imapped <%> imapped) f++eta12lhs, eta12rhs+ :: (FunctorWithIndex i f, FunctorWithIndex j g)+ => ((i, j) -> b) -> f (g a) -> f (g b)+eta12lhs = iset' (imapped <%> imapped)+eta12rhs f = iset' (imapped <%> imapped) f
+ tests/Optics/Tests/Labels.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Optics.Tests.Labels where++import Data.Ord+import Data.Word+import Control.Monad.Reader+import Control.Monad.State+import Test.Tasty+import Test.Tasty.HUnit+import Test.Inspection+import qualified System.Random as R++import Optics+import Optics.Tests.Utils++labelsTests :: TestTree+labelsTests = testGroup "Labels"+ [+ testCase "view #name s = humanName s" $+ assertSuccess $(inspectTest $ 'label1lhs ==- 'label1rhs)+ , testCase "set #pets s b = s { humanPets = b }" $+ assertSuccess $(inspectTest $ 'label2lhs ==- 'label2rhs)+ , testCase "view (#fish % #name) s = fishName (humanFish s)" $+ assertSuccess $(inspectTest $ 'label3lhs ==- 'label3rhs)+ , testCase "set (#fish % #name) b s = s { humanFish = ... }" $+ assertSuccess $(inspectTest $ 'label4lhs ==- 'label4rhs)+ , testCase "multiple set with labels = multiple set with record syntax" $+ assertSuccess $(inspectTest $ 'label5lhs ==- 'label5rhs)+ ]++label1lhs, label1rhs :: Human a -> String+label1lhs s = view #name s+label1rhs s = humanName s++label2lhs, label2rhs :: Human a -> [b] -> Human b+label2lhs s b = set #pets b s+label2rhs s b = s { humanPets = b }++label3lhs, label3rhs :: Human a -> String+label3lhs s = view (#fish % #name) s+label3rhs s = fishName (humanFish s)++label4lhs, label4rhs :: Human a -> String -> Human a+label4lhs s b = set (#fish % #name) b s+label4rhs s b = s { humanFish = (humanFish s) { fishName = b } }++label5lhs, label5rhs :: Human a -> String -> Int -> String -> [b] -> Human b+label5lhs s name_ age_ fishName_ pets_ = s+ & #name .~ name_+ & #age .~ age_+ & #fish % #name .~ fishName_+ & #pets .~ pets_+label5rhs s name_ age_ fishName_ pets_ = s+ { humanName = name_+ , humanAge = age_+ , humanFish = (humanFish s) { fishName = fishName_ }+ , humanPets = pets_+ }++----------------------------------------+-- Data definitions++data Mammal+ = Dog { mammalName :: String, mammalAge :: Int }+ | Cat { mammalName :: String, mammalAge :: Int, mammalLazy :: Bool }+ deriving Show++data Fish = GoldFish { fishName :: String } | Herring { fishName :: String }+ deriving Show++data Human a = Human+ { humanName :: String+ , humanAge :: Int+ , humanFish :: Fish+ , humanPets :: [a]+ }+ deriving Show++human :: Human Mammal+human = Human+ { humanName = "Andrzej"+ , humanAge = 30+ , humanFish = GoldFish "Goldie"+ , humanPets = [Dog "Rocky" 3, Cat "Pickle" 4 True, Cat "Max" 1 False]+ }++makeFieldLabels ''Mammal+makePrismLabels ''Mammal+makeFieldLabels ''Fish+makePrismLabels ''Fish+makeFieldLabels ''Human++----------------------------------------+-- Basic data manipulation++petNames :: [String]+petNames = toListOf (#pets % folded % #name) human++otherHuman :: Human a+otherHuman = human & set #name "Peter"+ & set #pets []+ & set #age 41++humanWithFish :: Human Fish+humanWithFish = set #pets [GoldFish "Goldie", GoldFish "Slick", Herring "See"] human++howManyGoldFish :: Int+howManyGoldFish = lengthOf (#pets % folded % #_GoldFish) humanWithFish++hasLazyPets :: Bool+hasLazyPets = orOf (#pets % folded % #lazy) human++yearLater :: Human Mammal+yearLater = human & #age %~ (+1)+ & #pets % mapped % #age %~ (+1)++oldestPet :: Maybe Mammal+oldestPet = maximumByOf (#pets % folded) (comparing $ view #age) human++luckyDog :: Human Mammal+luckyDog = human & set (#pets % mapped % #_Dog % _1) "Lucky"++----------------------------------------+-- Generalization of Has* classes++type HasConfig k s = (LabelOptic' "config" k s Config, Is k A_Getter)++data Config = Config+instance+ (a ~ Config, b ~ Config+ ) => LabelOptic "config" An_Iso Config Config a b where+ labelOptic = equality++data Env = Env { envConfig :: Config, envRng :: R.StdGen }+makeFieldLabels ''Env++data Nested = Nested { nestedName :: String, nestedEnv :: Env }+makeFieldLabels ''Nested++instance+ (a ~ Config, b ~ Config+ ) => LabelOptic "config" A_Lens Nested Nested a b where+ labelOptic = #env % #config++doStuff :: (MonadReader r m, HasConfig k r) => m ()+doStuff = do+ _ <- asks (view #config)+ -- ...+ pure ()++env :: Env+env = Env Config (R.mkStdGen 0)++-- | Do stuff with 'Config' directly.+doStuffWithConfig :: Monad m => m ()+doStuffWithConfig = runReaderT doStuff Config++-- | Do stuff with larger environment containing 'Config'.+doStuffWithEnv :: Monad m => m ()+doStuffWithEnv = runReaderT doStuff env++-- | Do stuff with even larger environment.+doStuffWithNested :: Monad m => m ()+doStuffWithNested = runReaderT doStuff (Nested "weird" env)++----------------------------------------+-- Composition++randomValue+ :: (MonadState s m, LabelOptic' "rng" A_Lens s R.StdGen, R.Random r)+ => m r+randomValue = do+ (r, g) <- gets $ view (#rng % to R.random)+ modify' $ set #rng g+ pure r++randomWords :: IO [Word8]+randomWords = do+ rng <- R.mkStdGen <$> R.randomIO+ (`evalStateT` Env Config rng) $ do+ n <- fix $ \loop -> do+ n <- (`mod` 16) <$> randomValue+ if n < 5+ then loop+ else pure n+ replicateM n randomValue
+ tests/Optics/Tests/Misc.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Optics.Tests.Misc (miscTests) where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Inspection+import qualified Data.Map as M+import qualified Data.Sequence as S++import Optics+import Optics.Tests.Utils++miscTests :: TestTree+miscTests = testGroup "Miscellaneous"+ [ testCase "optimized sipleMapIx" $+ assertSuccess $(inspectTest $ 'simpleMapIx `hasNoTypeClassesExcept` [''Ord])+ , testCase "optimized mapIx" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'mapIx)+ , testCase "optimized seqIx" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'seqIx)+ , testCase "optimized itoList" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'checkitoListOf)+ ]++simpleMapIx+ :: Ord k => k -> Either a (M.Map k (b, v)) -> Maybe v+simpleMapIx k = preview (_Right % ix k % _2)++mapIx+ :: (Foldable f, Foldable g, Ord k)+ => (f (Either a (g (M.Map k v))), b) -> k -> [v]+mapIx m k = toListOf (_1 % folded % _Right % folded % ix k) m++seqIx :: Int -> [S.Seq a] -> [a]+seqIx i = toListOf (folded % ix i)++checkitoListOf :: Int -> [S.Seq a] -> [(Int, a)]+checkitoListOf i = itoListOf (ifolded % ix i)
+ tests/Optics/Tests/Utils.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+module Optics.Tests.Utils where++import Language.Haskell.TH (Name)+import Test.Tasty.HUnit+import Test.Inspection++import qualified Optics.Internal.Profunctor as P++hasNoProfunctors :: Name -> Obligation+hasNoProfunctors name = mkObligation name $ NoUseOf+ [ 'P.dimap+ , 'P.lmap+ , 'P.rmap+ , 'P.lcoerce'+ , 'P.rcoerce'+ , 'P.conjoined__+ , 'P.ixcontramap+ , 'P.first'+ , 'P.second'+ , 'P.linear+ , 'P.ilinear+ , 'P.unfirst+ , 'P.unsecond+ , 'P.left'+ , 'P.right'+ , 'P.unleft+ , 'P.unright+ , 'P.visit+ , 'P.ivisit+ , 'P.wander+ , 'P.iwander+ , 'P.roam+ , 'P.iroam+ ]++assertSuccess :: Result -> IO ()+assertSuccess (Success _) = return ()+assertSuccess (Failure err) = assertFailure err++assertFailure' :: Result -> IO ()+assertFailure' (Success err) = assertFailure err+assertFailure' (Failure _) = return ()++ghc80failure :: Result -> IO ()+#if __GLASGOW_HASKELL__ == 800+ghc80failure = assertFailure'+#else+ghc80failure = assertSuccess+#endif++ghc80success :: Result -> IO ()+#if __GLASGOW_HASKELL__ == 800+ghc80success = assertSuccess+#else+ghc80success = assertFailure'+#endif++ghc82to86failure :: Result -> IO ()+#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ <= 806+ghc82to86failure = assertFailure'+#else+ghc82to86failure = assertSuccess+#endif++ghc82failure :: Result -> IO ()+#if __GLASGOW_HASKELL__ == 802+ghc82failure = assertFailure'+#else+ghc82failure = assertSuccess+#endif++ghcGE86failure :: Result -> IO ()+#if __GLASGOW_HASKELL__ >= 806+ghcGE86failure = assertFailure'+#else+ghcGE86failure = assertSuccess+#endif