ENH remove subfeature crap

This commit is contained in:
Nathan Dwarshuis 2021-11-20 11:48:05 -05:00
parent 7ec86d04c4
commit f473e1f26d
8 changed files with 78 additions and 82 deletions

View File

@ -232,11 +232,8 @@ dateCmd = CmdSpec
-- toJust :: a -> Bool -> Maybe a -- toJust :: a -> Bool -> Maybe a
-- toJust x b = if b then Just x else Nothing -- toJust x b = if b then Just x else Nothing
dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency a dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
dbusDep usesys bus obj iface mem = dbusDep usesys bus obj iface mem = DBusEndpoint
Dependency d
where
d = DBusEndpoint
{ ddDbusBus = bus { ddDbusBus = bus
, ddDbusSystem = usesys , ddDbusSystem = usesys
, ddDbusObject = obj , ddDbusObject = obj
@ -314,10 +311,10 @@ getBattery :: BarFeature
getBattery = Feature getBattery = Feature
{ ftrAction = batteryCmd { ftrAction = batteryCmd
, ftrSilent = False , ftrSilent = False
, ftrChildren = [Dependency $ IOTest hasBattery] , ftrChildren = [IOTest hasBattery]
} }
type BarFeature = Feature CmdSpec (IO ()) type BarFeature = Feature CmdSpec
getVPN :: BarFeature getVPN :: BarFeature
getVPN = Feature getVPN = Feature
@ -327,7 +324,7 @@ getVPN = Feature
} }
where where
d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType d = dbusDep True vpnBus vpnPath vpnInterface $ Property_ vpnConnType
v = Dependency $ IOTest vpnPresent v = IOTest vpnPresent
getBt :: BarFeature getBt :: BarFeature
getBt = Feature getBt = Feature

View File

@ -45,7 +45,7 @@ myOptimusManager = "optimus-manager"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Core commands -- | Core commands
runScreenLock :: Feature (X ()) (X ()) runScreenLock :: Feature (X ())
runScreenLock = Feature runScreenLock = Feature
{ ftrAction = spawn myScreenlock { ftrAction = spawn myScreenlock
, ftrSilent = False , ftrSilent = False

View File

@ -33,10 +33,8 @@ memAdded = memberName_ "InterfacesAdded"
memRemoved :: MemberName memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved" memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> Dependency (IO a) dbusDep :: MemberName -> Dependency
dbusDep m = Dependency d dbusDep m = DBusEndpoint
where
d = DBusEndpoint
{ ddDbusBus = bus { ddDbusBus = bus
, ddDbusSystem = True , ddDbusSystem = True
, ddDbusObject = path , ddDbusObject = path
@ -44,10 +42,10 @@ dbusDep m = Dependency d
, ddDbusMember = Signal_ m , ddDbusMember = Signal_ m
} }
addedDep :: Dependency (IO a) addedDep :: Dependency
addedDep = dbusDep memAdded addedDep = dbusDep memAdded
removedDep :: Dependency (IO a) removedDep :: Dependency
removedDep = dbusDep memRemoved removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath driveInsertedSound :: FilePath

View File

@ -45,12 +45,12 @@ data BrightnessControls = BrightnessControls
, bctlDec :: FeatureIO , bctlDec :: FeatureIO
} }
exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConfig a b exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Client -> IO BrightnessControls -> Client -> IO BrightnessControls
exportBrightnessControls deps bc client = exportBrightnessControls deps bc client =
initControls client (brightnessExporter deps bc) controls initControls client (brightnessExporter deps bc) controls
where where
controls exporter = let callBacklight' = callBacklight bc exporter in controls _ = let callBacklight' = callBacklight bc in
BrightnessControls BrightnessControls
{ bctlMax = callBacklight' memMax { bctlMax = callBacklight' memMax
, bctlMin = callBacklight' memMin , 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 -> BrightnessConfig a b -> Client -> FeatureIO
brightnessExporter deps bc client = Feature brightnessExporter deps bc client = Feature
{ ftrAction = exportBrightnessControls' bc client { ftrAction = exportBrightnessControls' bc client
@ -127,13 +127,15 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
-- callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem = -- callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem =
-- void $ callMethod $ methodCall p i mem -- void $ callMethod $ methodCall p i mem
callBacklight :: BrightnessConfig a b -> FeatureIO -> MemberName -> FeatureIO callBacklight :: BrightnessConfig a b -> MemberName -> FeatureIO
callBacklight BrightnessConfig { bcPath = p, bcInterface = i } exporter mem = callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem =
Feature Feature
{ ftrAction = void $ callMethod $ methodCall p i mem { ftrAction = void $ callMethod $ methodCall p i mem
, ftrSilent = False , ftrSilent = False
, ftrChildren = [SubFeature exporter] , ftrChildren = [mkDep mem]
} }
where
mkDep = xDbusDep p i . Method_
bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

@ -82,10 +82,10 @@ intelBacklightConfig = BrightnessConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
curFileDep :: Dependency (IO a) curFileDep :: Dependency
curFileDep = pathRW curFile curFileDep = pathRW curFile
maxFileDep :: Dependency (IO a) maxFileDep :: Dependency
maxFileDep = pathR maxFile maxFileDep = pathR maxFile
exportIntelBacklight :: Client -> IO BrightnessControls exportIntelBacklight :: Client -> IO BrightnessControls

View File

@ -6,6 +6,7 @@ module XMonad.Internal.DBus.Common
, callMethod' , callMethod'
, addMatchCallback , addMatchCallback
, xmonadBus , xmonadBus
, xDbusDep
, initControls , initControls
) where ) where
@ -17,6 +18,15 @@ import XMonad.Internal.Dependency
xmonadBus :: BusName xmonadBus :: BusName
xmonadBus = busName_ "org.xmonad" 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 -- | Call a method and return its result if successful
callMethod :: MethodCall -> IO (Maybe [Variant]) callMethod :: MethodCall -> IO (Maybe [Variant])
callMethod mc = do callMethod mc = do

View File

@ -31,8 +31,8 @@ type SSState = Bool -- true is enabled
ssExecutable :: String ssExecutable :: String
ssExecutable = "xset" ssExecutable = "xset"
ssDep :: Dependency (IO a) ssDep :: Dependency
ssDep = exe ssExecutable ssDep = Executable ssExecutable
toggle :: IO SSState toggle :: IO SSState
toggle = do toggle = do
@ -102,7 +102,7 @@ newtype SSControls = SSControls { ssToggle :: FeatureIO }
exportScreensaver :: Client -> IO SSControls exportScreensaver :: Client -> IO SSControls
exportScreensaver client = initControls client exportScreensaver' controls exportScreensaver client = initControls client exportScreensaver' controls
where where
controls exporter = SSControls { ssToggle = callToggle exporter } controls _ = SSControls { ssToggle = callToggle }
exportScreensaver' :: Client -> FeatureIO exportScreensaver' :: Client -> FeatureIO
exportScreensaver' client = Feature exportScreensaver' client = Feature
@ -119,14 +119,15 @@ exportScreensaver' client = Feature
] ]
} }
callToggle :: FeatureIO -> FeatureIO callToggle :: FeatureIO
callToggle exporter = Feature callToggle = Feature
{ ftrAction = cmd { ftrAction = cmd
, ftrSilent = False , ftrSilent = False
, ftrChildren = [SubFeature exporter] , ftrChildren = mkDep <$> [memQuery, memState, memToggle]
} }
where where
cmd = void $ callMethod $ methodCall ssPath interface memToggle cmd = void $ callMethod $ methodCall ssPath interface memToggle
mkDep = xDbusDep ssPath interface . Method_
callQuery :: IO (Maybe SSState) callQuery :: IO (Maybe SSState)
callQuery = do callQuery = do

View File

@ -5,7 +5,6 @@ module XMonad.Internal.Dependency
( MaybeExe ( MaybeExe
, UnitType(..) , UnitType(..)
, Dependency(..) , Dependency(..)
, DependencyData(..)
, DBusMember(..) , DBusMember(..)
, MaybeX , MaybeX
, FeatureX , FeatureX
@ -56,7 +55,8 @@ data DBusMember = Method_ MemberName
| Property_ String | Property_ String
deriving (Eq, Show) deriving (Eq, Show)
data DependencyData = Executable String -- data DependencyData = Executable String
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String)) | IOTest (IO (Maybe String))
| DBusEndpoint | DBusEndpoint
@ -68,32 +68,27 @@ data DependencyData = Executable String
} }
| Systemd UnitType String | Systemd UnitType String
data Dependency a = SubFeature (Feature a a) -- data Dependency a = SubFeature (Feature a a)
| Dependency DependencyData -- | Dependency DependencyData
data Feature a b = Feature data Feature a = Feature
{ ftrAction :: a { ftrAction :: a
, ftrSilent :: Bool , ftrSilent :: Bool
, ftrChildren :: [Dependency b] , ftrChildren :: [Dependency]
} }
| ConstFeature a | ConstFeature a
| BlankFeature | 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 :: (MonadIO m) => Feature (IO a) -> Feature (m a)
ioFeature f@Feature { ftrAction = a, ftrChildren = ds } = ioFeature f@Feature { ftrAction = a } = f { ftrAction = liftIO a }
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 (ConstFeature f) = ConstFeature $ liftIO f
ioFeature BlankFeature = BlankFeature ioFeature BlankFeature = BlankFeature
evalFeature :: Feature a b -> IO (MaybeExe a) evalFeature :: Feature a -> IO (MaybeExe a)
evalFeature (ConstFeature x) = return $ Right x evalFeature (ConstFeature x) = return $ Right x
evalFeature BlankFeature = return $ Left [] evalFeature BlankFeature = return $ Left []
evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
@ -102,35 +97,28 @@ evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
[] -> Right a [] -> Right a
es' -> Left (if s then [] else es') es' -> Left (if s then [] else es')
where where
go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs go = fmap maybeToList . depInstalled
go (Dependency d) = do
e <- depInstalled d
return $ maybeToList e
go (SubFeature _) = return []
exe :: String -> Dependency a exe :: String -> Dependency
exe = Dependency . Executable exe = Executable
unit :: UnitType -> String -> Dependency a path :: Bool -> Bool -> String -> Dependency
unit t = Dependency . Systemd t path r w n = AccessiblePath n r w
path :: Bool -> Bool -> String -> Dependency a pathR :: String -> Dependency
path r w n = Dependency $ AccessiblePath n r w
pathR :: String -> Dependency a
pathR = path True False pathR = path True False
pathW :: String -> Dependency a pathW :: String -> Dependency
pathW = path False True pathW = path False True
pathRW :: String -> Dependency a pathRW :: String -> Dependency
pathRW = path True True pathRW = path True True
systemUnit :: String -> Dependency a systemUnit :: String -> Dependency
systemUnit = unit SystemUnit systemUnit = Systemd SystemUnit
userUnit :: String -> Dependency a userUnit :: String -> Dependency
userUnit = unit UserUnit userUnit = Systemd UserUnit
-- TODO this is poorly named. This actually represents an action that has -- TODO this is poorly named. This actually represents an action that has
-- one or more dependencies (where "action" is not necessarily executing an exe) -- 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 ()) type MaybeX = MaybeExe (X ())
featureRun :: [Dependency a] -> b -> Feature b a featureRun :: [Dependency] -> a -> Feature a
featureRun ds x = Feature featureRun ds x = Feature
{ ftrAction = x { ftrAction = x
, ftrSilent = False , ftrSilent = False
, ftrChildren = ds , 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 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 [] featureSpawn cmd = featureSpawnCmd cmd []
exeInstalled :: String -> IO (Maybe String) 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 (Signal_ n) = elem n . fmap I.signalName . I.interfaceSignals
matchMem (Property_ n) = elem n . fmap I.propertyName . I.interfaceProperties 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 (Executable n) = exeInstalled n
depInstalled (IOTest t) = t depInstalled (IOTest t) = t
depInstalled (Systemd t n) = unitInstalled t n depInstalled (Systemd t n) = unitInstalled t n