ENH use either for dependency results

2021-11-19 00:35:54 -05:00 · 2021-11-19 00:35:54 -05:00 · 5a97a09623
parent 0caefb336f
commit 5a97a09623
7 changed files with 143 additions and 127 deletions
--- 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,7 +379,7 @@ getAllCommands right = do
    , brRight = mapMaybe eval right
    }
  where
-    eval (Installed x _) = Just x
+    eval (Right x) = Just x
    eval _         = Nothing

 --------------------------------------------------------------------------------
--- 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)]
--- 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"
--- 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
--- 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
+    (Right c) -> c
    _         -> return ()
  controls x
--- 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
--- 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 (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