module LittleLogger
  ( textLogStr
  , LogAction (..)
  , defaultLogAction
  , filterActionSeverity
  , newLogAction
  , runLogAction
  , handleLogAction
  , openLoggingHandle
  , closeLoggingHandle
  , fileLogAction
  , HasLogAction (..)
  , WithLogAction
  , askLogAction
  , LogActionWrapperM (..)
  , LogActionT (..)
  , runLogActionT
  , LogActionM
  , runLogActionM
  -- Re-exports
  , MonadLogger (..)
  , Loc (..)
  , LogSource
  , LogLevel (..)
  , LogStr
  , ToLogStr (..)
  , logDebugN
  , logInfoN
  , logWarnN
  , logErrorN
  , logOtherN
  )
where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO, askRunInIO)
import Control.Monad.Logger.CallStack
  ( Loc (..)
  , LogLevel (..)
  , LogSource
  , LogStr
  , MonadLogger (..)
  , ToLogStr (..)
  , defaultOutput
  , fromLogStr
  , logDebugN
  , logErrorN
  , logInfoN
  , logOtherN
  , logWarnN
  )
import Control.Monad.Reader (MonadReader, ReaderT (..), asks)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Lens.Micro (Lens')
import Lens.Micro.Extras (view)
import System.IO
  ( BufferMode (LineBuffering)
  , Handle
  , IOMode (AppendMode)
  , hClose
  , hSetBuffering
  , openFile
  , stderr
  , withFile
  )

textLogStr :: LogStr -> Text
textLogStr :: LogStr -> Text
textLogStr = ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
fromLogStr

newtype LogAction = LogAction {LogAction -> Loc -> Text -> LogLevel -> LogStr -> IO ()
unLogAction :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()}

instance Semigroup LogAction where
  LogAction Loc -> Text -> LogLevel -> LogStr -> IO ()
act1 <> :: LogAction -> LogAction -> LogAction
<> LogAction Loc -> Text -> LogLevel -> LogStr -> IO ()
act2 = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> LogAction
LogAction (\Loc
loc Text
src LogLevel
lvl LogStr
msg -> Loc -> Text -> LogLevel -> LogStr -> IO ()
act1 Loc
loc Text
src LogLevel
lvl LogStr
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Loc -> Text -> LogLevel -> LogStr -> IO ()
act2 Loc
loc Text
src LogLevel
lvl LogStr
msg)

instance Monoid LogAction where
  mempty :: LogAction
mempty = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> LogAction
LogAction (\Loc
_ Text
_ LogLevel
_ LogStr
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  mappend :: LogAction -> LogAction -> LogAction
mappend = forall a. Semigroup a => a -> a -> a
(<>)

newLogAction :: (MonadUnliftIO m) => (Loc -> LogSource -> LogLevel -> LogStr -> m ()) -> m LogAction
newLogAction :: forall (m :: * -> *).
MonadUnliftIO m =>
(Loc -> Text -> LogLevel -> LogStr -> m ()) -> m LogAction
newLogAction Loc -> Text -> LogLevel -> LogStr -> m ()
act = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\m () -> IO ()
run -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> LogAction
LogAction (\Loc
loc Text
src LogLevel
lvl LogStr
msg -> m () -> IO ()
run (Loc -> Text -> LogLevel -> LogStr -> m ()
act Loc
loc Text
src LogLevel
lvl LogStr
msg))) forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO

runLogAction :: (MonadIO m) => LogAction -> Loc -> LogSource -> LogLevel -> LogStr -> m ()
runLogAction :: forall (m :: * -> *).
MonadIO m =>
LogAction -> Loc -> Text -> LogLevel -> LogStr -> m ()
runLogAction (LogAction Loc -> Text -> LogLevel -> LogStr -> IO ()
act) Loc
loc Text
src LogLevel
lvl LogStr
msg = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Loc -> Text -> LogLevel -> LogStr -> IO ()
act Loc
loc Text
src LogLevel
lvl LogStr
msg)

defaultLogAction :: LogAction
defaultLogAction :: LogAction
defaultLogAction = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> LogAction
LogAction (Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
defaultOutput Handle
stderr)

filterActionSeverity :: LogLevel -> LogAction -> LogAction
filterActionSeverity :: LogLevel -> LogAction -> LogAction
filterActionSeverity LogLevel
lim (LogAction Loc -> Text -> LogLevel -> LogStr -> IO ()
act) =
  (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> LogAction
LogAction (\Loc
loc Text
src LogLevel
lvl LogStr
msg -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
lvl forall a. Ord a => a -> a -> Bool
>= LogLevel
lim) (Loc -> Text -> LogLevel -> LogStr -> IO ()
act Loc
loc Text
src LogLevel
lvl LogStr
msg))

handleLogAction :: Handle -> LogAction
handleLogAction :: Handle -> LogAction
handleLogAction = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> LogAction
LogAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
defaultOutput

openLoggingHandle :: (MonadIO m) => FilePath -> m Handle
openLoggingHandle :: forall (m :: * -> *). MonadIO m => FilePath -> m Handle
openLoggingHandle FilePath
fp = do
  Handle
handle <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
AppendMode)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> BufferMode -> IO ()
hSetBuffering Handle
handle BufferMode
LineBuffering)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
handle

closeLoggingHandle :: (MonadIO m) => Handle -> m ()
closeLoggingHandle :: forall (m :: * -> *). MonadIO m => Handle -> m ()
closeLoggingHandle = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
hClose

fileLogAction :: (MonadUnliftIO m) => FilePath -> (LogAction -> m a) -> m a
fileLogAction :: forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (LogAction -> m a) -> m a
fileLogAction FilePath
fp LogAction -> m a
f = do
  m a -> IO a
run <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
fp IOMode
AppendMode forall a b. (a -> b) -> a -> b
$ \Handle
handle -> do
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
handle BufferMode
LineBuffering
    m a -> IO a
run (LogAction -> m a
f (Handle -> LogAction
handleLogAction Handle
handle))

class HasLogAction env where
  logActionL :: Lens' env LogAction

instance HasLogAction LogAction where
  logActionL :: Lens' LogAction LogAction
logActionL = forall a. a -> a
id

type WithLogAction env m = (MonadIO m, MonadReader env m, HasLogAction env)

askLogAction :: (MonadReader env m, HasLogAction env) => m LogAction
askLogAction :: forall env (m :: * -> *).
(MonadReader env m, HasLogAction env) =>
m LogAction
askLogAction = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view forall env. HasLogAction env => Lens' env LogAction
logActionL)

-- | Use deriving-via with this wrapper to add MonadLogger instances to your types
newtype LogActionWrapperM env m a = LogActionM {forall env (m :: * -> *) a. LogActionWrapperM env m a -> m a
unLogActionM :: m a}
  deriving newtype (forall a b.
a -> LogActionWrapperM env m b -> LogActionWrapperM env m a
forall a b.
(a -> b) -> LogActionWrapperM env m a -> LogActionWrapperM env m b
forall env (m :: * -> *) a b.
Functor m =>
a -> LogActionWrapperM env m b -> LogActionWrapperM env m a
forall env (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogActionWrapperM env m a -> LogActionWrapperM env 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 -> LogActionWrapperM env m b -> LogActionWrapperM env m a
$c<$ :: forall env (m :: * -> *) a b.
Functor m =>
a -> LogActionWrapperM env m b -> LogActionWrapperM env m a
fmap :: forall a b.
(a -> b) -> LogActionWrapperM env m a -> LogActionWrapperM env m b
$cfmap :: forall env (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogActionWrapperM env m a -> LogActionWrapperM env m b
Functor, forall a. a -> LogActionWrapperM env m a
forall a b.
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m a
forall a b.
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
forall a b.
LogActionWrapperM env m (a -> b)
-> LogActionWrapperM env m a -> LogActionWrapperM env m b
forall a b c.
(a -> b -> c)
-> LogActionWrapperM env m a
-> LogActionWrapperM env m b
-> LogActionWrapperM env m c
forall {env} {m :: * -> *}.
Applicative m =>
Functor (LogActionWrapperM env m)
forall env (m :: * -> *) a.
Applicative m =>
a -> LogActionWrapperM env m a
forall env (m :: * -> *) a b.
Applicative m =>
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m a
forall env (m :: * -> *) a b.
Applicative m =>
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
forall env (m :: * -> *) a b.
Applicative m =>
LogActionWrapperM env m (a -> b)
-> LogActionWrapperM env m a -> LogActionWrapperM env m b
forall env (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> LogActionWrapperM env m a
-> LogActionWrapperM env m b
-> LogActionWrapperM env 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.
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m a
$c<* :: forall env (m :: * -> *) a b.
Applicative m =>
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m a
*> :: forall a b.
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
$c*> :: forall env (m :: * -> *) a b.
Applicative m =>
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
liftA2 :: forall a b c.
(a -> b -> c)
-> LogActionWrapperM env m a
-> LogActionWrapperM env m b
-> LogActionWrapperM env m c
$cliftA2 :: forall env (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> LogActionWrapperM env m a
-> LogActionWrapperM env m b
-> LogActionWrapperM env m c
<*> :: forall a b.
LogActionWrapperM env m (a -> b)
-> LogActionWrapperM env m a -> LogActionWrapperM env m b
$c<*> :: forall env (m :: * -> *) a b.
Applicative m =>
LogActionWrapperM env m (a -> b)
-> LogActionWrapperM env m a -> LogActionWrapperM env m b
pure :: forall a. a -> LogActionWrapperM env m a
$cpure :: forall env (m :: * -> *) a.
Applicative m =>
a -> LogActionWrapperM env m a
Applicative, forall a. a -> LogActionWrapperM env m a
forall a b.
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
forall a b.
LogActionWrapperM env m a
-> (a -> LogActionWrapperM env m b) -> LogActionWrapperM env m b
forall {env} {m :: * -> *}.
Monad m =>
Applicative (LogActionWrapperM env m)
forall env (m :: * -> *) a.
Monad m =>
a -> LogActionWrapperM env m a
forall env (m :: * -> *) a b.
Monad m =>
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
forall env (m :: * -> *) a b.
Monad m =>
LogActionWrapperM env m a
-> (a -> LogActionWrapperM env m b) -> LogActionWrapperM env 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 -> LogActionWrapperM env m a
$creturn :: forall env (m :: * -> *) a.
Monad m =>
a -> LogActionWrapperM env m a
>> :: forall a b.
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
$c>> :: forall env (m :: * -> *) a b.
Monad m =>
LogActionWrapperM env m a
-> LogActionWrapperM env m b -> LogActionWrapperM env m b
>>= :: forall a b.
LogActionWrapperM env m a
-> (a -> LogActionWrapperM env m b) -> LogActionWrapperM env m b
$c>>= :: forall env (m :: * -> *) a b.
Monad m =>
LogActionWrapperM env m a
-> (a -> LogActionWrapperM env m b) -> LogActionWrapperM env m b
Monad, forall a. IO a -> LogActionWrapperM env m a
forall {env} {m :: * -> *}.
MonadIO m =>
Monad (LogActionWrapperM env m)
forall env (m :: * -> *) a.
MonadIO m =>
IO a -> LogActionWrapperM env m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> LogActionWrapperM env m a
$cliftIO :: forall env (m :: * -> *) a.
MonadIO m =>
IO a -> LogActionWrapperM env m a
MonadIO, MonadReader env)

instance (WithLogAction env m) => MonadLogger (LogActionWrapperM env m) where
  monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> LogActionWrapperM env m ()
monadLoggerLog Loc
loc Text
src LogLevel
lvl msg
msg = do
    LogAction Loc -> Text -> LogLevel -> LogStr -> IO ()
act <- forall env (m :: * -> *).
(MonadReader env m, HasLogAction env) =>
m LogAction
askLogAction
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Loc -> Text -> LogLevel -> LogStr -> IO ()
act Loc
loc Text
src LogLevel
lvl (forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg))

newtype LogActionT m a = LogActionT {forall (m :: * -> *) a. LogActionT m a -> ReaderT LogAction m a
unLogActionT :: ReaderT LogAction m a}
  deriving newtype (forall a b. a -> LogActionT m b -> LogActionT m a
forall a b. (a -> b) -> LogActionT m a -> LogActionT m b
forall (m :: * -> *) a b.
Functor m =>
a -> LogActionT m b -> LogActionT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogActionT m a -> LogActionT 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 -> LogActionT m b -> LogActionT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> LogActionT m b -> LogActionT m a
fmap :: forall a b. (a -> b) -> LogActionT m a -> LogActionT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogActionT m a -> LogActionT m b
Functor, forall a. a -> LogActionT m a
forall a b. LogActionT m a -> LogActionT m b -> LogActionT m a
forall a b. LogActionT m a -> LogActionT m b -> LogActionT m b
forall a b.
LogActionT m (a -> b) -> LogActionT m a -> LogActionT m b
forall a b c.
(a -> b -> c) -> LogActionT m a -> LogActionT m b -> LogActionT 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 {m :: * -> *}. Applicative m => Functor (LogActionT m)
forall (m :: * -> *) a. Applicative m => a -> LogActionT m a
forall (m :: * -> *) a b.
Applicative m =>
LogActionT m a -> LogActionT m b -> LogActionT m a
forall (m :: * -> *) a b.
Applicative m =>
LogActionT m a -> LogActionT m b -> LogActionT m b
forall (m :: * -> *) a b.
Applicative m =>
LogActionT m (a -> b) -> LogActionT m a -> LogActionT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> LogActionT m a -> LogActionT m b -> LogActionT m c
<* :: forall a b. LogActionT m a -> LogActionT m b -> LogActionT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
LogActionT m a -> LogActionT m b -> LogActionT m a
*> :: forall a b. LogActionT m a -> LogActionT m b -> LogActionT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
LogActionT m a -> LogActionT m b -> LogActionT m b
liftA2 :: forall a b c.
(a -> b -> c) -> LogActionT m a -> LogActionT m b -> LogActionT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> LogActionT m a -> LogActionT m b -> LogActionT m c
<*> :: forall a b.
LogActionT m (a -> b) -> LogActionT m a -> LogActionT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
LogActionT m (a -> b) -> LogActionT m a -> LogActionT m b
pure :: forall a. a -> LogActionT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> LogActionT m a
Applicative, forall a. a -> LogActionT m a
forall a b. LogActionT m a -> LogActionT m b -> LogActionT m b
forall a b.
LogActionT m a -> (a -> LogActionT m b) -> LogActionT m b
forall {m :: * -> *}. Monad m => Applicative (LogActionT m)
forall (m :: * -> *) a. Monad m => a -> LogActionT m a
forall (m :: * -> *) a b.
Monad m =>
LogActionT m a -> LogActionT m b -> LogActionT m b
forall (m :: * -> *) a b.
Monad m =>
LogActionT m a -> (a -> LogActionT m b) -> LogActionT 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 -> LogActionT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> LogActionT m a
>> :: forall a b. LogActionT m a -> LogActionT m b -> LogActionT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
LogActionT m a -> LogActionT m b -> LogActionT m b
>>= :: forall a b.
LogActionT m a -> (a -> LogActionT m b) -> LogActionT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
LogActionT m a -> (a -> LogActionT m b) -> LogActionT m b
Monad, forall a. IO a -> LogActionT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (LogActionT m)
forall (m :: * -> *) a. MonadIO m => IO a -> LogActionT m a
liftIO :: forall a. IO a -> LogActionT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> LogActionT m a
MonadIO, MonadReader LogAction)
  deriving (forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> LogActionT m ()
forall (m :: * -> *).
Monad m
-> (forall msg.
    ToLogStr msg =>
    Loc -> Text -> LogLevel -> msg -> m ())
-> MonadLogger m
forall {m :: * -> *}. MonadIO m => Monad (LogActionT m)
forall (m :: * -> *) msg.
(MonadIO m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> LogActionT m ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> Text -> LogLevel -> msg -> LogActionT m ()
$cmonadLoggerLog :: forall (m :: * -> *) msg.
(MonadIO m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> LogActionT m ()
MonadLogger) via (LogActionWrapperM LogAction (LogActionT m))

runLogActionT :: LogActionT m a -> LogAction -> m a
runLogActionT :: forall (m :: * -> *) a. LogActionT m a -> LogAction -> m a
runLogActionT = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. LogActionT m a -> ReaderT LogAction m a
unLogActionT

type LogActionM a = LogActionT IO a

runLogActionM :: LogActionM a -> LogAction -> IO a
runLogActionM :: forall a. LogActionM a -> LogAction -> IO a
runLogActionM = forall (m :: * -> *) a. LogActionT m a -> LogAction -> m a
runLogActionT