diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/benchmarks/folds.hs b/benchmarks/folds.hs new file mode 100644 --- /dev/null +++ b/benchmarks/folds.hs @@ -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 diff --git a/benchmarks/traversals.hs b/benchmarks/traversals.hs new file mode 100644 --- /dev/null +++ b/benchmarks/traversals.hs @@ -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 diff --git a/diagrams/indexedoptics.png b/diagrams/indexedoptics.png new file mode 100644 Binary files /dev/null and b/diagrams/indexedoptics.png differ diff --git a/diagrams/optics.png b/diagrams/optics.png new file mode 100644 Binary files /dev/null and b/diagrams/optics.png differ diff --git a/diagrams/reoptics.png b/diagrams/reoptics.png new file mode 100644 Binary files /dev/null and b/diagrams/reoptics.png differ diff --git a/optics.cabal b/optics.cabal new file mode 100644 --- /dev/null +++ b/optics.cabal @@ -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 diff --git a/src/Optics.hs b/src/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Optics.hs @@ -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. + -- + -- <> + -- + , 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: +-- +-- <> +-- +-- 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 +-- +-- * a talk on the principles behind this library with by Adam Gundry (but note that the design details of @optics@ have changed substantially since this talk was given) +-- +-- * a talk on basics of profunctors and how they relate to data accessors such as lenses, prisms and traversals by Andrzej Rybczak +-- +-- * a paper by Matthew Pickering, Jeremy Gibbons and Nicolas Wu +-- +-- * and , blog posts by Oleg Grenrus +-- +-- * The 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 +-- +-- <> + +-- $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 diff --git a/tests/Optics/Tests.hs b/tests/Optics/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/Tests.hs @@ -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 + ] diff --git a/tests/Optics/Tests/Computation.hs b/tests/Optics/Tests/Computation.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/Tests/Computation.hs @@ -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 diff --git a/tests/Optics/Tests/Core.hs b/tests/Optics/Tests/Core.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/Tests/Core.hs @@ -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) diff --git a/tests/Optics/Tests/Eta.hs b/tests/Optics/Tests/Eta.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/Tests/Eta.hs @@ -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 diff --git a/tests/Optics/Tests/Labels.hs b/tests/Optics/Tests/Labels.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/Tests/Labels.hs @@ -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 diff --git a/tests/Optics/Tests/Misc.hs b/tests/Optics/Tests/Misc.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/Tests/Misc.hs @@ -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) diff --git a/tests/Optics/Tests/Utils.hs b/tests/Optics/Tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Optics/Tests/Utils.hs @@ -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