{-# OPTIONS_GHC -fno-warn-orphans #-}
module Pandora.Paradigm.Algebraic.Exponential where

import Pandora.Pattern.Betwixt (Betwixt)
import Pandora.Pattern.Semigroupoid (Semigroupoid ((.)))
import Pandora.Pattern.Category (Category ((<--), identity))
import Pandora.Pattern.Kernel (Kernel (constant))
import Pandora.Pattern.Functor.Covariant (Covariant ((<-|-)))
import Pandora.Pattern.Functor.Contravariant (Contravariant ((>-|-)))
import Pandora.Pattern.Functor.Distributive (Distributive ((-<<)))
import Pandora.Pattern.Functor.Bindable (Bindable ((=<<)))
import Pandora.Pattern.Object.Semigroup (Semigroup ((+)))
import Pandora.Pattern.Object.Ringoid (Ringoid ((*)))
import Pandora.Pattern.Morphism.Flip (Flip (Flip))
import Pandora.Pattern.Morphism.Straight (Straight (Straight))

infixr 7 .:..
infixr 9 %
infixl 1 &

type instance Betwixt (->) (->) = (->)

instance Semigroupoid (->) where
	b -> c
f . :: (b -> c) -> (a -> b) -> a -> c
. a -> b
g = \a
x -> b -> c
f (a -> b
g a
x)

instance Category (->) where
	identity :: a -> a
identity a
x = a
x

instance Kernel (->) where
	constant :: a -> i -> a
constant a
x i
_ = a
x

instance Covariant (->) (->) ((->) a) where
	<-|- :: (a -> b) -> (a -> a) -> a -> b
(<-|-) = (a -> b) -> (a -> a) -> a -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
(.)

instance Distributive (->) (->) ((->) e) where
	a -> e -> b
f -<< :: (a -> e -> b) -> u a -> e -> u b
-<< u a
g = \e
e -> a -> e -> b
f (a -> e -> b) -> e -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
% e
e (a -> b) -> u a -> u b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
<-|- u a
g

instance Bindable (->) ((->) e) where
	a -> e -> b
f =<< :: (a -> e -> b) -> (e -> a) -> e -> b
=<< e -> a
g = \e
x -> a -> e -> b
f (a -> e -> b) -> a -> e -> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- e -> a
g e
x (e -> b) -> e -> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- e
x

instance Semigroup r => Semigroup (e -> r) where
	e -> r
f + :: (e -> r) -> (e -> r) -> e -> r
+ e -> r
g = \e
e -> e -> r
f e
e r -> r -> r
forall a. Semigroup a => a -> a -> a
+ e -> r
g e
e

instance Ringoid r => Ringoid (e -> r) where
	e -> r
f * :: (e -> r) -> (e -> r) -> e -> r
* e -> r
g = \e
e -> e -> r
f e
e r -> r -> r
forall a. Ringoid a => a -> a -> a
* e -> r
g e
e

type (<--) = Flip (->)

instance Contravariant (->) (->) ((<--) a) where
	a -> b
f >-|- :: (a -> b) -> (a <-- b) -> a <-- a
>-|- Flip b -> a
g = (a -> a) -> a <-- a
forall (v :: * -> * -> *) a e. v e a -> Flip v a e
Flip ((a -> a) -> a <-- a) -> (a -> a) -> a <-- a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- b -> a
g (b -> a) -> (a -> b) -> a -> a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. a -> b
f

type (-->) = Straight (->)

instance Covariant (->) (->) ((-->) b) where
	a -> b
f <-|- :: (a -> b) -> (b --> a) -> b --> b
<-|- Straight b -> a
g = (b -> b) -> b --> b
forall (v :: * -> * -> *) a e. v a e -> Straight v a e
Straight ((b -> b) -> b --> b) -> (b -> b) -> b --> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
<-- a -> b
f (a -> b) -> (b -> a) -> b -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. b -> a
g

(.:..) :: (Covariant (->) target (v a), Semigroupoid v) => v c d -> target (v a (v b c)) (v a (v b d))
.:.. :: v c d -> target (v a (v b c)) (v a (v b d))
(.:..) v c d
f = (v b c -> v b d) -> target (v a (v b c)) (v a (v b d))
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
(<-|-) (v c d
f v c d -> v b c -> v b d
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
.)

{-# INLINE (%) #-}
(%) :: (a -> b -> c) -> b -> a -> c
% :: (a -> b -> c) -> b -> a -> c
(%) a -> b -> c
f b
x a
y = a -> b -> c
f a
y b
x

{-# INLINE (&) #-}
(&) :: a -> (a -> b) -> b
a
x & :: a -> (a -> b) -> b
& a -> b
f = a -> b
f a
x

fix :: (a -> a) -> a
fix :: (a -> a) -> a
fix a -> a
f = let x :: a
x = a -> a
f a
x in a
x