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

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

import Pandora.Pattern.Category ((.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Distributive (Distributive ((>>-)))
import Pandora.Pattern.Functor.Extendable (Extendable ((=>>)))
import Pandora.Pattern.Functor.Comonad (Comonad)
import Pandora.Pattern.Object.Monoid (Monoid (zero))
import Pandora.Pattern.Object.Semigroup (Semigroup ((+)))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Schematic, Interpreted (Primary, run, unite))
import Pandora.Paradigm.Controlflow.Effect.Transformer.Comonadic (Comonadic (bring), (:<) (TC))
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
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 a b -> m a b
$ a -> b
f (a -> b) -> (e -> a) -> e -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. e -> a
x

instance Distributive (Imprint e) where
	u a
g >>- :: u a -> (a -> Imprint e b) -> (Imprint e :. u) := b
>>- a -> Imprint e b
f = (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 a b -> m a b
$ u a
g u a -> (a -> e -> b) -> e -> u b
forall (t :: * -> *) (u :: * -> *) a b.
(Distributive t, Covariant u) =>
u a -> (a -> t b) -> (t :. u) := 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 (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> a -> Imprint e b
f)

instance Monoid e => Extractable (Imprint e) where
	extract :: a <-| Imprint e
extract (Imprint e -> a
x) = e -> a
x e
forall a. Monoid a => a
zero

instance Semigroup e => Extendable (Imprint e) where
	Imprint e -> a
x =>> :: Imprint e a -> (Imprint e a -> b) -> Imprint e b
=>> Imprint e a -> b
f = (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 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 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 a b -> m a b
$ e -> a
x (e -> a) -> (e -> e) -> e -> a
forall (m :: * -> * -> *) b c a.
Category 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 Monoid e => Comonadic (Imprint e) where
	bring :: (Imprint e :< u) ~> Imprint e
bring (TC (UT x)) = (e -> a) -> Imprint e a
forall e a. (e -> a) -> Imprint e a
Imprint ((e -> a) -> Imprint e a)
-> (u (e -> a) -> e -> a) -> u (e -> a) -> Imprint e a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. u (e -> a) -> e -> a
forall (t :: * -> *) a. Extractable t => a <-| t
extract (u (e -> a) -> Imprint e a) -> u (e -> a) -> Imprint e a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ u (e -> a)
x

instance {-# OVERLAPS #-} (Semigroup e, Extendable u) => Extendable ((->) e <.:> u) where
	UT (u :. (->) e) := a
x =>> :: (<.:>) ((->) e) u a
-> ((<.:>) ((->) e) u a -> b) -> (<.:>) ((->) e) u b
=>> (<.:>) ((->) e) u a -> b
f = ((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 a b -> m a b
$ (u :. (->) e) := a
x ((u :. (->) e) := a)
-> (((u :. (->) e) := a) -> e -> b) -> (u :. (->) e) := b
forall (t :: * -> *) a b. Extendable t => t a -> (t a -> b) -> t 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.
Category 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.
Category m =>
m b c -> m a b -> m a c
. ((e -> a) -> e -> a) -> ((u :. (->) e) := a) -> (u :. (->) e) := a
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
(<$>) ((e -> a) -> (e -> e) -> e -> a
forall (m :: * -> * -> *) b c a.
Category 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 a b -> m a b
$ (u :. (->) e) := a
x')

type Traceable e t = Adaptable t (Imprint e)