foldable1-classes-compat-0.1/0000755000000000000000000000000007346545000014310 5ustar0000000000000000foldable1-classes-compat-0.1/CHANGELOG.markdown0000644000000000000000000000026607346545000017347 0ustar0000000000000000# Revision history for foldable1-classes-compat ## 0.1 -- 2023-02-24 * Backport the `Foldable1` and `Bifoldable1` type classes that were introduced in `base-4.18.0.0` (GHC 9.6). foldable1-classes-compat-0.1/LICENSE0000644000000000000000000000277107346545000015324 0ustar0000000000000000Copyright (c) Edward Kmett, Oleg Grenrus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Don Stewart nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. foldable1-classes-compat-0.1/README.markdown0000644000000000000000000000260107346545000017010 0ustar0000000000000000# `foldable1-classes-compat` [![Hackage](https://img.shields.io/hackage/v/foldable1-classes-compat.svg)][Hackage: foldable1-classes-compat] [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/foldable1-classes-compat.svg)](http://packdeps.haskellers.com/reverse/foldable1-classes-compat) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] [![Build](https://github.com/haskell-compat/foldable1-classes-compat/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-compat/foldable1-classes-compat/actions?query=workflow%3AHaskell-CI) [Hackage: foldable1-classes-compat]: http://hackage.haskell.org/package/foldable1-classes-compat "foldable1-classes-compat package on Hackage" [Haskell.org]: http://www.haskell.org "The Haskell Programming Language" [tl;dr Legal: BSD3]: https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" A compatibility package for the `Foldable1` and `Bifoldable1` type classes, which were introduced in `base-4.18.0.0` (GHC 9.6.1). For more information, see [this Core Libraries Committee proposal](https://github.com/haskell/core-libraries-committee/issues/9). `Foldable1` and `Bifoldable1` classify non-empty data structures that can be folded to a summary value. foldable1-classes-compat-0.1/Setup.hs0000644000000000000000000000005607346545000015745 0ustar0000000000000000import Distribution.Simple main = defaultMain foldable1-classes-compat-0.1/bench/0000755000000000000000000000000007346545000015367 5ustar0000000000000000foldable1-classes-compat-0.1/bench/Bench.hs0000644000000000000000000001400407346545000016741 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} #if MIN_VERSION_base(4,18,0) # define HAS_FOLDABLE1_CONTAINERS MIN_VERSION_containers(0,6,7) #else # define HAS_FOLDABLE1_CONTAINERS 1 #endif module Main (main) where import Prelude hiding (foldl1, head, last, maximum) import Control.DeepSeq (NFData (..)) import Criterion.Main import qualified Data.Foldable as F (Foldable) import Data.Foldable1 import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup (Min (..)) #if HAS_FOLDABLE1_CONTAINERS import Data.Tree (Tree (..)) #endif input :: NonEmpty Int input = 1 :| take 10000000 [2 .. ] #if HAS_FOLDABLE1_CONTAINERS tree :: Tree Int tree = go 7 0 where go :: Int -> Int -> Tree Int go n x | n <= 0 = Node x [] | otherwise = Node x [ go (pred n) (x * 10 + x') | x' <- [0 .. 9] ] #endif main :: IO () main = defaultMain -- NonEmpty left folds [ env (return input) $ \ne -> bgroup "NonEmpty-vanilla" [ bench "foldMap1 Min" $ whnf (getMin . foldMap1 Min) ne , bench "foldMap1' Min" $ whnf (getMin . foldMap1' Min) ne , bench "foldl1' min" $ whnf (foldl1' min) ne , bench "foldl1 min" $ whnf (foldl1 min) ne , bench "foldlMap1' id min" $ whnf (foldlMap1' id min) ne , bench "foldlMap1 id min" $ whnf (foldlMap1 id min) ne ] , env (return $ NE1 input) $ \ne -> bgroup "NonEmpty-foldMap1" [ bench "foldMap1 Min" $ whnf (getMin . foldMap1 Min) ne , bench "foldMap1' Min" $ whnf (getMin . foldMap1' Min) ne , bench "foldl1' min" $ whnf (foldl1' min) ne , bench "foldl1 min" $ whnf (foldl1 min) ne , bench "foldlMap1' id min" $ whnf (foldlMap1' id min) ne , bench "foldlMap1 id min" $ whnf (foldlMap1 id min) ne ] , env (return $ NE3 input) $ \ne -> bgroup "NonEmpty-foldrMap1" [ bench "foldMap1 Min" $ whnf (getMin . foldMap1 Min) ne , bench "foldMap1' Min" $ whnf (getMin . foldMap1' Min) ne , bench "foldl1' min" $ whnf (foldl1' min) ne , bench "foldl1 min" $ whnf (foldl1 min) ne , bench "foldlMap1' id min" $ whnf (foldlMap1' id min) ne , bench "foldlMap1 id min" $ whnf (foldlMap1 id min) ne ] #if HAS_FOLDABLE1_CONTAINERS -- Trees , env (return tree) $ \tr -> bgroup "Tree-vanilla" [ bench "head" $ whnf head tr , bench "last" $ whnf last tr , bench "maximum" $ whnf maximum tr , bench "maximum'" $ whnf (foldl1' max) tr , bench "foldMap1 Min" $ whnf (getMin . foldMap1 Min) tr , bench "foldMap1' Min" $ whnf (getMin . foldMap1' Min) tr , bench "foldl1' min" $ whnf (foldl1' min) tr , bench "foldl1 min" $ whnf (foldl1 min) tr , bench "foldlMap1' id min" $ whnf (foldlMap1' id min) tr , bench "foldlMap1 id min" $ whnf (foldlMap1 id min) tr ] , env (return $ Tree1 tree) $ \tr -> bgroup "Tree-foldMap1" [ bench "head" $ whnf head tr , bench "last" $ whnf last tr , bench "maximum" $ whnf maximum tr , bench "maximum'" $ whnf (foldl1' max) tr , bench "foldMap1 Min" $ whnf (getMin . foldMap1 Min) tr , bench "foldMap1' Min" $ whnf (getMin . foldMap1' Min) tr , bench "foldl1' min" $ whnf (foldl1' min) tr , bench "foldl1 min" $ whnf (foldl1 min) tr , bench "foldlMap1' id min" $ whnf (foldlMap1' id min) tr , bench "foldlMap1 id min" $ whnf (foldlMap1 id min) tr ] , env (return $ Tree3 tree) $ \tr -> bgroup "Tree-foldr1Map" [ bench "head" $ whnf head tr , bench "last" $ whnf last tr , bench "maximum" $ whnf maximum tr , bench "maximum'" $ whnf (foldl1' max) tr , bench "foldMap1 Min" $ whnf (getMin . foldMap1 Min) tr , bench "foldMap1' Min" $ whnf (getMin . foldMap1' Min) tr , bench "foldl1' min" $ whnf (foldl1' min) tr , bench "foldl1 min" $ whnf (foldl1 min) tr , bench "foldlMap1' id min" $ whnf (foldlMap1' id min) tr , bench "foldlMap1 id min" $ whnf (foldlMap1 id min) tr ] #endif ] ------------------------------------------------------------------------------- -- NonEmpty variants ------------------------------------------------------------------------------- -- Using foldMap1 only newtype NE1 a = NE1 (NonEmpty a) deriving (Functor, F.Foldable) instance NFData a => NFData (NE1 a) where rnf (NE1 xs) = rnf xs instance Foldable1 NE1 where foldMap1 f (NE1 xs) = foldMap1 f xs -- Using toNonEmpty -- newtype NE2 a = NE2 (NonEmpty a) -- deriving (Functor, F.Foldable) -- -- instance NFData a => NFData (NE2 a) where -- rnf (NE2 xs) = rnf xs -- -- instance Foldable1 NE2 where -- toNonEmpty (NE2 xs) = toNonEmpty xs -- Using to foldrMap1 newtype NE3 a = NE3 (NonEmpty a) deriving (Functor, F.Foldable) instance NFData a => NFData (NE3 a) where rnf (NE3 xs) = rnf xs instance Foldable1 NE3 where foldrMap1 g f (NE3 xs) = foldrMap1 g f xs #if HAS_FOLDABLE1_CONTAINERS ------------------------------------------------------------------------------- -- Tree variants ------------------------------------------------------------------------------- -- Using foldMap1 only newtype Tree1 a = Tree1 (Tree a) deriving (Functor, F.Foldable) instance NFData a => NFData (Tree1 a) where rnf (Tree1 xs) = rnf xs instance Foldable1 Tree1 where foldMap1 f (Tree1 xs) = foldMap1 f xs -- Using toNonEmpty -- newtype Tree2 a = Tree2 (Tree a) -- deriving (Functor, F.Foldable) -- -- instance NFData a => NFData (Tree2 a) where -- rnf (Tree2 xs) = rnf xs -- -- instance Foldable1 Tree2 where -- toNonEmpty (Tree2 xs) = toNonEmpty xs -- Using to foldrMap1 newtype Tree3 a = Tree3 (Tree a) deriving (Functor, F.Foldable) instance NFData a => NFData (Tree3 a) where rnf (Tree3 xs) = rnf xs instance Foldable1 Tree3 where foldrMap1 f g (Tree3 xs) = foldrMap1 f g xs #endif foldable1-classes-compat-0.1/foldable1-classes-compat.cabal0000644000000000000000000000704207346545000022044 0ustar0000000000000000cabal-version: >=1.10 name: foldable1-classes-compat version: 0.1 synopsis: Compatibility package for the Foldable1 and Bifoldable1 type classes description: A compatibility package for the @Foldable1@ and @Bifoldable1@ type classes, which were introduced in @base-4.18.0.0@ (GHC 9.6.1). For more information, see . . @Foldable1@ and @Bifoldable1@ classify non-empty data structures that can be folded to a summary value. license: BSD3 maintainer: Ryan Scott author: Edward Kmett, Oleg Grenrus homepage: https://github.com/haskell-compat/foldable1-classes-compat bug-reports: https://github.com/haskell-compat/foldable1-classes-compat/issues category: Data, Compatibility license-file: LICENSE build-type: Simple extra-source-files: CHANGELOG.markdown README.markdown tested-with: GHC ==7.0.4 || ==7.2.2 || ==7.4.2 || ==7.6.3 || ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.5 || ==9.4.4 || ==9.6.1 -- , GHCJS ==8.4 source-repository head type: git location: https://github.com/haskell-compat/foldable1-classes-compat.git flag tagged description: You can disable the use of the `tagged` package using `-f-tagged`. . Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. default: True manual: True library default-language: Haskell2010 ghc-options: -Wall build-depends: base >=4.3 && <4.19 if !impl(ghc >= 9.6) hs-source-dirs: src build-depends: containers >=0.4 && <0.7 , transformers >=0.3 && <0.7 exposed-modules: Data.Foldable1 Data.Bifoldable1 if !impl(ghc >=8.6) build-depends: base-orphans >=0.8.1 && <0.9 if !impl(ghc >=8.2) build-depends: bifunctor-classes-compat >=0.1 && <0.2 if !impl(ghc >=8.0) build-depends: semigroups >=0.18.5 && <0.20 , transformers-compat >=0.6 && <0.8 if !impl(ghc >= 7.2) build-depends: generic-deriving >=1.14 && <1.15 if flag(tagged) build-depends: tagged >=0.4.4 && <1 if impl(ghc >= 9.0) build-depends: ghc-prim >= 0.7 && <0.11 else if !impl(ghc >=7.6) build-depends: ghc-prim test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -Wall hs-source-dirs: test main-is: Tests.hs -- because of quickcheck-instances if !impl(ghc >=7.4) buildable: False build-depends: base , containers , foldable1-classes-compat , transformers if !impl(ghc >=8.0) build-depends: semigroups , transformers-compat build-depends: QuickCheck >=2.13.2 && <2.15 , quickcheck-instances >=0.3.27 && <0.4 , test-framework >=0.8.2.0 && <0.9 , test-framework-quickcheck2 >=0.3.0.5 && <0.4 benchmark bench default-language: Haskell2010 type: exitcode-stdio-1.0 ghc-options: -Wall hs-source-dirs: bench main-is: Bench.hs if !impl(ghc >=7.6) buildable: False build-depends: base , containers , foldable1-classes-compat , transformers if !impl(ghc >=8.0) build-depends: semigroups , transformers-compat build-depends: criterion >=1.5.6.1 && <1.7 , deepseq >=1.3 && <1.5 foldable1-classes-compat-0.1/src/Data/0000755000000000000000000000000007346545000015750 5ustar0000000000000000foldable1-classes-compat-0.1/src/Data/Bifoldable1.hs0000644000000000000000000000322307346545000020410 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Data.Bifoldable1 where import Control.Applicative (Const (..)) import Data.Bifoldable (Bifoldable (..)) import Data.Semigroup (Arg (..), Semigroup (..)) import Prelude (Either (..), id) #ifdef MIN_VERSION_tagged import Data.Tagged (Tagged (..)) #endif #if !MIN_VERSION_base(4,12,0) import Data.Orphans () #endif 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 #-} #ifdef MIN_VERSION_tagged instance Bifoldable1 Tagged where bifoldMap1 _ g (Tagged b) = g b {-# INLINE bifoldMap1 #-} #endif foldable1-classes-compat-0.1/src/Data/Foldable1.hs0000644000000000000000000004670307346545000020107 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >=706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >=702 {-# LANGUAGE Trustworthy #-} #endif -- | 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 #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex (..)) import GHC.Generics (M1 (..), Par1 (..), Rec1 (..), V1, (:*:) (..), (:+:) (..), (:.:) (..)) #else import Generics.Deriving (M1 (..), Par1 (..), Rec1 (..), V1, (:*:) (..), (:+:) (..), (:.:) (..)) #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down (..)) #endif #if MIN_VERSION_base(4,8,0) import qualified Data.Monoid as Mon #endif #if !MIN_VERSION_base(4,12,0) import Data.Orphans () #endif #ifdef MIN_VERSION_tagged import Data.Tagged (Tagged (..)) #endif #ifdef MIN_VERSION_ghc_prim #if MIN_VERSION_ghc_prim(0,7,0) import GHC.Tuple (Solo (..)) #endif #endif -- Instances import Control.Applicative.Backwards (Backwards (..)) import Control.Applicative.Lift (Lift (..)) import Control.Monad.Trans.Identity (IdentityT (..)) import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity (..)) import Data.Functor.Reverse (Reverse (..)) import Data.Tree (Tree (..)) import qualified Data.Functor.Product as Functor import qualified Data.Functor.Sum as Functor -- coerce #if __GLASGOW_HASKELL__ <708 import Unsafe.Coerce (unsafeCoerce) #else import Data.Coerce (Coercible, coerce) #endif -- $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 #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL foldMap1 | foldrMap1 #-} #endif -- 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 alsays define instance using 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 #if MIN_VERSION_base(4,6,0) instance Foldable1 Down where foldMap1 = coerce #endif #if MIN_VERSION_base(4,4,0) instance Foldable1 Complex where foldMap1 f (x :+ y) = f x <> f y toNonEmpty (x :+ y) = x :| y : [] #endif ------------------------------------------------------------------------------- -- 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 #if MIN_VERSION_base(4,8,0) deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f) #endif #if MIN_VERSION_base(4,12,0) deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f) #endif ------------------------------------------------------------------------------- -- 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 ------------------------------------------------------------------------------- -- containers ------------------------------------------------------------------------------- instance Foldable1 Tree where foldMap1 f (Node x []) = f x foldMap1 f (Node x (y : ys)) = f x <> foldMap1 (foldMap1 f) (y :| ys) foldMap1' f = go where go (Node x ys) = foldl' (\m zs -> let gozs = go zs in gozs `seq` m <> gozs) (f x) ys foldlMap1 f g (Node x xs) = goForest (f x) xs where goForest = foldl' go go y (Node z zs) = goForest (g y z) zs foldlMap1' f g (Node x xs) = goForest (f x) xs where goForest !y = foldl' go y go !y (Node z zs) = goForest (g y z) zs head (Node x _) = x ------------------------------------------------------------------------------- -- transformers ------------------------------------------------------------------------------- instance Foldable1 f => Foldable1 (Reverse f) where foldMap1 f = getDual . foldMap1 (Dual . f) . getReverse foldrMap1 f g (Reverse xs) = foldlMap1 f (flip g) xs foldlMap1 f g (Reverse xs) = foldrMap1 f (flip g) xs foldrMap1' f g (Reverse xs) = foldlMap1' f (flip g) xs foldlMap1' f g (Reverse xs) = foldrMap1' f (flip g) xs head = last . getReverse last = head . getReverse deriving instance Foldable1 f => Foldable1 (IdentityT f) instance Foldable1 f => Foldable1 (Backwards f) where foldMap1 f = foldMap1 f . forwards instance Foldable1 f => Foldable1 (Lift f) where foldMap1 f (Pure x) = f x foldMap1 f (Other y) = foldMap1 f y ------------------------------------------------------------------------------- -- tagged ------------------------------------------------------------------------------- #ifdef MIN_VERSION_tagged instance Foldable1 (Tagged b) where foldMap1 = coerce foldrMap1 g _ = coerce g foldrMap1' g _ = coerce g foldlMap1 g _ = coerce g foldlMap1' g _ = coerce g toNonEmpty x = coerce x :| [] last = coerce head = coerce minimum = coerce maximum = coerce #endif ------------------------------------------------------------------------------- -- ghc-prim ------------------------------------------------------------------------------- #ifdef MIN_VERSION_ghc_prim #if MIN_VERSION_ghc_prim(0,7,0) instance Foldable1 Solo where foldMap1 f (Solo y) = f y toNonEmpty (Solo x) = x :| [] minimum (Solo x) = x maximum (Solo x) = x head (Solo x) = x last (Solo x) = x #endif #endif ------------------------------------------------------------------------------- -- coerce shim ------------------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <708 coerce :: a -> b coerce = unsafeCoerce (#.) :: (b -> c) -> (a -> b) -> a -> c (#.) _f = coerce #else (#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c (#.) _f = coerce #endif foldable1-classes-compat-0.1/test/0000755000000000000000000000000007346545000015267 5ustar0000000000000000foldable1-classes-compat-0.1/test/Tests.hs0000644000000000000000000002056607346545000016736 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} #if MIN_VERSION_base(4,18,0) # define HAS_FOLDABLE1_CONTAINERS MIN_VERSION_containers(0,6,7) # define HAS_FOLDABLE1_TRANSFORMERS MIN_VERSION_transformers(0,6,1) #else # define HAS_FOLDABLE1_CONTAINERS 1 # define HAS_FOLDABLE1_TRANSFORMERS 1 #endif module Main (main) where import Prelude hiding (foldl1, foldr1, head, last, maximum, minimum) import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity (..)) import Data.Functor.Product (Product (..)) import Data.Functor.Sum (Sum (..)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup (First (..), Last (..), Max (..), Min (..), Semigroup (..)) import Test.Framework.Providers.API (Test, TestName, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Runners.Console (defaultMain) import Test.QuickCheck (Arbitrary, Fun, Property, Testable, applyFun, applyFun2, counterexample, mapSize, (===)) import Test.QuickCheck.Poly (A, B, OrdA) import Test.QuickCheck.Instances () import qualified Data.Foldable as F (Foldable (foldMap)) import Data.Foldable (toList) import Data.Foldable1 #if HAS_FOLDABLE1_CONTAINERS import Data.Tree (Tree (..)) #endif #if HASH_FOLDABLE1_TRANSFORMERS import Data.Functor.Reverse (Reverse (..)) #endif main :: IO () main = defaultMain [ foldable1tests "NonEmpty" (P1 :: P1 NonEmpty) , foldable1tests "foldMap1" (P1 :: P1 NE1) , foldable1tests "foldrMap1" (P1 :: P1 NE3) #if HAS_FOLDABLE1_CONTAINERS , foldable1tests "Tree" (P1 :: P1 Tree) #endif , foldable1tests "Identity" (P1 :: P1 Identity) , foldable1tests "Compose" (P1 :: P1 (Compose NonEmpty NonEmpty)) , foldable1tests "Product" (P1 :: P1 (Product NonEmpty NonEmpty)) #if HASH_FOLDABLE1_TRANSFORMERS , foldable1tests "Reverse" (P1 :: P1 (Reverse NonEmpty)) #endif , foldable1tests "Sum" (P1 :: P1 (Sum NonEmpty NonEmpty)) ] ------------------------------------------------------------------------------- -- tests ------------------------------------------------------------------------------- foldable1tests :: forall f. ( Foldable1 f , Arbitrary (f A), Show (f A) , Arbitrary (f OrdA), Show (f OrdA) , Arbitrary (f B), Show (f B) , Arbitrary (f [B]), Show (f [B]) ) => TestName -> P1 f -> Test foldable1tests name _p = testGroup name [ testProperty "foldMap1 ~= foldMap" coherentFoldMap , testProperty "toList . toNonEmpty ~= toList" coherentToNonEmpty , testProperty "foldl1 non/strict" $ smaller strictFoldl1 , testProperty "foldr1 non/strict" $ smaller strictFoldr1 , testProperty "foldlMap1 non/strict" $ smaller strictFoldl1Map , testProperty "foldrMap1 non/strict" $ smaller strictFoldr1Map -- test against default implementations , testProperty "foldMap1 default" defaultFoldMap , testProperty "foldrMap1 default" $ smaller defaultFoldr1Map , testProperty "foldlMap1 default" $ smaller defaultFoldl1Map , testProperty "toNonEmpty default" defaultToNonEmpty , testProperty "head default" defaultHead , testProperty "last default" defaultLast , testProperty "minimum default" defaultMinimum , testProperty "maximum default" defaultMaximum -- if we first convert to nonEmpty it should be the same , testProperty "foldMap via toNonEmpty" viaFoldMap , testProperty "foldr1 via toNonEmpty" $ smaller viaFoldr1 , testProperty "foldl1 via toNonEmpty" $ smaller viaFoldl1 , testProperty "foldr1' via toNonEmpty" $ smaller viaFoldr1' , testProperty "foldl1' via toNonEmpty" $ smaller viaFoldl1' , testProperty "head via toNonEmpty" viaHead , testProperty "last via toNonEmpty" viaLast , testProperty "minimum via toNonEmpty" viaMinimum , testProperty "maximum via toNonEmpty" viaMaximum ] where -- Things like Compose NonEmpty NonEmpty are big smaller :: Testable prop => prop -> Property smaller = mapSize (`div` 3) coherentFoldMap :: f A -> Fun A [B] -> Property coherentFoldMap xs f' = F.foldMap f xs === foldMap1 f xs where f = applyFun f' coherentToNonEmpty :: f A -> Property coherentToNonEmpty xs = toList (toNonEmpty xs) === toList xs strictFoldr1 :: f [B] -> Fun ([B], [B]) [B] -> Property strictFoldr1 xs g' = foldr1 g xs === foldr1' g xs where g = applyFun2 g' strictFoldl1 :: f [B] -> Fun ([B], [B]) [B] -> Property strictFoldl1 xs g' = foldl1 g xs === foldl1' g xs where g = applyFun2 g' strictFoldr1Map :: f A -> Fun A B -> Fun (A, B) B -> Property strictFoldr1Map xs f' g' = foldrMap1 f g xs === foldrMap1' f g xs where f = applyFun f' g = applyFun2 g' strictFoldl1Map :: f A -> Fun A B -> Fun (B, A) B -> Property strictFoldl1Map xs f' g' = foldlMap1 f g xs === foldlMap1' f g xs where f = applyFun f' g = applyFun2 g' defaultFoldMap :: f A -> Fun A [B] -> Property defaultFoldMap xs f' = F.foldMap f xs === foldrMap1 f (\a m -> f a Data.Semigroup.<> m) xs where f = applyFun f' defaultFoldr1Map :: f A -> Fun A [B] -> Fun (A, [B]) [B] -> Property defaultFoldr1Map xs f' g' = counterexample ("NE: " ++ show ys) $ foldrMap1 f g xs === foldrMap1 f g ys where f = applyFun f' g = applyFun2 g' ys = toNonEmpty xs defaultFoldl1Map :: f A -> Fun A [B] -> Fun ([B], A) [B] -> Property defaultFoldl1Map xs f' g' = counterexample ("NE: " ++ show ys) $ foldlMap1 f g xs === foldlMap1 f g ys where f = applyFun f' g = applyFun2 g' ys = toNonEmpty xs defaultToNonEmpty :: f A -> Property defaultToNonEmpty xs = toNonEmpty xs === foldMap1 (:|[]) xs defaultHead :: f A -> Property defaultHead xs = head xs === getFirst (foldMap1 First xs) defaultLast :: f A -> Property defaultLast xs = last xs === getLast (foldMap1 Last xs) defaultMinimum :: f OrdA -> Property defaultMinimum xs = minimum xs === getMin (foldMap1 Min xs) defaultMaximum :: f OrdA -> Property defaultMaximum xs = maximum xs === getMax (foldMap1 Max xs) viaFoldMap :: f A -> Fun A [B] -> Property viaFoldMap xs f' = F.foldMap f xs === F.foldMap f (toNonEmpty xs) where f = applyFun f' viaFoldr1 :: f [B] -> Fun ([B],[B]) [B] -> Property viaFoldr1 xs g' = foldr1 g xs === foldr1 g (toNonEmpty xs) where g = applyFun2 g' viaFoldr1' :: f [B] -> Fun ([B],[B]) [B] -> Property viaFoldr1' xs g' = foldr1' g xs === foldr1' g (toNonEmpty xs) where g = applyFun2 g' viaFoldl1 :: f [B] -> Fun ([B],[B]) [B] -> Property viaFoldl1 xs g' = foldl1 g xs === foldl1 g (toNonEmpty xs) where g = applyFun2 g' viaFoldl1' :: f [B] -> Fun ([B],[B]) [B] -> Property viaFoldl1' xs g' = foldl1' g xs === foldl1' g (toNonEmpty xs) where g = applyFun2 g' viaHead :: f A -> Property viaHead xs = head xs === head (toNonEmpty xs) viaLast :: f A -> Property viaLast xs = last xs === last (toNonEmpty xs) viaMinimum :: f OrdA -> Property viaMinimum xs = minimum xs === minimum (toNonEmpty xs) viaMaximum :: f OrdA -> Property viaMaximum xs = maximum xs === maximum (toNonEmpty xs) ------------------------------------------------------------------------------- -- NonEmpty variants ------------------------------------------------------------------------------- -- Using foldMap1 to define Foldable1 newtype NE1 a = NE1 (NonEmpty a) deriving (Eq, Show, Functor, F.Foldable, Arbitrary) instance Foldable1 NE1 where foldMap1 f (NE1 xs) = foldMap1 f xs -- Using foldrMap1 to define Foldable1 newtype NE3 a = NE3 (NonEmpty a) deriving (Eq, Show, Functor, F.Foldable, Arbitrary) instance Foldable1 NE3 where foldrMap1 g f (NE3 xs) = foldrMap1 g f xs ------------------------------------------------------------------------------- -- utilities ------------------------------------------------------------------------------- -- Proxy of right kind data P1 f = P1 | Unused (f Int) _unused :: P1 [] _unused = Unused []