Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-optics-core for openSUSE:Factory
checked in at 2026-06-10 16:04:19
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-optics-core (Old)
and /work/SRC/openSUSE:Factory/.ghc-optics-core.new.2375 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-optics-core"
Wed Jun 10 16:04:19 2026 rev:8 rq:1358414 version:0.4.2
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-optics-core/ghc-optics-core.changes
2024-05-21 18:36:33.094625324 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-optics-core.new.2375/ghc-optics-core.changes
2026-06-10 16:07:23.200108124 +0200
@@ -1,0 +2,14 @@
+Tue Feb 10 19:58:59 UTC 2026 - Peter Simons <[email protected]>
+
+- Update optics-core to version 0.4.2.
+ # optics-core-0.4.2 (2025-02-10)
+ * Rename `PathTree` data constructor to `PathNode`, to avoid pun with type
+ constructor.
+ * Add support for using `gafield` as a label in GHC >= 9.6 using `#"?field"`
+ syntax.
+ * Add `unsafePartsOf` to `Optics.Traversal`.
+ * Add `failing`-like combinators for traversals: `adisjoin`
+ (`Optics.AffineTraversal`), `iadisjoin` (`Optics.IxAffineTraversal`),
+ `idisjoin` (`Optics.IxTraversal`) and `disjoin` (`Optics.Traversal`).
+
+-------------------------------------------------------------------
Old:
----
optics-core-0.4.1.1.tar.gz
optics-core.cabal
New:
----
optics-core-0.4.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-optics-core.spec ++++++
--- /var/tmp/diff_new_pack.a6r5Tu/_old 2026-06-10 16:07:25.664210238 +0200
+++ /var/tmp/diff_new_pack.a6r5Tu/_new 2026-06-10 16:07:25.664210238 +0200
@@ -1,7 +1,7 @@
#
# spec file for package ghc-optics-core
#
-# Copyright (c) 2024 SUSE LLC
+# Copyright (c) 2026 SUSE LLC
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -19,13 +19,12 @@
%global pkg_name optics-core
%global pkgver %{pkg_name}-%{version}
Name: ghc-%{pkg_name}
-Version: 0.4.1.1
+Version: 0.4.2
Release: 0
Summary: Optics as an abstract interface: core definitions
License: BSD-3-Clause
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-array-devel
BuildRequires: ghc-array-prof
@@ -44,10 +43,9 @@
%description
This package makes it possible to define and use Lenses, Traversals, Prisms and
-other optics, using an abstract interface.
-
-This variant provides core definitions with a minimal dependency footprint.
-See the '<https://hackage.haskell.org/package/optics optics>' package (and its
+other optics, using an abstract interface. . This variant provides core
+definitions with a minimal dependency footprint. See the
+'<https://hackage.haskell.org/package/optics optics>' package (and its
dependencies) for documentation and the "batteries-included" variant.
%package devel
@@ -78,7 +76,6 @@
%prep
%autosetup -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
++++++ optics-core-0.4.1.1.tar.gz -> optics-core-0.4.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/CHANGELOG.md
new/optics-core-0.4.2/CHANGELOG.md
--- old/optics-core-0.4.1.1/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
+++ new/optics-core-0.4.2/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200
@@ -1,3 +1,13 @@
+# optics-core-0.4.2 (2025-02-10)
+* Rename `PathTree` data constructor to `PathNode`, to avoid pun with type
+ constructor.
+* Add support for using `gafield` as a label in GHC >= 9.6 using `#"?field"`
+ syntax.
+* Add `unsafePartsOf` to `Optics.Traversal`.
+* Add `failing`-like combinators for traversals: `adisjoin`
+ (`Optics.AffineTraversal`), `iadisjoin` (`Optics.IxAffineTraversal`),
+ `idisjoin` (`Optics.IxTraversal`) and `disjoin` (`Optics.Traversal`).
+
# optics-core-0.4.1.1 (2023-06-22)
* Add INLINE pragmas to small functions that really should inline
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/optics-core.cabal
new/optics-core-0.4.2/optics-core.cabal
--- old/optics-core-0.4.1.1/optics-core.cabal 2001-09-09 03:46:40.000000000
+0200
+++ new/optics-core-0.4.2/optics-core.cabal 2001-09-09 03:46:40.000000000
+0200
@@ -1,13 +1,15 @@
-cabal-version: 2.2
+cabal-version: 3.0
name: optics-core
-version: 0.4.1.1
+version: 0.4.2
license: BSD-3-Clause
license-file: LICENSE
build-type: Simple
maintainer: [email protected]
author: Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus
-tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7
- || ==9.0.2 || ==9.2.8 || ==9.4.5 || ==9.6.2, GHCJS ==8.4
+tested-with: GHC == { 8.2.2, 8.4.4, 8.6.5, 8.8.4, 8.10.7, 9.0.2, 9.2.8
+ , 9.4.8, 9.6.7, 9.8.4, 9.10.3, 9.12.2, 9.14.1
+ }
+ GHCJS == { 8.4 }
synopsis: Optics as an abstract interface: core definitions
category: Data, Optics, Lenses
description:
@@ -35,11 +37,17 @@
common language
ghc-options: -Wall -Wcompat
+ if impl(ghc <9.4)
+ ghc-options: -Wno-unticked-promoted-constructors
default-language: Haskell2010
+ if impl(ghc < 8.6)
+ default-extensions: TypeInType
+
default-extensions: BangPatterns
ConstraintKinds
+ DataKinds
DefaultSignatures
DeriveFoldable
DeriveFunctor
@@ -56,6 +64,7 @@
LambdaCase
OverloadedLabels
PatternSynonyms
+ PolyKinds
RankNTypes
ScopedTypeVariables
TupleSections
@@ -73,7 +82,7 @@
build-depends: base >= 4.10 && <5
, array >= 0.5.2.0 && <0.6
- , containers >= 0.5.10.2 && <0.7
+ , containers >= 0.5.10.2 && <0.9
, indexed-profunctors >= 0.1 && <0.2
, transformers >= 0.5 && <0.7
, indexed-traversable >= 0.1 && <0.2
@@ -154,3 +163,5 @@
Optics.Internal.Setter
Optics.Internal.Traversal
Optics.Internal.Utils
+
+ x-docspec-options: -XTypeApplications -XTypeOperators -XFlexibleContexts
-XStandaloneDeriving -XDeriveGeneric -XDataKinds -XOverloadedLabels
-XTupleSections
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Data/IntMap/Optics.hs
new/optics-core-0.4.2/src/Data/IntMap/Optics.hs
--- old/optics-core-0.4.1.1/src/Data/IntMap/Optics.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Data/IntMap/Optics.hs 2001-09-09
03:46:40.000000000 +0200
@@ -50,6 +50,11 @@
import Optics.IxFold
import Optics.Optic
+-- $setup
+-- >>> import qualified Data.IntMap as IntMap
+-- >>> import Data.Monoid (Sum (..))
+-- >>> import Optics.Core
+
-- | Construct a map from an 'IxFold'.
--
-- The construction is left-biased (see 'IntMap.union'), i.e. the first
occurrences of
@@ -132,7 +137,3 @@
Nothing -> point s
Just (k', v) -> f k' v <&> \v' -> IntMap.insert k' v' s
{-# INLINE ge #-}
-
--- $setup
--- >>> import Data.Monoid
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Data/IntSet/Optics.hs
new/optics-core-0.4.2/src/Data/IntSet/Optics.hs
--- old/optics-core-0.4.1.1/src/Data/IntSet/Optics.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Data/IntSet/Optics.hs 2001-09-09
03:46:40.000000000 +0200
@@ -17,6 +17,10 @@
import Optics.Optic
import Optics.Setter
+-- $setup
+-- >>> import qualified Data.IntSet as IntSet
+-- >>> import Optics.Core
+
-- | IntSet isn't Foldable, but this 'Fold' can be used to access the members
of
-- an 'IntSet'.
--
@@ -49,6 +53,3 @@
setOf :: Is k A_Fold => Optic' k is s Int -> s -> IntSet
setOf l = foldMapOf l IntSet.singleton
{-# INLINE setOf #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Data/Map/Optics.hs
new/optics-core-0.4.2/src/Data/Map/Optics.hs
--- old/optics-core-0.4.1.1/src/Data/Map/Optics.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Data/Map/Optics.hs 2001-09-09
03:46:40.000000000 +0200
@@ -57,6 +57,11 @@
import Optics.IxFold
import Optics.Optic
+-- $setup
+-- >>> import qualified Data.Map as Map
+-- >>> import Data.Monoid (Sum (..))
+-- >>> import Optics.Core
+
-- | Construct a map from an 'IxFold'.
--
-- The construction is left-biased (see 'Map.union'), i.e. the first
@@ -139,7 +144,3 @@
Nothing -> point s
Just (k', v) -> f k' v <&> \v' -> Map.insert k' v' s
{-# INLINE ge #-}
-
--- $setup
--- >>> import Data.Monoid
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Data/Sequence/Optics.hs
new/optics-core-0.4.2/src/Data/Sequence/Optics.hs
--- old/optics-core-0.4.1.1/src/Data/Sequence/Optics.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Data/Sequence/Optics.hs 2001-09-09
03:46:40.000000000 +0200
@@ -20,6 +20,11 @@
import Optics.Optic
import Optics.Traversal
+-- $setup
+-- >>> import Data.Sequence (ViewL (..), ViewR (..))
+-- >>> import qualified Data.Sequence as Seq
+-- >>> import Optics.Core
+
-- * Sequence isomorphisms
-- | A 'Seq' is isomorphic to a 'ViewL'
@@ -136,6 +141,3 @@
seqOf :: Is k A_Fold => Optic' k is s a -> s -> Seq a
seqOf l = foldMapOf l Seq.singleton
{-# INLINE seqOf #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Data/Set/Optics.hs
new/optics-core-0.4.2/src/Data/Set/Optics.hs
--- old/optics-core-0.4.1.1/src/Data/Set/Optics.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Data/Set/Optics.hs 2001-09-09
03:46:40.000000000 +0200
@@ -16,6 +16,10 @@
import Optics.Optic
import Optics.Setter
+-- $setup
+-- >>> import qualified Data.Set as Set
+-- >>> import Optics.Core
+
-- | This 'Setter' can be used to change the type of a 'Set' by mapping the
-- elements to new values.
--
@@ -39,6 +43,3 @@
setOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Set a
setOf l = foldMapOf l Set.singleton
{-# INLINE setOf #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Data/Tree/Optics.hs
new/optics-core-0.4.2/src/Data/Tree/Optics.hs
--- old/optics-core-0.4.1.1/src/Data/Tree/Optics.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Data/Tree/Optics.hs 2001-09-09
03:46:40.000000000 +0200
@@ -13,6 +13,10 @@
import Optics.Lens
+-- $setup
+-- >>> import Data.Tree (Tree (..))
+-- >>> import Optics.Core
+
-- | A 'Lens' that focuses on the root of a 'Tree'.
--
-- >>> view root $ Node 42 []
@@ -27,6 +31,3 @@
branches :: Lens' (Tree a) [Tree a]
branches = lensVL $ \f (Node a as) -> Node a <$> f as
{-# INLINE branches #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Data/Tuple/Optics.hs
new/optics-core-0.4.2/src/Data/Tuple/Optics.hs
--- old/optics-core-0.4.1.1/src/Data/Tuple/Optics.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Data/Tuple/Optics.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-- |
-- Module: Data.Tuple.Optics
-- Description: 'Lens'es for tuple types.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/AffineFold.hs
new/optics-core-0.4.2/src/Optics/AffineFold.hs
--- old/optics-core-0.4.1.1/src/Optics/AffineFold.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/AffineFold.hs 2001-09-09
03:46:40.000000000 +0200
@@ -60,6 +60,10 @@
import Optics.Internal.Bi
import Optics.Internal.Optic
+-- $setup
+-- >>> import Data.Maybe (listToMaybe)
+-- >>> import Optics.Core
+
-- | Type synonym for an affine fold.
type AffineFold s a = Optic' An_AffineFold NoIx s a
@@ -152,6 +156,3 @@
isn't :: Is k An_AffineFold => Optic' k is s a -> s -> Bool
isn't k s = isNothing (preview k s)
{-# INLINE isn't #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/AffineTraversal.hs
new/optics-core-0.4.2/src/Optics/AffineTraversal.hs
--- old/optics-core-0.4.1.1/src/Optics/AffineTraversal.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/AffineTraversal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -48,6 +48,12 @@
-- * Additional elimination forms
, withAffineTraversal
+ -- * Monoid structure
+ -- | 'AffineTraversal' admits a monoid structure where 'adisjoin' returns the
+ -- result from the second affine traversal only if the first does not return
a
+ -- result. The identity element is 'ignored' (which traverses no elements).
+ , adisjoin
+
-- * Subtyping
, An_AffineTraversal
-- | <<diagrams/AffineTraversal.png AffineTraversal in the optics hierarchy>>
@@ -63,6 +69,10 @@
import Data.Profunctor.Indexed
import Optics.Internal.Optic
+import Optics.Internal.Utils
+
+-- $setup
+-- >>> import Optics.Core
-- | Type synonym for a type-modifying affine traversal.
type AffineTraversal s t a b = Optic An_AffineTraversal NoIx s t a b
@@ -165,6 +175,29 @@
matching o = withAffineTraversal o $ \match _ -> match
{-# INLINE matching #-}
+-- | Try the first 'AffineTraversal'. If it does not return an entry, try the
+-- second one.
+--
+-- >>> over (ix 2 `adisjoin` ix 1) (*5) [1,2,3]
+-- [1,2,15]
+-- >>> over (ix 2 `adisjoin` ix 1) (*5) [1,2]
+-- [1,10]
+--
+-- @since 0.4.3
+--
+adisjoin
+ :: (Is k An_AffineTraversal, Is l An_AffineTraversal)
+ => Optic k is s t a b
+ -> Optic l js s t a b
+ -> AffineTraversal s t a b
+adisjoin a b = atraversalVL $ \point f s ->
+ let OrT visited fu = atraverseOf a (OrT False . point) (wrapOrT . f) s
+ in if visited
+ then fu
+ else atraverseOf b point f s
+infixl 3 `adisjoin` -- Same as (<|>)
+{-# INLINE adisjoin #-}
+
-- | Filter result(s) of a traversal that don't satisfy a predicate.
--
-- /Note:/ This is /not/ a legal 'Optics.Traversal.Traversal', unless you are
@@ -186,6 +219,3 @@
unsafeFiltered :: (a -> Bool) -> AffineTraversal' a a
unsafeFiltered p = atraversalVL (\point f a -> if p a then f a else point a)
{-# INLINE unsafeFiltered #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/At/Core.hs
new/optics-core-0.4.2/src/Optics/At/Core.hs
--- old/optics-core-0.4.1.1/src/Optics/At/Core.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/At/Core.hs 2001-09-09 03:46:40.000000000
+0200
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeInType #-}
-- |
-- Module: Optics.At.Core
-- Description: Optics for 'Map' and 'Set'-like containers.
@@ -69,6 +68,11 @@
import Optics.Optic
import Optics.Setter
+-- $setup
+-- >>> import Optics.Core
+-- >>> import qualified Data.Map as Map
+-- >>> import qualified Data.IntSet as IntSet
+
-- | Type family that takes a key-value container type and returns the type of
-- keys (indices) into the container, for example @'Index' ('Map' k a) ~ k@.
-- This is shared by 'Ixed', 'At' and 'Contains'.
@@ -483,6 +487,3 @@
go (a:as) i = (a:) <$> (go as $! i - 1)
in go xs0 k
{-# INLINE ixListVL #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Each/Core.hs
new/optics-core-0.4.2/src/Optics/Each/Core.hs
--- old/optics-core-0.4.1.1/src/Optics/Each/Core.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Each/Core.hs 2001-09-09
03:46:40.000000000 +0200
@@ -176,25 +176,39 @@
{-# INLINE[1] each #-}
-- | @'each' :: 'IxTraversal' 'Int' [a] [b] a b@
-instance Each Int [a] [b] a b
+instance Each Int [a] [b] a b where
+ each = itraversed
+ {-# INLINE[1] each #-}
-- | @'each' :: 'IxTraversal' 'Int' (NonEmpty a) (NonEmpty b) a b@
-instance Each Int (NonEmpty a) (NonEmpty b) a b
+instance Each Int (NonEmpty a) (NonEmpty b) a b where
+ each = itraversed
+ {-# INLINE[1] each #-}
-- | @'each' :: 'IxTraversal' () ('Identity' a) ('Identity' b) a b@
-instance Each () (Identity a) (Identity b) a b
+instance Each () (Identity a) (Identity b) a b where
+ each = itraversed
+ {-# INLINE[1] each #-}
-- | @'each' :: 'IxTraversal' () ('Maybe' a) ('Maybe' b) a b@
-instance Each () (Maybe a) (Maybe b) a b
+instance Each () (Maybe a) (Maybe b) a b where
+ each = itraversed
+ {-# INLINE[1] each #-}
-- | @'each' :: 'IxTraversal' 'Int' ('Seq' a) ('Seq' b) a b@
-instance Each Int (Seq a) (Seq b) a b
+instance Each Int (Seq a) (Seq b) a b where
+ each = itraversed
+ {-# INLINE[1] each #-}
-- | @'each' :: 'IxTraversal' [Int] ('Tree' a) ('Tree' b) a b@
-instance Each [Int] (Tree a) (Tree b) a b
+instance Each [Int] (Tree a) (Tree b) a b where
+ each = itraversed
+ {-# INLINE[1] each #-}
-- | @'each' :: 'Ix' i => 'IxTraversal' i ('Array' i a) ('Array' i b) a b@
-instance (Ix i, i ~ j) => Each i (Array i a) (Array j b) a b
+instance (Ix i, i ~ j) => Each i (Array i a) (Array j b) a b where
+ each = itraversed
+ {-# INLINE[1] each #-}
-- $setup
-- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Fold.hs
new/optics-core-0.4.2/src/Optics/Fold.hs
--- old/optics-core-0.4.1.1/src/Optics/Fold.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/optics-core-0.4.2/src/Optics/Fold.hs 2001-09-09 03:46:40.000000000
+0200
@@ -106,7 +106,7 @@
import Control.Applicative.Backwards
import Control.Monad
import Data.Foldable
-import Data.Function
+import Data.Function (fix)
import Data.Monoid
import Data.Profunctor.Indexed
@@ -117,6 +117,10 @@
import Optics.Internal.Optic
import Optics.Internal.Utils
+-- $setup
+-- >>> import Optics.Core
+-- >>> import Data.Function (on)
+
-- | Type synonym for a fold.
type Fold s a = Optic' A_Fold NoIx s a
@@ -218,7 +222,7 @@
-- This can be useful to lift operations from @Data.List@ and elsewhere into a
-- 'Fold'.
--
--- >>> toListOf (folding tail) [1,2,3,4]
+-- >>> toListOf (folding (drop 1)) [1,2,3,4]
-- [2,3,4]
folding :: Foldable f => (s -> f a) -> Fold s a
folding f = Optic (contrafirst f . foldVL__ traverse_)
@@ -707,6 +711,3 @@
where
go a = f a (go <$> toListOf o a)
{-# INLINE paraOf #-}
-
--- $setup
--- >>> import Optics.Core
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Generic.hs
new/optics-core-0.4.2/src/Optics/Generic.hs
--- old/optics-core-0.4.1.1/src/Optics/Generic.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Generic.hs 2001-09-09 03:46:40.000000000
+0200
@@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module: Optics.Generic
@@ -53,6 +52,11 @@
import Optics.Prism
import Optics.Traversal
+-- $setup
+-- >>> import GHC.Generics (Generic)
+-- >>> import Optics.Core
+-- >>> newtype NoG = NoG { fromNoG :: Char }
+
-- | Hidden type for preventing GHC from solving constraints too early.
data Void0
@@ -176,6 +180,14 @@
-- ...In the...
-- ...
--
+-- /Note:/ 'gafield' is supported by 'Optics.Label.labelOptic' and can be used
+-- with a concise syntax via @OverloadedLabels@ with GHC >= 9.6.
+--
+-- @
+-- λ> herring ^? #"?name"
+-- Just \"Henry\"
+-- @
+--
-- @since 0.4
--
class GAffineField (name :: Symbol) s t a b | name s -> t a b
@@ -361,7 +373,7 @@
gplate :: Traversal' s a
instance GPlateContext a s => GPlate a s where
- gplate = traversalVL (gplateInner @'True)
+ gplate = traversalVL (gplateInner @True)
{-# INLINE gplate #-}
-- | Hide implementation from haddock.
@@ -377,7 +389,3 @@
instance GPlate Void0 a where
gplate = error "unreachable"
--- $setup
--- >>> :set -XDataKinds -XDeriveGeneric -XStandaloneDeriving -XOverloadedLabels
--- >>> import Optics.Core
--- >>> newtype NoG = NoG { fromNoG :: Char }
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Indexed/Core.hs
new/optics-core-0.4.2/src/Optics/Indexed/Core.hs
--- old/optics-core-0.4.1.1/src/Optics/Indexed/Core.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Indexed/Core.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-- |
-- Module: Optics.Indexed.Core
-- Description: Core definitions for indexed optics.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/optics-core-0.4.1.1/src/Optics/Internal/Generic/TypeLevel.hs
new/optics-core-0.4.2/src/Optics/Internal/Generic/TypeLevel.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Generic/TypeLevel.hs
2001-09-09 03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Generic/TypeLevel.hs
2001-09-09 03:46:40.000000000 +0200
@@ -1,5 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -33,7 +31,7 @@
-- a data type. Computed up front by generic optics for early error reporting
-- and efficient data traversal.
data PathTree e
- = PathTree (PathTree e) (PathTree e)
+ = PathNode (PathTree e) (PathTree e)
| PathLeaf (Either e [Path])
data Path = PathLeft | PathRight
@@ -44,12 +42,12 @@
-- | Compute paths to a field with a specific name.
type family GetFieldPaths s (name :: Symbol) g :: PathTree Symbol where
GetFieldPaths s name (M1 D _ g) = GetFieldPaths s name g
- GetFieldPaths s name (g1 :+: g2) = 'PathTree (GetFieldPaths s name g1)
- (GetFieldPaths s name g2)
- GetFieldPaths s name (M1 C _ g) = 'PathLeaf (GetNamePath name g '[])
+ GetFieldPaths s name (g1 :+: g2) = PathNode (GetFieldPaths s name g1)
+ (GetFieldPaths s name g2)
+ GetFieldPaths s name (M1 C _ g) = PathLeaf (GetNamePath name g '[])
- GetFieldPaths s name V1 = TypeError ('Text "Type " ':<>: QuoteType s ':<>:
- 'Text " has no data constructors")
+ GetFieldPaths s name V1 = TypeError (Text "Type " :<>: QuoteType s :<>:
+ Text " has no data constructors")
-- | Compute path to a constructor in a sum or a field in a product with a
-- specific name.
@@ -57,16 +55,16 @@
GetNamePath name (M1 D _ g) acc = GetNamePath name g acc
-- Find path to a constructor in a sum type.
- GetNamePath name (M1 C ('MetaCons name _ _) _) acc = 'Right (Reverse acc '[])
- GetNamePath name (g1 :+: g2) acc = FirstRight (GetNamePath name g1
('PathLeft : acc))
- (GetNamePath name g2
('PathRight : acc))
+ GetNamePath name (M1 C (MetaCons name _ _) _) acc = Right (Reverse acc '[])
+ GetNamePath name (g1 :+: g2) acc = FirstRight (GetNamePath name g1 (PathLeft
: acc))
+ (GetNamePath name g2
(PathRight : acc))
-- Find path to a field in a product type.
- GetNamePath name (M1 S ('MetaSel ('Just name) _ _ _) _) acc = 'Right
(Reverse acc '[])
- GetNamePath name (g1 :*: g2) acc = FirstRight (GetNamePath name g1
('PathLeft : acc))
- (GetNamePath name g2
('PathRight : acc))
+ GetNamePath name (M1 S (MetaSel (Just name) _ _ _) _) acc = Right (Reverse
acc '[])
+ GetNamePath name (g1 :*: g2) acc = FirstRight (GetNamePath name g1 (PathLeft
: acc))
+ (GetNamePath name g2
(PathRight : acc))
- GetNamePath name _ _ = 'Left name
+ GetNamePath name _ _ = Left name
----------------------------------------
-- Paths to a position
@@ -74,12 +72,12 @@
-- | Compute paths to a field at a specific position.
type family GetPositionPaths s (pos :: Nat) g :: PathTree (Nat, Nat) where
GetPositionPaths s pos (M1 D _ g) = GetPositionPaths s pos g
- GetPositionPaths s pos (g1 :+: g2) = 'PathTree (GetPositionPaths s pos g1)
- (GetPositionPaths s pos g2)
- GetPositionPaths s pos (M1 C _ g) = 'PathLeaf (GetPositionPath pos g 0 '[])
+ GetPositionPaths s pos (g1 :+: g2) = PathNode (GetPositionPaths s pos g1)
+ (GetPositionPaths s pos g2)
+ GetPositionPaths s pos (M1 C _ g) = PathLeaf (GetPositionPath pos g 0 '[])
- GetPositionPaths s pos V1 = TypeError ('Text "Type " ':<>: QuoteType s ':<>:
- 'Text " has no data constructors")
+ GetPositionPaths s pos V1 = TypeError (Text "Type " :<>: QuoteType s :<>:
+ Text " has no data constructors")
-- | Compute path to a constructor in a sum or a field in a product at a
-- specific position.
@@ -89,25 +87,25 @@
-- Find field at a position in a sum type.
GetPositionPath pos (M1 C _ _) k acc =
- If (pos == k + 1) ('Right (Reverse acc '[])) ('Left '(pos, k + 1))
+ If (pos == k + 1) (Right (Reverse acc '[])) (Left '(pos, k + 1))
GetPositionPath pos (g1 :+: g2) k acc =
- ContinueWhenLeft (GetPositionPath pos g1 k ('PathLeft : acc)) g2 acc
+ ContinueWhenLeft (GetPositionPath pos g1 k (PathLeft : acc)) g2 acc
-- Find field at a position in a product type.
GetPositionPath pos (M1 S _ _) k acc =
- If (pos == k + 1) ('Right (Reverse acc '[])) ('Left '(pos, k + 1))
+ If (pos == k + 1) (Right (Reverse acc '[])) (Left '(pos, k + 1))
GetPositionPath pos (g1 :*: g2) k acc =
- ContinueWhenLeft (GetPositionPath pos g1 k ('PathLeft : acc)) g2 acc
+ ContinueWhenLeft (GetPositionPath pos g1 k (PathLeft : acc)) g2 acc
-- The second element is the number of fields in the data constructor.
- GetPositionPath pos _ k _ = 'Left '(pos, k)
+ GetPositionPath pos _ k _ = Left '(pos, k)
-- | If the left branch had the position we're looking for, return it.
Otherwise
-- continue with the right branch.
type family ContinueWhenLeft (r :: Either (Nat, Nat) [Path]) g acc
:: Either (Nat, Nat) [Path] where
- ContinueWhenLeft ('Right path) _ _ = 'Right path
- ContinueWhenLeft ('Left '(pos, k)) g acc = GetPositionPath pos g k
('PathRight : acc)
+ ContinueWhenLeft (Right path) _ _ = Right path
+ ContinueWhenLeft (Left '(pos, k)) g acc = GetPositionPath pos g k (PathRight
: acc)
----------------------------------------
-- Misc
@@ -121,11 +119,11 @@
-- | Check if any leaf in the tree has a '[Path]'.
type family AnyHasPath (path :: PathTree e) :: Bool where
- AnyHasPath ('PathTree path1 path2) = AnyHasPath path1 || AnyHasPath path2
- AnyHasPath ('PathLeaf ('Right _)) = 'True
- AnyHasPath ('PathLeaf ('Left _ )) = 'False
+ AnyHasPath (PathNode path1 path2) = AnyHasPath path1 || AnyHasPath path2
+ AnyHasPath (PathLeaf (Right _)) = True
+ AnyHasPath (PathLeaf (Left _ )) = False
type family NoGenericError t where
NoGenericError t = TypeError
- ('Text "Type " ':<>: QuoteType t ':<>:
- 'Text " doesn't have a Generic instance")
+ (Text "Type " :<>: QuoteType t :<>:
+ Text " doesn't have a Generic instance")
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Internal/Generic.hs
new/optics-core-0.4.2/src/Optics/Internal/Generic.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Generic.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Generic.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -130,7 +129,7 @@
instance
( GSetFieldSum path1 g1 h1 b
, GSetFieldSum path2 g2 h2 b
- ) => GSetFieldSum ('PathTree path1 path2) (g1 :+: g2) (h1 :+: h2) b where
+ ) => GSetFieldSum (PathNode path1 path2) (g1 :+: g2) (h1 :+: h2) b where
gsetFieldSum (L1 x) = L1 . gsetFieldSum @path1 x
gsetFieldSum (R1 y) = R1 . gsetFieldSum @path2 y
{-# INLINE gsetFieldSum #-}
@@ -139,15 +138,15 @@
( path ~ GSetFieldPath con epath
, When (IsLeft epath) (HideReps g h)
, GSetFieldProd path g h b
- ) => GSetFieldSum ('PathLeaf epath) (M1 C ('MetaCons con fix hs) g)
- (M1 C ('MetaCons con fix hs) h) b where
+ ) => GSetFieldSum (PathLeaf epath) (M1 C (MetaCons con fix hs) g)
+ (M1 C (MetaCons con fix hs) h) b where
gsetFieldSum (M1 x) = M1 . gsetFieldProd @path x
type family GSetFieldPath (con :: Symbol) (e :: Either Symbol [Path]) ::
[Path] where
- GSetFieldPath _ ('Right path) = path
- GSetFieldPath con ('Left name) = TypeError
- ('Text "Data constructor " ':<>: QuoteSymbol con ':<>:
- 'Text " doesn't have a field named " ':<>: QuoteSymbol name)
+ GSetFieldPath _ (Right path) = path
+ GSetFieldPath con (Left name) = TypeError
+ (Text "Data constructor " :<>: QuoteSymbol con :<>:
+ Text " doesn't have a field named " :<>: QuoteSymbol name)
class GSetFieldProd (path :: [Path]) g h b | path h -> b
, path g b -> h where
@@ -156,27 +155,27 @@
-- fast path left
instance {-# OVERLAPPING #-}
( GSetFieldProd path g1 h1 b
- ) => GSetFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: g2) b where
+ ) => GSetFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: g2) b where
gsetFieldProd (x :*: y) = (:*: y) . gsetFieldProd @path x
-- slow path left
instance
( GSetFieldProd path g1 h1 b
, g2 ~ h2
- ) => GSetFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: h2) b where
+ ) => GSetFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: h2) b where
gsetFieldProd (x :*: y) = (:*: y) . gsetFieldProd @path x
-- fast path right
instance {-# OVERLAPPING #-}
( GSetFieldProd path g2 h2 b
- ) => GSetFieldProd ('PathRight : path) (g1 :*: g2) (g1 :*: h2) b where
+ ) => GSetFieldProd (PathRight : path) (g1 :*: g2) (g1 :*: h2) b where
gsetFieldProd (x :*: y) = (x :*:) . gsetFieldProd @path y
-- slow path right
instance
( GSetFieldProd path g2 h2 b
, g1 ~ h1
- ) => GSetFieldProd ('PathRight : path) (g1 :*: g2) (h1 :*: h2) b where
+ ) => GSetFieldProd (PathRight : path) (g1 :*: g2) (h1 :*: h2) b where
gsetFieldProd (x :*: y) = (x :*:) . gsetFieldProd @path y
instance
@@ -203,10 +202,10 @@
, HasField name s a -- require the field to be in scope
, Unless (AnyHasPath path)
(TypeError
- ('Text "Type " ':<>: QuoteType s ':<>:
- 'Text " doesn't have a field named " ':<>: QuoteSymbol name))
+ (Text "Type " :<>: QuoteType s :<>:
+ Text " doesn't have a field named " :<>: QuoteSymbol name))
, GAffineFieldSum path (Rep s) (Rep t) a b
- ) => GAffineFieldImpl 'True name s t a b where
+ ) => GAffineFieldImpl True name s t a b where
gafieldImpl = withAffineTraversal
(atraversalVL (\point f s -> to <$> gafieldSum @path point f (from s)))
(\match update -> atraversalVL $ \point f s ->
@@ -226,14 +225,14 @@
instance
( GAffineFieldSum path1 g1 h1 a b
, GAffineFieldSum path2 g2 h2 a b
- ) => GAffineFieldSum ('PathTree path1 path2) (g1 :+: g2) (h1 :+: h2) a b
where
+ ) => GAffineFieldSum (PathNode path1 path2) (g1 :+: g2) (h1 :+: h2) a b where
gafieldSum point f (L1 x) = L1 <$> gafieldSum @path1 point f x
gafieldSum point f (R1 y) = R1 <$> gafieldSum @path2 point f y
{-# INLINE gafieldSum #-}
instance
( GAffineFieldMaybe epath g h a b
- ) => GAffineFieldSum ('PathLeaf epath) (M1 C m g) (M1 C m h) a b where
+ ) => GAffineFieldSum (PathLeaf epath) (M1 C m g) (M1 C m h) a b where
gafieldSum point f (M1 x) = M1 <$> gafieldMaybe @epath point f x
class GAffineFieldMaybe (epath :: Either Symbol [Path]) g h a b where
@@ -241,12 +240,12 @@
instance
( g ~ h
- ) => GAffineFieldMaybe ('Left name) g h a b where
+ ) => GAffineFieldMaybe (Left name) g h a b where
gafieldMaybe point _ g = point g
instance
( GFieldProd prodPath g h a b
- ) => GAffineFieldMaybe ('Right prodPath) g h a b where
+ ) => GAffineFieldMaybe (Right prodPath) g h a b where
gafieldMaybe _ f g = gfieldProd @prodPath f g
----------------------------------------
@@ -260,27 +259,27 @@
-- fast path left
instance {-# OVERLAPPING #-}
( GFieldProd path g1 h1 a b
- ) => GFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: g2) a b where
+ ) => GFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: g2) a b where
gfieldProd f (x :*: y) = (:*: y) <$> gfieldProd @path f x
-- slow path left
instance
( GFieldProd path g1 h1 a b
, g2 ~ h2
- ) => GFieldProd ('PathLeft : path) (g1 :*: g2) (h1 :*: h2) a b where
+ ) => GFieldProd (PathLeft : path) (g1 :*: g2) (h1 :*: h2) a b where
gfieldProd f (x :*: y) = (:*: y) <$> gfieldProd @path f x
-- fast path right
instance {-# OVERLAPPING #-}
( GFieldProd path g2 h2 a b
- ) => GFieldProd ('PathRight : path) (g1 :*: g2) (g1 :*: h2) a b where
+ ) => GFieldProd (PathRight : path) (g1 :*: g2) (g1 :*: h2) a b where
gfieldProd f (x :*: y) = (x :*:) <$> gfieldProd @path f y
-- slow path right
instance
( GFieldProd path g2 h2 a b
, g1 ~ h1
- ) => GFieldProd ('PathRight : path) (g1 :*: g2) (h1 :*: h2) a b where
+ ) => GFieldProd (PathRight : path) (g1 :*: g2) (h1 :*: h2) a b where
gfieldProd f (x :*: y) = (x :*:) <$> gfieldProd @path f y
instance
@@ -305,11 +304,11 @@
( Generic s
, Generic t
, path ~ If (n <=? 0)
- (TypeError ('Text "There is no 0th position"))
+ (TypeError (Text "There is no 0th position"))
(GetPositionPaths s n (Rep s))
, When (n <=? 0) (HideReps (Rep s) (Rep t))
, GPositionSum path (Rep s) (Rep t) a b
- ) => GPositionImpl 'True n s t a b where
+ ) => GPositionImpl True n s t a b where
gpositionImpl = withLens
(lensVL (\f s -> to <$> gpositionSum @path f (from s)))
(\get set -> lensVL $ \f s -> set s <$> f (get s))
@@ -331,7 +330,7 @@
instance
( GPositionSum path1 g1 h1 a b
, GPositionSum path2 g2 h2 a b
- ) => GPositionSum ('PathTree path1 path2) (g1 :+: g2) (h1 :+: h2) a b where
+ ) => GPositionSum (PathNode path1 path2) (g1 :+: g2) (h1 :+: h2) a b where
gpositionSum f (L1 x) = L1 <$> gpositionSum @path1 f x
gpositionSum f (R1 y) = R1 <$> gpositionSum @path2 f y
{-# INLINE gpositionSum #-}
@@ -340,21 +339,21 @@
( path ~ GPositionPath con epath
, When (IsLeft epath) (HideReps g h)
, GFieldProd path g h a b
- ) => GPositionSum ('PathLeaf epath) (M1 C ('MetaCons con fix hs) g)
- (M1 C ('MetaCons con fix hs) h) a b where
+ ) => GPositionSum (PathLeaf epath) (M1 C (MetaCons con fix hs) g)
+ (M1 C (MetaCons con fix hs) h) a b where
gpositionSum f (M1 x) = M1 <$> gfieldProd @path f x
type family GPositionPath con (e :: Either (Nat, Nat) [Path]) :: [Path] where
- GPositionPath _ ('Right path) = path
- GPositionPath con ('Left '(n, k)) = TypeError
- ('Text "Data constructor " ':<>: QuoteSymbol con ':<>:
- 'Text " has " ':<>: ShowFieldNumber k ':<>: 'Text ", " ':<>:
- ToOrdinal n ':<>: 'Text " requested")
+ GPositionPath _ (Right path) = path
+ GPositionPath con (Left '(n, k)) = TypeError
+ (Text "Data constructor " :<>: QuoteSymbol con :<>:
+ Text " has " :<>: ShowFieldNumber k :<>: Text ", " :<>:
+ ToOrdinal n :<>: Text " requested")
type family ShowFieldNumber (k :: Nat) :: ErrorMessage where
- ShowFieldNumber 0 = 'Text "no fields"
- ShowFieldNumber 1 = 'Text "1 field"
- ShowFieldNumber k = 'ShowType k ':<>: 'Text " fields"
+ ShowFieldNumber 0 = Text "no fields"
+ ShowFieldNumber 1 = Text "1 field"
+ ShowFieldNumber k = ShowType k :<>: Text " fields"
----------------------------------------
-- Constructor
@@ -374,12 +373,12 @@
, epath ~ GetNamePath name (Rep s) '[]
, path ~ FromRight
(TypeError
- ('Text "Type " ':<>: QuoteType s ':<>:
- 'Text " doesn't have a constructor named " ':<>: QuoteSymbol name))
+ (Text "Type " :<>: QuoteType s :<>:
+ Text " doesn't have a constructor named " :<>: QuoteSymbol name))
epath
, When (IsLeft epath) (HideReps (Rep s) (Rep t))
, GConstructorSum path (Rep s) (Rep t) a b
- ) => GConstructorImpl 'True name s t a b where
+ ) => GConstructorImpl True name s t a b where
gconstructorImpl = withPrism (generic % gconstructorSum @path) prism
{-# INLINE gconstructorImpl #-}
@@ -399,27 +398,27 @@
-- fast path left
instance {-# OVERLAPPING #-}
( GConstructorSum path g1 h1 a b
- ) => GConstructorSum ('PathLeft : path) (g1 :+: g2) (h1 :+: g2) a b where
+ ) => GConstructorSum (PathLeft : path) (g1 :+: g2) (h1 :+: g2) a b where
gconstructorSum = _L1 % gconstructorSum @path
-- slow path left
instance
( GConstructorSum path g1 h1 a b
, g2 ~ h2
- ) => GConstructorSum ('PathLeft : path) (g1 :+: g2) (h1 :+: h2) a b where
+ ) => GConstructorSum (PathLeft : path) (g1 :+: g2) (h1 :+: h2) a b where
gconstructorSum = _L1 % gconstructorSum @path
-- fast path right
instance {-# OVERLAPPING #-}
( GConstructorSum path g2 h2 a b
- ) => GConstructorSum ('PathRight : path) (g1 :+: g2) (g1 :+: h2) a b where
+ ) => GConstructorSum (PathRight : path) (g1 :+: g2) (g1 :+: h2) a b where
gconstructorSum = _R1 % gconstructorSum @path
-- slow path right
instance
( GConstructorSum path g2 h2 a b
, g1 ~ h1
- ) => GConstructorSum ('PathRight : path) (g1 :+: g2) (h1 :+: h2) a b where
+ ) => GConstructorSum (PathRight : path) (g1 :+: g2) (h1 :+: h2) a b where
gconstructorSum = _R1 % gconstructorSum @path
instance
@@ -439,9 +438,9 @@
instance {-# OVERLAPPABLE #-}
( Dysfunctional () () g h a b
, TypeError
- ('Text "Generic based access supports constructors" ':$$:
- 'Text "containing up to 5 fields. Please generate" ':$$:
- 'Text "PrismS with Template Haskell if you need more.")
+ (Text "Generic based access supports constructors" :$$:
+ Text "containing up to 5 fields. Please generate" :$$:
+ Text "PrismS with Template Haskell if you need more.")
) => GConstructorTuple g h a b where
gconstructorTuple = error "unreachable"
@@ -545,7 +544,7 @@
class GPlateInner (repDefined :: Bool) s a where
gplateInner :: TraversalVL' s a
-instance (Generic s, GPlateImpl (Rep s) a) => GPlateInner 'True s a where
+instance (Generic s, GPlateImpl (Rep s) a) => GPlateInner True s a where
gplateInner f = fmap to . gplateImpl f . from
instance {-# INCOHERENT #-} GPlateInner repNotDefined s a where
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Internal/Indexed.hs
new/optics-core-0.4.2/src/Optics/Internal/Indexed.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Indexed.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Indexed.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -20,9 +18,9 @@
instance
( TypeError
- ('Text "‘" ':<>: 'Text f ':<>: 'Text "’ accepts only optics with no
indices")
- , (x ': xs) ~ NoIx
- ) => AcceptsEmptyIndices f (x ': xs)
+ (Text "‘" :<>: Text f :<>: Text "’ accepts only optics with no indices")
+ , (x : xs) ~ NoIx
+ ) => AcceptsEmptyIndices f (x : xs)
instance AcceptsEmptyIndices f '[]
@@ -32,10 +30,10 @@
instance
( TypeError
- ('Text "Indexed optic is expected")
+ (Text "Indexed optic is expected")
) => NonEmptyIndices '[]
-instance NonEmptyIndices (x ': xs)
+instance NonEmptyIndices (x : xs)
-- | Generate sensible error messages in case a user tries to pass either an
-- unindexed optic or indexed optic with unflattened indices where indexed
optic
@@ -46,57 +44,57 @@
instance
( TypeError
- ('Text "Indexed optic is expected")
+ (Text "Indexed optic is expected")
, '[] ~ '[i]
) => HasSingleIndex '[] i
instance
( TypeError
- ('Text "Use (<%>) or icompose to combine indices of type "
- ':<>: ShowTypes is)
+ (Text "Use (<%>) or icompose to combine indices of type "
+ :<>: ShowTypes is)
, is ~ '[i1, i2]
, is ~ '[i]
) => HasSingleIndex '[i1, i2] i
instance
( TypeError
- ('Text "Use icompose3 to combine indices of type "
- ':<>: ShowTypes is)
+ (Text "Use icompose3 to combine indices of type "
+ :<>: ShowTypes is)
, is ~ '[i1, i2, i3]
, is ~ '[i]
) => HasSingleIndex [i1, i2, i3] i
instance
( TypeError
- ('Text "Use icompose4 to combine indices of type "
- ':<>: ShowTypes is)
+ (Text "Use icompose4 to combine indices of type "
+ :<>: ShowTypes is)
, is ~ '[i1, i2, i3, i4]
, is ~ '[i]
) => HasSingleIndex '[i1, i2, i3, i4] i
instance
( TypeError
- ('Text "Use icompose5 to flatten indices of type "
- ':<>: ShowTypes is)
+ (Text "Use icompose5 to flatten indices of type "
+ :<>: ShowTypes is)
, is ~ '[i1, i2, i3, i4, i5]
, is ~ '[i]
) => HasSingleIndex '[i1, i2, i3, i4, i5] i
instance
( TypeError
- ('Text "Use icomposeN to flatten indices of type "
- ':<>: ShowTypes is)
- , is ~ (i1 ': i2 ': i3 ': i4 ': i5 ': i6 : is')
+ (Text "Use icomposeN to flatten indices of type "
+ :<>: ShowTypes is)
+ , is ~ (i1 : i2 : i3 : i4 : i5 : i6 : is')
, is ~ '[i]
- ) => HasSingleIndex (i1 ': i2 ': i3 ': i4 ': i5 ': i6 ': is') i
+ ) => HasSingleIndex (i1 : i2 : i3 : i4 : i5 : i6 : is') i
----------------------------------------
-- Helpers for HasSingleIndex
type family ShowTypes (types :: [Type]) :: ErrorMessage where
- ShowTypes '[i] = QuoteType i
- ShowTypes '[i, j] = QuoteType i ':<>: 'Text " and " ':<>: QuoteType j
- ShowTypes (i ': is) = QuoteType i ':<>: 'Text ", " ':<>: ShowTypes is
+ ShowTypes '[i] = QuoteType i
+ ShowTypes '[i, j] = QuoteType i :<>: Text " and " :<>: QuoteType j
+ ShowTypes (i : is) = QuoteType i :<>: Text ", " :<>: ShowTypes is
----------------------------------------
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Internal/Magic.hs
new/optics-core-0.4.2/src/Optics/Internal/Magic.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Magic.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Magic.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/optics-core-0.4.1.1/src/Optics/Internal/Optic/Subtyping.hs
new/optics-core-0.4.2/src/Optics/Internal/Optic/Subtyping.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Optic/Subtyping.hs
2001-09-09 03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Optic/Subtyping.hs
2001-09-09 03:46:40.000000000 +0200
@@ -1,6 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -33,9 +31,9 @@
-- | Overlappable instance for a custom type error.
instance {-# OVERLAPPABLE #-} TypeError
- ('ShowType k ':<>: 'Text " cannot be used as " ':<>: 'ShowType l
- ':$$: 'Text "Perhaps you meant one of these:"
- ':$$: ShowEliminations (EliminationForms k)
+ (ShowType k :<>: Text " cannot be used as " :<>: ShowType l
+ :$$: Text "Perhaps you meant one of these:"
+ :$$: ShowEliminations (EliminationForms k)
) => Is k l where
implies _ = error "unreachable"
@@ -434,6 +432,6 @@
instance {-# OVERLAPPABLE #-}
( JoinKinds k l m
- , TypeError ('ShowType k ':<>: 'Text " cannot be composed with " ':<>:
'ShowType l)
+ , TypeError (ShowType k :<>: Text " cannot be composed with " :<>: ShowType
l)
) => JoinKinds k l m where
joinKinds _ = error "unreachable"
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/optics-core-0.4.1.1/src/Optics/Internal/Optic/TypeLevel.hs
new/optics-core-0.4.2/src/Optics/Internal/Optic/TypeLevel.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Optic/TypeLevel.hs
2001-09-09 03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Optic/TypeLevel.hs
2001-09-09 03:46:40.000000000 +0200
@@ -1,6 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -26,23 +24,23 @@
-- Elimination forms in error messages
type family ShowSymbolWithOrigin symbol origin :: ErrorMessage where
- ShowSymbolWithOrigin symbol origin = 'Text " "
- ':<>: QuoteSymbol symbol
- ':<>: 'Text " (from "
- ':<>: 'Text origin
- ':<>: 'Text ")"
+ ShowSymbolWithOrigin symbol origin = Text " "
+ :<>: QuoteSymbol symbol
+ :<>: Text " (from "
+ :<>: Text origin
+ :<>: Text ")"
type family ShowSymbolsWithOrigin (fs :: [(Symbol, Symbol)]) :: ErrorMessage
where
ShowSymbolsWithOrigin '[ '(symbol, origin) ] =
ShowSymbolWithOrigin symbol origin
- ShowSymbolsWithOrigin ('(symbol, origin) ': rest) =
- ShowSymbolWithOrigin symbol origin ':$$: ShowSymbolsWithOrigin rest
+ ShowSymbolsWithOrigin ('(symbol, origin) : rest) =
+ ShowSymbolWithOrigin symbol origin :$$: ShowSymbolsWithOrigin rest
type family ShowOperators (ops :: [Symbol]) :: ErrorMessage where
ShowOperators '[op] =
- QuoteSymbol op ':<>: 'Text " (from Optics.Operators)"
- ShowOperators (op ': rest) =
- QuoteSymbol op ':<>: 'Text " " ':<>: ShowOperators rest
+ QuoteSymbol op :<>: Text " (from Optics.Operators)"
+ ShowOperators (op : rest) =
+ QuoteSymbol op :<>: Text " " :<>: ShowOperators rest
type family AppendEliminations a b where
AppendEliminations '(fs1, ops1) '(fs2, ops2) =
@@ -50,7 +48,7 @@
type family ShowEliminations forms :: ErrorMessage where
ShowEliminations '(fs, ops) =
- ShowSymbolsWithOrigin fs ':$$: 'Text " " ':<>: ShowOperators ops
+ ShowSymbolsWithOrigin fs :$$: Text " " :<>: ShowOperators ops
----------------------------------------
-- Lists
@@ -68,14 +66,13 @@
-- 'Curry' xs y = 'foldr' (->) y xs
-- @
type family Curry (xs :: IxList) (y :: Type) :: Type where
- Curry '[] y = y
- Curry (x ': xs) y = x -> Curry xs y
+ Curry '[] y = y
+ Curry (x : xs) y = x -> Curry xs y
-- | Append two type-level lists together.
type family Append (xs :: [k]) (ys :: [k]) :: [k] where
- Append '[] ys = ys -- needed for (<%>) and (%>)
- Append xs '[] = xs -- needed for (<%)
- Append (x ': xs) ys = x ': Append xs ys
+ Append '[] ys = ys
+ Append (x : xs) ys = x : Append xs ys
-- | Class that is inhabited by all type-level lists @xs@, providing the
ability
-- to compose a function under @'Curry' xs@.
@@ -88,7 +85,7 @@
instance CurryCompose '[] where
composeN = id
-instance CurryCompose xs => CurryCompose (x ': xs) where
+instance CurryCompose xs => CurryCompose (x : xs) where
composeN ij f = composeN @xs ij . f
----------------------------------------
@@ -119,57 +116,57 @@
instance ys ~ zs => AppendIndices '[] ys zs where
appendIndices = IxEq
-instance AppendIndices xs ys ks => AppendIndices (x ': xs) ys (x ': ks) where
- appendIndices :: forall i. IxEq i (Curry (x ': xs) (Curry ys i)) (Curry (x
': ks) i)
+instance AppendIndices xs ys ks => AppendIndices (x : xs) ys (x : ks) where
+ appendIndices :: forall i. IxEq i (Curry (x : xs) (Curry ys i)) (Curry (x :
ks) i)
appendIndices | IxEq <- appendIndices @xs @ys @ks @i = IxEq
----------------------------------------
-- Either
--- | If lhs is 'Right', return it. Otherwise check rhs.
+-- | If lhs is Right', return it. Otherwise check rhs.
type family FirstRight (m1 :: Either e a) (m2 :: Either e a) :: Either e a
where
- FirstRight ('Right a) _ = 'Right a
- FirstRight _ b = b
+ FirstRight (Right a) _ = Right a
+ FirstRight _ b = b
type family FromRight (def :: b) (e :: Either a b) :: b where
- FromRight _ ('Right b) = b
- FromRight def ('Left _) = def
+ FromRight _ (Right b) = b
+ FromRight def (Left _) = def
type family IsLeft (e :: Either a b) :: Bool where
- IsLeft ('Left _) = 'True
- IsLeft ('Right _) = 'False
+ IsLeft (Left _) = True
+ IsLeft (Right _) = False
----------------------------------------
-- Errors
-- | Show a custom type error if @p@ is true.
type family When (p :: Bool) (err :: Constraint) :: Constraint where
- When 'True err = err
- When 'False _ = ()
+ When True err = err
+ When False _ = ()
-- | Show a custom type error if @p@ is false (or stuck).
type family Unless (p :: Bool) (err :: Constraint) :: Constraint where
- Unless 'True _ = ()
- Unless 'False err = err
+ Unless True _ = ()
+ Unless False err = err
-- | Use with 'Unless' to detect stuck (undefined) type families.
type family Defined (f :: k) :: Bool where
Defined (f _) = Defined f
- Defined _ = 'True
+ Defined _ = True
-- | Show a type surrounded by quote marks.
type family QuoteType (x :: t) :: ErrorMessage where
- QuoteType x = 'Text "‘" ':<>: 'ShowType x ':<>: 'Text "’"
+ QuoteType x = Text "‘" :<>: ShowType x :<>: Text "’"
-- | Show a symbol surrounded by quote marks.
type family QuoteSymbol (x :: Symbol) :: ErrorMessage where
- QuoteSymbol x = 'Text "‘" ':<>: 'Text x ':<>: 'Text "’"
+ QuoteSymbol x = Text "‘" :<>: Text x :<>: Text "’"
type family ToOrdinal (n :: Nat) :: ErrorMessage where
- ToOrdinal 1 = 'Text "1st"
- ToOrdinal 2 = 'Text "2nd"
- ToOrdinal 3 = 'Text "3rd"
- ToOrdinal n = 'ShowType n ':<>: 'Text "th"
+ ToOrdinal 1 = Text "1st"
+ ToOrdinal 2 = Text "2nd"
+ ToOrdinal 3 = Text "3rd"
+ ToOrdinal n = ShowType n :<>: Text "th"
----------------------------------------
-- Misc
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/optics-core-0.4.1.1/src/Optics/Internal/Optic/Types.hs
new/optics-core-0.4.2/src/Optics/Internal/Optic/Types.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Optic/Types.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Optic/Types.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeInType #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | This module is intended for internal use only, and may change without
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Internal/Optic.hs
new/optics-core-0.4.2/src/Optics/Internal/Optic.hs
--- old/optics-core-0.4.1.1/src/Optics/Internal/Optic.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Internal/Optic.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeInType #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | Core optic types and subtyping machinery.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/IxAffineTraversal.hs
new/optics-core-0.4.2/src/Optics/IxAffineTraversal.hs
--- old/optics-core-0.4.1.1/src/Optics/IxAffineTraversal.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/IxAffineTraversal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -36,6 +36,13 @@
-- * Additional introduction forms
, ignored
+ -- * Monoid structure
+ -- | 'IxAffineTraversal' admits a monoid structure where 'iadisjoin' returns
+ -- the result from the second indexed affine traversal only if the first does
+ -- not return a result. The identity element is 'ignored' (which traverses no
+ -- elements).
+ , iadisjoin
+
-- * Subtyping
, An_AffineTraversal
@@ -49,6 +56,7 @@
import Data.Profunctor.Indexed
import Optics.AffineFold
+import Optics.AffineTraversal
import Optics.Internal.Indexed
import Optics.Internal.Optic
import Optics.Internal.Utils
@@ -130,6 +138,31 @@
ignored = iatraversalVL $ \point _ -> point
{-# INLINE ignored #-}
+-- | Try the first 'IxAffineTraversal'. If it does not return a entry, try the
+-- second one.
+--
+-- >>> iover (ifst `iadisjoin` isnd) (++) ("foo", "bar")
+-- ("barfoo","bar")
+--
+-- >>> iover (ignored `iadisjoin` isnd) (++) ("foo", "bar")
+-- ("foo","foobar")
+--
+-- @since 0.4.3
+--
+iadisjoin
+ :: ( Is k An_AffineTraversal, Is l An_AffineTraversal
+ , is1 `HasSingleIndex` i, is2 `HasSingleIndex` i)
+ => Optic k is1 s t a b
+ -> Optic l is2 s t a b
+ -> IxAffineTraversal i s t a b
+iadisjoin a b = conjoined (adisjoin a b) $ iatraversalVL $ \point f s ->
+ let OrT visited fu = iatraverseOf a (OrT False . point) (\i -> wrapOrT . f
i) s
+ in if visited
+ then fu
+ else iatraverseOf b point f s
+infixl 3 `iadisjoin` -- Same as (<|>)
+{-# INLINE iadisjoin #-}
+
-- $setup
-- >>> import Optics.Core
-- >>> import Data.Void (absurd)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/IxFold.hs
new/optics-core-0.4.2/src/Optics/IxFold.hs
--- old/optics-core-0.4.1.1/src/Optics/IxFold.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/IxFold.hs 2001-09-09 03:46:40.000000000
+0200
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-- |
-- Module: Optics.IxFold
-- Description: An indexed version of a 'Optics.Fold.Fold'.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/IxTraversal.hs
new/optics-core-0.4.2/src/Optics/IxTraversal.hs
--- old/optics-core-0.4.1.1/src/Optics/IxTraversal.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/IxTraversal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,4 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-- |
-- Module: Optics.IxTraversal
-- Description: An indexed version of a 'Optics.Traversal.Traversal'.
@@ -60,10 +59,16 @@
, ipartsOf
, isingular
- -- * Monoid structure
- -- | 'IxTraversal' admits a (partial) monoid structure where 'iadjoin'
- -- combines non-overlapping indexed traversals, and the identity element is
- -- 'ignored' (which traverses no elements).
+ -- * Monoid structures
+ -- | 'IxTraversal' admits two monoid structures:
+ --
+ -- * 'iadjoin' combines non-overlapping indexed traversals.
+ --
+ -- * 'idisjoin' returns results from the second indexed traversal only if the
+ -- first returns no results.
+ --
+ -- In both cases, the identity element is 'ignored' (which traverses no
+ -- elements).
--
-- If you merely need an 'IxFold', you can use indexed traversals as indexed
-- folds and combine them with one of the monoid structures on indexed folds
@@ -76,6 +81,7 @@
-- and the ('<>') operator could not be used to combine optics of different
-- kinds.
, iadjoin
+ , idisjoin
-- * Subtyping
, A_Traversal
@@ -356,6 +362,30 @@
Nothing -> pure a
{-# INLINE isingular #-}
+-- | Try the first 'IxTraversal'. If it returns no entries, try the second one.
+--
+-- >>> iover (_1 % itraversed `idisjoin` _2 % itraversed) (+) ([0, 0, 0], (3,
5))
+-- ([0,1,2],(3,5))
+--
+-- >>> iover (ignored `idisjoin` _2 % itraversed) (+) ([0, 0, 0], (3, 5))
+-- ([0,0,0],(3,8))
+--
+-- @since 0.4.3
+--
+idisjoin
+ :: ( Is k A_Traversal, Is l A_Traversal
+ , is1 `HasSingleIndex` i, is2 `HasSingleIndex` i)
+ => Optic k is1 s t a b
+ -> Optic l is2 s t a b
+ -> IxTraversal i s t a b
+idisjoin a b = conjoined (disjoin a b) $ itraversalVL $ \f s ->
+ let OrT visited fu = itraverseOf a (\i -> wrapOrT . f i) s
+ in if visited
+ then fu
+ else itraverseOf b f s
+infixl 3 `idisjoin` -- Same as (<|>)
+{-# INLINE idisjoin #-}
+
-- | Combine two disjoint indexed traversals into one.
--
-- >>> iover (_1 % itraversed `iadjoin` _2 % itraversed) (+) ([0, 0, 0], (3,
5))
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Label.hs
new/optics-core-0.4.2/src/Optics/Label.hs
--- old/optics-core-0.4.1.1/src/Optics/Label.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/optics-core-0.4.2/src/Optics/Label.hs 2001-09-09 03:46:40.000000000
+0200
@@ -1,7 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- |
@@ -533,9 +531,14 @@
, repDefined ~ (Defined (Rep s) && Defined (Rep t))
#endif
, Unless repDefined (NoLabelOpticError name k s t a b)
- , k ~ If (CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT)
+ -- If a label starts with "_[A-Z]", assume it's a name of a constructor.
+ -- Otherwise, if it starts with "?[a-z]", assume it's a name of a partial
+ -- field. Otherwise it's a total field.
+ , k ~ If (CmpSymbol "_@" name == LT && CmpSymbol "_[" name == GT)
A_Prism
- A_Lens
+ (If (CmpSymbol "?`" name == LT && CmpSymbol "?{" name == GT)
+ An_AffineTraversal
+ A_Lens)
, GenericOptic repDefined name k s t a b
, Dysfunctional name k s t a b
)
@@ -543,19 +546,19 @@
-- | If there is no specific 'LabelOptic' instance, display a custom type
error.
type family NoLabelOpticError name k s t a b where
NoLabelOpticError name k s t a b = TypeError
- ('Text "No instance for LabelOptic " ':<>: 'ShowType name
- ':<>: 'Text " " ':<>: QuoteType k
- ':<>: 'Text " " ':<>: QuoteType s
- ':<>: 'Text " " ':<>: QuoteType t
- ':<>: 'Text " " ':<>: QuoteType a
- ':<>: 'Text " " ':<>: QuoteType b
- ':$$: 'Text "Possible solutions:"
- ':$$: 'Text "- Check and correct spelling of the label"
- ':$$: 'Text "- Define the LabelOptic instance by hand or via Template
Haskell"
+ (Text "No instance for LabelOptic " :<>: ShowType name
+ :<>: Text " " :<>: QuoteType k
+ :<>: Text " " :<>: QuoteType s
+ :<>: Text " " :<>: QuoteType t
+ :<>: Text " " :<>: QuoteType a
+ :<>: Text " " :<>: QuoteType b
+ :$$: Text "Possible solutions:"
+ :$$: Text "- Check and correct spelling of the label"
+ :$$: Text "- Define the LabelOptic instance by hand or via Template
Haskell"
#ifdef EXPLICIT_GENERIC_LABELS
- ':$$: 'Text "- Derive a GenericLabelOptics instance for " ':<>: QuoteType
s
+ :$$: Text "- Derive a GenericLabelOptics instance for " :<>: QuoteType s
#else
- ':$$: 'Text "- Derive a Generic instance for " ':<>: QuoteType s
+ :$$: Text "- Derive a Generic instance for " :<>: QuoteType s
#endif
)
@@ -578,7 +581,7 @@
-- @since 0.4
class Generic a => GenericLabelOptics a where
type HasGenericLabelOptics a :: Bool
- type HasGenericLabelOptics a = 'True
+ type HasGenericLabelOptics a = True
----------------------------------------
@@ -593,10 +596,18 @@
) => GenericOptic repDefined name A_Lens s t a b where
genericOptic = gfieldImpl @name
+-- | This instance can only be used via label syntax with GHC >= 9.6 since it's
+-- the first release with unrestricted overloaded labels.
+instance
+ ( GAffineFieldImpl repDefined name s t a b
+ , origName ~ AppendSymbol "?" name
+ ) => GenericOptic repDefined origName An_AffineTraversal s t a b where
+ genericOptic = gafieldImpl @repDefined @name
+
instance
( GConstructorImpl repDefined name s t a b
- , _name ~ AppendSymbol "_" name
- ) => GenericOptic repDefined _name A_Prism s t a b where
+ , origName ~ AppendSymbol "_" name
+ ) => GenericOptic repDefined origName A_Prism s t a b where
genericOptic = gconstructorImpl @repDefined @name
----------------------------------------
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Mapping.hs
new/optics-core-0.4.2/src/Optics/Mapping.hs
--- old/optics-core-0.4.1.1/src/Optics/Mapping.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Mapping.hs 2001-09-09 03:46:40.000000000
+0200
@@ -6,7 +6,6 @@
-- @'Optic'' ('MappedOptic' k) 'NoIx' (f s) (f a)@, in other words optic
operating on values
-- in a 'Functor'.
--
-{-# LANGUAGE DataKinds #-}
module Optics.Mapping
( MappingOptic (..)
) where
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Re.hs
new/optics-core-0.4.2/src/Optics/Re.hs
--- old/optics-core-0.4.1.1/src/Optics/Re.hs 2001-09-09 03:46:40.000000000
+0200
+++ new/optics-core-0.4.2/src/Optics/Re.hs 2001-09-09 03:46:40.000000000
+0200
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeFamilyDependencies #-}
-- |
-- Module: Optics.Re
-- Description: The 're' operator allows some optics to be reversed.
@@ -22,8 +23,6 @@
--
-- <<diagrams/reoptics.png Reversed Optics>>
--
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
module Optics.Re
( ReversibleOptic(..)
) where
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/ReadOnly.hs
new/optics-core-0.4.2/src/Optics/ReadOnly.hs
--- old/optics-core-0.4.1.1/src/Optics/ReadOnly.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/ReadOnly.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeInType #-}
-- |
-- Module: Optics.ReadOnly
-- Description: Converting read-write optics into their read-only counterparts.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/optics-core-0.4.1.1/src/Optics/Traversal.hs
new/optics-core-0.4.2/src/Optics/Traversal.hs
--- old/optics-core-0.4.1.1/src/Optics/Traversal.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/optics-core-0.4.2/src/Optics/Traversal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module: Optics.Traversal
@@ -67,12 +66,19 @@
-- * Combinators
, backwards
, partsOf
+ , unsafePartsOf
, singular
- -- * Monoid structure
- -- | 'Traversal' admits a (partial) monoid structure where 'adjoin' combines
- -- non-overlapping traversals, and the identity element is
- -- 'Optics.IxAffineTraversal.ignored' (which traverses no elements).
+ -- * Monoid structures
+ -- | 'Traversal' admits two monoid structures:
+ --
+ -- * 'adjoin' combines non-overlapping traversals.
+ --
+ -- * 'disjoin' returns results from the second traversal only if the first
+ -- returns no results.
+ --
+ -- In both cases, the identity element is 'Optics.IxAffineTraversal.ignored'
+ -- (which traverses no elements).
--
-- If you merely need a 'Fold', you can use traversals as folds and combine
-- them with one of the monoid structures on folds (see
@@ -84,6 +90,7 @@
-- is not a unique choice of monoid to use that works for all optics, and the
-- ('<>') operator could not be used to combine optics of different kinds.
, adjoin
+ , disjoin
-- * Subtyping
, A_Traversal
@@ -380,7 +387,7 @@
-- So technically, this is only a 'Lens' if you do not change the number of
-- results it returns.
partsOf
- :: forall k is s t a. Is k A_Traversal
+ :: Is k A_Traversal
=> Optic k is s t a a
-> Lens s t [a] [a]
partsOf o = lensVL $ \f s -> evalState (traverseOf o update s)
@@ -391,6 +398,22 @@
[] -> pure a
{-# INLINE partsOf #-}
+-- | A variant of 'partsOf' that allows changing the type of elements.
+--
+-- /Warning:/ if you don't supply at least as many @b@'s as you were given
@a@'s,
+-- the reconstruction of @t@ will result in an error.
+unsafePartsOf
+ :: Is k A_Traversal
+ => Optic k is s t a b
+ -> Lens s t [a] [b]
+unsafePartsOf o = lensVL $ \f s -> evalState (traverseOf o update s)
+ <$> f (toListOf (getting $ castOptic @A_Traversal o) s)
+ where
+ update _ = get >>= \case
+ b : bs -> put bs >> pure b
+ [] -> error "unsafePartsOf: not enough elements were supplied"
+{-# INLINE unsafePartsOf #-}
+
-- | Convert a traversal to an 'AffineTraversal' that visits the first element
-- of the original traversal.
--
@@ -401,7 +424,7 @@
--
-- @since 0.3
singular
- :: forall k is s a. Is k A_Traversal
+ :: Is k A_Traversal
=> Optic' k is s a
-> AffineTraversal' s a
singular o = atraversalVL $ \point f s ->
@@ -414,6 +437,28 @@
Nothing -> pure a
{-# INLINE singular #-}
+-- | Try the first 'Traversal'. If it returns no entries, try the second one.
+--
+-- >>> over (_1 `disjoin` _2) succ (0, 0)
+-- (1,0)
+-- >>> over (ignored `disjoin` _2) succ (0, 0)
+-- (0,1)
+--
+-- @since 0.4.3
+--
+disjoin
+ :: (Is k A_Traversal, Is l A_Traversal)
+ => Optic k is s t a b
+ -> Optic l js s t a b
+ -> Traversal s t a b
+disjoin a b = traversalVL $ \f s ->
+ let OrT visited fu = traverseOf a (wrapOrT . f) s
+ in if visited
+ then fu
+ else traverseOf b f s
+infixl 3 `disjoin` -- Same as (<|>)
+{-# INLINE disjoin #-}
+
-- | Combine two disjoint traversals into one.
--
-- >>> over (_1 % _Just `adjoin` _2 % _Right) not (Just True, Right False)
