{-# OPTIONS_GHC -fno-warn-orphans #-}
module Pandora.Paradigm.Inventory.Some.Imprint (Imprint (..), Traceable) where

import Pandora.Core.Interpreted (Interpreted (Primary, run, unite))
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.Object.Semigroup (Semigroup ((+)))
import Pandora.Paradigm.Algebraic ()
import Pandora.Pattern.Morphism.Flip (Flip (Flip))
import Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable)
import Pandora.Paradigm.Schemes (Schematic, 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)
<--- (forall (t :: * -> *) a.
Interpreted (->) t =>
((->) < t a) < Primary t a
forall (m :: * -> * -> *) (t :: * -> *) a.
Interpreted m t =>
(m < 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 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) -> ((e -> a) -> Imprint e a) -> (e -> a) -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (e -> a) -> Imprint e a
forall e a. (e -> a) -> Imprint e a
Imprint ((e -> a) -> b) -> (e -> a) -> b
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)