REF use common feature structure

bin/xmonad.hs

@@ -8,10 +8,6 @@ module Main (main) where
 
 import           Control.Concurrent
 import           Control.Monad
-    ( forM_
-    , unless
-    , void
-    )
 
 import           Data.List
     ( intercalate
@@ -85,70 +81,110 @@ parse _          = usage
 
 run :: IO ()
 run = do
-  db <- connectXDBus
+  conf <- evalConf =<< connectDBusX
-  (h, p) <- spawnPipe "xmobar"
+  ds <- getDirectories
-  ps <- catMaybes <$> mapM executeSometimes [ runNetAppDaemon
+  -- IDK why this is necessary; nothing prior to this will print if missing
+  hFlush stdout
+  launch conf ds
+
+data FeatureSet = FeatureSet
+  { fsKeys          :: ThreadState -> DBusState -> [KeyGroup FeatureX]
+  , fsDBusExporters :: [Maybe Client -> SometimesIO]
+  , fsPowerMon      :: SometimesIO
+  , fsRemovableMon  :: Maybe Client -> SometimesIO
+  , fsDaemons       :: [Sometimes (IO ProcessHandle)]
+  , fsACPIHandler   :: Always (String -> X ())
+  , fsTabbedTheme   :: Always Theme
+  , fsDynWorkspaces :: [Sometimes DynWorkspace]
+  , fsShowKeys      :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
+  }
+
+features :: FeatureSet
+features = FeatureSet
+  { fsKeys = externalBindings
+  , fsDBusExporters = dbusExporters
+  , fsPowerMon = runPowermon
+  , fsRemovableMon = runRemovableMon
+  , fsACPIHandler = runHandleACPI
+  , fsDynWorkspaces = allDWs'
+  , fsTabbedTheme = T.tabbedFeature
+  , fsShowKeys = runShowKeys
+  , fsDaemons = [ runNetAppDaemon
                 , runFlameshotDaemon
+                  -- TODO the problem with launching
+                  -- dunst here is that the history
+                  -- will get nuked on each restart
                 , runNotificationDaemon
                 , runBwDaemon
+                  -- TODO does this have a lag when
+                  -- spawned within the WM?
                 , runClipManager
                 , runAutolock
                 ]
-  void $ executeSometimes $ runRemovableMon $ dbSystemClient db
-  dws <- allDWs
-  forkIO_ $ void $ executeSometimes runPowermon
-  forkIO_ $ runWorkspaceMon dws
-  let ts = ThreadState
-           { tsChildPIDs = p:ps
-           , tsChildHandles = [h]
   }
-  fb <- evalAlways T.defFont
+
-  ext <- evalExternal $ externalBindings ts db
+evalConf db = do
-  sk <- evalAlways runShowKeys
+  -- start DBus interfaces first since many features after this test these
-  ha <- evalAlways runHandleACPI
+  -- interfaces as dependencies
-  -- IDK why this is necessary; nothing prior to this line will print if missing
+  startDBusInterfaces
-  hFlush stdout
+  (xmobarHandle, ts) <- startChildDaemons
-  ds <- getDirectories
+  startRemovableMon
-  let conf = ewmh
+  startPowerMon
-             $ addKeymap dws sk (filterExternal ext)
+  dws <- startDynWorkspaces
+  tt <- evalAlways $ fsTabbedTheme features
+  -- fb <- evalAlways $ fsFontBuilder features
+  kbs <- filterExternal <$> evalExternal (fsKeys features ts db)
+  sk <- evalAlways $ fsShowKeys features
+  ha <- evalAlways $ fsACPIHandler features
+  return $ ewmh
+    $ addKeymap dws sk kbs
     $ docks
     $ def { terminal = myTerm
           , modMask = myModMask
-                   , layoutHook = myLayouts fb
+          , layoutHook = myLayouts tt
           , manageHook = myManageHook dws
           , handleEventHook = myEventHook ha
           , startupHook = myStartupHook
           , workspaces = myWorkspaces
-                   , logHook = myLoghook h
+          , logHook = myLoghook xmobarHandle
           , clickJustFocuses = False
           , focusFollowsMouse = False
           , normalBorderColor = T.bordersColor
           , focusedBorderColor = T.selectedBordersColor
           }
-  launch conf ds
   where
     forkIO_ = void . forkIO
+    startDBusInterfaces = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
+      $ fsDBusExporters features
+    startChildDaemons = do
+      (h, p) <- spawnPipe "xmobar"
+      ps <- catMaybes <$> mapM executeSometimes (fsDaemons features)
+      return (h, ThreadState (p:ps) [h])
+    startRemovableMon = void $ executeSometimes $ fsRemovableMon features
+                        $ dbSysClient db
+    startPowerMon = forkIO_ $ void $ executeSometimes $ fsPowerMon features
+    startDynWorkspaces = do
+      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces features)
+      forkIO_ $ runWorkspaceMon dws
+      return dws
 
 printDeps :: IO ()
 printDeps = do
-  ses <- getDBusClient False
+  db <- connectDBus
-  sys <- getDBusClient True
-  let db = DBusState ses sys
   (i, f, d) <- allFeatures db
   is <- mapM dumpSometimes i
   fs <- mapM dumpFeature f
   ds <- mapM dumpSometimes d
   let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds
   putStrLn u
-  forM_ ses disconnect
+  disconnectDBus db
-  forM_ sys disconnect
 
 allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
 allFeatures db = do
   let bfs = concatMap (fmap kbMaybeAction . kgBindings)
             $ externalBindings ts db
-  let dbus = fmap (\f -> f $ dbSessionClient db) dbusExporters
+  let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
-  let others = [runRemovableMon $ dbSystemClient db, runPowermon]
+  let others = [runRemovableMon $ dbSysClient db, runPowermon]
   return (dbus ++ others, Left runScreenLock:bfs, allDWs')
   where
     ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
@@ -159,26 +195,9 @@ usage = putStrLn $ intercalate "\n"
   , "xmonad --deps: print dependencies"
   ]
 
-connectXDBus :: IO DBusState
-connectXDBus = connectDBus_ startXMonadService
-
-connectDBus_ :: IO (Maybe Client) -> IO DBusState
-connectDBus_ getSes = do
-  ses <- getSes
-  sys <- getDBusClient True
-  return DBusState
-    { dbSessionClient = ses
-    , dbSystemClient = sys
-    }
-
 --------------------------------------------------------------------------------
 -- | Concurrency configuration
 
-data DBusState = DBusState
-    { dbSessionClient :: Maybe Client
-    , dbSystemClient  :: Maybe Client
-    }
-
 data ThreadState = ThreadState
     { tsChildPIDs    :: [ProcessHandle]
     , tsChildHandles :: [Handle]
@@ -188,8 +207,7 @@ data ThreadState = ThreadState
 runCleanup :: ThreadState -> DBusState -> X ()
 runCleanup ts db = io $ do
   mapM_ killHandle $ tsChildPIDs ts
-  forM_ (dbSessionClient db) stopXMonadService
+  disconnectDBusX db
-  forM_ (dbSystemClient db) disconnect
 
 --------------------------------------------------------------------------------
 -- | Startuphook configuration
@@ -300,21 +318,18 @@ allDWs' = [xsaneDynamicWorkspace
           , f5vpnDynamicWorkspace
           ]
 
-allDWs :: IO [DynWorkspace]
-allDWs = catMaybes <$> mapM evalSometimes allDWs'
-
 --------------------------------------------------------------------------------
 -- | Layout configuration
 
 -- NOTE this will have all available layouts, even those that may be for
 -- features that failed. Trying to dynamically take out a layout seems to
 -- make a new type :/
-myLayouts fb = onWorkspace vmTag vmLayout
+myLayouts tt = onWorkspace vmTag vmLayout
   $ onWorkspace gimpTag gimpLayout
   $ mkToggle (single HIDE)
   $ tall ||| fulltab ||| full
   where
-    addTopBar = noFrillsDeco shrinkText $ T.tabbedTheme fb
+    addTopBar = noFrillsDeco shrinkText tt
     tall = renamed [Replace "Tall"]
       $ avoidStruts
       $ addTopBar
@@ -323,7 +338,7 @@ myLayouts fb = onWorkspace vmTag vmLayout
     fulltab = renamed [Replace "Tabbed"]
       $ avoidStruts
       $ noBorders
-      $ tabbedAlways shrinkText $ T.tabbedTheme fb
+      $ tabbedAlways shrinkText tt
     full = renamed [Replace "Full"]
       $ noBorders Full
     vmLayout = noBorders Full
@@ -656,7 +671,7 @@ externalBindings ts db =
     , KeyBinding "M-S-," "keyboard down" $ ck bctlDec
     , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
     , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
-    , KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
+    , KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
     , KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
     , KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
     -- M-<F1> reserved for showing the keymap
@@ -672,7 +687,7 @@ externalBindings ts db =
     ]
   ]
   where
-    cl = dbSessionClient db
+    cl = dbSesClient db
     brightessControls ctl getter = (ioSometimes . getter . ctl) cl
     ib = Left . brightessControls intelBacklightControls
     ck = Left . brightessControls clevoKeyboardControls

lib/XMonad/Internal/Command/Power.hs

@@ -96,8 +96,7 @@ quitPrompt :: T.FontBuilder -> X ()
 quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
 
 sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
-sometimesPrompt n = sometimesIO n (n ++ " command")
+sometimesPrompt n = sometimesIO n (n ++ " command") T.defFontTree
-  $ Only $ IOAlways T.defFont id
 
 -- TODO doesn't this need to also lock the screen?
 runSuspendPrompt :: SometimesX
@@ -141,7 +140,7 @@ runOptimusPrompt = Sometimes "graphics switcher" [s]
   where
     s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error }
     r = IORoot runOptimusPrompt' t
-    t = And1 (Only $ IOAlways T.defFont id)
+    t = And1 T.defFontTree
       $ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
 
 --------------------------------------------------------------------------------
@@ -170,16 +169,13 @@ data PowerPrompt = PowerPrompt
 instance XPrompt PowerPrompt where
     showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
 
-runPowerPrompt :: AlwaysX
+runPowerPrompt :: SometimesX
-runPowerPrompt = Always "power prompt" $ Option sf fallback
+runPowerPrompt = Sometimes "power prompt" [sf]
   where
-    sf = Subfeature withLock "lock-enabled prompt" Error
+    sf = Subfeature withLock "prompt with lock" Error
     withLock = IORoot (uncurry powerPrompt) tree
-    tree = And12 (,) (Only $ IOSometimes runScreenLock id) (Only $ IOAlways T.defFont id)
+    tree = And12 (,) lockTree T.defFontTree
-    fallback = Always_ $ FallbackTree powerPromptNoLock $ FallbackBottom T.defFont
+    lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
-
-powerPromptNoLock :: T.FontBuilder -> X ()
-powerPromptNoLock = powerPrompt skip
 
 powerPrompt :: X () -> T.FontBuilder -> X ()
 powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -27,7 +27,10 @@ import           XMonad.Internal.Command.Power
 import           XMonad.Internal.Concurrent.ClientMessage
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Shell
-import           XMonad.Internal.Theme                    (FontBuilder, defFont)
+import           XMonad.Internal.Theme
+    ( FontBuilder
+    , defFontTree
+    )
 
 --------------------------------------------------------------------------------
 -- | Data structure to hold the ACPI events I care about
@@ -120,6 +123,6 @@ runHandleACPI :: Always (String -> X ())
 runHandleACPI = Always "ACPI event handler" $ Option sf fallback
   where
     sf = Subfeature withLock "acpid prompt" Error
-    withLock = IORoot (uncurry handleACPI)
+    withLock = IORoot (uncurry handleACPI) $ And12 (,) defFontTree $ Only
-      $ And12 (,) (Only $ IOAlways defFont id) (Only $ IOSometimes runScreenLock id)
+               $ IOSometimes runScreenLock id
-    fallback = Always_ $ FallbackTree (`handleACPI` skip) $ FallbackBottom defFont
+    fallback = Always_ $ FallbackAlone $ const skip

lib/XMonad/Internal/DBus/Control.hs

@@ -5,16 +5,19 @@
 
 module XMonad.Internal.DBus.Control
   ( Client
-  , startXMonadService
+  , DBusState(..)
+  , connectDBus
+  , connectDBusX
+  , disconnectDBus
+  , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
-  , stopXMonadService
   , disconnect
   , dbusExporters
   ) where
 
-import           Control.Monad                                  (forM_, void)
+import           Control.Monad
 
 import           DBus
 import           DBus.Client
@@ -26,17 +29,42 @@ import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.DBus.Screensaver
 import           XMonad.Internal.Dependency
 
-startXMonadService :: IO (Maybe Client)
+-- | Current connections to the DBus (session and system buses)
-startXMonadService = do
+data DBusState = DBusState
-  client <- getDBusClient False
+    { dbSesClient :: Maybe Client
-  forM_ client requestXMonadName
+    , dbSysClient :: Maybe Client
-  mapM_ (\f -> executeSometimes $ f client) dbusExporters
+    }
-  return client
 
-stopXMonadService :: Client -> IO ()
+-- | Connect to the DBus
-stopXMonadService client = do
+connectDBus :: IO DBusState
-  void $ releaseName client xmonadBusName
+connectDBus = do
-  disconnect client
+  ses <- getDBusClient False
+  sys <- getDBusClient True
+  return DBusState { dbSesClient = ses, dbSysClient = sys }
+
+-- | Disconnect from the DBus
+disconnectDBus :: DBusState -> IO ()
+disconnectDBus db = forM_ (dbSysClient db) disconnect
+
+-- | Connect to the DBus and request the XMonad name
+connectDBusX :: IO DBusState
+connectDBusX = do
+  db <- connectDBus
+  forM_ (dbSesClient db) requestXMonadName
+  return db
+
+-- | Disconnect from DBus and release the XMonad name
+disconnectDBusX :: DBusState -> IO ()
+disconnectDBusX db = do
+  forM_ (dbSesClient db) releaseXMonadName
+  disconnectDBus db
+
+-- | All exporter features to be assigned to the DBus
+dbusExporters :: [Maybe Client -> SometimesIO]
+dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
+
+releaseXMonadName :: Client -> IO ()
+releaseXMonadName cl = void $ releaseName cl xmonadBusName
 
 requestXMonadName :: Client -> IO ()
 requestXMonadName client = do
@@ -51,5 +79,5 @@ requestXMonadName client = do
   where
     xn = "'" ++ formatBusName xmonadBusName ++ "'"
 
-dbusExporters :: [Maybe Client -> SometimesIO]
+-- executeExporters :: Maybe Client -> IO ()
-dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
+-- executeExporters cl = mapM_ (\f -> executeSometimes $ f cl) dbusExporters

lib/XMonad/Internal/Dependency.hs

@@ -74,7 +74,6 @@ module XMonad.Internal.Dependency
   -- dependency construction
   , sysExe
   , localExe
-  , fontFam
   , sysdSystem
   , sysdUser
   , listToAnds
@@ -83,6 +82,9 @@ module XMonad.Internal.Dependency
   , pathRW
   , pathW
   , sysTest
+
+  -- misc
+  , shellTest
   ) where
 
 import           Control.Monad.IO.Class
@@ -255,9 +257,15 @@ type DBusTree p = Tree IODependency DBusDependency_ p
 type IOTree_ = Tree_ IODependency_
 type DBusTree_ = Tree_ DBusDependency_
 
--- | A dependency that only requires IO to evaluate
+-- | A dependency that only requires IO to evaluate (with payload)
-data IODependency p = IORead String (IO (Result p))
+data IODependency p =
+  -- an IO action that yields a payload
+  IORead String (IO (Result p))
+  -- always yields a payload
+  | IOConst p
+  -- an always that yields a payload
   | forall a. IOAlways (Always a) (a -> p)
+  -- a sometimes that yields a payload
   | forall a. IOSometimes (Sometimes a) (a -> p)
 
 -- | A dependency pertaining to the DBus
@@ -269,8 +277,10 @@ data DBusDependency_ = Bus BusName
 data IODependency_ = IOSystem_ SystemDependency
   | forall a. IOSometimes_ (Sometimes a)
 
-data SystemDependency = Executable Bool FilePath
+-- | A system component to an IODependency
-  | FontFamily String
+-- This name is dumb, but most constructors should be obvious
+data SystemDependency =
+  Executable Bool FilePath
   | AccessiblePath FilePath Bool Bool
   | IOTest String (IO (Maybe String))
   | Systemd UnitType String
@@ -411,6 +421,7 @@ testTree test_ test = go
 
 testIODependency :: IODependency p -> IO (Result p)
 testIODependency (IORead _ t)      = t
+testIODependency (IOConst c)       = return $ Right $ PostPass c []
 -- TODO this is a bit odd because this is a dependency that will always
 -- succeed, which kinda makes this pointless. The only reason I would want this
 -- is if I want to have a built-in logic to "choose" a payload to use in
@@ -445,10 +456,6 @@ testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
   where
     msg = unwords [e, "executable", singleQuote bin, "not found"]
     e = if sys then "system" else "local"
-testSysDependency (FontFamily fam) = shellTest cmd msg
-  where
-    msg = unwords ["font family", singleQuote fam, "not found"]
-    cmd = fmtCmd "fc-list" ["-q", singleQuote fam]
 testSysDependency (Systemd t n) = shellTest cmd msg
   where
     msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
@@ -620,9 +627,6 @@ toAnd a b = And_ (Only_ a) (Only_ b)
 exe :: Bool -> String -> IODependency_
 exe b = IOSystem_ . Executable b
 
-fontFam :: String -> IODependency_
-fontFam = IOSystem_ . FontFamily
-
 sysExe :: String -> IODependency_
 sysExe = exe True
 
@@ -750,9 +754,9 @@ dataTree_ f_ = go
 dataIODependency :: IODependency p -> DependencyData
 dataIODependency d = first Q $ case d of
   (IORead n _)                    -> ("ioread", [("desc", JSON_Q $ Q n)])
-  -- TODO make this actually useful (I actually need to name my features)
+  (IOConst _)                     -> ("const", [])
-  (IOSometimes _ _) -> ("sometimes", [])
+  (IOSometimes (Sometimes n _) _) -> ("sometimes", [("name", JSON_Q $ Q n)])
-  (IOAlways _ _)    -> ("always", [])
+  (IOAlways (Always n _) _)       -> ("always", [("name", JSON_Q $ Q n)])
 
 dataIODependency_ :: IODependency_ -> DependencyData
 dataIODependency_ d = case d of
@@ -766,7 +770,6 @@ dataSysDependency d = first Q $
                                             , ("path", JSON_Q $ Q path)
                                             ])
     (IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)])
-    (FontFamily fam) -> ("font", [("family", JSON_Q $ Q fam)])
     (AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
                                        , ("readable", JSON_UQ $ jsonBool r)
                                        , ("writable", JSON_UQ $ jsonBool w)

lib/XMonad/Internal/Theme.hs

@@ -22,9 +22,12 @@ module XMonad.Internal.Theme
   , FontBuilder
   , buildFont
   , defFontData
-  , defFont
+  , defFontDep
+  , defFontTree
   , fontFeature
+  , fontDependency
   , tabbedTheme
+  , tabbedFeature
   , promptTheme
   ) where
 
@@ -33,7 +36,11 @@ import           Data.Colour
 import           Data.Colour.SRGB
 import           Data.List
 
+import           System.Exit
+
 import           XMonad.Internal.Dependency
+import           XMonad.Internal.Process
+import           XMonad.Internal.Shell
 import qualified XMonad.Layout.Decoration   as D
 import qualified XMonad.Prompt              as P
 
@@ -130,11 +137,32 @@ buildFont (Just fam) FontData { weight = w
     showLower :: Show a => Maybe a -> Maybe String
     showLower = fmap (fmap toLower . show)
 
+fallbackFont :: FontBuilder
+fallbackFont = buildFont Nothing
+
+testFont :: String -> IO (Result FontBuilder)
+testFont fam = do
+  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
+  return $ case rc of
+    ExitSuccess -> Right $ PostPass (buildFont $ Just fam) []
+    _           -> Left [msg]
+  where
+    msg = unwords ["font family", qFam, "not found"]
+    cmd = fmtCmd "fc-list" ["-q", qFam]
+    qFam = singleQuote fam
+
+fontDependency :: String -> IODependency FontBuilder
+fontDependency fam =
+  IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam
+
+fontTree :: String -> IOTree FontBuilder
+fontTree fam = Or (Only $ fontDependency fam) (Only $ IOConst fallbackFont)
+
 fontFeature :: String -> String -> Always FontBuilder
 fontFeature n fam = always1 n sfn root def
   where
     sfn = "Font family for " ++ fam
-    root = IORoot_ (buildFont $ Just fam) $ Only_ $ fontFam fam
+    root = IORoot id $ fontTree fam
     def = buildFont Nothing
 
 --------------------------------------------------------------------------------
@@ -149,8 +177,11 @@ defFontData = FontData
   , pixelsize = Nothing
   }
 
-defFont :: Always FontBuilder
+defFontDep :: IODependency FontBuilder
-defFont = fontFeature "Default Font" "DejaVu Sans"
+defFontDep = fontDependency "DejaVu Sans"
+
+defFontTree :: IOTree FontBuilder
+defFontTree = fontTree "DejaVu Sans"
 
 --------------------------------------------------------------------------------
 -- | Complete themes
@@ -181,6 +212,13 @@ tabbedTheme fb = D.def
   , D.windowTitleIcons      = []
   }
 
+tabbedFeature :: Always D.Theme
+tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
+  where
+    sf = Subfeature niceTheme "theme with nice font" Error
+    niceTheme = IORoot tabbedTheme $ Only defFontDep
+    fallback = Always_ $ FallbackAlone $ tabbedTheme fallbackFont
+
 promptTheme :: FontBuilder -> P.XPConfig
 promptTheme fb = P.def
   { P.font              = fb $ defFontData { size = Just 12 }