ENH tweak logging

bin/xmobar.hs

@@ -65,21 +65,26 @@ parseTest =
     (long "test" <> short 't' <> help "test dependencies without running")
 
 xio :: XOpts -> IO ()
-xio o = withCache $
+xio o = runXIO $
   case o of
     XDeps -> printDeps
     XTest -> withDBus_ evalConfig
     XRun -> run
 
-run :: FIO ()
+run :: XIO ()
 run = do
   -- IDK why this is needed, I thought this was default
   liftIO $ hSetBuffering stdout LineBuffering
+  -- this isn't totally necessary except for the fact that killing xmobar
+  -- will make it print something about catching SIGTERM, and without
+  -- linebuffering it usually only prints the first few characters (even then
+  -- it only prints 10-20% of the time)
+  liftIO $ hSetBuffering stderr LineBuffering
   withDBus_ $ \db -> do
     c <- evalConfig db
     liftIO $ xmobar c
 
-evalConfig :: DBusState -> FIO Config
+evalConfig :: DBusState -> XIO Config
 evalConfig db = do
   cs <- getAllCommands <$> rightPlugins db
   bf <- getTextFont
@@ -87,7 +92,7 @@ evalConfig db = do
   d <- io $ cfgDir <$> getDirectories
   return $ config bf ifs ios cs d
 
-printDeps :: FIO ()
+printDeps :: XIO ()
 printDeps = withDBus_ $ \db ->
   mapM_ logInfo $
     fmap showFulfillment $
@@ -186,7 +191,7 @@ getAllCommands right =
     , brRight = catMaybes right
     }
 
-rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
+rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
 rightPlugins db =
   mapM evalFeature $
     allFeatures db
@@ -523,7 +528,7 @@ dateCmd =
 --------------------------------------------------------------------------------
 -- low-level testing functions
 
-vpnPresent :: FIO (Maybe Msg)
+vpnPresent :: XIO (Maybe Msg)
 vpnPresent = do
   res <- proc "nmcli" args readProcess
   return $ case res of
@@ -549,7 +554,7 @@ vpnPresent = do
 -- ASSUME there is only one text font for this entire configuration. This
 -- will correspond to the first font/offset parameters in the config record.
 
-getTextFont :: FIO T.Text
+getTextFont :: XIO T.Text
 getTextFont = do
   fb <- evalAlways textFont
   return $ fb textFontData
@@ -557,7 +562,7 @@ getTextFont = do
 --------------------------------------------------------------------------------
 -- icon fonts
 
-getIconFonts :: FIO ([T.Text], [Int])
+getIconFonts :: XIO ([T.Text], [Int])
 getIconFonts = do
   fb <- evalSometimes iconFont
   return $ maybe ([], []) apply fb

bin/xmonad.hs

@@ -91,13 +91,13 @@ parseTest =
     (long "test" <> short 't' <> help "test dependencies without running")
 
 xio :: XOpts -> IO ()
-xio o = withCache $
+xio o = runXIO $
   case o of
     XDeps -> printDeps
     XTest -> undefined
     XRun -> run
 
-run :: FIO ()
+run :: XIO ()
 run = do
   -- These first two commands are only significant when xmonad is restarted.
   -- The 'launch' function below this will turn off buffering (so flushes are
@@ -172,10 +172,10 @@ getCreateDirectories = do
 
 data FeatureSet = FeatureSet
   { fsKeys :: X () -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe SesClient -> Sometimes (FIO (), FIO ())]
+  , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
   , fsPowerMon :: SometimesIO
   , fsRemovableMon :: Maybe SysClient -> SometimesIO
-  , fsDaemons :: [Sometimes (FIO (Process () () ()))]
+  , fsDaemons :: [Sometimes (XIO (Process () () ()))]
   , fsACPIHandler :: Always (String -> X ())
   , fsTabbedTheme :: Always Theme
   , fsDynWorkspaces :: [Sometimes DynWorkspace]
@@ -203,11 +203,12 @@ features cl =
     , fsDaemons = [runNetAppDaemon cl, runAutolock]
     }
 
-withXmobar :: (Process Handle () () -> FIO a) -> FIO a
+withXmobar :: (Process Handle () () -> XIO a) -> XIO a
 withXmobar = bracket startXmobar stopXmobar
 
-startXmobar :: FIO (Process Handle () ())
+startXmobar :: XIO (Process Handle () ())
 startXmobar = do
+  logInfo "starting xmobar child process"
   p <- proc "xmobar" [] start
   io $ hSetBuffering (getStdin p) LineBuffering
   return p
@@ -225,21 +226,37 @@ stopXmobar p = do
   logInfo "stopping xmobar child process"
   io $ killNoWait p
 
-withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
+withChildDaemons
+  :: FeatureSet
+  -> ([(Utf8Builder, Process () () ())] -> XIO a)
+  -> XIO a
 withChildDaemons fs = bracket (startChildDaemons fs) stopChildDaemons
 
-startChildDaemons :: FeatureSet -> FIO [Process () () ()]
+startChildDaemons :: FeatureSet -> XIO [(Utf8Builder, Process () () ())]
-startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
+startChildDaemons fs = catMaybes <$> mapM start (fsDaemons fs)
+  where
+    start s@(Sometimes sname _ _) = do
+      let sname_ = Utf8Builder $ encodeUtf8Builder sname
+      res <- executeSometimes s
+      case res of
+        Just p -> do
+          logInfo $ "starting child process: " <> sname_
+          return $ Just (sname_, p)
+        -- don't log anything here since presumably the feature itself will log
+        -- an error if it fails during execution
+        _ -> return Nothing
 
 stopChildDaemons
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [Process () () ()]
+  => [(Utf8Builder, Process () () ())]
   -> m ()
-stopChildDaemons ps = do
+stopChildDaemons = mapM_ stop
-  logInfo "stopping child processes"
+  where
-  mapM_ (liftIO . killNoWait) ps
+    stop (n, p) = do
+      logInfo $ "stopping child process: " <> n
+      liftIO $ killNoWait p
 
-printDeps :: FIO ()
+printDeps :: XIO ()
 printDeps = withDBus_ $ \db -> do
   runIO <- askRunInIO
   let mockCleanup = runCleanup runIO mockClean db
@@ -248,7 +265,7 @@ printDeps = withDBus_ $ \db -> do
           externalBindings mockCleanup db
   let dbus =
         fmap (\f -> f $ dbSesClient db) dbusExporters
-          :: [Sometimes (FIO (), FIO ())]
+          :: [Sometimes (XIO (), XIO ())]
   let others = [runRemovableMon $ dbSysClient db, runPowermon]
   -- TODO might be better to use glog for this?
   mapM_ logInfo $
@@ -267,13 +284,13 @@ printDeps = withDBus_ $ \db -> do
 -- Concurrency configuration
 
 data Cleanup = Cleanup
-  { clChildren :: [Process () () ()]
+  { clChildren :: [(Utf8Builder, Process () () ())]
   , clXmobar :: Maybe (Process Handle () ())
-  , clDBusUnexporters :: [FIO ()]
+  , clDBusUnexporters :: [XIO ()]
   }
 
 runCleanup
-  :: (FIO () -> IO ())
+  :: (XIO () -> IO ())
   -> Cleanup
   -> DBusState
   -> X ()
@@ -756,13 +773,13 @@ data KeyGroup a = KeyGroup
   , kgBindings :: [KeyBinding a]
   }
 
-evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
+evalExternal :: [KeyGroup FeatureX] -> XIO [KeyGroup MaybeX]
 evalExternal = mapM go
   where
     go k@KeyGroup {kgBindings = bs} =
       (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
 
-evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
+evalKeyBinding :: KeyBinding FeatureX -> XIO (KeyBinding MaybeX)
 evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
   (\f -> k {kbMaybeAction = f}) <$> evalFeature a
 

lib/Data/Internal/Dependency.hs

@@ -53,8 +53,8 @@ module Data.Internal.Dependency
   , dumpSometimes
   , showFulfillment
   -- testing
-  , FIO
+  , XIO
-  , withCache
+  , runXIO
   , evalFeature
   , executeSometimes
   , executeAlways
@@ -128,9 +128,9 @@ import XMonad.Internal.Theme
 
 -- | Run feature evaluation(s) with the cache
 -- Currently there is no easy way to not use this (oh well)
-withCache :: FIO a -> IO a
+runXIO :: XIO a -> IO a
-withCache x = do
+runXIO x = do
-  logOpts <- logOptionsHandle stderr False
+  logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle stderr False
   pc <- mkDefaultProcessContext
   withLogFunc logOpts $ \f -> do
     p <- getParams
@@ -138,20 +138,20 @@ withCache x = do
     runRIO s x
 
 -- | Execute an Always immediately
-executeAlways :: Always (IO a) -> FIO a
+executeAlways :: Always (IO a) -> XIO a
 executeAlways = io <=< evalAlways
 
 -- | Execute a Sometimes immediately (or do nothing if failure)
-executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
+executeSometimes :: Sometimes (XIO a) -> XIO (Maybe a)
 executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
 
 -- | Possibly return the action of an Always/Sometimes
-evalFeature :: Feature a -> FIO (Maybe a)
+evalFeature :: Feature a -> XIO (Maybe a)
 evalFeature (Right a) = Just <$> evalAlways a
 evalFeature (Left s) = evalSometimes s
 
 -- | Possibly return the action of a Sometimes
-evalSometimes :: Sometimes a -> FIO (Maybe a)
+evalSometimes :: Sometimes a -> XIO (Maybe a)
 evalSometimes x = either goFail goPass =<< evalSometimesMsg x
   where
     goPass (a, ws) = putErrors ws >> return (Just a)
@@ -159,13 +159,13 @@ evalSometimes x = either goFail goPass =<< evalSometimesMsg x
     putErrors = mapM_ logMsg
 
 -- | Return the action of an Always
-evalAlways :: Always a -> FIO a
+evalAlways :: Always a -> XIO a
 evalAlways a = do
   (x, ws) <- evalAlwaysMsg a
   mapM_ logMsg ws
   return x
 
-logMsg :: FMsg -> FIO ()
+logMsg :: FMsg -> XIO ()
 logMsg (FMsg fn n (Msg ll m)) = do
   p <- io getProgName
   f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p)
@@ -210,7 +210,7 @@ type AlwaysIO = Always (IO ())
 
 type SometimesX = Sometimes (X ())
 
-type SometimesIO = Sometimes (FIO ())
+type SometimesIO = Sometimes (XIO ())
 
 type Feature a = Either (Sometimes a) (Always a)
 
@@ -290,7 +290,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
 -- | A dependency that only requires IO to evaluate (with payload)
 data IODependency p
   = -- an IO action that yields a payload
-    IORead T.Text [Fulfillment] (FIO (Result p))
+    IORead T.Text [Fulfillment] (XIO (Result p))
   | -- always yields a payload
     IOConst p
   | -- an always that yields a payload
@@ -308,7 +308,7 @@ data DBusDependency_ c
 -- | A dependency that only requires IO to evaluate (no payload)
 data IODependency_
   = IOSystem_ [Fulfillment] SystemDependency
-  | IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
+  | IOTest_ T.Text [Fulfillment] (XIO (Maybe Msg))
   | forall a. IOSometimes_ (Sometimes a)
 
 -- | A system component to an IODependency
@@ -377,7 +377,7 @@ data PostFail = PostFail [Msg] | PostMissing Msg
 --------------------------------------------------------------------------------
 -- Configuration
 
-type FIO a = RIO DepStage a
+type XIO a = RIO DepStage a
 
 data DepStage = DepStage
   { dsLogFun :: !LogFunc
@@ -508,7 +508,7 @@ infix 9 .:+
 --------------------------------------------------------------------------------
 -- Testing pipeline
 
-evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
+evalSometimesMsg :: Sometimes a -> XIO (Either [FMsg] (a, [FMsg]))
 evalSometimesMsg (Sometimes n u xs) = do
   r <- asks (u . xpFeatures . dsParams)
   if not r
@@ -522,7 +522,7 @@ evalSometimesMsg (Sometimes n u xs) = do
   where
     dis name = FMsg name Nothing (Msg LevelDebug "feature disabled")
 
-evalAlwaysMsg :: Always a -> FIO (a, [FMsg])
+evalAlwaysMsg :: Always a -> XIO (a, [FMsg])
 evalAlwaysMsg (Always n x) = do
   r <- testAlways x
   return $ case r of
@@ -542,7 +542,7 @@ failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
   where
     f = fmap (FMsg fn (Just n))
 
-testAlways :: Always_ a -> FIO (PostAlways a)
+testAlways :: Always_ a -> XIO (PostAlways a)
 testAlways = go []
   where
     go failed (Option fd next) = do
@@ -552,18 +552,18 @@ testAlways = go []
         (Right pass) -> return $ Primary pass failed next
     go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
 
-evalFallbackRoot :: FallbackRoot a -> FIO a
+evalFallbackRoot :: FallbackRoot a -> XIO a
 evalFallbackRoot (FallbackAlone a) = return a
 evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s
 
-evalFallbackStack :: FallbackStack p -> FIO p
+evalFallbackStack :: FallbackStack p -> XIO p
 evalFallbackStack (FallbackBottom a) = evalAlways a
 evalFallbackStack (FallbackStack f a as) = do
   ps <- evalFallbackStack as
   p <- evalAlways a
   return $ f p ps
 
-testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
+testSometimes :: Sometimes_ a -> XIO (PostSometimes a)
 testSometimes = go (PostSometimes Nothing [])
   where
     go ts [] = return ts
@@ -573,13 +573,13 @@ testSometimes = go (PostSometimes Nothing [])
         (Left l) -> go (ts {psFailed = l : psFailed ts}) xs
         (Right pass) -> return $ ts {psSuccess = Just pass}
 
-testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
+testSubfeature :: SubfeatureRoot a -> XIO (Either SubfeatureFail (SubfeaturePass a))
 testSubfeature sf@Subfeature {sfData = t} = do
   t' <- testRoot t
   -- monomorphism restriction :(
   return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
 
-testRoot :: Root a -> FIO (Either PostFail (PostPass a))
+testRoot :: Root a -> XIO (Either PostFail (PostPass a))
 testRoot r = do
   case r of
     (IORoot a t) -> go a testIODep_ testIODep t
@@ -593,7 +593,7 @@ testRoot r = do
             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 =
+    go a f_ (f :: forall q. d q -> XIO (MResult q)) t =
       bimap PostFail (fmap a) <$> testTree f_ f t
     go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
 
@@ -606,13 +606,13 @@ type MResult p = Memoized (Result p)
 
 testTree
   :: forall d d_ p
-   . (d_ -> FIO MResult_)
+   . (d_ -> XIO MResult_)
-  -> (forall q. d q -> FIO (MResult q))
+  -> (forall q. d q -> XIO (MResult q))
   -> Tree d d_ p
-  -> FIO (Either [Msg] (PostPass p))
+  -> XIO (Either [Msg] (PostPass p))
 testTree test_ test = go
   where
-    go :: forall q. Tree d d_ q -> FIO (Result q)
+    go :: forall q. Tree d d_ q -> XIO (Result q)
     go (And12 f a b) = do
       ra <- go a
       liftRight (\pa -> (and2nd f pa =<<) <$> go b) ra
@@ -629,7 +629,7 @@ testTree test_ test = go
     and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
     liftRight = either (return . Left)
 
-testIODep :: IODependency p -> FIO (MResult p)
+testIODep :: IODependency p -> XIO (MResult p)
 testIODep d = memoizeMVar $ case d of
   IORead _ _ t -> t
   IOConst c -> return $ Right $ PostPass c []
@@ -657,7 +657,7 @@ type Result_ = Either [Msg] [Msg]
 
 type MResult_ = Memoized Result_
 
-testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_
+testTree_ :: (d -> XIO MResult_) -> Tree_ d -> XIO Result_
 testTree_ test = go
   where
     go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
@@ -665,10 +665,10 @@ testTree_ test = go
     go (Only_ a) = runMemoized =<< test a
     test2nd ws = fmap ((Right . (ws ++)) =<<) . go
 
-testIODep_ :: IODependency_ -> FIO MResult_
+testIODep_ :: IODependency_ -> XIO MResult_
 testIODep_ d = memoizeMVar $ testIODepNoCache_ d
 
-testIODepNoCache_ :: IODependency_ -> FIO Result_
+testIODepNoCache_ :: IODependency_ -> XIO Result_
 testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
 testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
 testIODepNoCache_ (IOSometimes_ x) =
@@ -763,7 +763,7 @@ fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont
 fontTestName :: T.Text -> T.Text
 fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
 
--- testFont :: T.Text -> FIO (Result FontBuilder)
+-- testFont :: T.Text -> XIO (Result FontBuilder)
 -- testFont = liftIO . testFont'
 
 testFont
@@ -821,7 +821,7 @@ readInterface n f = IORead n [] go
 --------------------------------------------------------------------------------
 -- Misc testers
 
-socketExists :: T.Text -> [Fulfillment] -> FIO FilePath -> IODependency_
+socketExists :: T.Text -> [Fulfillment] -> XIO FilePath -> IODependency_
 socketExists n ful =
   IOTest_ (T.unwords ["test if", n, "socket exists"]) ful . socketExists'
 
@@ -845,10 +845,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> FIO MResult_
+testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
 testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
 
-testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
+testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
 testDBusDepNoCache_ cl (Bus _ bus) = io $ do
   ret <- callMethod cl queryBus queryPath queryIface queryMem
   return $ case ret of

lib/XMonad/Internal/Command/Desktop.hs

@@ -264,7 +264,7 @@ runNotificationContext =
 -- System commands
 
 -- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
+runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
 runNetAppDaemon cl =
   Sometimes
     "network applet"

lib/XMonad/Internal/Command/Power.hs

@@ -84,7 +84,7 @@ runReboot = spawn "systemctl reboot"
 --------------------------------------------------------------------------------
 -- Autolock
 
-runAutolock :: Sometimes (FIO (P.Process () () ()))
+runAutolock :: Sometimes (XIO (P.Process () () ()))
 runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
   where
     tree =

lib/XMonad/Internal/DBus/Control.hs

@@ -102,9 +102,9 @@ disconnectDBusX db = do
 
 withDBusInterfaces
   :: DBusState
-  -> [Maybe SesClient -> Sometimes (FIO (), FIO ())]
+  -> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
-  -> ([FIO ()] -> FIO a)
+  -> ([XIO ()] -> XIO a)
-  -> FIO a
+  -> XIO a
 withDBusInterfaces db interfaces = bracket up sequence
   where
     up = do