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

module Pandora.Paradigm.Inventory.Imprint (Imprint (..), Traceable) where

import Pandora.Pattern.Semigroupoid ((.))
import Pandora.Pattern.Category (($))
import Pandora.Pattern.Functor.Covariant (Covariant ((-<$>-)))
import Pandora.Pattern.Functor.Contravariant (Contravariant ((->$<-)))
import Pandora.Pattern.Functor.Distributive (Distributive ((-<<)))
import Pandora.Pattern.Functor.Extendable (Extendable ((<<=)))
import Pandora.Pattern.Functor.Comonad (Comonad)
import Pandora.Pattern.Functor.Divariant (Divariant ((>->)))
import Pandora.Pattern.Object.Semigroup (Semigroup ((+)))
import Pandora.Paradigm.Primary.Algebraic.Exponential ()
import Pandora.Paradigm.Primary.Transformer.Flip (Flip (Flip))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Schematic, Interpreted (Primary, run, unite, (||=)))
import Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable)
import Pandora.Paradigm.Schemes.UT (UT (UT), type (<.:>))

newtype Imprint e a = Imprint (e -> a)

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

instance Contravariant (->) (->) (Flip Imprint a) where
	a -> b
f ->$<- :: (a -> b) -> Flip Imprint a b -> Flip Imprint a a
->$<- Flip (Imprint b -> a
g) = Imprint a a -> Flip Imprint a a
forall (v :: * -> * -> *) a e. v e a -> Flip v a e
Flip (Imprint a a -> Flip Imprint a a)
-> ((a -> a) -> Imprint a a) -> (a -> a) -> Flip Imprint a a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (a -> a) -> Imprint a a
forall e a. (e -> a) -> Imprint e a
Imprint ((a -> a) -> Flip Imprint a a) -> (a -> a) -> Flip Imprint 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

instance Distributive (->) (->) (Imprint e) where
	a -> Imprint e b
f -<< :: (a -> Imprint e b) -> u a -> Imprint e (u b)
-<< u a
g = (e -> u b) -> Imprint e (u b)
forall e a. (e -> a) -> Imprint e a
Imprint ((e -> u b) -> Imprint e (u b)) -> (e -> u b) -> Imprint e (u b)
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (Imprint e b -> e -> b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (Imprint e b -> e -> b) -> (a -> Imprint e b) -> a -> e -> b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
-<$>- a -> Imprint e b
f) (a -> e -> b) -> u a -> e -> u b
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
(Distributive source target t, Covariant source target u) =>
source a (t b) -> target (u a) (t (u b))
-<< u a
g

instance Divariant (->) (->) (->) Imprint where
	>-> :: (a -> b) -> (c -> d) -> Imprint b c -> Imprint a d
(>->) a -> b
ab c -> d
cd Imprint b c
bc = a -> b
ab (a -> b) -> (c -> d) -> (b -> c) -> a -> d
forall (left :: * -> * -> *) (right :: * -> * -> *)
       (target :: * -> * -> *) (v :: * -> * -> *) a b c d.
Divariant left right target v =>
left a b -> right c d -> target (v b c) (v a d)
>-> c -> d
cd (Primary (Imprint b) c -> Primary (Imprint a) d)
-> Imprint b c -> Imprint a d
forall (t :: * -> *) (u :: * -> *) a b.
(Interpreted t, Interpreted u) =>
(Primary t a -> Primary u b) -> t a -> u b
||= Imprint b c
bc

instance Semigroup e => Extendable (->) (Imprint e) where
	Imprint e a -> b
f <<= :: (Imprint e a -> b) -> Imprint e a -> Imprint e b
<<= Imprint e -> a
x = (e -> b) -> Imprint e b
forall e a. (e -> a) -> Imprint e a
Imprint ((e -> b) -> Imprint e b) -> (e -> b) -> Imprint e b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ \e
e -> Imprint e a -> b
f (Imprint e a -> b) -> Imprint e a -> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (e -> a) -> Imprint e a
forall e a. (e -> a) -> Imprint e a
Imprint ((e -> a) -> Imprint e a) -> (e -> a) -> Imprint e a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ e -> a
x (e -> a) -> (e -> e) -> e -> a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
+)

instance Interpreted (Imprint e) where
	type Primary (Imprint e) a = (->) e a
	run :: Imprint e a -> Primary (Imprint e) a
run ~(Imprint e -> a
x) = Primary (Imprint e) a
e -> a
x
	unite :: Primary (Imprint e) a -> Imprint e a
unite = Primary (Imprint e) a -> Imprint e a
forall e a. (e -> a) -> Imprint e a
Imprint

type instance Schematic Comonad (Imprint e) = (<.:>) ((->) e)

instance {-# OVERLAPS #-} (Semigroup e, Extendable (->) u) => Extendable (->) ((->) e <.:> u) where
	(<.:>) ((->) e) u a -> b
f <<= :: ((<.:>) ((->) e) u a -> b)
-> (<.:>) ((->) e) u a -> (<.:>) ((->) e) u b
<<= UT (u :. (->) e) := a
x = ((u :. (->) e) := b) -> (<.:>) ((->) e) u b
forall k k k k (ct :: k) (cu :: k) (t :: k -> k) (u :: k -> *)
       (a :: k).
((u :. t) := a) -> UT ct cu t u a
UT (((u :. (->) e) := b) -> (<.:>) ((->) e) u b)
-> ((u :. (->) e) := b) -> (<.:>) ((->) e) u b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (\(u :. (->) e) := a
x' e
e -> (<.:>) ((->) e) u a -> b
f ((<.:>) ((->) e) u a -> b)
-> (((u :. (->) e) := a) -> (<.:>) ((->) e) u a)
-> ((u :. (->) e) := a)
-> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. ((u :. (->) e) := a) -> (<.:>) ((->) e) u a
forall k k k k (ct :: k) (cu :: k) (t :: k -> k) (u :: k -> *)
       (a :: k).
((u :. t) := a) -> UT ct cu t u a
UT (((u :. (->) e) := a) -> (<.:>) ((->) e) u a)
-> (((u :. (->) e) := a) -> (u :. (->) e) := a)
-> ((u :. (->) e) := a)
-> (<.:>) ((->) e) u a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. ((e -> a) -> e -> a) -> ((u :. (->) e) := a) -> (u :. (->) e) := a
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
(-<$>-) ((e -> a) -> (e -> e) -> e -> a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
+)) (((u :. (->) e) := a) -> b) -> ((u :. (->) e) := a) -> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (u :. (->) e) := a
x') (((u :. (->) e) := a) -> e -> b)
-> ((u :. (->) e) := a) -> (u :. (->) e) := b
forall (source :: * -> * -> *) (t :: * -> *) a b.
Extendable source t =>
source (t a) b -> source (t a) (t b)
<<= (u :. (->) e) := a
x

type Traceable e t = Adaptable t (Imprint e)