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

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

-----------------------------------------------------------------------------
-- |
-- 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 GHC.Exts (inline)

#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid
import Data.Traversable (Traversable (traverse))
#endif

import Data.Semigroup (Arg(..))

#ifdef MIN_VERSION_tagged
import Data.Tagged
#endif

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

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

  (<<*>>) :: p (a -> b) (c -> d) -> p a c -> p b d
  (<<*>>) = ((a -> b) -> a -> b)
-> ((c -> d) -> c -> d) -> 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 (a -> b) -> a -> b
forall a. a -> a
id (c -> d) -> c -> d
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 = (a -> b -> c) -> (d -> e -> f) -> p a d -> p (b -> c) (e -> f)
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 (p a d -> p (b -> c) (e -> f)) -> p a d -> p (b -> c) (e -> f)
forall a b. (a -> b) -> a -> b
<<$>> p a d
a p (b -> c) (e -> f) -> p b e -> p c f
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 = (a -> c -> c) -> (b -> d -> d) -> p a b -> p c d -> p c 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 ((c -> c) -> a -> c -> c
forall a b. a -> b -> a
const c -> c
forall a. a -> a
id) ((d -> d) -> b -> d -> d
forall a b. a -> b -> a
const d -> d
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 = (a -> c -> a) -> (b -> d -> b) -> p a b -> p c d -> p a 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 a -> c -> a
forall a b. a -> b -> a
const b -> d -> b
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
<<**>> :: p a c -> p (a -> b) (c -> d) -> p b d
(<<**>>) = (a -> (a -> b) -> b)
-> (c -> (c -> d) -> d) -> 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 (((a -> b) -> a -> b) -> a -> (a -> b) -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> a -> b
forall a. a -> a
id) (((c -> d) -> c -> d) -> c -> (c -> d) -> d
forall a b c. (a -> b -> c) -> b -> a -> c
flip (c -> d) -> c -> d
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 :: (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 = (a -> b -> c -> d)
-> (e -> f -> g -> h) -> w a e -> w b f -> w (c -> d) (g -> h)
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 w (c -> d) (g -> h) -> w c g -> w d h
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 :: (a -> p b c) -> t a -> p (t b) (t c)
traverseBia = ((a -> p b c) -> t a -> p (t b) (t c))
-> (a -> p b c) -> t a -> p (t b) (t c)
forall a. a -> a
inline ((forall (f :: * -> *) x.
 Applicative f =>
 (a -> f x) -> t a -> f (t x))
-> (a -> p b c) -> t a -> p (t b) (t c)
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)
forall (f :: * -> *) x.
Applicative f =>
(a -> f x) -> t a -> f (t x)
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 :: t (p b c) -> p (t b) (t c)
sequenceBia = (t (p b c) -> p (t b) (t c)) -> t (p b c) -> p (t b) (t c)
forall a. a -> a
inline ((p b c -> p b c) -> t (p b c) -> p (t b) (t c)
forall (t :: * -> *) (p :: * -> * -> *) a b c.
(Traversable t, Biapplicative p) =>
(a -> p b c) -> t a -> p (t b) (t c)
traverseBia p b c -> p b c
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 (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 = (a -> p b c) -> (forall x. Mag a x (t x)) -> p (t b) (t c)
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 ((a -> Mag a x x) -> s -> Mag a x (t x)
forall (f :: * -> *) x. Applicative f => (a -> f x) -> s -> f (t x)
trav a -> Mag a x x
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 :: (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 = Mag a b (t b) -> Mag a c (t c) -> p (t b) (t c)
forall x y. Mag a b x -> Mag a c y -> p x y
go Mag a b (t b)
forall x. Mag a x (t x)
m Mag a c (t c)
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 :: Mag a b x -> Mag a c y -> p x y
go (Pure x
t) (Pure y
u) = x -> y -> p x y
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) = (x -> x) -> (x -> y) -> p x x -> p 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 (Mag a b x -> Mag a c x -> p x x
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) = Mag a b (t -> x) -> Mag a c (t -> y) -> p (t -> x) (t -> y)
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 p (t -> x) (t -> y) -> p t t -> p x y
forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p (a -> b) (c -> d) -> p a c -> p b d
<<*>> Mag a b t -> Mag a c t -> p t t
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) = (t -> u -> x) -> (t -> u -> y) -> p t t -> p u u -> p x y
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 (Mag a b t -> Mag a c t -> p t t
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) (Mag a b u -> Mag a c u -> p u u
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
_ = p x 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 :: a
impossibleError = [Char] -> a
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 :: (a -> b) -> Mag a b a -> Mag a b b
fmap = (a -> b) -> Mag a b a -> Mag a b b
forall x t a b. (x -> t) -> Mag a b x -> Mag a b t
Map

instance Applicative (Mag a b) where
  pure :: a -> Mag a b a
pure = a -> Mag a b a
forall t a b. t -> Mag a b t
Pure
  <*> :: Mag a b (a -> b) -> Mag a b a -> Mag a b 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 :: (a -> b -> c) -> Mag a b a -> Mag a b b -> Mag a b c
liftA2 = (a -> b -> c) -> Mag a b a -> Mag a b b -> Mag a b c
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 :: (a -> p b c) -> [a] -> p [b] [c]
traverseBiaList a -> p b c
f = (a -> p [b] [c] -> p [b] [c]) -> p [b] [c] -> [a] -> p [b] [c]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> p [b] [c] -> p [b] [c]
go ([b] -> [c] -> p [b] [c]
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 = (b -> [b] -> [b])
-> (c -> [c] -> [c]) -> p b c -> p [b] [c] -> p [b] [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 -> 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 :: (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c)
traverseBiaMaybe a -> p b c
_f Maybe a
Nothing = Maybe b -> Maybe c -> p (Maybe b) (Maybe c)
forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure Maybe b
forall a. Maybe a
Nothing Maybe c
forall a. Maybe a
Nothing
traverseBiaMaybe a -> p b c
f (Just a
x) = (b -> Maybe b) -> (c -> Maybe c) -> p b c -> p (Maybe b) (Maybe c)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b -> Maybe b
forall a. a -> Maybe a
Just c -> Maybe c
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 :: (a -> p b c) -> Either e a -> p (Either e b) (Either e c)
traverseBiaEither a -> p b c
f (Right a
x) = (b -> Either e b)
-> (c -> Either e c) -> p b c -> p (Either e b) (Either e c)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b -> Either e b
forall a b. b -> Either a b
Right c -> Either e c
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)) = Either e b -> Either e c -> p (Either e b) (Either e c)
forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure Either e b
forall x. Either e x
m Either e c
forall x. Either e x
m
  where
    m :: Either e x
    m :: Either e x
m = e -> Either e x
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 :: (a -> p b c) -> Identity a -> p (Identity b) (Identity c)
traverseBiaIdentity a -> p b c
f (Identity a
x) = (b -> Identity b)
-> (c -> Identity c) -> p b c -> p (Identity b) (Identity c)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b -> Identity b
forall a. a -> Identity a
Identity c -> Identity c
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 :: (a -> p b c) -> Const x a -> p (Const x b) (Const x c)
traverseBiaConst a -> p b c
_f (Const x
x) = Const x b -> Const x c -> p (Const x b) (Const x c)
forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure (x -> Const x b
forall k a (b :: k). a -> Const a b
Const x
x) (x -> Const x c
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 :: (a -> p b c) -> (e, a) -> p (e, b) (e, c)
traverseBiaPair a -> p b c
f (e
x,a
y) = (b -> (e, b)) -> (c -> (e, c)) -> p b c -> p (e, b) (e, c)
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 :: a -> b -> (a, b)
bipure = (,)
  {-# INLINE bipure #-}
  (a -> b
f, c -> d
g) <<*>> :: (a -> b, c -> d) -> (a, c) -> (b, d)
<<*>> (a
a, c
b) = (a -> b
f a
a, c -> d
g c
b)
  {-# INLINE (<<*>>) #-}
  biliftA2 :: (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 :: a -> b -> Arg a b
bipure = a -> b -> Arg a b
forall a b. a -> b -> Arg a b
Arg
  {-# INLINE bipure #-}
  Arg a -> b
f c -> d
g <<*>> :: Arg (a -> b) (c -> d) -> Arg a c -> Arg b d
<<*>> Arg a
a c
b = b -> d -> Arg b d
forall a b. a -> b -> Arg a b
Arg (a -> b
f a
a) (c -> d
g c
b)
  {-# INLINE (<<*>>) #-}
  biliftA2 :: (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) = c -> f -> Arg c f
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 :: a -> b -> (x, a, b)
bipure = (,,) x
forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  (x
x, a -> b
f, c -> d
g) <<*>> :: (x, a -> b, c -> d) -> (x, a, c) -> (x, b, d)
<<*>> (x
x', a
a, c
b) = (x -> x -> x
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 :: a -> b -> (x, y, a, b)
bipure = (,,,) x
forall a. Monoid a => a
mempty y
forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  (x
x, y
y, a -> b
f, c -> d
g) <<*>> :: (x, y, a -> b, c -> d) -> (x, y, a, c) -> (x, y, b, d)
<<*>> (x
x', y
y', a
a, c
b) = (x -> x -> x
forall a. Monoid a => a -> a -> a
mappend x
x x
x', y -> y -> y
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 :: a -> b -> (x, y, z, a, b)
bipure = (,,,,) x
forall a. Monoid a => a
mempty y
forall a. Monoid a => a
mempty z
forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  (x
x, y
y, z
z, a -> b
f, c -> d
g) <<*>> :: (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) = (x -> x -> x
forall a. Monoid a => a -> a -> a
mappend x
x x
x', y -> y -> y
forall a. Monoid a => a -> a -> a
mappend y
y y
y', z -> z -> z
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 :: a -> b -> (x, y, z, w, a, b)
bipure = (,,,,,) x
forall a. Monoid a => a
mempty y
forall a. Monoid a => a
mempty z
forall a. Monoid a => a
mempty w
forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  (x
x, y
y, z
z, w
w, a -> b
f, c -> d
g) <<*>> :: (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) = (x -> x -> x
forall a. Monoid a => a -> a -> a
mappend x
x x
x', y -> y -> y
forall a. Monoid a => a -> a -> a
mappend y
y y
y', z -> z -> z
forall a. Monoid a => a -> a -> a
mappend z
z z
z', w -> w -> w
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 :: a -> b -> (x, y, z, w, v, a, b)
bipure = (,,,,,,) x
forall a. Monoid a => a
mempty y
forall a. Monoid a => a
mempty z
forall a. Monoid a => a
mempty w
forall a. Monoid a => a
mempty v
forall a. Monoid a => a
mempty
  {-# INLINE bipure #-}
  (x
x, y
y, z
z, w
w, v
v, a -> b
f, c -> d
g) <<*>> :: (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) = (x -> x -> x
forall a. Monoid a => a -> a -> a
mappend x
x x
x', y -> y -> y
forall a. Monoid a => a -> a -> a
mappend y
y y
y', z -> z -> z
forall a. Monoid a => a -> a -> a
mappend z
z z
z', w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w w
w', v -> v -> v
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 :: a -> b -> Tagged a b
bipure a
_ b
b = b -> Tagged a b
forall k (s :: k) b. b -> Tagged s b
Tagged b
b
  {-# INLINE bipure #-}

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

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