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

module Pandora.Paradigm.Inventory.Equipment (Equipment (..), retrieve) where

import Pandora.Pattern.Semigroupoid ((.))
import Pandora.Pattern.Category (($))
import Pandora.Pattern.Functor.Covariant (Covariant ((-<$>-)))
import Pandora.Pattern.Functor.Traversable (Traversable ((<<-)))
import Pandora.Pattern.Functor.Extendable (Extendable ((<<=)))
import Pandora.Pattern.Functor.Comonad (Comonad)
import Pandora.Paradigm.Primary.Algebraic ()
import Pandora.Paradigm.Primary.Algebraic.Product ((:*:) ((:*:)), attached)
import Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable (adapt))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Schematic, Interpreted (Primary, run, unite))
import Pandora.Paradigm.Schemes.TU (TU (TU), type (<:.>))

newtype Equipment e a = Equipment (e :*: a)

instance Covariant (->) (->) (Equipment e) where
	a -> b
f -<$>- :: (a -> b) -> Equipment e a -> Equipment e b
-<$>- Equipment e :*: a
x = (e :*: b) -> Equipment e b
forall e a. (e :*: a) -> Equipment e a
Equipment ((e :*: b) -> Equipment e b) -> (e :*: b) -> Equipment 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 (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
-<$>- e :*: a
x

instance Traversable (->) (->) (Equipment e) where
	a -> u b
f <<- :: (a -> u b) -> Equipment e a -> u (Equipment e b)
<<- Equipment e :*: a
x = (e :*: b) -> Equipment e b
forall e a. (e :*: a) -> Equipment e a
Equipment ((e :*: b) -> Equipment e b) -> u (e :*: b) -> u (Equipment e b)
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) a b.
Covariant source target t =>
source a b -> target (t a) (t b)
-<$>- a -> u b
f (a -> u b) -> (e :*: a) -> u (e :*: b)
forall (source :: * -> * -> *) (target :: * -> * -> *)
       (t :: * -> *) (u :: * -> *) a b.
(Traversable source target t, Covariant source target u,
 Monoidal source target (:*:) (:*:) u) =>
source a (u b) -> target (t a) (u (t b))
<<- e :*: a
x

instance Extendable (->) (Equipment e) where
	Equipment e a -> b
f <<= :: (Equipment e a -> b) -> Equipment e a -> Equipment e b
<<= Equipment (e
e :*: a
x) = (e :*: b) -> Equipment e b
forall e a. (e :*: a) -> Equipment e a
Equipment ((e :*: b) -> Equipment e b)
-> ((e :*: a) -> e :*: b) -> (e :*: a) -> Equipment e b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. e -> b -> e :*: b
forall s a. s -> a -> s :*: a
(:*:) e
e (b -> e :*: b) -> ((e :*: a) -> b) -> (e :*: a) -> e :*: b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. Equipment e a -> b
f (Equipment e a -> b)
-> ((e :*: a) -> Equipment e a) -> (e :*: a) -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (e :*: a) -> Equipment e a
forall e a. (e :*: a) -> Equipment e a
Equipment ((e :*: a) -> Equipment e b) -> (e :*: a) -> Equipment e b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ e
e e -> a -> e :*: a
forall s a. s -> a -> s :*: a
:*: a
x

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

type instance Schematic Comonad (Equipment e) = (<:.>) ((:*:) e)

type Equipped e t = Adaptable t (Equipment e)

instance {-# OVERLAPS #-} Extendable (->) u => Extendable (->) ((:*:) e <:.> u) where
	(<:.>) ((:*:) e) u a -> b
f <<= :: ((<:.>) ((:*:) e) u a -> b)
-> (<:.>) ((:*:) e) u a -> (<:.>) ((:*:) e) u b
<<= TU (e
e :*: u a
x) = (((:*:) e :. u) := b) -> (<:.>) ((:*:) e) u b
forall k k k k (ct :: k) (cu :: k) (t :: k -> *) (u :: k -> k)
       (a :: k).
((t :. u) := a) -> TU ct cu t u a
TU ((((:*:) e :. u) := b) -> (<:.>) ((:*:) e) u b)
-> (u b -> ((:*:) e :. u) := b) -> u b -> (<:.>) ((:*:) e) u b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. e -> u b -> ((:*:) e :. u) := b
forall s a. s -> a -> s :*: a
(:*:) e
e (u b -> (<:.>) ((:*:) e) u b) -> u b -> (<:.>) ((:*:) e) u b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (<:.>) ((:*:) e) u a -> b
f ((<:.>) ((:*:) e) u a -> b)
-> (u a -> (<:.>) ((:*:) e) u a) -> u a -> b
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. (e :*: u a) -> (<:.>) ((:*:) e) u a
forall k k k k (ct :: k) (cu :: k) (t :: k -> *) (u :: k -> k)
       (a :: k).
((t :. u) := a) -> TU ct cu t u a
TU ((e :*: u a) -> (<:.>) ((:*:) e) u a)
-> (u a -> e :*: u a) -> u a -> (<:.>) ((:*:) e) u a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. e -> u a -> e :*: u a
forall s a. s -> a -> s :*: a
(:*:) e
e (u a -> b) -> u a -> u b
forall (source :: * -> * -> *) (t :: * -> *) a b.
Extendable source t =>
source (t a) b -> source (t a) (t b)
<<= u a
x

retrieve :: Equipped e t => t a -> e
retrieve :: t a -> e
retrieve = (e :*: a) -> e
forall a b. (a :*: b) -> a
attached ((e :*: a) -> e) -> (t a -> e :*: a) -> t a -> e
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. forall a.
Interpreted (Equipment e) =>
Equipment e a -> Primary (Equipment e) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run @(Equipment _) (Equipment e a -> e :*: a)
-> (t a -> Equipment e a) -> t a -> e :*: a
forall (m :: * -> * -> *) b c a.
Semigroupoid m =>
m b c -> m a b -> m a c
. t a -> Equipment e a
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt