{-# LANGUAGE UndecidableInstances #-}

-- | generic, thread safe logging
module Control.Carrier.Logging.Generic (GenericLoggingC (..), runGenericLogging, runStdoutLogging, runColourLogging) where

import Colourista.Pure (cyan, formatWith, green, red, white, yellow)
import Control.Algebra (Algebra (alg), (:+:) (L, R))
import Control.Carrier.Reader (ReaderC (ReaderC))
import Control.Effect.Logging (LogMsg (MkLogMsg), Logging (LoggerLog))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel (..), ToLogStr (toLogStr), defaultLogStr, defaultOutput, fromLogStr)
import Data.Kind (Type)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as TIO
import System.IO (BufferMode (LineBuffering), stdout)
import UnliftIO (MonadUnliftIO, bracket, cancel, hSetBuffering, withAsync)
import UnliftIO.STM (TChan, atomically, newTChanIO, readTChan, tryReadTChan, writeTChan)

type GenericLoggingC :: (Type -> Type) -> Type -> Type
newtype GenericLoggingC m a = MkGenericLoggingC {runGenericLoggingC :: TChan LogMsg -> m a}
  deriving
    (Functor, Applicative, Monad, MonadIO, MonadFail, MonadUnliftIO)
    via ReaderC (TChan LogMsg) m

{-# INLINE runGenericLogging #-}
runGenericLogging
  :: MonadUnliftIO m
  => (LogMsg -> m ())
  -- ^ what to do with a log message
  -> GenericLoggingC m a
  -- ^ the action
  -> m a
runGenericLogging fn act =
  bracket
    newTChanIO
    flushChan
    \chan -> withAsync (readFromChan chan) \async -> do
      res <- runGenericLoggingC act chan
      cancel async
      pure res
 where
  readFromChan chan = go where go = do atomically (readTChan chan) >>= fn; go
  flushChan chan = go where go = atomically (tryReadTChan chan) >>= maybe (pure ()) \el -> do fn el; go

instance (Algebra sig m, MonadIO m) => Algebra (Logging :+: sig) (GenericLoggingC m) where
  alg hdl sig ctx = case sig of
    L (LoggerLog msg) ->
      (<$ ctx) <$> MkGenericLoggingC (atomically . flip writeTChan msg)
    R other -> MkGenericLoggingC \chan -> do
      alg (flip runGenericLoggingC chan . hdl) other ctx

-- | log to stdout, supports concurrency
runStdoutLogging :: MonadUnliftIO m => GenericLoggingC m a -> m a
runStdoutLogging act = do
  hSetBuffering stdout LineBuffering
  runGenericLogging
    logStdout
    act
 where
  {-# INLINE logStdout #-}
  logStdout (MkLogMsg loc lvl msg) = liftIO do
    defaultOutput stdout loc (T.pack "") lvl (toLogStr msg)
{-# INLINE runStdoutLogging #-}

-- | logs to stdout, supports concurrency, logs are printed in colours according to the severity
runColourLogging :: MonadUnliftIO m => GenericLoggingC m a -> m a
runColourLogging act = do
  hSetBuffering stdout LineBuffering
  runGenericLogging
    logColourful
    act
 where
  {-# INLINE logColourful #-}
  logColourful (MkLogMsg loc lvl msg) = liftIO do
    let tm = T.decodeUtf8 $ fromLogStr $ defaultLogStr loc (T.pack "") lvl (toLogStr msg)
        fmt = case lvl of
          LevelDebug -> cyan
          LevelWarn -> yellow
          LevelInfo -> green
          LevelError -> red
          LevelOther _ -> white
    TIO.putStr $ formatWith [fmt] tm
{-# INLINE runColourLogging #-}