-- 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 (Functor (LoggerT w m)
Functor (LoggerT w m)
-> (forall a. a -> LoggerT w m a)
-> (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 a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m b)
-> (forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m a)
-> Applicative (LoggerT w m)
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 -> b) -> LoggerT w m a -> LoggerT w m b)
-> (forall a b. a -> LoggerT w m b -> LoggerT w m a)
-> Functor (LoggerT w m)
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, Applicative (LoggerT w m)
Applicative (LoggerT w m)
-> (forall a b.
    LoggerT w m a -> (a -> LoggerT w m b) -> LoggerT w m b)
-> (forall a b. LoggerT w m a -> LoggerT w m b -> LoggerT w m b)
-> (forall a. a -> LoggerT w m a)
-> Monad (LoggerT w m)
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 (m :: * -> *) a. Monad m => m a -> LoggerT w m a)
-> MonadTrans (LoggerT w)
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,
        Monad (LoggerT w m)
Monad (LoggerT w m)
-> (forall a. IO a -> LoggerT w m a) -> MonadIO (LoggerT w m)
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) <- StateT [w] m a -> [w] -> m (a, [w])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
Strict.runStateT (LoggerT w m a -> StateT [w] m a
forall w (m :: * -> *) a. LoggerT w m a -> StateT [w] m a
runLoggerT LoggerT w m a
m) []
    (a, [w]) -> m (a, [w])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, [w] -> [w]
forall a. [a] -> [a]
reverse [w]
logs)

runId :: Logger w a -> (a, [w])
runId :: forall w a. Logger w a -> (a, [w])
runId = Identity (a, [w]) -> (a, [w])
forall a. Identity a -> a
Identity.runIdentity (Identity (a, [w]) -> (a, [w]))
-> (Logger w a -> Identity (a, [w])) -> Logger w a -> (a, [w])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger w a -> Identity (a, [w])
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 = [w] -> m [w]
forall (m :: * -> *) a. Monad m => a -> m a
return ([w] -> m [w]) -> ((a, [w]) -> [w]) -> (a, [w]) -> m [w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, [w]) -> [w]
forall a b. (a, b) -> b
snd ((a, [w]) -> m [w]) -> m (a, [w]) -> m [w]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LoggerT w m a -> m (a, [w])
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 = (w -> m ()) -> [w] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ w -> m ()
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) = StateT [w] Identity a -> LoggerT w Identity a
forall w (m :: * -> *) a. StateT [w] m a -> LoggerT w m a
LoggerT (StateT [w] Identity a -> LoggerT w Identity a)
-> StateT [w] Identity a -> LoggerT w Identity a
forall a b. (a -> b) -> a -> b
$ ([w] -> [w]) -> StateT [w] Identity a -> StateT [w] Identity a
forall s a. (s -> s) -> State s a -> State s a
Strict.withState ((w -> w) -> [w] -> [w]
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 = StateT [w] m () -> LoggerT w m ()
forall w (m :: * -> *) a. StateT [w] m a -> LoggerT w m a
LoggerT (StateT [w] m () -> LoggerT w m ())
-> StateT [w] m () -> LoggerT w m ()
forall a b. (a -> b) -> a -> b
$ do
        [w]
ms <- StateT [w] m [w]
forall s (m :: * -> *). MonadState s m => m s
Strict.get
        [w] -> StateT [w] m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
Strict.put ([w] -> StateT [w] m ()) -> [w] -> StateT [w] m ()
forall a b. (a -> b) -> a -> b
$! (w
msgw -> [w] -> [w]
forall a. a -> [a] -> [a]
:[w]
ms)
    peek :: LoggerT w m [w]
peek = StateT [w] m [w] -> LoggerT w m [w]
forall w (m :: * -> *) a. StateT [w] m a -> LoggerT w m a
LoggerT (StateT [w] m [w] -> LoggerT w m [w])
-> StateT [w] m [w] -> LoggerT w m [w]
forall a b. (a -> b) -> a -> b
$ do
        [w]
ms <- StateT [w] m [w]
forall s (m :: * -> *). MonadState s m => m s
Strict.get
        [w] -> StateT [w] m [w]
forall (m :: * -> *) a. Monad m => a -> m a
return ([w] -> StateT [w] m [w]) -> [w] -> StateT [w] m [w]
forall a b. (a -> b) -> a -> b
$! [w] -> [w]
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 = m s -> LoggerT w m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift m s
forall s (m :: * -> *). MonadState s m => m s
Strict.get
    put :: s -> LoggerT w m ()
put = m () -> LoggerT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> LoggerT w m ()) -> (s -> m ()) -> s -> LoggerT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
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 = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> StateT s m ()) -> (w -> m ()) -> w -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: StateT s m [w]
peek = m [w] -> StateT s m [w]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift m [w]
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 = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> StateT s m ()) -> (w -> m ()) -> w -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: StateT s m [w]
peek = m [w] -> StateT s m [w]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift m [w]
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 = m () -> ErrorT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> ErrorT e m ()) -> (w -> m ()) -> w -> ErrorT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: ErrorT e m [w]
peek = m [w] -> ErrorT e m [w]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift m [w]
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 = m () -> ExceptT e m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> ExceptT e m ()) -> (w -> m ()) -> w -> ExceptT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: ExceptT e m [w]
peek = m [w] -> ExceptT e m [w]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift m [w]
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 = m () -> ReaderT r m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> ReaderT r m ()) -> (w -> m ()) -> w -> ReaderT r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: ReaderT r m [w]
peek = m [w] -> ReaderT r m [w]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift m [w]
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 = m () -> WriterT w m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (m () -> WriterT w m ()) -> (log -> m ()) -> log -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. log -> m ()
forall w (m :: * -> *). MonadLogger w m => w -> m ()
log
    peek :: WriterT w m [log]
peek = m [log] -> WriterT w m [log]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift m [log]
forall w (m :: * -> *). MonadLogger w m => m [w]
peek