Add optic utilities for Fold1s

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

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)
 

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
 

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
 

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 #-}
+