{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Comonad.Trans.Env
-- Copyright   :  (C) 2008-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- The environment comonad holds a value along with some retrievable context.
--
-- This module specifies the environment comonad transformer (aka coreader),
-- which is left adjoint to the reader comonad.
--
-- The following sets up an experiment that retains its initial value in the
-- background:
--
-- >>> let initial = env 0 0
--
-- Extract simply retrieves the value:
--
-- >>> extract initial
-- 0
--
-- Play around with the value, in our case producing a negative value:
--
-- >>> let experiment = fmap (+ 10) initial
-- >>> extract experiment
-- 10
--
-- Oh noes, something went wrong, 10 isn't very negative! Better restore the
-- initial value using the default:
--
-- >>> let initialRestored = experiment =>> ask
-- >>> extract initialRestored
-- 0
----------------------------------------------------------------------------
module Control.Comonad.Trans.Env
  (
  -- * The strict environment comonad
    Env
  , env
  , runEnv
  -- * The strict environment comonad transformer
  , EnvT(..)
  , runEnvT
  , lowerEnvT
  -- * Combinators
  , ask
  , asks
  , local
  ) where

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

#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__ >= 707
#define Typeable1 Typeable
#endif
import Data.Data

-- $setup
-- >>> import Control.Comonad

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

envTTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
envTTyCon = mkTyCon "Control.Comonad.Trans.Env.EnvT"
#else
envTTyCon = mkTyCon3 "comonad-transformers" "Control.Comonad.Trans.Env" "EnvT"
#endif
{-# NOINLINE envTTyCon #-}

#endif

#if __GLASGOW_HASKELL__ < 707
instance (Typeable s, Typeable1 w, Typeable a) => Typeable (EnvT s w a) where
  typeOf = typeOfDefault
#endif

instance
  ( Data e
  , Typeable1 w, Data (w a)
  , Data a
  ) => Data (EnvT e w a) where
    gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EnvT e w a -> c (EnvT e w a)
gfoldl forall d b. Data d => c (d -> b) -> d -> c b
f forall g. g -> c g
z (EnvT e
e w a
wa) = (e -> w a -> EnvT e w a) -> c (e -> w a -> EnvT e w a)
forall g. g -> c g
z e -> w a -> EnvT e w a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT c (e -> w a -> EnvT e w a) -> e -> c (w a -> EnvT e w a)
forall d b. Data d => c (d -> b) -> d -> c b
`f` e
e c (w a -> EnvT e w a) -> w a -> c (EnvT e w a)
forall d b. Data d => c (d -> b) -> d -> c b
`f` w a
wa
    toConstr :: EnvT e w a -> Constr
toConstr EnvT e w a
_ = Constr
envTConstr
    gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (EnvT e w a)
gunfold forall b r. Data b => c (b -> r) -> c r
k forall r. r -> c r
z Constr
c = case Constr -> Int
constrIndex Constr
c of
        Int
1 -> c (w a -> EnvT e w a) -> c (EnvT e w a)
forall b r. Data b => c (b -> r) -> c r
k (c (e -> w a -> EnvT e w a) -> c (w a -> EnvT e w a)
forall b r. Data b => c (b -> r) -> c r
k ((e -> w a -> EnvT e w a) -> c (e -> w a -> EnvT e w a)
forall r. r -> c r
z e -> w a -> EnvT e w a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT))
        Int
_ -> [Char] -> c (EnvT e w a)
forall a. HasCallStack => [Char] -> a
error [Char]
"gunfold"
    dataTypeOf :: EnvT e w a -> DataType
dataTypeOf EnvT e w a
_ = DataType
envTDataType
    dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (EnvT e w a))
dataCast1 forall d. Data d => c (t d)
f = c (t a) -> Maybe (c (EnvT e w a))
forall {k1} {k2} (c :: k1 -> *) (t :: k2 -> k1) (t' :: k2 -> k1)
       (a :: k2).
(Typeable t, Typeable t') =>
c (t a) -> Maybe (c (t' a))
gcast1 c (t a)
forall d. Data d => c (t d)
f

envTConstr :: Constr
envTConstr :: Constr
envTConstr = DataType -> [Char] -> [[Char]] -> Fixity -> Constr
mkConstr DataType
envTDataType [Char]
"EnvT" [] Fixity
Prefix
{-# NOINLINE envTConstr #-}

envTDataType :: DataType
envTDataType :: DataType
envTDataType = [Char] -> [Constr] -> DataType
mkDataType [Char]
"Control.Comonad.Trans.Env.EnvT" [Constr
envTConstr]
{-# NOINLINE envTDataType #-}

#endif

type Env e = EnvT e Identity
data EnvT e w a = EnvT e (w a)

-- | Create an Env using an environment and a value
env :: e -> a -> Env e a
env :: forall e a. e -> a -> Env e a
env e
e a
a = e -> Identity a -> EnvT e Identity a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e (a -> Identity a
forall a. a -> Identity a
Identity a
a)

runEnv :: Env e a -> (e, a)
runEnv :: forall e a. Env e a -> (e, a)
runEnv (EnvT e
e (Identity a
a)) = (e
e, a
a)

runEnvT :: EnvT e w a -> (e, w a)
runEnvT :: forall e (w :: * -> *) a. EnvT e w a -> (e, w a)
runEnvT (EnvT e
e w a
wa) = (e
e, w a
wa)

instance Functor w => Functor (EnvT e w) where
  fmap :: forall a b. (a -> b) -> EnvT e w a -> EnvT e w b
fmap a -> b
g (EnvT e
e w a
wa) = e -> w b -> EnvT e w b
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e ((a -> b) -> w a -> w 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
g w a
wa)

instance Comonad w => Comonad (EnvT e w) where
  duplicate :: forall a. EnvT e w a -> EnvT e w (EnvT e w a)
duplicate (EnvT e
e w a
wa) = e -> w (EnvT e w a) -> EnvT e w (EnvT e w a)
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e ((w a -> EnvT e w a) -> w a -> w (EnvT e 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 (e -> w a -> EnvT e w a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e) w a
wa)
  extract :: forall a. EnvT e w a -> a
extract (EnvT e
_ w a
wa) = w a -> a
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w a
wa

instance ComonadTrans (EnvT e) where
  lower :: forall (w :: * -> *) a. Comonad w => EnvT e w a -> w a
lower (EnvT e
_ w a
wa) = w a
wa

instance (Monoid e, Applicative m) => Applicative (EnvT e m) where
  pure :: forall a. a -> EnvT e m a
pure = e -> m a -> EnvT e m a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
forall a. Monoid a => a
mempty (m a -> EnvT e m a) -> (a -> m a) -> a -> EnvT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  EnvT e
ef m (a -> b)
wf <*> :: forall a b. EnvT e m (a -> b) -> EnvT e m a -> EnvT e m b
<*> EnvT e
ea m a
wa = e -> m b -> EnvT e m b
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT (e
ef e -> e -> e
forall a. Monoid a => a -> a -> a
`mappend` e
ea) (m (a -> b)
wf m (a -> b) -> m a -> m b
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a
wa)

-- | Gets rid of the environment. This differs from 'extract' in that it will
--   not continue extracting the value from the contained comonad.
lowerEnvT :: EnvT e w a -> w a
lowerEnvT :: forall e (w :: * -> *) a. EnvT e w a -> w a
lowerEnvT (EnvT e
_ w a
wa) = w a
wa

instance ComonadHoist (EnvT e) where
  cohoist :: forall (w :: * -> *) (v :: * -> *) a.
(Comonad w, Comonad v) =>
(forall x. w x -> v x) -> EnvT e w a -> EnvT e v a
cohoist forall x. w x -> v x
l (EnvT e
e w a
wa) = e -> v a -> EnvT e v a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e (w a -> v a
forall x. w x -> v x
l w a
wa)

instance (Semigroup e, ComonadApply w) => ComonadApply (EnvT e w) where
  EnvT e
ef w (a -> b)
wf <@> :: forall a b. EnvT e w (a -> b) -> EnvT e w a -> EnvT e w b
<@> EnvT e
ea w a
wa = e -> w b -> EnvT e w b
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT (e
ef e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
ea) (w (a -> b)
wf w (a -> b) -> w a -> w 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 a
wa)

instance Foldable w => Foldable (EnvT e w) where
  foldMap :: forall m a. Monoid m => (a -> m) -> EnvT e w a -> m
foldMap a -> m
f (EnvT e
_ w a
w) = (a -> m) -> w a -> m
forall m a. Monoid m => (a -> m) -> w a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f w a
w

instance Traversable w => Traversable (EnvT e w) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> EnvT e w a -> f (EnvT e w b)
traverse a -> f b
f (EnvT e
e w a
w) = e -> w b -> EnvT e w b
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT e
e (w b -> EnvT e w b) -> f (w b) -> f (EnvT e w b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> w a -> f (w b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> w a -> f (w b)
traverse a -> f b
f w a
w

-- | Retrieves the environment.
ask :: EnvT e w a -> e
ask :: forall e (w :: * -> *) a. EnvT e w a -> e
ask (EnvT e
e w a
_) = e
e

-- | Like 'ask', but modifies the resulting value with a function.
--
--   > asks = f . ask
asks :: (e -> f) -> EnvT e w a -> f
asks :: forall e f (w :: * -> *) a. (e -> f) -> EnvT e w a -> f
asks e -> f
f (EnvT e
e w a
_) = e -> f
f e
e

-- | Modifies the environment using the specified function.
local :: (e -> e') -> EnvT e w a -> EnvT e' w a
local :: forall e e' (w :: * -> *) a. (e -> e') -> EnvT e w a -> EnvT e' w a
local e -> e'
f (EnvT e
e w a
wa) = e' -> w a -> EnvT e' w a
forall e (w :: * -> *) a. e -> w a -> EnvT e w a
EnvT (e -> e'
f e
e) w a
wa