diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 5886996..087131b 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -81,8 +81,9 @@ main = do , childPIDs = [p] , childHandles = [h] } - (ekbs, missing) <- fmap filterExternal $ evalExternal $ externalBindings bc sc ts - mapM_ warnMissing missing + ext <- evalExternal $ externalBindings bc sc ts + 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 kgs = let kgs' = fmap go kgs in (fst <$> kgs', concatMap snd kgs') +filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())] +filterExternal = fmap go where - go k@KeyGroup { kgBindings = bs } = let bs' = go' <$> bs in - (k { kgBindings = mapMaybe fst bs' }, concatMap snd bs') - go' k@KeyBinding{ kbDesc = d, kbAction = a } = case a of - Installed x ds -> (Just $ k{ kbAction = x }, ds) - Missing ds -> (Just $ k{ kbDesc = flagMissing d, kbAction = skip }, ds) - Ignore -> (Nothing, []) - flagMissing s = "[!!!]" ++ s + go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs } + -- go k@KeyGroup { kgBindings = bs } = + -- ( k { kgBindings = mapMaybe flagKeyBinding bs } + -- , concatMap go' bs + -- ) + -- go' KeyBinding{ kbAction = a } = case a of + -- 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 down" $ runMaybe bc bctlDec - , KeyBinding "M-M1-," "backlight min" $ runMaybe bc bctlMin - , KeyBinding "M-M1-." "backlight max" $ runMaybe bc bctlMax + [ KeyBinding "M-." "backlight up" $ return $ io <$> bctlInc bc + , KeyBinding "M-," "backlight down" $ return $ io <$> bctlDec bc + , KeyBinding "M-M1-," "backlight min" $ return $ io <$> bctlMin bc + , KeyBinding "M-M1-." "backlight max" $ return $ io <$> bctlMax bc , KeyBinding "M-" "power menu" $ noCheck runPowerPrompt , KeyBinding "M-" "quit xmonad" $ noCheck runQuitPrompt , KeyBinding "M-" "lock screen" runScreenLock @@ -558,8 +573,8 @@ externalBindings bc sc ts = , KeyBinding "M-" "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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 9db5951..fa6e35c 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/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 () - , bctlMin :: IO () - , bctlInc :: IO () - , bctlDec :: IO () + { bctlMax :: MaybeExe (IO ()) + , bctlMin :: MaybeExe (IO ()) + , bctlInc :: MaybeExe (IO ()) + , bctlDec :: MaybeExe (IO ()) } -exportBrightnessControls :: RealFrac b => BrightnessConfig a b -> Client - -> IO BrightnessControls -exportBrightnessControls bc client = do - exportBrightnessControls' bc client +exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b + -> Client -> IO BrightnessControls +exportBrightnessControls deps bc client = do + (req, opt) <- checkInstalled deps + when (null req) $ + exportBrightnessControls' bc client return $ BrightnessControls - { bctlMax = callBacklight' memMax - , bctlMin = callBacklight' memMin - , bctlInc = callBacklight' memInc - , bctlDec = callBacklight' memDec + { bctlMax = callBacklight' req opt memMax + , bctlMin = callBacklight' req opt memMin + , bctlInc = callBacklight' req opt memInc + , 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 diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 20417a5..38a2936 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/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' = do - mx <- isReadable maxFile - cx <- isWritable curFile - return $ case (mx, cx) of - (NotFoundError, NotFoundError) -> Right False - (PermResult True, PermResult True) -> Right True - (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files" - _ -> Left "Could not determine permissions for backlight files" +-- hasBacklight' :: IO (Either String Bool) +-- hasBacklight' = do +-- mx <- isReadable maxFile +-- cx <- isWritable curFile +-- return $ case (mx, cx) of +-- (NotFoundError, NotFoundError) -> Right False +-- (PermResult True, PermResult True) -> Right True +-- (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files" +-- _ -> Left "Could not determine permissions for backlight files" -msg :: Either String Bool -> IO () -msg (Right True) = return () -msg (Right False) = putStrLn "No backlight detected. Controls disabled" -msg (Left m) = putStrLn $ "WARNING: " ++ m +-- msg :: Either String Bool -> IO () +-- msg (Right True) = return () +-- msg (Right False) = putStrLn "No backlight detected. Controls disabled" +-- msg (Left m) = putStrLn $ "WARNING: " ++ m -hasBacklightMsg :: IO Bool -hasBacklightMsg = do - b <- hasBacklight' - msg b - return $ fromRight False b +-- hasBacklightMsg :: IO Bool +-- hasBacklightMsg = do +-- b <- hasBacklight' +-- msg b +-- return $ fromRight False b -hasBacklight :: IO Bool -hasBacklight = fromRight False <$> hasBacklight' +-- hasBacklight :: IO Bool +-- hasBacklight = fromRight False <$> hasBacklight' -------------------------------------------------------------------------------- -- | DBus interface @@ -112,12 +113,14 @@ intelBacklightConfig = BrightnessConfig -------------------------------------------------------------------------------- -- | Exported haskell API -exportIntelBacklight :: Client -> IO (Maybe BrightnessControls) -exportIntelBacklight client = do - b <- hasBacklightMsg - if b - then Just <$> exportBrightnessControls intelBacklightConfig client - else return Nothing +exportIntelBacklight :: Client -> IO BrightnessControls +exportIntelBacklight = exportBrightnessControls deps intelBacklightConfig + where + deps = [pathRW curFile, pathR maxFile] + -- b <- hasBacklightMsg + -- if b + -- then Just <$> exportBrightnessControls intelBacklightConfig client + -- else return Nothing callGetBrightnessIB :: IO (Maybe Brightness) callGetBrightnessIB = callGetBrightness intelBacklightConfig diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index a87a231..ef233f6 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -31,29 +31,37 @@ introspectMethod = memberName_ "Introspect" data DBusXMonad = DBusXMonad { dxClient :: Client - , dxIntelBacklightCtrl :: Maybe BrightnessControls - , dxClevoBacklightCtrl :: Maybe BrightnessControls + , dxIntelBacklightCtrl :: 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 } diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index aa0468c..a1b690d 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/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" diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 2a23d1b..675bf20 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/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) +import System.Directory (findExecutable, readable, writable) 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 - -- | AccessiblePath FilePath Bool Bool - | Systemd UnitType deriving (Eq, Show) +data DependencyData = Executable String + | AccessiblePath FilePath Bool Bool + | Systemd UnitType String + deriving (Eq, Show) data Dependency = Dependency { depRequired :: Bool - , depName :: String - , depType :: DependencyType + , depData :: DependencyData } deriving (Eq, Show) exe :: String -> Dependency exe n = Dependency { depRequired = True - , depName = n - , depType = Executable + , depData = Executable n } unit :: UnitType -> String -> Dependency unit t n = Dependency { depRequired = True - , depName = n - , depType = Systemd t + , depData = Systemd t n } +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 _ Ignore = Ignore + fmap f (Installed x ds) = Installed (f x) ds + 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 x u = do +unitInstalled :: UnitType -> String -> IO Bool +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 --- res <- getPermissionsSafe p --- let msg = permMsg res --- return $ fmap (\m -> m ++ ": " ++ p) 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 +pathAccessible :: FilePath -> Bool -> Bool -> IO Bool +pathAccessible p testread testwrite = do + res <- getPermissionsSafe p + let msg = permMsg res + return msg + -- return $ fmap (\m -> m ++ ": " ++ p) 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 NotFoundError = False + 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 -depInstalled Dependency { depName = n, depType = t } = - case t of - Executable -> exeInstalled n +-- TODO somehow get this to preserve error messages if something isn't found +depInstalled :: DependencyData -> IO Bool +depInstalled (Executable n) = 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 - return $ if not $ any depRequired missing - then Installed x $ filter (not . depRequired) missing - else Missing missing + (req, opt) <- checkInstalled ds + return $ createInstalled req opt x 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 diff --git a/lib/XMonad/Internal/IO.hs b/lib/XMonad/Internal/IO.hs index fed5f6e..dd25951 100644 --- a/lib/XMonad/Internal/IO.hs +++ b/lib/XMonad/Internal/IO.hs @@ -17,9 +17,10 @@ module XMonad.Internal.IO , writePercentMax , decPercent , incPercent - , isReadable - , isWritable + -- , isReadable + -- , 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 - fmap f (PermResult r) = PermResult $ f r - fmap _ NotFoundError = NotFoundError - fmap _ PermError = PermError +-- instance Functor PermResult where +-- fmap f (PermResult r) = PermResult $ f r +-- fmap _ NotFoundError = NotFoundError +-- 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 = fmap (fmap readable) . getPermissionsSafe +-- isReadable :: FilePath -> IO (PermResult Bool) +-- isReadable = fmap (fmap readable) . getPermissionsSafe -isWritable :: FilePath -> IO (PermResult Bool) -isWritable = fmap (fmap writable) . getPermissionsSafe +-- isWritable :: FilePath -> IO (PermResult Bool) +-- isWritable = fmap (fmap writable) . getPermissionsSafe