1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4{-# LANGUAGE StandaloneDeriving #-} 5 6#if __GLASGOW_HASKELL__ >= 702 7{-# LANGUAGE Trustworthy #-} 8#endif 9 10----------------------------------------------------------------------------- 11-- | 12-- Copyright : (C) 2011-2015 Edward Kmett 13-- License : BSD-style (see the file LICENSE) 14-- 15-- Maintainer : Edward Kmett <ekmett@gmail.com> 16-- Stability : provisional 17-- Portability : portable 18-- 19---------------------------------------------------------------------------- 20module Data.Bifoldable 21 ( Bifoldable(..) 22 , bifoldr' 23 , bifoldr1 24 , bifoldrM 25 , bifoldl' 26 , bifoldl1 27 , bifoldlM 28 , bitraverse_ 29 , bifor_ 30 , bimapM_ 31 , biforM_ 32 , bimsum 33 , bisequenceA_ 34 , bisequence_ 35 , biasum 36 , biList 37 , binull 38 , bilength 39 , bielem 40 , bimaximum 41 , biminimum 42 , bisum 43 , biproduct 44 , biconcat 45 , biconcatMap 46 , biand 47 , bior 48 , biany 49 , biall 50 , bimaximumBy 51 , biminimumBy 52 , binotElem 53 , bifind 54 ) where 55 56import Control.Applicative 57import Control.Monad 58import Data.Functor.Constant 59import Data.Maybe (fromMaybe) 60import Data.Monoid 61 62#if MIN_VERSION_base(4,7,0) 63import Data.Coerce 64#else 65import Unsafe.Coerce 66#endif 67 68import Data.Semigroup (Arg(..)) 69 70#ifdef MIN_VERSION_tagged 71import Data.Tagged 72#endif 73 74#if __GLASGOW_HASKELL__ >= 702 75import GHC.Generics (K1(..)) 76#endif 77 78#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 79import Data.Typeable 80#endif 81 82-- | 'Bifoldable' identifies foldable structures with two different varieties 83-- of elements (as opposed to 'Foldable', which has one variety of element). 84-- Common examples are 'Either' and '(,)': 85-- 86-- > instance Bifoldable Either where 87-- > bifoldMap f _ (Left a) = f a 88-- > bifoldMap _ g (Right b) = g b 89-- > 90-- > instance Bifoldable (,) where 91-- > bifoldr f g z (a, b) = f a (g b z) 92-- 93-- A minimal 'Bifoldable' definition consists of either 'bifoldMap' or 94-- 'bifoldr'. When defining more than this minimal set, one should ensure 95-- that the following identities hold: 96-- 97-- @ 98-- 'bifold' ≡ 'bifoldMap' 'id' 'id' 99-- 'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty' 100-- 'bifoldr' f g z t ≡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z 101-- @ 102-- 103-- If the type is also a 'Bifunctor' instance, it should satisfy: 104-- 105-- > 'bifoldMap' f g ≡ 'bifold' . 'bimap' f g 106-- 107-- which implies that 108-- 109-- > 'bifoldMap' f g . 'bimap' h i ≡ 'bifoldMap' (f . h) (g . i) 110class Bifoldable p where 111 -- | Combines the elements of a structure using a monoid. 112 -- 113 -- @'bifold' ≡ 'bifoldMap' 'id' 'id'@ 114 bifold :: Monoid m => p m m -> m 115 bifold = bifoldMap id id 116 {-# INLINE bifold #-} 117 118 -- | Combines the elements of a structure, given ways of mapping them to a 119 -- common monoid. 120 -- 121 -- @'bifoldMap' f g ≡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@ 122 bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m 123 bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty 124 {-# INLINE bifoldMap #-} 125 126 -- | Combines the elements of a structure in a right associative manner. Given 127 -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a 128 -- list of all elements of a structure in order, the following would hold: 129 -- 130 -- @'bifoldr' f g z ≡ 'foldr' ('either' f g) z . toEitherList@ 131 bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c 132 bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z 133 {-# INLINE bifoldr #-} 134 135 -- | Combines the elments of a structure in a left associative manner. Given a 136 -- hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a 137 -- list of all elements of a structure in order, the following would hold: 138 -- 139 -- @'bifoldl' f g z ≡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@ 140 -- 141 -- Note that if you want an efficient left-fold, you probably want to use 142 -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not 143 -- force the "inner" results, resulting in a thunk chain which then must be 144 -- evaluated from the outside-in. 145 bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c 146 bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f) (Dual . Endo . flip g) t)) z 147 {-# INLINE bifoldl #-} 148 149#if __GLASGOW_HASKELL__ >= 708 150 {-# MINIMAL bifoldr | bifoldMap #-} 151#endif 152 153#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 154deriving instance Typeable Bifoldable 155#endif 156 157instance Bifoldable Arg where 158 bifoldMap f g (Arg a b) = f a `mappend` g b 159 160instance Bifoldable (,) where 161 bifoldMap f g ~(a, b) = f a `mappend` g b 162 {-# INLINE bifoldMap #-} 163 164instance Bifoldable Const where 165 bifoldMap f _ (Const a) = f a 166 {-# INLINE bifoldMap #-} 167 168instance Bifoldable Constant where 169 bifoldMap f _ (Constant a) = f a 170 {-# INLINE bifoldMap #-} 171 172#if __GLASGOW_HASKELL__ >= 702 173instance Bifoldable (K1 i) where 174 bifoldMap f _ (K1 c) = f c 175 {-# INLINE bifoldMap #-} 176#endif 177 178instance Bifoldable ((,,) x) where 179 bifoldMap f g ~(_,a,b) = f a `mappend` g b 180 {-# INLINE bifoldMap #-} 181 182instance Bifoldable ((,,,) x y) where 183 bifoldMap f g ~(_,_,a,b) = f a `mappend` g b 184 {-# INLINE bifoldMap #-} 185 186instance Bifoldable ((,,,,) x y z) where 187 bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b 188 {-# INLINE bifoldMap #-} 189 190instance Bifoldable ((,,,,,) x y z w) where 191 bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b 192 {-# INLINE bifoldMap #-} 193 194instance Bifoldable ((,,,,,,) x y z w v) where 195 bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b 196 {-# INLINE bifoldMap #-} 197 198#ifdef MIN_VERSION_tagged 199instance Bifoldable Tagged where 200 bifoldMap _ g (Tagged b) = g b 201 {-# INLINE bifoldMap #-} 202#endif 203 204instance Bifoldable Either where 205 bifoldMap f _ (Left a) = f a 206 bifoldMap _ g (Right b) = g b 207 {-# INLINE bifoldMap #-} 208 209-- | As 'bifoldr', but strict in the result of the reduction functions at each 210-- step. 211bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c 212bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where 213 f' k x z = k $! f x z 214 g' k x z = k $! g x z 215{-# INLINE bifoldr' #-} 216 217-- | A variant of 'bifoldr' that has no base case, 218-- and thus may only be applied to non-empty structures. 219bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a 220bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure") 221 (bifoldr mbf mbf Nothing xs) 222 where 223 mbf x m = Just (case m of 224 Nothing -> x 225 Just y -> f x y) 226{-# INLINE bifoldr1 #-} 227 228-- | Right associative monadic bifold over a structure. 229bifoldrM :: (Bifoldable t, Monad m) => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c 230bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where 231 f' k x z = f x z >>= k 232 g' k x z = g x z >>= k 233{-# INLINE bifoldrM #-} 234 235-- | As 'bifoldl', but strict in the result of the reduction functions at each 236-- step. 237-- 238-- This ensures that each step of the bifold is forced to weak head normal form 239-- before being applied, avoiding the collection of thunks that would otherwise 240-- occur. This is often what you want to strictly reduce a finite structure to 241-- a single, monolithic result (e.g., 'bilength'). 242bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a 243bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where 244 f' x k z = k $! f z x 245 g' x k z = k $! g z x 246{-# INLINE bifoldl' #-} 247 248-- | A variant of 'bifoldl' that has no base case, 249-- and thus may only be applied to non-empty structures. 250bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a 251bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure") 252 (bifoldl mbf mbf Nothing xs) 253 where 254 mbf m y = Just (case m of 255 Nothing -> y 256 Just x -> f x y) 257{-# INLINe bifoldl1 #-} 258 259-- | Left associative monadic bifold over a structure. 260bifoldlM :: (Bifoldable t, Monad m) => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a 261bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where 262 f' x k z = f z x >>= k 263 g' x k z = g z x >>= k 264{-# INLINE bifoldlM #-} 265 266-- | Map each element of a structure using one of two actions, evaluate these 267-- actions from left to right, and ignore the results. For a version that 268-- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'. 269bitraverse_ :: (Bifoldable t, Applicative f) => (a -> f c) -> (b -> f d) -> t a b -> f () 270bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ()) 271{-# INLINE bitraverse_ #-} 272 273-- | As 'bitraverse_', but with the structure as the primary argument. For a 274-- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'. 275-- 276-- >>> > bifor_ ('a', "bc") print (print . reverse) 277-- 'a' 278-- "cb" 279bifor_ :: (Bifoldable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f () 280bifor_ t f g = bitraverse_ f g t 281{-# INLINE bifor_ #-} 282 283-- | As 'Data.Bitraversable.bimapM', but ignores the results of the functions, 284-- merely performing the "actions". 285bimapM_:: (Bifoldable t, Monad m) => (a -> m c) -> (b -> m d) -> t a b -> m () 286bimapM_ f g = bifoldr ((>>) . f) ((>>) . g) (return ()) 287{-# INLINE bimapM_ #-} 288 289-- | As 'bimapM_', but with the structure as the primary argument. 290biforM_ :: (Bifoldable t, Monad m) => t a b -> (a -> m c) -> (b -> m d) -> m () 291biforM_ t f g = bimapM_ f g t 292{-# INLINE biforM_ #-} 293 294-- | As 'Data.Bitraversable.bisequenceA', but ignores the results of the actions. 295bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f () 296bisequenceA_ = bifoldr (*>) (*>) (pure ()) 297{-# INLINE bisequenceA_ #-} 298 299-- | Evaluate each action in the structure from left to right, and ignore the 300-- results. For a version that doesn't ignore the results, see 301-- 'Data.Bitraversable.bisequence'. 302bisequence_ :: (Bifoldable t, Monad m) => t (m a) (m b) -> m () 303bisequence_ = bifoldr (>>) (>>) (return ()) 304{-# INLINE bisequence_ #-} 305 306-- | The sum of a collection of actions, generalizing 'biconcat'. 307biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a 308biasum = bifoldr (<|>) (<|>) empty 309{-# INLINE biasum #-} 310 311-- | The sum of a collection of actions, generalizing 'biconcat'. 312bimsum :: (Bifoldable t, MonadPlus m) => t (m a) (m a) -> m a 313bimsum = bifoldr mplus mplus mzero 314{-# INLINE bimsum #-} 315 316-- | Collects the list of elements of a structure, from left to right. 317biList :: Bifoldable t => t a a -> [a] 318biList = bifoldr (:) (:) [] 319{-# INLINE biList #-} 320 321-- | Test whether the structure is empty. 322binull :: Bifoldable t => t a b -> Bool 323binull = bifoldr (\_ _ -> False) (\_ _ -> False) True 324{-# INLINE binull #-} 325 326-- | Returns the size/length of a finite structure as an 'Int'. 327bilength :: Bifoldable t => t a b -> Int 328bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0 329{-# INLINE bilength #-} 330 331-- | Does the element occur in the structure? 332bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool 333bielem x = biany (== x) (== x) 334{-# INLINE bielem #-} 335 336-- | Reduces a structure of lists to the concatenation of those lists. 337biconcat :: Bifoldable t => t [a] [a] -> [a] 338biconcat = bifold 339{-# INLINE biconcat #-} 340 341newtype Max a = Max {getMax :: Maybe a} 342newtype Min a = Min {getMin :: Maybe a} 343 344instance Ord a => Monoid (Max a) where 345 mempty = Max Nothing 346 347 {-# INLINE mappend #-} 348 m `mappend` Max Nothing = m 349 Max Nothing `mappend` n = n 350 (Max m@(Just x)) `mappend` (Max n@(Just y)) 351 | x >= y = Max m 352 | otherwise = Max n 353 354instance Ord a => Monoid (Min a) where 355 mempty = Min Nothing 356 357 {-# INLINE mappend #-} 358 m `mappend` Min Nothing = m 359 Min Nothing `mappend` n = n 360 (Min m@(Just x)) `mappend` (Min n@(Just y)) 361 | x <= y = Min m 362 | otherwise = Min n 363 364-- | The largest element of a non-empty structure. 365bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a 366bimaximum = fromMaybe (error "bimaximum: empty structure") . 367 getMax . bifoldMap mj mj 368 where mj = Max #. (Just :: a -> Maybe a) 369{-# INLINE bimaximum #-} 370 371-- | The least element of a non-empty structure. 372biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a 373biminimum = fromMaybe (error "biminimum: empty structure") . 374 getMin . bifoldMap mj mj 375 where mj = Min #. (Just :: a -> Maybe a) 376{-# INLINE biminimum #-} 377 378-- | The 'bisum' function computes the sum of the numbers of a structure. 379bisum :: (Bifoldable t, Num a) => t a a -> a 380bisum = getSum #. bifoldMap Sum Sum 381{-# INLINE bisum #-} 382 383-- | The 'biproduct' function computes the product of the numbers of a 384-- structure. 385biproduct :: (Bifoldable t, Num a) => t a a -> a 386biproduct = getProduct #. bifoldMap Product Product 387{-# INLINE biproduct #-} 388 389-- | Given a means of mapping the elements of a structure to lists, computes the 390-- concatenation of all such lists in order. 391biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c] 392biconcatMap = bifoldMap 393{-# INLINE biconcatMap #-} 394 395-- | 'biand' returns the conjunction of a container of Bools. For the 396-- result to be 'True', the container must be finite; 'False', however, 397-- results from a 'False' value finitely far from the left end. 398biand :: Bifoldable t => t Bool Bool -> Bool 399biand = getAll #. bifoldMap All All 400{-# INLINE biand #-} 401 402-- | 'bior' returns the disjunction of a container of Bools. For the 403-- result to be 'False', the container must be finite; 'True', however, 404-- results from a 'True' value finitely far from the left end. 405bior :: Bifoldable t => t Bool Bool -> Bool 406bior = getAny #. bifoldMap Any Any 407{-# INLINE bior #-} 408 409-- | Determines whether any element of the structure satisfies the appropriate 410-- predicate. 411biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool 412biany p q = getAny #. bifoldMap (Any . p) (Any . q) 413{-# INLINE biany #-} 414 415-- | Determines whether all elements of the structure satisfy the appropriate 416-- predicate. 417biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool 418biall p q = getAll #. bifoldMap (All . p) (All . q) 419{-# INLINE biall #-} 420 421-- | The largest element of a non-empty structure with respect to the 422-- given comparison function. 423bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a 424bimaximumBy cmp = bifoldr1 max' 425 where max' x y = case cmp x y of 426 GT -> x 427 _ -> y 428{-# INLINE bimaximumBy #-} 429 430-- | The least element of a non-empty structure with respect to the 431-- given comparison function. 432biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a 433biminimumBy cmp = bifoldr1 min' 434 where min' x y = case cmp x y of 435 GT -> y 436 _ -> x 437{-# INLINE biminimumBy #-} 438 439-- | 'binotElem' is the negation of 'bielem'. 440binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool 441binotElem x = not . bielem x 442{-# INLINE binotElem #-} 443 444-- | The 'bifind' function takes a predicate and a structure and returns 445-- the leftmost element of the structure matching the predicate, or 446-- 'Nothing' if there is no such element. 447bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a 448bifind p = getFirst . bifoldMap finder finder 449 where finder x = First (if p x then Just x else Nothing) 450{-# INLINE bifind #-} 451 452-- See Note [Function coercion] 453#if MIN_VERSION_base(4,7,0) 454(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) 455(#.) _f = coerce 456#else 457(#.) :: (b -> c) -> (a -> b) -> (a -> c) 458(#.) _f = unsafeCoerce 459#endif 460{-# INLINE (#.) #-} 461 462{- 463Note [Function coercion] 464~~~~~~~~~~~~~~~~~~~~~~~~ 465 466Several functions here use (#.) instead of (.) to avoid potential efficiency 467problems relating to #7542. The problem, in a nutshell: 468 469If N is a newtype constructor, then N x will always have the same 470representation as x (something similar applies for a newtype deconstructor). 471However, if f is a function, 472 473N . f = \x -> N (f x) 474 475This looks almost the same as f, but the eta expansion lifts it--the lhs could 476be _|_, but the rhs never is. This can lead to very inefficient code. Thus we 477steal a technique from Shachaf and Edward Kmett and adapt it to the current 478(rather clean) setting. Instead of using N . f, we use N .## f, which is 479just 480 481coerce f `asTypeOf` (N . f) 482 483That is, we just *pretend* that f has the right type, and thanks to the safety 484of coerce, the type checker guarantees that nothing really goes wrong. We still 485have to be a bit careful, though: remember that #. completely ignores the 486*value* of its left operand. 487-} 488