{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE TemplateHaskell     #-}

module Puppy.Logging (
  LogContext (..),
  genTracer,
  Level (..),
  Tracer,

  -- * Effect
  Log,

  -- * Actions

  -- | Get the current logging context.
  getContext,
  -- | Override the current logging context.
  setContext,
  -- | Push a scope segment to the stack.
  scope,
  debug,
  info,
  warn,

  -- * Handlers
  runLog,
) where

import Control.Monad (when)
import Crypto.Random
import Data.Functor ((<&>))
import Data.Text (Text, justifyRight)
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Reader.Dynamic
import Effectful.TH (makeEffect)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS
import qualified Data.Text.IO as T

data LogContext
  = LogRequest { scopeLabel :: Text, tracer :: Tracer }
  | LogGeneral { scopeLabel :: Text }

newtype Tracer
  = Tracer { getTracerBytes :: BS.ByteString }

genTracer :: (MonadIO m) => m Tracer
genTracer = Tracer <$> liftIO (getRandomBytes 8)

data Level = Debug | Info | Warn deriving (Enum, Eq, Ord)

data Log :: Effect where
  GetContext   :: Log m LogContext
  SetContext   :: LogContext -> m a -> Log m a
  DebugMessage :: Text -> Log m ()
  InfoMessage  :: Text -> Log m ()
  WarnMessage  :: Text -> Log m ()
  Scope        :: Text -> m a -> Log m a

makeEffect ''Log

-- | Insert a message into the log.
debug, info, warn :: (Log :> es) => Text -> Eff es ()
debug = debugMessage
info  = infoMessage
warn  = warnMessage

-- | Run the logging effect.
runLog
  :: (IOE :> es)
  => LogContext
  -> Level
  -> Eff (Log : es) a
  -> Eff es a
runLog logContext lvl = reinterpret (runReader logContext) $ \env x -> do
  label <- asks scopeLabel
  trace <- ask <&> \case
    LogRequest { tracer } -> " [" <> BS.encodeBase64 (getTracerBytes tracer) <> "]"
    _ -> ""
  let writeMessage :: IOE :> es => Text -> Text -> Eff es ()
      writeMessage level msg = liftIO (T.putStrLn (justifyRight 9 ' ' ("[" <> level <> "]") <> trace <> " (" <> label <> "): " <> msg))
  case x of
    GetContext -> ask
    SetContext ctx rest -> localSeqUnlift env $ \unlift -> do
      local (const ctx) (unlift rest)
    -- Modify the context label
    Scope name rest -> localSeqUnlift env $ \unlift -> do
      local (\c -> c { scopeLabel = c.scopeLabel <> "::" <> name }) $ unlift rest
    -- Print messages at different severities
    DebugMessage msg -> when (lvl <= Debug) (writeMessage "debug" msg)
    InfoMessage msg -> when (lvl <= Info) (writeMessage "info" msg)
    WarnMessage msg -> when (lvl <= Warn) (writeMessage "warning" msg)