{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
----------------------------------------------------------------------
-- |
-- Module      :  Control.Comonad.Representable.Store
-- Copyright   :  (c) Edward Kmett & Sjoerd Visscher 2011
-- License     :  BSD3
--
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
--
-- This is a generalized 'Store' 'Comonad', parameterized by a 'Representable' 'Functor'.
-- The representation of that 'Functor' serves as the index of the store.
--
-- This can be useful if the representable functor serves to memoize its
-- contents and will be inspected often.
----------------------------------------------------------------------
module Control.Comonad.Representable.Store
   ( Store
   , store
   , runStore
   , StoreT(..)
   , storeT
   , runStoreT
   , ComonadStore(..)
   ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Comonad
import Control.Comonad.Cofree.Class
import Control.Comonad.Env.Class
import Control.Comonad.Hoist.Class
import Control.Comonad.Store.Class
import Control.Comonad.Traced.Class
import Control.Comonad.Trans.Class
import Control.Monad.Identity
import Data.Functor.Apply
import Data.Functor.Extend
import Data.Functor.Rep
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif

-- | A memoized store comonad parameterized by a representable functor @g@, where
-- the representatation of @g@, @Rep g@ is the index of the store.
--
type Store g = StoreT g Identity

-- | Construct a store comonad computation from a function and a current index.
-- (The inverse of 'runStore'.)
store :: Representable g
      => (Rep g -> a)  -- ^ computation
      -> Rep g         -- ^ index
      -> Store g a
store :: (Rep g -> a) -> Rep g -> Store g a
store = Identity (Rep g -> a) -> Rep g -> Store g a
forall (w :: * -> *) (g :: * -> *) a.
(Functor w, Representable g) =>
w (Rep g -> a) -> Rep g -> StoreT g w a
storeT (Identity (Rep g -> a) -> Rep g -> Store g a)
-> ((Rep g -> a) -> Identity (Rep g -> a))
-> (Rep g -> a)
-> Rep g
-> Store g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep g -> a) -> Identity (Rep g -> a)
forall a. a -> Identity a
Identity

-- | Unwrap a store comonad computation as a function and a current index.
-- (The inverse of 'store'.)
runStore :: Representable g
         => Store g a           -- ^ a store to access
         -> (Rep g -> a, Rep g) -- ^ initial state
runStore :: Store g a -> (Rep g -> a, Rep g)
runStore (StoreT (Identity g a
ga) Rep g
k) = (g a -> Rep g -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index g a
ga, Rep g
k)

-- ---------------------------------------------------------------------------
-- | A store transformer comonad parameterized by:
--
--   * @g@ - A representable functor used to memoize results for an index @Rep g@
--
--   * @w@ - The inner comonad.
data StoreT g w a = StoreT (w (g a)) (Rep g)

storeT :: (Functor w, Representable g) => w (Rep g -> a) -> Rep g -> StoreT g w a
storeT :: w (Rep g -> a) -> Rep g -> StoreT g w a
storeT = w (g a) -> Rep g -> StoreT g w a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (w (g a) -> Rep g -> StoreT g w a)
-> (w (Rep g -> a) -> w (g a))
-> w (Rep g -> a)
-> Rep g
-> StoreT g w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Rep g -> a) -> g a) -> w (Rep g -> a) -> w (g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rep g -> a) -> g a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate

runStoreT :: (Functor w, Representable g) => StoreT g w a -> (w (Rep g -> a), Rep g)
runStoreT :: StoreT g w a -> (w (Rep g -> a), Rep g)
runStoreT (StoreT w (g a)
w Rep g
s) = (g a -> Rep g -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (g a -> Rep g -> a) -> w (g a) -> w (Rep g -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (g a)
w, Rep g
s)

instance (Comonad w, Representable g, Rep g ~ s) => ComonadStore s (StoreT g w) where
  pos :: StoreT g w a -> s
pos (StoreT w (g a)
_ Rep g
s) = s
Rep g
s
  peek :: s -> StoreT g w a -> a
peek s
s (StoreT w (g a)
w Rep g
_) = w (g a) -> g a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (g a)
w g a -> Rep g -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` s
Rep g
s
  peeks :: (s -> s) -> StoreT g w a -> a
peeks s -> s
f (StoreT w (g a)
w Rep g
s) = w (g a) -> g a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (g a)
w g a -> Rep g -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` s -> s
f s
Rep g
s
  seek :: s -> StoreT g w a -> StoreT g w a
seek s
s (StoreT w (g a)
w Rep g
_) = w (g a) -> Rep g -> StoreT g w a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT w (g a)
w s
Rep g
s
  seeks :: (s -> s) -> StoreT g w a -> StoreT g w a
seeks s -> s
f (StoreT w (g a)
w Rep g
s) = w (g a) -> Rep g -> StoreT g w a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT w (g a)
w (s -> s
f s
Rep g
s)

instance (Functor w, Functor g) => Functor (StoreT g w) where
  fmap :: (a -> b) -> StoreT g w a -> StoreT g w b
fmap a -> b
f (StoreT w (g a)
w Rep g
s) = w (g b) -> Rep g -> StoreT g w b
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT ((g a -> g b) -> w (g a) -> w (g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) w (g a)
w) Rep g
s

instance (Apply w, Semigroup (Rep g), Representable g) => Apply (StoreT g w) where
  StoreT w (g (a -> b))
ff Rep g
m <.> :: StoreT g w (a -> b) -> StoreT g w a -> StoreT g w b
<.> StoreT w (g a)
fa Rep g
n = w (g b) -> Rep g -> StoreT g w b
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (g (a -> b) -> g a -> g b
forall (f :: * -> *) a b.
Representable f =>
f (a -> b) -> f a -> f b
apRep (g (a -> b) -> g a -> g b) -> w (g (a -> b)) -> w (g a -> g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (g (a -> b))
ff w (g a -> g b) -> w (g a) -> w (g b)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> w (g a)
fa) (Rep g
m Rep g -> Rep g -> Rep g
forall a. Semigroup a => a -> a -> a
<> Rep g
n)

instance (ComonadApply w, Semigroup (Rep g), Representable g) => ComonadApply (StoreT g w) where
  StoreT w (g (a -> b))
ff Rep g
m <@> :: StoreT g w (a -> b) -> StoreT g w a -> StoreT g w b
<@> StoreT w (g a)
fa Rep g
n = w (g b) -> Rep g -> StoreT g w b
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (g (a -> b) -> g a -> g b
forall (f :: * -> *) a b.
Representable f =>
f (a -> b) -> f a -> f b
apRep (g (a -> b) -> g a -> g b) -> w (g (a -> b)) -> w (g a -> g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (g (a -> b))
ff w (g a -> g b) -> w (g a) -> w (g b)
forall (w :: * -> *) a b.
ComonadApply w =>
w (a -> b) -> w a -> w b
<@> w (g a)
fa) (Rep g
m Rep g -> Rep g -> Rep g
forall a. Semigroup a => a -> a -> a
<> Rep g
n)

instance (Applicative w, Monoid (Rep g), Representable g) => Applicative (StoreT g w) where
  pure :: a -> StoreT g w a
pure a
a = w (g a) -> Rep g -> StoreT g w a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (g a -> w (g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> g a
forall (f :: * -> *) a. Representable f => a -> f a
pureRep a
a)) Rep g
forall a. Monoid a => a
mempty
  StoreT w (g (a -> b))
ff Rep g
m <*> :: StoreT g w (a -> b) -> StoreT g w a -> StoreT g w b
<*> StoreT w (g a)
fa Rep g
n = w (g b) -> Rep g -> StoreT g w b
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (g (a -> b) -> g a -> g b
forall (f :: * -> *) a b.
Representable f =>
f (a -> b) -> f a -> f b
apRep (g (a -> b) -> g a -> g b) -> w (g (a -> b)) -> w (g a -> g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (g (a -> b))
ff w (g a -> g b) -> w (g a) -> w (g b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> w (g a)
fa) (Rep g
m Rep g -> Rep g -> Rep g
forall a. Monoid a => a -> a -> a
`mappend` Rep g
n)

instance (Extend w, Representable g) => Extend (StoreT g w) where
  duplicated :: StoreT g w a -> StoreT g w (StoreT g w a)
duplicated (StoreT w (g a)
wf Rep g
s) = w (g (StoreT g w a)) -> Rep g -> StoreT g w (StoreT g w a)
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT ((w (g a) -> g (StoreT g w a)) -> w (g a) -> w (g (StoreT g w a))
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended ((Rep g -> StoreT g w a) -> g (StoreT g w a)
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate ((Rep g -> StoreT g w a) -> g (StoreT g w a))
-> (w (g a) -> Rep g -> StoreT g w a)
-> w (g a)
-> g (StoreT g w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (g a) -> Rep g -> StoreT g w a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT) w (g a)
wf) Rep g
s

instance (Comonad w, Representable g) => Comonad (StoreT g w) where
  duplicate :: StoreT g w a -> StoreT g w (StoreT g w a)
duplicate (StoreT w (g a)
wf Rep g
s) = w (g (StoreT g w a)) -> Rep g -> StoreT g w (StoreT g w a)
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT ((w (g a) -> g (StoreT g w a)) -> w (g a) -> w (g (StoreT g w a))
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend ((Rep g -> StoreT g w a) -> g (StoreT g w a)
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate ((Rep g -> StoreT g w a) -> g (StoreT g w a))
-> (w (g a) -> Rep g -> StoreT g w a)
-> w (g a)
-> g (StoreT g w a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (g a) -> Rep g -> StoreT g w a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT) w (g a)
wf) Rep g
s
  extract :: StoreT g w a -> a
extract (StoreT w (g a)
wf Rep g
s) = g a -> Rep g -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (w (g a) -> g a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (g a)
wf) Rep g
s

instance Representable g => ComonadTrans (StoreT g) where
  lower :: StoreT g w a -> w a
lower (StoreT w (g a)
w Rep g
s) = (g a -> a) -> w (g a) -> w a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (g a -> Rep g -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` Rep g
s) w (g a)
w

instance ComonadHoist (StoreT g) where
  cohoist :: (forall x. w x -> v x) -> StoreT g w a -> StoreT g v a
cohoist forall x. w x -> v x
f (StoreT w (g a)
w Rep g
s) = v (g a) -> Rep g -> StoreT g v a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (w (g a) -> v (g a)
forall x. w x -> v x
f w (g a)
w) Rep g
s

instance (ComonadTraced m w, Representable g) => ComonadTraced m (StoreT g w) where
  trace :: m -> StoreT g w a -> a
trace m
m = m -> w a -> a
forall m (w :: * -> *) a. ComonadTraced m w => m -> w a -> a
trace m
m (w a -> a) -> (StoreT g w a -> w a) -> StoreT g w a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreT g w a -> w a
forall (t :: (* -> *) -> * -> *) (w :: * -> *) a.
(ComonadTrans t, Comonad w) =>
t w a -> w a
lower

instance (ComonadEnv m w, Representable g) => ComonadEnv m (StoreT g w) where
  ask :: StoreT g w a -> m
ask = w a -> m
forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask (w a -> m) -> (StoreT g w a -> w a) -> StoreT g w a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreT g w a -> w a
forall (t :: (* -> *) -> * -> *) (w :: * -> *) a.
(ComonadTrans t, Comonad w) =>
t w a -> w a
lower

instance (Representable g, ComonadCofree f w) => ComonadCofree f (StoreT g w) where
  unwrap :: StoreT g w a -> f (StoreT g w a)
unwrap (StoreT w (g a)
w Rep g
s) = (w (g a) -> StoreT g w a) -> f (w (g a)) -> f (StoreT g w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w (g a) -> Rep g -> StoreT g w a
forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
`StoreT` Rep g
s) (w (g a) -> f (w (g a))
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap w (g a)
w)