diff options
-rw-r--r-- | libraries/base/Data/Bifoldable1.hs | 49 | ||||
-rw-r--r-- | libraries/base/Data/Foldable1.hs | 513 | ||||
-rw-r--r-- | libraries/base/base.cabal | 2 | ||||
-rw-r--r-- | libraries/base/changelog.md | 3 |
4 files changed, 566 insertions, 1 deletions
diff --git a/libraries/base/Data/Bifoldable1.hs b/libraries/base/Data/Bifoldable1.hs new file mode 100644 index 0000000000..9e0521a9bd --- /dev/null +++ b/libraries/base/Data/Bifoldable1.hs @@ -0,0 +1,49 @@ +-- | +-- Copyright: Edward Kmett, Oleg Grenrus +-- License: BSD-3-Clause +-- + +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} + +module Data.Bifoldable1 where + +import Control.Applicative (Const (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Semigroup (Arg (..), Semigroup (..)) +import Prelude (Either (..), id) + +class Bifoldable t => Bifoldable1 t where + bifold1 :: Semigroup m => t m m -> m + bifold1 = bifoldMap1 id id + {-# INLINE bifold1 #-} + + bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m + +instance Bifoldable1 Arg where + bifoldMap1 f g (Arg a b) = f a <> g b + +instance Bifoldable1 Either where + bifoldMap1 f _ (Left a) = f a + bifoldMap1 _ g (Right b) = g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 (,) where + bifoldMap1 f g (a, b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 ((,,) x) where + bifoldMap1 f g (_,a,b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 ((,,,) x y) where + bifoldMap1 f g (_,_,a,b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 ((,,,,) x y z) where + bifoldMap1 f g (_,_,_,a,b) = f a <> g b + {-# INLINE bifoldMap1 #-} + +instance Bifoldable1 Const where + bifoldMap1 f _ (Const a) = f a + {-# INLINE bifoldMap1 #-} diff --git a/libraries/base/Data/Foldable1.hs b/libraries/base/Data/Foldable1.hs new file mode 100644 index 0000000000..c0dac6a0f5 --- /dev/null +++ b/libraries/base/Data/Foldable1.hs @@ -0,0 +1,513 @@ +-- | +-- Copyright: Edward Kmett, Oleg Grenrus +-- License: BSD-3-Clause +-- + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +-- | A class of non-empty data structures that can be folded to a summary value. +module Data.Foldable1 ( + Foldable1(..), + foldr1, foldr1', + foldl1, foldl1', + intercalate1, + foldrM1, + foldlM1, + foldrMapM1, + foldlMapM1, + maximumBy, + minimumBy, + ) where + +import Data.Foldable (Foldable, foldlM, foldr) +import Data.List (foldl, foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup + (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..), + Semigroup (..), Sum (..)) +import Prelude + (Maybe (..), Monad (..), Ord, Ordering (..), id, seq, ($!), ($), (.), + (=<<), flip, const, error) + +import qualified Data.List.NonEmpty as NE + +import Data.Complex (Complex (..)) +import GHC.Generics + (M1 (..), Par1 (..), Rec1 (..), V1, (:*:) (..), (:+:) (..), (:.:) (..)) + +import Data.Ord (Down (..)) + +import qualified Data.Monoid as Mon + +-- Instances +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Identity (Identity (..)) + +import qualified Data.Functor.Product as Functor +import qualified Data.Functor.Sum as Functor + +-- coerce +import Data.Coerce (Coercible, coerce) + +-- $setup +-- >>> import Prelude hiding (foldr1, foldl1, head, last, minimum, maximum) + +------------------------------------------------------------------------------- +-- Foldable1 type class +------------------------------------------------------------------------------- + +-- | Non-empty data structures that can be folded. +class Foldable t => Foldable1 t where + {-# MINIMAL foldMap1 | foldrMap1 #-} + + -- At some point during design it was possible to define this class using + -- only 'toNonEmpty'. But it seems a bad idea in general. + -- + -- So currently we require either foldMap1 or foldrMap1 + -- + -- * foldMap1 defined using foldrMap1 + -- * foldrMap1 defined using foldMap1 + -- + -- One can always define an instance using the following pattern: + -- + -- toNonEmpty = ... + -- foldMap f = foldMap f . toNonEmpty + -- foldrMap1 f g = foldrMap1 f g . toNonEmpty + + -- | Combine the elements of a structure using a semigroup. + fold1 :: Semigroup m => t m -> m + fold1 = foldMap1 id + + -- | Map each element of the structure to a semigroup, + -- and combine the results. + -- + -- >>> foldMap1 Sum (1 :| [2, 3, 4]) + -- Sum {getSum = 10} + -- + foldMap1 :: Semigroup m => (a -> m) -> t a -> m + foldMap1 f = foldrMap1 f (\a m -> f a <> m) + + -- | A variant of 'foldMap1' that is strict in the accumulator. + -- + -- >>> foldMap1' Sum (1 :| [2, 3, 4]) + -- Sum {getSum = 10} + -- + foldMap1' :: Semigroup m => (a -> m) -> t a -> m + foldMap1' f = foldlMap1' f (\m a -> m <> f a) + + -- | List of elements of a structure, from left to right. + -- + -- >>> toNonEmpty (Identity 2) + -- 2 :| [] + -- + toNonEmpty :: t a -> NonEmpty a + toNonEmpty = runNonEmptyDList . foldMap1 singleton + + -- | The largest element of a non-empty structure. + -- + -- >>> maximum (32 :| [64, 8, 128, 16]) + -- 128 + -- + maximum :: Ord a => t a -> a + maximum = getMax #. foldMap1' Max + + -- | The least element of a non-empty structure. + -- + -- >>> minimum (32 :| [64, 8, 128, 16]) + -- 8 + -- + minimum :: Ord a => t a -> a + minimum = getMin #. foldMap1' Min + + -- | The first element of a non-empty structure. + -- + -- >>> head (1 :| [2, 3, 4]) + -- 1 + -- + head :: t a -> a + head = getFirst #. foldMap1 First + + -- | The last element of a non-empty structure. + -- + -- >>> last (1 :| [2, 3, 4]) + -- 4 + -- + last :: t a -> a + last = getLast #. foldMap1 Last + + -- | Generalized 'foldr1'. + foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b + foldrMap1 f g xs = + appFromMaybe (foldMap1 (FromMaybe #. h) xs) Nothing + where + h a Nothing = f a + h a (Just b) = g a b + + -- | Generalized 'foldl1''. + foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b + foldlMap1' f g xs = + foldrMap1 f' g' xs SNothing + where + -- f' :: a -> SMaybe b -> b + f' a SNothing = f a + f' a (SJust b) = g b a + + -- g' :: a -> (SMaybe b -> b) -> SMaybe b -> b + g' a x SNothing = x $! SJust (f a) + g' a x (SJust b) = x $! SJust (g b a) + + -- | Generalized 'foldl1'. + foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b + foldlMap1 f g xs = + appFromMaybe (getDual (foldMap1 ((Dual . FromMaybe) #. h) xs)) Nothing + where + h a Nothing = f a + h a (Just b) = g b a + + -- | Generalized 'foldr1''. + foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b + foldrMap1' f g xs = + foldlMap1 f' g' xs SNothing + where + f' a SNothing = f a + f' a (SJust b) = g a b + + g' bb a SNothing = bb $! SJust (f a) + g' bb a (SJust b) = bb $! SJust (g a b) + +------------------------------------------------------------------------------- +-- Combinators +------------------------------------------------------------------------------- + +-- | Right-associative fold of a structure. +-- +-- In the case of lists, 'foldr1', when applied to a binary operator, +-- and a list, reduces the list using the binary operator, +-- from right to left: +-- +-- > foldr1 f [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn1 `f` xn )...) +-- +-- Note that, since the head of the resulting expression is produced by +-- an application of the operator to the first element of the list, +-- 'foldr1' can produce a terminating expression from an infinite list. +-- +-- For a general 'Foldable1' structure this should be semantically identical +-- to, +-- +-- @foldr1 f = foldr1 f . 'toNonEmpty'@ +-- +foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a +foldr1 = foldrMap1 id +{-# INLINE foldr1 #-} + +-- | Right-associative fold of a structure, but with strict application of +-- the operator. +-- +foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a +foldr1' = foldrMap1' id +{-# INLINE foldr1' #-} + +-- | Left-associative fold of a structure. +-- +-- In the case of lists, 'foldl1', when applied to a binary +-- operator, and a list, reduces the list using the binary operator, +-- from left to right: +-- +-- > foldl1 f [x1, x2, ..., xn] == (...((x1 `f` x2) `f`...) `f` xn +-- +-- Note that to produce the outermost application of the operator the +-- entire input list must be traversed. This means that 'foldl1' will +-- diverge if given an infinite list. +-- +-- Also note that if you want an efficient left-fold, you probably want to +-- use 'foldl1'' instead of 'foldl1'. The reason for this is that latter does +-- not force the "inner" results (e.g. @x1 \`f\` x2@ in the above example) +-- before applying them to the operator (e.g. to @(\`f\` x3)@). This results +-- in a thunk chain \(\mathcal{O}(n)\) elements long, which then must be +-- evaluated from the outside-in. +-- +-- For a general 'Foldable1' structure this should be semantically identical +-- to, +-- +-- @foldl1 f z = foldl1 f . 'toNonEmpty'@ +-- +foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a +foldl1 = foldlMap1 id +{-# INLINE foldl1 #-} + +-- | Left-associative fold of a structure but with strict application of +-- the operator. +-- +-- This ensures that each step of the fold is forced to weak head normal +-- form before being applied, avoiding the collection of thunks that would +-- otherwise occur. This is often what you want to strictly reduce a finite +-- list to a single, monolithic result (e.g. 'length'). +-- +-- For a general 'Foldable1' structure this should be semantically identical +-- to, +-- +-- @foldl1' f z = foldl1 f . 'toNonEmpty'@ +-- +foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a +foldl1' = foldlMap1' id +{-# INLINE foldl1' #-} + +-- | Insert an @m@ between each pair of @t m@. +-- +-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"] +-- "hello, how, are, you" +-- +-- >>> intercalate1 ", " $ "hello" :| [] +-- "hello" +-- +-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"] +-- "IAmFineYou?" +-- +intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m +intercalate1 = flip intercalateMap1 id + +intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m +intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f) + +-- | Monadic fold over the elements of a non-empty structure, +-- associating to the right, i.e. from right to left. +foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a +foldrM1 = foldrMapM1 return + +-- | Map variant of 'foldrM1'. +foldrMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (a -> b -> m b) -> t a -> m b +foldrMapM1 g f = go . toNonEmpty + where + go (e:|es) = + case es of + [] -> g e + x:xs -> f e =<< go (x:|xs) + +-- | Monadic fold over the elements of a non-empty structure, +-- associating to the left, i.e. from left to right. +foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a +foldlM1 = foldlMapM1 return + +-- | Map variant of 'foldlM1'. +foldlMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (b -> a -> m b) -> t a -> m b +foldlMapM1 g f t = g x >>= \y -> foldlM f y xs + where x:|xs = toNonEmpty t + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. + +-- See Note [maximumBy/minimumBy space usage] +maximumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a +maximumBy cmp = foldl1' max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. + +-- See Note [maximumBy/minimumBy space usage] +minimumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a +minimumBy cmp = foldl1' min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +------------------------------------------------------------------------------- +-- Auxiliary types +------------------------------------------------------------------------------- + +-- | 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 #-} + +-- | 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) + +-- | Strict maybe, used to implement default foldlMap1' etc. +data SMaybe a = SNothing | SJust !a + +-- | Used to implement intercalate1/Map +newtype JoinWith a = JoinWith {joinee :: (a -> a)} + +instance Semigroup a => Semigroup (JoinWith a) where + JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j + +------------------------------------------------------------------------------- +-- Instances for misc base types +------------------------------------------------------------------------------- + +instance Foldable1 NonEmpty where + foldMap1 f (x :| xs) = go (f x) xs where + go y [] = y + go y (z : zs) = y <> go (f z) zs + + foldMap1' f (x :| xs) = foldl' (\m y -> m <> f y) (f x) xs + + toNonEmpty = id + + foldrMap1 g f (x :| xs) = go x xs where + go y [] = g y + go y (z : zs) = f y (go z zs) + + foldlMap1 g f (x :| xs) = foldl f (g x) xs + foldlMap1' g f (x :| xs) = let gx = g x in gx `seq` foldl' f gx xs + + head = NE.head + last = NE.last + +instance Foldable1 Down where + foldMap1 = coerce + +instance Foldable1 Complex where + foldMap1 f (x :+ y) = f x <> f y + + toNonEmpty (x :+ y) = x :| y : [] + +------------------------------------------------------------------------------- +-- Instances for tuples +------------------------------------------------------------------------------- + +-- 3+ tuples are not Foldable/Traversable + +instance Foldable1 ((,) a) where + foldMap1 f (_, y) = f y + toNonEmpty (_, x) = x :| [] + minimum (_, x) = x + maximum (_, x) = x + head (_, x) = x + last (_, x) = x + +------------------------------------------------------------------------------- +-- Monoid / Semigroup instances +------------------------------------------------------------------------------- + +instance Foldable1 Dual where + foldMap1 = coerce + +instance Foldable1 Sum where + foldMap1 = coerce + +instance Foldable1 Product where + foldMap1 = coerce + +instance Foldable1 Min where + foldMap1 = coerce + +instance Foldable1 Max where + foldMap1 = coerce + +instance Foldable1 First where + foldMap1 = coerce + +instance Foldable1 Last where + foldMap1 = coerce + +deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f) + +deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f) + +------------------------------------------------------------------------------- +-- GHC.Generics instances +------------------------------------------------------------------------------- + +instance Foldable1 V1 where + foldMap1 _ x = x `seq` error "foldMap1 @V1" + +instance Foldable1 Par1 where + foldMap1 = coerce + +deriving instance Foldable1 f => Foldable1 (Rec1 f) + +deriving instance Foldable1 f => Foldable1 (M1 i c f) + +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where + foldMap1 f (L1 x) = foldMap1 f x + foldMap1 f (R1 y) = foldMap1 f y + +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where + foldMap1 f (x :*: y) = foldMap1 f x <> foldMap1 f y + +instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where + foldMap1 f = foldMap1 (foldMap1 f) . unComp1 + +------------------------------------------------------------------------------- +-- Extra instances +------------------------------------------------------------------------------- + +instance Foldable1 Identity where + foldMap1 = coerce + + foldrMap1 g _ = coerce g + foldrMap1' g _ = coerce g + foldlMap1 g _ = coerce g + foldlMap1' g _ = coerce g + + toNonEmpty (Identity x) = x :| [] + + last = coerce + head = coerce + minimum = coerce + maximum = coerce + +-- | It would be enough for either half of a product to be 'Foldable1'. +-- Other could be 'Foldable'. +instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where + foldMap1 f (Functor.Pair x y) = foldMap1 f x <> foldMap1 f y + foldrMap1 g f (Functor.Pair x y) = foldr f (foldrMap1 g f y) x + + head (Functor.Pair x _) = head x + last (Functor.Pair _ y) = last y + +instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where + foldMap1 f (Functor.InL x) = foldMap1 f x + foldMap1 f (Functor.InR y) = foldMap1 f y + + foldrMap1 g f (Functor.InL x) = foldrMap1 g f x + foldrMap1 g f (Functor.InR y) = foldrMap1 g f y + + toNonEmpty (Functor.InL x) = toNonEmpty x + toNonEmpty (Functor.InR y) = toNonEmpty y + + head (Functor.InL x) = head x + head (Functor.InR y) = head y + last (Functor.InL x) = last x + last (Functor.InR y) = last y + + minimum (Functor.InL x) = minimum x + minimum (Functor.InR y) = minimum y + maximum (Functor.InL x) = maximum x + maximum (Functor.InR y) = maximum y + +instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where + foldMap1 f = foldMap1 (foldMap1 f) . getCompose + + foldrMap1 f g = foldrMap1 (foldrMap1 f g) (\xs x -> foldr g x xs) . getCompose + + head = head . head . getCompose + last = last . last . getCompose + +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c +(#.) _f = coerce diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index a8223bbce8..58e11e30f7 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -115,6 +115,7 @@ Library Control.Monad.Zip Data.Array.Byte Data.Bifoldable + Data.Bifoldable1 Data.Bifunctor Data.Bitraversable Data.Bits @@ -128,6 +129,7 @@ Library Data.Eq Data.Fixed Data.Foldable + Data.Foldable1 Data.Function Data.Functor Data.Functor.Classes diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 2b6aea6f6c..1517a48572 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -6,7 +6,8 @@ exception handler. * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which the user to override the above-mentioned handler. - * `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe`. + * `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe`. + * Add `Data.Foldable1` and `Data.Bifoldable1`. ## 4.17.0.0 *TBA* |