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

module Pandora.Paradigm.Inventory (module Exports, zoom, magnify, (=<>), (~<>), adjust) where

import Pandora.Paradigm.Inventory.Optics as Exports
import Pandora.Paradigm.Inventory.Store as Exports
import Pandora.Paradigm.Inventory.State as Exports
import Pandora.Paradigm.Inventory.Imprint as Exports
import Pandora.Paradigm.Inventory.Equipment as Exports
import Pandora.Paradigm.Inventory.Environment as Exports
import Pandora.Paradigm.Inventory.Accumulator as Exports

import Pandora.Core.Functor (type (~>))
import Pandora.Pattern.Category ((.), ($), (#), identity)
import Pandora.Pattern.Functor.Covariant (Covariant)
import Pandora.Pattern.Functor.Adjoint (Adjoint ((-|), (|-)))
import Pandora.Pattern.Functor.Extractable (extract)
import Pandora.Pattern.Functor.Bivariant ((<->))
import Pandora.Paradigm.Primary.Functor.Function ((!.), (%))
import Pandora.Paradigm.Primary.Functor.Identity (Identity (Identity))
import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:)))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (run)
import Pandora.Paradigm.Controlflow.Effect.Adaptable (adapt)
import Pandora.Paradigm.Structure.Ability.Accessible (Accessible (access))

instance Adjoint (Store s) (State s) where
	(-|) :: a -> (Store s a -> b) -> State s b
	a
x -| :: a -> (Store s a -> b) -> State s b
-| Store s a -> b
f = (((->) s :. (:*:) s) := b) -> State s b
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((((->) s :. (:*:) s) := b) -> State s b)
-> (((->) s :. (:*:) s) := b) -> State s b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ \s
s -> s -> b -> Product s b
forall s a. s -> a -> Product s a
(:*:) s
s (b -> Product s b)
-> (Product s (s -> a) -> b) -> Product s (s -> a) -> Product s b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Store s a -> b
f (Store s a -> b)
-> (Product s (s -> a) -> Store s a) -> Product s (s -> a) -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Product s (s -> a) -> Store s a
forall s a. (((:*:) s :. (->) s) := a) -> Store s a
Store (Product s (s -> a) -> Product s b)
-> Product s (s -> a) -> Product s b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ s
s s -> (s -> a) -> Product s (s -> a)
forall s a. s -> a -> Product s a
:*: (a
x a -> s -> a
forall a b. a -> b -> a
!.)
	(|-) :: Store s a -> (a -> State s b) -> b
	Store (s
s :*: s -> a
f) |- :: Store s a -> (a -> State s b) -> b
|- a -> State s b
g = Product s b -> b
forall (t :: * -> *) (source :: * -> * -> *) a.
Extractable t source =>
source (t a) a
extract (Product s b -> b) -> (a -> Product s b) -> a -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (State s b -> ((->) s :. (:*:) s) := b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (State s b -> ((->) s :. (:*:) s) := b)
-> s -> State s b -> Product s b
forall a b c. (a -> b -> c) -> b -> a -> c
% s
s) (State s b -> Product s b) -> (a -> State s b) -> a -> Product s b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> State s b
g (a -> b) -> a -> b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ s -> a
f s
s

instance Adjoint (Accumulator e) (Imprint e) where
	a
x -| :: a -> (Accumulator e a -> b) -> Imprint e b
-| Accumulator 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 (m a b) (m a b)
$ a
x a -> (Product e a -> b) -> e -> b
forall (t :: * -> *) (u :: * -> *) a b.
Adjoint t u =>
a -> (t a -> b) -> u b
-| Accumulator e a -> b
f (Accumulator e a -> b)
-> (Product e a -> Accumulator 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 -> Accumulator e a
forall e a. (e :*: a) -> Accumulator e a
Accumulator
	Accumulator e a
x |- :: Accumulator e a -> (a -> Imprint e b) -> b
|- a -> Imprint e b
g = Accumulator e a -> Primary (Accumulator e) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Accumulator e a
x (e :*: a) -> (a -> e -> b) -> b
forall (t :: * -> *) (u :: * -> *) a b.
Adjoint t u =>
t a -> (a -> u b) -> 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 (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> Imprint e b
g

instance Adjoint (Equipment e) (Environment e) where
	a
x -| :: a -> (Equipment e a -> b) -> Environment e b
-| Equipment e a -> b
f = (e -> b) -> Environment e b
forall e a. (e -> a) -> Environment e a
Environment ((e -> b) -> Environment e b) -> (e -> b) -> Environment e b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ a
x a -> (Product e a -> b) -> e -> b
forall (t :: * -> *) (u :: * -> *) a b.
Adjoint t u =>
a -> (t a -> b) -> u b
-| 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
	Equipment e a
x |- :: Equipment e a -> (a -> Environment e b) -> b
|- a -> Environment e b
g = Equipment e a -> Primary (Equipment e) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Equipment e a
x (e :*: a) -> (a -> e -> b) -> b
forall (t :: * -> *) (u :: * -> *) a b.
Adjoint t u =>
t a -> (a -> u b) -> b
|- Environment e b -> e -> b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (Environment e b -> e -> b)
-> (a -> Environment e b) -> a -> e -> b
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. a -> Environment e b
g

zoom :: Stateful bg t => Lens Identity bg ls -> State ls ~> t
zoom :: Lens Identity bg ls -> State ls ~> t
zoom Lens Identity bg ls
lens State ls a
less = let restruct :: (Identity ls -> bg) -> Identity ls -> Product bg a
restruct Identity ls -> bg
to = (Identity ls -> bg
to (Identity ls -> bg) -> (ls -> Identity ls) -> ls -> bg
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. ls -> Identity ls
forall a. a -> Identity a
Identity (ls -> bg) -> (a -> a) -> Product ls a -> Product bg a
forall (v :: * -> * -> *) a b c d.
(Bivariant v, forall i. Covariant (v i)) =>
(a -> b) -> (c -> d) -> v a c -> v b d
<-> a -> a
forall (m :: * -> * -> *) a. Category m => m a a
identity) (Product ls a -> Product bg a)
-> (Identity ls -> Product ls a) -> Identity ls -> Product bg a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. State ls a -> Primary (State ls) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run State ls a
less (((->) ls :. (:*:) ls) := a)
-> (Identity ls -> ls) -> Identity ls -> Product ls a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. forall (t :: * -> *) (source :: * -> * -> *) a.
Extractable t source =>
source (t a) a
forall (source :: * -> * -> *) a.
Extractable Identity source =>
source (Identity a) a
extract @Identity
	in State bg a -> t a
forall k (t :: k -> *) (u :: k -> *). Adaptable t u => t ~> u
adapt (State bg a -> t a)
-> ((bg -> Product bg a) -> State bg a)
-> (bg -> Product bg a)
-> t a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (bg -> Product bg a) -> State bg a
forall s a. (((->) s :. (:*:) s) := a) -> State s a
State ((bg -> Product bg a) -> t a) -> (bg -> Product bg a) -> t a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ (Product (Identity ls) (Identity ls -> bg)
-> ((Identity ls -> bg) -> Identity ls -> Product bg a)
-> Product bg a
forall (t :: * -> *) (u :: * -> *) a b.
Adjoint t u =>
t a -> (a -> u b) -> b
|- (Identity ls -> bg) -> Identity ls -> Product bg a
restruct) (Product (Identity ls) (Identity ls -> bg) -> Product bg a)
-> (bg -> Product (Identity ls) (Identity ls -> bg))
-> bg
-> Product bg a
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Store (Identity ls) bg -> Product (Identity ls) (Identity ls -> bg)
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (Store (Identity ls) bg
 -> Product (Identity ls) (Identity ls -> bg))
-> (bg -> Store (Identity ls) bg)
-> bg
-> Product (Identity ls) (Identity ls -> bg)
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Lens Identity bg ls -> Primary (P_Q_T (->) Store Identity bg) ls
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Lens Identity bg ls
lens

(=<>) :: Stateful src t => Lens mode src tgt -> mode tgt -> t src
Lens mode src tgt
lens =<> :: Lens mode src tgt -> mode tgt -> t src
=<> mode tgt
new = (src -> src) -> t src
forall s (t :: * -> *). Stateful s t => (s -> s) -> t s
modify ((src -> src) -> t src) -> (src -> src) -> t src
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ Lens mode src tgt -> mode tgt -> src -> src
forall (available :: * -> *) source target.
Lens available source target
-> available target -> source -> source
set Lens mode src tgt
lens mode tgt
new

(~<>) :: Covariant mode => Stateful src t => Lens mode src tgt -> (mode tgt -> mode tgt) -> t src
Lens mode src tgt
lens ~<> :: Lens mode src tgt -> (mode tgt -> mode tgt) -> t src
~<> mode tgt -> mode tgt
f = (src -> src) -> t src
forall s (t :: * -> *). Stateful s t => (s -> s) -> t s
modify ((src -> src) -> t src) -> (src -> src) -> t src
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ Lens mode src tgt -> (mode tgt -> mode tgt) -> src -> src
forall (available :: * -> *) source target.
Covariant available =>
Lens available source target
-> (available target -> available target) -> source -> source
over Lens mode src tgt
lens mode tgt -> mode tgt
f

magnify :: forall bg ls t . (Accessible ls bg, Stateful bg t) => t ls
magnify :: t ls
magnify = forall bg (t :: * -> *) ls.
Stateful bg t =>
Lens Identity bg ls -> State ls ~> t
forall (t :: * -> *) ls.
Stateful bg t =>
Lens Identity bg ls -> State ls ~> t
zoom @bg (Lens Identity bg ls -> State ls ls -> t ls)
-> Lens Identity bg ls -> State ls ls -> t ls
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# Accessible ls bg => Lens Identity bg ls
forall target source.
Accessible target source =>
Lens Identity source target
access @ls @bg (State ls ls -> t ls) -> State ls ls -> t ls
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# State ls ls
forall s (t :: * -> *). Stateful s t => t s
current

adjust :: forall bg ls t . (Accessible ls bg, Stateful bg t) => (ls -> ls) -> t ls
adjust :: (ls -> ls) -> t ls
adjust = Lens Identity bg ls -> State ls ~> t
forall bg (t :: * -> *) ls.
Stateful bg t =>
Lens Identity bg ls -> State ls ~> t
zoom @bg (Accessible ls bg => Lens Identity bg ls
forall target source.
Accessible target source =>
Lens Identity source target
access @ls @bg) (State ls ls -> t ls)
-> ((ls -> ls) -> State ls ls) -> (ls -> ls) -> t ls
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (ls -> ls) -> State ls ls
forall s (t :: * -> *). Stateful s t => (s -> s) -> t s
modify