diff --git a/bin/xmobar.hs b/bin/xmobar.hs index c25989f..815c966 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -234,7 +234,7 @@ dateCmd = CmdSpec dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency a dbusDep usesys bus obj iface mem = - Dependency { depRequired = True, depData = d } + Dependency d where d = DBusEndpoint { ddDbusBus = bus @@ -271,13 +271,13 @@ readInterface f = do return $ Just x _ -> return Nothing -vpnPresent :: IO (Either String Bool) +vpnPresent :: IO (Maybe String) vpnPresent = do res <- tryIOError $ readProcessWithExitCode "nmcli" args "" -- TODO provide some error messages return $ case res of - (Right (ExitSuccess, out, _)) -> Right $ "vpn" `elem` lines out - _ -> Left "puke" + (Right (ExitSuccess, out, _)) -> if "vpn" `elem` lines out then Nothing else Just "vpn not found" + _ -> Just "puke" where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] @@ -296,17 +296,17 @@ rightPlugins = , nocheck dateCmd ] where - nocheck = return . flip Installed [] + nocheck = return . Right getWireless :: IO (MaybeExe CmdSpec) getWireless = do i <- readInterface isWireless - return $ maybe Ignore (flip Installed [] . wirelessCmd) i + return $ maybe (Left []) (Right . wirelessCmd) i getEthernet :: IO (MaybeExe CmdSpec) getEthernet = do i <- readInterface isEthernet - maybe (return Ignore) (runIfInstalled [dep] . ethernetCmd) i + maybe (return $ Left []) (runIfInstalled [dep] . ethernetCmd) i where dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP @@ -315,7 +315,7 @@ getBattery = Feature { ftrAction = batteryCmd , ftrSilent = False , ftrDefault = Nothing - , ftrChildren = [Dependency { depRequired = True, depData = IOTest hasBattery }] + , ftrChildren = [Dependency $ IOTest hasBattery] } type BarFeature = Feature CmdSpec (IO ()) @@ -329,7 +329,7 @@ getVPN = Feature } where d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType - v = Dependency { depRequired = True, depData = IOTest vpnPresent } + v = Dependency $ IOTest vpnPresent getBt :: BarFeature getBt = Feature @@ -379,8 +379,8 @@ getAllCommands right = do , brRight = mapMaybe eval right } where - eval (Installed x _) = Just x - eval _ = Nothing + eval (Right x) = Just x + eval _ = Nothing -------------------------------------------------------------------------------- -- | various formatting things diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 81c20f1..db00b82 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -500,9 +500,9 @@ externalToMissing = concatMap go 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 + (Right x) -> Just $ k{ kbAction = x } + (Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip } + -- _ -> Nothing externalBindings :: BrightnessControls -> SSControls -> ThreadState -> [KeyGroup (IO MaybeX)] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index ba5f63a..2244e78 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -77,12 +77,12 @@ runQuitPrompt = confirmPrompt T.promptTheme "quit?" $ io exitSuccess isUsingNvidia :: IO Bool isUsingNvidia = doesDirectoryExist "/sys/module/nvidia" -hasBattery :: IO (Either String Bool) +hasBattery :: IO (Maybe String) hasBattery = do ps <- fromRight [] <$> tryIOError (listDirectory syspath) ts <- mapM readType ps -- TODO this is obviously stupid - return $ Right $ "Battery\n" `elem` ts + return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found" where readType p = fromRight [] <$> tryIOError (readFile $ syspath p "type") syspath = "/sys/class/power_supply" diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 324b2fa..7e61c95 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -33,7 +33,7 @@ memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" dbusDep :: MemberName -> Dependency (IO a) -dbusDep m = Dependency { depRequired = True, depData = d } +dbusDep m = Dependency d where d = DBusEndpoint { ddDbusBus = bus diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 72b1d34..7441e2a 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -46,6 +46,6 @@ initControls client exporter controls = do let x = exporter client e <- evalFeature x case e of - (Installed c _) -> c - _ -> return () + (Right c) -> c + _ -> return () controls x diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index ed61f85..42103ef 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -21,7 +21,7 @@ import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Screensaver -import XMonad.Internal.Dependency +-- import XMonad.Internal.Dependency introspectInterface :: InterfaceName introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" @@ -38,14 +38,14 @@ data DBusXMonad = DBusXMonad blankControls :: BrightnessControls blankControls = BrightnessControls - { bctlMax = Ignore - , bctlMin = Ignore - , bctlInc = Ignore - , bctlDec = Ignore + { bctlMax = Left [] + , bctlMin = Left [] + , bctlInc = Left [] + , bctlDec = Left [] } blankSSToggle :: SSControls -blankSSToggle = SSControls { ssToggle = Ignore } +blankSSToggle = SSControls { ssToggle = Left [] } startXMonadService :: IO DBusXMonad startXMonadService = do diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 135c06e..8a49d7f 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DeriveTraversable #-} - -------------------------------------------------------------------------------- -- | Functions for handling dependencies module XMonad.Internal.Dependency - ( MaybeExe(..) + ( MaybeExe , UnitType(..) , Dependency(..) , DependencyData(..) @@ -18,7 +16,7 @@ module XMonad.Internal.Dependency , pathR , pathW , pathRW - , checkInstalled + -- , checkInstalled , runIfInstalled , depInstalled , warnMissing @@ -39,13 +37,10 @@ module XMonad.Internal.Dependency , spawnSound ) where -import Control.Arrow ((***)) -import Control.Monad (filterM, join) import Control.Monad.IO.Class -import Data.Either (isRight) -import Data.List (find, partition) -import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.List (find) +import Data.Maybe (listToMaybe, maybeToList) import DBus import DBus.Client @@ -72,7 +67,7 @@ data DBusMember = Method_ MemberName data DependencyData = Executable String | AccessiblePath FilePath Bool Bool - | IOTest (IO (Either String Bool)) + | IOTest (IO (Maybe String)) | DBusEndpoint { ddDbusBus :: BusName , ddDbusSystem :: Bool @@ -83,11 +78,7 @@ data DependencyData = Executable String | Systemd UnitType String data Dependency a = SubFeature (Feature a a) - | Dependency - -- TODO when would this ever be false? - { depRequired :: Bool - , depData :: DependencyData - } + | Dependency DependencyData data Feature a b = Feature { ftrAction :: a @@ -96,39 +87,51 @@ data Feature a b = Feature , ftrChildren :: [Dependency b] } | ConstFeature a +-- data Chain a = Chain +-- { chainAction :: a +-- , chainChildren :: [Feature a a] +-- , chainCompose :: a -> a -> a +-- } + evalFeature :: Feature a b -> IO (MaybeExe a) -evalFeature (ConstFeature x) = return $ Installed x [] +evalFeature (ConstFeature x) = return $ Right x evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do - c' <- concat <$> mapM go c - return $ case foldl groupResult ([], []) c' of - ([], opt) -> Installed a opt - (req, opt) -> if s then Ignore else Missing req opt + es <- mapM go c + return $ case concat es of + [] -> Right a + es' -> Left (if s then [] else es') + -- return $ case foldl groupResult ([], []) c' of + -- ([], opt) -> Installed a opt + -- (req, opt) -> if s then Ignore else Missing req opt where go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs go (SubFeature (ConstFeature _)) = return [] - go Dependency { depRequired = r, depData = d } = do - i <- depInstalled d - return [(r, d) | not i ] - groupResult (x, y) (True, z) = (z:x, y) - groupResult (x, y) (False, z) = (x, z:y) + go (Dependency d) = do + e <- depInstalled d + return $ maybeToList e + -- groupResult (x, y) (True, z) = (z:x, y) + -- groupResult (x, y) (False, z) = (x, z:y) + +-- evalChain :: Chain a -> IO (MaybeExe a) +-- evalChain Chain { chainAction = a, chainChildren = cs , chainCompose = f } = +-- flip Installed [] <$> foldM go a cs +-- where +-- go acc child = do +-- c <- evalFeature child +-- -- TODO need a way to get error messages out of this for anything +-- -- that's missing +-- return $ case c of +-- (Installed x _) -> f x acc +-- _ -> acc exe :: String -> Dependency a -exe n = Dependency - { depRequired = True - , depData = Executable n - } +exe = Dependency . Executable unit :: UnitType -> String -> Dependency a -unit t n = Dependency - { depRequired = True - , depData = Systemd t n - } +unit t = Dependency . Systemd t path :: Bool -> Bool -> String -> Dependency a -path r w n = Dependency - { depRequired = True - , depData = AccessiblePath n r w - } +path r w n = Dependency $ AccessiblePath n r w pathR :: String -> Dependency a pathR = path True False @@ -147,32 +150,39 @@ userUnit = unit UserUnit -- 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 (Foldable, Traversable) +-- data MaybeExe a = Installed a [DependencyData] +-- | Missing [DependencyData] [DependencyData] +-- | Ignore +-- deriving (Foldable, Traversable) +-- data MaybeExe a = MaybeExe (Maybe a) [String] +type MaybeExe a = Either [String] a +-- deriving (Foldable, Traversable) -instance Functor MaybeExe where - fmap f (Installed x ds) = Installed (f x) ds - fmap _ (Missing req opt) = Missing req opt - fmap _ Ignore = Ignore +-- instance Functor MaybeExe where +-- fmap f (MaybeExe x m) = MaybeExe (f <$> x) m type MaybeX = MaybeExe (X ()) -exeInstalled :: String -> IO Bool -exeInstalled x = isJust <$> findExecutable x +exeInstalled :: String -> IO (Maybe String) +exeInstalled x = do + r <- findExecutable x + return $ case r of + (Just _) -> Nothing + _ -> Just $ "executable '" ++ x ++ "' not found" -unitInstalled :: UnitType -> String -> IO Bool +unitInstalled :: UnitType -> String -> IO (Maybe String) unitInstalled u x = do (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" return $ case rc of - ExitSuccess -> True - _ -> False + 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" -- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String) -pathAccessible :: FilePath -> Bool -> Bool -> IO Bool +pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String) pathAccessible p testread testwrite = do res <- getPermissionsSafe p let msg = permMsg res @@ -181,20 +191,20 @@ pathAccessible p testread testwrite = do 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 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 + -- (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" @@ -207,7 +217,7 @@ introspectMethod :: MemberName introspectMethod = memberName_ "Introspect" dbusInstalled :: BusName -> Bool -> ObjectPath -> InterfaceName -> DBusMember - -> IO Bool + -> IO (Maybe String) dbusInstalled bus usesystem objpath iface mem = do client <- if usesystem then connectSystem else connectSession reply <- call_ client (methodCall objpath introspectInterface introspectMethod) @@ -215,7 +225,10 @@ dbusInstalled bus usesystem objpath iface mem = do let res = findMem =<< I.parseXML objpath =<< fromVariant =<< listToMaybe (methodReturnBody reply) disconnect client - return $ fromMaybe False res + return $ case res of + Just _ -> Nothing + _ -> Just "some random dbus interface not found" + -- return $ fromMaybe False res where findMem obj = fmap (matchMem mem) $ find (\i -> I.interfaceName i == iface) @@ -224,10 +237,9 @@ dbusInstalled bus usesystem objpath iface mem = do matchMem (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties --- TODO somehow get this to preserve error messages if something isn't found -depInstalled :: DependencyData -> IO Bool +depInstalled :: DependencyData -> IO (Maybe String) depInstalled (Executable n) = exeInstalled n -depInstalled (IOTest t) = isRight <$> t +depInstalled (IOTest t) = t depInstalled (Systemd t n) = unitInstalled t n depInstalled (AccessiblePath p r w) = pathAccessible p r w depInstalled DBusEndpoint { ddDbusBus = b @@ -237,13 +249,13 @@ depInstalled DBusEndpoint { ddDbusBus = b , ddDbusMember = m } = dbusInstalled b s o i m -checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData]) -checkInstalled = fmap go . filterMissing - where - go = join (***) (fmap depData) . partition depRequired +-- checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData]) +-- checkInstalled = fmap go . filterMissing +-- where +-- go = join (***) (fmap depData) . partition depRequired -filterMissing :: [Dependency a] -> IO [Dependency a] -filterMissing = filterM (fmap not . depInstalled . depData) +-- filterMissing :: [Dependency a] -> IO [Dependency a] +-- filterMissing = filterM (fmap not . depInstalled . depData) runIfInstalled :: [Dependency a] -> b -> IO (MaybeExe b) runIfInstalled ds x = evalFeature $ @@ -264,11 +276,11 @@ whenInstalled :: Monad m => MaybeExe (m ()) -> m () whenInstalled = flip ifInstalled skip ifInstalled :: MaybeExe a -> a -> a -ifInstalled (Installed x _) _ = x -ifInstalled _ alt = alt +ifInstalled (Right x) _ = x +ifInstalled _ alt = alt noCheck :: Monad m => a () -> m (MaybeExe (a ())) -noCheck = return . flip Installed [] +noCheck = return . Right -- not sure what to do with these @@ -285,35 +297,39 @@ playSound file = do -- paplay seems to have less latency than aplay 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 = ([], []) +-- 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 (IOTest _) = "some random test failed" -fmtMissing DBusEndpoint {} = "some random dbus path is missing" -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" +-- fmtMissing :: DependencyData -> String +-- -- TODO this error message is lame +-- fmtMissing (IOTest _) = "some random test failed" +-- fmtMissing DBusEndpoint {} = "some random dbus path is missing" +-- 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) +-- fmtMsgs :: [DependencyData] -> [DependencyData] -> [String] +-- fmtMsgs req opt = ("[WARNING] "++) +-- <$> (("[REQUIRED DEP] "++) . fmtMissing <$> req) +-- ++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt) + +-- warnMsg :: +-- warnMsg xs = mapM_ putStrLn +-- $ [ "[WARNING] " ++ m | (MaybeExe _ (Just m)) <- xs ] warnMissing :: [MaybeExe a] -> IO () -warnMissing = mapM_ putStrLn . uncurry fmtMsgs . partitionMissing +warnMissing xs = mapM_ putStrLn $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ] -- fmtType (AccessiblePath _ _ _) = undefined