bifunctors 3.0.4 → 3.1

raw patch · 12 files changed

+398/−13 lines, 12 filesdep +taggeddep ~semigroupoidsPVP ok

version bump matches the API change (PVP)

Dependencies added: tagged

Dependency ranges changed: semigroupoids

API changes (from Hackage documentation)

Files

• bifunctors.cabal +6/−2
• src/Data/Biapplicative.hs +81/−0
• src/Data/Bifoldable.hs +21/−0
• src/Data/Bifunctor.hs +5/−0
• src/Data/Bifunctor/Apply.hs +16/−0
• src/Data/Bifunctor/Clown.hs +81/−0
• src/Data/Bifunctor/Flip.hs +8/−1
• src/Data/Bifunctor/Joker.hs +88/−0
• src/Data/Bifunctor/Wrapped.hs +8/−1
• src/Data/Bitraversable.hs +24/−4
• src/Data/Semigroup/Bifoldable.hs +32/−3
• src/Data/Semigroup/Bitraversable.hs +28/−2

@@ -1,6 +1,6 @@ name:          bifunctors category:      Data, Functors-version:       3.0.4+version:       3.1 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -24,12 +24,16 @@   build-depends:     base          == 4.*,     semigroups    >= 0.8.3.1,-    semigroupoids >= 3.0+    semigroupoids == 3.*,+    tagged        >= 0.4.4 && < 1    exposed-modules:+    Data.Biapplicative     Data.Bifunctor     Data.Bifunctor.Apply+    Data.Bifunctor.Clown     Data.Bifunctor.Flip+    Data.Bifunctor.Joker     Data.Bifunctor.Wrapped     Data.Bifoldable     Data.Bitraversable

@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bifunctor.Apply+-- Copyright   :  (C) 2011-2013 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+----------------------------------------------------------------------------+module Data.Biapplicative (+  -- * Biapplicative bifunctors+    Biapplicative(..)+  , (<<$>>)+  , (<<**>>)+  , biliftA2+  , biliftA3+  , module Data.Bifunctor+  ) where++import Control.Applicative+import Data.Bifunctor+import Data.Bifunctor.Apply ((<<$>>))+import Data.Tagged++infixl 4 <<*>>, <<*, *>>, <<**>>++class Bifunctor p => Biapplicative p where+  bipure :: a -> b -> p a b++  (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d++  -- |+  -- @+  -- a '*>' b ≡ 'const' 'id' '<$>' a '<*>' b+  -- @+  (*>>) :: p a b -> p c d -> p c d+  a *>> b = bimap (const id) (const id) <<$>> a <<*>> b+  {-# INLINE (*>>) #-}++  -- |+  -- @+  -- a '<*' b ≡ 'const' '<$>' a '<.>' b+  -- @+  (<<*) :: p a b -> p c d -> p a b+  a <<* b = bimap const const <<$>> a <<*>> b+  {-# INLINE (<<*) #-}++(<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d+(<<**>>) = biliftA2 (flip id) (flip id)+{-# INLINE (<<**>>) #-}++-- | Lift binary functions+biliftA2 :: Biapplicative w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f+biliftA2 f g a b = bimap f g <<$>> a <<*>> b+{-# INLINE biliftA2 #-}++-- | Lift ternary functions+biliftA3 :: Biapplicative w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h+biliftA3 f g a b c = bimap f g <<$>> a <<*>> b <<*>> c+{-# INLINE biliftA3 #-}++instance Biapplicative (,) where+  bipure = (,)+  {-# INLINE bipure #-}+  (f, g) <<*>> (a, b) = (f a, g b)+  {-# INLINE (<<*>>) #-}++instance Biapplicative Tagged where+  bipure _ b = Tagged b+  {-# INLINE bipure #-}++  Tagged f <<*>> Tagged x = Tagged (f x)+  {-# INLINE (<<*>>) #-}++instance Biapplicative Const where+  bipure a _ = Const a+  {-# INLINE bipure #-}+  Const f <<*>> Const x = Const (f x)+  {-# INLINE (<<*>>) #-}

@@ -30,6 +30,7 @@  import Control.Applicative import Data.Monoid+import Data.Tagged  class Bifoldable p where   bifold :: Monoid m => p m m -> m@@ -50,6 +51,26 @@  instance Bifoldable (,) where   bifoldMap f g ~(a, b) = f a `mappend` g b+  {-# INLINE bifoldMap #-}++instance Bifoldable Const where+  bifoldMap f _ (Const a) = f a+  {-# INLINE bifoldMap #-}++instance Bifoldable ((,,) x) where+  bifoldMap f g ~(_,a,b) = f a `mappend` g b+  {-# INLINE bifoldMap #-}++instance Bifoldable ((,,,) x y) where+  bifoldMap f g ~(_,_,a,b) = f a `mappend` g b+  {-# INLINE bifoldMap #-}++instance Bifoldable ((,,,,) x y z) where+  bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b+  {-# INLINE bifoldMap #-}++instance Bifoldable Tagged where+  bifoldMap _ g (Tagged b) = g b   {-# INLINE bifoldMap #-}  instance Bifoldable Either where

@@ -14,6 +14,7 @@   ) where  import Control.Applicative+import Data.Tagged  -- | Minimal definition either 'bimap' or 'first' and 'second' @@ -92,4 +93,8 @@  instance Bifunctor Const where   bimap f _ (Const a) = Const (f a)+  {-# INLINE bimap #-}++instance Bifunctor Tagged where+  bimap _ g (Tagged b) = Tagged (g b)   {-# INLINE bimap #-}

@@ -19,7 +19,10 @@   , module Data.Bifunctor   ) where +import Control.Applicative import Data.Bifunctor+import Data.Semigroup+import Data.Tagged  infixl 4 <<$>>, <<.>>, <<., .>>, <<..>> @@ -62,4 +65,17 @@  instance Biapply (,) where   (f, g) <<.>> (a, b) = (f a, g b)+  {-# INLINE (<<.>>) #-}++instance Semigroup s => Biapply ((,,) s) where+  (s,f,g) <<.>> (t,a,b) = (s <> t, f a, g b)+  {-# INLINE (<<.>>) #-}++instance Biapply Const where+  Const f <<.>> Const x = Const (f x)+  {-# INLINE (<<.>>) #-}+++instance Biapply Tagged where+  Tagged f <<.>> Tagged x = Tagged (f x)   {-# INLINE (<<.>>) #-}

@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bifunctor.Clown+-- Copyright   :  (C) 2008-2013 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\"+-- by Conor McBride.+----------------------------------------------------------------------------+module Data.Bifunctor.Clown+  ( Clown(..)+  ) where++import Control.Applicative+import Data.Biapplicative+import Data.Bifunctor.Apply+import Data.Bifoldable+import Data.Bitraversable+import Data.Foldable+import Data.Functor.Apply+import Data.Monoid+import Data.Semigroup.Bifoldable+import Data.Semigroup.Bitraversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Traversable++-- | Make a 'Functor' over the first argument of a 'Bifunctor'.+newtype Clown f a b = Clown { runClown :: f a }+  deriving (Eq,Ord,Show,Read)++instance Functor f => Bifunctor (Clown f) where+  first f = Clown . fmap f . runClown+  {-# INLINE first #-}+  second _ = Clown . runClown+  {-# INLINE second #-}+  bimap f _ = Clown . fmap f . runClown+  {-# INLINE bimap #-}++instance Functor (Clown f a) where+  fmap _ = Clown . runClown+  {-# INLINE fmap #-}++instance Applicative f => Biapplicative (Clown f) where+  bipure a _ = Clown (pure a)+  {-# INLINE bipure #-}++  Clown mf <<*>> Clown mx = Clown (mf <*> mx)+  {-# INLINE (<<*>>) #-}++instance Apply f => Biapply (Clown f) where+  Clown fg <<.>> Clown xy = Clown (fg <.> xy)+  {-# INLINE (<<.>>) #-}++instance Foldable f => Bifoldable (Clown f) where+  bifoldMap f _ = foldMap f . runClown+  {-# INLINE bifoldMap #-}++instance Foldable (Clown f a) where+  foldMap _ = mempty+  {-# INLINE foldMap #-}++instance Traversable f => Bitraversable (Clown f) where+  bitraverse f _ = fmap Clown . traverse f . runClown+  {-# INLINE bitraverse #-}++instance Traversable (Clown f a) where+  traverse _ = pure . Clown . runClown+  {-# INLINE traverse #-}++instance Foldable1 f => Bifoldable1 (Clown f) where+  bifoldMap1 f _ = foldMap1 f . runClown+  {-# INLINE bifoldMap1 #-}++instance Traversable1 f => Bitraversable1 (Clown f) where+  bitraverse1 f _ = fmap Clown . traverse1 f . runClown+  {-# INLINE bitraverse1 #-}

@@ -14,7 +14,7 @@   ) where  import Control.Applicative-import Data.Bifunctor+import Data.Biapplicative import Data.Bifunctor.Apply import Data.Bifoldable import Data.Bitraversable@@ -39,6 +39,13 @@ instance Bifunctor p => Functor (Flip p a) where   fmap f = Flip . first f . runFlip   {-# INLINE fmap #-}++instance Biapplicative p => Biapplicative (Flip p) where+  bipure a b = Flip (bipure b a)+  {-# INLINE bipure #-}++  Flip fg <<*>> Flip xy = Flip (fg <<*>> xy)+  {-# INLINE (<<*>>) #-}  instance Biapply p => Biapply (Flip p) where   Flip fg <<.>> Flip xy = Flip (fg <<.>> xy)

@@ -0,0 +1,88 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Bifunctor.Joker+-- Copyright   :  (C) 2008-2013 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\"+-- by Conor McBride.+----------------------------------------------------------------------------+module Data.Bifunctor.Joker+  ( Joker(..)+  ) where++import Control.Applicative+import Data.Biapplicative+import Data.Bifunctor.Apply+import Data.Bifoldable+import Data.Bitraversable+import Data.Foldable+import Data.Functor.Apply+import Data.Semigroup.Bifoldable+import Data.Semigroup.Bitraversable+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Traversable++-- | Make a 'Functor' over the first argument of a 'Bifunctor'.+newtype Joker g a b = Joker { runJoker :: g b }+  deriving (Eq,Ord,Show,Read)++instance Functor g => Bifunctor (Joker g) where+  first _ = Joker . runJoker+  {-# INLINE first #-}+  second g = Joker . fmap g . runJoker+  {-# INLINE second #-}+  bimap _ g = Joker . fmap g . runJoker+  {-# INLINE bimap #-}++instance Functor g => Functor (Joker g a) where+  fmap g = Joker . fmap g . runJoker+  {-# INLINE fmap #-}++instance Applicative g => Biapplicative (Joker g) where+  bipure _ b = Joker (pure b)+  {-# INLINE bipure #-}++  Joker mf <<*>> Joker mx = Joker (mf <*> mx)+  {-# INLINE (<<*>>) #-}++instance Apply g => Biapply (Joker g) where+  Joker fg <<.>> Joker xy = Joker (fg <.> xy)+  {-# INLINE (<<.>>) #-}++instance Foldable g => Bifoldable (Joker g) where+  bifoldMap _ g = foldMap g . runJoker+  {-# INLINE bifoldMap #-}++instance Foldable g => Foldable (Joker g a) where+  foldMap g = foldMap g . runJoker+  {-# INLINE foldMap #-}++instance Traversable g => Bitraversable (Joker g) where+  bitraverse _ g = fmap Joker . traverse g . runJoker+  {-# INLINE bitraverse #-}++instance Traversable g => Traversable (Joker g a) where+  traverse g = fmap Joker . traverse g . runJoker+  {-# INLINE traverse #-}++instance Foldable1 g => Bifoldable1 (Joker g) where+  bifoldMap1 _ g = foldMap1 g . runJoker+  {-# INLINE bifoldMap1 #-}++instance Foldable1 g => Foldable1 (Joker g a) where+  foldMap1 g = foldMap1 g . runJoker+  {-# INLINE foldMap1 #-}++instance Traversable1 g => Bitraversable1 (Joker g) where+  bitraverse1 _ g = fmap Joker . traverse1 g . runJoker+  {-# INLINE bitraverse1 #-}++instance Traversable1 g => Traversable1 (Joker g a) where+  traverse1 g = fmap Joker . traverse1 g . runJoker+  {-# INLINE traverse1 #-}

@@ -14,8 +14,8 @@   ) where  import Control.Applicative+import Data.Biapplicative import Data.Bifoldable-import Data.Bifunctor import Data.Bifunctor.Apply import Data.Bitraversable import Data.Foldable@@ -42,6 +42,13 @@  instance Biapply p => Biapply (WrappedBifunctor p) where   WrapBifunctor fg <<.>> WrapBifunctor xy = WrapBifunctor (fg <<.>> xy)+  {-# INLINE (<<.>>) #-}++instance Biapplicative p => Biapplicative (WrappedBifunctor p) where+  bipure a b = WrapBifunctor (bipure a b)+  {-# INLINE bipure #-}+  WrapBifunctor fg <<*>> WrapBifunctor xy = WrapBifunctor (fg <<*>> xy)+  {-# INLINE (<<*>>) #-}  instance Bifoldable p => Foldable (WrappedBifunctor p a) where   foldMap f = bifoldMap (const mempty) f . unwrapBifunctor

@@ -20,9 +20,10 @@   ) where  import Control.Applicative-import Data.Monoid import Data.Bifunctor import Data.Bifoldable+import Data.Monoid+import Data.Tagged  class (Bifunctor t, Bifoldable t) => Bitraversable t where   bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)@@ -45,11 +46,31 @@   bitraverse f g ~(a, b) = (,) <$> f a <*> g b   {-# INLINE bitraverse #-} +instance Bitraversable ((,,) x) where+  bitraverse f g ~(x, a, b) = (,,) x <$> f a <*> g b+  {-# INLINE bitraverse #-}++instance Bitraversable ((,,,) x y) where+  bitraverse f g ~(x, y, a, b) = (,,,) x y <$> f a <*> g b+  {-# INLINE bitraverse #-}++instance Bitraversable ((,,,,) x y z) where+  bitraverse f g ~(x, y, z, a, b) = (,,,,) x y z <$> f a <*> g b+  {-# INLINE bitraverse #-}+ instance Bitraversable Either where   bitraverse f _ (Left a) = Left <$> f a   bitraverse _ g (Right b) = Right <$> g b   {-# INLINE bitraverse #-} +instance Bitraversable Const where+  bitraverse f _ (Const a) = Const <$> f a+  {-# INLINE bitraverse #-}++instance Bitraversable Tagged where+  bitraverse _ g (Tagged b) = Tagged <$> g b+  {-# INLINE bitraverse #-}+ bifor :: (Bitraversable t, Applicative f) => t a b -> (a -> f c) -> (b -> f d) -> f (t c d) bifor t f g = bitraverse f g t {-# INLINE bifor #-}@@ -58,8 +79,7 @@ biforM t f g = bimapM f g t {-# INLINE biforM #-} ---- left-to-right state transformer+-- | left-to-right state transformer newtype StateL s a = StateL { runStateL :: s -> (s, a) }  instance Functor (StateL s) where@@ -80,7 +100,7 @@ bimapAccumL f g s t = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s {-# INLINE bimapAccumL #-} --- right-to-left state transformer+-- | right-to-left state transformer newtype StateR s a = StateR { runStateR :: s -> (s, a) }  instance Functor (StateR s) where

@@ -17,44 +17,74 @@   , bifoldMapDefault1   ) where -import Prelude hiding (foldr)+import Control.Applicative import Data.Bifoldable import Data.Functor.Apply import Data.Semigroup+import Data.Tagged+import Prelude hiding (foldr)  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   bifoldMap1 f g = maybe (error "bifoldMap1") id . getOption . bifoldMap (Option . Just . f) (Option . Just . g)+  {-# INLINE bifoldMap1 #-}  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 #-}++instance Bifoldable1 Tagged where+  bifoldMap1 _ g (Tagged b) = g b+  {-# INLINE bifoldMap1 #-}+ newtype Act f a = Act { getAct :: f a }  instance Apply f => Semigroup (Act f a) where   Act a <> Act b = Act (a .> b)+  {-# INLINE (<>) #-}  instance Functor f => Functor (Act f) where   fmap f (Act a) = Act (f <$> a)+  {-# INLINE fmap #-}   b <$ Act a = Act (b <$ a)+  {-# INLINE (<$) #-}  bitraverse1_ :: (Bifoldable1 t, Apply f) => (a -> f b) -> (c -> f d) -> t a c -> f () bitraverse1_ f g t = getAct (bifoldMap1 (Act . ignore . f) (Act . ignore . g) t) {-# INLINE bitraverse1_ #-}  bifor1_ :: (Bifoldable1 t, Apply f) => t a c -> (a -> f b) -> (c -> f d) -> f ()-bifor1_ t f g = bitraverse1_ f g t +bifor1_ t f g = bitraverse1_ f g t {-# INLINE bifor1_ #-}  ignore :: Functor f => f a -> f () ignore = (() <$)+{-# INLINE ignore #-}  bisequenceA1_ :: (Bifoldable1 t, Apply f) => t (f a) (f b) -> f () bisequenceA1_ t = getAct (bifoldMap1 (Act . ignore) (Act . ignore) t)@@ -64,4 +94,3 @@ bifoldMapDefault1 :: (Bifoldable1 t, Monoid m) => (a -> m) -> (b -> m) -> t a b -> m bifoldMapDefault1 f g = unwrapMonoid . bifoldMap (WrapMonoid . f) (WrapMonoid . g) {-# INLINE bifoldMapDefault1 #-}-

@@ -15,25 +15,51 @@   ) where  import Control.Applicative-import Data.Functor.Apply-import Data.Semigroup.Bifoldable import Data.Bitraversable import Data.Bifunctor+import Data.Functor.Apply import Data.Semigroup+import Data.Semigroup.Bifoldable+import Data.Tagged  class (Bifoldable1 t, Bitraversable t) => Bitraversable1 t where   bitraverse1 :: Apply f => (a -> f b) -> (c -> f d) -> t a c -> f (t b d)   bitraverse1 f g  = bisequence1 . bimap f g+  {-# INLINE bitraverse1 #-}    bisequence1 :: Apply f => t (f a) (f b) -> f (t a b)   bisequence1 = bitraverse1 id id+  {-# INLINE bisequence1 #-}  bifoldMap1Default :: (Bitraversable1 t, Semigroup m) => (a -> m) -> (b -> m) -> t a b -> m bifoldMap1Default f g = getConst . bitraverse1 (Const . f) (Const . g)+{-# INLINE bifoldMap1Default #-}  instance Bitraversable1 Either where   bitraverse1 f _ (Left a) = Left <$> f a   bitraverse1 _ g (Right b) = Right <$> g b+  {-# INLINE bitraverse1 #-}  instance Bitraversable1 (,) where   bitraverse1 f g (a, b) = (,) <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,) x) where+  bitraverse1 f g (x, a, b) = (,,) x <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,,) x y) where+  bitraverse1 f g (x, y, a, b) = (,,,) x y <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 ((,,,,) x y z) where+  bitraverse1 f g (x, y, z, a, b) = (,,,,) x y z <$> f a <.> g b+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 Const where+  bitraverse1 f _ (Const a) = Const <$> f a+  {-# INLINE bitraverse1 #-}++instance Bitraversable1 Tagged where+  bitraverse1 _ g (Tagged b) = Tagged <$> g b+  {-# INLINE bitraverse1 #-}