Bifunctor.hs

module Foo.Bifunctor
  (
  -- * These
    These (..), these'fold, these'fst, these'snd

  -- * TupleF
  , TupleF (..), tupleF'fst, tupleF'snd

  -- * TupleFirstF
  , TupleFirstF (..), tupleFirstF'fst, tupleFirstF'snd

  -- * TupleSecondF
  , TupleSecondF (..), tupleSecondF'fst, tupleSecondF'snd

  -- * Re-exports
  , Bifunctor (..)

  ) where

import Data.Bifunctor

--------------------------------------------------------------------------------

data These a b = This a | That b | These a b
  deriving (Eq, Show)

instance Bifunctor These
  where
    bimap f _ (This  a  ) = This  (f a)
    bimap _ g (That    b) = That        (g b)
    bimap f g (These a b) = These (f a) (g b)

    first f   (This  a)   = This  (f a)
    first _   (That    b) = That        b
    first f   (These a b) = These (f a) b

    second  _ (This  a  ) = This  a
    second  g (That    b) = That    (g b)
    second  g (These a b) = These a (g b)

these'fold :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these'fold f _ _ (This a) = f a
these'fold _ g _ (That b) = g b
these'fold _ _ h (These a b) = h a b

these'fst :: These a b -> Maybe a
these'fst = these Just (const Nothing) (\a _b -> a)

these'snd :: These a b -> Maybe b
these'snd = these (const Nothing) Just (\_a b -> b)

--------------------------------------------------------------------------------

data TupleF s t a b = TupleF (s a) (t b)
  deriving (Eq, Show)

instance (Functor s, Functor t) => Bifunctor (TupleF s t)
  where
    bimap  f g (TupleF x y) = TupleF (fmap f x) (fmap g y)
    first  f   (TupleF x y) = TupleF (fmap f x) y
    second   g (TupleF x y) = TupleF x          (fmap g y)

tupleF'fst :: TupleF s t a b -> s a
tupleF'fst x _ = x

tupleF'snd :: TupleF s t a b -> t b
tupleF'snd _ y = y

--------------------------------------------------------------------------------

data TupleFirstF s a b = TupleFirstF (s a) b
  deriving (Eq, Show)

instance Functor s => Bifunctor (TupleFirstF s)
  where
    bimap  f g (TupleFirstF x b) = TupleFirstF (fmap f x) (g y)
    first  f   (TupleFirstF x b) = TupleFirstF (fmap f x) b
    second   g (TupleFirstF x b) = TupleFirstF x          (g y)

tupleFirstF'fst :: TupleF s a b -> s a
tupleFirstF'fst x _ = x

tupleFirstF'snd :: TupleF s a b -> b
tupleFirstF'snd _ y = y

--------------------------------------------------------------------------------

data TupleSecondF t a b = TupleSecondF a (t b)
  deriving (Eq, Show)

instance Functor s => Bifunctor (TupleSecondF s)
  where
    bimap  f g (TupleSecondF a y) = TupleSecondF (f a) (fmap g y)
    first  f   (TupleSecondF a y) = TupleSecondF (f x) b
    second   g (TupleSecondF a y) = TupleSecondF a     (fmap g y)

tupleSecondF'fst :: TupleSecondF t a b -> a
tupleSecondF'fst x _ = x

tupleSecondF'snd :: TupleSecondF t a b -> t b
tupleSecondF'snd _ y = y