Storage.hs

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

import Pandora.Core.Functor (type (:.:))
import Pandora.Core.Morphism ((.), ($), (?))
import Pandora.Paradigm.Basis.Identity (Identity)
import Pandora.Paradigm.Basis.Product (Product ((:*:)), type (:*:))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Extractable (Extractable (extract))
import Pandora.Pattern.Functor.Extendable (Extendable ((=>>)))
import Pandora.Pattern.Functor.Applicative (Applicative ((<*>)))
import Pandora.Pattern.Functor.Comonad (Comonad)

newtype Storage p t a = Storage { stored :: ((:*:) p :.: t :.: (->) p) a }

instance Covariant t => Covariant (Storage p t) where
	f <$> Storage (p :*: x) = Storage . (:*:) p $ (f .) <$> x

instance Extractable t => Extractable (Storage p t) where
	extract (Storage (p :*: x)) = extract x p

instance Extendable t => Extendable (Storage p t) where
	Storage (old :*: x) =>> f = Storage . (:*:) old . (=>>) x $
		\y -> \new -> f . Storage $ new :*: y

instance Applicative t => Applicative (Storage p t) where
	Storage (_ :*: x) <*> Storage (q :*: y) = Storage . (:*:) q $
		(\f g x' -> f x' (g x')) <$> x <*> y

instance Comonad g => Comonad (Storage p g) where

type Store p = Storage p Identity

position :: Storage p t a -> p
position (Storage (p :*: _)) = p

access :: Extractable t => p -> Storage p t a -> a
access p = extract ? p . extract . stored

retrofit :: Extractable t => (p -> p) -> Storage p t a -> Storage p t a
retrofit f (Storage (p :*: x)) = Storage $ (f p) :*: x