optics 0.2 → 0.3
raw patch · 9 files changed
+231/−40 lines, 9 filesdep +QuickCheckdep +tasty-quickcheckdep ~optics-coredep ~optics-extradep ~optics-th
Dependencies added: QuickCheck, tasty-quickcheck
Dependency ranges changed: optics-core, optics-extra, optics-th
Files
- CHANGELOG.md +28/−0
- benchmarks/folds.hs +0/−3
- benchmarks/traversals.hs +24/−0
- optics.cabal +10/−5
- src/Optics.hs +18/−2
- tests/Optics/Tests.hs +2/−0
- tests/Optics/Tests/Labels.hs +29/−30
- tests/Optics/Tests/Misc.hs +34/−0
- tests/Optics/Tests/Properties.hs +86/−0
CHANGELOG.md view
@@ -1,3 +1,31 @@+# optics-0.3 (2020-04-15)+* GHC-8.10 support+* Add `filteredBy` and `unsafeFilteredBy`+* Add `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex`+ instances for `Const` and `Constant`+* Add `afoldVL` and `iafoldVL` constructors+* Rename `toAtraversalVL` to `atraverseOf`, and `toIxAtraversalVL` to `iatraverseOf`+* Generalise `element` and `elementOf` to construct `IxAffineTraversal`s+ instead of `IxTraversal`s+* Change `mapping` to work on optic kinds other than `Iso`: it now supports+ `Lens` and `Prism` degenerating to `Getter` and `Review` respectively+* Generalise `ignored` to be an `IxAffineTraversal` instead of an `IxTraversal`+* Add `singular` and `isingular`+* Add `(^?!)` operator+* Expose `Curry` and `CurryCompose`+* Show expected elimination forms on optic kind mismatch+* Use stricter `uncurry` for better performance+* Add hidden `LabelOptic` instance to postpone instance resolution+* Add `GeneralLabelOptic` for pluggable generic optics as labels+* Document monoidal structures of `Fold`s+* Remove proxy argument from `implies`+* Add `itoList`+* Improvements to TH-generated optics:+ - `LabelOptic` instances make optic kind a type equality for better type inference+ - `LabelOptic` instances for field optics work properly in the presence of type families+ - Fixed calculation of phantom types in `LabelOptic` prism instances+ - Better support for generating optics in the presence of kind polymorphism+ # optics-0.2 (2019-10-18) * Add `non`, `non'` and `anon` to `Optics.Iso` * `ix` can produce optic kinds other than `AffineTraversal`
benchmarks/folds.hs view
@@ -17,9 +17,6 @@ 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"
benchmarks/traversals.hs view
@@ -84,6 +84,10 @@ , 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 "singular"+ [ bench "singular" $ nf (over (singular traversed) id) v+ , bench "singular/lens" $ nf (L.over (L.singular traverse) id) v+ ] , bgroup "indices" [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) v , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) v@@ -152,6 +156,10 @@ , 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 "singular"+ [ bench "singular" $ nf (over (singular traversed) id) s+ , bench "singular/lens" $ nf (L.over (L.singular traverse) id) s+ ] , bgroup "indices" [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) s , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) s@@ -256,6 +264,10 @@ , 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 "singular"+ [ bench "singular" $ nf (over (singular traversed) id) l+ , bench "singular/lens" $ nf (L.over (L.singular traverse) id) l+ ] , bgroup "indices" [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) l , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) l@@ -313,6 +325,10 @@ , 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 "singular"+ [ bench "singular" $ nf (over (singular traversed) id) im+ , bench "singular/lens" $ nf (L.over (L.singular traverse) id) im+ ] , bgroup "indices" [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) im , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) im@@ -370,6 +386,10 @@ , 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 "singular"+ [ bench "singular" $ nf (over (singular traversed) id) m+ , bench "singular/lens" $ nf (L.over (L.singular traverse) id) m+ ] , bgroup "indices" [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) m , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) m@@ -426,6 +446,10 @@ , 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 "singular"+ [ bench "singular" $ nf (over (singular traversed) id) h+ , bench "singular/lens" $ nf (L.over (L.singular traverse) id) h ] , bgroup "indices" [ bench "indices" $ nf (iover (itraversed %& indices even) (+)) h
optics.cabal view
@@ -1,12 +1,12 @@ name: optics-version: 0.2+version: 0.3 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, GHCJS ==8.4+tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1, GHCJS ==8.4 synopsis: Optics as an abstract interface category: Data, Optics, Lenses description:@@ -42,9 +42,9 @@ , array >= 0.5.1.1 && <0.6 , containers >= 0.5.7.1 && <0.7 , mtl >= 2.2.2 && <2.3- , optics-core >= 0.2 && <0.2.1- , optics-extra >= 0.2 && <0.2.1- , optics-th >= 0.2 && <0.2.1+ , optics-core >= 0.3 && <0.3.1+ , optics-extra >= 0.3 && <0.3.1+ , optics-th >= 0.3 && <0.3.1 , transformers >= 0.5 && <0.6 -- main module to land with repl@@ -83,7 +83,9 @@ , Optics.Empty , Optics.Indexed , Optics.Label+ , Optics.Mapping , Optics.Operators+ , Optics.Operators.Unsafe , Optics.Passthrough , Optics.Re , Optics.ReadOnly@@ -136,9 +138,11 @@ , mtl , optics , optics-core+ , QuickCheck , random , tasty , tasty-hunit+ , tasty-quickcheck , template-haskell type: exitcode-stdio-1.0@@ -149,6 +153,7 @@ Optics.Tests.Eta Optics.Tests.Labels Optics.Tests.Misc+ Optics.Tests.Properties Optics.Tests.Utils -- Benchmarking folds
src/Optics.hs view
@@ -115,6 +115,11 @@ -- counterpart. , module Optics.ReadOnly + -- ** Mapping++ -- | Defines 'mapping' through 'Functor's+ , module Optics.Mapping+ -- ** 'Setter' utilities for working in 'Control.Monad.State.MonadState'. , module Optics.State @@ -204,6 +209,7 @@ import Optics.Each import Optics.Empty import Optics.Indexed+import Optics.Mapping import Optics.Operators import Optics.Re import Optics.ReadOnly@@ -535,6 +541,10 @@ -- ... -- ...A_Setter cannot be composed with A_Fold -- ...+--+-- The ('Control.Category..') operator from "Control.Category" cannot be used to+-- compose optics either, because it would not support type-changing optics or+-- composing optics of different kinds. -- $lens_comparison --@@ -707,6 +717,12 @@ -- 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.+--+-- * 'singular' ('isingular' for indexed optics) doesn't produce a partial lens+-- that might fail with a runtime error, but an affine traversal.+--+-- * '<>' cannot be used to combine 'Fold's, so 'summing' should be used+-- instead. -- $otherresources@@ -835,7 +851,7 @@ -- >>> 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).+-- In the diagram below, the optics hierarchy 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@@ -872,7 +888,7 @@ -- +-------------------+---------------+---------------------------------------------------+ -- |'views' |'iviews' |View after applying a function. | -- +-------------------+---------------+---------------------------------------------------+--- | | |+-- | | -- +-------------------+---------------+---------------------------------------------------+ -- |__Setters__ | -- +-------------------+---------------+---------------------------------------------------+
tests/Optics/Tests.hs view
@@ -10,6 +10,7 @@ import Optics.Tests.Eta import Optics.Tests.Labels import Optics.Tests.Misc+import Optics.Tests.Properties -- | Composing a lens and a traversal yields a traversal _comp1 :: Traversable t => Optic A_Traversal NoIx (t a, y) (t b, y) a b@@ -48,4 +49,5 @@ , miscTests ] , computationTests+ , propertiesTests ]
tests/Optics/Tests/Labels.hs view
@@ -22,6 +22,30 @@ import Optics import Optics.Tests.Utils +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++makeFieldLabels ''Mammal+makePrismLabels ''Mammal+makeFieldLabels ''Fish+makePrismLabels ''Fish+makeFieldLabels ''Human++----------------------------------------+ labelsTests :: TestTree labelsTests = testGroup "Labels" [@@ -67,23 +91,7 @@ } ------------------------------------------- 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+-- Basic data manipulation human :: Human Mammal human = Human@@ -93,15 +101,6 @@ , 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 @@ -136,8 +135,8 @@ data Config = Config instance- (a ~ Config, b ~ Config- ) => LabelOptic "config" An_Iso Config Config a b where+ (k ~ An_Iso, a ~ Config, b ~ Config+ ) => LabelOptic "config" k Config Config a b where labelOptic = equality data Env = Env { envConfig :: Config, envRng :: R.StdGen }@@ -147,8 +146,8 @@ makeFieldLabels ''Nested instance- (a ~ Config, b ~ Config- ) => LabelOptic "config" A_Lens Nested Nested a b where+ (k ~ A_Lens, a ~ Config, b ~ Config+ ) => LabelOptic "config" k Nested Nested a b where labelOptic = #env % #config doStuff :: (MonadReader r m, HasConfig k r) => m ()
tests/Optics/Tests/Misc.hs view
@@ -21,6 +21,14 @@ assertSuccess $(inspectTest $ hasNoProfunctors 'seqIx) , testCase "optimized itoList" $ assertSuccess $(inspectTest $ hasNoProfunctors 'checkitoListOf)+ , testCase "optimized partsOf" $+ ghc80failure $(inspectTest $ hasNoProfunctors 'checkPartsOf)+ , testCase "optimized singular" $+ ghc80failure $(inspectTest $ hasNoProfunctors 'checkSingular)+ , testCase "optimized filteredBy" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'checkFilteredBy)+ , testCase "optimized unsafeFilteredBy" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'checkUnsafeFilteredBy) ] simpleMapIx@@ -37,3 +45,29 @@ checkitoListOf :: Int -> [S.Seq a] -> [(Int, a)] checkitoListOf i = itoListOf (ifolded % ix i)++checkPartsOf+ :: Traversable f+ => (f (Either a b), c)+ -> (f (Either a b), c)+checkPartsOf = partsOf (_1 % traversed % _Right) %~ reverse++checkSingular+ :: Traversable f+ => Either (f (a, Char)) b+ -> Either (f (a, Char)) b+checkSingular = singular (_Left % traversed % _2) .~ 'x'++checkFilteredBy+ :: Applicative f+ => ((Maybe i, b) -> f r)+ -> (Maybe i, b)+ -> f ()+checkFilteredBy = atraverseOf_ (filteredBy (_1 % _Just)) pure++checkUnsafeFilteredBy+ :: Applicative f+ => (i -> Either a1 (a, Maybe i) -> f (Either a1 (a, Maybe i)))+ -> Either a1 (a, Maybe i)+ -> f (Either a1 (a, Maybe i))+checkUnsafeFilteredBy = iatraverseOf (unsafeFilteredBy (_Right % _2 % _Just)) pure
+ tests/Optics/Tests/Properties.hs view
@@ -0,0 +1,86 @@+module Optics.Tests.Properties (propertiesTests) where++import Data.Either (isRight)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck (Fun, expectFailure, applyFun, applyFun2, Property, (===), (==>))+import Test.QuickCheck.Poly (A, B, C, OrdA)++import Optics+import Optics.Internal.Optic+import Optics.Internal.Bi++type S = C+type T = OrdA++propertiesTests :: TestTree+propertiesTests = testGroup "properties"+ -- lens bundles /any/ two functions together+ [ testGroup "Lens"+ [ testProperty "view (lens f g) = f" $+ let prop :: Fun S A -> Fun (S, B) T -> S -> Property+ prop f g s =+ view (getting (lens (applyFun f) (applyFun2 g))) s+ ===+ applyFun f s++ in prop+ , testProperty "set (lens f g) = g" $+ let prop :: Fun S A -> Fun (S, B) T -> S -> B -> Property+ prop f g s b =+ set (lens (applyFun f) (applyFun2 g)) b s+ ===+ applyFun2 g s b++ in prop+ ]++ -- also prisms+ , testGroup "Prism"+ [ testProperty "review (prism f g) = f" $+ let prop :: Fun B T -> Fun S (Either T A) -> B -> Property+ prop f g b =+ review (reviewing (castOptic (prism (applyFun f) (applyFun g)))) b+ ===+ applyFun f b+ in prop+ , testProperty "matching (prism f g) = g" $+ let prop :: Fun B T -> Fun S (Either T A) -> S -> Property+ prop f g s =+ matching (prism (applyFun f) (applyFun g)) s+ ===+ applyFun g s+ in prop+ ]++ -- affine traversals are trickier, atraversal doesn't just bundle+ -- two arbitrary functions together.+ , testGroup "AffineTraversal"+ [ testProperty "matching (atraversal f g) = g" $+ let prop :: Fun S (Either T A) -> Fun (S, B) T -> S -> Property+ prop f g s =+ matching (atraversal (applyFun f) (applyFun2 g)) s+ ===+ applyFun f s+ in prop+ , testProperty "set (atraversal f g) ~= flip g" $+ let prop :: Fun S (Either T A) -> Fun (S, B) T -> S -> B -> Property+ prop f g s b =+ set (atraversal (applyFun f) (applyFun2 g)) b s+ ===+ applyFun2 g s b+ in expectFailure prop+ , testProperty "isRight (f s) ==> set (atraversal f g) = flip g" $+ let prop :: Fun S (Either T A) -> Fun (S, B) T -> S -> B -> Property+ prop f g s b =+ isRight (applyFun f s)+ ==>+ set (atraversal (applyFun f) (applyFun2 g)) b s+ ===+ applyFun2 g s b+ in prop+ ]+ ]++reviewing :: Optic A_Review NoIx s t a b -> Review t b+reviewing (Optic o) = Optic (lphantom . o . lphantom)