REF use more consice type for features/actions

lib/XMonad/Internal/Dependency.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveFunctor   #-}
 {-# LANGUAGE GADTs           #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -8,10 +7,7 @@
 module XMonad.Internal.Dependency
   ( MaybeAction
   , MaybeX
-  , Parent(..)
+  , Action(..)
-  , Chain(..)
-  , DBusEndpoint_(..)
-  , DBusBus_(..)
   , FeatureX
   , FeatureIO
   , Feature(..)
@@ -75,29 +71,22 @@ import           XMonad.Internal.Shell
 -- dependencies that target the output/state of another feature; this is more
 -- robust anyways, at the cost of being a bit slower.
 
-data Feature a = forall e. Evaluable e => Feature
+data Feature a = Feature
-  { ftrMaybeAction :: e a
+  { ftrMaybeAction :: Action a
   , ftrName        :: String
   , ftrWarning     :: Warning
   }
   | ConstFeature a
-  -- | BlankFeature
 
-data Parent a = Parent a [Dependency] deriving (Functor)
+data Action a = Parent a [Dependency]
+  | forall b. Chain (b -> a) (IO (Either [String] b))
+  | DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint] [Dependency]
+  | DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
 
-data Chain a = forall b. Chain (b -> a) (IO (Either [String] b))
+instance Functor Action where
-
+  fmap f (Parent a ds)               = Parent (f a) ds
-instance Functor Chain where
   fmap f (Chain a b)                 = Chain (f . a) b
-
-data DBusEndpoint_ a = DBusEndpoint_ (Client -> a) BusName (Maybe Client) [Endpoint] [Dependency]
-
-instance Functor DBusEndpoint_ where
   fmap f (DBusEndpoint_ a b c es ds) = DBusEndpoint_ (f . a) b c es ds
-
-data DBusBus_ a = DBusBus_ (Client -> a) BusName (Maybe Client) [Dependency]
-
-instance Functor DBusBus_ where
   fmap f (DBusBus_ a b c eps)        = DBusBus_ (f . a) b c eps
 
 -- TODO this is silly as is, and could be made more useful by representing
@@ -148,60 +137,74 @@ featureEndpoint busname path iface mem client = Feature
 -- either the action of the feature or 0 or more error messages that signify
 -- what dependencies are missing and why.
 
-class Functor e => Evaluable e where
-  eval :: e a -> IO (MaybeAction a)
-
 type MaybeAction a = Either [String] a
 
 type MaybeX = MaybeAction (X ())
 
-instance Evaluable Parent where
+evalAction :: Action a -> IO (MaybeAction a)
-  eval (Parent a ds) = do
+
+evalAction (Parent a ds) = do
   es <- catMaybes <$> mapM evalDependency ds
   return $ case es of
     []  -> Right a
     es' -> Left es'
 
-instance Evaluable Chain where
+evalAction (Chain a b) = second a <$> b
-  eval (Chain a b) = second a <$> b
 
-instance Evaluable DBusEndpoint_ where
+evalAction (DBusEndpoint_ _ _ Nothing _ _) = return $ Left ["client not available"]
-  eval (DBusEndpoint_ _ _ Nothing _ _) = return $ Left ["client not available"]
+evalAction (DBusEndpoint_ action busname (Just client) es ds) = do
-  eval (DBusEndpoint_ action busname (Just client) es ds) = do
   eperrors <- mapM (endpointSatisfied client busname) es
   dperrors <- mapM evalDependency ds
   return $ case catMaybes (eperrors ++ dperrors) of
     []  -> Right $ action client
     es' -> Left es'
 
-instance Evaluable DBusBus_ where
+evalAction (DBusBus_ _ _ Nothing _) = return $ Left ["client not available"]
-  eval (DBusBus_ _ _ Nothing _) = return $ Left ["client not available"]
+evalAction (DBusBus_ action busname (Just client) deps) = do
-  eval (DBusBus_ action busname (Just client) deps) = do
   res <- busSatisfied client busname
   es <- catMaybes . (res:) <$> mapM evalDependency deps
   return $ case es of
     []  -> Right $ action client
     es' -> Left es'
 
--- instance Evaluable BlankFeature where
+-- instance Evaluable Parent where
---   eval (BlankFeature a) = Left ["hopefully a useful error message"]
+--   eval (Parent a ds) = do
+--     es <- catMaybes <$> mapM evalDependency ds
+--     return $ case es of
+--       []  -> Right a
+--       es' -> Left es'
+
+-- instance Evaluable Chain where
+--   eval (Chain a b) = second a <$> b
+
+-- instance Evaluable DBusEndpoint_ where
+--   eval (DBusEndpoint_ _ _ Nothing _ _) = return $ Left ["client not available"]
+--   eval (DBusEndpoint_ action busname (Just client) es ds) = do
+--     eperrors <- mapM (endpointSatisfied client busname) es
+--     dperrors <- mapM evalDependency ds
+--     return $ case catMaybes (eperrors ++ dperrors) of
+--       []  -> Right $ action client
+--       es' -> Left es'
+
+-- instance Evaluable DBusBus_ where
+--   eval (DBusBus_ _ _ Nothing _) = return $ Left ["client not available"]
+--   eval (DBusBus_ action busname (Just client) deps) = do
+--     res <- busSatisfied client busname
+--     es <- catMaybes . (res:) <$> mapM evalDependency deps
+--     return $ case es of
+--       []  -> Right $ action client
+--       es' -> Left es'
 
 evalFeature :: Feature a -> IO (MaybeAction a)
 evalFeature (ConstFeature x) = return $ Right x
--- evalFeature BlankFeature = return $ Left []
 evalFeature Feature
   { ftrMaybeAction = a
   , ftrName = n
   , ftrWarning = w
-  -- , ftrChildren = c
   } = do
   procName <- getProgName
-  res <- eval a
+  res <- evalAction a
   return $ first (fmtWarnings procName) res
-  -- es <- catMaybes <$> mapM evalDependency c
-  -- return $ case res of
-  --   []  -> Right a
-  --   es' -> Left $ fmtWarnings procName es'
   where
     fmtWarnings procName es = case w of
       Silent  -> []
@@ -234,11 +237,8 @@ ifSatisfied _ alt       = alt
 data Dependency = Executable String
   | AccessiblePath FilePath Bool Bool
   | IOTest (IO (Maybe String))
-  -- | DBusEndpoint Bus Endpoint
-  -- | DBusBus Bus
   | Systemd UnitType String
 
-
 data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
 
 data DBusMember = Method_ MemberName
@@ -276,8 +276,6 @@ evalDependency (Executable n)         = exeSatisfied n
 evalDependency (IOTest t)             = t
 evalDependency (Systemd t n)          = unitSatisfied t n
 evalDependency (AccessiblePath p r w) = pathSatisfied p r w
--- evalDependency (DBusEndpoint b e)     = endpointSatisfied b e
--- evalDependency (DBusBus b)            = busSatisfied b
 
 exeSatisfied :: String -> IO (Maybe String)
 exeSatisfied x = do