Logger.hs

{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE RecordWildCards        #-}
{-# OPTIONS_GHC -fno-warn-orphans   #-}
module LuminescentDreams.Logger (
    LogLevel(..), Logger(..), LogMsg, formatMsg, logMsg
  )
  where

-- import           Control.Monad.IO.Class   (MonadIO, liftIO)
import           Data.Monoid
import qualified Data.Text.Format         as TF
import qualified Data.Text.Lazy           as T
import qualified Data.Text.Buildable      as TFB
import qualified Data.Time                as Time
import qualified Data.List                as List


{-
A writer monad running over a LogMsg. It can write to a variety of things. That has to be part of the structure. Pattern:

msg -> writer -> writer

writer -> writer is a data structure, specifically WriterM.
-}
--
-- class (Monoid w, Monad m) => MonadLogger w m where
--   logMsg :: LogMsg -> w -> m a
--
--
data LogLevel = LogDebug
              | LogInfo
              | LogWarning
              | LogError
              | LogEmergency
              deriving (Eq, Ord)

data Logger = Logger (T.Text -> IO ()) LogLevel

data LogMsg = LogMsg LogLevel [(String, String)] String

logMsg :: Logger -> LogLevel -> [(String, String)] -> String -> IO ()
logMsg l lvl tags text = logMsg_ l (LogMsg lvl tags text)

logMsg_ :: Logger -> LogMsg -> IO ()
logMsg_ (Logger writer pri) msg@(LogMsg lvl _ _) =
  if lvl >= pri
    then do
      t <-  Time.getCurrentTime
      writer $ formatMsg t msg
    else return ()


formatMsg :: Time.UTCTime -> LogMsg -> T.Text
formatMsg t (LogMsg lvl tags text) =
  TF.format "{} {} {} {}" (Time.formatTime Time.defaultTimeLocale "%Y-%m-%d %H:%M:%S" t, lvl, tags, text)


instance TFB.Buildable LogLevel where
  build LogDebug      = TFB.build ("DEBUG" :: String)
  build LogInfo       = TFB.build ("INFO" :: String)
  build LogWarning    = TFB.build ("WARNING" :: String)
  build LogError      = TFB.build ("ERROR" :: String)
  build LogEmergency  = TFB.build ("EMERGENCY" :: String)

instance TFB.Buildable (String, String) where
  build (name, value) = TFB.build $ "(" <> name <> ", " <> value <> ")"

instance TFB.Buildable [(String, String)] where
  -- build lst = TFB.build "[" <> TFB.build `fmap` lst "]"
  build lst =
    mconcat $ [TFB.build ("[" :: String)]
           <>  (List.intersperse (TFB.build (", " :: String)) (TFB.build `fmap` lst))
           <> [TFB.build ("]" :: String)]