{-# 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  :  [email protected]
-- 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 :: forall (g :: * -> *) a.
Representable g =>
(Rep g -> a) -> Rep g -> Store g a
store = forall (w :: * -> *) (g :: * -> *) a.
(Functor w, Representable g) =>
w (Rep g -> a) -> Rep g -> StoreT g w a
storeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (g :: * -> *) a.
Representable g =>
Store g a -> (Rep g -> a, Rep g)
runStore (StoreT (Identity g a
ga) Rep g
k) = (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 :: forall (w :: * -> *) (g :: * -> *) a.
(Functor w, Representable g) =>
w (Rep g -> a) -> Rep g -> StoreT g w a
storeT = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 :: forall (w :: * -> *) (g :: * -> *) a.
(Functor w, Representable g) =>
StoreT g w a -> (w (Rep g -> a), Rep g)
runStoreT (StoreT w (g a)
w Rep g
s) = (forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index 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 :: forall a. StoreT g w a -> s
pos (StoreT w (g a)
_ Rep g
s) = Rep g
s
  peek :: forall a. s -> StoreT g w a -> a
peek s
s (StoreT w (g a)
w Rep g
_) = forall (w :: * -> *) a. Comonad w => w a -> a
extract w (g a)
w forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` s
s
  peeks :: forall a. (s -> s) -> StoreT g w a -> a
peeks s -> s
f (StoreT w (g a)
w Rep g
s) = forall (w :: * -> *) a. Comonad w => w a -> a
extract w (g a)
w forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
`index` s -> s
f Rep g
s
  seek :: forall a. s -> StoreT g w a -> StoreT g w a
seek s
s (StoreT w (g a)
w Rep g
_) = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT w (g a)
w s
s
  seeks :: forall a. (s -> s) -> StoreT g w a -> StoreT g w a
seeks s -> s
f (StoreT w (g a)
w Rep g
s) = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT w (g a)
w (s -> s
f Rep g
s)

instance (Functor w, Functor g) => Functor (StoreT g w) where
  fmap :: forall a b. (a -> b) -> StoreT g w a -> StoreT g w b
fmap a -> b
f (StoreT w (g a)
w Rep g
s) = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 <.> :: forall a b. StoreT g w (a -> b) -> StoreT g w a -> StoreT g w b
<.> StoreT w (g a)
fa Rep g
n = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (forall (f :: * -> *) a b.
Representable f =>
f (a -> b) -> f a -> f b
apRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (g (a -> b))
ff forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> w (g a)
fa) (Rep g
m 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 <@> :: forall a b. StoreT g w (a -> b) -> StoreT g w a -> StoreT g w b
<@> StoreT w (g a)
fa Rep g
n = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (forall (f :: * -> *) a b.
Representable f =>
f (a -> b) -> f a -> f b
apRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (g (a -> b))
ff forall (w :: * -> *) a b.
ComonadApply w =>
w (a -> b) -> w a -> w b
<@> w (g a)
fa) (Rep g
m forall a. Semigroup a => a -> a -> a
<> Rep g
n)

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

instance (Extend w, Representable g) => Extend (StoreT g w) where
  duplicated :: forall a. StoreT g w a -> StoreT g w (StoreT g w a)
duplicated (StoreT w (g a)
wf Rep g
s) = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended (forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. StoreT g w a -> StoreT g w (StoreT g w a)
duplicate (StoreT w (g a)
wf Rep g
s) = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend (forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT) w (g a)
wf) Rep g
s
  extract :: forall a. StoreT g w a -> a
extract (StoreT w (g a)
wf Rep g
s) = forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index (forall (w :: * -> *) a. Comonad w => w a -> a
extract w (g a)
wf) Rep g
s

instance Representable g => ComonadTrans (StoreT g) where
  lower :: forall (w :: * -> *) a. Comonad w => StoreT g w a -> w a
lower (StoreT w (g a)
w Rep g
s) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 (w :: * -> *) (v :: * -> *) a.
(Comonad w, Comonad v) =>
(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) = forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
StoreT (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 :: forall a. m -> StoreT g w a -> a
trace m
m = forall m (w :: * -> *) a. ComonadTraced m w => m -> w a -> a
trace m
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. StoreT g w a -> m
ask = forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. StoreT g w a -> f (StoreT g w a)
unwrap (StoreT w (g a)
w Rep g
s) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (g :: * -> *) (w :: * -> *) a.
w (g a) -> Rep g -> StoreT g w a
`StoreT` Rep g
s) (forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap w (g a)
w)