-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Monad.Error
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
{- | A monad like WriterT, but intended for logging.

    WriterT is not actually all that good for logging because its (>>=) is not
    tail recursive.

    TODO there's now a CPS version on hackage: writer-cps-mtl It might be more
    efficient.
-}
module Util.Logger (
    LoggerT, Logger, run, runId, exec, MonadLogger(..), logs
    , mapLogs
) where
import Prelude hiding (log)
import qualified Control.Monad.Error as Error
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.Reader as Reader
import qualified Control.Monad.State.Lazy as Lazy
import qualified Control.Monad.State.Strict as Strict
import qualified Control.Monad.Trans as Trans
import qualified Control.Monad.Writer as Writer

import qualified Data.Monoid as Monoid


-- | This uses a plain list for now.  DList is not actually very efficient for
-- appends because appending nil doesn't strictly eliminate the nil.
newtype LoggerT w m a = LoggerT { forall w (m :: * -> *) a. LoggerT w m a -> StateT [w] m a
runLoggerT :: Strict.StateT [w] m a }
    deriving (forall a. a -> LoggerT w m a
forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m a
forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m b
forall a b. LoggerT w m (a -> b) -> LoggerT w m a -> LoggerT w m b
forall a b c.
(a -> b -> c) -> LoggerT w m a -> LoggerT w m b -> LoggerT w m c
forall {w} {m :: * -> *}. Monad m => Functor (LoggerT w m)
forall w (m :: * -> *) a. Monad m => a -> LoggerT w m a
forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> LoggerT w m b -> LoggerT w m a
forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> LoggerT w m b -> LoggerT w m b
forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m (a -> b) -> LoggerT w m a -> LoggerT w m b
forall w (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> LoggerT w m a -> LoggerT w m b -> LoggerT w m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m a
$c<* :: forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> LoggerT w m b -> LoggerT w m a
*> :: forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m b
$c*> :: forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> LoggerT w m b -> LoggerT w m b
liftA2 :: forall a b c.
(a -> b -> c) -> LoggerT w m a -> LoggerT w m b -> LoggerT w m c
$cliftA2 :: forall w (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> LoggerT w m a -> LoggerT w m b -> LoggerT w m c
<*> :: forall a b. LoggerT w m (a -> b) -> LoggerT w m a -> LoggerT w m b
$c<*> :: forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m (a -> b) -> LoggerT w m a -> LoggerT w m b
pure :: forall a. a -> LoggerT w m a
$cpure :: forall w (m :: * -> *) a. Monad m => a -> LoggerT w m a
Applicative, forall a b. a -> LoggerT w m b -> LoggerT w m a
forall a b. (a -> b) -> LoggerT w m a -> LoggerT w m b
forall w (m :: * -> *) a b.
Functor m =>
a -> LoggerT w m b -> LoggerT w m a
forall w (m :: * -> *) a b.
Functor m =>
(a -> b) -> LoggerT w m a -> LoggerT w m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> LoggerT w m b -> LoggerT w m a
$c<$ :: forall w (m :: * -> *) a b.
Functor m =>
a -> LoggerT w m b -> LoggerT w m a
fmap :: forall a b. (a -> b) -> LoggerT w m a -> LoggerT w m b
$cfmap :: forall w (m :: * -> *) a b.
Functor m =>
(a -> b) -> LoggerT w m a -> LoggerT w m b
Functor, forall a. a -> LoggerT w m a
forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m b
forall a b. LoggerT w m a -> (a -> LoggerT w m b) -> LoggerT w m b
forall w (m :: * -> *). Monad m => Applicative (LoggerT w m)
forall w (m :: * -> *) a. Monad m => a -> LoggerT w m a
forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> LoggerT w m b -> LoggerT w m b
forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> (a -> LoggerT w m b) -> LoggerT w m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> LoggerT w m a
$creturn :: forall w (m :: * -> *) a. Monad m => a -> LoggerT w m a
>> :: forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m b
$c>> :: forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> LoggerT w m b -> LoggerT w m b
>>= :: forall a b. LoggerT w m a -> (a -> LoggerT w m b) -> LoggerT w m b
$c>>= :: forall w (m :: * -> *) a b.
Monad m =>
LoggerT w m a -> (a -> LoggerT w m b) -> LoggerT w m b
Monad, forall w (m :: * -> *) a. Monad m => m a -> LoggerT w m a
forall (m :: * -> *) a. Monad m => m a -> LoggerT w m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> LoggerT w m a
$clift :: forall w (m :: * -> *) a. Monad m => m a -> LoggerT w m a
Trans.MonadTrans,
        forall a. IO a -> LoggerT w m a
forall {w} {m :: * -> *}. MonadIO m => Monad (LoggerT w m)
forall w (m :: * -> *) a. MonadIO m => IO a -> LoggerT w m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> LoggerT w m a
$cliftIO :: forall w (m :: * -> *) a. MonadIO m => IO a -> LoggerT w m a
Trans.MonadIO, Except.MonadError e, Reader.MonadReader r)

type Logger w a = LoggerT w Identity.Identity a

run :: Monad m => LoggerT w m a -> m (a, [w])
run :: forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w])
run LoggerT w m a
m = do
    (a
result, [w]
logs) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT (forall w (m :: * -> *) a. LoggerT w m a -> StateT [w] m a
runLoggerT LoggerT w m a
m) []
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, forall a. [a] -> [a]
reverse [w]
logs)

runId :: Logger w a -> (a, [w])
runId :: forall w a. Logger w a -> (a, [w])
runId = forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w])
run

exec :: Monad m => LoggerT w m a -> m [w]
exec :: forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m [w]
exec LoggerT w m a
m = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) w a. Monad m => LoggerT w m a -> m (a, [w])
run LoggerT w m a
m

class Monad m => MonadLogger w m | m -> w where
    log :: w -> m ()
    peek :: m [w]

logs :: (MonadLogger w m) => [w] -> m ()
logs :: forall w (m :: * -> *). MonadLogger w m => [w] -> m ()
logs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall w (m :: * -> *). MonadLogger w m => w -> m ()
log

mapLogs :: (w -> w) -> Logger w a -> Logger w a
mapLogs :: forall w a. (w -> w) -> Logger w a -> Logger w a
mapLogs w -> w
f (LoggerT StateT [w] Identity a
m) = forall w (m :: * -> *) a. StateT [w] m a -> LoggerT w m a
LoggerT forall a b. (a -> b) -> a -> b
$ forall s a. (s -> s) -> State s a -> State s a
Strict.withState (forall a b. (a -> b) -> [a] -> [b]
map w -> w
f) StateT [w] Identity a
m

instance Monad m => MonadLogger w (LoggerT w m) where
    log :: w -> LoggerT w m ()
log w
msg = forall w (m :: * -> *) a. StateT [w] m a -> LoggerT w m a
LoggerT forall a b. (a -> b) -> a -> b
$ do
        [w]
ms <- forall s (m :: * -> *). MonadState s m => m s
Strict.get
        forall s (m :: * -> *). MonadState s m => s -> m ()
Strict.put forall a b. (a -> b) -> a -> b
$! (w
msgforall a. a -> [a] -> [a]
:[w]
ms)
    peek :: LoggerT w m [w]
peek = forall w (m :: * -> *) a. StateT [w] m a -> LoggerT w m a
LoggerT forall a b. (a -> b) -> a -> b
$ do
        [w]
ms <- forall s (m :: * -> *). MonadState s m => m s
Strict.get
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
reverse [w]
ms

-- | I think I can't automatically derive this because LoggerT itself is
-- a StateT.
instance (Strict.MonadState s m) => Strict.MonadState s (LoggerT w m) where
    get :: LoggerT w m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall s (m :: * -> *). MonadState s m => m s
Strict.get
    put :: s -> LoggerT w m ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
Strict.put

-- mtl instances

instance MonadLogger w m => MonadLogger w (Strict.StateT s m) where
    log :: w -> StateT s m ()
log = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: StateT s m [w]
peek = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall w (m :: * -> *). MonadLogger w m => m [w]
peek

instance MonadLogger w m => MonadLogger w (Lazy.StateT s m) where
    log :: w -> StateT s m ()
log = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: StateT s m [w]
peek = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall w (m :: * -> *). MonadLogger w m => m [w]
peek

instance (Error.Error e, MonadLogger w m) =>
        MonadLogger w (Error.ErrorT e m) where
    log :: w -> ErrorT e m ()
log = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: ErrorT e m [w]
peek = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall w (m :: * -> *). MonadLogger w m => m [w]
peek

instance MonadLogger w m => MonadLogger w (Except.ExceptT e m) where
    log :: w -> ExceptT e m ()
log = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: ExceptT e m [w]
peek = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall w (m :: * -> *). MonadLogger w m => m [w]
peek

instance MonadLogger w m => MonadLogger w (Reader.ReaderT r m) where
    log :: w -> ReaderT r m ()
log = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: ReaderT r m [w]
peek = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall w (m :: * -> *). MonadLogger w m => m [w]
peek

instance (Monoid.Monoid w, MonadLogger log m) =>
        MonadLogger log (Writer.WriterT w m) where
    log :: log -> WriterT w m ()
log = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: WriterT w m [log]
peek = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift forall w (m :: * -> *). MonadLogger w m => m [w]
peek