ENH use either for dependency results

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
+    (Right (ExitSuccess, out, _)) -> if "vpn" `elem` lines out then Nothing else Just "vpn not found"
-    _                             -> Left "puke"
+    _                             -> 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 (Right x) = Just x
-    eval _               = Nothing
+    eval _         = Nothing
 
 --------------------------------------------------------------------------------
 -- | various formatting things

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 }
+  (Right x) -> Just $ k{ kbAction = x }
-  Missing _ _   -> Just $ k{ kbDesc = "[!!!]" ++  d, kbAction = skip }
+  (Left _)  -> Just $ k{ kbDesc = "[!!!]" ++  d, kbAction = skip }
-  Ignore        -> Nothing
+  -- _                     -> Nothing
 
 externalBindings :: BrightnessControls -> SSControls -> ThreadState
   -> [KeyGroup (IO MaybeX)]

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"

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

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 ()
+    _         -> return ()
   controls x

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
+  { bctlMax = Left []
-  , bctlMin = Ignore
+  , bctlMin = Left []
-  , bctlInc = Ignore
+  , bctlInc = Left []
-  , bctlDec = Ignore
+  , bctlDec = Left []
   }
 
 blankSSToggle :: SSControls
-blankSSToggle = SSControls { ssToggle = Ignore }
+blankSSToggle = SSControls { ssToggle = Left [] }
 
 startXMonadService :: IO DBusXMonad
 startXMonadService = do

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)
-import           Data.List               (find, partition)
+import           Data.Maybe              (listToMaybe, maybeToList)
-import           Data.Maybe              (fromMaybe, isJust, listToMaybe)
 
 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
+  | Dependency DependencyData
-  -- TODO when would this ever be false?
-  { depRequired :: Bool
-  , depData     :: 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
+  es <- mapM go c
-  return $ case foldl groupResult ([], []) c' of
+  return $ case concat es of
-    ([], opt)  -> Installed a opt
+    []  -> Right a
-    (req, opt) -> if s then Ignore else Missing req opt
+    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
+    go (Dependency d) = do
-      i <- depInstalled d
+      e <- depInstalled d
-      return [(r, d) | not i ]
+      return $ maybeToList e
-    groupResult (x, y) (True, z)  = (z:x, y)
+    -- groupResult (x, y) (True, z)  = (z:x, y)
-    groupResult (x, y) (False, z) = (x, z: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
+exe = Dependency . Executable
-  { depRequired = True
-  , depData = Executable n
-  }
 
 unit :: UnitType -> String -> Dependency a
-unit t n = Dependency
+unit t = Dependency . Systemd t
-  { depRequired = True
-  , depData = Systemd t n
-  }
 
 path :: Bool -> Bool -> String -> Dependency a
-path r w n = Dependency
+path r w n = Dependency $ AccessiblePath n r w
-  { depRequired = True
-  , depData = 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]
+-- data MaybeExe a = Installed a [DependencyData]
-  | Missing [DependencyData] [DependencyData]
+--   | Missing [DependencyData] [DependencyData]
-  | Ignore
+--   | Ignore
-  deriving (Foldable, Traversable)
+--   deriving (Foldable, Traversable)
+-- data MaybeExe a = MaybeExe (Maybe a) [String]
+type MaybeExe a = Either [String] a
+--   deriving (Foldable, Traversable)
 
-instance Functor MaybeExe where
+-- instance Functor MaybeExe where
-  fmap f (Installed x ds)  = Installed (f x) ds
+--   fmap f (MaybeExe x m)    = MaybeExe (f <$> x) m
-  fmap _ (Missing req opt) = Missing req opt
-  fmap _ Ignore            = Ignore
 
 type MaybeX = MaybeExe (X ())
 
-exeInstalled :: String -> IO Bool
+exeInstalled :: String -> IO (Maybe String)
-exeInstalled x = isJust <$> findExecutable x
+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
+    ExitSuccess -> Nothing
-    _           -> False
+    _           -> 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 NotFoundError            = Just "file not found"
-    -- permMsg PermError                = Just "could not get permissions"
+    permMsg PermError                = Just "could not get permissions"
-    permMsg NotFoundError            = False
+    -- permMsg NotFoundError            = False
-    permMsg PermError                = 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 False) -> Just "file not readable or writable"
-        -- (Just False, _)          -> Just "file not readable"
+        (Just False, _)          -> Just "file not readable"
-        -- (_, Just False)          -> Just "file not writable"
+        (_, Just False)          -> Just "file not writable"
-        -- _                        -> Nothing
+        _                        -> Nothing
-        (Just True, Just True) -> True
+        -- (Just True, Just True)   -> True
-        (Just True, Nothing)   -> True
+        -- (Just True, Nothing)     -> True
-        (Nothing, Just True)   -> True
+        -- (Nothing, Just True)     -> True
-        _                      -> False
+        -- _                        -> 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 (Maybe String)
-depInstalled :: DependencyData -> IO Bool
 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 :: [Dependency a] -> IO ([DependencyData], [DependencyData])
-checkInstalled = fmap go . filterMissing
+-- checkInstalled = fmap go . filterMissing
-  where
+--   where
-    go = join (***) (fmap depData) . partition depRequired
+--     go = join (***) (fmap depData) . partition depRequired
 
-filterMissing :: [Dependency a] -> IO [Dependency a]
+-- filterMissing :: [Dependency a] -> IO [Dependency a]
-filterMissing = filterM (fmap not . depInstalled . depData)
+-- 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
+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 :: [MaybeExe a] -> ([DependencyData], [DependencyData])
-partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
+-- partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
-  where
+--   where
-    go (Installed _ opt) = ([], opt)
+--     go (Installed _ opt) = ([], opt)
-    go (Missing req opt) = (req, opt)
+--     go (Missing req opt) = (req, opt)
-    go Ignore            = ([], [])
+--     go Ignore            = ([], [])
 
-fmtMissing :: DependencyData -> String
+-- fmtMissing :: DependencyData -> String
--- TODO this error message is lame
+-- -- TODO this error message is lame
-fmtMissing (IOTest _) = "some random test failed"
+-- fmtMissing (IOTest _) = "some random test failed"
-fmtMissing DBusEndpoint {} = "some random dbus path is missing"
+-- fmtMissing DBusEndpoint {} = "some random dbus path is missing"
-fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
+-- fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
-fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
+-- fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
-fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
+-- fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
-fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
+-- fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
-fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
+-- fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
-fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
+-- fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
-  ++ n ++ "' not found"
+--   ++ n ++ "' not found"
-  where
+--   where
-    unitType SystemUnit = "system"
+--     unitType SystemUnit = "system"
-    unitType UserUnit   = "user"
+--     unitType UserUnit   = "user"
 
-fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
+-- fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
-fmtMsgs req opt = ("[WARNING] "++)
+-- fmtMsgs req opt = ("[WARNING] "++)
-  <$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
+--   <$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
-  ++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt)
+--   ++ (("[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