Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

moved Biapply, Bifoldable1 and Bitraversable1 from semigroupoids

  • Loading branch information...
commit 17a876ec193c47445d028cdb38d507446556c6c4 1 parent 340d4ba
Edward Kmett authored
68  Data/Semigroup/Bifoldable.hs
... ...
@@ -0,0 +1,68 @@
  1
+-----------------------------------------------------------------------------
  2
+-- |
  3
+-- Module      :  Data.Semigroup.Foldable
  4
+-- Copyright   :  (C) 2011 Edward Kmett
  5
+-- License     :  BSD-style (see the file LICENSE)
  6
+--
  7
+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  8
+-- Stability   :  provisional
  9
+-- Portability :  portable
  10
+--
  11
+----------------------------------------------------------------------------
  12
+module Data.Semigroup.Bifoldable
  13
+  ( Bifoldable1(..)
  14
+  , bitraverse1_
  15
+  , bifor1_
  16
+  , bisequenceA1_
  17
+  , bifoldMapDefault1
  18
+  ) where
  19
+
  20
+import Prelude hiding (foldr)
  21
+import Data.Bifoldable
  22
+import Data.Functor.Apply
  23
+import Data.Semigroup
  24
+import Data.Monoid
  25
+
  26
+class Bifoldable t => Bifoldable1 t where
  27
+  bifold1 :: Semigroup m => t m m -> m
  28
+  bifold1 = bifoldMap1 id id
  29
+
  30
+  bifoldMap1 :: Semigroup m => (a -> m) -> (b -> m) -> t a b -> m
  31
+  bifoldMap1 f g = maybe (error "bifoldMap1") id . getOption . bifoldMap (Option . Just . f) (Option . Just . g)
  32
+
  33
+instance Bifoldable1 Either where
  34
+  bifoldMap1 f _ (Left a) = f a
  35
+  bifoldMap1 _ g (Right b) = g b
  36
+
  37
+instance Bifoldable1 (,) where
  38
+  bifoldMap1 f g (a, b) = f a <> g b
  39
+
  40
+newtype Act f a = Act { getAct :: f a }
  41
+
  42
+instance Apply f => Semigroup (Act f a) where
  43
+  Act a <> Act b = Act (a .> b)
  44
+
  45
+instance Functor f => Functor (Act f) where
  46
+  fmap f (Act a) = Act (f <$> a)
  47
+  b <$ Act a = Act (b <$ a)
  48
+
  49
+bitraverse1_ :: (Bifoldable1 t, Apply f) => (a -> f b) -> (c -> f d) -> t a c -> f ()
  50
+bitraverse1_ f g t = getAct (bifoldMap1 (Act . ignore . f) (Act . ignore . g) t)
  51
+{-# INLINE bitraverse1_ #-}
  52
+
  53
+bifor1_ :: (Bifoldable1 t, Apply f) => t a c -> (a -> f b) -> (c -> f d) -> f ()
  54
+bifor1_ t f g = bitraverse1_ f g t 
  55
+{-# INLINE bifor1_ #-}
  56
+
  57
+ignore :: Functor f => f a -> f ()
  58
+ignore = (() <$)
  59
+
  60
+bisequenceA1_ :: (Bifoldable1 t, Apply f) => t (f a) (f b) -> f ()
  61
+bisequenceA1_ t = getAct (bifoldMap1 (Act . ignore) (Act . ignore) t)
  62
+{-# INLINE bisequenceA1_ #-}
  63
+
  64
+-- | Usable default for foldMap, but only if you define bifoldMap1 yourself
  65
+bifoldMapDefault1 :: (Bifoldable1 t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m
  66
+bifoldMapDefault1 f g = unwrapMonoid . bifoldMap (WrapMonoid . f) (WrapMonoid . g)
  67
+{-# INLINE bifoldMapDefault1 #-}
  68
+
39  Data/Semigroup/Bitraversable.hs
... ...
@@ -0,0 +1,39 @@
  1
+-----------------------------------------------------------------------------
  2
+-- |
  3
+-- Module      :  Data.Semigroup.Bitraversable
  4
+-- Copyright   :  (C) 2011 Edward Kmett
  5
+-- License     :  BSD-style (see the file LICENSE)
  6
+--
  7
+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  8
+-- Stability   :  provisional
  9
+-- Portability :  portable
  10
+--
  11
+----------------------------------------------------------------------------
  12
+module Data.Semigroup.Bitraversable
  13
+  ( Bitraversable1(..)
  14
+  , bifoldMap1Default
  15
+  ) where
  16
+
  17
+import Control.Applicative
  18
+import Data.Functor.Apply
  19
+import Data.Semigroup.Bifoldable
  20
+import Data.Bitraversable
  21
+import Data.Bifunctor
  22
+import Data.Semigroup
  23
+
  24
+class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where
  25
+  bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d)
  26
+  bitraverse1 f g  = bisequence1 . bimap f g
  27
+
  28
+  bisequence1 :: Apply f => t (f a) (f b) -> f (t a b)
  29
+  bisequence1 = bitraverse1 id id
  30
+
  31
+bifoldMap1Default :: (Bitraversable1 t, Semigroup m) => (a -> m) -> (b -> m) -> t a b -> m
  32
+bifoldMap1Default f g = getConst . bitraverse1 (Const . f) (Const . g)
  33
+
  34
+instance Bitraversable1 Either where
  35
+  bitraverse1 f _ (Left a) = Left <$> f a
  36
+  bitraverse1 _ g (Right b) = Right <$> g b
  37
+
  38
+instance Bitraversable1 (,) where
  39
+  bitraverse1 f g (a, b) = (,) <$> f a <.> g b
6  bifunctors.cabal
@@ -19,12 +19,16 @@ source-repository head
19 19
 
20 20
 library
21 21
   build-depends: 
22  
-    base >= 4 && < 4.4
  22
+    base >= 4 && < 4.4,
  23
+    semigroups >= 0.5 && < 0.6,
  24
+    semigroupoids >= 1.2.2 && < 1.3
23 25
 
24 26
   exposed-modules:
25 27
     Data.Bifunctor
26 28
     Data.Bifunctor.Apply
27 29
     Data.Bifoldable
28 30
     Data.Bitraversable
  31
+    Data.Semigroup.Bifoldable
  32
+    Data.Semigroup.Bitraversable
29 33
 
30 34
   ghc-options: -Wall 

0 notes on commit 17a876e

Please sign in to comment.
Something went wrong with that request. Please try again.