ENH actually make dependency framework functional

bin/xmobar.hs

@@ -11,8 +11,6 @@ module Main (main) where
 -- * Theme integration with xmonad (shared module imported below)
 -- * A custom Locks plugin from my own forked repo
 
-import           Control.Monad
-
 import           Data.Either
 import           Data.List
 import           Data.Maybe
@@ -255,16 +253,15 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
 sysfsNet :: FilePath
 sysfsNet = "/sys/class/net"
 
-readInterface :: (String -> Bool) -> IO (Either String String)
+readInterface :: String -> (String -> Bool) -> IODependency String
-readInterface f = do
+readInterface n f = IORead n go
-  ns <- filter f <$> listInterfaces
+  where
-  case ns of
+    go = do
-    [] -> return $ Left "no interfaces found"
+      ns <- filter f <$> listInterfaces
-    (x:xs) -> do
+      case ns of
-      unless (null xs) $
+        [] -> return $ Left ["no interfaces found"]
-        -- TODO store this somehow intead of printing
+        (x:xs) -> do
-        putStrLn $ "WARNING: extra interfaces found, using " ++ x
+          return $ Right $ PostPass x $ fmap ("ignoring extra interface: "++) xs
-      return $ Right x
 
 vpnPresent :: IO (Maybe String)
 vpnPresent = do
@@ -292,53 +289,48 @@ rightPlugins sysClient sesClient = mapM evalFeature
   ]
 
 getWireless :: BarFeature
-getWireless = sometimes1 "wireless status indicator"
+getWireless = sometimes1 "wireless status indicator" $ IORoot wirelessCmd
-  $ IOTree (Consumer wirelessCmd)
+  $ Only $ readInterface "get wifi interface" isWireless
-  $ Only $ IORead "get wifi interface" $ fmap Just <$> readInterface isWireless
 
 getEthernet :: Maybe Client -> BarFeature
 getEthernet client = sometimes1 "ethernet status indicator" $
-  DBusTree (Consumer act) client deps
+  DBusRoot (const . ethernetCmd) tree client
   where
-    act i = const $ ethernetCmd i
+    tree = And1 id (Only readEth) (Only_ devDep)
-    deps = And (\_ s -> s) (Only devDep) (Only readEth)
+    readEth = readInterface "read ethernet interface" isEthernet
-    readEth = DBusIO $ IORead "read ethernet interface"
-      $ fmap Just <$> readInterface isEthernet
 
 getBattery :: BarFeature
 getBattery = sometimesIO "battery level indicator"
-  (Only $ IOTest "Test if battery is present" hasBattery)
+  (Only_ $ sysTest "Test if battery is present" hasBattery)
   batteryCmd
 
 getVPN :: Maybe Client -> BarFeature
 getVPN client = sometimesDBus client "VPN status indicator"
   (toAnd vpnDep test) (const vpnCmd)
   where
-    test = DBusIO $ IOTest "Use nmcli to test if VPN is present" vpnPresent
+    test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
 
 getBt :: Maybe Client -> BarFeature
 getBt client = sometimesDBus client "bluetooth status indicator"
-  (Only btDep)
+  (Only_ btDep)
   (const btCmd)
 
 getAlsa :: BarFeature
-getAlsa = sometimesIO "volume level indicator"
+getAlsa = sometimesIO "volume level indicator" (Only_ $ sysExe "alsact") alsaCmd
-  (Only $ Executable True "alsact")
-  alsaCmd
 
 getBl :: Maybe Client -> BarFeature
 getBl client = sometimesDBus client "Intel backlight indicator"
-  (Only intelBacklightSignalDep)
+  (Only_ intelBacklightSignalDep)
   (const blCmd)
 
 getCk :: Maybe Client -> BarFeature
 getCk client = sometimesDBus client "Clevo keyboard indicator"
-  (Only clevoKeyboardSignalDep)
+  (Only_ clevoKeyboardSignalDep)
   (const ckCmd)
 
 getSs :: Maybe Client -> BarFeature
 getSs client = sometimesDBus client "screensaver indicator"
-  (Only ssSignalDep) $ const ssCmd
+  (Only_ ssSignalDep) $ const ssCmd
 
 getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
 getAllCommands right = do
@@ -430,4 +422,3 @@ fmtSpecs = intercalate sep . fmap go
 fmtRegions :: BarRegions -> String
 fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } =
   fmtSpecs l ++ [lSep] ++ fmtSpecs c ++ [rSep] ++ fmtSpecs r
-

lib/XMonad/Internal/Command/DMenu.hs

@@ -72,7 +72,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
 -- | Exported Commands
 
 runDevMenu :: SometimesX
-runDevMenu = sometimesIO "device manager" (Only $ Executable False myDmenuDevices) $ do
+runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do
   c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
   spawnCmd myDmenuDevices
     $ ["-c", c]
@@ -84,11 +84,11 @@ runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth
   $ "-c":themeArgs "#0044bb"
 
 runBwMenu :: SometimesX
-runBwMenu = sometimesIO "password manager" (Only $ Executable False myDmenuPasswords) $
+runBwMenu = sometimesIO "password manager" (Only_ $ localExe myDmenuPasswords) $
   spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
 
 runVPNMenu :: SometimesX
-runVPNMenu = sometimesIO "VPN selector" (Only $ Executable False myDmenuVPN) $
+runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $
   spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
 
 -- runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
@@ -135,7 +135,7 @@ runClipMenu :: SometimesX
 runClipMenu = sometimesIO "clipboard manager" deps act
   where
     act = spawnCmd myDmenuCmd args
-    deps = toAnd (Executable True myDmenuCmd) (Executable True "greenclip")
+    deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")
     args = [ "-modi", "\"clipboard:greenclip print\""
            , "-show", "clipboard"
            , "-run-command", "'{cmd}'"

lib/XMonad/Internal/Command/Desktop.hs

@@ -97,7 +97,7 @@ runTerm = sometimesExe "terminal" True myTerm
 runTMux :: SometimesX
 runTMux = sometimesIO "terminal multiplexer" deps act
   where
-    deps = listToAnds (Executable True myTerm) $ fmap (Executable True) ["tmux", "bash"]
+    deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
     act = spawn
       $ "tmux has-session"
       #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
@@ -108,7 +108,7 @@ runTMux = sometimesIO "terminal multiplexer" deps act
 runCalc :: SometimesX
 runCalc = sometimesIO "calculator" deps act
   where
-    deps = toAnd (Executable True myTerm) (Executable True "R")
+    deps = toAnd (sysExe myTerm) (sysExe "R")
     act = spawnCmd myTerm ["-e", "R"]
 
 runBrowser :: SometimesX
@@ -155,7 +155,7 @@ playSound file = do
 
 featureSound :: String -> FilePath -> X () -> X () -> SometimesX
 featureSound n file pre post =
-  sometimesIO ("volume " ++ n ++ " control") (Only $ Executable True "paplay")
+  sometimesIO ("volume " ++ n ++ " control") (Only_ $ sysExe "paplay")
   $ pre >> playSound file >> post
 
 runVolumeDown :: SometimesX
@@ -194,7 +194,7 @@ runNotificationContext =
 
 runToggleBluetooth :: SometimesX
 runToggleBluetooth =
-  sometimesIO "bluetooth toggle" (Only $ Executable True myBluetooth)
+  sometimesIO "bluetooth toggle" (Only_ $ sysExe myBluetooth)
   $ spawn
   $ myBluetooth ++ " show | grep -q \"Powered: no\""
   #!&& "a=on"
@@ -203,7 +203,7 @@ runToggleBluetooth =
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a"  }
 
 runToggleEthernet :: SometimesX
-runToggleEthernet = sometimesIO "ethernet toggle" (Only $ Executable True "nmcli")
+runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
   $ spawn
   $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
   #!&& "a=connect"
@@ -212,14 +212,14 @@ runToggleEthernet = sometimesIO "ethernet toggle" (Only $ Executable True "nmcli
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed"  }
 
 runStartISyncTimer :: SometimesX
-runStartISyncTimer = sometimesIO "isync timer" (Only $ Systemd UserUnit "mbsync.timer")
+runStartISyncTimer = sometimesIO "isync timer" (Only_ $ sysdUser "mbsync.timer")
   $ spawn
   $ "systemctl --user start mbsync.timer"
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started"  }
   #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
 
 runStartISyncService :: SometimesX
-runStartISyncService = sometimesIO "isync" (Only $ Systemd UserUnit "mbsync.service")
+runStartISyncService = sometimesIO "isync" (Only_ $ sysdUser "mbsync.service")
   $ spawn
   $ "systemctl --user start mbsync.service"
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@@ -264,7 +264,7 @@ getCaptureDir = do
     fallback = (</> ".local/share") <$> getHomeDirectory
 
 runFlameshot :: String -> String -> SometimesX
-runFlameshot n mode = sometimesIO n (Only $ Executable True myCapture)
+runFlameshot n mode = sometimesIO n (Only_ $ sysExe myCapture)
   $ spawnCmd myCapture [mode]
 
 -- TODO this will steal focus from the current window (and puts it
@@ -282,6 +282,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
 
 runCaptureBrowser :: SometimesX
 runCaptureBrowser =
-  sometimesIO "screen capture browser" (Only $ Executable True myImageBrowser) $ do
+  sometimesIO "screen capture browser" (Only_ $ sysExe myImageBrowser) $ do
   dir <- io getCaptureDir
   spawnCmd myImageBrowser [dir]

lib/XMonad/Internal/Command/Power.hs

@@ -101,7 +101,7 @@ runOptimusPrompt' = do
       #!&& "killall xmonad"
 
 runOptimusPrompt :: SometimesX
-runOptimusPrompt = sometimesIO "graphics switcher" (Only $ Executable True myOptimusManager)
+runOptimusPrompt = sometimesIO "graphics switcher" (Only_ $ localExe myOptimusManager)
   runOptimusPrompt'
 
 --------------------------------------------------------------------------------

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
 -- | Spawn a new thread that will listen for ACPI events on the acpid socket
 -- and send ClientMessage events when it receives them
 runPowermon :: SometimesIO
-runPowermon = sometimesIO "ACPI event monitor" (Only $ pathR acpiPath) listenACPI
+runPowermon = sometimesIO "ACPI event monitor" (Only_ $ pathR acpiPath) listenACPI
 
 -- | Handle ClientMessage event containing and ACPI event (to be used in
 -- Xmonad's event hook)

lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs

@@ -107,13 +107,13 @@ clevoKeyboardConfig = BrightnessConfig
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-stateFileDep :: IODependency p
+stateFileDep :: IODependency_
 stateFileDep = pathRW stateFile
 
-brightnessFileDep :: IODependency p
+brightnessFileDep :: IODependency_
 brightnessFileDep = pathR brightnessFile
 
-clevoKeyboardSignalDep :: DBusDependency RawBrightness
+clevoKeyboardSignalDep :: DBusDependency_
 clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
 
 exportClevoKeyboard :: Maybe Client -> SometimesIO

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -67,7 +67,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
   either (const Nothing) bodyGetBrightness
   <$> callMethod client xmonadBusName p i memGet
 
-signalDep :: BrightnessConfig a b -> DBusDependency m
+signalDep :: BrightnessConfig a b -> DBusDependency_
 signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
   Endpoint xmonadBusName p i $ Signal_ memCur
 
@@ -85,8 +85,8 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
 --------------------------------------------------------------------------------
 -- | Internal DBus Crap
 
-brightnessExporter :: RealFrac b => [IODependency (Maybe x)]
+brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
-  -> BrightnessConfig a b -> Maybe Client -> SometimesIO
+  -> Maybe Client -> SometimesIO
 brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
   sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
   where

lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs

@@ -89,13 +89,13 @@ intelBacklightConfig = BrightnessConfig
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-curFileDep :: IODependency p
+curFileDep :: IODependency_
 curFileDep = pathRW curFile
 
-maxFileDep :: IODependency p
+maxFileDep :: IODependency_
 maxFileDep = pathR maxFile
 
-intelBacklightSignalDep :: DBusDependency RawBrightness
+intelBacklightSignalDep :: DBusDependency_
 intelBacklightSignalDep = signalDep intelBacklightConfig
 
 exportIntelBacklight :: Maybe Client -> SometimesIO

lib/XMonad/Internal/DBus/Removable.hs

@@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
 memRemoved :: MemberName
 memRemoved = memberName_ "InterfacesRemoved"
 
-dbusDep :: MemberName -> DBusDependency p
+dbusDep :: MemberName -> DBusDependency_
 dbusDep m = Endpoint bus path interface $ Signal_ m
 
-addedDep :: DBusDependency p
+addedDep :: DBusDependency_
 addedDep = dbusDep memAdded
 
-removedDep :: DBusDependency p
+removedDep :: DBusDependency_
 removedDep = dbusDep memRemoved
 
 driveInsertedSound :: FilePath

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -117,7 +117,7 @@ exportScreensaver client =
         ]
       }
     bus = Bus xmonadBusName
-    ssx = DBusIO $ Executable True ssExecutable
+    ssx = DBusIO $ IOSystem_ $ Executable True ssExecutable
 
 callToggle :: Maybe Client -> SometimesIO
 callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
@@ -132,5 +132,5 @@ matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
 matchSignal cb =
   fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
 
-ssSignalDep :: DBusDependency p
+ssSignalDep :: DBusDependency_
 ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState

lib/XMonad/Internal/Dependency.hs

@@ -1,30 +1,44 @@
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GADTs         #-}
-{-# LANGUAGE TupleSections #-}
 
 --------------------------------------------------------------------------------
 -- | Functions for handling dependencies
 
 module XMonad.Internal.Dependency
-  ( AlwaysX
+  -- feature types
-  , AlwaysIO
+  ( Feature
-  , Feature
   , Always(..)
-  , TestedSometimes(..)
+  , Sometimes
+  , AlwaysX
+  , AlwaysIO
   , SometimesX
   , SometimesIO
-  , Sometimes
+  , PostPass(..)
-  , ioSometimes
+  , Subfeature(..)
-  , ioAlways
+  , LogLevel(..)
+
+  -- dependency tree types
+  , Root(..)
+  , Tree(..)
+  , Tree_(..)
+  , IODependency(..)
+  , IODependency_(..)
+  , SystemDependency(..)
+  , DBusDependency_(..)
+  , DBusMember(..)
+  , UnitType(..)
+  , Result
+
+  -- testing
   , evalFeature
   , executeSometimes
   , executeAlways
   , evalAlways
   , evalSometimes
 
-  , Subfeature(..)
+  -- lifting
-  , LogLevel(..)
+  , ioSometimes
-
+  , ioAlways
-  , Action(..)
 
   -- feature construction
   , sometimes1
@@ -34,18 +48,17 @@ module XMonad.Internal.Dependency
   , sometimesExeArgs
   , sometimesEndpoint
 
-  -- Dependency tree
+  -- dependency construction
-  , ActionTree(..)
+  , sysExe
-  , Tree(..)
+  , localExe
-  , IODependency(..)
+  , sysdSystem
-  , DBusDependency(..)
+  , sysdUser
-  , DBusMember(..)
-  , UnitType(..)
   , listToAnds
   , toAnd
   , pathR
   , pathRW
   , pathW
+  , sysTest
   ) where
 
 import           Control.Monad.IO.Class
@@ -53,7 +66,6 @@ import           Control.Monad.Identity
 
 -- import           Data.Aeson
 import           Data.Bifunctor
--- import           Data.Either
 import           Data.List               (find)
 import           Data.Maybe
 -- import qualified Data.Text               as T
@@ -64,7 +76,7 @@ import           DBus.Internal
 import qualified DBus.Introspection      as I
 
 import           System.Directory        (findExecutable, readable, writable)
--- import           System.Environment
+import           System.Environment
 import           System.Exit
 
 import           XMonad.Core             (X, io)
@@ -73,9 +85,52 @@ import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
 
 --------------------------------------------------------------------------------
--- | Features
+-- | Feature Evaluation
+--
+-- Here we attempt to build and return the monadic actions encoded by each
+-- feature.
 
--- data AlwaysAny = AX AlwaysX | AIO AlwaysIO
+-- | Execute an Always immediately
+executeAlways :: MonadIO m => Always (m a) -> m a
+executeAlways = join . evalAlways
+
+-- | Execute a Sometimes immediately (or do nothing if failure)
+executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
+executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
+
+-- | Possibly return the action of an Always/Sometimes
+evalFeature :: MonadIO m => Feature a -> m (Maybe a)
+evalFeature (Right a) = Just <$> evalAlways a
+evalFeature (Left s)  = evalSometimes s
+
+-- | Possibly return the action of a Sometimes
+evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
+evalSometimes x = io $ either goFail goPass =<< evalSometimesMsg x
+  where
+    goPass (PostPass a ws) = putErrors ws >> return (Just a)
+    goFail es = putErrors es >> return Nothing
+    putErrors = mapM_ putStrLn
+
+-- | Return the action of an Always
+evalAlways :: MonadIO m => Always a -> m a
+evalAlways a = do
+  (PostPass x ws) <- evalAlwaysMsg a
+  io $ mapM_ putStrLn ws
+  return x
+
+--------------------------------------------------------------------------------
+-- | Feature status
+
+-- | Dump the status of an Always to stdout
+-- dumpAlways :: MonadIO m => Always a -> m ()
+-- dumpAlways = undefined
+
+-- | Dump the status of a Sometimes to stdout
+-- dumpSometimes :: MonadIO m => Sometimes a -> m ()
+-- dumpSometimes = undefined
+
+--------------------------------------------------------------------------------
+-- | Wrapper types
 
 type AlwaysX = Always (X ())
 
@@ -87,388 +142,273 @@ type SometimesIO = Sometimes (IO ())
 
 type Feature a = Either (Sometimes a) (Always a)
 
-data Always a = Option (Subfeature a Tree) (Always a) | Always a
-
-type Sometimes a = [Subfeature a Tree]
-
-ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
-ioSometimes = fmap ioSubfeature
-
-ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
-ioAlways (Always x)    = Always $ io x
-ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
-
-data TestedAlways a p =
-  Primary (Finished a p) [FailedFeature a p] (Always a)
-  | Fallback a [FailedFeature a p]
-
-data TestedSometimes a p = TestedSometimes
-  { tsSuccess  :: Maybe (Finished a p)
-  , tsFailed   :: [FailedFeature a p]
-  , tsUntested :: [Subfeature a Tree]
-  }
-
-type FailedFeature a p = Either (Subfeature a Tree, String)
-  (Subfeature a ResultTree, [String])
-
-data Finished a p = Finished
-  { finData     :: Subfeature a ResultTree
-  , finAction   :: a
-  , finWarnings :: [String]
-  }
-
-data FeatureResult a p = Untestable (Subfeature a Tree) String |
-  FailedFtr (Subfeature a ResultTree) [String] |
-  SuccessfulFtr (Finished a p)
-
-type ActionTreeMaybe a p = Either (ActionTree a Tree, String)
-  (ActionTree a ResultTree, Maybe a, [String])
-
-sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a
-sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }]
-
--- always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
--- always1_ l n t x =
---   Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
-
-sometimes1 :: String -> ActionTree a Tree -> Sometimes a
-sometimes1 = sometimes1_ Error
-
-sometimesIO :: String -> Tree (IODependency p) p -> a -> Sometimes a
-sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t
-
-sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency p) p
-  -> (Client -> a) -> Sometimes a
-sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t
-
 --------------------------------------------------------------------------------
--- | Feature Data
+-- | Feature declaration
 
-data Subfeature a t = Subfeature
+-- | Feature that is guaranteed to work
-  { sfTree  :: ActionTree a t
+-- This is composed of sub-features that are tested in order, and if all fail
+-- the fallback is a monadic action (eg a plain haskell function)
+data Always a = Option (SubfeatureRoot a) (Always a) | Always a
+
+-- | Feature that might not be present
+-- This is like an Always except it doesn't fall back on a guaranteed monadic
+-- action
+type Sometimes a = [SubfeatureRoot a]
+
+-- | Individually tested sub-feature data for Always/sometimes
+-- The polymorphism allows representing tested and untested states. Includes
+-- the 'action' itself to be tested and any auxilary data for describing the
+-- sub-feature.
+data Subfeature f = Subfeature
+  { sfData  :: f
   , sfName  :: String
   , sfLevel :: LogLevel
   }
 
+type SubfeatureRoot a = Subfeature (Root a)
+
+-- | Loglevel at which feature testing should be reported
+-- This is currently not used for anything important
 data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
 
-ioSubfeature :: MonadIO m => Subfeature (IO a) t -> Subfeature (m a) t
+-- | An action and its dependencies
-ioSubfeature sf = sf { sfTree = ioActionTree $ sfTree sf }
+-- May be a plain old monad or be DBus-dependent, in which case a client is
+-- needed
+data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p)
+  | IORoot_ a (Tree_ IODependency_)
+  | forall p. DBusRoot (p -> Client -> a) (Tree IODependency DBusDependency_ p) (Maybe Client)
+  | DBusRoot_ (Client -> a) (Tree_ DBusDependency_) (Maybe Client)
 
--- data Msg = Msg LogLevel String String
+-- | The dependency tree with rules to merge results
+data Tree d d_ p =
+  And12 (p -> p -> p) (Tree d d_ p) (Tree d d_ p)
+  | And1 (p -> p) (Tree d d_ p) (Tree_ d_)
+  | And2 (p -> p) (Tree_ d_) (Tree d d_ p)
+  | Or (p -> p) (p -> p) (Tree d d_ p) (Tree d d_ p)
+  | Only (d p)
 
---------------------------------------------------------------------------------
+-- | A dependency tree without functions to merge results
--- | Action Tree
+data Tree_ d =
+  And_ (Tree_ d) (Tree_ d)
+  | Or_ (Tree_ d) (Tree_ d)
+  | Only_ d
 
-data ActionTree a t =
+-- | A dependency that only requires IO to evaluate
-  forall p. IOTree (Action a p) (t (IODependency p) p)
+data IODependency p = IORead String (IO (Result p))
-  | forall p. DBusTree (Action (Client -> a) p) (Maybe Client)
+  | forall a. IOAlways (Always a) (a -> p)
-    (t (DBusDependency p) p)
+  | forall a. IOSometimes (Sometimes a) (a -> p)
 
-data Action a p = Standalone a | Consumer (p -> a)
+-- | A dependency pertaining to the DBus
+-- data DBusDependency p =
+--   -- Bus BusName
+--   -- | Endpoint BusName ObjectPath InterfaceName DBusMember
+--   DBusIO (IODependency p)
 
-ioActionTree :: MonadIO m => ActionTree (IO a) t -> ActionTree (m a) t
+-- | A dependency pertaining to the DBus
-ioActionTree (IOTree (Standalone a) t)      = IOTree (Standalone $ io a) t
+data DBusDependency_ = Bus BusName
-ioActionTree (IOTree (Consumer a) t)        = IOTree (Consumer $ io . a) t
+  | Endpoint BusName ObjectPath InterfaceName DBusMember
-ioActionTree (DBusTree (Standalone a) cl t) = DBusTree (Standalone $ io . a) cl t
+  | DBusIO IODependency_
-ioActionTree (DBusTree (Consumer a) cl t)   = DBusTree (Consumer (\p c -> io $ a p c)) cl t
 
--- --------------------------------------------------------------------------------
+-- | A dependency that only requires IO to evaluate (no payload)
--- | Dependency Tree
+data IODependency_ = IOSystem_ SystemDependency | forall a. IOSometimes_ (Sometimes a)
 
-data Tree d p =
+data SystemDependency = Executable Bool FilePath
-  And (p -> p -> p) (Tree d p) (Tree d p)
-  | Or (p -> p) (p -> p) (Tree d p) (Tree d p)
-  | Only d
-
-listToAnds :: d -> [d] -> Tree d (Maybe x)
-listToAnds i = foldr (And (const . const Nothing) . Only) (Only i)
-
-toAnd :: d -> d -> Tree d (Maybe x)
-toAnd a b = And (const . const Nothing) (Only a) (Only b)
-
---------------------------------------------------------------------------------
--- | Result Tree
-
--- | how to interpret ResultTree combinations:
--- First (LeafSuccess a) (Tree a) -> Or that succeeded on left
--- First (LeafFail a) (Tree a) -> And that failed on left
--- Both (LeafFail a) (Fail a) -> Or that failed
--- Both (LeafSuccess a) (LeafSuccess a) -> And that succeeded
--- Both (LeafFail a) (LeafSuccess a) -> Or that failed first and succeeded second
--- Both (LeafSuccess a) (LeafFail a) -> And that failed on the right
-
-data ResultTree d p =
-  First (ResultTree d p) (Tree d p)
-  | Both  (ResultTree d p) (ResultTree d p)
-  | LeafSuccess d [String]
-  | LeafFail d [String]
-
-type Payload p = (Maybe p, [String])
-
-type Summary p = Either [String] (Payload p)
-
-smryNil :: q -> Summary p
-smryNil = const $ Right (Nothing, [])
-
-smryFail :: String -> Either [String] a
-smryFail msg = Left [msg]
-
--- smryInit :: Summary p
--- smryInit = Right (Nothing, [])
-
--- foldResultTreeMsgs :: ResultTree d p -> ([String], [String])
--- foldResultTreeMsgs = undefined
-
---------------------------------------------------------------------------------
--- | Result
-
--- type Result p = Either [String] (Maybe p)
-
--- resultNil :: p -> Result q
--- resultNil = const $ Right Nothing
-
---------------------------------------------------------------------------------
--- | IO Dependency
-
-data IODependency p = Executable Bool FilePath
   | AccessiblePath FilePath Bool Bool
   | IOTest String (IO (Maybe String))
-  | IORead String (IO (Either String (Maybe p)))
   | Systemd UnitType String
-  | forall a. NestedAlways (Always a) (a -> p)
-  | forall a. NestedSometimes (Sometimes a) (a -> p)
 
+-- | The type of a systemd service
 data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
 
-sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
+-- | Wrapper type to describe and endpoint
-sometimesExe n sys path = sometimesExeArgs n sys path []
-
-sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
-sometimesExeArgs n sys path args =
-  sometimesIO n (Only (Executable sys path)) $ spawnCmd path args
-
-pathR :: String -> IODependency p
-pathR n = AccessiblePath n True False
-
-pathW :: String -> IODependency p
-pathW n = AccessiblePath n False True
-
-pathRW :: String -> IODependency p
-pathRW n = AccessiblePath n True True
-
---------------------------------------------------------------------------------
--- | DBus Dependency Result
-
-data DBusDependency p =
-  Bus BusName
-  | Endpoint BusName ObjectPath InterfaceName DBusMember
-  | DBusIO (IODependency p)
-
 data DBusMember = Method_ MemberName
   | Signal_ MemberName
   | Property_ String
   deriving (Eq, Show)
 
-introspectInterface :: InterfaceName
+--------------------------------------------------------------------------------
-introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
+-- | Tested dependency tree
+--
+-- The main reason I need this is so I have a "result" I can convert to JSON
+-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
 
-introspectMethod :: MemberName
+-- | Tested Always feature
-introspectMethod = memberName_ "Introspect"
+data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always a)
+  | Fallback a [SubfeatureFail]
 
-sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
+-- | Tested Sometimes feature
-  -> MemberName -> Maybe Client -> Sometimes (m ())
+data PostSometimes a = PostSometimes
-sometimesEndpoint name busname path iface mem client =
+  { psSuccess :: Maybe (SubfeaturePass a)
-  sometimesDBus client name deps cmd
+  , psFailed  :: [SubfeatureFail]
-  where
+  }
-    deps = Only $ Endpoint busname path iface $ Method_ mem
+
-    cmd c = io $ void $ callMethod c busname path iface mem
+-- | Passing subfeature
+type SubfeaturePass a = Subfeature (PostPass a)
+
+-- | Failed subfeature
+type SubfeatureFail = Subfeature PostFail
+
+-- | An action that passed
+data PostPass a = PostPass a [String] deriving (Functor)
+
+addMsgs :: PostPass a -> [String] -> PostPass a
+addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
+
+-- | An action that failed
+data PostFail = PostFail [String] | PostMissing String
 
 --------------------------------------------------------------------------------
--- | Feature evaluation
+-- | Testing pipeline
---
--- Here we attempt to build and return the monadic actions encoded by each
--- feature.
 
-executeAlways :: MonadIO m => Always (m a) -> m a
+evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
-executeAlways = join . evalAlways
-
-executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
-executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
-
-evalFeature :: MonadIO m => Feature a -> m (Maybe a)
-evalFeature (Right a) = Just <$> evalAlways a
-evalFeature (Left s)  = evalSometimes s
-
--- TODO actually print things
-evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
-evalSometimes x = either (const Nothing) (Just . fst) <$> evalSometimesMsg x
-
--- TODO actually collect error messages here
--- TODO add feature name to errors
-evalSometimesMsg :: MonadIO m => Sometimes a -> m (Either [String] (a, [String]))
 evalSometimesMsg x = io $ do
-  TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
+  PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes x
-  return $ maybe (Left []) (\Finished { finAction = a } -> Right (a, [])) s
+  case s of
+    (Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False fs
+    _                                  -> Left <$> failedMsgs True fs
 
+evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
+evalAlwaysMsg x = io $ do
+  r <- testAlways x
+  case r of
+    (Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False fs
+    (Fallback act fs) -> PostPass act <$> failedMsgs False fs
 
--- TODO actually print things
+testAlways :: Always a -> IO (PostAlways a)
-evalAlways :: MonadIO m => Always a -> m a
-evalAlways a = fst <$> evalAlwaysMsg a
-
-evalAlwaysMsg :: MonadIO m => Always a -> m (a, [String])
-evalAlwaysMsg a = io $ do
-  r <- testAlways a
-  return $ case r of
-    (Primary (Finished { finAction = act }) _ _) -> (act, [])
-    (Fallback act _)                             -> (act, [])
-
---------------------------------------------------------------------------------
--- | Dependency Testing
---
--- Here we test all dependencies and keep the tree structure so we can print it
--- for diagnostic purposes. This obviously has overlap with feature evaluation
--- since we need to resolve dependencies to build each feature.
-
-testAlways :: Always m -> IO (TestedAlways m p)
 testAlways = go []
   where
     go failed (Option fd next) = do
       r <- testSubfeature fd
       case r of
-        (Untestable fd' err) -> go (Left (fd' ,err):failed) next
+        (Left l)     -> go (l:failed) next
-        (FailedFtr fd' errs) -> go (Right (fd' ,errs):failed) next
+        (Right pass) -> return $ Primary pass failed next
-        (SuccessfulFtr s)    -> return $ Primary s failed next
     go failed (Always a) = return $ Fallback a failed
 
-testSometimes :: Sometimes m -> IO (TestedSometimes m p)
+testSometimes :: Sometimes a -> IO (PostSometimes a)
-testSometimes = go (TestedSometimes Nothing [] [])
+testSometimes = go (PostSometimes Nothing [])
   where
     go ts [] = return ts
     go ts (x:xs) = do
-      r <- testSubfeature x
+      sf <- testSubfeature x
-      case r of
+      case sf of
-        (Untestable fd' err) -> go (addFail ts (Left (fd' ,err))) xs
+        (Left l)     -> go (ts { psFailed = l:psFailed ts }) xs
-        (FailedFtr fd' errs) -> go (addFail ts (Right (fd' ,errs))) xs
+        (Right pass) -> return $ ts { psSuccess = Just pass }
-        (SuccessfulFtr s)    -> return $ ts { tsSuccess = Just s }
-    addFail ts@(TestedSometimes { tsFailed = f }) new
-      = ts { tsFailed = new:f }
 
-testSubfeature :: Subfeature m Tree -> IO (FeatureResult m p)
+testSubfeature :: SubfeatureRoot a -> IO (Either SubfeatureFail (SubfeaturePass a))
-testSubfeature fd@(Subfeature { sfTree = t }) = do
+testSubfeature sf@Subfeature{ sfData = t } = do
-  atm <- testActionTree t
+  t' <- testRoot t
-  return $ either untestable checkAction atm
+  -- monomorphism restriction :(
+  return $ bimap (\n -> sf { sfData = n }) (\n -> sf { sfData = n }) t'
+
+testRoot :: Root a -> IO (Either PostFail (PostPass a))
+testRoot r = do
+  case r of
+    (IORoot a t)              -> go a testIODependency_ testIODependency t
+    (IORoot_ a t)             -> go_ a testIODependency_ t
+    (DBusRoot a t (Just cl))  -> go (`a` cl) (testDBusDependency_ cl) testIODependency t
+    (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDependency_ cl) t
+    _                         -> return $ Left $ PostMissing "client not available"
   where
-    untestable (t', err) = Untestable (fd { sfTree = t' }) err
+    go a f_ f t = bimap PostFail (fmap a) <$> testTree f_ f t
-    checkAction (t', Just a, ms) = SuccessfulFtr
+    go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
-      $ Finished { finData = fd { sfTree = t' }
-                 , finAction = a
-                 , finWarnings = ms
-                 }
-    checkAction (t', Nothing, ms) = FailedFtr (fd { sfTree = t' }) ms
 
-testActionTree :: ActionTree m Tree -> IO (ActionTreeMaybe m p)
+--------------------------------------------------------------------------------
-testActionTree t = do
+-- | Payloaded dependency testing
-  case t of
+
-    (IOTree a d)             -> do
+type Result p = Either [String] (PostPass p)
-      (t', a', msgs) <- doTest testIOTree d a
+
-      return $ Right (IOTree a t', a', msgs)
+testTree :: (d_ -> IO Result_) -> (d p -> IO (Result p)) -> Tree d d_ p
-    (DBusTree a (Just cl) d) -> do
+  -> IO (Either [String] (PostPass p))
-      (t', a', msgs) <- doTest (testDBusTree cl) d a
+testTree test_ test = go
-      return $ Right (DBusTree a (Just cl) t', fmap (\f -> f cl) a', msgs)
+  -- TODO clean this up
-    _                        -> return $ Left (t, "client not available")
   where
-    doTest testFun d a = do
+    go (And12 f a b) = either (return . Left) (\ra -> (and2nd f ra =<<) <$> go b)
-      (t', r) <- testFun d
+      =<< go a
-      -- TODO actually recover the proper error messages
+    go (And1 f a b) = do
-      let (a', msgs) = maybe (Nothing, []) (\p -> (fmap (apply a) p, [])) r
+      ra <- go a
-      return (t', a', msgs)
+      case ra of
-    apply (Standalone a) _ = a
+        (Right (PostPass pa wa)) -> do
-    apply (Consumer a) p   = a p
+          rb <- testTree_ test_ b
-
+          return $ case rb of
-testIOTree :: Tree (IODependency p) p
+            (Left es)  -> Left es
-  -> IO (ResultTree (IODependency p) p, Maybe (Maybe p))
+            (Right wb) -> Right $ PostPass (f pa) $ wa ++ wb
-testIOTree = testTree testIODependency
+        l -> return l
-
+    go (And2 f a b) = do
-testDBusTree :: Client -> Tree (DBusDependency p) p
+      ra <- testTree_ test_ a
-  -> IO (ResultTree (DBusDependency p) p, Maybe (Maybe p))
+      case ra of
-testDBusTree client = testTree (testDBusDependency client)
+        (Right wa) -> do
-
+          rb <- go b
-testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
+          return $ case rb of
-  -> m (ResultTree d p, Maybe (Maybe p))
+            (Left es)                -> Left es
-testTree test = go
+            (Right (PostPass pb wb)) -> Right $ PostPass (f pb) $ wa ++ wb
-  where
+        (Left l) -> return $ Left l
-    go (And f a b) = do
-      (ra, pa) <- go a
-      let combine = maybe (const Nothing) (\pa' -> Just . f pa')
-      let pass p = test2nd (combine p) ra b
-      let fail_ = return (First ra b, Nothing)
-      maybe fail_ pass pa
     go (Or fa fb a b) = do
-      (ra, pa) <- go a
+      ra <- go a
-      let pass p = return (First ra b, Just $ fa <$> p)
+      case ra of
-      let fail_ = test2nd (Just . fb) ra b
+        (Right (PostPass pa wa)) -> return $ Right $ PostPass (fa pa) wa
-      maybe fail_ pass pa
+        (Left ea)                -> (or2nd fb ea =<<) <$> go b
-    go (Only a) =
+    go (Only a)    = test a
-      either (\es -> (LeafFail a es, Nothing)) (\(p, ws) -> (LeafSuccess a ws, Just p))
+    and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb
-      <$> test a
+    or2nd f es (PostPass pb wb) = Right $ PostPass (f pb) $ es ++ wb
-    test2nd f ra b = do
-      (rb, pb) <- go b
-      return (Both ra rb, fmap (f =<<) pb)
 
-testIODependency :: IODependency p -> IO (Summary p)
+testIODependency :: IODependency p -> IO (Result p)
-testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
+testIODependency (IORead _ t)      = t
+testIODependency (IOAlways a f)    = Right . fmap f <$> evalAlwaysMsg a
+testIODependency (IOSometimes x f) = second (fmap f) <$> evalSometimesMsg x
+
+--------------------------------------------------------------------------------
+-- | Standalone dependency testing
+
+type Result_ = Either [String] [String]
+
+testTree_ :: (d -> IO Result_) -> Tree_ d -> IO (Either [String] [String])
+testTree_ test = go
   where
-    err = Left ["executable '" ++ bin ++ "' not found"]
+    go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a
+    go (Or_ a b)  = either (`test2nd` b) (return . Right) =<< go a
+    go (Only_ a)  = test a
+    test2nd ws = fmap ((Right . (ws ++)) =<<) . go
 
-testIODependency (IOTest _ t) = maybe (Right (Nothing, [])) (Left . (:[])) <$> t
+testIODependency_ :: IODependency_ -> IO Result_
+testIODependency_ (IOSystem_ s) = maybe (Right []) (Left . (:[])) <$> testSysDependency s
+testIODependency_ (IOSometimes_ x) = second (\(PostPass _ ws) -> ws) <$> evalSometimesMsg x
 
-testIODependency (IORead _ t) = bimap (:[]) (, []) <$> t
+testSysDependency :: SystemDependency -> IO (Maybe String)
-
+testSysDependency (IOTest _ t) = t
-testIODependency (Systemd t n) = do
+testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
+  <$> findExecutable bin
+  where
+    msg = unwords [e, "executable", quote bin, "not found"]
+    e = if sys then "system" else "local"
+testSysDependency (Systemd t n) = do
   (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
   return $ case rc of
-    ExitSuccess -> Right (Nothing, [])
+    ExitSuccess -> Nothing
-    _           -> Left ["systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"]
+    _           -> Just $ "systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"
   where
     cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
     unitType SystemUnit = "system"
     unitType UserUnit   = "user"
-
+testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
-testIODependency (AccessiblePath p r w) = do
-  res <- getPermissionsSafe p
-  let msg = permMsg res
-  return msg
   where
     testPerm False _ _  = Nothing
     testPerm True f res = Just $ f res
-    permMsg NotFoundError            = smryFail "file not found"
+    permMsg NotFoundError            = Just "file not found"
-    permMsg PermError                = smryFail "could not get permissions"
+    permMsg PermError                = Just "could not get permissions"
     permMsg (PermResult res) =
       case (testPerm r readable res, testPerm w writable res) of
-        (Just False, Just False) -> smryFail "file not readable or writable"
+        (Just False, Just False) -> Just "file not readable or writable"
-        (Just False, _)          -> smryFail "file not readable"
+        (Just False, _)          -> Just "file not readable"
-        (_, Just False)          -> smryFail "file not writable"
+        (_, Just False)          -> Just "file not writable"
-        _                        -> Right (Nothing, [])
+        _                        -> Nothing
 
--- TODO actually collect errors here
+testDBusDependency_ :: Client -> DBusDependency_ -> IO Result_
-testIODependency (NestedAlways a f) = do
+testDBusDependency_ client (Bus bus) = do
-  r <- testAlways a
-  return $ Right $ case r of
-    (Primary (Finished { finAction = act }) _ _) -> (Just $ f act, [])
-    (Fallback act _)                             -> (Just $ f act, [])
-
-testIODependency (NestedSometimes x f) = do
-  TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
-  return $ maybe (Left []) (\Finished { finAction = a } -> Right (Just $ f a, [])) s
-
-testDBusDependency :: Client -> DBusDependency p -> IO (Summary p)
-testDBusDependency client (Bus bus) = do
   ret <- callMethod client queryBus queryPath queryIface queryMem
   return $ case ret of
         Left e    -> smryFail e
         Right b -> let ns = bodyGetNames b in
-          if bus' `elem` ns then Right (Nothing, [])
+          if bus' `elem` ns then Right []
           else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
   where
     bus' = formatBusName bus
@@ -479,7 +419,7 @@ testDBusDependency client (Bus bus) = do
     bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
     bodyGetNames _   = []
 
-testDBusDependency client (Endpoint busname objpath iface mem) = do
+testDBusDependency_ client (Endpoint busname objpath iface mem) = do
   ret <- callMethod client busname objpath introspectInterface introspectMethod
   return $ case ret of
         Left e     -> smryFail e
@@ -488,7 +428,7 @@ testDBusDependency client (Endpoint busname objpath iface mem) = do
     procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
                           =<< listToMaybe body in
       case res of
-        Just True -> Right (Nothing, [])
+        Just True -> Right []
         _         -> smryFail $ fmtMsg' mem
     findMem = fmap (matchMem mem)
       . find (\i -> I.interfaceName i == iface)
@@ -509,7 +449,124 @@ testDBusDependency client (Endpoint busname objpath iface mem) = do
       , formatBusName busname
       ]
 
-testDBusDependency _ (DBusIO d) = testIODependency d
+testDBusDependency_ _ (DBusIO i) = testIODependency_ i
+
+--------------------------------------------------------------------------------
+-- | Constructor functions
+
+sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
+sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
+
+-- always1_ :: LogLevel -> String -> Root a Tree -> a -> Always a
+-- always1_ l n t x =
+--   Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x)
+
+sometimes1 :: String -> Root a -> Sometimes a
+sometimes1 = sometimes1_ Error
+
+sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
+sometimesIO n t x = sometimes1 n $ IORoot_ x t
+
+sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
+  -> (Client -> a) -> Sometimes a
+sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
+
+--------------------------------------------------------------------------------
+-- | IO Lifting functions
+
+ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
+ioSometimes = fmap ioSubfeature
+
+ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
+ioAlways (Always x)    = Always $ io x
+ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
+
+ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
+ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
+
+-- data Msg = Msg LogLevel String String
+
+ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
+ioRoot (IORoot a t)       = IORoot (io . a) t
+ioRoot (IORoot_ a t)      = IORoot_ (io a) t
+ioRoot (DBusRoot a t cl)  = DBusRoot (\p c -> io $ a p c) t cl
+ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
+
+-- --------------------------------------------------------------------------------
+-- | Dependency Tree
+
+listToAnds :: d -> [d] -> Tree_ d
+listToAnds i = foldr (And_ . Only_) (Only_ i)
+
+toAnd :: d -> d -> Tree_ d
+toAnd a b = And_ (Only_ a) (Only_ b)
+
+smryFail :: String -> Either [String] a
+smryFail msg = Left [msg]
+
+--------------------------------------------------------------------------------
+-- | IO Dependency
+
+sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
+sometimesExe n sys path = sometimesExeArgs n sys path []
+
+sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
+sometimesExeArgs n sys path args =
+  sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
+
+exe :: Bool -> String -> IODependency_
+exe b = IOSystem_ . Executable b
+
+sysExe :: String -> IODependency_
+sysExe = exe True
+
+localExe :: String -> IODependency_
+localExe = exe False
+
+pathR :: String -> IODependency_
+pathR n = IOSystem_ $ AccessiblePath n True False
+
+pathW :: String -> IODependency_
+pathW n = IOSystem_ $ AccessiblePath n False True
+
+pathRW :: String -> IODependency_
+pathRW n = IOSystem_ $ AccessiblePath n True True
+
+sysd :: UnitType -> String -> IODependency_
+sysd u = IOSystem_ . Systemd u
+
+sysdUser :: String -> IODependency_
+sysdUser = sysd UserUnit
+
+sysdSystem :: String -> IODependency_
+sysdSystem = sysd SystemUnit
+
+sysTest :: String -> IO (Maybe String) -> IODependency_
+sysTest n = IOSystem_ . IOTest n
+
+--------------------------------------------------------------------------------
+-- | DBus Dependency Result
+
+introspectInterface :: InterfaceName
+introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
+
+introspectMethod :: MemberName
+introspectMethod = memberName_ "Introspect"
+
+sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
+  -> MemberName -> Maybe Client -> Sometimes (m ())
+sometimesEndpoint name busname path iface mem client =
+  sometimesDBus client name deps cmd
+  where
+    deps = Only_ $ Endpoint busname path iface $ Method_ mem
+    cmd c = io $ void $ callMethod c busname path iface mem
+
+--------------------------------------------------------------------------------
+-- | Dependency Testing
+--
+-- Here we test all dependencies and keep the tree structure so we can print it
+-- for diagnostic purposes. This obviously has overlap with feature evaluation
+-- since we need to resolve dependencies to build each feature.
 
 --------------------------------------------------------------------------------
 -- | Printing
@@ -525,3 +582,22 @@ testDBusDependency _ (DBusIO d) = testIODependency d
 --   | otherwise = skip
 --   where
 --     bracket s = "[" ++ s ++ "]"
+
+bracket :: String -> String
+bracket s = "[" ++ s ++ "]"
+
+quote :: String -> String
+quote s = "'" ++ s ++ "'"
+
+failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
+failedMsgs err = fmap concat . mapM (failedMsg err)
+
+failedMsg :: Bool -> SubfeatureFail -> IO [String]
+failedMsg err Subfeature { sfData = d, sfName = n } = do
+  mapM (fmtMsg err n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
+
+fmtMsg :: Bool -> String -> String -> IO String
+fmtMsg err n msg = do
+  let e = if err then "ERROR" else "WARNING"
+  p <- getProgName
+  return $ unwords [bracket p, bracket e, bracket n, msg]

lib/Xmobar/Plugins/Bluetooth.hs

@@ -55,7 +55,7 @@ import           Xmobar.Plugins.Common
 btAlias :: String
 btAlias = "bluetooth"
 
-btDep :: DBusDependency p
+btDep :: DBusDependency_
 btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
 
 data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)

lib/Xmobar/Plugins/Device.hs

@@ -41,7 +41,7 @@ getByIP = memberName_ "GetDeviceByIpIface"
 devSignal :: String
 devSignal = "Ip4Connectivity"
 
-devDep :: DBusDependency p
+devDep :: DBusDependency_
 devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
 
 getDevice :: Client -> String -> IO (Maybe ObjectPath)

lib/Xmobar/Plugins/VPN.hs

@@ -118,5 +118,5 @@ vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
 vpnAlias :: String
 vpnAlias = "vpn"
 
-vpnDep :: DBusDependency p
+vpnDep :: DBusDependency_
 vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects