{-# OPTIONS_GHC -fno-warn-orphans #-}

module Pandora.Paradigm.Primary.Algebraic (module Exports, (-<*>-)) where

import Pandora.Paradigm.Primary.Algebraic.Exponential as Exports
import Pandora.Paradigm.Primary.Algebraic.Product as Exports

import Pandora.Pattern.Category (($))
import Pandora.Pattern.Functor.Covariant (Covariant_ ((-<$>-)))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Applicative (Semimonoidal (multiply))
import Pandora.Pattern.Functor.Traversable (Traversable ((<<-)))
import Pandora.Pattern.Functor.Adjoint (Adjoint ((-|), (|-)))

infixl 4 -<*>-

instance Semimonoidal ((->) e) (:*:) (->) (->) where
	multiply :: ((a :*: b) -> r) -> ((e -> a) :*: (e -> b)) -> e -> r
multiply (a :*: b) -> r
f (e -> a
g :*: e -> b
h) = \e
x -> (a :*: b) -> r
f ((a :*: b) -> r) -> (a :*: b) -> r
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ e -> a
g e
x a -> b -> a :*: b
forall s a. s -> a -> s :*: a
:*: e -> b
h e
x

instance Traversable ((:*:) s) (->) (->) where
	a -> u b
f <<- :: (a -> u b) -> (s :*: a) -> u (s :*: b)
<<- s :*: a
x = ((s :*: a) -> s
forall a b. (a :*: b) -> a
attached s :*: a
x s -> b -> s :*: b
forall s a. s -> a -> s :*: a
:*:) (b -> s :*: b) -> u b -> u (s :*: b)
forall (t :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Covariant_ t source target =>
source a b -> target (t a) (t b)
-<$>- a -> u b
f ((s :*: a) -> a
forall (t :: * -> *) (source :: * -> * -> *) a.
Extractable t source =>
source (t a) a
extract s :*: a
x)

instance Adjoint ((:*:) s) ((->) s) (->) (->) where
	(-|) :: ((s :*: a) -> b) -> a -> (s -> b)
	(s :*: a) -> b
f -| :: ((s :*: a) -> b) -> a -> s -> b
-| a
x = \s
s -> (s :*: a) -> b
f ((s :*: a) -> b) -> (s :*: a) -> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ s
s s -> a -> s :*: a
forall s a. s -> a -> s :*: a
:*: a
x
	(|-) :: (a -> s -> b) -> (s :*: a) -> b
	a -> s -> b
f |- :: (a -> s -> b) -> (s :*: a) -> b
|- ~(s
s :*: a
x) = a -> s -> b
f a
x s
s

(-<*>-) :: forall a b t . (Semimonoidal t (:*:) (->) (->)) => t (a -> b) -> t a -> t b
-<*>- :: t (a -> b) -> t a -> t b
(-<*>-) = (t a -> t (a -> b) -> t b) -> t (a -> b) -> t a -> t b
forall a b c. (a -> b -> c) -> b -> a -> c
(%) (((t (a -> b) :*: t a) -> t b) -> t a -> t (a -> b) -> t b
forall (t :: * -> *) (u :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Adjoint t u source target =>
source (t a) b -> target a (u b)
(-|) @((:*:) (t (a -> b))) ((((a -> b) :*: a) -> b) -> (t (a -> b) :*: t a) -> t b
forall (t :: * -> *) (v :: * -> * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b r.
Semimonoidal t v source target =>
source (v a b) r -> target (v (t a) (t b)) (t r)
multiply @t @(:*:) @(->) @(->) (a -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
(&) (a -> (a -> b) -> b) -> ((a -> b) :*: a) -> b
forall (t :: * -> *) (u :: * -> *) (source :: * -> * -> *)
       (target :: * -> * -> *) a b.
Adjoint t u source target =>
target a (u b) -> source (t a) b
|-)))