ADD awkwardly unify path dependencies into dependency module

bin/xmonad.hs

@@ -81,8 +81,9 @@ main = do
         , childPIDs = [p]
         , childHandles = [h]
         }
-  (ekbs, missing) <- fmap filterExternal $ evalExternal $ externalBindings bc sc ts
+  ext <- evalExternal $ externalBindings bc sc ts
-  mapM_ warnMissing missing
+  let ekbs = filterExternal ext
+  warnMissing $ externalToMissing ext
   -- IDK why this is necessary; nothing prior to this line will print if missing
   hFlush stdout
   launch
@@ -479,18 +480,32 @@ evalExternal = mapM go
 evalKeyBinding :: Monad m => KeyBinding (m a) -> m (KeyBinding a)
 evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a
 
-filterExternal :: [KeyGroup MaybeX] -> ([KeyGroup (X ())], [Dependency])
+filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
-filterExternal kgs = let kgs' = fmap go kgs in (fst <$> kgs', concatMap snd kgs')
+filterExternal = fmap go
   where
-    go k@KeyGroup { kgBindings = bs } = let bs' = go' <$> bs in
+    go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
-      (k { kgBindings = mapMaybe fst bs' }, concatMap snd bs')
+    -- go k@KeyGroup { kgBindings = bs } =
-    go' k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
+    --   ( k { kgBindings = mapMaybe flagKeyBinding bs }
-      Installed x ds -> (Just $ k{ kbAction = x }, ds)
+    --   , concatMap go' bs
-      Missing ds     -> (Just $ k{ kbDesc = flagMissing d, kbAction = skip }, ds)
+    --   )
-      Ignore         -> (Nothing, [])
+    -- go' KeyBinding{ kbAction = a } = case a of
-    flagMissing s = "[!!!]" ++ s
+    --   Installed _ opt ->  opt
+    --   -- TODO this will mash together the optional and required deps
+    --   Missing req opt ->  req ++ opt
+    --   Ignore          ->  []
 
-externalBindings :: Maybe BrightnessControls
+externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a]
+externalToMissing = concatMap go
+  where
+    go KeyGroup { kgBindings = bs } = fmap kbAction bs
+
+flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
+flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of
+  Installed x _ -> Just $ k{ kbAction = x }
+  Missing _ _   -> Just $ k{ kbDesc = "[!!!]" ++  d, kbAction = skip }
+  Ignore        -> Nothing
+
+externalBindings :: BrightnessControls
   -> MaybeExe SSControls
   -> ThreadState
   -> [KeyGroup (IO MaybeX)]
@@ -539,10 +554,10 @@ externalBindings bc sc ts =
     ]
 
   , KeyGroup "System"
-    [ KeyBinding "M-." "backlight up" $ runMaybe bc bctlInc
+    [ KeyBinding "M-." "backlight up" $ return $ io <$> bctlInc bc
-    , KeyBinding "M-," "backlight down" $ runMaybe bc bctlDec
+    , KeyBinding "M-," "backlight down" $ return $ io <$> bctlDec bc
-    , KeyBinding "M-M1-," "backlight min" $ runMaybe bc bctlMin
+    , KeyBinding "M-M1-," "backlight min" $ return $ io <$> bctlMin bc
-    , KeyBinding "M-M1-." "backlight max" $ runMaybe bc bctlMax
+    , KeyBinding "M-M1-." "backlight max" $ return $ io <$> bctlMax bc
     , KeyBinding "M-<End>" "power menu" $ noCheck runPowerPrompt
     , KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
     , KeyBinding "M-<Delete>" "lock screen" runScreenLock
@@ -558,8 +573,8 @@ externalBindings bc sc ts =
     , KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
     ]
   ]
-  where
+  -- where
     -- TODO this is hacky, I shouldn't really need this data structure for
     -- something that doesn't depend on executables
-    runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c
+    -- runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c
 

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

@@ -9,7 +9,7 @@ module XMonad.Internal.DBus.Brightness.Common
   , matchSignal
   ) where
 
-import           Control.Monad               (void)
+import           Control.Monad               (void, when)
 
 import           Data.Int                    (Int32)
 
@@ -17,6 +17,7 @@ import           DBus
 import           DBus.Client
 
 import           XMonad.Internal.DBus.Common
+import           XMonad.Internal.Dependency
 
 --------------------------------------------------------------------------------
 -- | External API
@@ -38,24 +39,26 @@ data BrightnessConfig a b = BrightnessConfig
   }
 
 data BrightnessControls = BrightnessControls
-  { bctlMax :: IO ()
+  { bctlMax :: MaybeExe (IO ())
-  , bctlMin :: IO ()
+  , bctlMin :: MaybeExe (IO ())
-  , bctlInc :: IO ()
+  , bctlInc :: MaybeExe (IO ())
-  , bctlDec :: IO ()
+  , bctlDec :: MaybeExe (IO ())
   }
 
-exportBrightnessControls :: RealFrac b => BrightnessConfig a b -> Client
+exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b
-  -> IO BrightnessControls
+  -> Client -> IO BrightnessControls
-exportBrightnessControls bc client = do
+exportBrightnessControls deps bc client = do
+  (req, opt) <- checkInstalled deps
+  when (null req) $
     exportBrightnessControls' bc client
   return $ BrightnessControls
-    { bctlMax = callBacklight' memMax
+    { bctlMax = callBacklight' req opt memMax
-    , bctlMin = callBacklight' memMin
+    , bctlMin = callBacklight' req opt memMin
-    , bctlInc = callBacklight' memInc
+    , bctlInc = callBacklight' req opt memInc
-    , bctlDec = callBacklight' memDec
+    , bctlDec = callBacklight' req opt memDec
     }
   where
-    callBacklight' = callBacklight bc
+    callBacklight' r o = createInstalled r o . callBacklight bc
 
 callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
 callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do

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

@@ -5,11 +5,11 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
   ( callGetBrightnessIB
   , matchSignalIB
   , exportIntelBacklight
-  , hasBacklight
+  -- , hasBacklight
   , blPath
   ) where
 
-import           Data.Either
+-- import           Data.Either
 import           Data.Int                               (Int32)
 
 import           DBus
@@ -18,6 +18,7 @@ import           DBus.Client
 import           System.FilePath.Posix
 
 import           XMonad.Internal.DBus.Brightness.Common
+import           XMonad.Internal.Dependency
 import           XMonad.Internal.IO
 
 --------------------------------------------------------------------------------
@@ -64,29 +65,29 @@ decBrightness = decPercent steps curFile
 -- Right True -> backlight accessible and present
 -- Right False -> backlight not present
 -- Left x -> backlight present but could not access (x explaining why)
-hasBacklight' :: IO (Either String Bool)
+-- hasBacklight' :: IO (Either String Bool)
-hasBacklight' = do
+-- hasBacklight' = do
-  mx <- isReadable maxFile
+--   mx <- isReadable maxFile
-  cx <- isWritable curFile
+--   cx <- isWritable curFile
-  return $ case (mx, cx) of
+--   return $ case (mx, cx) of
-    (NotFoundError, NotFoundError) -> Right False
+--     (NotFoundError, NotFoundError) -> Right False
-    (PermResult True, PermResult True) -> Right True
+--     (PermResult True, PermResult True) -> Right True
-    (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
+--     (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
-    _ -> Left "Could not determine permissions for backlight files"
+--     _ -> Left "Could not determine permissions for backlight files"
 
-msg :: Either String Bool -> IO ()
+-- msg :: Either String Bool -> IO ()
-msg (Right True)  = return ()
+-- msg (Right True)  = return ()
-msg (Right False) = putStrLn "No backlight detected. Controls disabled"
+-- msg (Right False) = putStrLn "No backlight detected. Controls disabled"
-msg (Left m)      = putStrLn $ "WARNING: " ++ m
+-- msg (Left m)      = putStrLn $ "WARNING: " ++ m
 
-hasBacklightMsg :: IO Bool
+-- hasBacklightMsg :: IO Bool
-hasBacklightMsg = do
+-- hasBacklightMsg = do
-  b <- hasBacklight'
+--   b <- hasBacklight'
-  msg b
+--   msg b
-  return $ fromRight False b
+--   return $ fromRight False b
 
-hasBacklight :: IO Bool
+-- hasBacklight :: IO Bool
-hasBacklight = fromRight False <$> hasBacklight'
+-- hasBacklight = fromRight False <$> hasBacklight'
 
 --------------------------------------------------------------------------------
 -- | DBus interface
@@ -112,12 +113,14 @@ intelBacklightConfig = BrightnessConfig
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-exportIntelBacklight :: Client -> IO (Maybe BrightnessControls)
+exportIntelBacklight :: Client -> IO BrightnessControls
-exportIntelBacklight client = do
+exportIntelBacklight = exportBrightnessControls deps intelBacklightConfig
-  b <- hasBacklightMsg
+  where
-  if b
+    deps = [pathRW curFile, pathR maxFile]
-    then Just <$> exportBrightnessControls intelBacklightConfig client
+  -- b <- hasBacklightMsg
-    else return Nothing
+  -- if b
+  --   then Just <$> exportBrightnessControls intelBacklightConfig client
+  --   else return Nothing
 
 callGetBrightnessIB :: IO (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig

lib/XMonad/Internal/DBus/Control.hs

@@ -31,29 +31,37 @@ introspectMethod = memberName_ "Introspect"
 
 data DBusXMonad = DBusXMonad
   { dxClient             :: Client
-  , dxIntelBacklightCtrl :: Maybe BrightnessControls
+  , dxIntelBacklightCtrl :: BrightnessControls
-  , dxClevoBacklightCtrl :: Maybe BrightnessControls
+  -- , dxClevoBacklightCtrl :: MaybeExe BrightnessControls
   , dxScreensaverCtrl    :: MaybeExe SSControls
   }
 
+blankControls :: BrightnessControls
+blankControls = BrightnessControls
+  { bctlMax = Ignore
+  , bctlMin = Ignore
+  , bctlInc = Ignore
+  , bctlDec = Ignore
+  }
+
 startXMonadService :: IO DBusXMonad
 startXMonadService = do
   client <- connectSession
   requestResult <- requestName client xmonadBus []
   -- TODO if the client is not released on shutdown the owner will be
   -- different
-  (i, c, s) <- if requestResult /= NamePrimaryOwner then do
+  (i, s) <- if requestResult /= NamePrimaryOwner then do
     putStrLn "Another service owns \"org.xmonad\""
-    return (Nothing, Nothing, Ignore)
+    return (blankControls, Ignore)
     else do
     putStrLn "Started xmonad dbus client"
     bc <- exportIntelBacklight client
     sc <- exportScreensaver client
-    return (bc, Nothing, sc)
+    return (bc, sc)
   return $ DBusXMonad
     { dxClient = client
     , dxIntelBacklightCtrl = i
-    , dxClevoBacklightCtrl = c
+    -- , dxClevoBacklightCtrl = c
     , dxScreensaverCtrl = s
     }
 

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -94,9 +94,9 @@ newtype SSControls = SSControls { ssToggle :: IO () }
 
 exportScreensaver :: Client -> IO (MaybeExe SSControls)
 exportScreensaver client = do
-  d <- depInstalled dep
+  d <- depInstalled $ depData dep
   if d then flip Installed [] <$> exportScreensaver' client
-    else return $ Missing [dep]
+    else return $ Missing [depData dep] []
   where
     dep = exe "xset"
 

lib/XMonad/Internal/Dependency.hs

@@ -5,10 +5,16 @@ module XMonad.Internal.Dependency
   ( MaybeExe(..)
   , UnitType(..)
   , Dependency(..)
+  , DependencyData(..)
   , MaybeX
   , exe
   , systemUnit
   , userUnit
+  , pathR
+  , pathW
+  , pathRW
+  , checkInstalled
+  , createInstalled
   , runIfInstalled
   , depInstalled
   , warnMissing
@@ -29,18 +35,19 @@ module XMonad.Internal.Dependency
   , spawnSound
   ) where
 
-import           Control.Monad           (filterM)
+import           Control.Arrow           ((***))
+import           Control.Monad           (filterM, join)
 import           Control.Monad.IO.Class
 
+import           Data.List               (partition)
 import           Data.Maybe              (isJust)
 
--- import           System.Directory        (findExecutable, readable, writable)
+import           System.Directory        (findExecutable, readable, writable)
-import           System.Directory        (findExecutable)
 import           System.Exit
 import           System.FilePath
 
 import           XMonad.Core             (X, getXMonadDir)
--- import           XMonad.Internal.IO
+import           XMonad.Internal.IO
 import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
 
@@ -49,61 +56,69 @@ import           XMonad.Internal.Shell
 
 data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
 
-data DependencyType = Executable
+data DependencyData = Executable String
-  -- | AccessiblePath FilePath Bool Bool
+  | AccessiblePath FilePath Bool Bool
-  | Systemd UnitType deriving (Eq, Show)
+  | Systemd UnitType String
+  deriving (Eq, Show)
 
 data Dependency = Dependency
   { depRequired :: Bool
-  , depName     :: String
+  , depData     :: DependencyData
-  , depType     :: DependencyType
   }
   deriving (Eq, Show)
 
 exe :: String -> Dependency
 exe n = Dependency
   { depRequired = True
-  , depName = n
+  , depData = Executable n
-  , depType = Executable
   }
 
 unit :: UnitType -> String -> Dependency
 unit t n = Dependency
   { depRequired = True
-  , depName = n
+  , depData = Systemd t n
-  , depType = Systemd t
   }
 
+path :: Bool -> Bool -> String -> Dependency
+path r w n = Dependency
+  { depRequired = True
+  , depData = AccessiblePath n r w
+  }
+
+pathR :: String -> Dependency
+pathR = path True False
+
+pathW :: String -> Dependency
+pathW = path False True
+
+pathRW :: String -> Dependency
+pathRW = path True True
+
 systemUnit :: String -> Dependency
 systemUnit = unit SystemUnit
 
 userUnit :: String -> Dependency
 userUnit = unit UserUnit
 
-data MaybeExe a = Installed a [Dependency] | Missing [Dependency] | Ignore
+-- TODO this is poorly named. This actually represents an action that has
+-- one or more dependencies (where "action" is not necessarily executing an exe)
+data MaybeExe a = Installed a [DependencyData]
+  | Missing [DependencyData] [DependencyData]
+  | Ignore
+  deriving (Eq, Show)
 
 instance Functor MaybeExe where
   fmap f (Installed x ds)  = Installed (f x) ds
-  fmap _ (Missing x)      = Missing x
+  fmap _ (Missing req opt) = Missing req opt
   fmap _ Ignore            = Ignore
 
 type MaybeX = MaybeExe (X ())
 
-warnMissing :: Dependency -> IO ()
-warnMissing Dependency {depRequired = r, depName = n, depType = t } =
-  putStrLn $ "WARNING: " ++ r' ++ " " ++ fmtType t ++ " not found: " ++ n
-  where
-    fmtType Executable           = "executable"
-    -- fmtType (AccessiblePath _ _ _) = undefined
-    fmtType (Systemd UserUnit)   = "systemd user unit"
-    fmtType (Systemd SystemUnit) = "systemd system unit"
-    r' = if r then "required" else "optional"
-
 exeInstalled :: String -> IO Bool
 exeInstalled x = isJust <$> findExecutable x
 
-unitInstalled :: String -> UnitType -> IO Bool
+unitInstalled :: UnitType -> String -> IO Bool
-unitInstalled x u = do
+unitInstalled u x = do
   (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
   return $ case rc of
     ExitSuccess -> True
@@ -112,38 +127,56 @@ unitInstalled x u = do
     cmd = fmtCmd "systemctl" $ ["--user" | u == UserUnit] ++ ["status", x]
 
 -- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
--- pathAccessible p testread testwrite = do
+pathAccessible :: FilePath -> Bool -> Bool -> IO Bool
---   res <- getPermissionsSafe p
+pathAccessible p testread testwrite = do
---   let msg = permMsg res
+  res <- getPermissionsSafe p
+  let msg = permMsg res
+  return msg
   -- return $ fmap (\m -> m ++ ": " ++ p) msg
---   where
+  where
---     testPerm False _ _ = Nothing
+    testPerm False _ _ = Nothing
---     testPerm True f r  = Just $ f r
+    testPerm True f r  = Just $ f r
     -- permMsg NotFoundError            = Just "file not found"
     -- permMsg PermError                = Just "could not get permissions"
---     permMsg (PermResult r) =
+    permMsg NotFoundError            = False
---       case (testPerm testread readable r, testPerm testwrite writable r) of
+    permMsg PermError                = False
+    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
+        (Just True, Just True) -> True
+        (Just True, Nothing)   -> True
+        (Nothing, Just True)   -> True
+        _                      -> False
         -- (Just False, Just False) -> Just "file not readable or writable"
         -- (Just False, _)          -> Just "file not readable"
         -- (_, Just False)          -> Just "file not writable"
         -- _                        -> Nothing
 
-depInstalled :: Dependency -> IO Bool
+-- TODO somehow get this to preserve error messages if something isn't found
-depInstalled Dependency { depName = n, depType = t } =
+depInstalled :: DependencyData -> IO Bool
-  case t of
+depInstalled (Executable n)         = exeInstalled n
-    Executable -> exeInstalled n
+depInstalled (Systemd t n)          = unitInstalled t n
+depInstalled (AccessiblePath p r w) = pathAccessible p r w
     -- (AccessiblePath p r w) -> pathAccessible p r w
-    Systemd u  -> unitInstalled n u
+
+checkInstalled :: [Dependency] -> IO ([DependencyData], [DependencyData])
+checkInstalled = fmap go . filterMissing
+  where
+    go = join (***) (fmap depData) . partition depRequired
+
+createInstalled :: [DependencyData] -> [DependencyData] -> a -> MaybeExe a
+createInstalled req opt x = if null req then Installed x opt else Missing req opt
 
 filterMissing :: [Dependency] -> IO [Dependency]
-filterMissing = filterM (fmap not . depInstalled)
+filterMissing = filterM (fmap not . depInstalled . depData)
 
-runIfInstalled :: MonadIO m => [Dependency] -> m () -> IO (MaybeExe (m ()))
+runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a))
 runIfInstalled ds x = do
-  missing <- filterMissing ds
+  (req, opt) <- checkInstalled ds
-  return $ if not $ any depRequired missing
+  return $ createInstalled req opt x
-    then Installed x $ filter (not . depRequired) missing
-    else Missing missing
 
 spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
 spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
@@ -172,6 +205,42 @@ spawnSound file pre post = runIfInstalled [exe "paplay"]
 
 playSound :: MonadIO m => FilePath -> m ()
 playSound file = do
-  path <- (</> soundDir </> file) <$> getXMonadDir
+  p <- (</> soundDir </> file) <$> getXMonadDir
   -- paplay seems to have less latency than aplay
-  spawnCmd "paplay" [path]
+  spawnCmd "paplay" [p]
+
+partitionMissing :: [MaybeExe a] -> ([DependencyData], [DependencyData])
+partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
+  where
+    go (Installed _ opt) = ([], opt)
+    go (Missing req opt) = (req, opt)
+    go Ignore            = ([], [])
+
+fmtMissing :: DependencyData -> String
+-- TODO this error message is lame
+fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
+fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
+fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
+fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
+fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
+fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
+  ++ n ++ "' not found"
+  where
+    unitType SystemUnit = "system"
+    unitType UserUnit   = "user"
+
+fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
+fmtMsgs req opt = ("[WARNING] "++)
+  <$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
+  ++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt)
+
+warnMissing :: [MaybeExe a] -> IO ()
+warnMissing = mapM_ putStrLn . uncurry fmtMsgs . partitionMissing
+
+-- fmtType (AccessiblePath _ _ _) = undefined
+
+-- splitDeps :: [MaybeExe a] -> ([a], [String])
+-- splitDeps xs = undefined
+
+-- splitDeps' :: [m (MaybeExe a)] -> ([m a], [String])
+-- splitDeps' xs = undefined

lib/XMonad/Internal/IO.hs

@@ -17,9 +17,10 @@ module XMonad.Internal.IO
   , writePercentMax
   , decPercent
   , incPercent
-  , isReadable
+  -- , isReadable
-  , isWritable
+  -- , isWritable
   , PermResult(..)
+  , getPermissionsSafe
   ) where
 
 import           Data.Char
@@ -99,10 +100,10 @@ decPercent = shiftPercent subtract -- silly (-) operator thingy error
 data PermResult a = PermResult a | NotFoundError | PermError
   deriving (Show, Eq)
 
-instance Functor PermResult where
+-- instance Functor PermResult where
-  fmap f (PermResult r) = PermResult $ f r
+--   fmap f (PermResult r) = PermResult $ f r
-  fmap _ NotFoundError  = NotFoundError
+--   fmap _ NotFoundError  = NotFoundError
-  fmap _ PermError      = PermError
+--   fmap _ PermError      = PermError
 
 getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
 getPermissionsSafe f = do
@@ -115,8 +116,8 @@ getPermissionsSafe f = do
     -- so the catchall case should never happen
     _                                  -> error "Unknown permission error"
 
-isReadable :: FilePath -> IO (PermResult Bool)
+-- isReadable :: FilePath -> IO (PermResult Bool)
-isReadable = fmap (fmap readable) . getPermissionsSafe
+-- isReadable = fmap (fmap readable) . getPermissionsSafe
 
-isWritable :: FilePath -> IO (PermResult Bool)
+-- isWritable :: FilePath -> IO (PermResult Bool)
-isWritable = fmap (fmap writable) . getPermissionsSafe
+-- isWritable = fmap (fmap writable) . getPermissionsSafe