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

module Pandora.Paradigm.Inventory.Optics where

import Pandora.Core.Functor (type (|->))
import Pandora.Pattern.Category ((.), ($))
import Pandora.Pattern.Functor.Covariant ((<$))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Representable (Representable (Representation, (<#>), tabulate))
import Pandora.Pattern.Object.Setoid (Setoid ((==)))
import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:)))
import Pandora.Paradigm.Primary.Object.Boolean ((?))
import Pandora.Paradigm.Inventory.Store (Store (Store), access, position, retrofit)

infixr 0 :-.
type (:-.) src tgt = Lens src tgt

type Lens src tgt = src |-> Store tgt

-- | Lens composition infix operator
(|>) :: Lens src old -> Lens old new -> Lens src new
Lens src old
from |> :: Lens src old -> Lens old new -> Lens src new
|> Lens old new
to = \src
x -> (src -> Store new old -> Store new src
forall (t :: * -> *) a b. Covariant t => a -> t b -> t a
(<$) src
x (Store new old -> Store new src)
-> Lens old new -> old -> Store new src
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Lens old new
to) (old -> Store new src) -> (src -> old) -> Lens src new
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Store old src -> old
forall s (t :: * -> *) a. Storable s t => t a -> s
position (Store old src -> old) -> Lens src old -> src -> old
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Lens src old
from Lens src new -> Lens src new
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ src
x

-- | Get the target of a lens
view :: Lens src tgt -> src -> tgt
view :: Lens src tgt -> src -> tgt
view Lens src tgt
lens = Store tgt src -> tgt
forall s (t :: * -> *) a. Storable s t => t a -> s
position (Store tgt src -> tgt) -> Lens src tgt -> src -> tgt
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Lens src tgt
lens

-- | Infix version of `view`
(^.) :: Lens src tgt -> src -> tgt
^. :: Lens src tgt -> src -> tgt
(^.) = Lens src tgt -> src -> tgt
forall src tgt. Lens src tgt -> src -> tgt
view

-- | Replace the target of a lens
set :: Lens src tgt -> tgt -> src -> src
set :: Lens src tgt -> tgt -> src -> src
set Lens src tgt
lens tgt
new = tgt -> src <-| Store tgt
forall s (t :: * -> *) a. Storable s t => s -> a <-| t
access tgt
new (src <-| Store tgt) -> Lens src tgt -> src -> src
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Lens src tgt
lens

-- | Infix version of `set`
(.~) :: Lens src tgt -> tgt -> src -> src
Lens src tgt
lens .~ :: Lens src tgt -> tgt -> src -> src
.~ tgt
new = Lens src tgt -> tgt -> src -> src
forall src tgt. Lens src tgt -> tgt -> src -> src
set Lens src tgt
lens tgt
new

-- | Modify the target of a lens
over :: Lens src tgt -> (tgt -> tgt) -> src -> src
over :: Lens src tgt -> (tgt -> tgt) -> src -> src
over Lens src tgt
lens tgt -> tgt
f = src <-| Store tgt
forall (t :: * -> *) a. Extractable t => a <-| t
extract (src <-| Store tgt) -> Lens src tgt -> src -> src
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. (tgt -> tgt) -> Store tgt ~> Store tgt
forall p. (p -> p) -> Store p ~> Store p
retrofit tgt -> tgt
f (Store tgt src -> Store tgt src) -> Lens src tgt -> Lens src tgt
forall (m :: * -> * -> *) b c a.
Category m =>
m b c -> m a b -> m a c
. Lens src tgt
lens

-- | Infix version of `over`
(%~) :: Lens src tgt -> (tgt -> tgt) -> src -> src
Lens src tgt
lens %~ :: Lens src tgt -> (tgt -> tgt) -> src -> src
%~ tgt -> tgt
f = Lens src tgt -> (tgt -> tgt) -> src -> src
forall src tgt. Lens src tgt -> (tgt -> tgt) -> src -> src
over Lens src tgt
lens tgt -> tgt
f

represent :: (Representable t, Setoid (Representation t)) => Representation t -> t a :-. a
represent :: Representation t -> t a :-. a
represent Representation t
r t a
x = (((:*:) a :. (->) a) := t a) -> Store a (t a)
forall p a. (((:*:) p :. (->) p) := a) -> Store p a
Store ((((:*:) a :. (->) a) := t a) -> Store a (t a))
-> (((:*:) a :. (->) a) := t a) -> Store a (t a)
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ (Representation t
r Representation t -> a <-| t
forall (t :: * -> *) a.
Representable t =>
Representation t -> a <-| t
<#> t a
x) a -> (a -> t a) -> ((:*:) a :. (->) a) := t a
forall s a. s -> a -> Product s a
:*: \a
new -> (Representation t -> a) -> t a
forall (t :: * -> *) a.
Representable t =>
(Representation t -> a) -> t a
tabulate (\Representation t
r' -> Representation t
r' Representation t -> Representation t -> Boolean
forall a. Setoid a => a -> a -> Boolean
== Representation t
r Boolean -> a -> a -> a
forall a. Boolean -> a -> a -> a
? a
new (a -> a) -> a -> a
forall (m :: * -> * -> *) a b. Category m => m a b -> m a b
$ Representation t
r' Representation t -> a <-| t
forall (t :: * -> *) a.
Representable t =>
Representation t -> a <-| t
<#> t a
x)