{-# LANGUAGE TypeOperators #-}
module Rahm.Desktop.Logger
  ( getLogLevel,
    setLogLevel,
    logs,
    LogLevel (..),
  )
where

import Control.Exception
import Control.Monad (forM_, join, when)
import Data.Time.LocalTime (getZonedTime)
import Text.Printf (PrintfArg, PrintfType, printf)
import XMonad
  ( ExtensionClass (..),
    StateExtension (PersistentExtension),
    X,
    XConf (config),
    XConfig (logHook),
    asks,
    io,
  )
import qualified XMonad.Util.ExtensibleState as XS (get, put)

data LogLevel = Trace | Debug | Info | Warn | Error | Fatal
  deriving (Show, Read, Ord, Eq, Enum, Bounded)

newtype LoggerState = LoggerState
  { logLevel :: LogLevel
  }
  deriving (Show, Read, Eq)

instance ExtensionClass LoggerState where
  initialValue = LoggerState Info
  extensionType = PersistentExtension

class (PrintfType (Printf t)) => LoggerType t where
  type Printf t :: *
  gp :: Printf t -> (String -> X ()) -> t

instance (PrintfArg a, LoggerType b) => LoggerType (a -> b) where
  type Printf (a -> b) = a -> Printf b
  gp g f a = gp (g a) f

instance (a ~ ()) => LoggerType (X a) where
  type Printf (X a) = String
  gp str fn = fn str

getLogLevel :: X LogLevel
getLogLevel = logLevel <$> XS.get

setLogLevel :: LogLevel -> X ()
setLogLevel ll = do
  XS.put $ LoggerState ll
  join $ asks (logHook . config)

logs :: (LoggerType r) => LogLevel -> String -> r
logs ll fmt = gp (printf fmt) $ \ss -> do
  LoggerState ll' <- XS.get
  io $
    catch
      ( do
          zoneTime <- getZonedTime
          when (ll >= ll') $
            forM_ (lines ss) $ \s ->
              putStrLn (printf "[%s %s] - %s" (take 23 $ show zoneTime) (show ll) s)
      )
      (\error -> putStrLn $ "Error: " ++ show (error :: SomeException))