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.

4 files changed, 46 insertions, 30 deletions

diff --git a/src/Rahm/Desktop/Keys.hs b/src/Rahm/Desktop/Keys.hs
index a453df1..c8abbf0 100644
--- a/src/Rahm/Desktop/Keys.hs
+++ b/src/Rahm/Desktop/Keys.hs
@@ -172,7 +172,7 @@ keymap = runKeys $ do
     -- things all for BS security theater, but I guess there might be some way
     -- to do this via XTest?
     shiftMod $ forAllWindows  $ \w -> do
-      logs $ "Try send to " ++ show w
+      logs Info "Try send to %s" (show w)
       sendKey (0, xK_a) w
 
     justMod $
@@ -185,7 +185,7 @@ keymap = runKeys $ do
 
     justMod $
       doc "Print this documentation." $
-      logs (documentation (keymap config))
+      (logs Info "%s" (documentation (keymap config)) :: X ())
 
   bind xK_F10 $ do
     justMod playPauseDoc
@@ -221,7 +221,7 @@ keymap = runKeys $ do
         withScreen W.shift idx
 
       altgrMod $
-        logs "Test altgr"
+        (logs Info "Test altgr" :: X ())
 
   bind xK_bracketright $ do
     justMod $
@@ -391,7 +391,7 @@ keymap = runKeys $ do
       bind xK_q $
         (justMod -|- noMod) $
           doc "EXPERIMENTAL: Move mouse to control media." $
-            mouseRotateMotion (logs "CW") (logs "CCW")
+            mouseRotateMotion (logs Info "CW") (logs Info "CCW")
 
   bind xK_r $ do
     justMod $ doc "Run a command via Rofi" runDMenu
@@ -516,7 +516,7 @@ keymap = runKeys $ do
             doc "Go to the prior window in the history" historyBack
 
         bind xK_t $ do
-          (justMod -|- noMod) $ logs "Test Log"
+          (justMod -|- noMod) $ (logs Info "Test Log" :: X ())
 
         -- bind xK_n $ do
         --   (justMod -|- noMod) $
@@ -845,7 +845,7 @@ windowSpecificBindings config = do
 
     bind xK_F2 $
       -- Experimental.
-      noMod $ logs "This is a test"
+      noMod $ (logs Info "This is a test" :: X ())
 
   -- Add a binding to xev as a test.
   configureIf (title =? "Event Tester") $
@@ -878,9 +878,9 @@ windowBindings xconfig =
       map <- execWriterT $ windowSpecificBindings xconfig
       w <- ask
 
-      liftX $ logs $ printf "For Window: %s" (show w)
+      liftX $ logs Info "For Window: %s" (show w)
       forM_ (Map.toList map) $ \(key, action) -> do
-        liftX $ logs $ printf "   -- remap: %s" (show key)
+        liftX $ logs Info "   -- remap: %s" (show key)
         remapKey key action
 
 applyKeys :: XConfig l -> IO (XConfig l)
diff --git a/src/Rahm/Desktop/Keys/Wml.hs b/src/Rahm/Desktop/Keys/Wml.hs
index 7659a7d..dd82922 100644
--- a/src/Rahm/Desktop/Keys/Wml.hs
+++ b/src/Rahm/Desktop/Keys/Wml.hs
@@ -107,12 +107,12 @@ alternateWorkspace :: Workspace
 alternateWorkspace =
   Workspace {
     moveLocationToWorkspaceFn  = \l@(Location _ maybeWin) -> do
-      logs $ "Moving Location: " ++ show l
+      logs Info "Moving Location: %s" (show l)
       case maybeWin of
         Nothing -> return ()
         Just win -> do
           alter <- getAlternateWorkspace win
-          logs $ printf "Moving %s to %s" (show win) (show alter)
+          logs Info "Moving %s to %s" (show win) (show alter)
           mapM_ (moveLocationToWorkspace l) alter
 
   , gotoWorkspaceFn = do
@@ -297,7 +297,7 @@ readNextLocationSet =
         mapM windowLocation =<< MaybeT askWindowId
       (_, _, "%") -> fromMaybeTX $ do
         ret <- mapM windowLocation =<< lift (withWindowSet (return . sortOn Down . W.allWindows))
-        lift $ logs $ "allWindows " ++ intercalate "\n"  (map show ret)
+        lift $ logs Info "allWindows %s" (intercalate "\n"  (map show ret))
         return ret
       (_, _, s) | s == "\t" || s == "@" || s == "\n" ->
         (mt . windowsInWorkspace . workspaceName) =<< readNextWorkspace
@@ -329,7 +329,7 @@ readNextLocationSet =
         return $ filter (`elem` l2) l1
       (mask, keysym, _) -> do
         macro <- (MaybeT . fromX) (Map.lookup (mask, keysym) . windowsetMacros <$> XS.get)
-        lift $ fromX $ logs $ "Executing Macro: " ++ show macro
+        lift $ fromX $ logs Info "Executing Macro: %s" (show macro)
         fromMaybeTX $ locationSetForKeysT macro
   where
     mt :: (KeyFeeder m) => X a -> MaybeT m a
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"
diff --git a/src/Rahm/Desktop/MouseMotion.hs b/src/Rahm/Desktop/MouseMotion.hs
index b5e8874..cacb52f 100644
--- a/src/Rahm/Desktop/MouseMotion.hs
+++ b/src/Rahm/Desktop/MouseMotion.hs
@@ -39,7 +39,7 @@ motion = MouseMotionM $ do
   ev <- nextMotionOrButton
   case ev of
     Right button -> do
-      logs ("Button " ++ show button)
+      logs Info "Button %s" (show button)
       return Nothing
 
     Left motion -> return (Just $ uncurry V2 motion)
@@ -93,4 +93,4 @@ mouseRotateMotion clockWise counterClockwise = execMouseMotionM doMouse
   where
     doMouse = forever $ do
       v <- motion
-      liftMouseMotionM $ logs $ "Motion: " ++ show v
+      liftMouseMotionM $ logs Info "Motion: %s" (show v)