Infrastructure for better logging, finally!

Right now all existing logs are logged at Info, but this will
change. This should make it significantly easier to debug
things wit log levels like Trace. I may at some point define more
log level endpoints or come up with a more expressive logging
system, but this is a good start.

1 files changed, 32 insertions, 16 deletions

diff --git a/src/Rahm/Desktop/Logger.hs b/src/Rahm/Desktop/Logger.hs
index c73942f..3da70d1 100644
--- a/src/Rahm/Desktop/Logger.hs
+++ b/src/Rahm/Desktop/Logger.hs
@@ -1,32 +1,48 @@
 module Rahm.Desktop.Logger where
 
+import Control.Monad (when)
 import XMonad
 import qualified XMonad.Util.ExtensibleState as XS
 import System.IO
 
 import Rahm.Desktop.NoPersist
+import Text.Printf
+
+data LogLevel = Trace | Debug | Info | Warn | Error | Fatal
+  deriving (Show, Read, Ord, Eq, Enum)
 
 newtype LoggerState =
   LoggerState {
-    logHandle :: Maybe (NoPersist Handle)
-  }
+    logLevel :: LogLevel
+  } deriving (Show, Read, Eq)
 
 instance ExtensionClass LoggerState where
-  initialValue = LoggerState Nothing
+  initialValue = LoggerState Info
+  extensionType = PersistentExtension
+
+class (PrintfType (Printf t)) => LoggerType t where
+  type EndResult t :: *
+  type Printf t :: *
+
+  gp :: (String -> EndResult t) -> Printf t -> 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)
 
-logs :: String -> X ()
-logs s = do
-  LoggerState handle' <- XS.get
+instance (a ~ ()) => LoggerType (X a) where
+  type EndResult (X a) = X ()
+  type Printf (X a) = String
 
-  handle <-
-    case handle' of
-      Nothing -> do
-        handle <- io $ openFile "/tmp/xmonad.log" AppendMode
-        XS.put $ LoggerState $ Just $ NoPersist handle
-        return handle
+  gp fn str = fn str
 
-      Just (NoPersist h) -> return h
+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)
 
-  io $ do
-    hPutStrLn handle s
-    hFlush handle
+test :: X ()
+test = logs Info "Test %s"