ENH remove subfeature crap
This commit is contained in:
parent
7ec86d04c4
commit
f473e1f26d
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue