{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
#ifndef MIN_VERSION_semigroups
#define MIN_VERSION_semigroups(x,y,z) 0
#endif
module Data.Biapplicative (
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
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2)
import Data.Semigroup (Arg(..))
#endif
#ifdef MIN_VERSION_tagged
import Data.Tagged
#endif
infixl 4 <<$>>, <<*>>, <<*, *>>, <<**>>
(<<$>>) :: (a -> b) -> a -> b
(<<$>>) = 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
(<<*>>) = biliftA2 id id
{-# INLINE (<<*>>) #-}
biliftA2 :: (a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 f g a b = bimap f g <<$>> a <<*>> b
{-# INLINE biliftA2 #-}
(*>>) :: p a b -> p c d -> p c d
a *>> b = biliftA2 (const id) (const id) a b
{-# INLINE (*>>) #-}
(<<*) :: p a b -> p c d -> p a b
a <<* b = biliftA2 const const a b
{-# INLINE (<<*) #-}
(<<**>>) :: Biapplicative p => p a c -> p (a -> b) (c -> d) -> p b d
(<<**>>) = biliftA2 (flip id) (flip id)
{-# INLINE (<<**>>) #-}
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 = biliftA2 f g a b <<*>> c
{-# INLINE biliftA3 #-}
traverseBia :: (Traversable t, Biapplicative p)
=> (a -> p b c) -> t a -> p (t b) (t c)
traverseBia = inline (traverseBiaWith traverse)
{-# INLINABLE [1] traverseBia #-}
sequenceBia :: (Traversable t, Biapplicative p)
=> t (p b c) -> p (t b) (t c)
sequenceBia = inline (traverseBia id)
{-# INLINABLE sequenceBia #-}
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 trav p s = smash p (trav One 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 p m = go m m
where
go :: forall x y. Mag a b x -> Mag a c y -> p x y
go (Pure t) (Pure u) = bipure t u
go (Map f x) (Map g y) = bimap f g (go x y)
go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys
#if MIN_VERSION_base(4,10,0)
go (LiftA2 f xs ys) (LiftA2 g zs ws) = bimap f g (go xs zs) <<*>> go ys ws
#endif
go (One x) (One _) = p x
go _ _ = impossibleError
{-# INLINABLE smash #-}
impossibleError :: a
impossibleError = error "Impossible: the arguments are always the same."
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 = Map
instance Applicative (Mag a b) where
pure = Pure
(<*>) = Ap
#if MIN_VERSION_base(4,10,0)
liftA2 = LiftA2
#endif
{-# 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 f = foldr go (bipure [] [])
where
go x r = biliftA2 (:) (:) (f x) r
traverseBiaMaybe :: Biapplicative p => (a -> p b c) -> Maybe a -> p (Maybe b) (Maybe c)
traverseBiaMaybe _f Nothing = bipure Nothing Nothing
traverseBiaMaybe f (Just x) = bimap Just Just (f x)
traverseBiaEither :: Biapplicative p => (a -> p b c) -> Either e a -> p (Either e b) (Either e c)
traverseBiaEither f (Right x) = bimap Right Right (f x)
traverseBiaEither _f (Left (e :: e)) = bipure m m
where
m :: Either e x
m = Left e
traverseBiaIdentity :: Biapplicative p => (a -> p b c) -> Identity a -> p (Identity b) (Identity c)
traverseBiaIdentity f (Identity x) = bimap Identity Identity (f x)
traverseBiaConst :: Biapplicative p => (a -> p b c) -> Const x a -> p (Const x b) (Const x c)
traverseBiaConst _f (Const x) = bipure (Const x) (Const x)
traverseBiaPair :: Biapplicative p => (a -> p b c) -> (e, a) -> p (e, b) (e, c)
traverseBiaPair f (x,y) = bimap ((,) x) ((,) x) (f y)
instance Biapplicative (,) where
bipure = (,)
{-# INLINE bipure #-}
(f, g) <<*>> (a, b) = (f a, g b)
{-# INLINE (<<*>>) #-}
biliftA2 f g (x, y) (a, b) = (f x a, g y b)
{-# INLINE biliftA2 #-}
#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2)
instance Biapplicative Arg where
bipure = Arg
{-# INLINE bipure #-}
Arg f g <<*>> Arg a b = Arg (f a) (g b)
{-# INLINE (<<*>>) #-}
biliftA2 f g (Arg x y) (Arg a b) = Arg (f x a) (g y b)
{-# INLINE biliftA2 #-}
#endif
instance Monoid x => Biapplicative ((,,) x) where
bipure = (,,) mempty
{-# INLINE bipure #-}
(x, f, g) <<*>> (x', a, b) = (mappend x x', f a, g b)
{-# INLINE (<<*>>) #-}
instance (Monoid x, Monoid y) => Biapplicative ((,,,) x y) where
bipure = (,,,) mempty mempty
{-# INLINE bipure #-}
(x, y, f, g) <<*>> (x', y', a, b) = (mappend x x', mappend y y', f a, g b)
{-# INLINE (<<*>>) #-}
instance (Monoid x, Monoid y, Monoid z) => Biapplicative ((,,,,) x y z) where
bipure = (,,,,) mempty mempty mempty
{-# INLINE bipure #-}
(x, y, z, f, g) <<*>> (x', y', z', a, b) = (mappend x x', mappend y y', mappend z z', f a, g b)
{-# INLINE (<<*>>) #-}
instance (Monoid x, Monoid y, Monoid z, Monoid w) => Biapplicative ((,,,,,) x y z w) where
bipure = (,,,,,) mempty mempty mempty mempty
{-# INLINE bipure #-}
(x, y, z, w, f, g) <<*>> (x', y', z', w', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', f a, g b)
{-# INLINE (<<*>>) #-}
instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Biapplicative ((,,,,,,) x y z w v) where
bipure = (,,,,,,) mempty mempty mempty mempty mempty
{-# INLINE bipure #-}
(x, y, z, w, v, f, g) <<*>> (x', y', z', w', v', a, b) = (mappend x x', mappend y y', mappend z z', mappend w w', mappend v v', f a, g b)
{-# INLINE (<<*>>) #-}
#ifdef MIN_VERSION_tagged
instance Biapplicative Tagged where
bipure _ b = Tagged b
{-# INLINE bipure #-}
Tagged f <<*>> Tagged x = Tagged (f x)
{-# INLINE (<<*>>) #-}
#endif
instance Biapplicative Const where
bipure a _ = Const a
{-# INLINE bipure #-}
Const f <<*>> Const x = Const (f x)
{-# INLINE (<<*>>) #-}