Foldable1.foldr1 and Foldable1.foldl1

src/Data/Semigroup/Foldable.purs

@@ -2,11 +2,17 @@ module Data.Semigroup.Foldable
   ( class Foldable1
   , foldMap1
   , fold1
+  , foldr1
+  , foldl1
   , traverse1_
   , for1_
   , sequence1_
   , foldMap1Default
   , fold1Default
+  , fold1DefaultR
+  , fold1DefaultL
+  , foldr1Default
+  , foldl1Default
   , intercalate
   , intercalateMap
   , maximum
@@ -18,42 +24,70 @@ import Prelude
 import Data.Foldable (class Foldable)
 import Data.Monoid.Dual (Dual(..))
 import Data.Monoid.Multiplicative (Multiplicative(..))
-import Data.Newtype (ala)
+import Data.Newtype (ala, alaF)
 import Data.Ord.Max (Max(..))
 import Data.Ord.Min (Min(..))
 
 -- | `Foldable1` represents data structures with a minimum of one element that can be _folded_.
 -- |
 -- | - `fold1` folds a structure using a `Semigroup` instance
 -- | - `foldMap1` folds a structure by accumulating values in a `Semigroup`
+-- | - `foldr1` folds a structure from the right
+-- | - `foldl1` folds a structure from the left
 -- |
 -- | Default implementations are provided by the following functions:
 -- |
 -- | - `fold1Default`
+-- | - `fold1DefaultR`
+-- | - `fold1DefaultL`
 -- | - `foldMap1Default`
+-- | - `foldr1Default`
+-- | - `foldl1Default`
 -- |
 -- | Note: some combinations of the default implementations are unsafe to
 -- | use together - causing a non-terminating mutually recursive cycle.
 -- | These combinations are documented per function.
 class Foldable t <= Foldable1 t where
   foldMap1 :: forall a m. Semigroup m => (a -> m) -> t a -> m
   fold1 :: forall m. Semigroup m => t m -> m
+  foldr1 :: forall a. (a -> a -> a) -> t a -> a
+  foldl1 :: forall a. (a -> a -> a) -> t a -> a
 
 -- | A default implementation of `fold1` using `foldMap1`.
 fold1Default :: forall t m. Foldable1 t => Semigroup m => t m -> m
 fold1Default = foldMap1 identity
 
+-- | A default implementation of `fold1` using `foldr1`.
+fold1DefaultR :: forall t m. Foldable1 t => Semigroup m => t m -> m
+fold1DefaultR = foldr1 append
+
+-- | A default implementation of `fold1` using `foldl1`.
+fold1DefaultL :: forall t m. Foldable1 t => Semigroup m => t m -> m
+fold1DefaultL = foldl1 append
+
 -- | A default implementation of `foldMap1` using `fold1`.
 foldMap1Default :: forall t m a. Foldable1 t => Functor t => Semigroup m => (a -> m) -> t a -> m
 foldMap1Default f = (map f) >>> fold1
 
+-- | A default implementation of `foldr1` using `foldMap1`.
+foldr1Default :: forall t a. Foldable1 t => (a -> a -> a) -> t a -> a
+foldr1Default = flip (runFoldRight1 <<< foldMap1 mkFoldRight1)
+
+-- | A default implementation of `foldl1` using `foldMap1`.
+foldl1Default :: forall t a. Foldable1 t => (a -> a -> a) -> t a -> a
+foldl1Default = flip (runFoldRight1 <<< alaF Dual foldMap1 mkFoldRight1) <<< flip
+
 instance foldableDual :: Foldable1 Dual where
   foldMap1 f (Dual x) = f x
   fold1 = fold1Default
+  foldr1 _ (Dual x) = x
+  foldl1 _ (Dual x) = x
 
 instance foldableMultiplicative :: Foldable1 Multiplicative where
   foldMap1 f (Multiplicative x) = f x
   fold1 = fold1Default
+  foldr1 _ (Multiplicative x) = x
+  foldl1 _ (Multiplicative x) = x
 
 newtype Act :: forall k. (k -> Type) -> k -> Type
 newtype Act f a = Act (f a)
@@ -110,3 +144,15 @@ intercalateMap
   => m -> (a -> m) -> f a -> m
 intercalateMap j f foldable =
   joinee (foldMap1 (JoinWith <<< const <<< f) foldable) j
+
+-- | Internal. Used by foldr1Default and foldl1Default.
+data FoldRight1 a = FoldRight1 (a -> (a -> a -> a) -> a) a
+
+instance foldRight1Semigroup :: Semigroup (FoldRight1 a) where
+  append (FoldRight1 lf lr) (FoldRight1 rf rr) = FoldRight1 (\a f -> lf (f lr (rf a f)) f) rr
+
+mkFoldRight1 :: forall a. a -> FoldRight1 a
+mkFoldRight1 = FoldRight1 const
+
+runFoldRight1 :: forall a. FoldRight1 a -> (a -> a -> a) -> a
+runFoldRight1 (FoldRight1 f a) = f a

test/Main.js

@@ -17,3 +17,24 @@ exports.arrayReplicate = function (n) {
     return result;
   };
 };
+
+exports.mkNEArray = function (nothing) {
+  return function (just) {
+    return function (arr) {
+      return arr.length > 0 ? just(arr) : nothing;
+    };
+  };
+};
+
+exports.foldMap1NEArray = function (append) {
+  return function (f) {
+    return function (arr) {
+      var acc = f(arr[0]);
+      var len = arr.length;
+      for (var i = 1; i < len; i++) {
+        acc = append(acc)(f(arr[i]));
+      }
+      return acc;
+    };
+  };
+};

test/Main.purs

@@ -13,6 +13,7 @@ import Data.Int (toNumber, pow)
 import Data.Maybe (Maybe(..))
 import Data.Monoid.Additive (Additive(..))
 import Data.Newtype (unwrap)
+import Data.Semigroup.Foldable (class Foldable1, foldr1, foldl1, fold1Default, foldr1Default, foldl1Default)
 import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
 import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
 import Effect (Effect, foreachE)
@@ -24,6 +25,24 @@ import Unsafe.Coerce (unsafeCoerce)
 foreign import arrayFrom1UpTo :: Int -> Array Int
 foreign import arrayReplicate :: forall a. Int -> a -> Array a
 
+foreign import data NEArray :: Type -> Type
+foreign import mkNEArray :: forall r a. r -> (NEArray a -> r) -> Array a -> r
+foreign import foldMap1NEArray :: forall r a. (r -> r -> r) -> (a -> r) -> NEArray a -> r
+
+instance foldableNEArray :: Foldable NEArray where
+  foldMap = foldMap1NEArray append
+  foldl f = foldlDefault f
+  foldr f = foldrDefault f
+
+instance foldable1NEArray :: Foldable1 NEArray where
+  foldMap1 = foldMap1NEArray append
+  fold1 = fold1Default
+  foldr1 f = foldr1Default f
+  foldl1 f = foldl1Default f
+
+maybeMkNEArray :: forall a. Array a -> Maybe (NEArray a)
+maybeMkNEArray = mkNEArray Nothing Just
+
 foldableLength :: forall f a. Foldable f => f a -> Int
 foldableLength = unwrap <<< foldMap (const (Additive 1))
 
@@ -177,6 +196,10 @@ main = do
   assert $ "*0a*1b*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
   assert $ "*0a*1b*2c*" == surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]
 
+  log "Test Foldable1 defaults"
+  assert $ "(a(b(cd)))" == foldMap (foldr1 (\x y -> "(" <> x <> y <> ")")) (maybeMkNEArray ["a", "b", "c", "d"])
+  assert $ "(((ab)c)d)" == foldMap (foldl1 (\x y -> "(" <> x <> y <> ")")) (maybeMkNEArray ["a", "b", "c", "d"])
+
   log "All done!"