ENH use rio for logging deps stage

bin/xmobar.hs

@@ -20,10 +20,10 @@ import           Data.Internal.Dependency
 import           Data.List
 import           Data.Maybe
 
+import           RIO                                            hiding (hFlush)
 import qualified RIO.Text                                       as T
 
 import           System.Environment
-import           System.Exit
 import           System.IO
 import           System.IO.Error
 
@@ -218,7 +218,7 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
   where
     root useIcon = IORoot_ (batteryCmd useIcon)
     tree = Only_ $ IOTest_ "Test if battery is present" []
-      $ fmap (Msg Error) <$> hasBattery
+      $ fmap (Msg LevelError) <$> hasBattery
 
 getVPN :: Maybe SysClient -> BarFeature
 getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
@@ -426,13 +426,13 @@ vpnPresent =
   where
     args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
     go (Right (ExitSuccess, out, _))   = if "vpn" `elem` T.lines out then Nothing
-                                         else Just $ Msg Error "vpn not found"
+                                         else Just $ Msg LevelError "vpn not found"
-    go (Right (ExitFailure c, _, err)) = Just $ Msg Error
+    go (Right (ExitFailure c, _, err)) = Just $ Msg LevelError
                                          $ T.concat ["vpn search exited with code "
                                                     , T.pack $ show c
                                                     , ": "
                                                     , err]
-    go (Left e)                        = Just $ Msg Error $ T.pack $ show e
+    go (Left e)                        = Just $ Msg LevelError $ T.pack $ show e
 
 --------------------------------------------------------------------------------
 -- | text font

bin/xmonad.hs

@@ -7,7 +7,6 @@
 
 module Main (main) where
 
-import           Control.Concurrent
 import           Control.Monad
 
 import           Data.Internal.DBus
@@ -166,7 +165,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
           , focusedBorderColor = T.unpack XT.selectedBordersColor
           }
   where
-    forkIO_ = void . forkIO
+    forkIO_ = void . async
     startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
       $ fsDBusExporters fs
     startChildDaemons fs = do
@@ -185,11 +184,12 @@ printDeps :: FIO ()
 printDeps = do
   db <- io connectDBus
   (i, f, d) <- allFeatures db
-  let is = concatMap dumpSometimes i
+  io $ mapM_ (putStrLn . T.unpack)
-  let fs = concatMap dumpFeature f
+    $ fmap showFulfillment
-  let ds = concatMap dumpSometimes d
+    $ sort
-  let ps = fmap showFulfillment $ sort $ nub $ is ++ fs ++ ds
+    $ nub
-  io $ mapM_ (putStrLn . T.unpack) ps
+    $ concat
+    $ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
   io $ disconnectDBus db
 
 allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])

lib/Data/Internal/Dependency.hs

@@ -25,7 +25,6 @@ module Data.Internal.Dependency
   , Subfeature(..)
   , SubfeatureRoot
   , Msg(..)
-  , LogLevel(..)
 
   -- configuration
   , XParams(..)
@@ -125,7 +124,7 @@ import           GHC.IO.Exception        (ioe_description)
 import           DBus                    hiding (typeOf)
 import qualified DBus.Introspection      as I
 
-import           RIO                     hiding (LogLevel, bracket, fromString)
+import           RIO                     hiding (bracket, fromString)
 import           RIO.FilePath
 import qualified RIO.Text                as T
 
@@ -150,8 +149,11 @@ import           XMonad.Internal.Theme
 -- Currently there is no easy way to not use this (oh well)
 withCache :: FIO a -> IO a
 withCache x = do
+  logOpts <- logOptionsHandle stderr False
+  withLogFunc logOpts $ \f -> do
     p <- getParams
-  runRIO p x
+    let s = DepStage f p
+    runRIO s x
 
 -- | Execute an Always immediately
 executeAlways :: Always (IO a) -> FIO a
@@ -172,25 +174,27 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
   where
     goPass (a, ws) = putErrors ws >> return (Just a)
     goFail es = putErrors es >> return Nothing
-    putErrors = mapM_ printMsg
+    putErrors = mapM_ logMsg
 
 -- | Return the action of an Always
 evalAlways :: Always a -> FIO a
 evalAlways a = do
   (x, ws) <- evalAlwaysMsg a
-  mapM_ printMsg ws
+  mapM_ logMsg ws
   return x
 
--- TODO use real logging functions
+logMsg :: FMsg -> FIO ()
-printMsg :: FMsg -> FIO ()
+logMsg (FMsg fn n (Msg ll m)) = do
-printMsg (FMsg fn n (Msg ll m)) = do
-  xl <- asks xpLogLevel
   p <- io getProgName
-  io $ when (ll <= xl) $
+  f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
-    putStrLn $ T.unpack $ T.concat $ s (T.pack p)
   where
-    s p = [ bracket p
+    llFun LevelError = ("ERROR", logError)
-          , bracket $ T.pack $ show ll
+    llFun LevelInfo  = ("INFO", logInfo)
+    llFun LevelWarn  = ("WARN", logWarn)
+    llFun _          = ("DEBUG", logDebug)
+    (s, f) = llFun ll
+    fmt p l = [ bracket p
+              , bracket l
               , bracket fn
               ]
               ++ maybe [] ((:[]) . bracket) n
@@ -265,11 +269,6 @@ data Subfeature f = Subfeature
   , sfName :: T.Text
   }
 
--- | Loglevel at which feature testing should be reported
--- This is currently not used for anything important
-data LogLevel = Silent | Error | Warn | Debug | Info
-  deriving (Eq, Show, Ord, Generic)
-
 type SubfeatureRoot a = Subfeature (Root a)
 
 -- | An action and its dependencies
@@ -383,19 +382,37 @@ data PostFail = PostFail [Msg] | PostMissing Msg
 --------------------------------------------------------------------------------
 -- | Configuration
 
-type FIO a = RIO XParams a
+type FIO a = RIO DepStage a
+
+data DepStage = DepStage
+  { dsLogFun :: !LogFunc
+  , dsParams :: !XParams
+  }
+
+instance HasLogFunc DepStage where
+  logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y })
+
 
 data XParams = XParams
   { xpLogLevel :: LogLevel
   , xpFeatures :: XPFeatures
   }
 
-instance FromJSON XParams where
+data JLogLevel = Error | Warn | Debug | Info
-  parseJSON = withObject "parameters" $ \o -> XParams
+  deriving (Eq, Show, Ord, Generic)
-    <$> o .: fromString "loglevel"
-    <*> o .: fromString "features"
 
-instance FromJSON LogLevel
+instance FromJSON JLogLevel
+
+instance FromJSON XParams where
+  parseJSON = withObject "parameters" $ \o -> do
+    ll <- mapLevel <$> o .: fromString "loglevel"
+    fs <- o .: fromString "features"
+    return $ XParams ll fs
+      where
+        mapLevel Info  = LevelInfo
+        mapLevel Error = LevelError
+        mapLevel Warn  = LevelWarn
+        mapLevel Debug = LevelDebug
 
 data XPFeatures = XPFeatures
   { xpfOptimus        :: Bool
@@ -427,7 +444,7 @@ instance FromJSON XPFeatures where
 
 defParams :: XParams
 defParams = XParams
-  { xpLogLevel = Error
+  { xpLogLevel = LevelError
   , xpFeatures = defXPFeatures
   }
 
@@ -480,7 +497,7 @@ infix .:+
 
 evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
 evalSometimesMsg (Sometimes n u xs) = do
-  r <- asks (u . xpFeatures)
+  r <- asks (u . xpFeatures . dsParams)
   if not r then return $ Left [dis n] else do
     PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
     let fs' = failedMsgs n fs
@@ -488,7 +505,7 @@ evalSometimesMsg (Sometimes n u xs) = do
       (Just p) -> Right $ second (++ fs') $ passActMsg n p
       _        -> Left fs'
   where
-    dis name = FMsg name Nothing (Msg Debug "feature disabled")
+    dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
 
 evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
 evalAlwaysMsg (Always n x) = do
@@ -555,7 +572,7 @@ testRoot r = do
     (DBusRoot a t (Just cl))  -> go (`a` cl) (testDBusDep_ cl) testIODep t
     (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
     _                         -> return $ Left $ PostMissing
-                                 $ Msg Error "client not available"
+                                 $ Msg LevelError "client not available"
   where
     -- rank N polymorphism is apparently undecidable...gross
     go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
@@ -640,11 +657,11 @@ testSysDependency :: SystemDependency -> IO (Maybe Msg)
 testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
   <$> findExecutable bin
   where
-    msg = Msg Error $ T.concat [e, "executable", singleQuote $ T.pack bin, "not found"]
+    msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
     e = if sys then "system" else "local"
 testSysDependency (Systemd t n) = shellTest cmd msg
   where
-    msg = T.concat ["systemd", unitType t, "unit", singleQuote n, "not found"]
+    msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
     cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
 testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n])
   $ T.unwords ["Process", singleQuote n, "not found"]
@@ -652,7 +669,7 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
   where
     testPerm False _ _  = Nothing
     testPerm True f res = Just $ f res
-    mkErr = Just . Msg Error
+    mkErr = Just . Msg LevelError
     permMsg NotFoundError            = mkErr "file not found"
     permMsg PermError                = mkErr "could not get permissions"
     permMsg (PermResult res) =
@@ -667,7 +684,7 @@ shellTest cmd msg = do
   (rc, _, _) <- readCreateProcessWithExitCode' (shell $ T.unpack cmd) ""
   return $ case rc of
     ExitSuccess -> Nothing
-    _           -> Just $ Msg Error msg
+    _           -> Just $ Msg LevelError msg
 
 unitType :: UnitType -> T.Text
 unitType SystemUnit = "system"
@@ -754,10 +771,10 @@ readInterface n f = IORead n [] go
     go = io $ do
       ns <- filter f <$> listInterfaces
       case ns of
-        [] -> return $ Left [Msg Error "no interfaces found"]
+        [] -> return $ Left [Msg LevelError "no interfaces found"]
         (x:xs) -> do
           return $ Right $ PostPass x
-            $ fmap (Msg Warn . T.append "ignoring extra interface: ") xs
+            $ fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
 
 --------------------------------------------------------------------------------
 -- | Misc testers
@@ -774,7 +791,7 @@ socketExists' getPath = do
     Left e  -> toErr $ T.pack $ ioe_description e
     Right s -> if isSocket s then Nothing else toErr $ T.append (T.pack p) " is not a socket"
   where
-    toErr = Just . Msg Error
+    toErr = Just . Msg LevelError
 
 --------------------------------------------------------------------------------
 -- | DBus Dependency Testing
@@ -792,11 +809,11 @@ testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
 testDBusDepNoCache_ cl (Bus _ bus) = io $ do
   ret <- callMethod cl queryBus queryPath queryIface queryMem
   return $ case ret of
-        Left e    -> Left [Msg Error e]
+        Left e    -> Left [Msg LevelError e]
         Right b -> let ns = bodyGetNames b in
           if bus' `elem` ns then Right []
           else Left [
-            Msg Error $ T.unwords ["name", singleQuote bus', "not found on dbus"]
+            Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
             ]
   where
     bus' = T.pack $ formatBusName bus
@@ -810,14 +827,14 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
 testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
   ret <- callMethod cl busname objpath introspectInterface introspectMethod
   return $ case ret of
-        Left e     -> Left [Msg Error e]
+        Left e     -> Left [Msg LevelError e]
         Right body -> procBody body
   where
     procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
                           =<< listToMaybe body in
       case res of
         Just True -> Right []
-        _         -> Left [Msg Error $ fmtMsg' mem]
+        _         -> Left [Msg LevelError $ fmtMsg' mem]
     findMem = fmap (matchMem mem)
       . find (\i -> I.interfaceName i == iface)
       . I.objectInterfaces
@@ -927,7 +944,7 @@ voidResult (Left es)               = Left es
 voidResult (Right (PostPass _ ws)) = Right ws
 
 voidRead :: Result p -> Maybe Msg
-voidRead (Left [])    = Just $ Msg Error "unspecified error"
+voidRead (Left [])    = Just $ Msg LevelError "unspecified error"
 voidRead (Left (e:_)) = Just e
 voidRead (Right _)    = Nothing
 

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -16,6 +16,7 @@ import           Data.Internal.Dependency
 
 import           Text.XML.Light
 
+import           RIO                      hiding (try)
 import           RIO.FilePath
 import qualified RIO.Text                 as T
 
@@ -24,7 +25,7 @@ import           System.Directory
 import           XMonad.Internal.Shell
 
 vmExists :: T.Text -> IO (Maybe Msg)
-vmExists vm = either (Just . Msg Error) (const Nothing) <$> vmInstanceConfig vm
+vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm
 
 vmInstanceConfig :: T.Text -> IO (Either T.Text FilePath)
 vmInstanceConfig vmName = do