    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Data.Bifunctor.Apply
    -- Copyright   :  (C) 2011 Edward Kmett,
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  provisional
    -- Portability :  portable
    --
    ----------------------------------------------------------------------------
    module Data.Bifunctor.Apply (
      -- * Biappliable bifunctors
        Biapply(..)
      , (<<$>>)
      , (<<..>>)
      , bilift2
      , bilift3
      , module Data.Bifunctor
      ) where

    import Control.Applicative
    import Data.Bifunctor
    import Data.Semigroup
    import Data.Tagged

    infixl 4 <<$>>, <<.>>, <<., .>>, <<..>>

    (<<$>>) :: (a -> b) -> a -> b
    (<<$>>) = id
    {-# INLINE (<<$>>) #-}

    class Bifunctor p => Biapply p where
      (<<.>>) :: 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 (<<.) #-}

    (<<..>>) :: Biapply p => p a c -> p (a -> b) (c -> d) -> p b d
    (<<..>>) = bilift2 (flip id) (flip id)
    {-# INLINE (<<..>>) #-}

    -- | Lift binary functions
    bilift2 :: Biapply w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f
    bilift2 f g a b = bimap f g <<$>> a <<.>> b
    {-# INLINE bilift2 #-}

    -- | Lift ternary functions
    bilift3 :: Biapply w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h
    bilift3 f g a b c = bimap f g <<$>> a <<.>> b <<.>> c
    {-# INLINE bilift3 #-}

    instance Biapply (,) where
      (f, g) <<.>> (a, b) = (f a, g b)
      {-# INLINE (<<.>>) #-}

    instance Semigroup x => Biapply ((,,) x) where
      (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b)
      {-# INLINE (<<.>>) #-}

    instance (Semigroup x, Semigroup y) => Biapply ((,,,) x y) where
      (x, y, f, g) <<.>> (x', y', a, b) = (x <> x', y <> y', f a, g b)
      {-# INLINE (<<.>>) #-}

    instance (Semigroup x, Semigroup y, Semigroup z) => Biapply ((,,,,) x y z) where
      (x, y, z, f, g) <<.>> (x', y', z', a, b) = (x <> x', y <> y', z <> z', 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 (<<.>>) #-}