{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Comonad.Trans.Store
-- Copyright   :  (C) 2008-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
--
-- The store comonad holds a constant value along with a modifiable /accessor/
-- function, which maps the /stored value/ to the /focus/.
--
-- This module defines the strict store (aka state-in-context/costate) comonad
-- transformer.
--
-- @stored value = (1, 5)@, @accessor = fst@, @resulting focus = 1@:
--
-- >>> :{
--  let
--    storeTuple :: Store (Int, Int) Int
--    storeTuple = store fst (1, 5)
-- :}
--
-- Add something to the focus:
--
-- >>> :{
--  let
--    addToFocus :: Int -> Store (Int, Int) Int -> Int
--    addToFocus x wa = x + extract wa
-- :}
--
-- >>> :{
--   let
--     added3 :: Store (Int, Int) Int
--     added3 = extend (addToFocus 3) storeTuple
-- :}
--
-- The focus of added3 is now @1 + 3 = 4@. However, this action changed only
-- the accessor function and therefore the focus but not the stored value:
--
-- >>> pos added3
-- (1,5)
--
-- >>> extract added3
-- 4
--
-- The strict store (state-in-context/costate) comonad transformer is subject
-- to the laws:
--
-- > x = seek (pos x) x
-- > y = pos (seek y x)
-- > seek y x = seek y (seek z x)
--
-- Thanks go to Russell O'Connor and Daniel Peebles for their help formulating
-- and proving the laws for this comonad transformer.
----------------------------------------------------------------------------
module Control.Comonad.Trans.Store
  (
  -- * The Store comonad
    Store, store, runStore
  -- * The Store comonad transformer
  , StoreT(..), runStoreT
  -- * Operations
  , pos
  , seek, seeks
  , peek, peeks
  , experiment
  ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Comonad
import Control.Comonad.Hoist.Class
import Control.Comonad.Trans.Class
import Data.Functor.Identity
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif

#ifdef __GLASGOW_HASKELL__
import Data.Typeable

-- $setup
-- >>> import Control.Comonad
-- >>> import Data.Tuple (swap)

#if __GLASGOW_HASKELL__ >= 707
deriving instance Typeable StoreT
#else
instance (Typeable s, Typeable1 w) => Typeable1 (StoreT s w) where
  typeOf1 dswa = mkTyConApp storeTTyCon [typeOf (s dswa), typeOf1 (w dswa)]
    where
      s :: StoreT s w a -> s
      s = undefined
      w :: StoreT s w a -> w a
      w = undefined

instance (Typeable s, Typeable1 w, Typeable a) => Typeable (StoreT s w a) where
  typeOf = typeOfDefault

storeTTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
storeTTyCon = mkTyCon "Control.Comonad.Trans.Store.StoreT"
#else
storeTTyCon = mkTyCon3 "comonad-transformers" "Control.Comonad.Trans.Store" "StoreT"
#endif
{-# NOINLINE storeTTyCon #-}
#endif

#endif

type Store s = StoreT s Identity

-- | Create a Store using an accessor function and a stored value
store :: (s -> a) -> s -> Store s a
store :: forall s a. (s -> a) -> s -> Store s a
store s -> a
f s
s = Identity (s -> a) -> s -> StoreT s Identity a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT ((s -> a) -> Identity (s -> a)
forall a. a -> Identity a
Identity s -> a
f) s
s

runStore :: Store s a -> (s -> a, s)
runStore :: forall s a. Store s a -> (s -> a, s)
runStore (StoreT (Identity s -> a
f) s
s) = (s -> a
f, s
s)

data StoreT s w a = StoreT (w (s -> a)) s

runStoreT :: StoreT s w a -> (w (s -> a), s)
runStoreT :: forall s (w :: * -> *) a. StoreT s w a -> (w (s -> a), s)
runStoreT (StoreT w (s -> a)
wf s
s) = (w (s -> a)
wf, s
s)

instance Functor w => Functor (StoreT s w) where
  fmap :: forall a b. (a -> b) -> StoreT s w a -> StoreT s w b
fmap a -> b
f (StoreT w (s -> a)
wf s
s) = w (s -> b) -> s -> StoreT s w b
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT (((s -> a) -> s -> b) -> w (s -> a) -> w (s -> b)
forall a b. (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f (a -> b) -> (s -> a) -> s -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) w (s -> a)
wf) s
s

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

instance (Applicative w, Monoid s) => Applicative (StoreT s w) where
  pure :: forall a. a -> StoreT s w a
pure a
a = w (s -> a) -> s -> StoreT s w a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT ((s -> a) -> w (s -> a)
forall a. a -> w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> s -> a
forall a b. a -> b -> a
const a
a)) s
forall a. Monoid a => a
mempty
  StoreT w (s -> a -> b)
ff s
m <*> :: forall a b. StoreT s w (a -> b) -> StoreT s w a -> StoreT s w b
<*> StoreT w (s -> a)
fa s
n = w (s -> b) -> s -> StoreT s w b
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT ((s -> a -> b) -> (s -> a) -> s -> b
forall a b. (s -> a -> b) -> (s -> a) -> s -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) ((s -> a -> b) -> (s -> a) -> s -> b)
-> w (s -> a -> b) -> w ((s -> a) -> s -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (s -> a -> b)
ff w ((s -> a) -> s -> b) -> w (s -> a) -> w (s -> b)
forall a b. w (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> w (s -> a)
fa) (s -> s -> s
forall a. Monoid a => a -> a -> a
mappend s
m s
n)

instance Comonad w => Comonad (StoreT s w) where
  duplicate :: forall a. StoreT s w a -> StoreT s w (StoreT s w a)
duplicate (StoreT w (s -> a)
wf s
s) = w (s -> StoreT s w a) -> s -> StoreT s w (StoreT s w a)
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT ((w (s -> a) -> s -> StoreT s w a)
-> w (s -> a) -> w (s -> StoreT s w a)
forall a b. (w a -> b) -> w a -> w b
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend w (s -> a) -> s -> StoreT s w a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT w (s -> a)
wf) s
s
  extend :: forall a b. (StoreT s w a -> b) -> StoreT s w a -> StoreT s w b
extend StoreT s w a -> b
f (StoreT w (s -> a)
wf s
s) = w (s -> b) -> s -> StoreT s w b
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT ((w (s -> a) -> s -> b) -> w (s -> a) -> w (s -> b)
forall a b. (w a -> b) -> w a -> w b
forall (w :: * -> *) a b. Comonad w => (w a -> b) -> w a -> w b
extend (\w (s -> a)
wf' s
s' -> StoreT s w a -> b
f (w (s -> a) -> s -> StoreT s w a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT w (s -> a)
wf' s
s')) w (s -> a)
wf) s
s
  extract :: forall a. StoreT s w a -> a
extract (StoreT w (s -> a)
wf s
s) = w (s -> a) -> s -> a
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (s -> a)
wf s
s

instance ComonadTrans (StoreT s) where
  lower :: forall (w :: * -> *) a. Comonad w => StoreT s w a -> w a
lower (StoreT w (s -> a)
f s
s) = ((s -> a) -> a) -> w (s -> a) -> w a
forall a b. (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ s
s) w (s -> a)
f

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

-- | Read the stored value
--
-- >>> pos $ store fst (1,5)
-- (1,5)
--
pos :: StoreT s w a -> s
pos :: forall s (w :: * -> *) a. StoreT s w a -> s
pos (StoreT w (s -> a)
_ s
s) = s
s

-- | Set the stored value
--
-- >>> pos . seek (3,7) $ store fst (1,5)
-- (3,7)
--
-- Seek satisfies the law
--
-- > seek s = peek s . duplicate
seek :: s -> StoreT s w a -> StoreT s w a
seek :: forall s (w :: * -> *) a. s -> StoreT s w a -> StoreT s w a
seek s
s ~(StoreT w (s -> a)
f s
_) = w (s -> a) -> s -> StoreT s w a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT w (s -> a)
f s
s

-- | Modify the stored value
--
-- >>> pos . seeks swap $ store fst (1,5)
-- (5,1)
--
-- Seeks satisfies the law
--
-- > seeks f = peeks f . duplicate
seeks :: (s -> s) -> StoreT s w a -> StoreT s w a
seeks :: forall s (w :: * -> *) a. (s -> s) -> StoreT s w a -> StoreT s w a
seeks s -> s
f ~(StoreT w (s -> a)
g s
s) = w (s -> a) -> s -> StoreT s w a
forall s (w :: * -> *) a. w (s -> a) -> s -> StoreT s w a
StoreT w (s -> a)
g (s -> s
f s
s)

-- | Peek at what the current focus would be for a different stored value
--
-- Peek satisfies the law
--
-- > peek x . extend (peek y) = peek y
peek :: Comonad w => s -> StoreT s w a -> a
peek :: forall (w :: * -> *) s a. Comonad w => s -> StoreT s w a -> a
peek s
s (StoreT w (s -> a)
g s
_) = w (s -> a) -> s -> a
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (s -> a)
g s
s


-- | Peek at what the current focus would be if the stored value was
--   modified by some function
peeks :: Comonad w => (s -> s) -> StoreT s w a -> a
peeks :: forall (w :: * -> *) s a.
Comonad w =>
(s -> s) -> StoreT s w a -> a
peeks s -> s
f ~(StoreT w (s -> a)
g s
s) = w (s -> a) -> s -> a
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (s -> a)
g (s -> s
f s
s)

-- | Applies a functor-valued function to the stored value, and then uses the
--   new accessor to read the resulting focus.
--
--   >>> let f x = if x > 0 then Just (x^2) else Nothing
--   >>> experiment f $ store (+1) 2
--   Just 5
--   >>> experiment f $ store (+1) (-2)
--   Nothing
experiment :: (Comonad w, Functor f) => (s -> f s) -> StoreT s w a -> f a
experiment :: forall (w :: * -> *) (f :: * -> *) s a.
(Comonad w, Functor f) =>
(s -> f s) -> StoreT s w a -> f a
experiment s -> f s
f (StoreT w (s -> a)
wf s
s) = w (s -> a) -> s -> a
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (s -> a)
wf (s -> a) -> f s -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> f s
f s
s