Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-optics for openSUSE:Factory checked in at 2021-03-10 08:55:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-optics (Old) and /work/SRC/openSUSE:Factory/.ghc-optics.new.2378 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-optics" Wed Mar 10 08:55:13 2021 rev:3 rq:877657 version:0.4 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-optics/ghc-optics.changes 2020-12-22 11:43:39.573727194 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-optics.new.2378/ghc-optics.changes 2021-03-10 08:57:20.150893971 +0100 @@ -1,0 +2,51 @@ +Tue Feb 23 18:12:01 UTC 2021 - [email protected] + +- Update optics to version 0.4. + # optics-0.4 (2021-02-22) + * See [migration-guide-0.4.md](https://github.com/well-typed/optics/blob/master/migration-guide-0.4.md) for more details + * Add support for GHC-9.0 + * Drop support for GHC-8.0 + * The `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` type + classes have been migrated to a new package, + [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable) + ([#370](https://github.com/well-typed/optics/pull/370)) + * Add `adjoin`, `iadjoin` and `both` to `Optics.[Ix]Traversal` + ([#332](https://github.com/well-typed/optics/pull/332), + [#372](https://github.com/well-typed/optics/pull/372)) + * Add `ifst` and `isnd` to `Optics.IxLens` + ([#389](https://github.com/well-typed/optics/pull/389)) + * Generalize types of `generic` + ([#376](https://github.com/well-typed/optics/pull/376)) + * Make `chosen` an indexed lens to see which value is traversed + ([#335](https://github.com/well-typed/optics/pull/335)) + * Remove `GeneralLabelOptic` extensibility mechanism + ([#361](https://github.com/well-typed/optics/pull/361)) + * Add `gfield`, `gafield`, `gconstructor`, `gposition` and `gplate` for + generics-based data access + ([#358](https://github.com/well-typed/optics/pull/358), + [#361](https://github.com/well-typed/optics/pull/361)) + * Add support for generics-based field lenses and constructor prisms (`gfield` + and `gconstructor`) to `LabelOptic` so they can be used via `OverloadedLabels` + ([#361](https://github.com/well-typed/optics/pull/361)) + * Remove unnecessary INLINE pragmas to reduce compile times + ([#394](https://github.com/well-typed/optics/pull/394)) + * Simplify the type of `(%)` using new `JoinKinds` and `AppendIndices` classes + in place of the `Join` and `Append` type families + ([#397](https://github.com/well-typed/optics/pull/397), + [#399](https://github.com/well-typed/optics/pull/399)) + * Print missing language extensions during TH generation of labels if there are + any ([#352](https://github.com/well-typed/optics/pull/352)) + * Add support for getters of rank1 polymorphic fields to optics generated with + the `makeFieldLabels` family of functions + ([#365](https://github.com/well-typed/optics/pull/365)) + * Extend support of type-changing optics generated with the `makeFieldLabels` + family to type parameters that are phantom and applied to non-injective type + families + ([#365](https://github.com/well-typed/optics/pull/365)) + * Fix TH generation of optics for poly-kinded data families + ([#378](https://github.com/well-typed/optics/pull/378)) + * Fix `declareFieldLabels` when a field type refers to a type defined in the + same quote + ([#380](https://github.com/well-typed/optics/pull/380)) + +------------------------------------------------------------------- Old: ---- optics-0.3.tar.gz New: ---- optics-0.4.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-optics.spec ++++++ --- /var/tmp/diff_new_pack.WPToyy/_old 2021-03-10 08:57:20.942894789 +0100 +++ /var/tmp/diff_new_pack.WPToyy/_new 2021-03-10 08:57:20.946894793 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-optics # -# Copyright (c) 2020 SUSE LLC +# Copyright (c) 2021 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name optics %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.3 +Version: 0.4 Release: 0 Summary: Optics as an abstract interface License: BSD-3-Clause ++++++ optics-0.3.tar.gz -> optics-0.4.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/CHANGELOG.md new/optics-0.4/CHANGELOG.md --- old/optics-0.3/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,50 @@ +# optics-0.4 (2021-02-22) +* See [migration-guide-0.4.md](https://github.com/well-typed/optics/blob/master/migration-guide-0.4.md) for more details +* Add support for GHC-9.0 +* Drop support for GHC-8.0 +* The `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` type + classes have been migrated to a new package, + [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable) + ([#370](https://github.com/well-typed/optics/pull/370)) +* Add `adjoin`, `iadjoin` and `both` to `Optics.[Ix]Traversal` + ([#332](https://github.com/well-typed/optics/pull/332), + [#372](https://github.com/well-typed/optics/pull/372)) +* Add `ifst` and `isnd` to `Optics.IxLens` + ([#389](https://github.com/well-typed/optics/pull/389)) +* Generalize types of `generic` + ([#376](https://github.com/well-typed/optics/pull/376)) +* Make `chosen` an indexed lens to see which value is traversed + ([#335](https://github.com/well-typed/optics/pull/335)) +* Remove `GeneralLabelOptic` extensibility mechanism + ([#361](https://github.com/well-typed/optics/pull/361)) +* Add `gfield`, `gafield`, `gconstructor`, `gposition` and `gplate` for + generics-based data access + ([#358](https://github.com/well-typed/optics/pull/358), + [#361](https://github.com/well-typed/optics/pull/361)) +* Add support for generics-based field lenses and constructor prisms (`gfield` + and `gconstructor`) to `LabelOptic` so they can be used via `OverloadedLabels` + ([#361](https://github.com/well-typed/optics/pull/361)) +* Remove unnecessary INLINE pragmas to reduce compile times + ([#394](https://github.com/well-typed/optics/pull/394)) +* Simplify the type of `(%)` using new `JoinKinds` and `AppendIndices` classes + in place of the `Join` and `Append` type families + ([#397](https://github.com/well-typed/optics/pull/397), + [#399](https://github.com/well-typed/optics/pull/399)) +* Print missing language extensions during TH generation of labels if there are + any ([#352](https://github.com/well-typed/optics/pull/352)) +* Add support for getters of rank1 polymorphic fields to optics generated with + the `makeFieldLabels` family of functions + ([#365](https://github.com/well-typed/optics/pull/365)) +* Extend support of type-changing optics generated with the `makeFieldLabels` + family to type parameters that are phantom and applied to non-injective type + families + ([#365](https://github.com/well-typed/optics/pull/365)) +* Fix TH generation of optics for poly-kinded data families + ([#378](https://github.com/well-typed/optics/pull/378)) +* Fix `declareFieldLabels` when a field type refers to a type defined in the + same quote + ([#380](https://github.com/well-typed/optics/pull/380)) + # optics-0.3 (2020-04-15) * GHC-8.10 support * Add `filteredBy` and `unsafeFilteredBy` diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/benchmarks/folds.hs new/optics-0.4/benchmarks/folds.hs --- old/optics-0.3/benchmarks/folds.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/benchmarks/folds.hs 2001-09-09 03:46:40.000000000 +0200 @@ -125,7 +125,7 @@ ] , bgroup "intmap" [ bgroup "toList" - [ bench "native" $ nf F.toList im + [ bench "native" $ nf IM.elems im , bench "each" $ nf (toListOf each) im , bench "each/lens" $ nf (L.toListOf L.each) im , bench "itraversed" $ nf (toListOf itraversed) im @@ -146,7 +146,7 @@ ] , bgroup "map" [ bgroup "toList" - [ bench "native" $ nf F.toList m + [ bench "native" $ nf M.elems m , bench "each" $ nf (toListOf each) m , bench "each/lens" $ nf (L.toListOf L.each) m , bench "itraversed" $ nf (toListOf itraversed) m @@ -167,7 +167,7 @@ ] , bgroup "hash map" [ bgroup "toList" - [ bench "native" $ nf HM.keys h + [ bench "native" $ nf HM.elems h , bench "each" $ nf (toListOf each) h , bench "each/lens" $ nf (L.toListOf L.each) h , bench "itraversed" $ nf (toListOf itraversed) h diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/benchmarks/traversals.hs new/optics-0.4/benchmarks/traversals.hs --- old/optics-0.3/benchmarks/traversals.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/benchmarks/traversals.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} module Main where import Criterion.Main import Criterion.Types import Data.Char import qualified Control.Lens as L +import qualified Control.Lens.Unsound as L import qualified Control.Monad.Trans.State as S import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -21,15 +21,6 @@ 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" @@ -118,7 +109,7 @@ 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 "native" $ nf (\x -> S.execState (S.traverseWithIndex (\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 @@ -456,16 +447,47 @@ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) h ] ] + , bgroup "misc" + [ bgroup "adjoin" + [ bench "hand-written" $ nf (over adjoinHandWritten (+1)) tuple + , bench "adjoin" $ nf (over adjoinOptics (+1)) tuple + , bench "adjoin/lens" $ nf (L.over adjoinLens (+1)) tuple + ] + ] ] where config = defaultConfig { timeLimit = 1 } + l = [0..10000] :: [Int] + {-# NOINLINE l #-} xl = [0..100000] :: [Int] + {-# NOINLINE xl #-} b = BS.pack $ map fromIntegral xl + {-# NOINLINE b #-} bl = BSL.pack $ map fromIntegral [0..1000000::Int] + {-# NOINLINE bl #-} h = HM.fromList $ zip l l + {-# NOINLINE h #-} m = M.fromList $ zip l l + {-# NOINLINE m #-} im = IM.fromList $ zip l l + {-# NOINLINE im #-} s = S.fromList l + {-# NOINLINE s #-} u = U.fromList xl + {-# NOINLINE u #-} v = V.fromList l + {-# NOINLINE v #-} + tuple :: (Maybe Int, Either Int Int, Int) + tuple = (Just 67, Right 567, 23) + {-# NOINLINE tuple #-} + +adjoinHandWritten :: Traversal' (Maybe a, Either a a, a) a +adjoinHandWritten = traversalVL $ \f (a, b, c) -> + (,,) <$> traverseOf _Just f a <*> traverseOf chosen f b <*> f c + +adjoinOptics :: Traversal' (Maybe a, Either a a, a) a +adjoinOptics = _1 % _Just `adjoin` _2 % chosen `adjoin` _3 + +adjoinLens :: L.Traversal' (Maybe a, Either a a, a) a +adjoinLens = (L._1 . L._Just) `L.adjoin` (L._2 . L.chosen) `L.adjoin` L._3 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/optics.cabal new/optics-0.4/optics.cabal --- old/optics-0.3/optics.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/optics.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,12 +1,12 @@ name: optics -version: 0.3 +version: 0.4 license: BSD3 license-file: LICENSE build-type: Simple maintainer: [email protected] 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.3 || ==8.10.1, GHCJS ==8.4 +tested-with: ghc ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3, GHCJS ==8.4 synopsis: Optics as an abstract interface category: Data, Optics, Lenses description: @@ -38,13 +38,13 @@ 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 + build-depends: base >= 4.10 && <5 + , array >= 0.5.2.0 && <0.6 + , containers >= 0.5.10.2 && <0.7 , mtl >= 2.2.2 && <2.3 - , optics-core >= 0.3 && <0.3.1 - , optics-extra >= 0.3 && <0.3.1 - , optics-th >= 0.3 && <0.3.1 + , optics-core >= 0.4 && <0.4.1 + , optics-extra >= 0.4 && <0.4.1 + , optics-th >= 0.4 && <0.4.1 , transformers >= 0.5 && <0.6 -- main module to land with repl @@ -81,6 +81,7 @@ , Optics.Cons , Optics.Each , Optics.Empty + , Optics.Generic , Optics.Indexed , Optics.Label , Optics.Mapping @@ -151,7 +152,8 @@ other-modules: Optics.Tests.Computation Optics.Tests.Core Optics.Tests.Eta - Optics.Tests.Labels + Optics.Tests.Labels.Generic + Optics.Tests.Labels.TH Optics.Tests.Misc Optics.Tests.Properties Optics.Tests.Utils diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/src/Optics.hs new/optics-0.4/src/Optics.hs --- old/optics-0.3/src/Optics.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/src/Optics.hs 2001-09-09 03:46:40.000000000 +0200 @@ -86,6 +86,9 @@ -- , module Optics.Empty + -- ** Generic data access + , module Optics.Generic + -- ** Re -- | Some optics can be reversed with 're'. This is mainly useful to invert @@ -163,6 +166,9 @@ -- $indexed , module Optics.Indexed + -- * Monoid structures #monoids# + -- $monoids + -- * Generation of optics -- ** ...with Template Haskell , module Optics.TH @@ -208,6 +214,7 @@ import Optics.Cons import Optics.Each import Optics.Empty +import Optics.Generic import Optics.Indexed import Optics.Mapping import Optics.Operators @@ -525,18 +532,14 @@ -- 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 :: OpticKind --- = An_AffineTraversal +-- >>> let res :: JoinKinds A_Lens A_Prism k => Proxy k; res = Proxy +-- >>> :t res +-- res :: Proxy 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 :: OpticKind --- = (TypeError ...) --- -- >>> :t mapped % folded -- ... -- ...A_Setter cannot be composed with A_Fold @@ -721,21 +724,34 @@ -- * '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. +-- * '<>' cannot be used to combine 'Fold's, so 'summing' should be used instead +-- (see the "Monoid structures" section below in "Optics#monoids"). -- $otherresources -- --- * <https://skillsmatter.com/skillscasts/10692-through-a-glass-abstractly-lenses-and-the-power-of-abstraction Through a Glass, Abstractly: Lenses and the Power of Abstraction> a talk on the principles behind this library with <https://github.com/well-typed/optics/raw/master/Talk.pdf accompanying slides> by Adam Gundry (but note that the design details of @optics@ have changed substantially since this talk was given) +-- === Talks +-- +-- * (2020-10) <https://skillsmatter.com/skillscasts/14906-user-friendly-optics User Friendly Optics> - a talk about the @optics@ library in comparison to the @lens@ library by Andrzej Rybczak +-- +-- * (2020-06) <https://www.youtube.com/watch?v=geV8F59q48E Basic optics: lenses, prisms, and traversals> - an introductory talk about this library by Alejandro Serrano +-- +-- * (2018-10) <https://skillsmatter.com/skillscasts/12360-profunctors-and-data-accessors Profunctors and Data Accessors> - a talk on basics of profunctors and how they relate to data accessors such as lenses, prisms and traversals by Andrzej Rybczak +-- +-- * (2017-10) <https://skillsmatter.com/skillscasts/10692-through-a-glass-abstractly-lenses-and-the-power-of-abstraction Through a Glass, Abstractly: Lenses and the Power of Abstraction> - a talk on the principles behind this library with <https://github.com/well-typed/optics/raw/master/Talk.pdf accompanying slides> by Adam Gundry (but note that the design details of @optics@ have changed substantially since this talk was given) +-- +-- === Articles -- --- * <https://skillsmatter.com/skillscasts/12360-profunctors-and-data-accessors Profunctors and Data Accessors> a talk on basics of profunctors and how they relate to data accessors such as lenses, prisms and traversals by Andrzej Rybczak +-- * (2020-01) <https://oleg.fi/gists/posts/2020-01-25-case-study-migration-from-lens-to-optics.html Case study: migrating from lens to optics> - a blog post by Oleg Grenrus, potentially useful if you wish to migrate an existing codebase to @optics@ from @lens@ -- --- * <https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf Profunctor Optics: Modular Data Accessors> a paper by Matthew Pickering, Jeremy Gibbons and Nicolas Wu +-- * (2017-04) <https://oleg.fi/gists/posts/2017-04-18-glassery.html Glassery> and <https://oleg.fi/gists/posts/2017-04-26-indexed-poptics.html Indexed Profunctor optics> - blog posts by Oleg Grenrus on the internal representations used by this library -- --- * <https://oleg.fi/gists/posts/2017-04-18-glassery.html Glassery> and <https://oleg.fi/gists/posts/2017-04-26-indexed-poptics.html Indexed Profunctor optics>, blog posts by Oleg Grenrus +-- * (2017-03) <https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf Profunctor Optics: Modular Data Accessors> - a paper by Matthew Pickering, Jeremy Gibbons and Nicolas Wu +-- +-- === Libraries -- -- * The <https://hackage.haskell.org/package/lens lens> package by Edward Kmett and contributors +-- -- $basicusage @@ -866,6 +882,30 @@ -- -- <<diagrams/indexedoptics.png Indexed Optics>> + +-- $monoids +-- +-- There are two ways to combine (possibly indexed) folds, traversals and +-- related optics with the same outer and inner types: +-- +-- * Visit all the targets of the first optic, then all the targets of the +-- second optic. This makes sense for folds ('summing' or 'isumming') and +-- traversals ('adjoin' or 'iadjoin'), provided in the latter case that the +-- targets are disjoint. +-- +-- * Visit the targets of the first optic if there are any, or if not, visit the +-- targets of the second optic. This makes sense for folds ('failing' or +-- 'ifailing') and affine folds ('afailing' or 'iafailing'). +-- +-- These operations form monoid structures on the appropriate optic kinds, with +-- the identity element 'ignored', which visits no targets. +-- +-- There is no 'Semigroup' or 'Monoid' instance for 'Optic', because there is +-- not a unique choice of monoid to use, and the ('<>') operator could not be +-- used to combine optics of different kinds. When porting code from @lens@ that +-- uses ('<>') to combine folds, use 'summing' instead. + + -- $cheatsheet -- -- The following table summarizes the key optic kinds and their combinators. @@ -955,9 +995,11 @@ -- +--------------+-----------------+-------------------------------------------+------------------------------+-------------------------------+-------------------------------------------+ -- $setup +-- >>> :set -XFlexibleContexts -- >>> import Control.Monad.Reader -- >>> import Control.Monad.State -- >>> import Data.Functor.Identity +-- >>> import Data.Proxy -- >>> import qualified Data.IntSet as IntSet -- >>> import qualified Data.Map as Map -- >>> import Optics.State.Operators diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests/Core.hs new/optics-0.4/tests/Optics/Tests/Core.hs --- old/optics-0.3/tests/Optics/Tests/Core.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/tests/Optics/Tests/Core.hs 2001-09-09 03:46:40.000000000 +0200 @@ -26,7 +26,7 @@ , testCase "optimized rhs03" $ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs03) , testCase "traverseOf_ (folded % folded) = traverseOf_ (ifolded % ifolded)" $ - assertSuccess $(inspectTest $ 'lhs04 === 'rhs04) + assertSuccess $(inspectTest $ 'lhs04 ==- 'rhs04) , testCase "optimized lhs04" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs04) , testCase "optimized rhs04" $ @@ -60,14 +60,15 @@ , 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) + -- GHC 9.0.1 splits the rhs into two bindings + ghc90failure $(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) + -- GHC 8.2 gives a different order of let bindings + ghc82failure $(inspectTest $ 'lhs10 === 'rhs10) , testCase "optimized lhs10a" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs10a) , testCase "optimized rhs10a" $ @@ -91,7 +92,7 @@ , testCase "optimized rhs13" $ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs13) , testCase "traverseOf_ itraversed = traverseOf_ folded" $ - assertSuccess $(inspectTest $ 'lhs14 === 'rhs14) + assertSuccess $(inspectTest $ 'lhs14 ==- 'rhs14) , testCase "optimized lhs14a" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs14a) , testCase "optimized rhs14a" $ @@ -103,9 +104,7 @@ , 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) + assertSuccess $(inspectTest $ 'lhs16 === 'rhs16) , testCase "optimized lhs16" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs16) , testCase "optimized rhs16" $ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests/Eta.hs new/optics-0.4/tests/Optics/Tests/Eta.hs --- old/optics-0.3/tests/Optics/Tests/Eta.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/tests/Optics/Tests/Eta.hs 2001-09-09 03:46:40.000000000 +0200 @@ -32,8 +32,8 @@ , 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) + -- The lhs has more lets which the rhs inlines. + ghc82and90failure $(inspectTest $ 'eta6lhs === 'eta6rhs) , testCase "optimized eta6lhs" $ assertSuccess $(inspectTest $ hasNoProfunctors 'eta6lhs) , testCase "over mapped = \\f -> over mapped f" $ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests/Labels/Generic.hs new/optics-0.4/tests/Optics/Tests/Labels/Generic.hs --- old/optics-0.3/tests/Optics/Tests/Labels/Generic.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/optics-0.4/tests/Optics/Tests/Labels/Generic.hs 2001-09-09 03:46:40.000000000 +0200 @@ -0,0 +1,168 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-} +module Optics.Tests.Labels.Generic where + +import Data.Ord +import GHC.Generics (Generic) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Inspection + +import Optics +import Optics.Tests.Utils + +data Mammal + = Dog { name :: String, age :: Int } + | Cat { name :: String, age :: Int, lazy :: Bool } + deriving (Show, Generic) + +data Fish + = GoldFish { name :: String } + | Herring { name :: String } + deriving (Show, Generic) + +data Human a = Human + { name :: String + , age :: Int + , fish :: Fish + , pets :: [a] + } + deriving (Show, Generic) + +---------------------------------------- + +genericLabelsTests :: TestTree +genericLabelsTests = testGroup "Labels via Generic" + [ + testCase "view #name s = name s" $ + assertSuccess $(inspectTest $ 'label1lhs ==- 'label1rhs) + , testCase "set #pets s b = s { pets = b }" $ + assertSuccess $(inspectTest $ 'label2lhs ==- 'label2rhs) + , testCase "view (#fish % #name) s = name (fish s)" $ + assertSuccess $(inspectTest $ 'label3lhs ==- 'label3rhs) + , testCase "set (#fish % #name) b s = s { fish = ... }" $ + assertSuccess $(inspectTest $ 'label4lhs ==- 'label4rhs) + , testCase "set (#pets % traversed % #name) b s = s { pets = ... }" $ + -- GHC 8.2 is the same modulo a case expression structure + ghc82failure $(inspectTest $ 'label5lhs ==- 'label5rhs) + , testCase "multiple set with labels = multiple set with record syntax" $ + assertSuccess $(inspectTest $ 'label6lhs ==- 'label6rhs) + , testCase "optimized petNames (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'petNames) + , testCase "optimized otherHuman (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'otherHuman) + , testCase "optimized humanWithFish (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'humanWithFish) + , testCase "optimized howManyGoldFish (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'howManyGoldFish) + , testCase "optimized hasLazyPets (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'hasLazyPets) + , testCase "optimized yearLater (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'yearLater) + , testCase "optimized oldestPet (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'oldestPet) + , testCase "optimized luckyDog (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'luckyDog) + ] + +label1lhs, label1rhs :: forall a. Human a -> String +label1lhs s = view #name s +label1rhs s = name (s :: Human a) + +label2lhs, label2rhs :: Human a -> [b] -> Human b +label2lhs s b = set #pets b s +label2rhs s b = s { pets = b } + +label3lhs, label3rhs :: Human a -> String +label3lhs s = view (#fish % #name) s +label3rhs s = name (fish s :: Fish) + +label4lhs, label4rhs :: Human a -> String -> Human a +label4lhs s b = set (#fish % #name) b s +label4rhs s b = s { fish = (fish s) { name = b } } + +label5lhs, label5rhs :: Human Mammal -> Bool -> Human Mammal +label5lhs s b = set (#pets % traversed % gafield @"lazy") b s +label5rhs s b = s { pets = (`map` pets s) $ \case + Dog name age -> Dog{..} + Cat name age _ -> Cat { lazy = b, .. } + } + +label6lhs, label6rhs :: Human a -> String -> Int -> String -> [b] -> Human b +label6lhs = label6setter +label6rhs s name_ age_ fishName_ pets_ = s + { name = name_ + , age = age_ + , fish = case fish s of + GoldFish{} -> GoldFish fishName_ + herring -> herring + , pets = pets_ + } + +-- | Check that the setter compiles in full generality. +label6setter + :: ( Is k1 A_Setter + , Is k2 A_Setter + , Is k3 A_Setter + , Is k4 A_Setter + , JoinKinds k5 l k4 + , LabelOptic "_GoldFish" l u v a1 b1 + , LabelOptic "age" k2 s1 s2 a2 b2 + , LabelOptic "fish" k5 s2 s3 u v + , LabelOptic "name" k3 s4 s1 a3 b3 + , LabelOptic "pets" k1 s3 b4 a4 b5 + ) => s4 -> b3 -> b2 -> b1 -> b5 -> b4 +label6setter s name_ age_ fishName_ pets_ = s + & #name .~ name_ + & #age .~ age_ + & #fish % #_GoldFish .~ fishName_ + & #pets .~ pets_ + +---------------------------------------- +-- Basic data manipulation + +human :: Human Mammal +human = Human + { name = "Andrzej" + , age = 30 + , fish = GoldFish "Goldie" + , pets = [Dog "Rocky" 3, Cat "Pickle" 4 True, Cat "Max" 1 False] + } + +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 % gafield @"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" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests/Labels/TH.hs new/optics-0.4/tests/Optics/Tests/Labels/TH.hs --- old/optics-0.3/tests/Optics/Tests/Labels/TH.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/optics-0.4/tests/Optics/Tests/Labels/TH.hs 2001-09-09 03:46:40.000000000 +0200 @@ -0,0 +1,194 @@ +{-# 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.TH 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 + +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 + +---------------------------------------- + +thLabelsTests :: TestTree +thLabelsTests = testGroup "Labels via Template Haskell" + [ + 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_ + } + +---------------------------------------- +-- Basic data manipulation + +human :: Human Mammal +human = Human + { humanName = "Andrzej" + , humanAge = 30 + , humanFish = GoldFish "Goldie" + , humanPets = [Dog "Rocky" 3, Cat "Pickle" 4 True, Cat "Max" 1 False] + } + +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 + (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 } +makeFieldLabels ''Env + +data Nested = Nested { nestedName :: String, nestedEnv :: Env } +makeFieldLabels ''Nested + +instance + (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 () +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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests/Labels.hs new/optics-0.4/tests/Optics/Tests/Labels.hs --- old/optics-0.3/tests/Optics/Tests/Labels.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/tests/Optics/Tests/Labels.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,194 +0,0 @@ -{-# 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 - -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" - [ - 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_ - } - ----------------------------------------- --- Basic data manipulation - -human :: Human Mammal -human = Human - { humanName = "Andrzej" - , humanAge = 30 - , humanFish = GoldFish "Goldie" - , humanPets = [Dog "Rocky" 3, Cat "Pickle" 4 True, Cat "Max" 1 False] - } - -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 - (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 } -makeFieldLabels ''Env - -data Nested = Nested { nestedName :: String, nestedEnv :: Env } -makeFieldLabels ''Nested - -instance - (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 () -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests/Misc.hs new/optics-0.4/tests/Optics/Tests/Misc.hs --- old/optics-0.3/tests/Optics/Tests/Misc.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/tests/Optics/Tests/Misc.hs 2001-09-09 03:46:40.000000000 +0200 @@ -22,13 +22,25 @@ , testCase "optimized itoList" $ assertSuccess $(inspectTest $ hasNoProfunctors 'checkitoListOf) , testCase "optimized partsOf" $ - ghc80failure $(inspectTest $ hasNoProfunctors 'checkPartsOf) + assertSuccess $(inspectTest $ hasNoProfunctors 'checkPartsOf) , testCase "optimized singular" $ - ghc80failure $(inspectTest $ hasNoProfunctors 'checkSingular) + assertSuccess $(inspectTest $ hasNoProfunctors 'checkSingular) , testCase "optimized filteredBy" $ assertSuccess $(inspectTest $ hasNoProfunctors 'checkFilteredBy) , testCase "optimized unsafeFilteredBy" $ assertSuccess $(inspectTest $ hasNoProfunctors 'checkUnsafeFilteredBy) + -- GHC <= 8.4 doesn't optimize away profunctor classes + , testCase "optimized adjoin" $ + ghcLE84failure $(inspectTest $ hasNoProfunctors 'checkAdjoin) + -- GHC <= 8.4 doesn't optimize away profunctor classes + , testCase "optimized iadjoin" $ + ghcLE84failure $(inspectTest $ hasNoProfunctors 'checkIxAdjoin) + , testCase "optimized gplate (profunctors)" $ + assertSuccess $(inspectTest $ hasNoProfunctors 'checkGplate) + , testCase "optimized gplate (generics)" $ + assertSuccess $(inspectTest $ hasNoGenericRep 'checkGplate) + , testCase "optimized icomposeN/appendIndices" $ + assertSuccess $ $(inspectTest $ hasNoIndexClasses 'checkNoIndexFunctions) ] simpleMapIx @@ -71,3 +83,29 @@ -> Either a1 (a, Maybe i) -> f (Either a1 (a, Maybe i)) checkUnsafeFilteredBy = iatraverseOf (unsafeFilteredBy (_Right % _2 % _Just)) pure + +checkAdjoin :: (a -> a) -> (Maybe a, Either a a, [a]) -> (Maybe a, Either a a, [a]) +checkAdjoin = over (_1 % _Just `adjoin` _2 % chosen `adjoin` _3 % traversed) + +checkIxAdjoin :: (Int -> a -> a) -> ((Int, a), [a], (Int, Maybe a)) -> ((Int, a), [a], (Int, Maybe a)) +checkIxAdjoin = iover (_1 % itraversed `iadjoin` _2 % itraversed `iadjoin` _3 % itraversed % _Just) + +checkGplate + :: (Char, ([Either Char ()], Char, Maybe Char), [Char], Either Char Int) + -> [Char] +checkGplate = toListOf gplate + +checkNoIndexFunctions + :: ( TraversableWithIndex i1 f1, TraversableWithIndex i2 f2 + , TraversableWithIndex i3 f3, TraversableWithIndex i4 f4 + , TraversableWithIndex i5 f5, TraversableWithIndex i6 f6 + , TraversableWithIndex i7 f7, TraversableWithIndex i8 f8 + ) => Optic A_Traversal + (WithIx (i1, i2, i3, i4, i5, i6, i7, i8)) + (f1 (f2 (f3 (f4 (f5 (f6 (f7 (f8 a)))))))) + (f1 (f2 (f3 (f4 (f5 (f6 (f7 (f8 b)))))))) + a + b +checkNoIndexFunctions + = icomposeN (,,,,,,,) $ (((itraversed % itraversed) % itraversed) % itraversed) + % (itraversed % (itraversed % (itraversed % itraversed))) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests/Utils.hs new/optics-0.4/tests/Optics/Tests/Utils.hs --- old/optics-0.3/tests/Optics/Tests/Utils.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/tests/Optics/Tests/Utils.hs 2001-09-09 03:46:40.000000000 +0200 @@ -5,7 +5,9 @@ import Language.Haskell.TH (Name) import Test.Tasty.HUnit import Test.Inspection +import qualified GHC.Generics as G +import Optics.Internal.Optic import qualified Data.Profunctor.Indexed as P hasNoProfunctors :: Name -> Obligation @@ -33,6 +35,29 @@ , 'P.iwander , 'P.roam , 'P.iroam + , 'appendIndices + , 'composeN + ] + +hasNoIndexClasses :: Name -> Obligation +hasNoIndexClasses name = mkObligation name $ NoUseOf + [ 'appendIndices + , 'composeN + ] + +-- | 'hasNoGenerics' from 'Test.Inspection' checks for lack of data types, but +-- they show up in coercions even though the representation was optimized away; +-- check for functions and data constructors instead. +hasNoGenericRep :: Name -> Obligation +hasNoGenericRep name = mkObligation name $ NoUseOf + [ 'G.from + , 'G.to + , '(G.:*:) + , 'G.K1 + , 'G.L1 + , 'G.M1 + , 'G.R1 + , 'G.U1 ] assertSuccess :: Result -> IO () @@ -43,20 +68,6 @@ 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' @@ -77,3 +88,24 @@ #else ghcGE86failure = assertSuccess #endif + +ghcLE84failure :: Result -> IO () +#if __GLASGOW_HASKELL__ <= 804 +ghcLE84failure = assertFailure' +#else +ghcLE84failure = assertSuccess +#endif + +ghc82and90failure :: Result -> IO () +#if __GLASGOW_HASKELL__ == 802 || __GLASGOW_HASKELL__ == 900 +ghc82and90failure = assertFailure' +#else +ghc82and90failure = assertSuccess +#endif + +ghc90failure :: Result -> IO () +#if __GLASGOW_HASKELL__ == 900 +ghc90failure = assertFailure' +#else +ghc90failure = assertSuccess +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/optics-0.3/tests/Optics/Tests.hs new/optics-0.4/tests/Optics/Tests.hs --- old/optics-0.3/tests/Optics/Tests.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/optics-0.4/tests/Optics/Tests.hs 2001-09-09 03:46:40.000000000 +0200 @@ -8,7 +8,8 @@ import Optics.Tests.Computation import Optics.Tests.Core import Optics.Tests.Eta -import Optics.Tests.Labels +import Optics.Tests.Labels.Generic +import Optics.Tests.Labels.TH import Optics.Tests.Misc import Optics.Tests.Properties @@ -45,7 +46,8 @@ [ testGroup "Inspection" [ coreTests , etaTests - , labelsTests + , genericLabelsTests + , thLabelsTests , miscTests ] , computationTests
