{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2015 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(..)
  , (<<$>>)
  , (<<**>>)
  , biliftA3
  , traverseBia
  , sequenceBia
  , traverseBiaWith
  , module Data.Bifunctor
  ) where

import Control.Applicative
import Data.Bifunctor
import Data.Functor.Identity
import Data.Semigroup (Arg(..))
import GHC.Exts (inline)

#ifdef MIN_VERSION_tagged
import Data.Tagged
#endif

infixl 4 <<$>>, <<*>>, <<*, *>>, <<**>>
(<<$>>) :: (a -> b) -> a -> b
<<$>> :: forall a b. (a -> b) -> a -> b
(<<$>>) = forall a. a -> a
id
{-# INLINE (<<$>>) #-}

class Bifunctor p => Biapplicative p where
  {-# MINIMAL bipure, ((<<*>>) | biliftA2 ) #-}
  bipure :: a -> b -> p a b

  (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d
  (<<*>>) = forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 forall a. a -> a
id forall a. a -> a
id
  {-# INLINE (<<*>>) #-}

  -- | Lift binary functions
  biliftA2 :: (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
  biliftA2 a -> b -> c
f d -> e -> f
g p a d
a p b e
b = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b -> c
f d -> e -> f
g forall a b. (a -> b) -> a -> b
<<$>> p a d
a forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p (a -> b) (c -> d) -> p a c -> p b d
<<*>> p b e
b
  {-# INLINE biliftA2 #-}

  -- |
  -- @
  -- a '*>>' b ≡ 'bimap' ('const' 'id') ('const' 'id') '<<$>>' a '<<*>>' b
  -- @
  (*>>) :: p a b -> p c d -> p c d
  p a b
a *>> p c d
b = forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 (forall a b. a -> b -> a
const forall a. a -> a
id) (forall a b. a -> b -> a
const forall a. a -> a
id) p a b
a p c d
b
  {-# INLINE (*>>) #-}

  -- |
  -- @
  -- a '<<*' b ≡ 'bimap' 'const' 'const' '<<$>>' a '<<*>>' b
  -- @
  (<<*) :: p a b -> p c d -> p a b
  p a b
a <<* p c d
b = forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 forall a b. a -> b -> a
const forall a b. a -> b -> a
const p a b
a p c d
b
  {-# INLINE (<<*) #-}

(<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d
<<**>> :: forall (p :: * -> * -> *) a c b d.
Biapplicative p =>
p a c -> p (a -> b) (c -> d) -> p b d
(<<**>>) = forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> a
id) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> a
id)
{-# INLINE (<<**>>) #-}


-- | 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 :: forall (w :: * -> * -> *) a b c d e f g h.
Biapplicative w =>
(a -> b -> c -> d)
-> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h
biliftA3 a -> b -> c -> d
f e -> f -> g -> h
g w a e
a w b f
b w c g
c = forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 a -> b -> c -> d
f e -> f -> g -> h
g w a e
a w b f
b forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p (a -> b) (c -> d) -> p a c -> p b d
<<*>> w c g
c
{-# INLINE biliftA3 #-}

-- | Traverse a 'Traversable' container in a 'Biapplicative'.
--
-- 'traverseBia' satisfies the following properties:
--
-- [/Pairing/]
--
--     @'traverseBia' (,) t = (t, t)@
--
-- [/Composition/]
--
--     @'traverseBia' ('Data.Bifunctor.Biff.Biff' . 'bimap' g h . f) = 'Data.Bifunctor.Biff.Biff' . 'bimap' ('traverse' g) ('traverse' h) . 'traverseBia' f@
--
--     @'traverseBia' ('Data.Bifunctor.Tannen.Tannen' . 'fmap' f . g) = 'Data.Bifunctor.Tannen.Tannen' . 'fmap' ('traverseBia' f) . 'traverse' g@
--
-- [/Naturality/]
--
--     @ t . 'traverseBia' f = 'traverseBia' (t . f) @
--
--     for every biapplicative transformation @t@.
--
--     A /biapplicative transformation/ from a 'Biapplicative' @P@ to a 'Biapplicative' @Q@
--     is a function
--
--     @t :: P a b -> Q a b@
--
--     preserving the 'Biapplicative' operations. That is,
--
--     * @t ('bipure' x y) = 'bipure' x y@
--
--     * @t (x '<<*>>' y) = t x '<<*>>' t y@
--
-- === Performance note
--
-- 'traverseBia' is fairly efficient, and uses compiler rewrite rules
-- to be even more efficient for a few important types like @[]@. However,
-- if performance is critical, you might consider writing a container-specific
-- implementation.
traverseBia :: (Traversable t, Biapplicative p)
            => (a -> p b c) -> t a -> p (t b) (t c)
traverseBia :: forall (t :: * -> *) (p :: * -> * -> *) a b c.
(Traversable t, Biapplicative p) =>
(a -> p b c) -> t a -> p (t b) (t c)
traverseBia = forall a. a -> a
inline (forall (p :: * -> * -> *) a b c s (t :: * -> *).
Biapplicative p =>
(forall (f :: * -> *) x.
 Applicative f =>
 (a -> f x) -> s -> f (t x))
-> (a -> p b c) -> s -> p (t b) (t c)
traverseBiaWith forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
-- We explicitly inline traverseBiaWith because it seems likely to help
-- specialization. I'm not much of an expert at the inlining business,
-- so I won't mind if someone else decides to do this differently.

-- We use a staged INLINABLE so we can rewrite traverseBia to specialized
-- versions for a few important types.
{-# INLINABLE [1] traverseBia #-}

-- | Perform all the 'Biappicative' actions in a 'Traversable' container
-- and produce a container with all the results.
--
-- @
-- sequenceBia = 'traverseBia' id
-- @
sequenceBia :: (Traversable t, Biapplicative p)
            => t (p b c) -> p (t b) (t c)
sequenceBia :: forall (t :: * -> *) (p :: * -> * -> *) b c.
(Traversable t, Biapplicative p) =>
t (p b c) -> p (t b) (t c)
sequenceBia = forall a. a -> a
inline (forall (t :: * -> *) (p :: * -> * -> *) a b c.
(Traversable t, Biapplicative p) =>
(a -> p b c) -> t a -> p (t b) (t c)
traverseBia forall a. a -> a
id)
{-# INLINABLE sequenceBia #-}

-- | A version of 'traverseBia' that doesn't care how the traversal is
-- done.
--
-- @
-- 'traverseBia' = traverseBiaWith traverse
-- @
traverseBiaWith :: forall p a b c s t. Biapplicative p
  => (forall f x. Applicative f => (a -> f x) -> s -> f (t x))
  -> (a -> p b c) -> s -> p (t b) (t c)
traverseBiaWith :: forall (p :: * -> * -> *) a b c s (t :: * -> *).
Biapplicative p =>
(forall (f :: * -> *) x.
 Applicative f =>
 (a -> f x) -> s -> f (t x))
-> (a -> p b c) -> s -> p (t b) (t c)
traverseBiaWith forall (f :: * -> *) x. Applicative f => (a -> f x) -> s -> f (t x)
trav a -> p b c
p s
s = forall (p :: * -> * -> *) (t :: * -> *) a b c.
Biapplicative p =>
(a -> p b c) -> (forall x. Mag a x (t x)) -> p (t b) (t c)
smash a -> p b c
p (forall (f :: * -> *) x. Applicative f => (a -> f x) -> s -> f (t x)
trav forall a b. a -> Mag a b b
One s
s)
{-# INLINABLE traverseBiaWith #-}

smash :: forall p t a b c. Biapplicative p
      => (a -> p b c)
      -> (forall x. Mag a x (t x))
      -> p (t b) (t c)
smash :: forall (p :: * -> * -> *) (t :: * -> *) a b c.
Biapplicative p =>
(a -> p b c) -> (forall x. Mag a x (t x)) -> p (t b) (t c)
smash a -> p b c
p forall x. Mag a x (t x)
m = forall x y. Mag a b x -> Mag a c y -> p x y
go forall x. Mag a x (t x)
m forall x. Mag a x (t x)
m
  where
    go :: forall x y. Mag a b x -> Mag a c y -> p x y
    go :: forall x y. Mag a b x -> Mag a c y -> p x y
go (Pure x
t) (Pure y
u) = forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure x
t y
u
    go (Map x -> x
f Mag a b x
x) (Map x -> y
g Mag a c x
y) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap x -> x
f x -> y
g (forall x y. Mag a b x -> Mag a c y -> p x y
go Mag a b x
x Mag a c x
y)
    go (Ap Mag a b (t -> x)
fs Mag a b t
xs) (Ap Mag a c (t -> y)
gs Mag a c t
ys) = forall x y. Mag a b x -> Mag a c y -> p x y
go Mag a b (t -> x)
fs Mag a c (t -> y)
gs forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p (a -> b) (c -> d) -> p a c -> p b d
<<*>> forall x y. Mag a b x -> Mag a c y -> p x y
go Mag a b t
xs Mag a c t
ys
#if MIN_VERSION_base(4,10,0)
    go (LiftA2 t -> u -> x
f Mag a b t
xs Mag a b u
ys) (LiftA2 t -> u -> y
g Mag a c t
zs Mag a c u
ws) = forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 t -> u -> x
f t -> u -> y
g (forall x y. Mag a b x -> Mag a c y -> p x y
go Mag a b t
xs Mag a c t
zs) (forall x y. Mag a b x -> Mag a c y -> p x y
go Mag a b u
ys Mag a c u
ws)
#endif
    go (One a
x) (One a
_) = a -> p b c
p a
x
    go Mag a b x
_ Mag a c y
_ = forall a. a
impossibleError
{-# INLINABLE smash #-}

-- Let's not end up with a bunch of CallStack junk in the smash
-- unfolding.
impossibleError :: a
impossibleError :: forall a. a
impossibleError = forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: the arguments are always the same."

-- This is used to reify a traversal for 'traverseBia'. It's a somewhat
-- bogus 'Functor' and 'Applicative' closely related to 'Magma' from the
-- @lens@ package. Valid traversals don't use (<$), (<*), or (*>), so
-- we leave them out. We offer all the rest of the Functor and Applicative
-- operations to improve performance: we generally want to keep the structure
-- as small as possible. We might even consider using RULES to widen lifts
-- when we can:
--
--   liftA2 f x y <*> z ==> liftA3 f x y z,
--
-- etc., up to the pointer tagging limit. But we do need to be careful. I don't
-- *think* GHC will ever inline the traversal into the go function (because that
-- would duplicate work), but if it did, and if different RULES fired for the
-- two copies, everything would break horribly.
--
-- Note: if it's necessary for some reason, we *could* relax GADTs to
-- ExistentialQuantification by changing the type of One to
--
--   One :: (b -> c) -> a -> Mag a b c
--
-- where the function will always end up being id. But we allocate a *lot*
-- of One constructors, so this would definitely be bad for performance.
data Mag a b t where
  Pure :: t -> Mag a b t
  Map :: (x -> t) -> Mag a b x -> Mag a b t
  Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u
#if MIN_VERSION_base(4,10,0)
  LiftA2 :: (t -> u -> v) -> Mag a b t -> Mag a b u -> Mag a b v
#endif
  One :: a -> Mag a b b

instance Functor (Mag a b) where
  fmap :: forall a b. (a -> b) -> Mag a b a -> Mag a b b
fmap = forall t t a b. (t -> t) -> Mag a b t -> Mag a b t
Map

instance Applicative (Mag a b) where
  pure :: forall a. a -> Mag a b a
pure = forall t a b. t -> Mag a b t
Pure
  <*> :: forall a b. Mag a b (a -> b) -> Mag a b a -> Mag a b b
(<*>) = forall a b a b. Mag a b (a -> b) -> Mag a b a -> Mag a b b
Ap
#if MIN_VERSION_base(4,10,0)
  liftA2 :: forall a b c. (a -> b -> c) -> Mag a b a -> Mag a b b -> Mag a b c
liftA2 = forall t u v a b.
(t -> u -> v) -> Mag a b t -> Mag a b u -> Mag a b v
LiftA2
#endif

-- Rewrite rules for traversing a few important types. These avoid the overhead
-- of allocating and matching on a Mag.
{-# RULES
"traverseBia/list" forall f t. traverseBia f t = traverseBiaList f t
"traverseBia/Maybe" forall f t. traverseBia f t = traverseBiaMaybe f t
"traverseBia/Either" forall f t. traverseBia f t = traverseBiaEither f t
"traverseBia/Identity" forall f t. traverseBia f t = traverseBiaIdentity f t
"traverseBia/Const" forall f t. traverseBia f t = traverseBiaConst f t
"traverseBia/Pair" forall f t. traverseBia f t = traverseBiaPair f t
 #-}

traverseBiaList :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c]
traverseBiaList :: forall (p :: * -> * -> *) a b c.
Biapplicative p =>
(a -> p b c) -> [a] -> p [b] [c]
traverseBiaList a -> p b c
f = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> p [b] [c] -> p [b] [c]
go (forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure [] [])
  where
    go :: a -> p [b] [c] -> p [b] [c]
go a
x p [b] [c]
r = forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 (:) (:) (a -> p b c
f a
x) p [b] [c]
r

traverseBiaMaybe :: Biapplicative p => (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c)
traverseBiaMaybe :: forall (p :: * -> * -> *) a b c.
Biapplicative p =>
(a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c)
traverseBiaMaybe a -> p b c
_f Maybe a
Nothing = forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure forall a. Maybe a
Nothing forall a. Maybe a
Nothing
traverseBiaMaybe a -> p b c
f (Just a
x) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. a -> Maybe a
Just forall a. a -> Maybe a
Just (a -> p b c
f a
x)

traverseBiaEither :: Biapplicative p => (a -> p b c) -> Either e a -> p (Either e b) (Either e c)
traverseBiaEither :: forall (p :: * -> * -> *) a b c e.
Biapplicative p =>
(a -> p b c) -> Either e a -> p (Either e b) (Either e c)
traverseBiaEither a -> p b c
f (Right a
x) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a b. b -> Either a b
Right forall a b. b -> Either a b
Right (a -> p b c
f a
x)
traverseBiaEither a -> p b c
_f (Left (e
e :: e)) = forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure forall x. Either e x
m forall x. Either e x
m
  where
    m :: Either e x
    m :: forall x. Either e x
m = forall a b. a -> Either a b
Left e
e

traverseBiaIdentity :: Biapplicative p => (a -> p b c) -> Identity a -> p (Identity b) (Identity c)
traverseBiaIdentity :: forall (p :: * -> * -> *) a b c.
Biapplicative p =>
(a -> p b c) -> Identity a -> p (Identity b) (Identity c)
traverseBiaIdentity a -> p b c
f (Identity a
x) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. a -> Identity a
Identity forall a. a -> Identity a
Identity (a -> p b c
f a
x)

traverseBiaConst :: Biapplicative p => (a -> p b c) -> Const x a -> p (Const x b) (Const x c)
traverseBiaConst :: forall (p :: * -> * -> *) a b c x.
Biapplicative p =>
(a -> p b c) -> Const x a -> p (Const x b) (Const x c)
traverseBiaConst a -> p b c
_f (Const x
x) = forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure (forall {k} a (b :: k). a -> Const a b
Const x
x) (forall {k} a (b :: k). a -> Const a b
Const x
x)

traverseBiaPair :: Biapplicative p => (a -> p b c) -> (e, a) -> p (e, b) (e, c)
traverseBiaPair :: forall (p :: * -> * -> *) a b c e.
Biapplicative p =>
(a -> p b c) -> (e, a) -> p (e, b) (e, c)
traverseBiaPair a -> p b c
f (e
x,a
y) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((,) e
x) ((,) e
x) (a -> p b c
f a
y)

----------------------------------------------
--
-- Instances

instance Biapplicative (,) where
  bipure :: forall a b. a -> b -> (a, b)
bipure = (,)
  {-# INLINE bipure #-}
  ~(a -> b
f, c -> d
g) <<*>> :: forall a b c d. (a -> b, c -> d) -> (a, c) -> (b, d)
<<*>> ~(a
a, c
b) = (a -> b
f a
a, c -> d
g c
b)
  {-# INLINE (<<*>>) #-}
  biliftA2 :: forall a b c d e f.
(a -> b -> c) -> (d -> e -> f) -> (a, d) -> (b, e) -> (c, f)
biliftA2 a -> b -> c
f d -> e -> f
g ~(a
x, d
y) ~(b
a, e
b) = (a -> b -> c
f a
x b
a, d -> e -> f
g d
y e
b)
  {-# INLINE biliftA2 #-}

instance Biapplicative Arg where
  bipure :: forall a b. a -> b -> Arg a b
bipure = forall a b. a -> b -> Arg a b
Arg
  {-# INLINE bipure #-}
  Arg a -> b
f c -> d
g <<*>> :: forall a b c d. Arg (a -> b) (c -> d) -> Arg a c -> Arg b d
<<*>> Arg a
a c
b = forall a b. a -> b -> Arg a b
Arg (a -> b
f a
a) (c -> d
g c
b)
  {-# INLINE (<<*>>) #-}
  biliftA2 :: forall a b c d e f.
(a -> b -> c) -> (d -> e -> f) -> Arg a d -> Arg b e -> Arg c f
biliftA2 a -> b -> c
f d -> e -> f
g (Arg a
x d
y) (Arg b
a e
b) = forall a b. a -> b -> Arg a b
Arg (a -> b -> c
f a
x b
a) (d -> e -> f
g d
y e
b)
  {-# INLINE biliftA2 #-}

instance Monoid x => Biapplicative ((,,) x) where
  bipure :: forall a b. a -> b -> (x, a, b)
bipure = (,,) forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  ~(x
x, a -> b
f, c -> d
g) <<*>> :: forall a b c d. (x, a -> b, c -> d) -> (x, a, c) -> (x, b, d)
<<*>> ~(x
x', a
a, c
b) = (forall a. Monoid a => a -> a -> a
mappend x
x x
x', a -> b
f a
a, c -> d
g c
b)
  {-# INLINE (<<*>>) #-}

instance (Monoid x, Monoid y) => Biapplicative ((,,,) x y) where
  bipure :: forall a b. a -> b -> (x, y, a, b)
bipure = (,,,) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  ~(x
x, y
y, a -> b
f, c -> d
g) <<*>> :: forall a b c d.
(x, y, a -> b, c -> d) -> (x, y, a, c) -> (x, y, b, d)
<<*>> ~(x
x', y
y', a
a, c
b) = (forall a. Monoid a => a -> a -> a
mappend x
x x
x', forall a. Monoid a => a -> a -> a
mappend y
y y
y', a -> b
f a
a, c -> d
g c
b)
  {-# INLINE (<<*>>) #-}

instance (Monoid x, Monoid y, Monoid z) => Biapplicative ((,,,,) x y z) where
  bipure :: forall a b. a -> b -> (x, y, z, a, b)
bipure = (,,,,) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  ~(x
x, y
y, z
z, a -> b
f, c -> d
g) <<*>> :: forall a b c d.
(x, y, z, a -> b, c -> d) -> (x, y, z, a, c) -> (x, y, z, b, d)
<<*>> ~(x
x', y
y', z
z', a
a, c
b) = (forall a. Monoid a => a -> a -> a
mappend x
x x
x', forall a. Monoid a => a -> a -> a
mappend y
y y
y', forall a. Monoid a => a -> a -> a
mappend z
z z
z', a -> b
f a
a, c -> d
g c
b)
  {-# INLINE (<<*>>) #-}

instance (Monoid x, Monoid y, Monoid z, Monoid w) => Biapplicative ((,,,,,) x y z w) where
  bipure :: forall a b. a -> b -> (x, y, z, w, a, b)
bipure = (,,,,,) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  ~(x
x, y
y, z
z, w
w, a -> b
f, c -> d
g) <<*>> :: forall a b c d.
(x, y, z, w, a -> b, c -> d)
-> (x, y, z, w, a, c) -> (x, y, z, w, b, d)
<<*>> ~(x
x', y
y', z
z', w
w', a
a, c
b) = (forall a. Monoid a => a -> a -> a
mappend x
x x
x', forall a. Monoid a => a -> a -> a
mappend y
y y
y', forall a. Monoid a => a -> a -> a
mappend z
z z
z', forall a. Monoid a => a -> a -> a
mappend w
w w
w', a -> b
f a
a, c -> d
g c
b)
  {-# INLINE (<<*>>) #-}

instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Biapplicative ((,,,,,,) x y z w v) where
  bipure :: forall a b. a -> b -> (x, y, z, w, v, a, b)
bipure = (,,,,,,) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  ~(x
x, y
y, z
z, w
w, v
v, a -> b
f, c -> d
g) <<*>> :: forall a b c d.
(x, y, z, w, v, a -> b, c -> d)
-> (x, y, z, w, v, a, c) -> (x, y, z, w, v, b, d)
<<*>> ~(x
x', y
y', z
z', w
w', v
v', a
a, c
b) = (forall a. Monoid a => a -> a -> a
mappend x
x x
x', forall a. Monoid a => a -> a -> a
mappend y
y y
y', forall a. Monoid a => a -> a -> a
mappend z
z z
z', forall a. Monoid a => a -> a -> a
mappend w
w w
w', forall a. Monoid a => a -> a -> a
mappend v
v v
v', a -> b
f a
a, c -> d
g c
b)
  {-# INLINE (<<*>>) #-}

#ifdef MIN_VERSION_tagged
instance Biapplicative Tagged where
  bipure :: forall a b. a -> b -> Tagged a b
bipure a
_ b
b = forall {k} (s :: k) b. b -> Tagged s b
Tagged b
b
  {-# INLINE bipure #-}

  Tagged c -> d
f <<*>> :: forall a b c d.
Tagged (a -> b) (c -> d) -> Tagged a c -> Tagged b d
<<*>> Tagged c
x = forall {k} (s :: k) b. b -> Tagged s b
Tagged (c -> d
f c
x)
  {-# INLINE (<<*>>) #-}
#endif

instance Biapplicative Const where
  bipure :: forall a b. a -> b -> Const a b
bipure a
a b
_ = forall {k} a (b :: k). a -> Const a b
Const a
a
  {-# INLINE bipure #-}
  Const a -> b
f <<*>> :: forall a b c d. Const (a -> b) (c -> d) -> Const a c -> Const b d
<<*>> Const a
x = forall {k} a (b :: k). a -> Const a b
Const (a -> b
f a
x)
  {-# INLINE (<<*>>) #-}