{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | An IO carrier for the 'Logger' effect that writes logs to a 'Handle'
-- selected by the provided function.
module Control.Carrier.Logger.IO (
  LoggerIOC (LoggerIOC),

  -- * Helpers
  HandleSelector,
  singleHandle,

  -- * Carrier implementation
  runLoggerIO,
  runStdoutLoggerIO,
  runStderrLoggerIO,
) where

import Control.Algebra (Algebra (..), (:+:) (..))
import Control.Carrier.Reader (ReaderC, runReader)
import Control.Effect.Logger (Logger (..))
import Control.Effect.Reader (ask)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Logger (
  Loc,
  LogLevel,
  LogSource,
  LogStr,
  ToLogStr (..),
  defaultLogStr,
  fromLogStr,
 )
import qualified Data.ByteString.Char8 as B (hPutStr)
import System.IO (Handle, stderr, stdout)

-- | Algebra for a simple IO logger. The inner function allows for selecting a
-- 'Handle' according to something like 'LogLevel'.
newtype LoggerIOC f m a = LoggerIOC
  { forall f (m :: * -> *) a. LoggerIOC f m a -> ReaderC f m a
runLoggerIOC :: ReaderC f m a
  }
  deriving (Functor (LoggerIOC f m)
Functor (LoggerIOC f m) =>
(forall a. a -> LoggerIOC f m a)
-> (forall a b.
    LoggerIOC f m (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b)
-> (forall a b c.
    (a -> b -> c)
    -> LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m c)
-> (forall a b.
    LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b)
-> (forall a b.
    LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m a)
-> Applicative (LoggerIOC f m)
forall a. a -> LoggerIOC f m a
forall a b. LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m a
forall a b. LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
forall a b.
LoggerIOC f m (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
forall a b c.
(a -> b -> c)
-> LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m c
forall f (m :: * -> *). Applicative m => Functor (LoggerIOC f m)
forall f (m :: * -> *) a. Applicative m => a -> LoggerIOC f m a
forall f (m :: * -> *) a b.
Applicative m =>
LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m a
forall f (m :: * -> *) a b.
Applicative m =>
LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
forall f (m :: * -> *) a b.
Applicative m =>
LoggerIOC f m (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
forall f (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f 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
$cpure :: forall f (m :: * -> *) a. Applicative m => a -> LoggerIOC f m a
pure :: forall a. a -> LoggerIOC f m a
$c<*> :: forall f (m :: * -> *) a b.
Applicative m =>
LoggerIOC f m (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
<*> :: forall a b.
LoggerIOC f m (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
$cliftA2 :: forall f (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m c
liftA2 :: forall a b c.
(a -> b -> c)
-> LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m c
$c*> :: forall f (m :: * -> *) a b.
Applicative m =>
LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
*> :: forall a b. LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
$c<* :: forall f (m :: * -> *) a b.
Applicative m =>
LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m a
<* :: forall a b. LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m a
Applicative, (forall a b. (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b)
-> (forall a b. a -> LoggerIOC f m b -> LoggerIOC f m a)
-> Functor (LoggerIOC f m)
forall a b. a -> LoggerIOC f m b -> LoggerIOC f m a
forall a b. (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
forall f (m :: * -> *) a b.
Functor m =>
a -> LoggerIOC f m b -> LoggerIOC f m a
forall f (m :: * -> *) a b.
Functor m =>
(a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall f (m :: * -> *) a b.
Functor m =>
(a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
fmap :: forall a b. (a -> b) -> LoggerIOC f m a -> LoggerIOC f m b
$c<$ :: forall f (m :: * -> *) a b.
Functor m =>
a -> LoggerIOC f m b -> LoggerIOC f m a
<$ :: forall a b. a -> LoggerIOC f m b -> LoggerIOC f m a
Functor, Applicative (LoggerIOC f m)
Applicative (LoggerIOC f m) =>
(forall a b.
 LoggerIOC f m a -> (a -> LoggerIOC f m b) -> LoggerIOC f m b)
-> (forall a b.
    LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b)
-> (forall a. a -> LoggerIOC f m a)
-> Monad (LoggerIOC f m)
forall a. a -> LoggerIOC f m a
forall a b. LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
forall a b.
LoggerIOC f m a -> (a -> LoggerIOC f m b) -> LoggerIOC f m b
forall f (m :: * -> *). Monad m => Applicative (LoggerIOC f m)
forall f (m :: * -> *) a. Monad m => a -> LoggerIOC f m a
forall f (m :: * -> *) a b.
Monad m =>
LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
forall f (m :: * -> *) a b.
Monad m =>
LoggerIOC f m a -> (a -> LoggerIOC f m b) -> LoggerIOC f 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
$c>>= :: forall f (m :: * -> *) a b.
Monad m =>
LoggerIOC f m a -> (a -> LoggerIOC f m b) -> LoggerIOC f m b
>>= :: forall a b.
LoggerIOC f m a -> (a -> LoggerIOC f m b) -> LoggerIOC f m b
$c>> :: forall f (m :: * -> *) a b.
Monad m =>
LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
>> :: forall a b. LoggerIOC f m a -> LoggerIOC f m b -> LoggerIOC f m b
$creturn :: forall f (m :: * -> *) a. Monad m => a -> LoggerIOC f m a
return :: forall a. a -> LoggerIOC f m a
Monad, Monad (LoggerIOC f m)
Monad (LoggerIOC f m) =>
(forall a. IO a -> LoggerIOC f m a) -> MonadIO (LoggerIOC f m)
forall a. IO a -> LoggerIOC f m a
forall f (m :: * -> *). MonadIO m => Monad (LoggerIOC f m)
forall f (m :: * -> *) a. MonadIO m => IO a -> LoggerIOC f m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall f (m :: * -> *) a. MonadIO m => IO a -> LoggerIOC f m a
liftIO :: forall a. IO a -> LoggerIOC f m a
MonadIO)

type HandleSelector = Loc -> LogSource -> LogLevel -> LogStr -> Handle

-- | Helper to run IO loggers by writing to the same 'Handle' every time.
singleHandle
  :: Handle
  -> HandleSelector
singleHandle :: Handle -> HandleSelector
singleHandle Handle
h Loc
_ LogSource
_ LogLevel
_ LogStr
_ = Handle
h

instance
  forall sig m
   . ( Algebra sig m
     , MonadIO m
     )
  => Algebra (Logger :+: sig) (LoggerIOC HandleSelector m)
  where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (LoggerIOC HandleSelector m)
-> (:+:) Logger sig n a
-> ctx ()
-> LoggerIOC HandleSelector m (ctx a)
alg Handler ctx n (LoggerIOC HandleSelector m)
hdl (:+:) Logger sig n a
sig ctx ()
ctx = case (:+:) Logger sig n a
sig of
    L (LoggerLog Loc
loc LogSource
src LogLevel
lvl msg
msg) -> ReaderC HandleSelector m (ctx a)
-> LoggerIOC HandleSelector m (ctx a)
forall f (m :: * -> *) a. ReaderC f m a -> LoggerIOC f m a
LoggerIOC (ReaderC HandleSelector m (ctx a)
 -> LoggerIOC HandleSelector m (ctx a))
-> ReaderC HandleSelector m (ctx a)
-> LoggerIOC HandleSelector m (ctx a)
forall a b. (a -> b) -> a -> b
$ do
      HandleSelector
f <- ReaderC HandleSelector m HandleSelector
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
      ctx a
ctx ()
ctx
        ctx a
-> ReaderC HandleSelector m () -> ReaderC HandleSelector m (ctx a)
forall a b.
a -> ReaderC HandleSelector m b -> ReaderC HandleSelector m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> ReaderC HandleSelector m ()
forall a. IO a -> ReaderC HandleSelector m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          ( Handle -> ByteString -> IO ()
B.hPutStr
              (HandleSelector
f Loc
loc LogSource
src LogLevel
lvl (msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg))
              (LogStr -> ByteString
fromLogStr (Loc -> LogSource -> LogLevel -> LogStr -> LogStr
defaultLogStr Loc
loc LogSource
src LogLevel
lvl (msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg)))
          )
    R sig n a
other -> ReaderC HandleSelector m (ctx a)
-> LoggerIOC HandleSelector m (ctx a)
forall f (m :: * -> *) a. ReaderC f m a -> LoggerIOC f m a
LoggerIOC (Handler ctx n (ReaderC HandleSelector m)
-> (:+:) (Reader HandleSelector) sig n a
-> ctx ()
-> ReaderC HandleSelector m (ctx a)
forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (ReaderC HandleSelector m)
-> (:+:) (Reader HandleSelector) sig n a
-> ctx ()
-> ReaderC HandleSelector m (ctx a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (ctx :: * -> *)
       (n :: * -> *) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (LoggerIOC HandleSelector m (ctx x)
-> ReaderC HandleSelector m (ctx x)
forall f (m :: * -> *) a. LoggerIOC f m a -> ReaderC f m a
runLoggerIOC (LoggerIOC HandleSelector m (ctx x)
 -> ReaderC HandleSelector m (ctx x))
-> (ctx (n x) -> LoggerIOC HandleSelector m (ctx x))
-> ctx (n x)
-> ReaderC HandleSelector m (ctx x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx (n x) -> LoggerIOC HandleSelector m (ctx x)
Handler ctx n (LoggerIOC HandleSelector m)
hdl) (sig n a -> (:+:) (Reader HandleSelector) sig n a
forall (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *)
       (m :: * -> *) k.
g m k -> (:+:) f g m k
R sig n a
other) ctx ()
ctx)

-- | Run logger, writing to a 'Handle' selected by a function @f@.
runLoggerIO
  :: HandleSelector
  -- ^ @f@
  -> LoggerIOC HandleSelector m a
  -> m a
runLoggerIO :: forall (m :: * -> *) a.
HandleSelector -> LoggerIOC HandleSelector m a -> m a
runLoggerIO HandleSelector
f = HandleSelector -> ReaderC HandleSelector m a -> m a
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader HandleSelector
f (ReaderC HandleSelector m a -> m a)
-> (LoggerIOC HandleSelector m a -> ReaderC HandleSelector m a)
-> LoggerIOC HandleSelector m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggerIOC HandleSelector m a -> ReaderC HandleSelector m a
forall f (m :: * -> *) a. LoggerIOC f m a -> ReaderC f m a
runLoggerIOC

-- | Run logger, writing everything to 'stdout'.
runStdoutLoggerIO
  :: LoggerIOC HandleSelector m a
  -> m a
runStdoutLoggerIO :: forall (m :: * -> *) a. LoggerIOC HandleSelector m a -> m a
runStdoutLoggerIO = HandleSelector -> LoggerIOC HandleSelector m a -> m a
forall (m :: * -> *) a.
HandleSelector -> LoggerIOC HandleSelector m a -> m a
runLoggerIO (Handle -> HandleSelector
singleHandle Handle
stdout)

-- | Run logger, writing everything to 'stderr'.
runStderrLoggerIO
  :: LoggerIOC HandleSelector m a
  -> m a
runStderrLoggerIO :: forall (m :: * -> *) a. LoggerIOC HandleSelector m a -> m a
runStderrLoggerIO = HandleSelector -> LoggerIOC HandleSelector m a -> m a
forall (m :: * -> *) a.
HandleSelector -> LoggerIOC HandleSelector m a -> m a
runLoggerIO (Handle -> HandleSelector
singleHandle Handle
stderr)