diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 3b27b20..e2422ab 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -232,17 +232,14 @@ dateCmd = CmdSpec -- toJust :: a -> Bool -> Maybe a -- toJust x b = if b then Just x else Nothing -dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency a -dbusDep usesys bus obj iface mem = - Dependency d - where - d = DBusEndpoint - { ddDbusBus = bus - , ddDbusSystem = usesys - , ddDbusObject = obj - , ddDbusInterface = iface - , ddDbusMember = mem - } +dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency +dbusDep usesys bus obj iface mem = DBusEndpoint + { ddDbusBus = bus + , ddDbusSystem = usesys + , ddDbusObject = obj + , ddDbusInterface = iface + , ddDbusMember = mem + } -- in the case of network interfaces, assume that the system uses systemd in -- which case ethernet interfaces always start with "en" and wireless @@ -314,10 +311,10 @@ getBattery :: BarFeature getBattery = Feature { ftrAction = batteryCmd , ftrSilent = False - , ftrChildren = [Dependency $ IOTest hasBattery] + , ftrChildren = [IOTest hasBattery] } -type BarFeature = Feature CmdSpec (IO ()) +type BarFeature = Feature CmdSpec getVPN :: BarFeature getVPN = Feature @@ -327,7 +324,7 @@ getVPN = Feature } where d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType - v = Dependency $ IOTest vpnPresent + v = IOTest vpnPresent getBt :: BarFeature getBt = Feature diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 7d35465..bd94c70 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -45,7 +45,7 @@ myOptimusManager = "optimus-manager" -------------------------------------------------------------------------------- -- | Core commands -runScreenLock :: Feature (X ()) (X ()) +runScreenLock :: Feature (X ()) runScreenLock = Feature { ftrAction = spawn myScreenlock , ftrSilent = False diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 30375fb..5888045 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -33,21 +33,19 @@ memAdded = memberName_ "InterfacesAdded" memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" -dbusDep :: MemberName -> Dependency (IO a) -dbusDep m = Dependency d - where - d = DBusEndpoint - { ddDbusBus = bus - , ddDbusSystem = True - , ddDbusObject = path - , ddDbusInterface = interface - , ddDbusMember = Signal_ m - } +dbusDep :: MemberName -> Dependency +dbusDep m = DBusEndpoint + { ddDbusBus = bus + , ddDbusSystem = True + , ddDbusObject = path + , ddDbusInterface = interface + , ddDbusMember = Signal_ m + } -addedDep :: Dependency (IO a) +addedDep :: Dependency addedDep = dbusDep memAdded -removedDep :: Dependency (IO a) +removedDep :: Dependency removedDep = dbusDep memRemoved driveInsertedSound :: FilePath diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index ec92230..0109793 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -45,12 +45,12 @@ data BrightnessControls = BrightnessControls , bctlDec :: FeatureIO } -exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConfig a b +exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b -> Client -> IO BrightnessControls exportBrightnessControls deps bc client = initControls client (brightnessExporter deps bc) controls where - controls exporter = let callBacklight' = callBacklight bc exporter in + controls _ = let callBacklight' = callBacklight bc in BrightnessControls { bctlMax = callBacklight' memMax , bctlMin = callBacklight' memMin @@ -93,7 +93,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do -- ] -- } -brightnessExporter :: RealFrac b => [Dependency (IO ())] +brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b -> Client -> FeatureIO brightnessExporter deps bc client = Feature { ftrAction = exportBrightnessControls' bc client @@ -127,13 +127,15 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = -- callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem = -- void $ callMethod $ methodCall p i mem -callBacklight :: BrightnessConfig a b -> FeatureIO -> MemberName -> FeatureIO -callBacklight BrightnessConfig { bcPath = p, bcInterface = i } exporter mem = +callBacklight :: BrightnessConfig a b -> MemberName -> FeatureIO +callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem = Feature { ftrAction = void $ callMethod $ methodCall p i mem , ftrSilent = False - , ftrChildren = [SubFeature exporter] + , ftrChildren = [mkDep mem] } + where + mkDep = xDbusDep p i . Method_ bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index a84eab1..23fc5c1 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -82,10 +82,10 @@ intelBacklightConfig = BrightnessConfig -------------------------------------------------------------------------------- -- | Exported haskell API -curFileDep :: Dependency (IO a) +curFileDep :: Dependency curFileDep = pathRW curFile -maxFileDep :: Dependency (IO a) +maxFileDep :: Dependency maxFileDep = pathR maxFile exportIntelBacklight :: Client -> IO BrightnessControls diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index b5c30e4..4394527 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -6,6 +6,7 @@ module XMonad.Internal.DBus.Common , callMethod' , addMatchCallback , xmonadBus + , xDbusDep , initControls ) where @@ -17,6 +18,15 @@ import XMonad.Internal.Dependency xmonadBus :: BusName xmonadBus = busName_ "org.xmonad" +xDbusDep :: ObjectPath -> InterfaceName -> DBusMember -> Dependency +xDbusDep o i m = DBusEndpoint + { ddDbusBus = xmonadBus + , ddDbusSystem = False + , ddDbusObject = o + , ddDbusInterface = i + , ddDbusMember = m + } + -- | Call a method and return its result if successful callMethod :: MethodCall -> IO (Maybe [Variant]) callMethod mc = do diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 06ef903..e4e1625 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -31,8 +31,8 @@ type SSState = Bool -- true is enabled ssExecutable :: String ssExecutable = "xset" -ssDep :: Dependency (IO a) -ssDep = exe ssExecutable +ssDep :: Dependency +ssDep = Executable ssExecutable toggle :: IO SSState toggle = do @@ -102,7 +102,7 @@ newtype SSControls = SSControls { ssToggle :: FeatureIO } exportScreensaver :: Client -> IO SSControls exportScreensaver client = initControls client exportScreensaver' controls where - controls exporter = SSControls { ssToggle = callToggle exporter } + controls _ = SSControls { ssToggle = callToggle } exportScreensaver' :: Client -> FeatureIO exportScreensaver' client = Feature @@ -119,14 +119,15 @@ exportScreensaver' client = Feature ] } -callToggle :: FeatureIO -> FeatureIO -callToggle exporter = Feature +callToggle :: FeatureIO +callToggle = Feature { ftrAction = cmd , ftrSilent = False - , ftrChildren = [SubFeature exporter] + , ftrChildren = mkDep <$> [memQuery, memState, memToggle] } where cmd = void $ callMethod $ methodCall ssPath interface memToggle + mkDep = xDbusDep ssPath interface . Method_ callQuery :: IO (Maybe SSState) callQuery = do diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 2984ba2..b657f37 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -5,7 +5,6 @@ module XMonad.Internal.Dependency ( MaybeExe , UnitType(..) , Dependency(..) - , DependencyData(..) , DBusMember(..) , MaybeX , FeatureX @@ -56,7 +55,8 @@ data DBusMember = Method_ MemberName | Property_ String deriving (Eq, Show) -data DependencyData = Executable String +-- data DependencyData = Executable String +data Dependency = Executable String | AccessiblePath FilePath Bool Bool | IOTest (IO (Maybe String)) | DBusEndpoint @@ -68,32 +68,27 @@ data DependencyData = Executable String } | Systemd UnitType String -data Dependency a = SubFeature (Feature a a) - | Dependency DependencyData +-- data Dependency a = SubFeature (Feature a a) +-- | Dependency DependencyData -data Feature a b = Feature +data Feature a = Feature { ftrAction :: a , ftrSilent :: Bool - , ftrChildren :: [Dependency b] + , ftrChildren :: [Dependency] } | ConstFeature a | BlankFeature -type FeatureX = Feature (X ()) (X ()) +type FeatureX = Feature (X ()) -type FeatureIO = Feature (IO ()) (IO ()) +type FeatureIO = Feature (IO ()) -ioFeature :: (MonadIO m, MonadIO n) => Feature (IO a) (IO b) -> Feature (m a) (n b) -ioFeature f@Feature { ftrAction = a, ftrChildren = ds } = - f { ftrAction = liftIO a, ftrChildren = fmap go ds } - where - go :: MonadIO o => Dependency (IO b) -> Dependency (o b) - go (SubFeature s) = SubFeature $ ioFeature s - go (Dependency d) = Dependency d -ioFeature (ConstFeature f) = ConstFeature $ liftIO f -ioFeature BlankFeature = BlankFeature +ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a) +ioFeature f@Feature { ftrAction = a } = f { ftrAction = liftIO a } +ioFeature (ConstFeature f) = ConstFeature $ liftIO f +ioFeature BlankFeature = BlankFeature -evalFeature :: Feature a b -> IO (MaybeExe a) +evalFeature :: Feature a -> IO (MaybeExe a) evalFeature (ConstFeature x) = return $ Right x evalFeature BlankFeature = return $ Left [] evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do @@ -102,35 +97,28 @@ evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do [] -> Right a es' -> Left (if s then [] else es') where - go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs - go (Dependency d) = do - e <- depInstalled d - return $ maybeToList e - go (SubFeature _) = return [] + go = fmap maybeToList . depInstalled -exe :: String -> Dependency a -exe = Dependency . Executable +exe :: String -> Dependency +exe = Executable -unit :: UnitType -> String -> Dependency a -unit t = Dependency . Systemd t +path :: Bool -> Bool -> String -> Dependency +path r w n = AccessiblePath n r w -path :: Bool -> Bool -> String -> Dependency a -path r w n = Dependency $ AccessiblePath n r w - -pathR :: String -> Dependency a +pathR :: String -> Dependency pathR = path True False -pathW :: String -> Dependency a +pathW :: String -> Dependency pathW = path False True -pathRW :: String -> Dependency a +pathRW :: String -> Dependency pathRW = path True True -systemUnit :: String -> Dependency a -systemUnit = unit SystemUnit +systemUnit :: String -> Dependency +systemUnit = Systemd SystemUnit -userUnit :: String -> Dependency a -userUnit = unit UserUnit +userUnit :: String -> Dependency +userUnit = Systemd 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) @@ -138,17 +126,17 @@ type MaybeExe a = Either [String] a type MaybeX = MaybeExe (X ()) -featureRun :: [Dependency a] -> b -> Feature b a +featureRun :: [Dependency] -> a -> Feature a featureRun ds x = Feature { ftrAction = x , ftrSilent = False , ftrChildren = ds } -featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ()) (m ()) +featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ()) featureSpawnCmd cmd args = featureRun [exe cmd] $ spawnCmd cmd args -featureSpawn :: MonadIO m => String -> Feature (m ()) (m ()) +featureSpawn :: MonadIO m => String -> Feature (m ()) featureSpawn cmd = featureSpawnCmd cmd [] exeInstalled :: String -> IO (Maybe String) @@ -212,7 +200,7 @@ 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 -depInstalled :: DependencyData -> IO (Maybe String) +depInstalled :: Dependency -> IO (Maybe String) depInstalled (Executable n) = exeInstalled n depInstalled (IOTest t) = t depInstalled (Systemd t n) = unitInstalled t n