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

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

import Pandora.Pattern.Category ((.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Traversable (Traversable ((->>)))
import Pandora.Pattern.Functor.Extendable (Extendable ((=>>)))
import Pandora.Pattern.Functor.Comonad (Comonad)
import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:)), type (:*:), attached)
import Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable (adapt))
import Pandora.Paradigm.Controlflow.Effect.Transformer.Comonadic (Comonadic (bring), (:<) (TC))
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 :: * -> * -> *). Category m => m ~~> m
$ a -> b
f (a -> b) -> (e :*: a) -> e :*: b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> e :*: a
x

instance Extractable (Equipment e) where
	extract :: a <:= Equipment e
extract = a <:= Product e
forall (t :: * -> *) a. Extractable t => a <:= t
extract (a <:= Product e)
-> (Equipment e a -> Product e a) -> a <:= Equipment e
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Equipment e a -> Product e a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run

instance Traversable (Equipment e) where
	Equipment e :*: a
x ->> :: Equipment e a -> (a -> u b) -> (u :. Equipment e) := b
->> a -> u b
f = (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 (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> e :*: a
x (e :*: a) -> (a -> u b) -> u (e :*: b)
forall (t :: * -> *) (u :: * -> *) a b.
(Traversable t, Pointable u, Applicative u) =>
t a -> (a -> u b) -> (u :. t) := b
->> a -> u b
f

instance Extendable (Equipment e) where
	Equipment (e
e :*: a
x) =>> :: Equipment e a -> (Equipment e a -> b) -> Equipment e b
=>> Equipment e a -> b
f = (e :*: b) -> Equipment e b
forall e a. (e :*: a) -> Equipment e a
Equipment ((e :*: b) -> Equipment e b)
-> (Product e a -> e :*: b) -> Product e a -> Equipment e b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. e -> b -> e :*: b
forall s a. s -> a -> Product s a
(:*:) e
e (b -> e :*: b) -> (Product e a -> b) -> Product e a -> e :*: b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Equipment e a -> b
f (Equipment e a -> b)
-> (Product e a -> Equipment e a) -> Product e a -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Product e a -> Equipment e a
forall e a. (e :*: a) -> Equipment e a
Equipment (Product e a -> Equipment e b) -> Product e a -> Equipment e b
forall (m :: * -> * -> *). Category m => m ~~> m
$ e
e e -> a -> Product e a
forall s a. s -> a -> Product 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)

instance Comonadic (Equipment e) where
	bring :: (Equipment e :< u) ~> Equipment e
bring (TC (TU x)) = (e :*: a) -> Equipment e a
forall e a. (e :*: a) -> Equipment e a
Equipment ((e :*: a) -> Equipment e a) -> (e :*: a) -> Equipment e a
forall (m :: * -> * -> *). Category m => m ~~> m
$ a <:= u
forall (t :: * -> *) a. Extractable t => a <:= t
extract (a <:= u) -> (e :*: u a) -> e :*: a
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> e :*: u a
x

type Equipped e t = Adaptable t (Equipment e)

instance {-# OVERLAPS #-} Extendable u => Extendable ((:*:) e <:.> u) where
	TU (e
e :*: u a
x) =>> :: (<:.>) ((:*:) e) u a
-> ((<:.>) ((:*:) e) u a -> b) -> (<:.>) ((:*:) e) u b
=>> (<:.>) ((:*:) e) u a -> b
f = (((:*:) 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.
Category m =>
m b c -> m a b -> m a c
. e -> u b -> ((:*:) e :. u) := b
forall s a. s -> a -> Product s a
(:*:) e
e (u b -> (<:.>) ((:*:) e) u b) -> u b -> (<:.>) ((:*:) e) u b
forall (m :: * -> * -> *). Category m => m ~~> m
$ u a
x u a -> (u a -> b) -> u b
forall (t :: * -> *) a b. Extendable t => t a -> (t a -> b) -> t b
=>> (<:.>) ((:*:) e) u a -> b
f ((<:.>) ((:*:) e) u a -> b)
-> (u a -> (<:.>) ((:*:) e) u a) -> u a -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Product 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 (Product e (u a) -> (<:.>) ((:*:) e) u a)
-> (u a -> Product e (u a)) -> u a -> (<:.>) ((:*:) e) u a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. e -> u a -> Product e (u a)
forall s a. s -> a -> Product s a
(:*:) e
e

instance Comonad (Equipment e) where

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.
Category 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.
Category 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