Some new styling and better logging capabilites

1 files changed, 20 insertions, 17 deletions

diff --git a/src/Rahm/Desktop/Logger.hs b/src/Rahm/Desktop/Logger.hs
index 3da70d1..95a65ca 100644
--- a/src/Rahm/Desktop/Logger.hs
+++ b/src/Rahm/Desktop/Logger.hs
@@ -1,15 +1,16 @@
 module Rahm.Desktop.Logger where
 
-import Control.Monad (when)
+import Control.Monad (when, forM_, join)
 import XMonad
 import qualified XMonad.Util.ExtensibleState as XS
 import System.IO
+import Data.Time.LocalTime (getZonedTime)
 
 import Rahm.Desktop.NoPersist
 import Text.Printf
 
 data LogLevel = Trace | Debug | Info | Warn | Error | Fatal
-  deriving (Show, Read, Ord, Eq, Enum)
+  deriving (Show, Read, Ord, Eq, Enum, Bounded)
 
 newtype LoggerState =
   LoggerState {
@@ -21,28 +22,30 @@ instance ExtensionClass LoggerState where
   extensionType = PersistentExtension
 
 class (PrintfType (Printf t)) => LoggerType t where
-  type EndResult t :: *
   type Printf t :: *
-
-  gp :: (String -> EndResult t) -> Printf t -> t
+  gp :: Printf t -> (String -> X ()) -> t
 
 instance (PrintfArg a, LoggerType b) => LoggerType (a -> b) where
-  type EndResult (a -> b) = EndResult b
   type Printf (a -> b) = a -> Printf b
-
-  gp f g a = gp f (g a)
+  gp g f a = gp (g a) f
 
 instance (a ~ ()) => LoggerType (X a) where
-  type EndResult (X a) = X ()
   type Printf (X a) = String
+  gp str fn = fn str
 
-  gp fn str = fn str
+getLogLevel :: X LogLevel
+getLogLevel = logLevel <$> XS.get
 
-logs :: (LoggerType r, EndResult r ~ X ()) => LogLevel -> String -> r
-logs ll fmt = gp (\s -> do
-  LoggerState ll' <- XS.get
-  when (ll >= ll') $
-    io $ putStrLn ("[" ++ show ll ++ "] " ++ s)) (printf fmt)
+setLogLevel :: LogLevel -> X ()
+setLogLevel ll = do
+  XS.put $ LoggerState ll
+  join $ asks (logHook . config)
 
-test :: X ()
-test = logs Info "Test %s"
+logs :: (LoggerType r) => LogLevel -> String -> r
+logs ll fmt = gp (printf fmt) $ \ss -> do
+  LoggerState ll' <- XS.get
+  io $ do
+    zoneTime <- getZonedTime
+    when (ll >= ll') $
+      forM_ (lines ss) $ \s ->
+        putStrLn (printf "[%s %s] - %s" (take 23 $ show zoneTime) (show ll) s)