diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index cc5c62db..881563a5 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.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 diff --git a/codegen/Subtypes.hs b/codegen/Subtypes.hs index 479a13c8..6cc90c42 100644 --- a/codegen/Subtypes.hs +++ b/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 diff --git a/indexed-profunctors/indexed-profunctors.cabal b/indexed-profunctors/indexed-profunctors.cabal index b0efc88f..d5c3b48e 100644 --- a/indexed-profunctors/indexed-profunctors.cabal +++ b/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 diff --git a/indexed-profunctors/src/Data/Profunctor/Indexed.hs b/indexed-profunctors/src/Data/Profunctor/Indexed.hs index 5598f60b..2e4653f2 100644 --- a/indexed-profunctors/src/Data/Profunctor/Indexed.hs +++ b/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 = diff --git a/optics-core/optics-core.cabal b/optics-core/optics-core.cabal index 7106d85f..2b3c3cea 100644 --- a/optics-core/optics-core.cabal +++ b/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 diff --git a/optics-core/src/Optics/Core.hs b/optics-core/src/Optics/Core.hs index c022ddb9..736f4f3c 100644 --- a/optics-core/src/Optics/Core.hs +++ b/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 diff --git a/optics-core/src/Optics/Fold.hs b/optics-core/src/Optics/Fold.hs index 91fae287..1eba392c 100644 --- a/optics-core/src/Optics/Fold.hs +++ b/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 diff --git a/optics-core/src/Optics/Internal/Bi.hs b/optics-core/src/Optics/Internal/Bi.hs index e93bfbd5..39a78f91 100644 --- a/optics-core/src/Optics/Internal/Bi.hs +++ b/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. diff --git a/optics-core/src/Optics/Internal/Indexed/Classes.hs b/optics-core/src/Optics/Internal/Indexed/Classes.hs index b8ceb1ad..1d70b2b7 100644 --- a/optics-core/src/Optics/Internal/Indexed/Classes.hs +++ b/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 diff --git a/optics-core/src/Optics/Internal/Optic/Subtyping.hs b/optics-core/src/Optics/Internal/Optic/Subtyping.hs index 5ab4d811..af9ad6a9 100644 --- a/optics-core/src/Optics/Internal/Optic/Subtyping.hs +++ b/optics-core/src/Optics/Internal/Optic/Subtyping.hs @@ -102,6 +102,7 @@ instance Is An_Iso A_Prism where implies r = r instance Is An_Iso A_Review where implies r = r instance Is An_Iso A_Lens where implies r = r instance Is An_Iso A_Getter where implies r = r +instance Is An_Iso A_NeFold where implies r = r instance Is An_Iso An_AffineTraversal where implies r = r instance Is An_Iso An_AffineFold where implies r = r instance Is An_Iso A_Traversal where implies r = r @@ -111,6 +112,7 @@ instance Is An_Iso A_Setter where implies r = r instance Is A_ReversedLens A_Review where implies r = r -- A_ReversedPrism instance Is A_ReversedPrism A_Getter where implies r = r +instance Is A_ReversedPrism A_NeFold where implies r = r instance Is A_ReversedPrism An_AffineFold where implies r = r instance Is A_ReversedPrism A_Fold where implies r = r -- A_Prism @@ -122,14 +124,18 @@ instance Is A_Prism A_Fold where implies r = r instance Is A_Prism A_Setter where implies r = r -- A_Lens instance Is A_Lens A_Getter where implies r = r +instance Is A_Lens A_NeFold where implies r = r instance Is A_Lens An_AffineTraversal where implies r = r instance Is A_Lens An_AffineFold where implies r = r instance Is A_Lens A_Traversal where implies r = r instance Is A_Lens A_Fold where implies r = r instance Is A_Lens A_Setter where implies r = r -- A_Getter +instance Is A_Getter A_NeFold where implies r = r instance Is A_Getter An_AffineFold where implies r = r instance Is A_Getter A_Fold where implies r = r +-- A_NeFold +instance Is A_NeFold A_Fold where implies r = r -- An_AffineTraversal instance Is An_AffineTraversal An_AffineFold where implies r = r instance Is An_AffineTraversal A_Traversal where implies r = r @@ -173,6 +179,8 @@ instance k ~ A_Lens => JoinKinds An_Iso A_Lens joinKinds r = r instance k ~ A_Getter => JoinKinds An_Iso A_Getter k where joinKinds r = r +instance k ~ A_NeFold => JoinKinds An_Iso A_NeFold k where + joinKinds r = r instance k ~ An_AffineTraversal => JoinKinds An_Iso An_AffineTraversal k where joinKinds r = r instance k ~ An_AffineFold => JoinKinds An_Iso An_AffineFold k where @@ -196,6 +204,7 @@ instance k ~ A_Review => JoinKinds A_ReversedLens A_Review joinKinds r = r -- no JoinKinds A_ReversedLens A_Lens -- no JoinKinds A_ReversedLens A_Getter +-- no JoinKinds A_ReversedLens A_NeFold -- no JoinKinds A_ReversedLens An_AffineTraversal -- no JoinKinds A_ReversedLens An_AffineFold -- no JoinKinds A_ReversedLens A_Traversal @@ -215,6 +224,8 @@ instance k ~ A_Getter => JoinKinds A_ReversedPrism A_Lens joinKinds r = r instance k ~ A_Getter => JoinKinds A_ReversedPrism A_Getter k where joinKinds r = r +instance k ~ A_NeFold => JoinKinds A_ReversedPrism A_NeFold k where + joinKinds r = r instance k ~ An_AffineFold => JoinKinds A_ReversedPrism An_AffineTraversal k where joinKinds r = r instance k ~ An_AffineFold => JoinKinds A_ReversedPrism An_AffineFold k where @@ -240,6 +251,8 @@ instance k ~ An_AffineTraversal => JoinKinds A_Prism A_Lens joinKinds r = r instance k ~ An_AffineFold => JoinKinds A_Prism A_Getter k where joinKinds r = r +instance k ~ A_Fold => JoinKinds A_Prism A_NeFold k where + joinKinds r = r instance k ~ An_AffineTraversal => JoinKinds A_Prism An_AffineTraversal k where joinKinds r = r instance k ~ An_AffineFold => JoinKinds A_Prism An_AffineFold k where @@ -263,6 +276,7 @@ instance k ~ A_Review => JoinKinds A_Review A_Prism joinKinds r = r -- no JoinKinds A_Review A_Lens -- no JoinKinds A_Review A_Getter +-- no JoinKinds A_Review A_NeFold -- no JoinKinds A_Review An_AffineTraversal -- no JoinKinds A_Review An_AffineFold -- no JoinKinds A_Review A_Traversal @@ -282,6 +296,8 @@ instance k ~ An_AffineTraversal => JoinKinds A_Lens A_Prism -- no JoinKinds A_Lens A_Review instance k ~ A_Getter => JoinKinds A_Lens A_Getter k where joinKinds r = r +instance k ~ A_NeFold => JoinKinds A_Lens A_NeFold k where + joinKinds r = r instance k ~ An_AffineTraversal => JoinKinds A_Lens An_AffineTraversal k where joinKinds r = r instance k ~ An_AffineFold => JoinKinds A_Lens An_AffineFold k where @@ -306,6 +322,8 @@ instance k ~ An_AffineFold => JoinKinds A_Getter A_Prism -- no JoinKinds A_Getter A_Review instance k ~ A_Getter => JoinKinds A_Getter A_Lens k where joinKinds r = r +instance k ~ A_NeFold => JoinKinds A_Getter A_NeFold k where + joinKinds r = r instance k ~ An_AffineFold => JoinKinds A_Getter An_AffineTraversal k where joinKinds r = r instance k ~ An_AffineFold => JoinKinds A_Getter An_AffineFold k where @@ -316,6 +334,31 @@ instance k ~ A_Fold => JoinKinds A_Getter A_Fold joinKinds r = r -- no JoinKinds A_Getter A_Setter +-- A_NeFold ----- +instance k ~ A_NeFold => JoinKinds A_NeFold A_NeFold k where + joinKinds r = r +instance k ~ A_NeFold => JoinKinds A_NeFold An_Iso k where + joinKinds r = r +-- no JoinKinds A_NeFold A_ReversedLens +instance k ~ A_NeFold => JoinKinds A_NeFold A_ReversedPrism k where + joinKinds r = r +instance k ~ A_Fold => JoinKinds A_NeFold A_Prism k where + joinKinds r = r +-- no JoinKinds A_NeFold A_Review +instance k ~ A_NeFold => JoinKinds A_NeFold A_Lens k where + joinKinds r = r +instance k ~ A_NeFold => JoinKinds A_NeFold A_Getter k where + joinKinds r = r +instance k ~ A_Fold => JoinKinds A_NeFold An_AffineTraversal k where + joinKinds r = r +instance k ~ A_Fold => JoinKinds A_NeFold An_AffineFold k where + joinKinds r = r +instance k ~ A_Fold => JoinKinds A_NeFold A_Traversal k where + joinKinds r = r +instance k ~ A_Fold => JoinKinds A_NeFold A_Fold k where + joinKinds r = r +-- no JoinKinds A_NeFold A_Setter + -- An_AffineTraversal ----- instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal An_AffineTraversal k where joinKinds r = r @@ -331,6 +374,8 @@ instance k ~ An_AffineTraversal => JoinKinds An_AffineTraversal A_Lens joinKinds r = r instance k ~ An_AffineFold => JoinKinds An_AffineTraversal A_Getter k where joinKinds r = r +instance k ~ A_Fold => JoinKinds An_AffineTraversal A_NeFold k where + joinKinds r = r instance k ~ An_AffineFold => JoinKinds An_AffineTraversal An_AffineFold k where joinKinds r = r instance k ~ A_Traversal => JoinKinds An_AffineTraversal A_Traversal k where @@ -355,6 +400,8 @@ instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Lens joinKinds r = r instance k ~ An_AffineFold => JoinKinds An_AffineFold A_Getter k where joinKinds r = r +instance k ~ A_Fold => JoinKinds An_AffineFold A_NeFold k where + joinKinds r = r instance k ~ An_AffineFold => JoinKinds An_AffineFold An_AffineTraversal k where joinKinds r = r instance k ~ A_Fold => JoinKinds An_AffineFold A_Traversal k where @@ -378,6 +425,8 @@ instance k ~ A_Traversal => JoinKinds A_Traversal A_Lens joinKinds r = r instance k ~ A_Fold => JoinKinds A_Traversal A_Getter k where joinKinds r = r +instance k ~ A_Fold => JoinKinds A_Traversal A_NeFold k where + joinKinds r = r instance k ~ A_Traversal => JoinKinds A_Traversal An_AffineTraversal k where joinKinds r = r instance k ~ A_Fold => JoinKinds A_Traversal An_AffineFold k where @@ -402,6 +451,8 @@ instance k ~ A_Fold => JoinKinds A_Fold A_Lens joinKinds r = r instance k ~ A_Fold => JoinKinds A_Fold A_Getter k where joinKinds r = r +instance k ~ A_Fold => JoinKinds A_Fold A_NeFold k where + joinKinds r = r instance k ~ A_Fold => JoinKinds A_Fold An_AffineTraversal k where joinKinds r = r instance k ~ A_Fold => JoinKinds A_Fold An_AffineFold k where @@ -423,6 +474,7 @@ instance k ~ A_Setter => JoinKinds A_Setter A_Prism instance k ~ A_Setter => JoinKinds A_Setter A_Lens k where joinKinds r = r -- no JoinKinds A_Setter A_Getter +-- no JoinKinds A_Setter A_NeFold instance k ~ A_Setter => JoinKinds A_Setter An_AffineTraversal k where joinKinds r = r -- no JoinKinds A_Setter An_AffineFold diff --git a/optics-core/src/Optics/Internal/Optic/Types.hs b/optics-core/src/Optics/Internal/Optic/Types.hs index b086a4e0..041472a7 100644 --- a/optics-core/src/Optics/Internal/Optic/Types.hs +++ b/optics-core/src/Optics/Internal/Optic/Types.hs @@ -10,8 +10,6 @@ import Data.Kind (Constraint, Type) import Data.Profunctor.Indexed -import Optics.Internal.Bi - -- | Kind for types used as optic tags, such as 'A_Lens'. -- -- @since 0.2 @@ -35,6 +33,8 @@ data A_ReversedPrism :: OpticKind data A_Getter :: OpticKind -- | Tag for an affine fold. data An_AffineFold :: OpticKind +-- | Tag for a non-empty fold +data A_NeFold :: OpticKind -- | Tag for a fold. data A_Fold :: OpticKind -- | Tag for a reversed lens. @@ -58,5 +58,6 @@ type family Constraints (k :: OpticKind) (p :: Type -> Type -> Type -> Type) :: Constraints A_Setter p = Mapping p Constraints A_Getter p = (Bicontravariant p, Cochoice p, Strong p) Constraints An_AffineFold p = (Bicontravariant p, Cochoice p, Visiting p) - Constraints A_Fold p = (Bicontravariant p, Cochoice p, Traversing p) + Constraints A_NeFold p = Folding1 p + Constraints A_Fold p = Folding p Constraints A_Review p = (Bifunctor p, Choice p, Costrong p) diff --git a/optics-core/src/Optics/Iso.hs b/optics-core/src/Optics/Iso.hs index 4f89c16c..61fbd279 100644 --- a/optics-core/src/Optics/Iso.hs +++ b/optics-core/src/Optics/Iso.hs @@ -345,7 +345,7 @@ involuted a = iso a a {-# INLINE involuted #-} -- | This class provides for symmetric bifunctors. -class Bifunctor p => Swapped p where +class Data.Bifunctor.Bifunctor p => Swapped p where -- | -- @ -- 'swapped' '.' 'swapped' ≡ 'id' diff --git a/optics-core/src/Optics/IxFold.hs b/optics-core/src/Optics/IxFold.hs index f5921fdb..7939f6ce 100644 --- a/optics-core/src/Optics/IxFold.hs +++ b/optics-core/src/Optics/IxFold.hs @@ -73,7 +73,6 @@ import Data.Monoid import Data.Profunctor.Indexed -import Optics.Internal.Bi import Optics.Internal.Indexed import Optics.Internal.Indexed.Classes import Optics.Internal.Fold diff --git a/optics-core/src/Optics/IxNeFold.hs b/optics-core/src/Optics/IxNeFold.hs new file mode 100644 index 00000000..3534f75f --- /dev/null +++ b/optics-core/src/Optics/IxNeFold.hs @@ -0,0 +1,27 @@ +module Optics.IxNeFold + ( + -- * Formation + IxNeFold + + -- * Elimination + , ifoldMap1Of + + -- * Re-exports + , Foldable1WithIndex(..) + ) where + +import Data.Profunctor.Indexed + +import Optics.Internal.Indexed +import Optics.Internal.Indexed.Classes +import Optics.Internal.Optic + +-- | Type synonym for an indexed non-empty fold. +type IxNeFold i s a = Optic' A_NeFold (WithIx i) s a +-- +-- | Fold with index via embedding into a semigroup. +ifoldMap1Of + :: (Is k A_NeFold, Semigroup m, is `HasSingleIndex` i) + => Optic' k is s a + -> (i -> a -> m) -> s -> m +ifoldMap1Of o = \f -> runIxForget (getOptic (castOptic @A_NeFold o) (IxForget f)) id diff --git a/optics-core/src/Optics/NeFold.hs b/optics-core/src/Optics/NeFold.hs new file mode 100644 index 00000000..9cb933a4 --- /dev/null +++ b/optics-core/src/Optics/NeFold.hs @@ -0,0 +1,175 @@ +-- | +-- Module: Optics.NeFold +-- Description: Extracts elements from a container. +-- +-- A @'NeFold' S A@ has the ability to extract some non-zero number of elements of type @A@ +-- from a container of type @S@. For example, 'toNonEmptyOf' can be used to obtain +-- the contained elements as a non-empty list. Unlike a 'Optics.Traversal.Traversal', +-- there is no way to set or update elements. +-- +-- This can be seen as a generalisation of 'foldMap1', where the type @S@ does +-- not need to be a type constructor with @A@ as the last parameter. +-- +-- A close relative is the 'Optics.AffineFold.AffineFold', which is a 'Fold' +-- that contains at most one element. 'NeFold' containst at least one element. +-- +module Optics.NeFold ( + -- * Formation + NeFold + + -- * Introduction + , foldrMapping1 + + -- * Elimination + -- , foldOf + , foldMap1Of + , foldrMap1Of + -- , foldlOf' + , toNonEmptyOf + + -- * Computation + -- + -- | + -- + -- @ + -- 'foldrMap1Of' ('foldrMapping1' f) ≡ f + -- @ + + -- * Additional introduction forms + , folded1 + , folding1 + , foldring + + -- * Additional elimination forms + + -- * Semigroup structure #monoids# + -- | 'NeFold' admits (at least) one semigroups structures: + -- + -- * 'summingL' (or 'summingR') concatenates results from both folds. + -- + -- TODO: one can concatenate 'Fold' with 'NeFold' and still get 'NeFold'. + , summingL + , summingR + + -- * Subtyping + , A_NeFold + -- | <> +) where + + +import Data.Foldable1 +import Data.List.NonEmpty (NonEmpty (..)) + +import qualified Data.List.NonEmpty as NE + +import Data.Profunctor.Indexed + +import Optics.Fold +import Optics.Internal.Optic + +-- | Type synonym for a non-empty fold. +type NeFold s a = Optic' A_NeFold NoIx s a + +-- | Fold via embedding into a semigroup. +foldMap1Of :: (Is k A_NeFold, Semigroup m) => Optic' k is s a -> (a -> m) -> s -> m +foldMap1Of o = runForget #. getOptic (castOptic @A_NeFold o) .# Forget +{-# INLINE foldMap1Of #-} + +-- | Fold right-associatively. +foldrMap1Of :: Is k A_NeFold => Optic' k is s a -> (a -> r) -> (a -> r -> r) -> s -> r +foldrMap1Of o = \one arr s -> + let h a Nothing = one a + h a (Just b) = arr a b + + in appFromMaybe (foldMap1Of o (FromMaybe #. h) s) Nothing + +{-# INLINE foldrMap1Of #-} + +-- | Used for foldrMap1 and foldlMap1 definitions +newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b } + +instance Semigroup (FromMaybe b) where + FromMaybe f <> FromMaybe g = FromMaybe (f . Just . g) + +{- +-- | Used for default toNonEmpty implementation. +newtype NonEmptyDList a = NEDL { unNEDL :: [a] -> NonEmpty a } + +instance Semigroup (NonEmptyDList a) where + xs <> ys = NEDL (unNEDL xs . NE.toList . unNEDL ys) + {-# INLINE (<>) #-} + +-- | Create dlist with a single element +singleton :: a -> NonEmptyDList a +singleton = NEDL #. (:|) + +-- | Convert a dlist to a non-empty list +runNonEmptyDList :: NonEmptyDList a -> NonEmpty a +runNonEmptyDList = ($ []) . unNEDL +{-# INLINE runNonEmptyDList #-} +-} + +-- | Fold to a non-empty list. +-- +-- >>> toNonEmptyOf (_1 % folded1) ('h' :| ['i'], "bye") +-- 'h' :| "i" +toNonEmptyOf :: Is k A_NeFold => Optic' k is s a -> s -> NonEmpty a +toNonEmptyOf o = foldrMap1Of o (\a -> a :| []) NE.cons +{-# INLINE toNonEmptyOf #-} + +---------------------------------------- + +-- | Fold via the 'Foldable1' class. +folded1 :: Foldable1 f => NeFold (f a) a +folded1 = Optic folded1__ +{-# INLINE folded1 #-} + +-- | Obtain a 'NeFold' by lifting an operation that returns a 'Foldable1' result. +-- +-- >>> toListOf (folding tail) [1,2,3,4] +-- [2,3,4] +folding1 :: Foldable1 f => (s -> f a) -> NeFold s a +folding1 f = Optic (contrabimap f f . folded1__) +{-# INLINE folding1 #-} + +-- | Obtain a 'NeFold' by lifting 'foldrMap1' like function. +-- +-- >>> toListOf (foldring foldr) [1,2,3,4] +-- [1,2,3,4] +foldrMapping1 + :: (forall b. (a -> b) -> (a -> b -> b) -> s -> b) + -> NeFold s a +foldrMapping1 fr = Optic (foldrMapping1__ fr) +{-# INLINE foldrMapping1 #-} + +-- | Return entries of the first 'NeFold', then the second one. +-- +-- >>> toNonEmptyOf (_1 % folded `summingL` _2 % folded1) ([1,2], 4 :| [7,1]) +-- 1 :| [2,4,7,1] +-- +summingL + :: (Is k A_Fold, Is l A_NeFold) + => Optic' k is s a + -> Optic' l js s a + -> NeFold s a +summingL a b = foldrMapping1 $ \f g s -> foldrOf a g (foldrMap1Of b f g s) s +infixr 6 `summingL` -- Same as (<>) +{-# INLINE summingL #-} + +-- | Return entries of the first 'NeFold', then the second one. +-- +-- Use 'summingL' if you can. +-- +-- >>> toNonEmptyOf (_1 % folded1 `summingR` _2 % folded2) (0 :| [1,2], 4 :| [7,1]) +-- 0 :| [1,2,4,7,1] +-- +summingR + :: (Is k A_NeFold, Is l A_Fold) + => Optic' k is s a + -> Optic' l js s a + -> NeFold s a +summingR a b = foldrMapping1 $ \f g s -> + let tmp = foldrOf b (\x acc -> Just $ maybe (f x) (g x) acc) Nothing s + in foldrMap1Of a (\x -> maybe (f x) (g x) tmp) g s +infixr 6 `summingR` -- Same as (<>) +{-# INLINE summingR #-} diff --git a/optics-core/src/Optics/Re.hs b/optics-core/src/Optics/Re.hs index 860837ea..239a3624 100644 --- a/optics-core/src/Optics/Re.hs +++ b/optics-core/src/Optics/Re.hs @@ -32,7 +32,6 @@ import Data.Coerce import Data.Profunctor.Indexed -import Optics.Internal.Bi import Optics.Internal.Indexed import Optics.Internal.Optic @@ -125,17 +124,17 @@ instance Profunctor p => Profunctor (Re p s t) where ixcontramap = error "ixcontramap(Re) shouldn't be reachable" instance Bicontravariant p => Bifunctor (Re p s t) where - bimap f g (Re p) = Re (p . contrabimap g f) - first f (Re p) = Re (p . contrasecond f) - second g (Re p) = Re (p . contrafirst g) - {-# INLINE bimap #-} - {-# INLINE first #-} - {-# INLINE second #-} + bimap_ f g (Re p) = Re (p . contrabimap g f) + first_ f (Re p) = Re (p . contrasecond f) + second_ g (Re p) = Re (p . contrafirst g) + {-# INLINE bimap_ #-} + {-# INLINE first_ #-} + {-# INLINE second_ #-} instance Bifunctor p => Bicontravariant (Re p s t) where - contrabimap f g (Re p) = Re (p . bimap g f) - contrafirst f (Re p) = Re (p . second f) - contrasecond g (Re p) = Re (p . first g) + contrabimap f g (Re p) = Re (p . bimap_ g f) + contrafirst f (Re p) = Re (p . second_ f) + contrasecond g (Re p) = Re (p . first_ g) {-# INLINE contrabimap #-} {-# INLINE contrafirst #-} {-# INLINE contrasecond #-}