{-# LANGUAGE PatternSynonyms #-}

module Effects.Log (
  Severity (.., I, D, W, E),
  runLog,
  runLogWithQsem,
  stderrLogger,
  fmtMessage,
  addTime,
  Log,
  log,
  LogData (..),
) where

import Colog.Core
import Data.Text (Text, justifyLeft)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Builder qualified as T
import Effectful
import Effectful.Concurrent.QSem
import Effectful.Dispatch.Dynamic
import Effectful.Reader.Static
import Effectful.TH
import Effects.Time
import UnliftIO.Exception (bracket_)
import UnliftIO.IO (stderr)
import Prelude hiding (log)

import Terminal

class Monoid a => LogData a where
  toLog :: a -> T.Builder

instance LogData T.Builder where
  toLog = id

instance LogData Text where
  toLog = T.fromText

instance LogData String where
  toLog = T.fromString

data Log :: Effect where
  Log :: Severity -> T.Builder -> Log m ()

makeEffect ''Log

runLog ::
  (Time :> es, Concurrent :> es, IOE :> es) =>
  LogAction IO T.Builder ->
  Eff (Log : es) a ->
  Eff es a
runLog logger e = do
  lock <- newQSem 1
  runLogWithQsem lock logger e

runLogWithQsem ::
  (Time :> es, Concurrent :> es, IOE :> es) =>
  QSem ->
  LogAction IO T.Builder ->
  Eff (Log : es) a ->
  Eff es a
runLogWithQsem lock logger e = do
  reinterpret
    (runReader lock)
    ( \_ -> \case
        Log sev msg -> do
          lock' <- ask
          bracket_ (waitQSem lock') (signalQSem lock') $ do
            t <- currentTimeB
            liftIO $ cmap (addTime t . fmtMessage) logger <& msg `WithSeverity` sev
    )
    e


stderrLogger ::
  (MonadIO m) =>
  LogAction m T.Builder
stderrLogger = LogAction (liftIO . T.hPutStrLn stderr . LT.toStrict . T.toLazyText)

fmtMessage :: WithSeverity T.Builder -> T.Builder
fmtMessage (WithSeverity txt sev) = "[" <> T.fromText (justifyLeft 7 ' ' (colorSev sev)) <> "] - " <> txt
 where
  colorSev :: Severity -> Text
  colorSev W = colorNormal Red . tshow $ W
  colorSev a = tshow a

addTime ::
  T.Builder ->
  T.Builder ->
  T.Builder
addTime t msg = (" [" :: T.Builder) <> t <> ("] " :: T.Builder) <> toLog msg

--- Helpers
tshow :: Show a => a -> Text
tshow = T.pack . show