From c1c9237f2ea3fd84adad4bbb835ad24fcc81ee01 Mon Sep 17 00:00:00 2001 From: Tobias Haslop Date: Sat, 24 Aug 2024 11:24:49 +0200 Subject: [PATCH] Add optic utilities for Fold1s --- CHANGELOG.md | 2 +- bench/Foldl.hs | 23 +++++++++ foldl.cabal | 3 +- src/Control/Foldl.hs | 9 ++-- src/Control/Foldl/NonEmpty.hs | 97 ++++++++++++++++++++++++++++++++++- 5 files changed, 126 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index fa5fd83..1adedc0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ -- Add [Fold1 utilities](): `purely`, `purely_`, `premap` +- Add [Fold1 utilities](): `purely`, `purely_`, `premap`, `handles`, `foldOver`, `folded1` - Add pattern synonym `Fold1_` that makes the initial, step and extraction functions explicit. 1.4.16 diff --git a/bench/Foldl.hs b/bench/Foldl.hs index 5c22eaf..a6ecaa0 100644 --- a/bench/Foldl.hs +++ b/bench/Foldl.hs @@ -3,11 +3,16 @@ module Main (main) where import Control.Foldl hiding (map) +import qualified Control.Foldl.NonEmpty as Foldl1 import Criterion.Main import qualified Data.List import Prelude hiding (length, sum) import qualified Prelude import qualified Data.Foldable as Foldable +import Data.Functor.Contravariant (Contravariant(..)) +import Data.Profunctor (Profunctor(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty main :: IO () main = defaultMain @@ -50,9 +55,27 @@ main = defaultMain nf sumAndLength_foldl ] ] + , env (return $ 1 :| [2..10000 :: Int]) $ \ns -> + bgroup "1 :| [2..10000 :: Int]" + [ bgroup "handles" $ map ($ ns) + [ bench "fold (handles (to succ) list)" . + nf (fold (handles (to succ) list)) + , bench "foldM (handlesM (to succ) (generalize list))" . + nfIO . foldM (handlesM (to succ) (generalize list)) + , bench "NonEmpty.map succ" . + nf (NonEmpty.map succ) + , bench "Foldl1.fold1 (Foldl1.handles (to succ) (Foldl1.fromFold list))" . + nf (Foldl1.fold1 (Foldl1.handles (to succ) (Foldl1.fromFold list))) + ] + ] ] +-- local definition to avoid importing Control.Lens.Getter.to +to :: (Profunctor p, Contravariant f) => (s -> a) -> p a (f a) -> p s (f s) +to k = dimap k (contramap k) +{-# INLINE to #-} + sumAndLength :: Num a => [a] -> (a, Int) sumAndLength xs = (Prelude.sum xs, Prelude.length xs) diff --git a/foldl.cabal b/foldl.cabal index f69c0a4..98170a5 100644 --- a/foldl.cabal +++ b/foldl.cabal @@ -62,7 +62,8 @@ Benchmark Foldl Build-Depends: base, criterion, - foldl + foldl, + profunctors GHC-Options: -O2 -Wall -rtsopts -with-rtsopts=-T Default-Language: Haskell2010 diff --git a/src/Control/Foldl.hs b/src/Control/Foldl.hs index 481b88b..3458eba 100644 --- a/src/Control/Foldl.hs +++ b/src/Control/Foldl.hs @@ -209,6 +209,7 @@ import qualified Data.Semigroupoid {- $setup >>> import qualified Control.Foldl as Foldl +>>> import Data.Functor.Apply (Apply(..)) >>> _2 f (x, y) = fmap (\i -> (x, i)) (f y) @@ -218,7 +219,7 @@ import qualified Data.Semigroupoid >>> in Control.Foldl.Optics.prism Just maybeEither >>> :} ->>> both f (x, y) = (,) <$> f x <*> f y +>>> both f (x, y) = (,) <$> f x <.> f y -} @@ -1349,7 +1350,7 @@ type Handler a b = >>> fold (handles traverse sum) [[1..5],[6..10]] 55 ->>> fold (handles (traverse.traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]] +>>> fold (handles (traverse . traverse) sum) [[Nothing, Just 2, Just 7],[Just 13, Nothing, Just 20]] 42 >>> fold (handles (filtered even) sum) [1..10] @@ -1382,7 +1383,7 @@ handles k (Fold step begin done) = Fold step' begin done > Foldl.foldOver f folder xs == Foldl.fold folder (xs^..f) -> Foldl.foldOver (folded.f) folder == Foldl.fold (handles f folder) +> Foldl.foldOver (folded . f) folder == Foldl.fold (handles f folder) > Foldl.foldOver folded == Foldl.fold @@ -1443,7 +1444,7 @@ handlesM k (FoldM step begin done) = FoldM step' begin done {- | @(foldOverM f folder xs)@ folds all values from a Lens, Traversal, Prism or Fold monadically with the given folder -> Foldl.foldOverM (folded.f) folder == Foldl.foldM (handlesM f folder) +> Foldl.foldOverM (folded . f) folder == Foldl.foldM (handlesM f folder) > Foldl.foldOverM folded == Foldl.foldM diff --git a/src/Control/Foldl/NonEmpty.hs b/src/Control/Foldl/NonEmpty.hs index 35a1a32..3aad0f7 100644 --- a/src/Control/Foldl/NonEmpty.hs +++ b/src/Control/Foldl/NonEmpty.hs @@ -52,14 +52,23 @@ module Control.Foldl.NonEmpty ( , purely , purely_ , premap + , FromMaybe(..) + , Handler1 + , handles + , foldOver + , folded1 ) where -import Control.Applicative (liftA2) +import Control.Applicative (liftA2, Const(..)) import Control.Foldl (Fold(..)) import Control.Foldl.Internal (Either'(..)) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Monoid (Dual(..)) +import Data.Functor.Apply (Apply) import Data.Profunctor (Profunctor(..)) -import Data.Semigroup.Foldable (Foldable1(..)) +import Data.Semigroup.Foldable (Foldable1(..), traverse1_) +import Data.Functor.Contravariant (Contravariant(..)) + import Prelude hiding (head, last, minimum, maximum) import qualified Control.Foldl as Foldl @@ -68,8 +77,14 @@ import qualified Control.Foldl as Foldl >>> import qualified Control.Foldl.NonEmpty as Foldl1 >>> import qualified Data.List.NonEmpty as NonEmpty +>>> import Data.Functor.Apply (Apply(..)) +>>> import Data.Semigroup.Traversable (Traversable1(..)) >>> import Data.Monoid (Sum(..)) +>>> _2 f (x, y) = fmap (\i -> (x, i)) (f y) + +>>> both f (x, y) = (,) <$> f x <.> f y + -} {-| A `Fold1` is like a `Fold` except that it consumes at least one input @@ -338,3 +353,81 @@ premap f (Fold1 k) = Fold1 k' where k' a = lmap f (k (f a)) {-# INLINABLE premap #-} + +{-| +> instance Monad m => Semigroup (FromMaybe m a) where +> mappend (FromMaybe f) (FromMaybe g) = FromMaybeM (f . Just . g) +-} +newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b } + +instance Semigroup (FromMaybe b) where + FromMaybe f <> FromMaybe g = FromMaybe (f . (Just $!) . g) + {-# INLINE (<>) #-} + +{-| A handler for the upstream input of a `Fold1` + + This is compatible with van Laarhoven optics as defined in the lens package. + Any lens, fold1 or traversal1 will type-check as a `Handler1`. +-} +type Handler1 a b = + forall x. (b -> Const (Dual (FromMaybe x)) b) -> a -> Const (Dual (FromMaybe x)) a + +{-| @(handles t folder)@ transforms the input of a `Fold1` using a Lens, + Traversal1, or Fold1 optic: + +> handles _1 :: Fold1 a r -> Fold1 (a, b) r +> handles traverse1 :: Traversable1 t => Fold1 a r -> Fold1 (t a) r +> handles folded1 :: Foldable1 t => Fold1 a r -> Fold1 (t a) r + +>>> Foldl1.fold1 (handles traverse1 Foldl1.nonEmpty) $ (1 :| [2..4]) :| [ 5 :| [6,7], 8 :| [9,10] ] +1 :| [2,3,4,5,6,7,8,9,10] + +>>> Foldl1.fold1 (handles _2 Foldl1.sconcat) $ (1,"Hello ") :| [(2,"World"),(3,"!")] +"Hello World!" + +> handles id = id +> +> handles (f . g) = handles f . handles g + +> handles t (pure r) = pure r +> +> handles t (f <*> x) = handles t f <*> handles t x +-} +handles :: forall a b r. Handler1 a b -> Fold1 b r -> Fold1 a r +handles k (Fold1_ begin step done) = Fold1_ begin' step' done + where + begin' = stepAfromMaybe Nothing + step' x = stepAfromMaybe (Just $! x) + stepAfromMaybe = flip (appFromMaybe . getDual . getConst . k (Const . Dual . FromMaybe . flip stepBfromMaybe)) + stepBfromMaybe = maybe begin step +{-# INLINABLE handles #-} + +{- | @(foldOver f folder xs)@ folds all values from a Lens, Traversal1 or Fold1 optic with the given folder + +>>> foldOver (_2 . both) Foldl1.nonEmpty (1, (2, 3)) +2 :| [3] + +> Foldl1.foldOver f folder xs == Foldl1.fold1 folder (xs ^.. f) + +> Foldl1.foldOver (folded1 . f) folder == Foldl1.fold1 (Foldl1.handles f folder) + +> Foldl1.foldOver folded1 == Foldl1.fold1 + +-} +foldOver :: Handler1 s a -> Fold1 a b -> s -> b +foldOver l (Fold1_ begin step done) = + done . stepSfromMaybe Nothing + where + stepSfromMaybe = flip (appFromMaybe . getDual . getConst . l (Const . Dual . FromMaybe . flip stepAfromMaybe)) + stepAfromMaybe = maybe begin step +{-# INLINABLE foldOver #-} + +{-| +> handles folded1 :: Foldable1 t => Fold1 a r -> Fold1 (t a) r +-} +folded1 + :: (Contravariant f, Apply f, Foldable1 t) + => (a -> f a) -> (t a -> f (t a)) +folded1 k ts = contramap (\_ -> ()) (traverse1_ k ts) +{-# INLINABLE folded1 #-} +