PoC: Add non-empty folds

.github/workflows/haskell-ci.yml

@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.17.20231110
+# version: 0.17.20231203
 #
-# REGENDATA ("0.17.20231110",["github","--config=cabal.haskell-ci","cabal.project"])
+# REGENDATA ("0.17.20231203",["github","--config=cabal.haskell-ci","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -202,7 +202,7 @@ jobs:
       - name: cache (tools)
         uses: actions/cache/restore@v3
         with:
-          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-5b6f802b
+          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-577ba131
           path: ~/.haskell-ci-tools
       - name: install cabal-plan
         run: |
@@ -221,7 +221,7 @@ jobs:
         uses: actions/cache/save@v3
         if: always()
         with:
-          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-5b6f802b
+          key: ${{ runner.os }}-${{ matrix.compiler }}-tools-577ba131
           path: ~/.haskell-ci-tools
       - name: checkout
         uses: actions/checkout@v3

codegen/Subtypes.hs

@@ -40,6 +40,8 @@ data OpticKind
   |  A_Getter
   -- | Tag for an affine fold.
   |  An_AffineFold
+  -- | Tag for a non-empty fold.
+  |  A_NeFold
   -- | Tag for a fold.
   |  A_Fold
   -- | Tag for a reversed lens.
@@ -69,6 +71,8 @@ opticsKind = mkProper $ Map.fromListWith (<>)
     , A_Traversal        ~> A_Fold
 
     , A_Getter           ~> An_AffineFold
+    , A_Getter           ~> A_NeFold
+    , A_NeFold           ~> A_Fold
     , An_AffineFold      ~> A_Fold
     ]
   where

indexed-profunctors/indexed-profunctors.cabal

@@ -59,6 +59,6 @@ library
   import:           language
   hs-source-dirs:   src
 
-  build-depends: base                   >= 4.10       && <5
+  build-depends: base                   >= 4.10       && <5, foldable1-classes-compat
 
   exposed-modules:    Data.Profunctor.Indexed

indexed-profunctors/src/Data/Profunctor/Indexed.hs

@@ -13,6 +13,10 @@ module Data.Profunctor.Indexed
   , Visiting(..)
   , Mapping(..)
   , Traversing(..)
+  , Bifunctor (..)
+  , Bicontravariant (..)
+  , Folding (..)
+  , Folding1 (..)
 
     -- * Concrete profunctors
   , Star(..)
@@ -55,6 +59,7 @@ module Data.Profunctor.Indexed
 import Data.Coerce (Coercible, coerce)
 import Data.Functor.Const
 import Data.Functor.Identity
+import Data.Foldable1
 
 ----------------------------------------
 -- Concrete profunctors
@@ -547,6 +552,67 @@ instance Mapping IxFunArrow where
   roam  f (IxFunArrow k) = IxFunArrow $ \i -> f (k i)
   iroam f (IxFunArrow k) = IxFunArrow $ \ij -> f $ \i -> k (ij i)
 
+----------------------------------------
+
+-- | Class for (covariant) bifunctors.
+class Bifunctor p where
+  bimap_  :: (a -> b) -> (c -> d) -> p i a c -> p i b d
+  first_  :: (a -> b)             -> p i a c -> p i b c
+  second_ ::             (c -> d) -> p i a c -> p i a d
+
+instance Bifunctor Tagged where
+  bimap_  _f g = Tagged #. g .# unTagged
+  first_  _f   = coerce
+  second_    g = Tagged #. g .# unTagged
+
+----------------------------------------
+
+-- | Class for contravariant bifunctors.
+class Bicontravariant p where
+  contrabimap  :: (b -> a) -> (d -> c) -> p i a c -> p i b d
+  contrafirst  :: (b -> a)             -> p i a c -> p i b c
+  contrasecond ::             (c -> b) -> p i a b -> p i a c
+
+instance Bicontravariant (Forget r) where
+  contrabimap  f _g (Forget k) = Forget (k . f)
+  contrafirst  f    (Forget k) = Forget (k . f)
+  contrasecond   _g (Forget k) = Forget k
+
+instance Bicontravariant (ForgetM r) where
+  contrabimap  f _g (ForgetM k) = ForgetM (k . f)
+  contrafirst  f    (ForgetM k) = ForgetM (k . f)
+  contrasecond   _g (ForgetM k) = ForgetM k
+
+instance Bicontravariant (IxForget r) where
+  contrabimap  f _g (IxForget k) = IxForget (\i -> k i . f)
+  contrafirst  f    (IxForget k) = IxForget (\i -> k i . f)
+  contrasecond   _g (IxForget k) = IxForget k
+
+instance Bicontravariant (IxForgetM r) where
+  contrabimap  f _g (IxForgetM k) = IxForgetM (\i -> k i . f)
+  contrafirst  f    (IxForgetM k) = IxForgetM (\i -> k i . f)
+  contrasecond   _g (IxForgetM k) = IxForgetM k
+
+----------------------------------------
+
+class (Bicontravariant p, Cochoice p, Strong p) => Folding1 p where
+  folded1__       :: Foldable1 f => p i a b -> p i (f a) (f b)
+  foldrMapping1__ :: (forall b. (a -> b) -> (a -> b -> b) -> s -> b) -> p i a a -> p i s s
+
+instance Semigroup r => Folding1 (Forget r) where
+  folded1__         (Forget k) = Forget (foldMap1 k)
+  foldrMapping1__ f (Forget k) = Forget (f k (\a r -> k a <> r))
+
+instance Semigroup r => Folding1 (IxForget r) where
+  folded1__         (IxForget k) = IxForget (\i -> foldMap1 (k i))
+  foldrMapping1__ f (IxForget k) = IxForget (\i -> f (k i) (\a r -> k i a <> r))
+
+class (Folding1 p, Traversing p) => Folding p where
+
+instance Monoid r => Folding (Forget r) where
+instance Monoid r => Folding (IxForget r) where
+
+----------------------------------------
 
   -- | Type to represent the components of an isomorphism.
 data Exchange a b i s t =

optics-core/optics-core.cabal

@@ -76,7 +76,8 @@ library
                , containers             >= 0.5.10.2   && <0.7
                , indexed-profunctors    >= 0.1        && <0.2
                , transformers           >= 0.5        && <0.7
-               , indexed-traversable    >= 0.1        && <0.2
+               , indexed-traversable    >= 0.1.3      && <0.2
+               , foldable1-classes-compat
 
   exposed-modules: Optics.Core
 
@@ -93,10 +94,12 @@ library
                    Optics.IxAffineTraversal
                    Optics.IxFold
                    Optics.IxGetter
+                   Optics.IxNeFold
                    Optics.IxLens
                    Optics.IxSetter
                    Optics.IxTraversal
                    Optics.Lens
+                   Optics.NeFold
                    Optics.Prism
                    Optics.ReversedLens
                    Optics.ReversedPrism

optics-core/src/Optics/Core.hs

@@ -41,6 +41,7 @@ import Optics.IxLens                           as O
 import Optics.IxSetter                         as O
 import Optics.IxTraversal                      as O
 import Optics.Lens                             as O
+import Optics.NeFold                           as O
 import Optics.ReversedLens                     as O
 import Optics.Prism                            as O
 import Optics.ReversedPrism                    as O

optics-core/src/Optics/Fold.hs

@@ -112,7 +112,6 @@ import Data.Monoid
 import Data.Profunctor.Indexed
 
 import Optics.AffineFold
-import Optics.Internal.Bi
 import Optics.Internal.Fold
 import Optics.Internal.Optic
 import Optics.Internal.Utils

optics-core/src/Optics/Internal/Bi.hs

@@ -6,54 +6,16 @@
 -- in subsequent releases.
 module Optics.Internal.Bi where
 
-import Data.Coerce
 import Data.Void
 
 import Data.Profunctor.Indexed
 
--- | Class for (covariant) bifunctors.
-class Bifunctor p where
-  bimap  :: (a -> b) -> (c -> d) -> p i a c -> p i b d
-  first  :: (a -> b)             -> p i a c -> p i b c
-  second ::             (c -> d) -> p i a c -> p i a d
-
-instance Bifunctor Tagged where
-  bimap  _f g = Tagged #. g .# unTagged
-  first  _f   = coerce
-  second    g = Tagged #. g .# unTagged
-
--- | Class for contravariant bifunctors.
-class Bicontravariant p where
-  contrabimap  :: (b -> a) -> (d -> c) -> p i a c -> p i b d
-  contrafirst  :: (b -> a)             -> p i a c -> p i b c
-  contrasecond ::             (c -> b) -> p i a b -> p i a c
-
-instance Bicontravariant (Forget r) where
-  contrabimap  f _g (Forget k) = Forget (k . f)
-  contrafirst  f    (Forget k) = Forget (k . f)
-  contrasecond   _g (Forget k) = Forget k
-
-instance Bicontravariant (ForgetM r) where
-  contrabimap  f _g (ForgetM k) = ForgetM (k . f)
-  contrafirst  f    (ForgetM k) = ForgetM (k . f)
-  contrasecond   _g (ForgetM k) = ForgetM k
-
-instance Bicontravariant (IxForget r) where
-  contrabimap  f _g (IxForget k) = IxForget (\i -> k i . f)
-  contrafirst  f    (IxForget k) = IxForget (\i -> k i . f)
-  contrasecond   _g (IxForget k) = IxForget k
-
-instance Bicontravariant (IxForgetM r) where
-  contrabimap  f _g (IxForgetM k) = IxForgetM (\i -> k i . f)
-  contrafirst  f    (IxForgetM k) = IxForgetM (\i -> k i . f)
-  contrasecond   _g (IxForgetM k) = IxForgetM k
-
 ----------------------------------------
 
 -- | If @p@ is a 'Profunctor' and a 'Bifunctor' then its left parameter must be
 -- phantom.
 lphantom :: (Profunctor p, Bifunctor p) => p i a c -> p i b c
-lphantom = first absurd . lmap absurd
+lphantom = first_ absurd . lmap absurd
 
 -- | If @p@ is a 'Profunctor' and 'Bicontravariant' then its right parameter
 -- must be phantom.

optics-core/src/Optics/Internal/Indexed/Classes.hs

@@ -9,9 +9,11 @@
 module Optics.Internal.Indexed.Classes (
    module Data.Functor.WithIndex,
    module Data.Foldable.WithIndex,
+   module Data.Foldable1.WithIndex,
    module Data.Traversable.WithIndex,
 ) where
 
 import Data.Functor.WithIndex
 import Data.Foldable.WithIndex
+import Data.Foldable1.WithIndex
 import Data.Traversable.WithIndex