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

module Pandora.Paradigm.Inventory.Accumulator (Accumulator (..), Accumulated, gather) where

import Pandora.Pattern.Category ((.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>), (<$$>)))
import Pandora.Pattern.Functor.Pointable (Pointable (point))
import Pandora.Pattern.Functor.Applicative (Applicative ((<*>)))
import Pandora.Pattern.Functor.Bindable (Bindable ((>>=)))
import Pandora.Pattern.Functor.Monad (Monad)
import Pandora.Pattern.Object.Monoid (Monoid (zero))
import Pandora.Pattern.Object.Semigroup (Semigroup ((+)))
import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:)), type (:*:))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Schematic, Interpreted (Primary, run))
import Pandora.Paradigm.Controlflow.Effect.Transformer.Monadic (Monadic (wrap), (:>) (TM))
import Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable (adapt))
import Pandora.Paradigm.Schemes.UT (UT (UT), type (<.:>))

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

instance Covariant (Accumulator e) where
	a -> b
f <$> :: (a -> b) -> Accumulator e a -> Accumulator e b
<$> Accumulator e :*: a
x = (e :*: b) -> Accumulator e b
forall e a. (e :*: a) -> Accumulator e a
Accumulator ((e :*: b) -> Accumulator e b) -> (e :*: b) -> Accumulator e b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ 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 Semigroup e => Applicative (Accumulator e) where
	Accumulator e (a -> b)
f <*> :: Accumulator e (a -> b) -> Accumulator e a -> Accumulator e b
<*> Accumulator e a
v = (e :*: b) -> Accumulator e b
forall e a. (e :*: a) -> Accumulator e a
Accumulator ((e :*: b) -> Accumulator e b) -> (e :*: b) -> Accumulator e b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Product e (a -> b) -> Product e a -> e :*: b
forall s t a.
Semigroup s =>
Product s (t -> a) -> Product s t -> Product s a
k (Accumulator e (a -> b) -> Primary (Accumulator e) (a -> b)
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Accumulator e (a -> b)
f) (Accumulator e a -> Primary (Accumulator e) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Accumulator e a
v) where
		k :: Product s (t -> a) -> Product s t -> Product s a
k ~(s
e :*: t -> a
g) ~(s
e' :*: t
w) = s
e s -> s -> s
forall a. Semigroup a => a -> a -> a
+ s
e' s -> a -> Product s a
forall s a. s -> a -> Product s a
:*: t -> a
g t
w

instance Monoid e => Pointable (Accumulator e) where
	point :: a |-> Accumulator e
point = (e :*: a) -> Accumulator e a
forall e a. (e :*: a) -> Accumulator e a
Accumulator ((e :*: a) -> Accumulator e a)
-> (a -> e :*: a) -> a |-> Accumulator e
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (e
forall a. Monoid a => a
zero e -> a -> e :*: a
forall s a. s -> a -> Product s a
:*:)

instance Semigroup e => Bindable (Accumulator e) where
	Accumulator (e
e :*: a
x) >>= :: Accumulator e a -> (a -> Accumulator e b) -> Accumulator e b
>>= a -> Accumulator e b
f = let (e
e' :*: b
b) = Accumulator e b -> Product e b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (Accumulator e b -> Product e b) -> Accumulator e b -> Product e b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ a -> Accumulator e b
f a
x in
		Product e b -> Accumulator e b
forall e a. (e :*: a) -> Accumulator e a
Accumulator (Product e b -> Accumulator e b) -> Product e b -> Accumulator e b
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
+ e
e'e -> b -> Product e b
forall s a. s -> a -> Product s a
:*: b
b

type instance Schematic Monad (Accumulator e) = (<.:>) ((:*:) e)

instance Interpreted (Accumulator e) where
	type Primary (Accumulator e) a = e :*: a
	run :: Accumulator e a -> Primary (Accumulator e) a
run ~(Accumulator e :*: a
x) = Primary (Accumulator e) a
e :*: a
x

instance Monoid e => Monadic (Accumulator e) where
	wrap :: Accumulator e ~> (Accumulator e :> u)
wrap = (<.:>) ((:*:) e) u a -> (:>) (Accumulator e) u a
forall (t :: * -> *) (u :: * -> *) a.
Schematic Monad t u a -> (:>) t u a
TM ((<.:>) ((:*:) e) u a -> (:>) (Accumulator e) u a)
-> (Accumulator e a -> (<.:>) ((:*:) e) u a)
-> Accumulator e a
-> (:>) (Accumulator e) u a
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)
-> (Accumulator e a -> (u :. (:*:) e) := a)
-> Accumulator e a
-> (<.:>) ((:*:) e) u a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Product e a |-> u
forall (t :: * -> *) a. Pointable t => a |-> t
point (Product e a |-> u)
-> (Accumulator e a -> Product e a)
-> Accumulator e a
-> (u :. (:*:) e) := a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Accumulator e a -> Product e a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run

type Accumulated e t = Adaptable (Accumulator e) t

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

instance (Semigroup e, Applicative u) => Applicative ((:*:) e <.:> u) where
	UT (u :. (:*:) e) := (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 a b -> m a b
$ Product e (a -> b) -> Product e a -> Product e b
forall s t a.
Semigroup s =>
Product s (t -> a) -> Product s t -> Product s a
k (Product e (a -> b) -> Product e a -> Product e b)
-> ((u :. (:*:) e) := (a -> b)) -> u (Product e a -> Product e b)
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> (u :. (:*:) e) := (a -> b)
f u (Product e a -> Product e b)
-> ((u :. (:*:) e) := a) -> (u :. (:*:) e) := b
forall (t :: * -> *) a b. Applicative t => t (a -> b) -> t a -> t b
<*> (u :. (:*:) e) := a
x where
		k :: Product s (t -> a) -> Product s t -> Product s a
k ~(s
u :*: t -> a
g) ~(s
v :*: t
y) = s
u s -> s -> s
forall a. Semigroup a => a -> a -> a
+ s
v s -> a -> Product s a
forall s a. s -> a -> Product s a
:*: t -> a
g t
y

instance (Pointable u, Monoid e) => Pointable ((:*:) e <.:> u) where
	point :: a |-> ((:*:) e <.:> u)
point = ((u :. (:*:) e) := a) -> UT Covariant Covariant ((:*:) 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) -> UT Covariant Covariant ((:*:) e) u a)
-> (a -> (u :. (:*:) e) := a) -> a |-> ((:*:) e <.:> u)
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Product e a |-> u
forall (t :: * -> *) a. Pointable t => a |-> t
point (Product e a |-> u)
-> (a -> Product e a) -> a -> (u :. (:*:) e) := a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (e
forall a. Monoid a => a
zero e -> a -> Product e a
forall s a. s -> a -> Product s a
:*:)

instance (Semigroup e, Pointable u, Bindable u) => Bindable ((:*:) e <.:> u) where
	UT (u :. (:*:) e) := a
x >>= :: (<.:>) ((:*:) e) u a
-> (a -> (<.:>) ((:*:) e) u b) -> (<.:>) ((:*:) e) u b
>>= a -> (<.:>) ((:*:) e) u 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)
-> ((e :*: a) -> (u :. (:*:) e) := b) -> (u :. (:*:) e) := b
forall (t :: * -> *) a b. Bindable t => t a -> (a -> t b) -> t b
>>= \(e
acc :*: a
v) -> (\(e
acc' :*: b
y) -> (e
acc e -> e -> e
forall a. Semigroup a => a -> a -> a
+ e
acc' e -> b -> Product e b
forall s a. s -> a -> Product s a
:*: b
y)) (Product e b -> Product e b)
-> ((u :. (:*:) e) := b) -> (u :. (:*:) e) := b
forall (t :: * -> *) a b. Covariant t => (a -> b) -> t a -> t b
<$> (<.:>) ((:*:) e) u b -> Primary ((:*:) e <.:> u) b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (a -> (<.:>) ((:*:) e) u b
f a
v)

gather :: Accumulated e t => e -> t ()
gather :: e -> t ()
gather e
x = Accumulator e () -> t ()
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt (Accumulator e () -> t ())
-> ((e :*: ()) -> Accumulator e ()) -> (e :*: ()) -> t ()
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (e :*: ()) -> Accumulator e ()
forall e a. (e :*: a) -> Accumulator e a
Accumulator ((e :*: ()) -> t ()) -> (e :*: ()) -> t ()
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ e
x e -> () -> e :*: ()
forall s a. s -> a -> Product s a
:*: ()