{-# LANGUAGE AllowAmbiguousTypes #-}

module Proarrow.Category.Monoidal.Applicative where

import Control.Applicative qualified as P
import Data.Function (($))
import Data.Kind (Constraint)
import Data.List.NonEmpty qualified as P
import Prelude qualified as P

import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))
import Proarrow.Category.Monoidal.Distributive (Distributive)
import Proarrow.Core (CategoryOf (..), Profunctor (..), type (+->))
import Proarrow.Functor (FromProfunctor (..), Functor (..), Prelude (..))
import Proarrow.Monoid (Comonoid (..))
import Proarrow.Object.BinaryCoproduct (HasBinaryCoproducts (..))

type Applicative :: forall {j} {k}. (j -> k) -> Constraint
class (Monoidal j, Monoidal k, Functor f) => Applicative (f :: j -> k) where
  pure :: Unit ~> a -> Unit ~> f a
  liftA2 :: (Ob a, Ob b) => (a ** b ~> c) -> f a ** f b ~> f c

instance (MonoidalProfunctor (p :: j +-> k), Comonoid x) => Applicative (FromProfunctor p x) where
  pure :: forall (a :: j). (Unit ~> a) -> Unit ~> FromProfunctor p x a
pure Unit ~> a
a () = p x a -> FromProfunctor p x a
forall {k} {k1} (p :: k -> k1 -> Type) (a :: k) (b :: k1).
p a b -> FromProfunctor p a b
FromProfunctor (p x a -> FromProfunctor p x a) -> p x a -> FromProfunctor p x a
forall a b. (a -> b) -> a -> b
$ (x ~> Unit) -> (Unit ~> a) -> p Unit Unit -> p x a
forall (c :: k) (a :: k) (b :: j) (d :: j).
(c ~> a) -> (b ~> d) -> p a b -> p c d
forall {j} {k} (p :: PRO j k) (c :: j) (a :: j) (b :: k) (d :: k).
Profunctor p =>
(c ~> a) -> (b ~> d) -> p a b -> p c d
dimap x ~> Unit
forall {k} (c :: k). Comonoid c => c ~> Unit
counit Unit ~> a
a p Unit Unit
forall {j} {k} (p :: j +-> k). MonoidalProfunctor p => p Unit Unit
par0
  liftA2 :: forall (a :: j) (b :: j) (c :: j).
(Ob a, Ob b) =>
((a ** b) ~> c)
-> (FromProfunctor p x a ** FromProfunctor p x b)
   ~> FromProfunctor p x c
liftA2 (a ** b) ~> c
abc (FromProfunctor p x a
pxa, FromProfunctor p x b
pxb) = p x c -> FromProfunctor p x c
forall {k} {k1} (p :: k -> k1 -> Type) (a :: k) (b :: k1).
p a b -> FromProfunctor p a b
FromProfunctor (p x c -> FromProfunctor p x c) -> p x c -> FromProfunctor p x c
forall a b. (a -> b) -> a -> b
$ (x ~> (x ** x)) -> ((a ** b) ~> c) -> p (x ** x) (a ** b) -> p x c
forall (c :: k) (a :: k) (b :: j) (d :: j).
(c ~> a) -> (b ~> d) -> p a b -> p c d
forall {j} {k} (p :: PRO j k) (c :: j) (a :: j) (b :: k) (d :: k).
Profunctor p =>
(c ~> a) -> (b ~> d) -> p a b -> p c d
dimap x ~> (x ** x)
forall {k} (c :: k). Comonoid c => c ~> (c ** c)
comult (a ** b) ~> c
abc (p x a
pxa p x a -> p x b -> p (x ** x) (a ** b)
forall (x1 :: k) (x2 :: j) (y1 :: k) (y2 :: j).
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
`par` p x b
pxb)

instance (P.Applicative f) => Applicative (Prelude f) where
  pure :: forall a. (Unit ~> a) -> Unit ~> Prelude f a
pure Unit ~> a
a () = f a -> Prelude f a
forall {k} (f :: k -> Type) (a :: k). f a -> Prelude f a
Prelude (a -> f a
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
P.pure (Unit ~> a
() -> a
a ()))
  liftA2 :: forall a b c.
(Ob a, Ob b) =>
((a ** b) ~> c) -> (Prelude f a ** Prelude f b) ~> Prelude f c
liftA2 (a ** b) ~> c
f (Prelude f a
fa, Prelude f b
fb) = f c -> Prelude f c
forall {k} (f :: k -> Type) (a :: k). f a -> Prelude f a
Prelude ((a -> b -> c) -> f a -> f b -> f c
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
P.liftA2 (((a, b) -> c) -> a -> b -> c
forall a b c. ((a, b) -> c) -> a -> b -> c
P.curry (a ** b) ~> c
(a, b) -> c
f) f a
fa f b
fb)

deriving via Prelude ((,) a) instance (P.Monoid a) => Applicative ((,) a)
deriving via Prelude ((->) a) instance Applicative ((->) a)
deriving via Prelude [] instance Applicative []
deriving via Prelude (P.Either e) instance Applicative (P.Either e)
deriving via Prelude P.IO instance Applicative P.IO
deriving via Prelude P.Maybe instance Applicative P.Maybe
deriving via Prelude P.NonEmpty instance Applicative P.NonEmpty

type Alternative :: forall {j} {k}. (j -> k) -> Constraint
class (Distributive j, Applicative f) => Alternative (f :: j -> k) where
  empty :: (Ob a) => Unit ~> f a
  alt :: (Ob a, Ob b) => (a || b ~> c) -> f a ** f b ~> f c

instance (P.Alternative f) => Alternative (Prelude f) where
  empty :: forall a. Ob a => Unit ~> Prelude f a
empty () = f a -> Prelude f a
forall {k} (f :: k -> Type) (a :: k). f a -> Prelude f a
Prelude f a
forall a. f a
forall (f :: Type -> Type) a. Alternative f => f a
P.empty
  alt :: forall a b c.
(Ob a, Ob b) =>
((a || b) ~> c) -> (Prelude f a ** Prelude f b) ~> Prelude f c
alt (a || b) ~> c
abc (Prelude f a
fl, Prelude f b
fr) = f c -> Prelude f c
forall {k} (f :: k -> Type) (a :: k). f a -> Prelude f a
Prelude ((Either a b -> c) -> f (Either a b) -> f c
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (a || b) ~> c
Either a b -> c
abc (f (Either a b) -> f c) -> f (Either a b) -> f c
forall a b. (a -> b) -> a -> b
$ (a -> Either a b) -> f a -> f (Either a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap a -> Either a b
forall a b. a -> Either a b
P.Left f a
fl f (Either a b) -> f (Either a b) -> f (Either a b)
forall a. f a -> f a -> f a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
P.<|> (b -> Either a b) -> f b -> f (Either a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap b -> Either a b
forall a b. b -> Either a b
P.Right f b
fr)

deriving via Prelude [] instance Alternative []
deriving via Prelude P.Maybe instance Alternative P.Maybe
deriving via Prelude P.IO instance Alternative P.IO