Store.hs

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

module Pandora.Paradigm.Inventory.Store (Store (..), Storable, position, access, retrofit) where

import Pandora.Core.Functor (type (:.), type (:=), type (<-|), type (~>))
import Pandora.Core.Morphism ((%))
import Pandora.Pattern.Category (identity, (.), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>), (<$$>), (<$$$>)), (.|..))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Extendable (Extendable ((=>>), (<<=$)))
import Pandora.Pattern.Functor.Comonad (Comonad)
import Pandora.Pattern.Functor.Adjoint ((-|), (|-))
import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:)), type (:*:), attached)
import Pandora.Paradigm.Controlflow.Effect.Adaptable (Adaptable (adapt))
import Pandora.Paradigm.Controlflow.Effect.Interpreted (Interpreted (Primary, run))
import Pandora.Paradigm.Controlflow.Effect.Schematic (Schematic)
import Pandora.Paradigm.Schemes.TUT (TUT (TUT), type (<:<.>:>))
import Pandora.Paradigm.Controlflow.Effect.Transformer.Comonadic (Comonadic (flick, bring), (:<) (TC))

newtype Store p a = Store ((:*:) p :. (->) p := a)

instance Covariant (Store p) where
	f <$> Store x = Store $ f <$$> x

instance Extractable (Store p) where
	extract = (|- ($)) . run

instance Extendable (Store p) where
	Store x =>> f = Store $ f <$$> (Store .|.. (-| identity)) <$> x

instance Comonad (Store p) where

instance Interpreted (Store p) where
	type Primary (Store p) a = (:*:) p :. (->) p := a
	run (Store x) = x

type instance Schematic Comonad (Store p) u = (:*:) p <:<.>:> (->) p := u

instance Comonadic (Store p) where
	flick (TC (TUT (p :*: f))) = ($ p) <$> f
	bring (TC (TUT (p :*: f))) = Store $ p :*: extract f

type Storable s x = Adaptable x (Store s)

instance Covariant u => Covariant ((:*:) p <:<.>:> (->) p := u) where
	f <$> TUT x = TUT $ f <$$$> x

instance Extractable u => Extractable ((:*:) p <:<.>:> (->) p := u) where
	extract = (|- extract) . run

instance Extendable u => Extendable ((:*:) p <:<.>:> (->) p := u) where
	TUT x =>> f = TUT $ x <<=$ (\x' -> f . TUT . (x' -| identity))

position :: Storable s t => t a -> s
position = attached . run @(Store _) . adapt

access :: Storable s t => s -> a <-| t
access p = extract % p . run @(Store _) . adapt

retrofit :: (p -> p) -> Store p ~> Store p
retrofit g (Store (p :*: f)) = Store $ g p :*: f