WIP transition all dependencies to new framework

lib/XMonad/Internal/Command/DMenu.hs

@@ -56,8 +56,8 @@ myDmenuNetworks = "networkmanager_dmenu"
 --------------------------------------------------------------------------------
 -- | Other internal functions
 
-spawnDmenuCmd :: String -> [String] -> FeatureX
+spawnDmenuCmd :: String -> [String] -> SometimesX
-spawnDmenuCmd n = featureExeArgs n myDmenuCmd
+spawnDmenuCmd n = sometimesExeArgs n True myDmenuCmd
 
 themeArgs :: String -> [String]
 themeArgs hexColor =
@@ -71,66 +71,83 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
 --------------------------------------------------------------------------------
 -- | Exported Commands
 
-runDevMenu :: FeatureX
+runDevMenu :: SometimesX
-runDevMenu = featureDefault "device manager" (Only $ exe myDmenuDevices) $ do
+runDevMenu = sometimesIO "device manager" (Only $ Executable False myDmenuDevices) $ do
   c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
   spawnCmd myDmenuDevices
     $ ["-c", c]
     ++ "--" : themeArgs "#999933"
     ++ myDmenuMatchingArgs
 
-runBTMenu :: FeatureX
+runBTMenu :: SometimesX
-runBTMenu = featureExeArgs "bluetooth selector" myDmenuBluetooth
+runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth
   $ "-c":themeArgs "#0044bb"
 
-runBwMenu :: FeatureX
+runBwMenu :: SometimesX
-runBwMenu = featureDefault "password manager" (Only $ exe myDmenuPasswords) $
+runBwMenu = sometimesIO "password manager" (Only $ Executable False myDmenuPasswords) $
   spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
 
-runVPNMenu :: FeatureX
+runVPNMenu :: SometimesX
-runVPNMenu = featureDefault "VPN selector" (Only $ exe myDmenuVPN) $
+runVPNMenu = sometimesIO "VPN selector" (Only $ Executable False myDmenuVPN) $
   spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
 
--- TODO this is weirdly inverted
+-- runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
+-- runShowKeys x = addName "Show Keybindings" $ do
+--   s <- io $ evalFeature $ runDMenuShowKeys x
+--   ifSatisfied s
+--     $ spawnNotify
+--     $ defNoteError { body = Just $ Text "could not display keymap" }
+
+-- TODO not sure what to do with this yet
 runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
-runShowKeys x = addName "Show Keybindings" $ do
+runShowKeys _ = NamedAction (skip :: (X ()))
-  s <- io $ evalFeature $ runDMenuShowKeys x
+  -- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x
-  ifSatisfied s
+
-    $ spawnNotify
+runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX
+runDMenuShowKeys kbs =
+  Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys)
+
+runNotifyShowKeys :: X ()
+runNotifyShowKeys = spawnNotify
   $ defNoteError { body = Just $ Text "could not display keymap" }
 
-runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
+runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree
-runDMenuShowKeys kbs =
+runDMenuShowKeys' kbs = Subfeature
-  featureDefault "keyboard shortcut menu" (Only $ exe myDmenuCmd) $ io $ do
+  { sfName = "keyboard shortcut menu"
+  , sfTree = IOTree (Standalone act) deps
+  , sfLevel = Warn
+  }
+  where
+    deps = Only $ Executable True myDmenuCmd
+    act = io $ do
       (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
       forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
-  where
     cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
       ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
 
-runCmdMenu :: FeatureX
+runCmdMenu :: SometimesX
 runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
 
-runAppMenu :: FeatureX
+runAppMenu :: SometimesX
 runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 
-runClipMenu :: FeatureX
+runClipMenu :: SometimesX
-runClipMenu =
+runClipMenu = sometimesIO "clipboard manager" deps act
-  featureDefault "clipboard manager" (And (Only $ exe myDmenuCmd) (Only $ exe "greenclip"))
-  $ spawnCmd myDmenuCmd args
   where
+    act = spawnCmd myDmenuCmd args
+    deps = toAnd (Executable True myDmenuCmd) (Executable True "greenclip")
     args = [ "-modi", "\"clipboard:greenclip print\""
            , "-show", "clipboard"
            , "-run-command", "'{cmd}'"
            ] ++ themeArgs "#00c44e"
 
-runWinMenu :: FeatureX
+runWinMenu :: SometimesX
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: FeatureX
+runNetMenu :: SometimesX
 runNetMenu =
-  featureExeArgs "network control menu" myDmenuNetworks $ themeArgs "#ff3333"
+  sometimesExeArgs "network control menu" True myDmenuNetworks $ themeArgs "#ff3333"
 
-runAutorandrMenu :: FeatureX
+runAutorandrMenu :: SometimesX
 runAutorandrMenu =
-  featureExeArgs "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066"
+  sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066"

lib/XMonad/Internal/Command/Desktop.hs

@@ -91,51 +91,53 @@ ethernetIface = "enp7s0f1"
 --------------------------------------------------------------------------------
 -- | Some nice apps
 
-runTerm :: FeatureX
+runTerm :: SometimesX
-runTerm = featureExe "terminal" myTerm
+runTerm = sometimesExe "terminal" True myTerm
 
-runTMux :: FeatureX
+runTMux :: SometimesX
-runTMux = featureDefault "terminal multiplexer" deps cmd
+runTMux = sometimesIO "terminal multiplexer" deps act
   where
-    deps = listToAnds (exe myTerm) $ fmap exe ["tmux", "bash"]
+    deps = listToAnds (Executable True myTerm) $ fmap (Executable True) ["tmux", "bash"]
-    cmd = spawn
+    act = spawn
       $ "tmux has-session"
       #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
       #!|| fmtNotifyCmd defNoteError { body = Just $ Text msg }
     c = "exec tmux attach-session -d"
     msg = "could not connect to tmux session"
 
-runCalc :: FeatureX
+runCalc :: SometimesX
-runCalc = featureDefault "calculator" (And (Only $ exe myTerm) (Only $ exe "R"))
+runCalc = sometimesIO "calculator" deps act
-  $ spawnCmd myTerm ["-e", "R"]
+  where
+    deps = toAnd (Executable True myTerm) (Executable True "R")
+    act = spawnCmd myTerm ["-e", "R"]
 
-runBrowser :: FeatureX
+runBrowser :: SometimesX
-runBrowser = featureExe "web browser" myBrowser
+runBrowser = sometimesExe "web browser" False myBrowser
 
-runEditor :: FeatureX
+runEditor :: SometimesX
-runEditor = featureExeArgs "text editor" myEditor
+runEditor = sometimesExeArgs "text editor" True myEditor
   ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
 
-runFileManager :: FeatureX
+runFileManager :: SometimesX
-runFileManager = featureExe "file browser" "pcmanfm"
+runFileManager = sometimesExe "file browser" True "pcmanfm"
 
 --------------------------------------------------------------------------------
 -- | Multimedia Commands
 
-runMultimediaIfInstalled :: String -> String -> FeatureX
+runMultimediaIfInstalled :: String -> String -> SometimesX
 runMultimediaIfInstalled n cmd =
-  featureExeArgs (n ++ " multimedia control") myMultimediaCtl [cmd]
+  sometimesExeArgs (n ++ " multimedia control") True myMultimediaCtl [cmd]
 
-runTogglePlay :: FeatureX
+runTogglePlay :: SometimesX
 runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
 
-runPrevTrack :: FeatureX
+runPrevTrack :: SometimesX
 runPrevTrack = runMultimediaIfInstalled "previous track" "previous"
 
-runNextTrack :: FeatureX
+runNextTrack :: SometimesX
 runNextTrack = runMultimediaIfInstalled "next track" "next"
 
-runStopPlay :: FeatureX
+runStopPlay :: SometimesX
 runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
 
 --------------------------------------------------------------------------------
@@ -151,48 +153,48 @@ playSound file = do
   -- paplay seems to have less latency than aplay
   spawnCmd "paplay" [p]
 
-featureSound :: String -> FilePath -> X () -> X () -> FeatureX
+featureSound :: String -> FilePath -> X () -> X () -> SometimesX
 featureSound n file pre post =
-  featureDefault ("volume " ++ n ++ " control") (Only $ exe "paplay")
+  sometimesIO ("volume " ++ n ++ " control") (Only $ Executable True "paplay")
   $ pre >> playSound file >> post
 
-runVolumeDown :: FeatureX
+runVolumeDown :: SometimesX
 runVolumeDown = featureSound "up" volumeChangeSound (return ()) $ void (lowerVolume 2)
 
-runVolumeUp :: FeatureX
+runVolumeUp :: SometimesX
 runVolumeUp = featureSound "down" volumeChangeSound (return ()) $ void (raiseVolume 2)
 
-runVolumeMute :: FeatureX
+runVolumeMute :: SometimesX
 runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
 
 --------------------------------------------------------------------------------
 -- | Notification control
 
-runNotificationCmd :: String -> String -> FeatureX
+runNotificationCmd :: String -> FilePath -> SometimesX
 runNotificationCmd n cmd =
-  featureExeArgs (n ++ " control") myNotificationCtrl [cmd]
+  sometimesExeArgs (n ++ " control") True myNotificationCtrl [cmd]
 
-runNotificationClose :: FeatureX
+runNotificationClose :: SometimesX
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: FeatureX
+runNotificationCloseAll :: SometimesX
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: FeatureX
+runNotificationHistory :: SometimesX
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: FeatureX
+runNotificationContext :: SometimesX
 runNotificationContext =
   runNotificationCmd "open notification context" "context"
 
 --------------------------------------------------------------------------------
 -- | System commands
 
-runToggleBluetooth :: FeatureX
+runToggleBluetooth :: SometimesX
 runToggleBluetooth =
-  featureDefault "bluetooth toggle" (Only $ exe myBluetooth)
+  sometimesIO "bluetooth toggle" (Only $ Executable True myBluetooth)
   $ spawn
   $ myBluetooth ++ " show | grep -q \"Powered: no\""
   #!&& "a=on"
@@ -200,8 +202,8 @@ runToggleBluetooth =
   #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a"  }
 
-runToggleEthernet :: FeatureX
+runToggleEthernet :: SometimesX
-runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "nmcli")
+runToggleEthernet = sometimesIO "ethernet toggle" (Only $ Executable True "nmcli")
   $ spawn
   $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
   #!&& "a=connect"
@@ -209,15 +211,15 @@ runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "nmcli")
   #!>> fmtCmd "nmcli" ["device", "$a", ethernetIface]
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed"  }
 
-runStartISyncTimer :: FeatureX
+runStartISyncTimer :: SometimesX
-runStartISyncTimer = featureDefault "isync timer" (Only $ userUnit "mbsync.timer")
+runStartISyncTimer = sometimesIO "isync timer" (Only $ Systemd UserUnit "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 :: FeatureX
+runStartISyncService :: SometimesX
-runStartISyncService = featureDefault "isync" (Only $ userUnit "mbsync.service")
+runStartISyncService = sometimesIO "isync" (Only $ Systemd UserUnit "mbsync.service")
   $ spawn
   $ "systemctl --user start mbsync.service"
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@@ -261,25 +263,25 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
-runFlameshot :: String -> String -> FeatureX
+runFlameshot :: String -> String -> SometimesX
-runFlameshot n mode = featureDefault n (Only $ exe myCapture)
+runFlameshot n mode = sometimesIO n (Only $ Executable True myCapture)
   $ spawnCmd myCapture [mode]
 
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: FeatureX
+runAreaCapture :: SometimesX
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: FeatureX
+runDesktopCapture :: SometimesX
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: FeatureX
+runScreenCapture :: SometimesX
 runScreenCapture = runFlameshot "screen capture" "screen"
 
-runCaptureBrowser :: FeatureX
+runCaptureBrowser :: SometimesX
 runCaptureBrowser =
-  featureDefault "screen capture browser" (Only $ exe myImageBrowser) $ do
+  sometimesIO "screen capture browser" (Only $ Executable True myImageBrowser) $ do
   dir <- io getCaptureDir
   spawnCmd myImageBrowser [dir]

lib/XMonad/Internal/Command/Power.hs

@@ -45,8 +45,8 @@ myOptimusManager = "optimus-manager"
 --------------------------------------------------------------------------------
 -- | Core commands
 
-runScreenLock :: Feature (X ())
+runScreenLock :: SometimesX
-runScreenLock = featureExe "screen locker" myScreenlock
+runScreenLock = sometimesExe "screen locker" True myScreenlock
 
 runPowerOff :: X ()
 runPowerOff = spawn "systemctl poweroff"
@@ -100,8 +100,8 @@ runOptimusPrompt' = do
       #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
       #!&& "killall xmonad"
 
-runOptimusPrompt :: FeatureX
+runOptimusPrompt :: SometimesX
-runOptimusPrompt = featureDefault "graphics switcher" (Only $ exe myOptimusManager)
+runOptimusPrompt = sometimesIO "graphics switcher" (Only $ Executable True myOptimusManager)
   runOptimusPrompt'
 
 --------------------------------------------------------------------------------

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -94,8 +94,8 @@ 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 :: FeatureIO
+runPowermon :: SometimesIO
-runPowermon = featureDefault "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,16 +107,16 @@ clevoKeyboardConfig = BrightnessConfig
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-stateFileDep :: FullDep Dependency
+stateFileDep :: IODependency a p
 stateFileDep = pathRW stateFile
 
-brightnessFileDep :: FullDep Dependency
+brightnessFileDep :: IODependency a p
 brightnessFileDep = pathR brightnessFile
 
-clevoKeyboardSignalDep :: DBusDep
+clevoKeyboardSignalDep :: DBusDependency RawBrightness p
 clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
 
-exportClevoKeyboard :: Maybe Client -> FeatureIO
+exportClevoKeyboard :: Maybe Client -> SometimesIO
 exportClevoKeyboard =
   brightnessExporter [stateFileDep, brightnessFileDep] clevoKeyboardConfig
 

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

@@ -45,10 +45,10 @@ data BrightnessConfig a b = BrightnessConfig
   }
 
 data BrightnessControls = BrightnessControls
-  { bctlMax :: FeatureIO
+  { bctlMax :: SometimesIO
-  , bctlMin :: FeatureIO
+  , bctlMin :: SometimesIO
-  , bctlInc :: FeatureIO
+  , bctlInc :: SometimesIO
-  , bctlDec :: FeatureIO
+  , bctlDec :: SometimesIO
   }
 
 brightnessControls :: BrightnessConfig a b -> Maybe Client -> BrightnessControls
@@ -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 -> DBusDep
+signalDep :: BrightnessConfig a b -> DBusDependency a p
 signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
   Endpoint xmonadBusName p i $ Signal_ memCur
 
@@ -85,14 +85,12 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
 --------------------------------------------------------------------------------
 -- | Internal DBus Crap
 
-brightnessExporter :: RealFrac b => [FullDep Dependency] -> BrightnessConfig a b
+brightnessExporter :: RealFrac b => [IODependency (IO ()) (Maybe x)]
-  -> Maybe Client -> FeatureIO
+  -> BrightnessConfig a b -> Maybe Client -> SometimesIO
-brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature
+brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
-  (n ++ " exporter") Default
+  sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
-  $ DBusTree (Single (exportBrightnessControls' bc)) client ds
   where
-    ds = listToAnds (fullDep $ Bus xmonadBusName)
+    ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
-      $ fmap (fmap DBusGenDep) deps
 
 exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
 exportBrightnessControls' bc client = do
@@ -130,11 +128,11 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
     sig = signal p i memCur
 
 callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
-  -> FeatureIO
+  -> SometimesIO
 callBacklight client BrightnessConfig { bcPath = p
                                       , bcInterface = i
                                       , bcName = n } controlName m =
-  featureEndpoint (unwords [n, controlName]) xmonadBusName p i m client
+  sometimesEndpoint (unwords [n, controlName]) xmonadBusName p i m client
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

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

@@ -89,16 +89,16 @@ intelBacklightConfig = BrightnessConfig
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-curFileDep :: FullDep Dependency
+curFileDep :: IODependency a p
 curFileDep = pathRW curFile
 
-maxFileDep :: FullDep Dependency
+maxFileDep :: IODependency a p
 maxFileDep = pathR maxFile
 
-intelBacklightSignalDep :: DBusDep
+intelBacklightSignalDep :: DBusDependency RawBrightness p
 intelBacklightSignalDep = signalDep intelBacklightConfig
 
-exportIntelBacklight :: Maybe Client -> FeatureIO
+exportIntelBacklight :: Maybe Client -> SometimesIO
 exportIntelBacklight =
   brightnessExporter [curFileDep, maxFileDep] intelBacklightConfig
 

lib/XMonad/Internal/DBus/Control.hs

@@ -30,7 +30,7 @@ startXMonadService :: IO (Maybe Client)
 startXMonadService = do
   client <- getDBusClient False
   forM_ client requestXMonadName
-  mapM_ (\f -> executeFeature_ $ f client) dbusExporters
+  mapM_ (\f -> executeSometimes_ $ f client) dbusExporters
   return client
 
 stopXMonadService :: Client -> IO ()
@@ -51,5 +51,5 @@ requestXMonadName client = do
   where
     xn = "'" ++ formatBusName xmonadBusName ++ "'"
 
-dbusExporters :: [Maybe Client -> FeatureIO]
+dbusExporters :: [Maybe Client -> SometimesIO]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

lib/XMonad/Internal/DBus/Removable.hs

@@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
 memRemoved :: MemberName
 memRemoved = memberName_ "InterfacesRemoved"
 
-dbusDep :: MemberName -> FullDep DBusDep
+dbusDep :: MemberName -> DBusDependency a p
-dbusDep m = fullDep $ Endpoint bus path interface $ Signal_ m
+dbusDep m = Endpoint bus path interface $ Signal_ m
 
-addedDep :: FullDep DBusDep
+addedDep :: DBusDependency a p
 addedDep = dbusDep memAdded
 
-removedDep :: FullDep DBusDep
+removedDep :: DBusDependency a p
 removedDep = dbusDep memRemoved
 
 driveInsertedSound :: FilePath
@@ -81,6 +81,8 @@ listenDevices client = do
     addMatch' m p f = void $ addMatch client ruleUdisks { matchMember = Just m }
       $ playSoundMaybe p . f . signalBody
 
-runRemovableMon :: Maybe Client -> FeatureIO
+runRemovableMon :: Maybe Client -> SometimesIO
-runRemovableMon client = feature "removeable device monitor" Default
+runRemovableMon cl =
-  $ DBusTree (Single listenDevices) client $ And (Only addedDep) (Only removedDep)
+  sometimesDBus cl "removeable device monitor" deps listenDevices
+  where
+    deps = toAnd addedDep removedDep

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -94,9 +94,9 @@ bodyGetCurrentState _   = Nothing
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-exportScreensaver :: Maybe Client -> FeatureIO
+exportScreensaver :: Maybe Client -> SometimesIO
-exportScreensaver client = feature "screensaver interface" Default
+exportScreensaver client =
-  $ DBusTree (Single cmd) client (And (Only bus) (Only ssx))
+  sometimesDBus client "screensaver interface" (toAnd bus ssx) cmd
   where
     cmd cl = export cl ssPath defaultInterface
       { interfaceName = interface
@@ -116,12 +116,12 @@ exportScreensaver client = feature "screensaver interface" Default
           }
         ]
       }
-    bus = fullDep $ Bus xmonadBusName
+    bus = Bus xmonadBusName
-    ssx = fullDep $ DBusGenDep $ Executable ssExecutable
+    ssx = DBusIO $ Executable True ssExecutable
 
-callToggle :: Maybe Client -> FeatureIO
+callToggle :: Maybe Client -> SometimesIO
-callToggle =
+callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
-  featureEndpoint "screensaver toggle" xmonadBusName ssPath interface memToggle
+  interface memToggle
 
 callQuery :: Client -> IO (Maybe SSState)
 callQuery client = do
@@ -132,5 +132,5 @@ matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
 matchSignal cb =
   fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
 
-ssSignalDep :: DBusDep
+ssSignalDep :: DBusDependency a p
 ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState

lib/XMonad/Internal/Dependency.hs

@@ -1,55 +1,56 @@
-{-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE GADTs         #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 --------------------------------------------------------------------------------
 -- | Functions for handling dependencies
 
 module XMonad.Internal.Dependency
-  ( MaybeAction
+  ( AlwaysX
-  , AnyFeature(..)
+  , AlwaysIO
-  , DepChoice(..)
+  , Always(..)
-  , MaybeX
+  , SometimesX
-  , FullDep(..)
+  , SometimesIO
-  , DepTree(..)
+  , Sometimes
+  , executeSometimes_
+  , executeSometimes
+  , executeAlways_
+  , executeAlways
+  , evalAlways
+  , evalSometimes
+
+  , Subfeature(..)
+  , LogLevel(..)
+
   , Action(..)
-  , DBusDep(..)
+
-  , FeatureX
+  -- feature construction
-  , FeatureIO
+  , sometimes1
-  , Feature(..)
+  , sometimesIO
-  , Feature_(..)
+  , sometimesDBus
-  , Warning(..)
+  , sometimesExe
-  , Dependency(..)
+  , sometimesExeArgs
-  , UnitType(..)
+  , sometimesEndpoint
+
+  -- Dependency tree
+  , ActionTree(..)
+  , Tree(..)
+  , IODependency(..)
+  , DBusDependency(..)
   , DBusMember(..)
-  , feature
+  , UnitType(..)
-  , ioFeature
-  , evalFeature
-  , systemUnit
-  , userUnit
-  , pathR
-  , pathW
-  , pathRW
-  , featureDefault
-  , featureExeArgs
-  , featureExe
-  , featureEndpoint
-  , whenSatisfied
-  , ifSatisfied
-  , executeFeature
-  , executeFeature_
-  , executeFeatureWith
-  , executeFeatureWith_
-  , depName
-  , fullDep
-  , exe
   , listToAnds
+  , toAnd
+  , pathR
+  , pathRW
+  , pathW
   ) where
 
 import           Control.Monad.IO.Class
 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
@@ -70,370 +71,384 @@ import           XMonad.Internal.Shell
 
 --------------------------------------------------------------------------------
 -- | Features
---
--- A 'feature' is composed of a 'dependency tree' which at the root has an
--- 'action' to be performed with a number of 'dependencies' below it.
---
--- NOTE: there is no way to make a feature depend on another feature. This is
--- very complicated to implement and would only be applicable to a few instances
--- (notably the dbus interfaces). In order to implement a dependency tree, use
--- dependencies that target the output/state of another feature; this is more
--- robust anyways, at the cost of being a bit slower.
 
--- TODO some things to add to make this more feature-ful (lol)
+-- data AlwaysAny = AX AlwaysX | AIO AlwaysIO
--- - use AndOr types to encode alternative dependencies into the tree
--- - use an Alt data constructor for Features (which will mean "try A before B"
--- - add an Either String Bool to dependency nodes that encodes testing status
---   (where Right False means untested)
--- - add a lens/functor mapper thingy to walk down the tree and update testing
---   status fields
--- - print to JSON
--- - make sum type to hold all type instances of Feature blabla (eg IO and X)
--- - figure out how to make features a dependency of another feature
 
-data Feature_ a = Feature_
+type AlwaysX = Always (X ())
-  { ftrDepTree :: DepTree a
+
-  , ftrName    :: String
+type AlwaysIO = Always (IO ())
-  , ftrWarning :: Warning
+
+type SometimesX = Sometimes (X ())
+
+type SometimesIO = Sometimes (IO ())
+
+data Always a = Option (Subfeature a Tree) (Always a) | Always a
+
+type Sometimes a = [Subfeature a Tree]
+
+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]
   }
 
-data Feature a = Feature (Feature_ a) (Feature a)
+type FailedFeature a p = Either (Subfeature a Tree, String)
-  | NoFeature
+  (Subfeature a ResultTree, [String])
-  | ConstFeature a
 
--- TODO this is silly as is, and could be made more useful by representing
+data Finished a p = Finished
--- loglevels
+  { finData     :: Subfeature a ResultTree
-data Warning = Silent | Default
+  , finAction   :: a
-
+  , finWarnings :: [String]
-type FeatureX = Feature (X ())
-
-type FeatureIO = Feature (IO ())
-
-data AnyFeature = FX FeatureX | FIO FeatureIO
-
-feature :: String -> Warning -> DepTree a -> Feature a
-feature n w t = Feature f NoFeature
-  where
-    f = Feature_
-      { ftrDepTree = t
-      , ftrName = n
-      , ftrWarning = w
   }
 
-ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
+data FeatureResult a p = Untestable (Subfeature a Tree) String |
-ioFeature (ConstFeature a) = ConstFeature $ liftIO a
+  FailedFtr (Subfeature a ResultTree) [String] |
-ioFeature NoFeature = NoFeature
+  SuccessfulFtr (Finished a p)
-ioFeature (Feature f r)
-  = Feature (f {ftrDepTree = liftIO <$> ftrDepTree f}) $ ioFeature r
 
-featureDefault :: String -> DepChoice (FullDep Dependency) -> a -> Feature a
+type ActionTreeMaybe a p = Either (ActionTree a Tree, String)
-featureDefault n ds x = feature n Default $ GenTree (Single x) ds
+  (ActionTree a ResultTree, Maybe a, [String])
 
-featureExe :: MonadIO m => String -> String -> Feature (m ())
+sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a
-featureExe n cmd = featureExeArgs n cmd []
+sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }]
 
-featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
+always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
-featureExeArgs n cmd args =
+always1_ l n t x =
-  featureDefault n (Only $ FullDep (Right False) $ Executable cmd) $ spawnCmd cmd args
+  Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
 
-featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
+sometimes1 :: String -> ActionTree a Tree -> Sometimes a
-  -> MemberName -> Maybe Client -> FeatureIO
+sometimes1 = sometimes1_ Error
-featureEndpoint name busname path iface mem client = feature name Default
+
-  $ DBusTree (Single cmd) client deps
+sometimesIO :: String -> Tree (IODependency a p) p -> a -> Sometimes a
-  where
+sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t
-    cmd c = void $ callMethod c busname path iface mem
+
-    deps = Only $ FullDep (Right False) $ Endpoint busname path iface $ Method_ mem
+sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency a p) p
+  -> (Client -> a) -> Sometimes a
+sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t
 
 --------------------------------------------------------------------------------
--- | Dependency Trees
+-- | Feature Data
---
--- Dependency trees have two subtypes: general and DBus. The latter require a
--- DBus client to evaluate (and will automatically fail if this is missing).
--- The former can be evaluated independently.
 
-data DepChoice a = And (DepChoice a) (DepChoice a)
+data Subfeature a t = Subfeature
-  | Or (DepChoice a) (DepChoice a)
+  { sfTree  :: ActionTree a t
-  | Only a
+  , sfName  :: String
+  , sfLevel :: LogLevel
+  }
 
-listToAnds :: a -> [a] -> DepChoice a
+data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
-listToAnds i = foldr (And . Only) (Only i)
 
-data DepTree a = GenTree (Action a) (DepChoice (FullDep Dependency))
+data Msg = Msg LogLevel String String
-  | DBusTree (Action (Client -> a)) (Maybe Client) (DepChoice (FullDep DBusDep))
-
-instance Functor DepTree where
-  fmap f (GenTree a ds)    = GenTree (f <$> a) ds
-  fmap f (DBusTree a c ds) = DBusTree (fmap (fmap f) a) c ds
 
 --------------------------------------------------------------------------------
--- | Actions
+-- | Action Tree
---
--- Actions have two subtypes: single and double. Single actions are just one
--- independent action. Double actions have one dependent pre-step which the
--- main action consumes (and fails if the pre-step fails).
 
-data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b))
+data ActionTree a t =
+  forall p. IOTree (Action a p) (t (IODependency a p) p)
+  | forall p. DBusTree (Action (Client -> a) p) (Maybe Client) (t (DBusDependency a p) p)
 
-instance Functor Action where
+data Action a p = Standalone a | Consumer (p -> a)
-  fmap f (Single a)   = Single (f a)
-  fmap f (Double a b) = Double (f . a) b
 
 --------------------------------------------------------------------------------
--- | Feature evaluation
+-- | Dependency Tree
---
--- Evaluate a feature by testing if its dependencies are satisfied, and return
--- either the action of the feature or 0 or more error messages that signify
--- what dependencies are missing and why.
 
-type MaybeAction a = Maybe a
+data Tree d p =
+  And (p -> p -> p) (Tree d p) (Tree d p)
+  | Or (p -> p) (p -> p) (Tree d p) (Tree d p)
+  | Only d
 
-type MaybeX = MaybeAction (X ())
+listToAnds :: d -> [d] -> Tree d (Maybe x)
+listToAnds i = foldr (And (const . const Nothing) . Only) (Only i)
 
-evalFeature :: Feature a -> IO (MaybeAction a)
+toAnd :: d -> d -> Tree d (Maybe x)
-evalFeature (ConstFeature x) = return $ Just x
+toAnd a b = And (const . const Nothing) (Only a) (Only b)
-evalFeature NoFeature = return Nothing
--- TODO actually deal with alt
-evalFeature (Feature (Feature_{ftrDepTree = a, ftrName = n, ftrWarning = w}) _) = do
-  procName <- getProgName
-  res <- evalTree =<< evalTree' a
-  either (printWarnings procName) (return . Just) res
-  where
-    printWarnings procName es = do
-      case w of
-        Silent  -> skip
-        Default -> let prefix = n ++ " disabled; "
-                       es' = fmap (fmtMsg procName . (prefix ++)) es in
-          mapM_ putStrLn es'
-      return Nothing
-    fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
-    bracket s = "[" ++ s ++ "]"
-
-mapMDepChoice :: Monad m => (a -> m a) -> (a -> Bool) -> DepChoice a -> m (DepChoice a)
-mapMDepChoice f pass = fmap snd . go
-  where
-    go d@(And a b) = do
-      (ra, a') <- go a
-      if not ra then return (False, d) else do
-        (rb, b') <- go b
-        return $ if rb then (True, And a' b') else (False, d)
-    go d@(Or a b) = do
-      (ra, a') <- go a
-      if ra then return (True, Or a' b) else do
-        (rb, b') <- go b
-        return $ if rb then (True, Or a' b') else (False, d)
-    go d@(Only a)  = do
-      a' <- f a
-      return $ if pass a' then (True, Only a') else (False, d)
-
--- foldDepChoice :: (a -> Bool) -> DepChoice a -> Bool
--- foldDepChoice get dc = case dc of
---   And a b -> go a && go b
---   Or a b  -> go a || go b
---   Only a  -> get a
---   where
---     go = foldDepChoice get
-
-foldDepChoice' :: Bool -> (a -> Maybe b) -> DepChoice a -> [b]
-foldDepChoice' justSucceed get = fromMaybe [] . go []
-  where
-    go acc (And a b) = Just $ andFun acc a b
-    go acc (Or a b)  = Just $ orFun acc a b
-    go acc (Only a)  = (:acc) <$> get a
-    (andFun, orFun) = if justSucceed then (and', or') else (or', and')
-    and' acc a b = case (go acc a, go acc b) of
-      (Just a', Just b') -> a' ++ b' ++ acc
-      (Just a', Nothing) -> a' ++ acc
-      (Nothing, _)       -> acc
-    or' acc a b = fromMaybe [] (go acc a) ++ fromMaybe [] (go acc b) ++ acc
-
--- foldDepChoice :: DepChoice a -> (a -> Maybe b) -> [b]
--- foldDepChoice dc f = go [] dc
---   where
---     go acc d = case d of
---       And a b -> do
---         acc'@(a':_) <- go acc a
---         if pass a' then go acc' b else return acc
---       Or a b  -> do
---         acc'@(a':_) <- go acc a
---         if pass a' then return [a'] else go acc' b
---       Only a  -> maybe acc $ f a
-
--- TODO wet code
-evalTree :: DepTree a -> IO (Either [String] a)
-evalTree (GenTree a ds) = do
-  case foldDepChoice' False fullDepMsg ds of
-      [] -> evalAction a
-      es -> return $ Left es
-evalTree (DBusTree a (Just client) ds) = do
-  case foldDepChoice' False fullDepMsg ds of
-    [] -> fmap (\f -> f client) <$> evalAction a
-    es -> return $ Left es
-evalTree (DBusTree _ Nothing _) = return $ Left ["client not available"]
-
-fullDepMsg :: FullDep a -> Maybe String
-fullDepMsg (FullDep e _) = either Just (const Nothing) e
-
-evalTree' :: DepTree a -> IO (DepTree a)
-
-evalTree' (GenTree a ds) = GenTree a <$> mapMDepChoice eval pass ds
-  where
-    eval (FullDep _ d) = do
-      r <- evalDependency d
-      return $ FullDep (maybe (Right True) Left r) d
-    pass (FullDep (Right True) _) = True
-    pass  _                       = True
-
-evalTree' d@(DBusTree _ Nothing _) = return d
-evalTree' (DBusTree a (Just client) ds) = DBusTree a (Just client) <$> mapMDepChoice eval pass ds
-  where
-    eval (FullDep _ d) = do
-      r <- eval' d
-      return $ FullDep (maybe (Right True) Left r) d
-    eval' (DBusGenDep d) = evalDependency d
-    eval' x              = dbusDepSatisfied client x
-    pass (FullDep (Right True) _) = True
-    pass  _                       = True
-
-
-evalAction :: Action a -> IO (Either [String] a)
-evalAction (Single a)   = return $ Right a
-evalAction (Double a b) = fmap a <$> b
-
-executeFeatureWith :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
-executeFeatureWith iof def ftr = do
-  a <- io $ evalFeature ftr
-  maybe (return def) (iof . io) a
-
-executeFeatureWith_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
-executeFeatureWith_ iof = executeFeatureWith iof ()
-
-executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
-executeFeature = executeFeatureWith id
-
-executeFeature_ :: Feature (IO ()) -> IO ()
-executeFeature_ = executeFeature ()
-
-whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
-whenSatisfied = flip ifSatisfied skip
-
-ifSatisfied ::  MaybeAction a -> a -> a
-ifSatisfied (Just x) _ = x
-ifSatisfied _ alt      = alt
 
 --------------------------------------------------------------------------------
--- | Dependencies (General)
+-- | Result Tree
 
-data FullDep a = FullDep (Either String Bool) a deriving (Functor)
+-- | 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
 
-fullDep :: a -> FullDep a
+data ResultTree d p =
-fullDep = FullDep (Right True)
+  First (ResultTree d p) (Tree d p)
+  | Both  (ResultTree d p) (ResultTree d p)
+  | LeafSuccess d [String]
+  | LeafFail d [String]
 
-data Dependency = Executable 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 a p = Executable Bool FilePath
   | AccessiblePath FilePath Bool Bool
   | IOTest String (IO (Maybe String))
+  | IORead String (IO (Either String (Maybe p)))
   | Systemd UnitType String
-  | DepFeature AnyFeature
+  | NestedAlways (Always a) (a -> p)
+  | NestedSometimes (Sometimes a) (a -> p)
 
 data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
 
-exe :: String -> FullDep Dependency
+sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
-exe = fullDep . Executable
+sometimesExe n sys path = sometimesExeArgs n sys path []
 
-pathR :: String -> FullDep Dependency
+sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
-pathR n = fullDep $ AccessiblePath n True False
+sometimesExeArgs n sys path args =
+  sometimesIO n (Only (Executable sys path)) $ spawnCmd path args
 
-pathW :: String -> FullDep Dependency
+pathR :: String -> IODependency a p
-pathW n = fullDep $ AccessiblePath n False True
+pathR n = AccessiblePath n True False
 
-pathRW :: String -> FullDep Dependency
+pathW :: String -> IODependency a p
-pathRW n = fullDep $ AccessiblePath n True True
+pathW n = AccessiblePath n False True
 
-systemUnit :: String -> FullDep Dependency
+pathRW :: String -> IODependency a p
-systemUnit = fullDep . Systemd SystemUnit
+pathRW n = AccessiblePath n True True
-
-userUnit :: String -> FullDep Dependency
-userUnit = fullDep . Systemd UserUnit
 
 --------------------------------------------------------------------------------
--- | Dependencies (DBus)
+-- | DBus Dependency Result
+
+data DBusDependency a p =
+  Bus BusName
+  | Endpoint BusName ObjectPath InterfaceName DBusMember
+  | DBusIO (IODependency a p)
 
 data DBusMember = Method_ MemberName
   | Signal_ MemberName
   | Property_ String
   deriving (Eq, Show)
 
-data DBusDep =
-  Bus BusName
-  | Endpoint BusName ObjectPath InterfaceName DBusMember
-  | DBusGenDep Dependency
-
---------------------------------------------------------------------------------
--- | Dependency evaluation (General)
---
--- Test the existence of dependencies and return either Nothing (which actually
--- means success) or Just <error message>.
-
-evalDependency :: Dependency -> IO (Maybe String)
-evalDependency (Executable n)         = exeSatisfied n
-evalDependency (IOTest _ t)           = t
-evalDependency (Systemd t n)          = unitSatisfied t n
-evalDependency (AccessiblePath p r w) = pathSatisfied p r w
-evalDependency (DepFeature _)         = undefined
--- TODO add something here to eval a nested feature's dependencies while
--- bypassing the feature itself
-
-exeSatisfied :: String -> IO (Maybe String)
-exeSatisfied x = do
-  r <- findExecutable x
-  return $ case r of
-    (Just _) -> Nothing
-    _        -> Just $ "executable '" ++ x ++ "' not found"
-
-unitSatisfied :: UnitType -> String -> IO (Maybe String)
-unitSatisfied u x = do
-  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
-  return $ case rc of
-    ExitSuccess -> Nothing
-    _           -> Just $ "systemd " ++ unitType u ++ " unit '" ++ x ++ "' not found"
-  where
-    cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
-    unitType SystemUnit = "system"
-    unitType UserUnit   = "user"
-
-pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
-pathSatisfied p testread testwrite = do
-  res <- getPermissionsSafe p
-  let msg = permMsg res
-  return msg
-  where
-    testPerm False _ _ = Nothing
-    testPerm True f r  = Just $ f r
-    permMsg NotFoundError            = Just "file not found"
-    permMsg PermError                = Just "could not get permissions"
-    permMsg (PermResult r) =
-      case (testPerm testread readable r, testPerm testwrite writable r) of
-        (Just False, Just False) -> Just "file not readable or writable"
-        (Just False, _)          -> Just "file not readable"
-        (_, Just False)          -> Just "file not writable"
-        _                        -> Nothing
-
---------------------------------------------------------------------------------
--- | Dependency evaluation (DBus)
-
 introspectInterface :: InterfaceName
 introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
+sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
-dbusDepSatisfied client (Bus bus) = do
+  -> 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
+
+--------------------------------------------------------------------------------
+-- | Feature evaluation
+--
+-- Here we attempt to build and return the monadic actions encoded by each
+-- feature.
+
+executeSometimes_ :: MonadIO m => Sometimes (m a) -> m ()
+executeSometimes_ = void . executeSometimes
+
+executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
+executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
+
+-- 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
+  return $ maybe (Left []) (\Finished { finAction = a } -> Right (a, [])) s
+
+executeAlways_ :: MonadIO m => Always (m a) -> m ()
+executeAlways_ = void . executeAlways
+
+executeAlways :: MonadIO m => Always (m a) -> m a
+executeAlways = join . evalAlways
+
+-- TODO actually print things
+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 a -> IO (TestedAlways a 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
+        (FailedFtr fd' errs) -> go (Right (fd' ,errs):failed) next
+        (SuccessfulFtr s)    -> return $ Primary s failed next
+    go failed (Always a) = return $ Fallback a failed
+
+testSometimes :: Sometimes a -> IO (TestedSometimes a p)
+testSometimes = go (TestedSometimes Nothing [] [])
+  where
+    go ts [] = return ts
+    go ts (x:xs) = do
+      r <- testSubfeature x
+      case r of
+        (Untestable fd' err) -> go (addFail ts (Left (fd' ,err))) xs
+        (FailedFtr fd' errs) -> go (addFail ts (Right (fd' ,errs))) xs
+        (SuccessfulFtr s)    -> return $ ts { tsSuccess = Just s }
+    addFail ts@(TestedSometimes { tsFailed = f }) new
+      = ts { tsFailed = new:f }
+
+testSubfeature :: Subfeature a Tree -> IO (FeatureResult a p)
+testSubfeature fd@(Subfeature { sfTree = t }) = do
+  atm <- testActionTree t
+  return $ either untestable checkAction atm
+  where
+    untestable (t', err) = Untestable (fd { sfTree = t' }) err
+    checkAction (t', Just a, ms) = SuccessfulFtr
+      $ Finished { finData = fd { sfTree = t' }
+                 , finAction = a
+                 , finWarnings = ms
+                 }
+    checkAction (t', Nothing, ms) = FailedFtr (fd { sfTree = t' }) ms
+
+testActionTree :: ActionTree a Tree -> IO (ActionTreeMaybe a p)
+testActionTree t = do
+  case t of
+    (IOTree a d)             -> do
+      (t', a', msgs) <- doTest testIOTree d a
+      return $ Right (IOTree a t', a', msgs)
+    (DBusTree a (Just cl) d) -> do
+      (t', a', msgs) <- doTest (testDBusTree cl) d a
+      return $ Right (DBusTree a (Just cl) t', fmap (\f -> f cl) a', msgs)
+    _                        -> return $ Left (t, "client not available")
+  where
+    doTest testFun d a = do
+      (t', r) <- testFun d
+      -- TODO actually recover the proper error messages
+      let (a', msgs) = maybe (Nothing, []) (\p -> (fmap (apply a) p, [])) r
+      return (t', a', msgs)
+    apply (Standalone a) _ = a
+    apply (Consumer a) p   = a p
+
+testIOTree :: Tree (IODependency a p) p
+  -> IO (ResultTree (IODependency a p) p, Maybe (Maybe p))
+testIOTree = testTree testIODependency
+
+testDBusTree :: Client -> Tree (DBusDependency a p) p
+  -> IO (ResultTree (DBusDependency a p) p, Maybe (Maybe p))
+testDBusTree client = testTree (testDBusDependency client)
+
+testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
+  -> m (ResultTree d p, Maybe (Maybe p))
+testTree test = go
+  where
+    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
+      let pass p = return (First ra b, Just $ fa <$> p)
+      let fail_ = test2nd (Just . fb) ra b
+      maybe fail_ pass pa
+    go (Only a) =
+      either (\es -> (LeafFail a es, Nothing)) (\(p, ws) -> (LeafSuccess a ws, Just p))
+      <$> test a
+    test2nd f ra b = do
+      (rb, pb) <- go b
+      return (Both ra rb, fmap (f =<<) pb)
+
+testIODependency :: IODependency a p -> IO (Summary p)
+testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
+  where
+    err = Left ["executable '" ++ bin ++ "' not found"]
+
+testIODependency (IOTest _ t) = maybe (Right (Nothing, [])) (Left . (:[])) <$> t
+
+testIODependency (IORead _ t) = bimap (:[]) (, []) <$> t
+
+testIODependency (Systemd t n) = do
+  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
+  return $ case rc of
+    ExitSuccess -> Right (Nothing, [])
+    _           -> Left ["systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"]
+  where
+    cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
+    unitType SystemUnit = "system"
+    unitType UserUnit   = "user"
+
+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 PermError                = smryFail "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, _)          -> smryFail "file not readable"
+        (_, Just False)          -> smryFail "file not writable"
+        _                        -> Right (Nothing, [])
+
+-- TODO actually collect errors here
+testIODependency (NestedAlways a f) = 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 a p -> IO (Summary p)
+testDBusDependency client (Bus bus) = do
   ret <- callMethod client queryBus queryPath queryIface queryMem
   return $ case ret of
-        Left e    -> Just e
+        Left e    -> smryFail e
         Right b -> let ns = bodyGetNames b in
-          if bus' `elem` ns then Nothing
+          if bus' `elem` ns then Right (Nothing, [])
-          else Just $ unwords ["name", singleQuote bus', "not found on dbus"]
+          else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
   where
     bus' = formatBusName bus
     queryBus = busName_ "org.freedesktop.DBus"
@@ -443,17 +458,17 @@ dbusDepSatisfied client (Bus bus) = do
     bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
     bodyGetNames _   = []
 
-dbusDepSatisfied 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     -> Just e
+        Left e     -> smryFail e
         Right body -> procBody body
   where
     procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
                           =<< listToMaybe body in
       case res of
-        Just True -> Nothing
+        Just True -> Right (Nothing, [])
-        _         -> Just $ fmtMsg' mem
+        _         -> smryFail $ fmtMsg' mem
     findMem = fmap (matchMem mem)
       . find (\i -> I.interfaceName i == iface)
       . I.objectInterfaces
@@ -473,43 +488,19 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
       , formatBusName busname
       ]
 
-dbusDepSatisfied _ (DBusGenDep d) = evalDependency d
+testDBusDependency _ (DBusIO d) = testIODependency d
 
 --------------------------------------------------------------------------------
--- | Printing dependencies
+-- | Printing
 
--- instance ToJSON (DepTree a) where
+printMsgs :: LogLevel -> [Msg] -> IO ()
---   toJSON (GenTree _) = undefined
+printMsgs lvl ms = do
+  pn <- getProgName
+  mapM_ (printMsg pn lvl) ms
 
--- instance ToJSON Dependency where
+printMsg :: String -> LogLevel -> Msg -> IO ()
---   toJSON (Executable n)         = depValue "executable" Nothing n
+printMsg pname lvl (Msg ml mn msg)
---   toJSON (IOTest d _)           = depValue "internal" Nothing d
+  | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
---   toJSON (Systemd t n)          = depValue "systemd" (Just $ tp t) n
+  | otherwise = skip
---     where
---       tp SystemUnit = "sys"
---       tp UserUnit   = "user"
---   toJSON (AccessiblePath p r w) = depValue "path" perms p
---     where
---       perms = case (r, w) of
---         (True, True)  -> Just "readwrite"
---         (True, False) -> Just "read"
---         (False, True) -> Just "write"
---         _             -> Nothing
-
--- depValue :: String -> Maybe String -> String -> Value
--- depValue t s n = object
---   [ "type" .= t
---   , "name" .= n
---   , "subtype" .= maybe Null (String . T.pack) s
---   ]
-
-depName :: Dependency -> String
-depName (Executable n)         = "executable: " ++ n
-depName (IOTest d _)           = "internal: " ++ d
-depName (Systemd t n)          = "systemd (" ++ tp t ++ "): "  ++ n
   where
-    tp SystemUnit = "sys"
+    bracket s = "[" ++ s ++ "]"
-    tp UserUnit   = "user"
-depName (AccessiblePath p _ _) = "path: " ++ p
-depName (DepFeature _)         = "feature: blablabla"
-

lib/XMonad/Internal/DependencyX.hs

@@ -1,395 +0,0 @@
-{-# LANGUAGE GADTs         #-}
-{-# LANGUAGE TupleSections #-}
-
---------------------------------------------------------------------------------
--- | Functions for handling dependencies
-
-module XMonad.Internal.DependencyX where
-
--- import           Control.Monad.IO.Class
--- 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
-
-import           DBus
-import           DBus.Client
-import           DBus.Internal
-import qualified DBus.Introspection      as I
-
-import           System.Directory        (findExecutable, readable, writable)
-import           System.Environment
-import           System.Exit
-
--- import           XMonad.Core             (X, io)
-import           XMonad.Core             (X)
-import           XMonad.Internal.IO
-import           XMonad.Internal.Process
-import           XMonad.Internal.Shell
-
---------------------------------------------------------------------------------
--- | Feature
-
-data AnyFeature p = FX (FeatureX p) | FIO (FeatureIO p)
-
-type FeatureX p = Feature (X ()) p
-
-type FeatureIO p = Feature (IO ()) p
-
-data Feature a p = Feature (FeatureData a Tree p) (Feature a p)
-  | NoFeature
-  | ConstFeature a
-
--- TODO this feels icky, and I don't feel like typing it
-data TestedFeature a p = TestedFeature (TestedFeature_ a p)
-  | TestedConst a [FailedFeature a p]
-
-data TestedFeature_ a p = TestedFeature_
-  { tfSuccess  :: Maybe (SuccessfulFeature a p)
-  , tfFailed   :: [FailedFeature a p]
-  , tfUntested :: Feature a p
-  }
-
-type FailedFeature a p = Either (FeatureData a Tree p, String)
-  (FeatureData a ResultTree p, [String])
-
-data SuccessfulFeature a p = SuccessfulFeature
-  { sfData     :: FeatureData a ResultTree p
-  , sfAction   :: a
-  , sfWarnings :: [String]
-  }
-
-data FeatureResult a p = Untestable (FeatureData a Tree p) String |
-  FailedFtr (FeatureData a ResultTree p) [String] |
-  SuccessfulFtr (SuccessfulFeature a p)
-
-type ActionTreeMaybe a p = Either (ActionTree a Tree p, String)
-  (ActionTree a ResultTree p, Maybe a, [String])
-
-printMsgs :: LogLevel -> [Msg] -> IO ()
-printMsgs lvl ms = do
-  pn <- getProgName
-  mapM_ (printMsg pn lvl) ms
-
-printMsg :: String -> LogLevel -> Msg -> IO ()
-printMsg pname lvl (Msg ml mn msg)
-  | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
-  | otherwise = skip
-  where
-    bracket s = "[" ++ s ++ "]"
-
---------------------------------------------------------------------------------
--- | Feature Data
-
-data FeatureData a t p = FeatureData
-  { fdTree  :: ActionTree a t p
-  , fdName  :: String
-  , fdLevel :: LogLevel
-  }
-
-data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
-
-data Msg = Msg LogLevel String String
-
---------------------------------------------------------------------------------
--- | Action Tree
-
-data ActionTree a t p =
-  IOTree (Action a p) (t (IODependency a p) p)
-  | DBusTree (Action (Client -> a) p) (Maybe Client) (t (DBusDependency a p) p)
-
-data Action a p = Standalone a | Consumer (p -> a)
-
---------------------------------------------------------------------------------
--- | (Result) Tree
-
-data Tree d p =
-  And (p -> p -> p) (Tree d p) (Tree d p)
-  | Or (p -> p) (p -> p) (Tree d p) (Tree d p)
-  | Only d
-
--- | 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 a p = Executable Bool FilePath
-  | AccessiblePath FilePath Bool Bool
-  | IOTest String (IO (Maybe String))
-  | IORead String (IO (Either String (Maybe p)))
-  | Systemd UnitType String
-  | NestedFeature (Feature a p) (a -> p)
-
-data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
-
---------------------------------------------------------------------------------
--- | DBus Dependency Result
-
-data DBusDependency a p =
-  Bus BusName
-  | Endpoint BusName ObjectPath InterfaceName DBusMember
-  | DBusIO (IODependency a p)
-
-data DBusMember = Method_ MemberName
-  | Signal_ MemberName
-  | Property_ String
-  deriving (Eq, Show)
-
-introspectInterface :: InterfaceName
-introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
-
-introspectMethod :: MemberName
-introspectMethod = memberName_ "Introspect"
-
---------------------------------------------------------------------------------
--- | Feature evaluation
---
--- Here we attempt to build and return the monadic actions encoded by each
--- feature.
-
-evalFeature :: Feature a p -> IO (Maybe a)
-evalFeature ftr = do
-  r <- testFeature ftr
-  -- TODO print out all the errors/warnings when doing this
-  case r of
-    TestedConst c _ -> return $ Just c
-    TestedFeature t ->
-      case t of
-        TestedFeature_ { tfSuccess = Nothing, tfFailed = _ } -> return Nothing
-        TestedFeature_ { tfSuccess = Just (SuccessfulFeature { sfAction = a })
-                       , tfFailed = _ }  -> return $ Just a
-
---------------------------------------------------------------------------------
--- | 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.
-
-testFeature :: Feature a p -> IO (TestedFeature a p)
-testFeature = go []
-  where
-    go failed (Feature fd alt) = do
-      r <- testFeatureData fd
-      case r of
-        (Untestable fd' err) -> tryAlt alt $ Left (fd' ,err):failed
-        (FailedFtr fd' errs) -> tryAlt alt $ Right (fd' ,errs):failed
-        (SuccessfulFtr s)    -> return $ TestedFeature $ TestedFeature_ (Just s) failed alt
-    go failed NoFeature = return $ TestedFeature $ TestedFeature_ Nothing failed NoFeature
-    go failed (ConstFeature c) = return $ TestedConst c failed
-    tryAlt NoFeature failed = return $ TestedFeature $ TestedFeature_ Nothing failed NoFeature
-    tryAlt alt failed       = go failed alt
-
-testFeatureData :: FeatureData a Tree p -> IO (FeatureResult a p)
-testFeatureData fd@(FeatureData { fdTree = t }) = do
-  atm <- testActionTree t
-  return $ either untestable checkAction atm
-  where
-    untestable (t', err) = Untestable (fd { fdTree = t' }) err
-    checkAction (t', Just a, ms) = SuccessfulFtr
-      $ SuccessfulFeature { sfData = fd { fdTree = t' }
-                          , sfAction = a
-                          , sfWarnings = ms
-                          }
-    checkAction (t', Nothing, ms) = FailedFtr (fd { fdTree = t' }) ms
-
-testActionTree :: ActionTree a Tree p -> IO (ActionTreeMaybe a p)
-testActionTree t = do
-  case t of
-    (IOTree a d)             -> do
-      (t', a', msgs) <- doTest testIOTree d a
-      return $ Right (IOTree a t', a', msgs)
-    (DBusTree a (Just cl) d) -> do
-      (t', a', msgs) <- doTest (testDBusTree cl) d a
-      return $ Right (DBusTree a (Just cl) t', fmap (\f -> f cl) a', msgs)
-    _                        -> return $ Left (t, "client not available")
-  where
-    doTest testFun d a = do
-      (t', r) <- testFun d
-      -- TODO actually recover the proper error messages
-      let (a', msgs) = maybe (Nothing, []) (\p -> (fmap (apply a) p, [])) r
-      return (t', a', msgs)
-    apply (Standalone a) _ = a
-    apply (Consumer a) p   = a p
-
-testIOTree :: Tree (IODependency a p) p
-  -> IO (ResultTree (IODependency a p) p, Maybe (Maybe p))
-testIOTree = testTree testIODependency
-
-testDBusTree :: Client -> Tree (DBusDependency a p) p
-  -> IO (ResultTree (DBusDependency a p) p, Maybe (Maybe p))
-testDBusTree client = testTree (testDBusDependency client)
-
-testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
-  -> m (ResultTree d p, Maybe (Maybe p))
-testTree test = go
-  where
-    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
-      let pass p = return (First ra b, Just $ fa <$> p)
-      let fail_ = test2nd (Just . fb) ra b
-      maybe fail_ pass pa
-    go (Only a) =
-      either (\es -> (LeafFail a es, Nothing)) (\(p, ws) -> (LeafSuccess a ws, Just p))
-      <$> test a
-    test2nd f ra b = do
-      (rb, pb) <- go b
-      return (Both ra rb, fmap (f =<<) pb)
-
-testIODependency :: IODependency a p -> IO (Summary p)
-testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
-  where
-    err = Left ["executable '" ++ bin ++ "' not found"]
-
-testIODependency (IOTest _ t) = maybe (Right (Nothing, [])) (Left . (:[])) <$> t
-
-testIODependency (IORead _ t) = bimap (:[]) (, []) <$> t
-
-testIODependency (Systemd t n) = do
-  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
-  return $ case rc of
-    ExitSuccess -> Right (Nothing, [])
-    _           -> Left ["systemd " ++ unitType t ++ " unit '" ++ n ++ "' not found"]
-  where
-    cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
-    unitType SystemUnit = "system"
-    unitType UserUnit   = "user"
-
-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 PermError                = smryFail "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, _)          -> smryFail "file not readable"
-        (_, Just False)          -> smryFail "file not writable"
-        _                        -> Right (Nothing, [])
-
-testIODependency (NestedFeature ftr trans) = do
-  r <- testFeature ftr
-  return $ case r of
-    -- TODO why would anyone do this?
-    TestedConst c _ -> Right (Just $ trans c, [])
-    TestedFeature t ->
-      case t of
-        -- TODO actually summarize errors
-        TestedFeature_ { tfSuccess = Nothing
-                       , tfFailed = _ } -> Left []
-        TestedFeature_ { tfSuccess = Just (SuccessfulFeature { sfAction = a })
-                       , tfFailed = _ }  -> Right (Just $ trans a, [])
--- testIODependency (NestedFeature ftr) = go ftr
---   where
---     go (Feature (FeatureData { fdTree = t }) alt) =
---       -- TODO add feature name to messages
---       case t of
---         (IOTree _ ct)             -> summarize <$> testIOTree ct
---         (DBusTree _ (Just cl) ct) -> summarize <$> testDBusTree cl ct
---         (DBusTree _ Nothing _)    -> failMaybe alt ["client not found"]
---       where
---         failMaybe NoFeature msg = return $ Left msg
---         failMaybe f _           = go f
---         -- TODO actually thread errors here
---         summarize (_, Just p)  = Right (p, [])
---         summarize (_, Nothing) = Left []
---     go _ = return $ Right (Nothing, [])
-
-testDBusDependency :: Client -> DBusDependency a 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, [])
-          else smryFail $ unwords ["name", singleQuote bus', "not found on dbus"]
-  where
-    bus' = formatBusName bus
-    queryBus = busName_ "org.freedesktop.DBus"
-    queryIface = interfaceName_ "org.freedesktop.DBus"
-    queryPath = objectPath_ "/"
-    queryMem = memberName_ "ListNames"
-    bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
-    bodyGetNames _   = []
-
-testDBusDependency client (Endpoint busname objpath iface mem) = do
-  ret <- callMethod client busname objpath introspectInterface introspectMethod
-  return $ case ret of
-        Left e     -> smryFail e
-        Right body -> procBody body
-  where
-    procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
-                          =<< listToMaybe body in
-      case res of
-        Just True -> Right (Nothing, [])
-        _         -> smryFail $ fmtMsg' mem
-    findMem = fmap (matchMem mem)
-      . find (\i -> I.interfaceName i == iface)
-      . I.objectInterfaces
-    matchMem (Method_ n)   = elemMember n I.methodName I.interfaceMethods
-    matchMem (Signal_ n)   = elemMember n I.signalName I.interfaceSignals
-    matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties
-    elemMember n fname fmember = elem n . fmap fname . fmember
-    fmtMem (Method_ n)   = "method " ++ singleQuote (formatMemberName n)
-    fmtMem (Signal_ n)   = "signal " ++ singleQuote (formatMemberName n)
-    fmtMem (Property_ n) = "property " ++ singleQuote n
-    fmtMsg' m = unwords
-      [ "could not find"
-      , fmtMem m
-      , "on interface"
-      , singleQuote $ formatInterfaceName iface
-      , "on bus"
-      , formatBusName busname
-      ]
-
-testDBusDependency _ (DBusIO d) = testIODependency d

lib/XMonad/Internal/Dependency_.hs

@@ -0,0 +1,591 @@
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+--------------------------------------------------------------------------------
+-- | Functions for handling dependencies
+
+module XMonad.Internal.Dependency
+  ( MaybeAction
+  , AnyFeature(..)
+  , DepChoice(..)
+  , MaybeX
+  , FullDep(..)
+  , DepTree(..)
+  , Action(..)
+  , DBusDep(..)
+  , FeatureX
+  , FeatureIO
+  , Feature(..)
+  , Feature_(..)
+  , Warning(..)
+  , Dependency(..)
+  , UnitType(..)
+  , DBusMember(..)
+  , feature
+  , ioFeature
+  , evalFeature
+  , systemUnit
+  , userUnit
+  , pathR
+  , pathW
+  , pathRW
+  , featureDefault
+  , featureExeArgs
+  , featureExe
+  , featureEndpoint
+  , whenSatisfied
+  , ifSatisfied
+  , executeFeature
+  , executeFeature_
+  , executeFeatureWith
+  , executeFeatureWith_
+  , depName
+  , fullDep
+  , exe
+  , listToAnds
+  ) where
+
+import           Control.Monad.IO.Class
+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
+
+import           DBus
+import           DBus.Client
+import           DBus.Internal
+import qualified DBus.Introspection      as I
+
+import           System.Directory        (findExecutable, readable, writable)
+import           System.Environment
+import           System.Exit
+
+import           XMonad.Core             (X, io)
+import           XMonad.Internal.IO
+import           XMonad.Internal.Process
+import           XMonad.Internal.Shell
+
+--------------------------------------------------------------------------------
+-- | Features
+--
+-- A 'feature' is composed of a 'dependency tree' which at the root has an
+-- 'action' to be performed with a number of 'dependencies' below it.
+--
+-- NOTE: there is no way to make a feature depend on another feature. This is
+-- very complicated to implement and would only be applicable to a few instances
+-- (notably the dbus interfaces). In order to implement a dependency tree, use
+-- dependencies that target the output/state of another feature; this is more
+-- robust anyways, at the cost of being a bit slower.
+
+-- TODO some things to add to make this more feature-ful (lol)
+-- - use AndOr types to encode alternative dependencies into the tree
+-- - use an Alt data constructor for Features (which will mean "try A before B"
+-- - add an Either String Bool to dependency nodes that encodes testing status
+--   (where Right False means untested)
+-- - add a lens/functor mapper thingy to walk down the tree and update testing
+--   status fields
+-- - print to JSON
+-- - make sum type to hold all type instances of Feature blabla (eg IO and X)
+-- - figure out how to make features a dependency of another feature
+
+data Feature_ a = Feature_
+  { ftrDepTree :: DepTree a
+  , ftrName    :: String
+  , ftrWarning :: Warning
+  }
+
+data Feature a = Feature (Feature_ a) (Feature a)
+  | NoFeature
+  | ConstFeature a
+
+-- TODO this is silly as is, and could be made more useful by representing
+-- loglevels
+data Warning = Silent | Default
+
+type FeatureX = Feature (X ())
+
+type FeatureIO = Feature (IO ())
+
+data AnyFeature = FX FeatureX | FIO FeatureIO
+
+feature :: String -> Warning -> DepTree a -> Feature a
+feature n w t = Feature f NoFeature
+  where
+    f = Feature_
+      { ftrDepTree = t
+      , ftrName = n
+      , ftrWarning = w
+      }
+
+ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
+ioFeature (ConstFeature a) = ConstFeature $ liftIO a
+ioFeature NoFeature = NoFeature
+ioFeature (Feature f r)
+  = Feature (f {ftrDepTree = liftIO <$> ftrDepTree f}) $ ioFeature r
+
+featureDefault :: String -> DepChoice (FullDep Dependency) -> a -> Feature a
+featureDefault n ds x = feature n Default $ GenTree (Single x) ds
+
+featureExe :: MonadIO m => String -> String -> Feature (m ())
+featureExe n cmd = featureExeArgs n cmd []
+
+featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
+featureExeArgs n cmd args =
+  featureDefault n (Only $ FullDep (Right False) $ Executable cmd) $ spawnCmd cmd args
+
+featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
+  -> MemberName -> Maybe Client -> FeatureIO
+featureEndpoint name busname path iface mem client = feature name Default
+  $ DBusTree (Single cmd) client deps
+  where
+    cmd c = void $ callMethod c busname path iface mem
+    deps = Only $ FullDep (Right False) $ Endpoint busname path iface $ Method_ mem
+
+--------------------------------------------------------------------------------
+-- | Dependency Trees
+--
+-- Dependency trees have two subtypes: general and DBus. The latter require a
+-- DBus client to evaluate (and will automatically fail if this is missing).
+-- The former can be evaluated independently.
+
+data DepChoice a = And (DepChoice a) (DepChoice a)
+  | Or (DepChoice a) (DepChoice a)
+  | Only a
+
+data DepChoice_ a b = And_ (b -> b -> b) (DepChoice_ a b) (DepChoice_ a b)
+  | Or_ (DepChoice_ a b) (DepChoice_ a b)
+  | Only_ a
+
+listToAnds :: a -> [a] -> DepChoice a
+listToAnds i = foldr (And . Only) (Only i)
+
+-- listToAnds' :: [a] -> Maybe (DepChoice a)
+-- listToAnds' []     = Nothing
+-- listToAnds' (x:xs) = Just $ foldr (And . Only) (Only x) xs
+
+data DepTree a = GenTree (Action a) (DepChoice (FullDep Dependency))
+  | DBusTree (Action (Client -> a)) (Maybe Client) (DepChoice (FullDep DBusDep))
+
+data DepTree_ a b = GenTree_ (Action_ a b) (DepChoice_ (FullDep Dependency) b)
+  | DBusTree_ (Action_ (Client -> a) b) (Maybe Client) (DepChoice_ (FullDep DBusDep) b)
+
+instance Functor DepTree where
+  fmap f (GenTree a ds)    = GenTree (f <$> a) ds
+  fmap f (DBusTree a c ds) = DBusTree (fmap (fmap f) a) c ds
+
+--------------------------------------------------------------------------------
+-- | Actions
+--
+-- Actions have two subtypes: single and double. Single actions are just one
+-- independent action. Double actions have one dependent pre-step which the
+-- main action consumes (and fails if the pre-step fails).
+
+data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b))
+
+data Action_ a b = Standalone a | Consumer (b -> a)
+
+instance Functor Action where
+  fmap f (Single a)   = Single (f a)
+  fmap f (Double a b) = Double (f . a) b
+
+--------------------------------------------------------------------------------
+-- | Feature evaluation
+--
+-- Evaluate a feature by testing if its dependencies are satisfied, and return
+-- either the action of the feature or 0 or more error messages that signify
+-- what dependencies are missing and why.
+
+type MaybeAction a = Maybe a
+
+type MaybeX = MaybeAction (X ())
+
+evalFeature :: Feature a -> IO (MaybeAction a)
+evalFeature (ConstFeature x) = return $ Just x
+evalFeature NoFeature = return Nothing
+evalFeature (Feature f alt) = do
+  procName <- getProgName
+  res <- evalTree =<< evalTree' a
+  case res of
+    Right r -> return $ Just r
+    Left l  -> do
+      printWarnings procName l
+      case alt of
+        NoFeature -> return Nothing
+        -- TODO make this message better
+        next      -> putStrLn "trying alternative" >> evalFeature next
+
+  where
+    Feature_ {ftrDepTree = a, ftrName = n, ftrWarning = w} = f
+    printWarnings procName es = do
+      case w of
+        Silent  -> return ()
+        Default -> let prefix = n ++ " disabled; "
+                       es' = fmap (fmtMsg procName . (prefix ++)) es in
+          mapM_ putStrLn es'
+    fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
+    bracket s = concat ["[", s, "]"]
+
+mapMDepChoice :: Monad m => (a -> m a) -> (a -> Bool) -> DepChoice a -> m (DepChoice a)
+mapMDepChoice f pass = fmap snd . go
+  where
+    go d@(And a b) = do
+      (ra, a') <- go a
+      if not ra then return (False, d) else do
+        (rb, b') <- go b
+        return $ if rb then (True, And a' b') else (False, d)
+    go d@(Or a b) = do
+      (ra, a') <- go a
+      if ra then return (True, Or a' b) else do
+        (rb, b') <- go b
+        return $ if rb then (True, Or a' b') else (False, d)
+    go d@(Only a)  = do
+      a' <- f a
+      return $ if pass a' then (True, Only a') else (False, d)
+
+-- foldDepChoice :: (a -> Bool) -> DepChoice a -> Bool
+-- foldDepChoice get dc = case dc of
+--   And a b -> go a && go b
+--   Or a b  -> go a || go b
+--   Only a  -> get a
+--   where
+--     go = foldDepChoice get
+
+foldDepChoice' :: Bool -> (a -> Maybe b) -> DepChoice a -> [b]
+foldDepChoice' justSucceed get = fromMaybe [] . go []
+  where
+    go acc (And a b) = Just $ andFun acc a b
+    go acc (Or a b)  = Just $ orFun acc a b
+    go acc (Only a)  = (:acc) <$> get a
+    (andFun, orFun) = if justSucceed then (and', or') else (or', and')
+    and' acc a b = case (go acc a, go acc b) of
+      (Just a', Just b') -> a' ++ b' ++ acc
+      (Just a', Nothing) -> a' ++ acc
+      (Nothing, _)       -> acc
+    or' acc a b = fromMaybe [] (go acc a) ++ fromMaybe [] (go acc b) ++ acc
+
+foldDepChoiceX :: (a -> Either b c) -> DepChoice_ a c -> Either [b] c
+foldDepChoiceX get = go (Left [])
+  where
+    go acc (And_ f a b) = case (go acc a, go acc b) of
+      (Right a', Right b') -> Right $ f a' b'
+      (Left a', Right _)   -> toLeft acc a'
+      (Right _, Left b')   -> toLeft acc b'
+      (Left a', Left b')   -> toLeft acc $ a' ++ b'
+    go acc (Or_ a b)    = case (go acc a, go acc b) of
+      (Right a', _)      -> Right a'
+      (Left _, Right b') -> Right b'
+      (Left a', Left b') -> toLeft acc $ a' ++ b'
+    go acc (Only_ a)    = first (:fromLeft [] acc) $ get a
+    toLeft acc xs = Left $ xs ++ fromLeft [] acc
+
+-- foldDepChoice :: DepChoice a -> (a -> Maybe b) -> [b]
+-- foldDepChoice dc f = go [] dc
+--   where
+--     go acc d = case d of
+--       And a b -> do
+--         acc'@(a':_) <- go acc a
+--         if pass a' then go acc' b else return acc
+--       Or a b  -> do
+--         acc'@(a':_) <- go acc a
+--         if pass a' then return [a'] else go acc' b
+--       Only a  -> maybe acc $ f a
+
+-- TODO wet code
+evalTree :: DepTree a -> IO (Either [String] a)
+evalTree dt = case dt of
+  (GenTree a ds) ->
+    case foldDep ds of
+      [] -> evalAction a
+      es -> return $ Left es
+  (DBusTree a (Just client) ds) ->
+    case foldDep ds of
+      [] -> fmap (\f -> f client) <$> evalAction a
+      es -> return $ Left es
+  (DBusTree _ Nothing _) -> return $ Left ["client not available"]
+  where
+    foldDep = foldDepChoice' False fullDepMsg
+    fullDepMsg (FullDep e _) = either Just (const Nothing) e
+
+evalTreeX :: DepTree_ a b -> IO (Either [String] a)
+evalTreeX dt = case dt of
+  (GenTree_ a ds) ->
+    case foldDep ds of
+      [] -> evalAction a
+      es -> return $ Left es
+  (DBusTree_ a (Just client) ds) ->
+    case foldDep ds of
+      [] -> fmap (\f -> f client) <$> evalAction a
+      es -> return $ Left es
+  (DBusTree_ _ Nothing _) -> return $ Left ["client not available"]
+  where
+    foldDep = foldDepChoiceX fullDepMsg
+    fullDepMsg (FullDep e _) = either Just (const Nothing) e
+
+depResult :: FullDep Dependency -> Either String (Maybe b)
+depResult (FullDep l@(Left e) d) = Left e
+depResult (FullDep _ d)          = Right $ extractDependency d
+
+evalTree' :: DepTree a -> IO (DepTree a)
+
+evalTree' (GenTree a ds) = GenTree a <$> mapMDepChoice eval pass ds
+  where
+    eval (FullDep _ d) = do
+      r <- evalDependency d
+      return $ FullDep (maybe (Right True) Left r) d
+    pass (FullDep (Right True) _) = True
+    pass  _                       = True
+
+evalTree' d@(DBusTree _ Nothing _) = return d
+evalTree' (DBusTree a (Just client) ds) = DBusTree a (Just client) <$> mapMDepChoice eval pass ds
+  where
+    eval (FullDep _ d) = do
+      r <- eval' d
+      return $ FullDep (maybe (Right True) Left r) d
+    eval' (DBusGenDep d) = evalDependency d
+    eval' x              = dbusDepSatisfied client x
+    pass (FullDep (Right True) _) = True
+    pass  _                       = True
+
+
+evalAction :: Action a -> IO (Either [String] a)
+evalAction (Single a)   = return $ Right a
+evalAction (Double a b) = fmap a <$> b
+
+-- evalActionX :: Action_ a b -> IO (Either [String] a)
+-- evalActionX (Standalone a) = return $ Right a
+-- evalActionX (Consumer f)   = fmap a <$> b
+
+executeFeatureWith :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
+executeFeatureWith iof def ftr = do
+  a <- io $ evalFeature ftr
+  maybe (return def) (iof . io) a
+
+executeFeatureWith_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
+executeFeatureWith_ iof = executeFeatureWith iof ()
+
+executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
+executeFeature = executeFeatureWith id
+
+executeFeature_ :: Feature (IO ()) -> IO ()
+executeFeature_ = executeFeature ()
+
+whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
+whenSatisfied = flip ifSatisfied skip
+
+ifSatisfied ::  MaybeAction a -> a -> a
+ifSatisfied (Just x) _ = x
+ifSatisfied _ alt      = alt
+
+--------------------------------------------------------------------------------
+-- | Dependencies (General)
+
+data FullDep a = FullDep (Either String Bool) a deriving (Functor)
+
+fullDep :: a -> FullDep a
+fullDep = FullDep (Right True)
+
+data Dependency = Executable String
+  | AccessiblePath FilePath Bool Bool
+  | IOTest String (IO (Maybe String))
+  | Systemd UnitType String
+  | DepFeature AnyFeature
+
+data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
+
+exe :: String -> FullDep Dependency
+exe = fullDep . Executable
+
+pathR :: String -> FullDep Dependency
+pathR n = fullDep $ AccessiblePath n True False
+
+pathW :: String -> FullDep Dependency
+pathW n = fullDep $ AccessiblePath n False True
+
+pathRW :: String -> FullDep Dependency
+pathRW n = fullDep $ AccessiblePath n True True
+
+systemUnit :: String -> FullDep Dependency
+systemUnit = fullDep . Systemd SystemUnit
+
+userUnit :: String -> FullDep Dependency
+userUnit = fullDep . Systemd UserUnit
+
+--------------------------------------------------------------------------------
+-- | Dependencies (DBus)
+
+data DBusMember = Method_ MemberName
+  | Signal_ MemberName
+  | Property_ String
+  deriving (Eq, Show)
+
+data DBusDep =
+  Bus BusName
+  | Endpoint BusName ObjectPath InterfaceName DBusMember
+  | DBusGenDep Dependency
+
+--------------------------------------------------------------------------------
+-- | Dependency evaluation (General)
+--
+-- Test the existence of dependencies and return either Nothing (which actually
+-- means success) or Just <error message>.
+
+evalDependency :: Dependency -> IO (Maybe String)
+evalDependency (Executable n)         = exeSatisfied n
+evalDependency (IOTest _ t)           = t
+evalDependency (Systemd t n)          = unitSatisfied t n
+evalDependency (AccessiblePath p r w) = pathSatisfied p r w
+evalDependency (DepFeature _)         = undefined
+-- TODO add something here to eval a nested feature's dependencies while
+-- bypassing the feature itself
+
+extractDependency :: Dependency -> Maybe a
+extractDependency (Executable n)         = Nothing
+extractDependency (IOTest _ t)           = Nothing
+extractDependency (Systemd t n)          = Nothing
+extractDependency (AccessiblePath p r w) = Nothing
+extractDependency (DepFeature _)         = Nothing
+
+exeSatisfied :: String -> IO (Maybe String)
+exeSatisfied x = do
+  r <- findExecutable x
+  return $ case r of
+    (Just _) -> Nothing
+    _        -> Just $ "executable '" ++ x ++ "' not found"
+
+unitSatisfied :: UnitType -> String -> IO (Maybe String)
+unitSatisfied u x = do
+  (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
+  return $ case rc of
+    ExitSuccess -> Nothing
+    _           -> Just $ "systemd " ++ unitType u ++ " unit '" ++ x ++ "' not found"
+  where
+    cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
+    unitType SystemUnit = "system"
+    unitType UserUnit   = "user"
+
+pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String)
+pathSatisfied p testread testwrite = do
+  res <- getPermissionsSafe p
+  let msg = permMsg res
+  return msg
+  where
+    testPerm False _ _ = Nothing
+    testPerm True f r  = Just $ f r
+    permMsg NotFoundError            = Just "file not found"
+    permMsg PermError                = Just "could not get permissions"
+    permMsg (PermResult r) =
+      case (testPerm testread readable r, testPerm testwrite writable r) of
+        (Just False, Just False) -> Just "file not readable or writable"
+        (Just False, _)          -> Just "file not readable"
+        (_, Just False)          -> Just "file not writable"
+        _                        -> Nothing
+
+--------------------------------------------------------------------------------
+-- | Dependency evaluation (DBus)
+
+introspectInterface :: InterfaceName
+introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
+
+introspectMethod :: MemberName
+introspectMethod = memberName_ "Introspect"
+
+dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
+dbusDepSatisfied client (Bus bus) = do
+  ret <- callMethod client queryBus queryPath queryIface queryMem
+  return $ case ret of
+        Left e    -> Just e
+        Right b -> let ns = bodyGetNames b in
+          if bus' `elem` ns then Nothing
+          else Just $ unwords ["name", singleQuote bus', "not found on dbus"]
+  where
+    bus' = formatBusName bus
+    queryBus = busName_ "org.freedesktop.DBus"
+    queryIface = interfaceName_ "org.freedesktop.DBus"
+    queryPath = objectPath_ "/"
+    queryMem = memberName_ "ListNames"
+    bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
+    bodyGetNames _   = []
+
+dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
+  ret <- callMethod client busname objpath introspectInterface introspectMethod
+  return $ case ret of
+        Left e     -> Just e
+        Right body -> procBody body
+  where
+    procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
+                          =<< listToMaybe body in
+      case res of
+        Just True -> Nothing
+        _         -> Just $ fmtMsg' mem
+    findMem = fmap (matchMem mem)
+      . find (\i -> I.interfaceName i == iface)
+      . I.objectInterfaces
+    matchMem (Method_ n)   = elemMember n I.methodName I.interfaceMethods
+    matchMem (Signal_ n)   = elemMember n I.signalName I.interfaceSignals
+    matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties
+    elemMember n fname fmember = elem n . fmap fname . fmember
+    fmtMem (Method_ n)   = "method " ++ singleQuote (formatMemberName n)
+    fmtMem (Signal_ n)   = "signal " ++ singleQuote (formatMemberName n)
+    fmtMem (Property_ n) = "property " ++ singleQuote n
+    fmtMsg' m = unwords
+      [ "could not find"
+      , fmtMem m
+      , "on interface"
+      , singleQuote $ formatInterfaceName iface
+      , "on bus"
+      , formatBusName busname
+      ]
+
+dbusDepSatisfied _ (DBusGenDep d) = evalDependency d
+
+--------------------------------------------------------------------------------
+-- | Printing dependencies
+
+-- instance ToJSON (Feature_ a) where
+--   toJSON Feature_ {}   = undefined
+
+-- instance ToJSON (Feature_ a) where
+--   toJSON Feature_ {}   = undefined
+
+-- instance ToJSON (DepTree a) where
+--   toJSON (GenTree _ _) = undefined
+--   toJSON (DBusTree {}) = undefined
+
+-- instance ToJSON Dependency where
+--   toJSON (Executable n)         = depValue "executable" Nothing n
+--   toJSON (IOTest d _)           = depValue "internal" Nothing d
+--   toJSON (Systemd t n)          = depValue "systemd" (Just $ tp t) n
+--     where
+--       tp SystemUnit = "sys"
+--       tp UserUnit   = "user"
+--   toJSON (AccessiblePath p r w) = depValue "path" perms p
+--     where
+--       perms = case (r, w) of
+--         (True, True)  -> Just "readwrite"
+--         (True, False) -> Just "read"
+--         (False, True) -> Just "write"
+--         _             -> Nothing
+--   toJSON (DepFeature _) = undefined
+
+-- depValue :: String -> Maybe String -> String -> Value
+-- depValue t s n = object
+--   [ "type" .= t
+--   , "name" .= n
+--   , "subtype" .= maybe Null (String . T.pack) s
+--   ]
+
+depName :: Dependency -> String
+depName (Executable n)         = "executable: " ++ n
+depName (IOTest d _)           = "internal: " ++ d
+depName (Systemd t n)          = "systemd (" ++ tp t ++ "): "  ++ n
+  where
+    tp SystemUnit = "sys"
+    tp UserUnit   = "user"
+depName (AccessiblePath p _ _) = "path: " ++ p
+depName (DepFeature _)         = "feature: blablabla"
+