{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable, Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
#ifdef MIN_VERSION_indexed_traversable
{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Comonad.Trans.Traced
-- Copyright   :  (C) 2008-2014 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- The trace comonad builds up a result by prepending monoidal values to each
-- other.
--
-- This module specifies the traced comonad transformer (aka the cowriter or
-- exponential comonad transformer).
--
----------------------------------------------------------------------------
module Control.Comonad.Trans.Traced
  (
  -- * Traced comonad
    Traced
  , traced
  , runTraced
  -- * Traced comonad transformer
  , TracedT(..)
  -- * Operations
  , trace
  , listen
  , listens
  , censor
  ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif

#if __GLASGOW_HASKELL__ < 707
import Control.Monad.Instances ()
#endif

import Control.Monad (ap)
import Control.Comonad
import Control.Comonad.Hoist.Class
import Control.Comonad.Trans.Class

#ifdef MIN_VERSION_distributive
import Data.Distributive
#endif

#ifdef MIN_VERSION_indexed_traversable
import Data.Functor.WithIndex
#endif

import Data.Functor.Identity

#if __GLASGOW_HASKELL__ < 710
import Data.Semigroup
#endif

import Data.Typeable


type Traced m = TracedT m Identity

traced :: (m -> a) -> Traced m a
traced :: forall m a. (m -> a) -> Traced m a
traced m -> a
f = Identity (m -> a) -> TracedT m Identity a
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT ((m -> a) -> Identity (m -> a)
forall a. a -> Identity a
Identity m -> a
f)

runTraced :: Traced m a -> m -> a
runTraced :: forall m a. Traced m a -> m -> a
runTraced (TracedT (Identity m -> a
f)) = m -> a
f

newtype TracedT m w a = TracedT { forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT :: w (m -> a) }

instance Functor w => Functor (TracedT m w) where
  fmap :: forall a b. (a -> b) -> TracedT m w a -> TracedT m w b
fmap a -> b
g = w (m -> b) -> TracedT m w b
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> b) -> TracedT m w b)
-> (TracedT m w a -> w (m -> b)) -> TracedT m w a -> TracedT m w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((m -> a) -> m -> b) -> w (m -> a) -> w (m -> 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 (a -> b) -> (m -> a) -> m -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (w (m -> a) -> w (m -> b))
-> (TracedT m w a -> w (m -> a)) -> TracedT m w a -> w (m -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT

instance (ComonadApply w, Monoid m) => ComonadApply (TracedT m w) where
  TracedT w (m -> a -> b)
wf <@> :: forall a b. TracedT m w (a -> b) -> TracedT m w a -> TracedT m w b
<@> TracedT w (m -> a)
wa = w (m -> b) -> TracedT m w b
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT ((m -> a -> b) -> (m -> a) -> m -> b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap ((m -> a -> b) -> (m -> a) -> m -> b)
-> w (m -> a -> b) -> w ((m -> a) -> m -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (m -> a -> b)
wf w ((m -> a) -> m -> b) -> w (m -> a) -> w (m -> 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 (m -> a)
wa)

instance Applicative w => Applicative (TracedT m w) where
  pure :: forall a. a -> TracedT m w a
pure = w (m -> a) -> TracedT m w a
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> a) -> TracedT m w a)
-> (a -> w (m -> a)) -> a -> TracedT m w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m -> a) -> w (m -> a)
forall a. a -> w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((m -> a) -> w (m -> a)) -> (a -> m -> a) -> a -> w (m -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m -> a
forall a b. a -> b -> a
const
  TracedT w (m -> a -> b)
wf <*> :: forall a b. TracedT m w (a -> b) -> TracedT m w a -> TracedT m w b
<*> TracedT w (m -> a)
wa = w (m -> b) -> TracedT m w b
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT ((m -> a -> b) -> (m -> a) -> m -> b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap ((m -> a -> b) -> (m -> a) -> m -> b)
-> w (m -> a -> b) -> w ((m -> a) -> m -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> w (m -> a -> b)
wf w ((m -> a) -> m -> b) -> w (m -> a) -> w (m -> 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 (m -> a)
wa)

instance (Comonad w, Monoid m) => Comonad (TracedT m w) where
  extend :: forall a b. (TracedT m w a -> b) -> TracedT m w a -> TracedT m w b
extend TracedT m w a -> b
f = w (m -> b) -> TracedT m w b
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> b) -> TracedT m w b)
-> (TracedT m w a -> w (m -> b)) -> TracedT m w a -> TracedT m w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w (m -> a) -> m -> b) -> w (m -> a) -> w (m -> 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 (m -> a)
wf m
m -> TracedT m w a -> b
f (w (m -> a) -> TracedT m w a
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (((m -> a) -> m -> a) -> w (m -> a) -> w (m -> a)
forall a b. (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m -> a) -> (m -> m) -> m -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> m -> m
forall a. Monoid a => a -> a -> a
mappend m
m) w (m -> a)
wf))) (w (m -> a) -> w (m -> b))
-> (TracedT m w a -> w (m -> a)) -> TracedT m w a -> w (m -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT
  extract :: forall a. TracedT m w a -> a
extract (TracedT w (m -> a)
wf) = w (m -> a) -> m -> a
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (m -> a)
wf m
forall a. Monoid a => a
mempty

instance Monoid m => ComonadTrans (TracedT m) where
  lower :: forall (w :: * -> *) a. Comonad w => TracedT m w a -> w a
lower = ((m -> a) -> a) -> w (m -> 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 ((m -> a) -> m -> a
forall a b. (a -> b) -> a -> b
$ m
forall a. Monoid a => a
mempty) (w (m -> a) -> w a)
-> (TracedT m w a -> w (m -> a)) -> TracedT m w a -> w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT

instance ComonadHoist (TracedT m) where
  cohoist :: forall (w :: * -> *) (v :: * -> *) a.
(Comonad w, Comonad v) =>
(forall x. w x -> v x) -> TracedT m w a -> TracedT m v a
cohoist forall x. w x -> v x
l = v (m -> a) -> TracedT m v a
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (v (m -> a) -> TracedT m v a)
-> (TracedT m w a -> v (m -> a)) -> TracedT m w a -> TracedT m v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w (m -> a) -> v (m -> a)
forall x. w x -> v x
l (w (m -> a) -> v (m -> a))
-> (TracedT m w a -> w (m -> a)) -> TracedT m w a -> v (m -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT

#ifdef MIN_VERSION_distributive
instance Distributive w => Distributive (TracedT m w) where
  distribute :: forall (f :: * -> *) a.
Functor f =>
f (TracedT m w a) -> TracedT m w (f a)
distribute = w (m -> f a) -> TracedT m w (f a)
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> f a) -> TracedT m w (f a))
-> (f (TracedT m w a) -> w (m -> f a))
-> f (TracedT m w a)
-> TracedT m w (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (m -> a) -> m -> f a) -> w (f (m -> a)) -> w (m -> f a)
forall a b. (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\f (m -> a)
tma m
m -> ((m -> a) -> a) -> f (m -> a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m -> a) -> m -> a
forall a b. (a -> b) -> a -> b
$ m
m) f (m -> a)
tma) (w (f (m -> a)) -> w (m -> f a))
-> (f (TracedT m w a) -> w (f (m -> a)))
-> f (TracedT m w a)
-> w (m -> f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TracedT m w a -> w (m -> a))
-> f (TracedT m w a) -> w (f (m -> a))
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive g, Functor f) =>
(a -> g b) -> f a -> g (f b)
forall (f :: * -> *) a b. Functor f => (a -> w b) -> f a -> w (f b)
collect TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT
#endif

#ifdef MIN_VERSION_indexed_traversable
instance FunctorWithIndex i w => FunctorWithIndex (s, i) (TracedT s w) where
  imap :: forall a b. ((s, i) -> a -> b) -> TracedT s w a -> TracedT s w b
imap (s, i) -> a -> b
f (TracedT w (s -> a)
w) = w (s -> b) -> TracedT s w b
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (s -> b) -> TracedT s w b) -> w (s -> b) -> TracedT s w b
forall a b. (a -> b) -> a -> b
$ (i -> (s -> a) -> s -> b) -> w (s -> a) -> w (s -> b)
forall a b. (i -> a -> b) -> w a -> w b
forall i (f :: * -> *) a b.
FunctorWithIndex i f =>
(i -> a -> b) -> f a -> f b
imap (\i
k' s -> a
g s
k -> (s, i) -> a -> b
f (s
k, i
k') (s -> a
g s
k)) w (s -> a)
w
  {-# INLINE imap #-}
#endif

trace :: Comonad w => m -> TracedT m w a -> a
trace :: forall (w :: * -> *) m a. Comonad w => m -> TracedT m w a -> a
trace m
m (TracedT w (m -> a)
wf) = w (m -> a) -> m -> a
forall a. w a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
extract w (m -> a)
wf m
m

listen :: Functor w => TracedT m w a -> TracedT m w (a, m)
listen :: forall (w :: * -> *) m a.
Functor w =>
TracedT m w a -> TracedT m w (a, m)
listen = w (m -> (a, m)) -> TracedT m w (a, m)
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> (a, m)) -> TracedT m w (a, m))
-> (TracedT m w a -> w (m -> (a, m)))
-> TracedT m w a
-> TracedT m w (a, m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((m -> a) -> m -> (a, m)) -> w (m -> a) -> w (m -> (a, m))
forall a b. (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\m -> a
f m
m -> (m -> a
f m
m, m
m)) (w (m -> a) -> w (m -> (a, m)))
-> (TracedT m w a -> w (m -> a))
-> TracedT m w a
-> w (m -> (a, m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT

listens :: Functor w => (m -> b) -> TracedT m w a -> TracedT m w (a, b)
listens :: forall (w :: * -> *) m b a.
Functor w =>
(m -> b) -> TracedT m w a -> TracedT m w (a, b)
listens m -> b
g = w (m -> (a, b)) -> TracedT m w (a, b)
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> (a, b)) -> TracedT m w (a, b))
-> (TracedT m w a -> w (m -> (a, b)))
-> TracedT m w a
-> TracedT m w (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((m -> a) -> m -> (a, b)) -> w (m -> a) -> w (m -> (a, b))
forall a b. (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\m -> a
f m
m -> (m -> a
f m
m, m -> b
g m
m)) (w (m -> a) -> w (m -> (a, b)))
-> (TracedT m w a -> w (m -> a))
-> TracedT m w a
-> w (m -> (a, b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT

censor :: Functor w => (m -> m) -> TracedT m w a -> TracedT m w a
censor :: forall (w :: * -> *) m a.
Functor w =>
(m -> m) -> TracedT m w a -> TracedT m w a
censor m -> m
g = w (m -> a) -> TracedT m w a
forall m (w :: * -> *) a. w (m -> a) -> TracedT m w a
TracedT (w (m -> a) -> TracedT m w a)
-> (TracedT m w a -> w (m -> a)) -> TracedT m w a -> TracedT m w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((m -> a) -> m -> a) -> w (m -> a) -> w (m -> a)
forall a b. (a -> b) -> w a -> w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m -> a) -> (m -> m) -> m -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> m
g) (w (m -> a) -> w (m -> a))
-> (TracedT m w a -> w (m -> a)) -> TracedT m w a -> w (m -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracedT m w a -> w (m -> a)
forall m (w :: * -> *) a. TracedT m w a -> w (m -> a)
runTracedT

#ifdef __GLASGOW_HASKELL__

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

tracedTTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
tracedTTyCon = mkTyCon "Control.Comonad.Trans.Traced.TracedT"
#else
tracedTTyCon = mkTyCon3 "comonad-transformers" "Control.Comonad.Trans.Traced" "TracedT"
#endif
{-# NOINLINE tracedTTyCon #-}

#endif

#endif