REF use RIO text pretty much everywhere
This commit is contained in:
parent
5ed8c769fa
commit
e76ace03ad
|
|
@ -21,6 +21,8 @@ import Control.Exception
|
||||||
|
|
||||||
import Data.List
|
import Data.List
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Text.Read
|
import Text.Read
|
||||||
import Text.XML.Light
|
import Text.XML.Light
|
||||||
|
|
||||||
|
|
@ -34,7 +36,7 @@ main :: IO ()
|
||||||
main = runAndWait =<< getArgs
|
main = runAndWait =<< getArgs
|
||||||
|
|
||||||
runAndWait :: [String] -> IO ()
|
runAndWait :: [String] -> IO ()
|
||||||
runAndWait [n] = either putStrLn runConfig =<< vmInstanceConfig n
|
runAndWait [n] = either (putStrLn . T.unpack) runConfig =<< vmInstanceConfig (T.pack n)
|
||||||
where
|
where
|
||||||
runConfig c = maybe err runID =<< vmMachineID c
|
runConfig c = maybe err runID =<< vmMachineID c
|
||||||
runID i = do
|
runID i = do
|
||||||
|
|
|
||||||
149
bin/xmobar.hs
149
bin/xmobar.hs
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -18,6 +20,8 @@ import Data.Internal.Dependency
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
|
|
@ -32,7 +36,6 @@ import Xmobar.Plugins.VPN
|
||||||
|
|
||||||
import System.Posix.Signals
|
import System.Posix.Signals
|
||||||
import XMonad.Core hiding (config)
|
import XMonad.Core hiding (config)
|
||||||
import XMonad.Hooks.DynamicLog hiding (xmobar)
|
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.Command.Power
|
import XMonad.Internal.Command.Power
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
|
|
@ -40,7 +43,7 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
import XMonad.Internal.DBus.Control
|
import XMonad.Internal.DBus.Control
|
||||||
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
||||||
import XMonad.Internal.Process hiding (CmdSpec)
|
import XMonad.Internal.Process hiding (CmdSpec)
|
||||||
import qualified XMonad.Internal.Theme as T
|
import qualified XMonad.Internal.Theme as XT
|
||||||
import Xmobar hiding
|
import Xmobar hiding
|
||||||
( iconOffset
|
( iconOffset
|
||||||
, run
|
, run
|
||||||
|
|
@ -81,7 +84,7 @@ printDeps :: FIO ()
|
||||||
printDeps = do
|
printDeps = do
|
||||||
db <- io connectDBus
|
db <- io connectDBus
|
||||||
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
|
let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
|
||||||
io $ mapM_ putStrLn ps
|
io $ mapM_ (putStrLn . T.unpack) ps
|
||||||
io $ disconnectDBus db
|
io $ disconnectDBus db
|
||||||
|
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
|
|
@ -94,7 +97,7 @@ usage = putStrLn $ intercalate "\n"
|
||||||
-- | toplevel configuration
|
-- | toplevel configuration
|
||||||
|
|
||||||
-- | The text font family
|
-- | The text font family
|
||||||
textFont :: Always T.FontBuilder
|
textFont :: Always XT.FontBuilder
|
||||||
textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono" defFontPkgs
|
textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono" defFontPkgs
|
||||||
|
|
||||||
-- | Offset of the text in the bar
|
-- | Offset of the text in the bar
|
||||||
|
|
@ -102,11 +105,11 @@ textFontOffset :: Int
|
||||||
textFontOffset = 16
|
textFontOffset = 16
|
||||||
|
|
||||||
-- | Attributes for the bar font (size, weight, etc)
|
-- | Attributes for the bar font (size, weight, etc)
|
||||||
textFontData :: T.FontData
|
textFontData :: XT.FontData
|
||||||
textFontData = T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
|
textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 }
|
||||||
|
|
||||||
-- | The icon font family
|
-- | The icon font family
|
||||||
iconFont :: Sometimes T.FontBuilder
|
iconFont :: Sometimes XT.FontBuilder
|
||||||
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
|
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
|
||||||
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
||||||
|
|
||||||
|
|
@ -125,28 +128,28 @@ iconSize IconLarge = 18
|
||||||
iconSize IconXLarge = 20
|
iconSize IconXLarge = 20
|
||||||
|
|
||||||
-- | Attributes for icon fonts
|
-- | Attributes for icon fonts
|
||||||
iconFontData :: Int -> T.FontData
|
iconFontData :: Int -> XT.FontData
|
||||||
iconFontData s = T.defFontData { T.pixelsize = Just s, T.size = Nothing }
|
iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }
|
||||||
|
|
||||||
-- | Global configuration
|
-- | Global configuration
|
||||||
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
|
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
|
||||||
-- only one) text font, and all other fonts are icon fonts. If this assumption
|
-- only one) text font, and all other fonts are icon fonts. If this assumption
|
||||||
-- changes the code will need to change significantly
|
-- changes the code will need to change significantly
|
||||||
config :: String -> [String] -> [Int] -> BarRegions -> FilePath -> Config
|
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
|
||||||
config bf ifs ios br confDir = defaultConfig
|
config bf ifs ios br confDir = defaultConfig
|
||||||
{ font = bf
|
{ font = T.unpack bf
|
||||||
, additionalFonts = ifs
|
, additionalFonts = fmap T.unpack ifs
|
||||||
, textOffset = textFontOffset
|
, textOffset = textFontOffset
|
||||||
, textOffsets = ios
|
, textOffsets = ios
|
||||||
, bgColor = T.bgColor
|
, bgColor = T.unpack XT.bgColor
|
||||||
, fgColor = T.fgColor
|
, fgColor = T.unpack XT.fgColor
|
||||||
, position = BottomSize C 100 24
|
, position = BottomSize C 100 24
|
||||||
, border = NoBorder
|
, border = NoBorder
|
||||||
, borderColor = T.bordersColor
|
, borderColor = T.unpack XT.bordersColor
|
||||||
|
|
||||||
, sepChar = pSep
|
, sepChar = T.unpack pSep
|
||||||
, alignSep = [lSep, rSep]
|
, alignSep = [lSep, rSep]
|
||||||
, template = fmtRegions br
|
, template = T.unpack $ fmtRegions br
|
||||||
|
|
||||||
, lowerOnStart = False
|
, lowerOnStart = False
|
||||||
, hideOnStart = False
|
, hideOnStart = False
|
||||||
|
|
@ -252,25 +255,25 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | bar feature constructors
|
-- | bar feature constructors
|
||||||
|
|
||||||
xmobarDBus :: SafeClient c => String -> XPQuery -> DBusDependency_ c
|
xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
|
||||||
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
|
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
|
||||||
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
||||||
where
|
where
|
||||||
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
||||||
|
|
||||||
iconIO_ :: String -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
|
iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
|
||||||
-> IOTree_ -> BarFeature
|
-> IOTree_ -> BarFeature
|
||||||
iconIO_ = iconSometimes' And_ Only_
|
iconIO_ = iconSometimes' And_ Only_
|
||||||
|
|
||||||
iconDBus :: SafeClient c => String -> XPQuery
|
iconDBus :: SafeClient c => T.Text -> XPQuery
|
||||||
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
|
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
|
||||||
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||||
|
|
||||||
iconDBus_ :: SafeClient c => String -> XPQuery
|
iconDBus_ :: SafeClient c => T.Text -> XPQuery
|
||||||
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
|
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
|
||||||
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
||||||
|
|
||||||
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String -> XPQuery
|
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery
|
||||||
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
|
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
|
||||||
iconSometimes' c d n q r t = Sometimes n q
|
iconSometimes' c d n q r t = Sometimes n q
|
||||||
[ Subfeature icon "icon indicator"
|
[ Subfeature icon "icon indicator"
|
||||||
|
|
@ -290,25 +293,26 @@ data BarRegions = BarRegions
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
data CmdSpec = CmdSpec
|
data CmdSpec = CmdSpec
|
||||||
{ csAlias :: String
|
{ csAlias :: T.Text
|
||||||
, csRunnable :: Runnable
|
, csRunnable :: Runnable
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
concatRegions :: BarRegions -> [CmdSpec]
|
concatRegions :: BarRegions -> [CmdSpec]
|
||||||
concatRegions (BarRegions l c r) = l ++ c ++ r
|
concatRegions (BarRegions l c r) = l ++ c ++ r
|
||||||
|
|
||||||
wirelessCmd :: String -> CmdSpec
|
wirelessCmd :: T.Text -> CmdSpec
|
||||||
wirelessCmd iface = CmdSpec
|
wirelessCmd iface = CmdSpec
|
||||||
{ csAlias = iface ++ "wi"
|
{ csAlias = T.append iface "wi"
|
||||||
, csRunnable = Run
|
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
||||||
$ Wireless iface
|
|
||||||
[ "-t", "<qualityipat><essid>"
|
|
||||||
, "--"
|
|
||||||
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
|
|
||||||
] 5
|
|
||||||
}
|
}
|
||||||
|
where
|
||||||
|
args = fmap T.unpack
|
||||||
|
[ "-t", "<qualityipat><essid>"
|
||||||
|
, "--"
|
||||||
|
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
|
||||||
|
]
|
||||||
|
|
||||||
ethernetCmd :: Fontifier -> String -> CmdSpec
|
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
||||||
ethernetCmd fontify iface = CmdSpec
|
ethernetCmd fontify iface = CmdSpec
|
||||||
{ csAlias = iface
|
{ csAlias = iface
|
||||||
, csRunnable = Run
|
, csRunnable = Run
|
||||||
|
|
@ -318,23 +322,23 @@ ethernetCmd fontify iface = CmdSpec
|
||||||
batteryCmd :: Fontifier -> CmdSpec
|
batteryCmd :: Fontifier -> CmdSpec
|
||||||
batteryCmd fontify = CmdSpec
|
batteryCmd fontify = CmdSpec
|
||||||
{ csAlias = "battery"
|
{ csAlias = "battery"
|
||||||
, csRunnable = Run
|
, csRunnable = Run $ Battery args 50
|
||||||
$ Battery
|
|
||||||
[ "--template", "<acstatus><left>"
|
|
||||||
, "--Low", "10"
|
|
||||||
, "--High", "80"
|
|
||||||
, "--low", "red"
|
|
||||||
, "--normal", T.fgColor
|
|
||||||
, "--high", T.fgColor
|
|
||||||
, "--"
|
|
||||||
, "-P"
|
|
||||||
, "-o" , fontify' "\xf0e7" "BAT"
|
|
||||||
, "-O" , fontify' "\xf1e6" "AC"
|
|
||||||
, "-i" , fontify' "\xf1e6" "AC"
|
|
||||||
] 50
|
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
fontify' = fontify IconSmall
|
fontify' = fontify IconSmall
|
||||||
|
args = fmap T.unpack
|
||||||
|
[ "--template", "<acstatus><left>"
|
||||||
|
, "--Low", "10"
|
||||||
|
, "--High", "80"
|
||||||
|
, "--low", "red"
|
||||||
|
, "--normal", XT.fgColor
|
||||||
|
, "--high", XT.fgColor
|
||||||
|
, "--"
|
||||||
|
, "-P"
|
||||||
|
, "-o" , fontify' "\xf0e7" "BAT"
|
||||||
|
, "-O" , fontify' "\xf1e6" "AC"
|
||||||
|
, "-i" , fontify' "\xf1e6" "AC"
|
||||||
|
]
|
||||||
|
|
||||||
vpnCmd :: Fontifier -> CmdSpec
|
vpnCmd :: Fontifier -> CmdSpec
|
||||||
vpnCmd fontify = CmdSpec
|
vpnCmd fontify = CmdSpec
|
||||||
|
|
@ -349,23 +353,24 @@ btCmd fontify = CmdSpec
|
||||||
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
fontify' i = fontify IconLarge i . ("BT" ++)
|
fontify' i = fontify IconLarge i . T.append "BT"
|
||||||
|
|
||||||
alsaCmd :: Fontifier -> CmdSpec
|
alsaCmd :: Fontifier -> CmdSpec
|
||||||
alsaCmd fontify = CmdSpec
|
alsaCmd fontify = CmdSpec
|
||||||
{ csAlias = "alsa:default:Master"
|
{ csAlias = "alsa:default:Master"
|
||||||
, csRunnable = Run
|
, csRunnable = Run
|
||||||
$ Alsa "default" "Master"
|
$ Alsa "default" "Master"
|
||||||
|
$ fmap T.unpack
|
||||||
[ "-t", "<status><volume>%"
|
[ "-t", "<status><volume>%"
|
||||||
, "--"
|
, "--"
|
||||||
, "-O", fontify' "\xf028" "+"
|
, "-O", fontify' "\xf028" "+"
|
||||||
, "-o", fontify' "\xf026" "-" ++ " "
|
, "-o", T.append (fontify' "\xf026" "-") " "
|
||||||
, "-c", T.fgColor
|
, "-c", XT.fgColor
|
||||||
, "-C", T.fgColor
|
, "-C", XT.fgColor
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
fontify' i = fontify IconSmall i . ("VOL" ++)
|
fontify' i = fontify IconSmall i . T.append "VOL"
|
||||||
|
|
||||||
blCmd :: Fontifier -> CmdSpec
|
blCmd :: Fontifier -> CmdSpec
|
||||||
blCmd fontify = CmdSpec
|
blCmd fontify = CmdSpec
|
||||||
|
|
@ -390,6 +395,7 @@ lockCmd fontify = CmdSpec
|
||||||
{ csAlias = "locks"
|
{ csAlias = "locks"
|
||||||
, csRunnable = Run
|
, csRunnable = Run
|
||||||
$ Locks
|
$ Locks
|
||||||
|
$ fmap T.unpack
|
||||||
[ "-N", numIcon
|
[ "-N", numIcon
|
||||||
, "-n", disabledColor numIcon
|
, "-n", disabledColor numIcon
|
||||||
, "-C", capIcon
|
, "-C", capIcon
|
||||||
|
|
@ -403,7 +409,7 @@ lockCmd fontify = CmdSpec
|
||||||
numIcon = fontify' "\xf8a5" "N"
|
numIcon = fontify' "\xf8a5" "N"
|
||||||
capIcon = fontify' "\xf657" "C"
|
capIcon = fontify' "\xf657" "C"
|
||||||
fontify' = fontify IconXLarge
|
fontify' = fontify IconXLarge
|
||||||
disabledColor = xmobarFGColor T.backdropFgColor
|
disabledColor = xmobarFGColor XT.backdropFgColor
|
||||||
|
|
||||||
dateCmd :: CmdSpec
|
dateCmd :: CmdSpec
|
||||||
dateCmd = CmdSpec
|
dateCmd = CmdSpec
|
||||||
|
|
@ -422,9 +428,9 @@ vpnPresent =
|
||||||
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing
|
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing
|
||||||
else Just $ Msg Error "vpn not found"
|
else Just $ Msg Error "vpn not found"
|
||||||
go (Right (ExitFailure c, _, err)) = Just $ Msg Error
|
go (Right (ExitFailure c, _, err)) = Just $ Msg Error
|
||||||
$ "vpn search exited with code "
|
$ T.concat ["vpn search exited with code "
|
||||||
++ show c ++ ": " ++ err
|
, T.pack $ show c, ": ", T.pack err]
|
||||||
go (Left e) = Just $ Msg Error $ show e
|
go (Left e) = Just $ Msg Error $ T.pack $ show e
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | text font
|
-- | text font
|
||||||
|
|
@ -432,7 +438,7 @@ vpnPresent =
|
||||||
-- ASSUME there is only one text font for this entire configuration. This
|
-- ASSUME there is only one text font for this entire configuration. This
|
||||||
-- will correspond to the first font/offset parameters in the config record.
|
-- will correspond to the first font/offset parameters in the config record.
|
||||||
|
|
||||||
getTextFont :: FIO String
|
getTextFont :: FIO T.Text
|
||||||
getTextFont = do
|
getTextFont = do
|
||||||
fb <- evalAlways textFont
|
fb <- evalAlways textFont
|
||||||
return $ fb textFontData
|
return $ fb textFontData
|
||||||
|
|
@ -440,7 +446,7 @@ getTextFont = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | icon fonts
|
-- | icon fonts
|
||||||
|
|
||||||
getIconFonts :: FIO ([String], [Int])
|
getIconFonts :: FIO ([T.Text], [Int])
|
||||||
getIconFonts = do
|
getIconFonts = do
|
||||||
fb <- evalSometimes iconFont
|
fb <- evalSometimes iconFont
|
||||||
return $ maybe ([], []) apply fb
|
return $ maybe ([], []) apply fb
|
||||||
|
|
@ -457,16 +463,17 @@ data BarFont = IconSmall
|
||||||
iconFonts :: [BarFont]
|
iconFonts :: [BarFont]
|
||||||
iconFonts = enumFrom minBound
|
iconFonts = enumFrom minBound
|
||||||
|
|
||||||
iconString :: T.FontBuilder -> BarFont -> String
|
iconString :: XT.FontBuilder -> BarFont -> T.Text
|
||||||
iconString fb i = fb $ iconFontData $ iconSize i
|
iconString fb i = fb $ iconFontData $ iconSize i
|
||||||
|
|
||||||
iconDependency :: IODependency_
|
iconDependency :: IODependency_
|
||||||
iconDependency = IOSometimes_ iconFont
|
iconDependency = IOSometimes_ iconFont
|
||||||
|
|
||||||
fontifyText :: BarFont -> String -> String
|
fontifyText :: BarFont -> T.Text -> T.Text
|
||||||
fontifyText fnt txt = concat ["<fn=", show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
|
fontifyText fnt txt =
|
||||||
|
T.concat ["<fn=", T.pack $ show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
|
||||||
|
|
||||||
type Fontifier = BarFont -> String -> String -> String
|
type Fontifier = BarFont -> T.Text -> T.Text -> T.Text
|
||||||
|
|
||||||
fontifyAlt :: Fontifier
|
fontifyAlt :: Fontifier
|
||||||
fontifyAlt _ _ alt = alt
|
fontifyAlt _ _ alt = alt
|
||||||
|
|
@ -478,10 +485,10 @@ fontifyIcon f i _ = fontifyText f i
|
||||||
-- | various formatting things
|
-- | various formatting things
|
||||||
|
|
||||||
colors :: Colors
|
colors :: Colors
|
||||||
colors = Colors { colorsOn = T.fgColor, colorsOff = T.backdropFgColor }
|
colors = Colors { colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor }
|
||||||
|
|
||||||
sep :: String
|
sep :: T.Text
|
||||||
sep = xmobarFGColor T.backdropFgColor " : "
|
sep = xmobarFGColor XT.backdropFgColor " : "
|
||||||
|
|
||||||
lSep :: Char
|
lSep :: Char
|
||||||
lSep = '}'
|
lSep = '}'
|
||||||
|
|
@ -489,14 +496,14 @@ lSep = '}'
|
||||||
rSep :: Char
|
rSep :: Char
|
||||||
rSep = '{'
|
rSep = '{'
|
||||||
|
|
||||||
pSep :: String
|
pSep :: T.Text
|
||||||
pSep = "%"
|
pSep = "%"
|
||||||
|
|
||||||
fmtSpecs :: [CmdSpec] -> String
|
fmtSpecs :: [CmdSpec] -> T.Text
|
||||||
fmtSpecs = intercalate sep . fmap go
|
fmtSpecs = T.intercalate sep . fmap go
|
||||||
where
|
where
|
||||||
go CmdSpec { csAlias = a } = wrap pSep pSep a
|
go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep]
|
||||||
|
|
||||||
fmtRegions :: BarRegions -> String
|
fmtRegions :: BarRegions -> T.Text
|
||||||
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } =
|
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat $
|
||||||
fmtSpecs l ++ [lSep] ++ fmtSpecs c ++ [rSep] ++ fmtSpecs r
|
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,6 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | XMonad binary
|
-- | XMonad binary
|
||||||
|
|
@ -20,6 +21,7 @@ import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
|
|
||||||
import RIO (async)
|
import RIO (async)
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
|
@ -51,7 +53,7 @@ import XMonad.Internal.DBus.Removable
|
||||||
import XMonad.Internal.DBus.Screensaver
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import XMonad.Internal.Process
|
import XMonad.Internal.Process
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
import qualified XMonad.Internal.Theme as T
|
import qualified XMonad.Internal.Theme as XT
|
||||||
import XMonad.Layout.MultiToggle
|
import XMonad.Layout.MultiToggle
|
||||||
import XMonad.Layout.NoBorders
|
import XMonad.Layout.NoBorders
|
||||||
import XMonad.Layout.NoFrillsDecoration
|
import XMonad.Layout.NoFrillsDecoration
|
||||||
|
|
@ -114,8 +116,8 @@ tabbedFeature :: Always Theme
|
||||||
tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
||||||
where
|
where
|
||||||
sf = Subfeature niceTheme "theme with nice font"
|
sf = Subfeature niceTheme "theme with nice font"
|
||||||
niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily defFontPkgs
|
niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
|
||||||
fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
|
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
||||||
|
|
||||||
features :: Maybe SysClient -> FeatureSet
|
features :: Maybe SysClient -> FeatureSet
|
||||||
features cl = FeatureSet
|
features cl = FeatureSet
|
||||||
|
|
@ -157,8 +159,8 @@ evalConf db@DBusState { dbSysClient = cl } = do
|
||||||
, logHook = myLoghook xmobarHandle
|
, logHook = myLoghook xmobarHandle
|
||||||
, clickJustFocuses = False
|
, clickJustFocuses = False
|
||||||
, focusFollowsMouse = False
|
, focusFollowsMouse = False
|
||||||
, normalBorderColor = T.bordersColor
|
, normalBorderColor = T.unpack XT.bordersColor
|
||||||
, focusedBorderColor = T.selectedBordersColor
|
, focusedBorderColor = T.unpack XT.selectedBordersColor
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
forkIO_ = void . forkIO
|
forkIO_ = void . forkIO
|
||||||
|
|
@ -184,7 +186,7 @@ printDeps = do
|
||||||
let fs = concatMap dumpFeature f
|
let fs = concatMap dumpFeature f
|
||||||
let ds = concatMap dumpSometimes d
|
let ds = concatMap dumpSometimes d
|
||||||
let ps = fmap showFulfillment $ sort $ nub $ is ++ fs ++ ds
|
let ps = fmap showFulfillment $ sort $ nub $ is ++ fs ++ ds
|
||||||
io $ mapM_ putStrLn ps
|
io $ mapM_ (putStrLn . T.unpack) ps
|
||||||
io $ disconnectDBus db
|
io $ disconnectDBus db
|
||||||
|
|
||||||
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
||||||
|
|
@ -272,7 +274,7 @@ vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
|
||||||
where
|
where
|
||||||
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
|
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
|
||||||
$ IOTest_ name [] $ vmExists vm
|
$ IOTest_ name [] $ vmExists vm
|
||||||
name = unwords ["test if", vm, "exists"]
|
name = T.unwords ["test if", vm, "exists"]
|
||||||
c = "VirtualBoxVM"
|
c = "VirtualBoxVM"
|
||||||
vm = "win8raw"
|
vm = "win8raw"
|
||||||
dw = DynWorkspace
|
dw = DynWorkspace
|
||||||
|
|
@ -435,35 +437,39 @@ whenChanged v action = do
|
||||||
logXinerama :: Handle -> X ()
|
logXinerama :: Handle -> X ()
|
||||||
logXinerama h = withWindowSet $ \ws -> io
|
logXinerama h = withWindowSet $ \ws -> io
|
||||||
$ hPutStrLn h
|
$ hPutStrLn h
|
||||||
$ unwords
|
$ T.unpack
|
||||||
$ filter (not . null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
|
$ T.unwords
|
||||||
|
$ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
|
||||||
where
|
where
|
||||||
onScreen ws = xmobarColor hilightFgColor hilightBgColor
|
onScreen ws = xmobarColor_ hilightFgColor hilightBgColor
|
||||||
$ pad
|
$ (T.pack . pad . T.unpack)
|
||||||
$ unwords
|
$ T.unwords
|
||||||
$ map (fmtTags ws . W.tag . W.workspace)
|
$ map (fmtTags ws . W.tag . W.workspace)
|
||||||
$ sortBy compareXCoord
|
$ sortBy compareXCoord
|
||||||
$ W.current ws : W.visible ws
|
$ W.current ws : W.visible ws
|
||||||
offScreen ws = xmobarColor T.backdropFgColor ""
|
offScreen = xmobarColor_ XT.backdropFgColor ""
|
||||||
$ unwords
|
. T.unwords
|
||||||
$ map W.tag
|
. fmap (T.pack . W.tag)
|
||||||
$ filter (isJust . W.stack)
|
. filter (isJust . W.stack)
|
||||||
$ sortOn W.tag
|
. sortOn W.tag
|
||||||
$ W.hidden ws
|
. W.hidden
|
||||||
sep = xmobarColor T.backdropFgColor "" ":"
|
sep = xmobarColor_ XT.backdropFgColor "" ":"
|
||||||
layout ws = description $ W.layout $ W.workspace $ W.current ws
|
layout = T.pack . description . W.layout . W.workspace . W.current
|
||||||
nWindows ws = wrap "(" ")"
|
nWindows = (\x -> T.concat ["(", x, ")"])
|
||||||
$ show
|
. T.pack
|
||||||
$ length
|
. show
|
||||||
$ W.integrate'
|
. length
|
||||||
$ W.stack
|
. W.integrate'
|
||||||
$ W.workspace
|
. W.stack
|
||||||
$ W.current ws
|
. W.workspace
|
||||||
|
. W.current
|
||||||
hilightBgColor = "#A6D3FF"
|
hilightBgColor = "#A6D3FF"
|
||||||
hilightFgColor = T.blend' 0.4 hilightBgColor T.fgColor
|
hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
|
||||||
fmtTags ws t = if t == W.currentTag ws
|
fmtTags ws t = let t_ = T.pack t in
|
||||||
then xmobarColor T.fgColor hilightBgColor t
|
if t == W.currentTag ws
|
||||||
else t
|
then xmobarColor_ XT.fgColor hilightBgColor t_
|
||||||
|
else t_
|
||||||
|
xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c)
|
||||||
|
|
||||||
compareXCoord
|
compareXCoord
|
||||||
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
|
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
|
||||||
|
|
@ -511,7 +517,7 @@ xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
|
||||||
case xtype of
|
case xtype of
|
||||||
Workspace -> removeDynamicWorkspace tag
|
Workspace -> removeDynamicWorkspace tag
|
||||||
ACPI -> handler tag
|
ACPI -> handler tag
|
||||||
Unknown -> io $ print "WARNING: unknown concurrent message"
|
Unknown -> io $ putStrLn "WARNING: unknown concurrent message"
|
||||||
return (All True)
|
return (All True)
|
||||||
xMsgEventHook _ _ = return (All True)
|
xMsgEventHook _ _ = return (All True)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -34,6 +34,8 @@ import Data.Bifunctor
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
|
|
@ -86,10 +88,10 @@ getDBusClient' sys = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Methods
|
-- | Methods
|
||||||
|
|
||||||
type MethodBody = Either String [Variant]
|
type MethodBody = Either T.Text [Variant]
|
||||||
|
|
||||||
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
||||||
callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody)
|
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||||
. call (toClient cl)
|
. call (toClient cl)
|
||||||
|
|
||||||
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
|
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
|
||||||
|
|
@ -175,24 +177,24 @@ withSignalMatch f (Match x) = f (Just x)
|
||||||
withSignalMatch f Failure = f Nothing
|
withSignalMatch f Failure = f Nothing
|
||||||
withSignalMatch _ NoMatch = return ()
|
withSignalMatch _ NoMatch = return ()
|
||||||
|
|
||||||
matchPropertyChanged :: IsVariant a => InterfaceName -> String -> [Variant]
|
matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant]
|
||||||
-> SignalMatch a
|
-> SignalMatch a
|
||||||
matchPropertyChanged iface property [i, body, _] =
|
matchPropertyChanged iface property [i, body, _] =
|
||||||
let i' = (fromVariant i :: Maybe String)
|
let i' = (fromVariant i :: Maybe T.Text)
|
||||||
b = toMap body in
|
b = toMap body in
|
||||||
case (i', b) of
|
case (i', b) of
|
||||||
(Just i'', Just b') -> if i'' == formatInterfaceName iface then
|
(Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then
|
||||||
maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
||||||
else NoMatch
|
else NoMatch
|
||||||
_ -> Failure
|
_ -> Failure
|
||||||
where
|
where
|
||||||
toMap v = fromVariant v :: Maybe (M.Map String Variant)
|
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
|
||||||
matchPropertyChanged _ _ _ = Failure
|
matchPropertyChanged _ _ _ = Failure
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Object Manager
|
-- | Object Manager
|
||||||
|
|
||||||
type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant))
|
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
||||||
|
|
||||||
omInterface :: InterfaceName
|
omInterface :: InterfaceName
|
||||||
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
|
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
|
@ -125,6 +126,7 @@ import DBus hiding (typeOf)
|
||||||
import qualified DBus.Introspection as I
|
import qualified DBus.Introspection as I
|
||||||
|
|
||||||
import RIO hiding (LogLevel, bracket, fromString)
|
import RIO hiding (LogLevel, bracket, fromString)
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
|
@ -179,14 +181,16 @@ evalAlways a = do
|
||||||
mapM_ printMsg ws
|
mapM_ printMsg ws
|
||||||
return x
|
return x
|
||||||
|
|
||||||
|
-- TODO use real logging functions
|
||||||
printMsg :: FMsg -> FIO ()
|
printMsg :: FMsg -> FIO ()
|
||||||
printMsg (FMsg fn n (Msg ll m)) = do
|
printMsg (FMsg fn n (Msg ll m)) = do
|
||||||
xl <- asks xpLogLevel
|
xl <- asks xpLogLevel
|
||||||
p <- io getProgName
|
p <- io getProgName
|
||||||
io $ when (ll <= xl) $ putStrLn $ unwords $ s p
|
io $ when (ll <= xl) $
|
||||||
|
putStrLn $ T.unpack $ T.concat $ s (T.pack p)
|
||||||
where
|
where
|
||||||
s p = [ bracket p
|
s p = [ bracket p
|
||||||
, bracket $ show ll
|
, bracket $ T.pack $ show ll
|
||||||
, bracket fn
|
, bracket fn
|
||||||
]
|
]
|
||||||
++ maybe [] ((:[]) . bracket) n
|
++ maybe [] ((:[]) . bracket) n
|
||||||
|
|
@ -195,8 +199,8 @@ printMsg (FMsg fn n (Msg ll m)) = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Package status
|
-- | Package status
|
||||||
|
|
||||||
showFulfillment :: Fulfillment -> String
|
showFulfillment :: Fulfillment -> T.Text
|
||||||
showFulfillment (Package t n) = show t ++ "\t" ++ n
|
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
|
||||||
|
|
||||||
dumpFeature :: Feature a -> [Fulfillment]
|
dumpFeature :: Feature a -> [Fulfillment]
|
||||||
dumpFeature = either dumpSometimes dumpAlways
|
dumpFeature = either dumpSometimes dumpAlways
|
||||||
|
|
@ -228,7 +232,7 @@ type Feature a = Either (Sometimes a) (Always a)
|
||||||
-- | Feature that is guaranteed to work
|
-- | Feature that is guaranteed to work
|
||||||
-- This is composed of sub-features that are tested in order, and if all fail
|
-- This is composed of sub-features that are tested in order, and if all fail
|
||||||
-- the fallback is a monadic action (eg a plain haskell function)
|
-- the fallback is a monadic action (eg a plain haskell function)
|
||||||
data Always a = Always String (Always_ a)
|
data Always a = Always T.Text (Always_ a)
|
||||||
|
|
||||||
-- | Feature that is guaranteed to work (inner data)
|
-- | Feature that is guaranteed to work (inner data)
|
||||||
data Always_ a = Option (SubfeatureRoot a) (Always_ a)
|
data Always_ a = Option (SubfeatureRoot a) (Always_ a)
|
||||||
|
|
@ -247,7 +251,7 @@ data FallbackStack p = FallbackBottom (Always p)
|
||||||
-- | Feature that might not be present
|
-- | Feature that might not be present
|
||||||
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
||||||
-- action
|
-- action
|
||||||
data Sometimes a = Sometimes String XPQuery (Sometimes_ a)
|
data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a)
|
||||||
|
|
||||||
-- | Feature that might not be present (inner data)
|
-- | Feature that might not be present (inner data)
|
||||||
type Sometimes_ a = [SubfeatureRoot a]
|
type Sometimes_ a = [SubfeatureRoot a]
|
||||||
|
|
@ -258,7 +262,7 @@ type Sometimes_ a = [SubfeatureRoot a]
|
||||||
-- sub-feature.
|
-- sub-feature.
|
||||||
data Subfeature f = Subfeature
|
data Subfeature f = Subfeature
|
||||||
{ sfData :: f
|
{ sfData :: f
|
||||||
, sfName :: String
|
, sfName :: T.Text
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Loglevel at which feature testing should be reported
|
-- | Loglevel at which feature testing should be reported
|
||||||
|
|
@ -296,7 +300,7 @@ type DBusTree_ c = Tree_ (DBusDependency_ c)
|
||||||
-- | A dependency that only requires IO to evaluate (with payload)
|
-- | A dependency that only requires IO to evaluate (with payload)
|
||||||
data IODependency p =
|
data IODependency p =
|
||||||
-- an IO action that yields a payload
|
-- an IO action that yields a payload
|
||||||
IORead String [Fulfillment] (FIO (Result p))
|
IORead T.Text [Fulfillment] (FIO (Result p))
|
||||||
-- always yields a payload
|
-- always yields a payload
|
||||||
| IOConst p
|
| IOConst p
|
||||||
-- an always that yields a payload
|
-- an always that yields a payload
|
||||||
|
|
@ -312,7 +316,7 @@ data DBusDependency_ c = Bus [Fulfillment] BusName
|
||||||
|
|
||||||
-- | A dependency that only requires IO to evaluate (no payload)
|
-- | A dependency that only requires IO to evaluate (no payload)
|
||||||
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
|
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
|
||||||
| IOTest_ String [Fulfillment] (IO (Maybe Msg))
|
| IOTest_ T.Text [Fulfillment] (IO (Maybe Msg))
|
||||||
| forall a. IOSometimes_ (Sometimes a)
|
| forall a. IOSometimes_ (Sometimes a)
|
||||||
|
|
||||||
-- | A system component to an IODependency
|
-- | A system component to an IODependency
|
||||||
|
|
@ -320,8 +324,8 @@ data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
|
||||||
data SystemDependency =
|
data SystemDependency =
|
||||||
Executable Bool FilePath
|
Executable Bool FilePath
|
||||||
| AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
| Systemd UnitType String
|
| Systemd UnitType T.Text
|
||||||
| Process String
|
| Process T.Text
|
||||||
deriving (Eq, Show, Generic)
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
-- | The type of a systemd service
|
-- | The type of a systemd service
|
||||||
|
|
@ -330,12 +334,12 @@ data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
|
||||||
-- | Wrapper type to describe and endpoint
|
-- | Wrapper type to describe and endpoint
|
||||||
data DBusMember = Method_ MemberName
|
data DBusMember = Method_ MemberName
|
||||||
| Signal_ MemberName
|
| Signal_ MemberName
|
||||||
| Property_ String
|
| Property_ T.Text
|
||||||
deriving (Eq, Show, Generic)
|
deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
-- | A means to fulfill a dependency
|
-- | A means to fulfill a dependency
|
||||||
-- For now this is just the name of an Arch Linux package (AUR or official)
|
-- For now this is just the name of an Arch Linux package (AUR or official)
|
||||||
data Fulfillment = Package ArchPkg String deriving (Eq, Show, Ord)
|
data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
|
||||||
|
|
||||||
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
|
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
|
||||||
|
|
||||||
|
|
@ -346,10 +350,10 @@ data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
|
||||||
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
||||||
|
|
||||||
-- | A message with criteria for when to show it
|
-- | A message with criteria for when to show it
|
||||||
data Msg = Msg LogLevel String
|
data Msg = Msg LogLevel T.Text
|
||||||
|
|
||||||
-- | A message annotated with subfeature and feature name
|
-- | A message annotated with subfeature and feature name
|
||||||
data FMsg = FMsg String (Maybe String) Msg
|
data FMsg = FMsg T.Text (Maybe T.Text) Msg
|
||||||
|
|
||||||
-- | Tested Always feature
|
-- | Tested Always feature
|
||||||
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
|
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
|
||||||
|
|
@ -493,13 +497,13 @@ evalAlwaysMsg (Always n x) = do
|
||||||
(Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p
|
(Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p
|
||||||
(Fallback act fs) -> (act, failedMsgs n fs)
|
(Fallback act fs) -> (act, failedMsgs n fs)
|
||||||
|
|
||||||
passActMsg :: String -> SubfeaturePass a -> (a, [FMsg])
|
passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg])
|
||||||
passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn (Just n)) ws)
|
passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn (Just n)) ws)
|
||||||
|
|
||||||
failedMsgs :: String -> [SubfeatureFail] -> [FMsg]
|
failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg]
|
||||||
failedMsgs n = concatMap (failedMsg n)
|
failedMsgs n = concatMap (failedMsg n)
|
||||||
|
|
||||||
failedMsg :: String -> SubfeatureFail -> [FMsg]
|
failedMsg :: T.Text -> SubfeatureFail -> [FMsg]
|
||||||
failedMsg fn Subfeature { sfData = d, sfName = n } = case d of
|
failedMsg fn Subfeature { sfData = d, sfName = n } = case d of
|
||||||
(PostFail es) -> f es
|
(PostFail es) -> f es
|
||||||
(PostMissing e) -> f [e]
|
(PostMissing e) -> f [e]
|
||||||
|
|
@ -636,14 +640,14 @@ testSysDependency :: SystemDependency -> IO (Maybe Msg)
|
||||||
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
||||||
<$> findExecutable bin
|
<$> findExecutable bin
|
||||||
where
|
where
|
||||||
msg = Msg Error $ unwords [e, "executable", singleQuote bin, "not found"]
|
msg = Msg Error $ T.concat [e, "executable", singleQuote $ T.pack bin, "not found"]
|
||||||
e = if sys then "system" else "local"
|
e = if sys then "system" else "local"
|
||||||
testSysDependency (Systemd t n) = shellTest cmd msg
|
testSysDependency (Systemd t n) = shellTest cmd msg
|
||||||
where
|
where
|
||||||
msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
|
msg = T.concat ["systemd", unitType t, "unit", singleQuote n, "not found"]
|
||||||
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
|
||||||
testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n])
|
testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n])
|
||||||
$ "Process " ++ singleQuote n ++ " not found"
|
$ T.unwords ["Process", singleQuote n, "not found"]
|
||||||
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
||||||
where
|
where
|
||||||
testPerm False _ _ = Nothing
|
testPerm False _ _ = Nothing
|
||||||
|
|
@ -658,14 +662,14 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
|
||||||
(_, Just False) -> mkErr "file not writable"
|
(_, Just False) -> mkErr "file not writable"
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
shellTest :: String -> String -> IO (Maybe Msg)
|
shellTest :: T.Text -> T.Text -> IO (Maybe Msg)
|
||||||
shellTest cmd msg = do
|
shellTest cmd msg = do
|
||||||
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
(rc, _, _) <- readCreateProcessWithExitCode' (shell $ T.unpack cmd) ""
|
||||||
return $ case rc of
|
return $ case rc of
|
||||||
ExitSuccess -> Nothing
|
ExitSuccess -> Nothing
|
||||||
_ -> Just $ Msg Error msg
|
_ -> Just $ Msg Error msg
|
||||||
|
|
||||||
unitType :: UnitType -> String
|
unitType :: UnitType -> T.Text
|
||||||
unitType SystemUnit = "system"
|
unitType SystemUnit = "system"
|
||||||
unitType UserUnit = "user"
|
unitType UserUnit = "user"
|
||||||
|
|
||||||
|
|
@ -675,44 +679,44 @@ unitType UserUnit = "user"
|
||||||
-- Make a special case for these since we end up testing the font alot, and it
|
-- Make a special case for these since we end up testing the font alot, and it
|
||||||
-- would be nice if I can cache them.
|
-- would be nice if I can cache them.
|
||||||
|
|
||||||
fontAlways :: String -> String -> [Fulfillment] -> Always FontBuilder
|
fontAlways :: T.Text -> T.Text -> [Fulfillment] -> Always FontBuilder
|
||||||
fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
|
fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
|
||||||
where
|
where
|
||||||
root = IORoot id $ fontTree fam ful
|
root = IORoot id $ fontTree fam ful
|
||||||
|
|
||||||
fontSometimes :: String -> String -> [Fulfillment]-> Sometimes FontBuilder
|
fontSometimes :: T.Text -> T.Text -> [Fulfillment]-> Sometimes FontBuilder
|
||||||
fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
|
fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
|
||||||
where
|
where
|
||||||
root = IORoot id $ fontTree fam ful
|
root = IORoot id $ fontTree fam ful
|
||||||
|
|
||||||
fontFeatureName :: String -> String
|
fontFeatureName :: T.Text -> T.Text
|
||||||
fontFeatureName n = unwords ["Font family for", singleQuote n]
|
fontFeatureName n = T.unwords ["Font family for", singleQuote n]
|
||||||
|
|
||||||
fontTreeAlt :: String -> [Fulfillment] -> Tree IODependency d_ FontBuilder
|
fontTreeAlt :: T.Text -> [Fulfillment] -> Tree IODependency d_ FontBuilder
|
||||||
fontTreeAlt fam ful = Or (fontTree fam ful) $ Only $ IOConst fallbackFont
|
fontTreeAlt fam ful = Or (fontTree fam ful) $ Only $ IOConst fallbackFont
|
||||||
|
|
||||||
fontTree :: String -> [Fulfillment] -> Tree IODependency d_ FontBuilder
|
fontTree :: T.Text -> [Fulfillment] -> Tree IODependency d_ FontBuilder
|
||||||
fontTree n = Only . fontDependency n
|
fontTree n = Only . fontDependency n
|
||||||
|
|
||||||
fontTree_ :: String -> [Fulfillment] -> IOTree_
|
fontTree_ :: T.Text -> [Fulfillment] -> IOTree_
|
||||||
fontTree_ n = Only_ . fontDependency_ n
|
fontTree_ n = Only_ . fontDependency_ n
|
||||||
|
|
||||||
fontDependency :: String -> [Fulfillment] -> IODependency FontBuilder
|
fontDependency :: T.Text -> [Fulfillment] -> IODependency FontBuilder
|
||||||
fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
|
fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
|
||||||
|
|
||||||
fontDependency_ :: String -> [Fulfillment] -> IODependency_
|
fontDependency_ :: T.Text -> [Fulfillment] -> IODependency_
|
||||||
fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont' fam
|
fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont' fam
|
||||||
|
|
||||||
fontTestName :: String -> String
|
fontTestName :: T.Text -> T.Text
|
||||||
fontTestName fam = unwords ["test if font", singleQuote fam, "exists"]
|
fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
|
||||||
|
|
||||||
testFont :: String -> FIO (Result FontBuilder)
|
testFont :: T.Text -> FIO (Result FontBuilder)
|
||||||
testFont = liftIO . testFont'
|
testFont = liftIO . testFont'
|
||||||
|
|
||||||
testFont' :: String -> IO (Result FontBuilder)
|
testFont' :: T.Text -> IO (Result FontBuilder)
|
||||||
testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
|
testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
|
||||||
where
|
where
|
||||||
msg = unwords ["font family", qFam, "not found"]
|
msg = T.unwords ["font family", qFam, "not found"]
|
||||||
cmd = fmtCmd "fc-list" ["-q", qFam]
|
cmd = fmtCmd "fc-list" ["-q", qFam]
|
||||||
qFam = singleQuote fam
|
qFam = singleQuote fam
|
||||||
pass = Right $ PostPass (buildFont $ Just fam) []
|
pass = Right $ PostPass (buildFont $ Just fam) []
|
||||||
|
|
@ -723,29 +727,28 @@ testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
|
||||||
-- ASSUME that the system uses systemd in which case ethernet interfaces always
|
-- ASSUME that the system uses systemd in which case ethernet interfaces always
|
||||||
-- start with "en" and wireless interfaces always start with "wl"
|
-- start with "en" and wireless interfaces always start with "wl"
|
||||||
|
|
||||||
readEthernet :: IODependency String
|
readEthernet :: IODependency T.Text
|
||||||
readEthernet = readInterface "get ethernet interface" isEthernet
|
readEthernet = readInterface "get ethernet interface" isEthernet
|
||||||
|
|
||||||
readWireless :: IODependency String
|
readWireless :: IODependency T.Text
|
||||||
readWireless = readInterface "get wireless interface" isWireless
|
readWireless = readInterface "get wireless interface" isWireless
|
||||||
|
|
||||||
isWireless :: String -> Bool
|
isWireless :: T.Text -> Bool
|
||||||
isWireless ('w':'l':_) = True
|
isWireless = T.isPrefixOf "wl"
|
||||||
isWireless _ = False
|
|
||||||
|
|
||||||
isEthernet :: String -> Bool
|
isEthernet :: T.Text -> Bool
|
||||||
isEthernet ('e':'n':_) = True
|
isEthernet = T.isPrefixOf "en"
|
||||||
isEthernet _ = False
|
|
||||||
|
|
||||||
listInterfaces :: IO [String]
|
listInterfaces :: IO [T.Text]
|
||||||
listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
|
listInterfaces = fromRight []
|
||||||
|
<$> tryIOError (fmap T.pack <$> listDirectory sysfsNet)
|
||||||
|
|
||||||
sysfsNet :: FilePath
|
sysfsNet :: FilePath
|
||||||
sysfsNet = "/sys/class/net"
|
sysfsNet = "/sys/class/net"
|
||||||
|
|
||||||
-- ASSUME there are no (non-base) packages required to make these interfaces
|
-- ASSUME there are no (non-base) packages required to make these interfaces
|
||||||
-- work (all at the kernel level)
|
-- work (all at the kernel level)
|
||||||
readInterface :: String -> (String -> Bool) -> IODependency String
|
readInterface :: T.Text -> (T.Text -> Bool) -> IODependency T.Text
|
||||||
readInterface n f = IORead n [] go
|
readInterface n f = IORead n [] go
|
||||||
where
|
where
|
||||||
go = io $ do
|
go = io $ do
|
||||||
|
|
@ -754,13 +757,13 @@ readInterface n f = IORead n [] go
|
||||||
[] -> return $ Left [Msg Error "no interfaces found"]
|
[] -> return $ Left [Msg Error "no interfaces found"]
|
||||||
(x:xs) -> do
|
(x:xs) -> do
|
||||||
return $ Right $ PostPass x
|
return $ Right $ PostPass x
|
||||||
$ fmap (Msg Warn . ("ignoring extra interface: " ++)) xs
|
$ fmap (Msg Warn . T.append "ignoring extra interface: ") xs
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Misc testers
|
-- | Misc testers
|
||||||
|
|
||||||
socketExists :: String -> [Fulfillment] -> IO FilePath -> IODependency_
|
socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
|
||||||
socketExists n ful = IOTest_ ("test if " ++ n ++ " socket exists") ful
|
socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
|
||||||
. socketExists'
|
. socketExists'
|
||||||
|
|
||||||
socketExists' :: IO FilePath -> IO (Maybe Msg)
|
socketExists' :: IO FilePath -> IO (Maybe Msg)
|
||||||
|
|
@ -768,8 +771,8 @@ socketExists' getPath = do
|
||||||
p <- getPath
|
p <- getPath
|
||||||
r <- tryIOError $ getFileStatus p
|
r <- tryIOError $ getFileStatus p
|
||||||
return $ case r of
|
return $ case r of
|
||||||
Left e -> toErr $ ioe_description e
|
Left e -> toErr $ T.pack $ ioe_description e
|
||||||
Right s -> if isSocket s then Nothing else toErr $ p ++ " is not a socket"
|
Right s -> if isSocket s then Nothing else toErr $ T.append (T.pack p) " is not a socket"
|
||||||
where
|
where
|
||||||
toErr = Just . Msg Error
|
toErr = Just . Msg Error
|
||||||
|
|
||||||
|
|
@ -793,15 +796,15 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
|
||||||
Right b -> let ns = bodyGetNames b in
|
Right b -> let ns = bodyGetNames b in
|
||||||
if bus' `elem` ns then Right []
|
if bus' `elem` ns then Right []
|
||||||
else Left [
|
else Left [
|
||||||
Msg Error $ unwords ["name", singleQuote bus', "not found on dbus"]
|
Msg Error $ T.unwords ["name", singleQuote bus', "not found on dbus"]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
bus' = formatBusName bus
|
bus' = T.pack $ formatBusName bus
|
||||||
queryBus = busName_ "org.freedesktop.DBus"
|
queryBus = busName_ "org.freedesktop.DBus"
|
||||||
queryIface = interfaceName_ "org.freedesktop.DBus"
|
queryIface = interfaceName_ "org.freedesktop.DBus"
|
||||||
queryPath = objectPath_ "/"
|
queryPath = objectPath_ "/"
|
||||||
queryMem = memberName_ "ListNames"
|
queryMem = memberName_ "ListNames"
|
||||||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String]
|
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
|
||||||
bodyGetNames _ = []
|
bodyGetNames _ = []
|
||||||
|
|
||||||
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
||||||
|
|
@ -820,18 +823,18 @@ testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
||||||
. I.objectInterfaces
|
. I.objectInterfaces
|
||||||
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
|
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
|
||||||
matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals
|
matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals
|
||||||
matchMem (Property_ n) = elemMember n I.propertyName I.interfaceProperties
|
matchMem (Property_ n) = elemMember n (T.pack . I.propertyName) I.interfaceProperties
|
||||||
elemMember n fname fmember = elem n . fmap fname . fmember
|
elemMember n fname fmember = elem n . fmap fname . fmember
|
||||||
fmtMem (Method_ n) = "method " ++ singleQuote (formatMemberName n)
|
fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)]
|
||||||
fmtMem (Signal_ n) = "signal " ++ singleQuote (formatMemberName n)
|
fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)]
|
||||||
fmtMem (Property_ n) = "property " ++ singleQuote n
|
fmtMem (Property_ n) = T.unwords ["property", singleQuote n]
|
||||||
fmtMsg' m = unwords
|
fmtMsg' m = T.unwords
|
||||||
[ "could not find"
|
[ "could not find"
|
||||||
, fmtMem m
|
, fmtMem m
|
||||||
, "on interface"
|
, "on interface"
|
||||||
, singleQuote $ formatInterfaceName iface
|
, singleQuote $ T.pack $ formatInterfaceName iface
|
||||||
, "on bus"
|
, "on bus"
|
||||||
, formatBusName busname
|
, T.pack $ formatBusName busname
|
||||||
]
|
]
|
||||||
|
|
||||||
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
|
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
|
||||||
|
|
@ -865,40 +868,40 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature constructors
|
-- | Feature constructors
|
||||||
|
|
||||||
sometimes1_ :: XPQuery -> String -> String -> Root a -> Sometimes a
|
sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a
|
||||||
sometimes1_ x fn n t = Sometimes fn x
|
sometimes1_ x fn n t = Sometimes fn x
|
||||||
[Subfeature{ sfData = t, sfName = n }]
|
[Subfeature{ sfData = t, sfName = n }]
|
||||||
|
|
||||||
always1_ :: String -> String -> Root a -> a -> Always a
|
always1_ :: T.Text -> T.Text -> Root a -> a -> Always a
|
||||||
always1_ fn n t x = Always fn
|
always1_ fn n t x = Always fn
|
||||||
$ Option (Subfeature{ sfData = t, sfName = n }) (Always_ $ FallbackAlone x)
|
$ Option (Subfeature{ sfData = t, sfName = n }) (Always_ $ FallbackAlone x)
|
||||||
|
|
||||||
sometimes1 :: String -> String -> Root a -> Sometimes a
|
sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a
|
||||||
sometimes1 = sometimes1_ (const True)
|
sometimes1 = sometimes1_ (const True)
|
||||||
|
|
||||||
always1 :: String -> String -> Root a -> a -> Always a
|
always1 :: T.Text -> T.Text -> Root a -> a -> Always a
|
||||||
always1 = always1_
|
always1 = always1_
|
||||||
|
|
||||||
sometimesIO_ :: String -> String -> IOTree_ -> a -> Sometimes a
|
sometimesIO_ :: T.Text -> T.Text -> IOTree_ -> a -> Sometimes a
|
||||||
sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
|
sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
|
||||||
|
|
||||||
sometimesIO :: String -> String -> IOTree p -> (p -> a) -> Sometimes a
|
sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a
|
||||||
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
|
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
|
||||||
|
|
||||||
sometimesExe :: MonadIO m => String -> String -> [Fulfillment] -> Bool
|
sometimesExe :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool
|
||||||
-> FilePath -> Sometimes (m ())
|
-> FilePath -> Sometimes (m ())
|
||||||
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
|
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
|
||||||
|
|
||||||
sometimesExeArgs :: MonadIO m => String -> String -> [Fulfillment] -> Bool
|
sometimesExeArgs :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool
|
||||||
-> FilePath -> [String] -> Sometimes (m ())
|
-> FilePath -> [T.Text] -> Sometimes (m ())
|
||||||
sometimesExeArgs fn n ful sys path args =
|
sometimesExeArgs fn n ful sys path args =
|
||||||
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
|
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
|
||||||
|
|
||||||
sometimesDBus :: SafeClient c => Maybe c -> String -> String
|
sometimesDBus :: SafeClient c => Maybe c -> T.Text -> T.Text
|
||||||
-> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a
|
-> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a
|
||||||
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||||
|
|
||||||
sometimesEndpoint :: (SafeClient c, MonadIO m) => String -> String
|
sometimesEndpoint :: (SafeClient c, MonadIO m) => T.Text -> T.Text
|
||||||
-> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName
|
-> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName
|
||||||
-> Maybe c -> Sometimes (m ())
|
-> Maybe c -> Sometimes (m ())
|
||||||
sometimesEndpoint fn name ful busname path iface mem cl =
|
sometimesEndpoint fn name ful busname path iface mem cl =
|
||||||
|
|
@ -935,37 +938,37 @@ readResult_ _ = Right []
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | IO Dependency Constructors
|
-- | IO Dependency Constructors
|
||||||
|
|
||||||
exe :: Bool -> [Fulfillment] -> String -> IODependency_
|
exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_
|
||||||
exe b ful = IOSystem_ ful . Executable b
|
exe b ful = IOSystem_ ful . Executable b
|
||||||
|
|
||||||
sysExe :: [Fulfillment] -> String -> IODependency_
|
sysExe :: [Fulfillment] -> FilePath -> IODependency_
|
||||||
sysExe = exe True
|
sysExe = exe True
|
||||||
|
|
||||||
localExe :: [Fulfillment] -> String -> IODependency_
|
localExe :: [Fulfillment] -> FilePath -> IODependency_
|
||||||
localExe = exe False
|
localExe = exe False
|
||||||
|
|
||||||
path' :: Bool -> Bool -> String -> [Fulfillment] -> IODependency_
|
path' :: Bool -> Bool -> FilePath -> [Fulfillment] -> IODependency_
|
||||||
path' r w n ful = IOSystem_ ful $ AccessiblePath n r w
|
path' r w n ful = IOSystem_ ful $ AccessiblePath n r w
|
||||||
|
|
||||||
pathR :: String -> [Fulfillment] -> IODependency_
|
pathR :: FilePath -> [Fulfillment] -> IODependency_
|
||||||
pathR = path' True False
|
pathR = path' True False
|
||||||
|
|
||||||
pathW :: String -> [Fulfillment] -> IODependency_
|
pathW :: FilePath -> [Fulfillment] -> IODependency_
|
||||||
pathW = path' False True
|
pathW = path' False True
|
||||||
|
|
||||||
pathRW :: String -> [Fulfillment] -> IODependency_
|
pathRW :: FilePath -> [Fulfillment] -> IODependency_
|
||||||
pathRW = path' True True
|
pathRW = path' True True
|
||||||
|
|
||||||
sysd :: UnitType -> [Fulfillment] -> String -> IODependency_
|
sysd :: UnitType -> [Fulfillment] -> T.Text -> IODependency_
|
||||||
sysd u ful = IOSystem_ ful . Systemd u
|
sysd u ful = IOSystem_ ful . Systemd u
|
||||||
|
|
||||||
sysdUser :: [Fulfillment] -> String -> IODependency_
|
sysdUser :: [Fulfillment] -> T.Text -> IODependency_
|
||||||
sysdUser = sysd UserUnit
|
sysdUser = sysd UserUnit
|
||||||
|
|
||||||
sysdSystem :: [Fulfillment] -> String -> IODependency_
|
sysdSystem :: [Fulfillment] -> T.Text -> IODependency_
|
||||||
sysdSystem = sysd SystemUnit
|
sysdSystem = sysd SystemUnit
|
||||||
|
|
||||||
process :: [Fulfillment] -> String -> IODependency_
|
process :: [Fulfillment] -> T.Text -> IODependency_
|
||||||
process ful = IOSystem_ ful . Process
|
process ful = IOSystem_ ful . Process
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -1022,6 +1025,6 @@ dataDBusDependency d = case d of
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | JSON formatting
|
-- | JSON formatting
|
||||||
|
|
||||||
bracket :: String -> String
|
bracket :: T.Text -> T.Text
|
||||||
bracket s = "[" ++ s ++ "]"
|
bracket s = T.concat ["[", s, "]"]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dmenu (Rofi) Commands
|
-- | Dmenu (Rofi) Commands
|
||||||
|
|
||||||
|
|
@ -24,6 +26,8 @@ import DBus
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
( XdgDirectory (..)
|
( XdgDirectory (..)
|
||||||
, getXdgDirectory
|
, getXdgDirectory
|
||||||
|
|
@ -41,28 +45,28 @@ import XMonad.Util.NamedActions
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DMenu executables
|
-- | DMenu executables
|
||||||
|
|
||||||
myDmenuCmd :: String
|
myDmenuCmd :: FilePath
|
||||||
myDmenuCmd = "rofi"
|
myDmenuCmd = "rofi"
|
||||||
|
|
||||||
myDmenuDevices :: String
|
myDmenuDevices :: FilePath
|
||||||
myDmenuDevices = "rofi-dev"
|
myDmenuDevices = "rofi-dev"
|
||||||
|
|
||||||
myDmenuPasswords :: String
|
myDmenuPasswords :: FilePath
|
||||||
myDmenuPasswords = "rofi-bw"
|
myDmenuPasswords = "rofi-bw"
|
||||||
|
|
||||||
myDmenuBluetooth :: String
|
myDmenuBluetooth :: FilePath
|
||||||
myDmenuBluetooth = "rofi-bt"
|
myDmenuBluetooth = "rofi-bt"
|
||||||
|
|
||||||
myDmenuVPN :: String
|
myDmenuVPN :: FilePath
|
||||||
myDmenuVPN = "rofi-evpn"
|
myDmenuVPN = "rofi-evpn"
|
||||||
|
|
||||||
myDmenuMonitors :: String
|
myDmenuMonitors :: FilePath
|
||||||
myDmenuMonitors = "rofi-autorandr"
|
myDmenuMonitors = "rofi-autorandr"
|
||||||
|
|
||||||
myDmenuNetworks :: String
|
myDmenuNetworks :: FilePath
|
||||||
myDmenuNetworks = "networkmanager_dmenu"
|
myDmenuNetworks = "networkmanager_dmenu"
|
||||||
|
|
||||||
myClipboardManager :: String
|
myClipboardManager :: FilePath
|
||||||
myClipboardManager = "greenclip"
|
myClipboardManager = "greenclip"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -77,17 +81,17 @@ clipboardPkgs = [Package AUR "rofi-greenclip"]
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Other internal functions
|
-- | Other internal functions
|
||||||
|
|
||||||
spawnDmenuCmd :: String -> [String] -> SometimesX
|
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
|
||||||
spawnDmenuCmd n =
|
spawnDmenuCmd n =
|
||||||
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
|
sometimesExeArgs n "rofi preset" dmenuPkgs True myDmenuCmd
|
||||||
|
|
||||||
themeArgs :: String -> [String]
|
themeArgs :: T.Text -> [T.Text]
|
||||||
themeArgs hexColor =
|
themeArgs hexColor =
|
||||||
[ "-theme-str"
|
[ "-theme-str"
|
||||||
, "'#element.selected.normal { background-color: " ++ hexColor ++ "; }'"
|
, T.concat ["'#element.selected.normal { background-color: ", hexColor, "; }'"]
|
||||||
]
|
]
|
||||||
|
|
||||||
myDmenuMatchingArgs :: [String]
|
myDmenuMatchingArgs :: [T.Text]
|
||||||
myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
||||||
|
|
||||||
dmenuTree :: IOTree_ -> IOTree_
|
dmenuTree :: IOTree_ -> IOTree_
|
||||||
|
|
@ -107,7 +111,7 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
|
||||||
x = do
|
x = do
|
||||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
|
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
|
||||||
spawnCmd myDmenuDevices
|
spawnCmd myDmenuDevices
|
||||||
$ ["-c", c]
|
$ ["-c", T.pack c]
|
||||||
++ "--" : themeArgs "#999933"
|
++ "--" : themeArgs "#999933"
|
||||||
++ myDmenuMatchingArgs
|
++ myDmenuMatchingArgs
|
||||||
|
|
||||||
|
|
@ -174,7 +178,7 @@ runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
||||||
where
|
where
|
||||||
act = spawnCmd myDmenuCmd args
|
act = spawnCmd myDmenuCmd args
|
||||||
tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
|
tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
|
||||||
, process [] myClipboardManager
|
, process [] $ T.pack myClipboardManager
|
||||||
]
|
]
|
||||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
args = [ "-modi", "\"clipboard:greenclip print\""
|
||||||
, "-show", "clipboard"
|
, "-show", "clipboard"
|
||||||
|
|
@ -200,7 +204,7 @@ showKeysDMenu = Subfeature
|
||||||
|
|
||||||
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
|
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
|
||||||
showKeys kbs = io $ do
|
showKeys kbs = io $ do
|
||||||
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
|
(h, _, _, _) <- createProcess' $ (shell' $ T.unpack cmd) { std_in = CreatePipe }
|
||||||
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
||||||
where
|
where
|
||||||
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
|
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | General commands
|
-- | General commands
|
||||||
|
|
||||||
|
|
@ -47,6 +49,8 @@ import Data.Internal.Dependency
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
@ -64,34 +68,34 @@ import XMonad.Operations
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | My Executables
|
-- | My Executables
|
||||||
|
|
||||||
myTerm :: String
|
myTerm :: FilePath
|
||||||
myTerm = "urxvt"
|
myTerm = "urxvt"
|
||||||
|
|
||||||
myCalc :: String
|
myCalc :: FilePath
|
||||||
myCalc = "bc"
|
myCalc = "bc"
|
||||||
|
|
||||||
myBrowser :: String
|
myBrowser :: FilePath
|
||||||
myBrowser = "brave"
|
myBrowser = "brave"
|
||||||
|
|
||||||
myEditor :: String
|
myEditor :: FilePath
|
||||||
myEditor = "emacsclient"
|
myEditor = "emacsclient"
|
||||||
|
|
||||||
myEditorServer :: String
|
myEditorServer :: FilePath
|
||||||
myEditorServer = "emacs"
|
myEditorServer = "emacs"
|
||||||
|
|
||||||
myMultimediaCtl :: String
|
myMultimediaCtl :: FilePath
|
||||||
myMultimediaCtl = "playerctl"
|
myMultimediaCtl = "playerctl"
|
||||||
|
|
||||||
myBluetooth :: String
|
myBluetooth :: FilePath
|
||||||
myBluetooth = "bluetoothctl"
|
myBluetooth = "bluetoothctl"
|
||||||
|
|
||||||
myCapture :: String
|
myCapture :: FilePath
|
||||||
myCapture = "flameshot"
|
myCapture = "flameshot"
|
||||||
|
|
||||||
myImageBrowser :: String
|
myImageBrowser :: FilePath
|
||||||
myImageBrowser = "feh"
|
myImageBrowser = "feh"
|
||||||
|
|
||||||
myNotificationCtrl :: String
|
myNotificationCtrl :: FilePath
|
||||||
myNotificationCtrl = "dunstctl"
|
myNotificationCtrl = "dunstctl"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -132,7 +136,8 @@ runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||||
deps = listToAnds (socketExists "tmux" [] socketName)
|
deps = listToAnds (socketExists "tmux" [] socketName)
|
||||||
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
|
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
|
||||||
act = spawn
|
act = spawn
|
||||||
$ "tmux has-session"
|
$ T.unpack
|
||||||
|
$ fmtCmd "tmux" ["has-session"]
|
||||||
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
||||||
#!|| fmtNotifyCmd defNoteError { body = Just $ Text msg }
|
#!|| fmtNotifyCmd defNoteError { body = Just $ Text msg }
|
||||||
c = "exec tmux attach-session -d"
|
c = "exec tmux attach-session -d"
|
||||||
|
|
@ -146,7 +151,7 @@ runCalc :: SometimesX
|
||||||
runCalc = sometimesIO_ "calculator" "bc" deps act
|
runCalc = sometimesIO_ "calculator" "bc" deps act
|
||||||
where
|
where
|
||||||
deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
|
deps = toAnd_ (sysExe myTermPkgs myTerm) (sysExe [Package Official "bc"] myCalc)
|
||||||
act = spawnCmd myTerm ["-e", myCalc, "-l"]
|
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
|
||||||
|
|
||||||
runBrowser :: SometimesX
|
runBrowser :: SometimesX
|
||||||
runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
|
runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
|
||||||
|
|
@ -159,7 +164,7 @@ runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
||||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
||||||
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
|
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
|
||||||
-- before xmonad starts, so just check to see if the process has started
|
-- before xmonad starts, so just check to see if the process has started
|
||||||
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] myEditorServer
|
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
|
||||||
|
|
||||||
runFileManager :: SometimesX
|
runFileManager :: SometimesX
|
||||||
runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
|
runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
|
||||||
|
|
@ -168,8 +173,8 @@ runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanf
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Multimedia Commands
|
-- | Multimedia Commands
|
||||||
|
|
||||||
runMultimediaIfInstalled :: String -> String -> SometimesX
|
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
|
||||||
runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
|
runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control")
|
||||||
"playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
|
"playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
|
||||||
|
|
||||||
runTogglePlay :: SometimesX
|
runTogglePlay :: SometimesX
|
||||||
|
|
@ -195,11 +200,11 @@ playSound file = do
|
||||||
-- manually look up directories to avoid the X monad
|
-- manually look up directories to avoid the X monad
|
||||||
p <- io $ (</> soundDir </> file) . cfgDir <$> getDirectories
|
p <- io $ (</> soundDir </> file) . cfgDir <$> getDirectories
|
||||||
-- paplay seems to have less latency than aplay
|
-- paplay seems to have less latency than aplay
|
||||||
spawnCmd "paplay" [p]
|
spawnCmd "paplay" [T.pack p]
|
||||||
|
|
||||||
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
|
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
|
||||||
featureSound n file pre post =
|
featureSound n file pre post =
|
||||||
sometimesIO_ ("volume " ++ n ++ " control") "paplay" tree
|
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree
|
||||||
$ pre >> playSound file >> post
|
$ pre >> playSound file >> post
|
||||||
where
|
where
|
||||||
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
|
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
|
||||||
|
|
@ -218,9 +223,9 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Notification control
|
-- | Notification control
|
||||||
|
|
||||||
runNotificationCmd :: String -> FilePath -> Maybe SesClient -> SometimesX
|
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
runNotificationCmd n arg cl =
|
runNotificationCmd n arg cl =
|
||||||
sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
|
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myNotificationCtrl [arg]
|
cmd _ = spawnCmd myNotificationCtrl [arg]
|
||||||
tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
|
tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
|
||||||
|
|
@ -260,7 +265,8 @@ runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
|
||||||
where
|
where
|
||||||
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
|
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
|
||||||
cmd _ = spawn
|
cmd _ = spawn
|
||||||
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
$ T.unpack
|
||||||
|
$ T.unwords [T.pack myBluetooth, "show | grep -q \"Powered: no\""]
|
||||||
#!&& "a=on"
|
#!&& "a=on"
|
||||||
#!|| "a=off"
|
#!|| "a=off"
|
||||||
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
|
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
|
||||||
|
|
@ -270,11 +276,11 @@ runToggleEthernet :: SometimesX
|
||||||
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
|
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
|
||||||
[Subfeature root "nmcli"]
|
[Subfeature root "nmcli"]
|
||||||
where
|
where
|
||||||
root = IORoot (spawn . cmd) $ And1 (Only readEthernet) $ Only_
|
root = IORoot (spawn . T.unpack . cmd) $ And1 (Only readEthernet) $ Only_
|
||||||
$ sysExe networkManagerPkgs "nmcli"
|
$ sysExe networkManagerPkgs "nmcli"
|
||||||
-- TODO make this less noisy
|
-- TODO make this less noisy
|
||||||
cmd iface =
|
cmd iface =
|
||||||
"nmcli -g GENERAL.STATE device show " ++ iface ++ " | grep -q disconnected"
|
T.unwords ["nmcli -g GENERAL.STATE device show", iface, "| grep -q disconnected"]
|
||||||
#!&& "a=connect"
|
#!&& "a=connect"
|
||||||
#!|| "a=disconnect"
|
#!|| "a=disconnect"
|
||||||
#!>> fmtCmd "nmcli" ["device", "$a", iface]
|
#!>> fmtCmd "nmcli" ["device", "$a", iface]
|
||||||
|
|
@ -291,7 +297,9 @@ runRecompile :: X ()
|
||||||
runRecompile = do
|
runRecompile = do
|
||||||
-- assume that the conf directory contains a valid stack project
|
-- assume that the conf directory contains a valid stack project
|
||||||
confDir <- asks (cfgDir . directories)
|
confDir <- asks (cfgDir . directories)
|
||||||
spawnAt confDir $ fmtCmd "stack" ["install"]
|
spawnAt confDir
|
||||||
|
$ T.unpack
|
||||||
|
$ fmtCmd "stack" ["install"]
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
|
||||||
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }
|
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }
|
||||||
|
|
||||||
|
|
@ -312,8 +320,8 @@ getCaptureDir = do
|
||||||
where
|
where
|
||||||
fallback = (</> ".local/share") <$> getHomeDirectory
|
fallback = (</> ".local/share") <$> getHomeDirectory
|
||||||
|
|
||||||
runFlameshot :: String -> String -> Maybe SesClient -> SometimesX
|
runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
|
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myCapture [mode]
|
cmd _ = spawnCmd myCapture [mode]
|
||||||
tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
|
tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
|
||||||
|
|
@ -336,4 +344,4 @@ runCaptureBrowser :: SometimesX
|
||||||
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
|
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
|
||||||
(Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
|
(Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
|
||||||
dir <- io getCaptureDir
|
dir <- io getCaptureDir
|
||||||
spawnCmd myImageBrowser [dir]
|
spawnCmd myImageBrowser [T.pack dir]
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Commands for controlling power
|
-- | Commands for controlling power
|
||||||
|
|
||||||
|
|
@ -34,6 +36,8 @@ import qualified Data.Map as M
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.FilePath.Posix
|
import System.FilePath.Posix
|
||||||
|
|
@ -43,20 +47,20 @@ import System.Process (ProcessHandle)
|
||||||
import XMonad.Core
|
import XMonad.Core
|
||||||
import XMonad.Internal.Process (spawnPipeArgs)
|
import XMonad.Internal.Process (spawnPipeArgs)
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
import qualified XMonad.Internal.Theme as T
|
import qualified XMonad.Internal.Theme as XT
|
||||||
import XMonad.Prompt
|
import XMonad.Prompt
|
||||||
import XMonad.Prompt.ConfirmPrompt
|
import XMonad.Prompt.ConfirmPrompt
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Executables
|
-- | Executables
|
||||||
|
|
||||||
myScreenlock :: String
|
myScreenlock :: FilePath
|
||||||
myScreenlock = "screenlock"
|
myScreenlock = "screenlock"
|
||||||
|
|
||||||
myOptimusManager :: String
|
myOptimusManager :: FilePath
|
||||||
myOptimusManager = "optimus-manager"
|
myOptimusManager = "optimus-manager"
|
||||||
|
|
||||||
myPrimeOffload :: String
|
myPrimeOffload :: FilePath
|
||||||
myPrimeOffload = "prime-offload"
|
myPrimeOffload = "prime-offload"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -97,23 +101,23 @@ runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Confirmation prompts
|
-- | Confirmation prompts
|
||||||
|
|
||||||
promptFontDep :: IOTree T.FontBuilder
|
promptFontDep :: IOTree XT.FontBuilder
|
||||||
promptFontDep = fontTreeAlt T.defFontFamily defFontPkgs
|
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
|
||||||
|
|
||||||
defFontPkgs :: [Fulfillment]
|
defFontPkgs :: [Fulfillment]
|
||||||
defFontPkgs = [Package Official "ttf-dejavu"]
|
defFontPkgs = [Package Official "ttf-dejavu"]
|
||||||
|
|
||||||
confirmPrompt' :: String -> X () -> T.FontBuilder -> X ()
|
confirmPrompt' :: T.Text -> X () -> XT.FontBuilder -> X ()
|
||||||
confirmPrompt' s x fb = confirmPrompt (T.promptTheme fb) s x
|
confirmPrompt' s x fb = confirmPrompt (XT.promptTheme fb) (T.unpack s) x
|
||||||
|
|
||||||
suspendPrompt :: T.FontBuilder -> X ()
|
suspendPrompt :: XT.FontBuilder -> X ()
|
||||||
suspendPrompt = confirmPrompt' "suspend?" runSuspend
|
suspendPrompt = confirmPrompt' "suspend?" runSuspend
|
||||||
|
|
||||||
quitPrompt :: T.FontBuilder -> X ()
|
quitPrompt :: XT.FontBuilder -> X ()
|
||||||
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
||||||
|
|
||||||
sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
|
sometimesPrompt :: T.Text -> (XT.FontBuilder -> X ()) -> SometimesX
|
||||||
sometimesPrompt n = sometimesIO n (n ++ " command") promptFontDep
|
sometimesPrompt n = sometimesIO n (T.append n " command") promptFontDep
|
||||||
|
|
||||||
-- TODO doesn't this need to also lock the screen?
|
-- TODO doesn't this need to also lock the screen?
|
||||||
runSuspendPrompt :: SometimesX
|
runSuspendPrompt :: SometimesX
|
||||||
|
|
@ -131,7 +135,7 @@ runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
|
||||||
isUsingNvidia :: IO Bool
|
isUsingNvidia :: IO Bool
|
||||||
isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
|
isUsingNvidia = doesDirectoryExist "/sys/module/nvidia"
|
||||||
|
|
||||||
hasBattery :: IO (Maybe String)
|
hasBattery :: IO (Maybe T.Text)
|
||||||
hasBattery = do
|
hasBattery = do
|
||||||
ps <- fromRight [] <$> tryIOError (listDirectory syspath)
|
ps <- fromRight [] <$> tryIOError (listDirectory syspath)
|
||||||
ts <- mapM readType ps
|
ts <- mapM readType ps
|
||||||
|
|
@ -140,16 +144,17 @@ hasBattery = do
|
||||||
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
|
readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
|
||||||
syspath = "/sys/class/power_supply"
|
syspath = "/sys/class/power_supply"
|
||||||
|
|
||||||
runOptimusPrompt' :: T.FontBuilder -> X ()
|
runOptimusPrompt' :: XT.FontBuilder -> X ()
|
||||||
runOptimusPrompt' fb = do
|
runOptimusPrompt' fb = do
|
||||||
nvidiaOn <- io isUsingNvidia
|
nvidiaOn <- io isUsingNvidia
|
||||||
switch $ if nvidiaOn then "integrated" else "nvidia"
|
switch $ if nvidiaOn then "integrated" else "nvidia"
|
||||||
where
|
where
|
||||||
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
|
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
|
||||||
prompt mode = "gpu switch to " ++ mode ++ "?"
|
prompt mode = T.concat ["gpu switch to ", mode, "?"]
|
||||||
cmd mode = spawn $
|
cmd mode = spawn $
|
||||||
myPrimeOffload
|
T.unpack
|
||||||
#!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
|
$ T.pack myPrimeOffload
|
||||||
|
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
|
||||||
#!&& "killall xmonad"
|
#!&& "killall xmonad"
|
||||||
|
|
||||||
runOptimusPrompt :: SometimesX
|
runOptimusPrompt :: SometimesX
|
||||||
|
|
@ -197,11 +202,11 @@ runPowerPrompt = Sometimes "power prompt" (const True) [sf]
|
||||||
tree = And12 (,) lockTree promptFontDep
|
tree = And12 (,) lockTree promptFontDep
|
||||||
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
|
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
|
||||||
|
|
||||||
powerPrompt :: X () -> T.FontBuilder -> X ()
|
powerPrompt :: X () -> XT.FontBuilder -> X ()
|
||||||
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
||||||
where
|
where
|
||||||
comp = mkComplFunFromList theme []
|
comp = mkComplFunFromList theme []
|
||||||
theme = (T.promptTheme fb) { promptKeymap = keymap }
|
theme = (XT.promptTheme fb) { promptKeymap = keymap }
|
||||||
keymap = M.fromList
|
keymap = M.fromList
|
||||||
$ ((controlMask, xK_g), quit) :
|
$ ((controlMask, xK_g), quit) :
|
||||||
map (first $ (,) 0)
|
map (first $ (,) 0)
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,6 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VirtualBox-specific functions
|
-- | VirtualBox-specific functions
|
||||||
|
|
||||||
|
|
@ -14,24 +16,26 @@ import Data.Internal.Dependency
|
||||||
|
|
||||||
import Text.XML.Light
|
import Text.XML.Light
|
||||||
|
|
||||||
|
import RIO.FilePath
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.FilePath
|
|
||||||
|
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
vmExists :: String -> IO (Maybe Msg)
|
vmExists :: T.Text -> IO (Maybe Msg)
|
||||||
vmExists vm = either (Just . Msg Error) (const Nothing) <$> vmInstanceConfig vm
|
vmExists vm = either (Just . Msg Error) (const Nothing) <$> vmInstanceConfig vm
|
||||||
|
|
||||||
vmInstanceConfig :: String -> IO (Either String FilePath)
|
vmInstanceConfig :: T.Text -> IO (Either T.Text FilePath)
|
||||||
vmInstanceConfig vmName = do
|
vmInstanceConfig vmName = do
|
||||||
either (return . Right) findInstance =<< vmDirectory
|
either (return . Right) findInstance =<< vmDirectory
|
||||||
where
|
where
|
||||||
path = vmName </> (vmName ++ ".vbox")
|
path = T.unpack vmName </> addExtension (T.unpack vmName) "vbox"
|
||||||
findInstance dir = do
|
findInstance dir = do
|
||||||
res <- findFile [dir] path
|
res <- findFile [dir] path
|
||||||
return $ case res of
|
return $ case res of
|
||||||
Just p -> Right p
|
Just p -> Right p
|
||||||
Nothing -> Left $ "could not find VM instance: " ++ singleQuote vmName
|
Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName
|
||||||
|
|
||||||
vmDirectory :: IO (Either String String)
|
vmDirectory :: IO (Either String String)
|
||||||
vmDirectory = do
|
vmDirectory = do
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for Clevo Keyboard control
|
-- | DBus module for Clevo Keyboard control
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for DBus brightness controls
|
-- | DBus module for DBus brightness controls
|
||||||
|
|
||||||
|
|
@ -21,6 +23,8 @@ import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified DBus.Introspection as I
|
import qualified DBus.Introspection as I
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Core (io)
|
import XMonad.Core (io)
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
|
||||||
|
|
@ -42,7 +46,7 @@ data BrightnessConfig a b = BrightnessConfig
|
||||||
, bcGetMax :: IO a
|
, bcGetMax :: IO a
|
||||||
, bcPath :: ObjectPath
|
, bcPath :: ObjectPath
|
||||||
, bcInterface :: InterfaceName
|
, bcInterface :: InterfaceName
|
||||||
, bcName :: String
|
, bcName :: T.Text
|
||||||
}
|
}
|
||||||
|
|
||||||
data BrightnessControls = BrightnessControls
|
data BrightnessControls = BrightnessControls
|
||||||
|
|
@ -92,7 +96,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
||||||
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
|
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
|
||||||
-> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
|
-> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
|
||||||
brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
|
brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
|
||||||
Sometimes (n ++ " DBus Interface") q [Subfeature root "exporter"]
|
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
||||||
where
|
where
|
||||||
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
||||||
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
|
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
|
||||||
|
|
@ -133,12 +137,12 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
|
||||||
where
|
where
|
||||||
sig = signal p i memCur
|
sig = signal p i memCur
|
||||||
|
|
||||||
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> String
|
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
|
||||||
-> MemberName -> SometimesIO
|
-> MemberName -> SometimesIO
|
||||||
callBacklight q cl BrightnessConfig { bcPath = p
|
callBacklight q cl BrightnessConfig { bcPath = p
|
||||||
, bcInterface = i
|
, bcInterface = i
|
||||||
, bcName = n } controlName m =
|
, bcName = n } controlName m =
|
||||||
Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
|
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
|
||||||
where
|
where
|
||||||
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
||||||
cmd c = io $ void $ callMethod c xmonadBusName p i m
|
cmd c = io $ void $ callMethod c xmonadBusName p i m
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for Intel Backlight control
|
-- | DBus module for Intel Backlight control
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Module for monitoring removable drive events
|
-- | Module for monitoring removable drive events
|
||||||
--
|
--
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for X11 screensave/DPMS control
|
-- | DBus module for X11 screensave/DPMS control
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for formatting and sending notifications
|
-- | Functions for formatting and sending notifications
|
||||||
--
|
--
|
||||||
|
|
@ -21,6 +23,8 @@ import Data.Maybe
|
||||||
|
|
||||||
import DBus.Notify
|
import DBus.Notify
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -40,21 +44,22 @@ defNoteError = defNote
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Format a 'notify-send' command to be send to the shell
|
-- | Format a 'notify-send' command to be send to the shell
|
||||||
|
|
||||||
parseBody :: Body -> Maybe String
|
parseBody :: Body -> Maybe T.Text
|
||||||
parseBody (Text s) = Just s
|
parseBody (Text s) = Just $ T.pack s
|
||||||
parseBody _ = Nothing
|
parseBody _ = Nothing
|
||||||
|
|
||||||
fmtNotifyCmd :: Note -> String
|
fmtNotifyCmd :: Note -> T.Text
|
||||||
fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
|
fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
|
||||||
|
|
||||||
spawnNotify :: MonadIO m => Note -> m ()
|
spawnNotify :: MonadIO m => Note -> m ()
|
||||||
spawnNotify = spawnCmd "notify-send" . fmtNotifyArgs
|
spawnNotify = spawnCmd "notify-send" . fmtNotifyArgs
|
||||||
|
|
||||||
fmtNotifyArgs :: Note -> [String]
|
fmtNotifyArgs :: Note -> [T.Text]
|
||||||
fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
|
fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
|
||||||
where
|
where
|
||||||
-- TODO add the rest of the options as needed
|
-- TODO add the rest of the options as needed
|
||||||
getSummary = (:[]) . doubleQuote . summary
|
getSummary = (:[]) . doubleQuote . T.pack . summary
|
||||||
getIcon n' = maybe [] (\i -> ["-i", case i of { Icon s -> s; File s -> s }])
|
getIcon n' =
|
||||||
|
maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }])
|
||||||
$ appImage n'
|
$ appImage n'
|
||||||
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'
|
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for formatting and spawning shell commands
|
-- | Functions for formatting and spawning shell commands
|
||||||
|
|
||||||
|
|
@ -15,45 +17,50 @@ module XMonad.Internal.Shell
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.Process
|
import XMonad.Internal.Process
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Opening subshell
|
-- | Opening subshell
|
||||||
|
|
||||||
spawnCmd :: MonadIO m => String -> [String] -> m ()
|
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
|
||||||
spawnCmd cmd args = spawn $ fmtCmd cmd args
|
spawnCmd cmd args = spawn $ T.unpack $ fmtCmd cmd args
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Formatting commands
|
-- | Formatting commands
|
||||||
|
|
||||||
fmtCmd :: String -> [String] -> String
|
fmtCmd :: FilePath -> [T.Text] -> T.Text
|
||||||
fmtCmd cmd args = unwords $ cmd : args
|
fmtCmd cmd args = T.unwords $ T.pack cmd : args
|
||||||
|
|
||||||
(#!&&) :: String -> String -> String
|
op :: T.Text -> T.Text -> T.Text -> T.Text
|
||||||
cmdA #!&& cmdB = cmdA ++ " && " ++ cmdB
|
op a x b = T.unwords [a, x, b]
|
||||||
|
|
||||||
|
(#!&&) :: T.Text -> T.Text -> T.Text
|
||||||
|
cmdA #!&& cmdB = op cmdA "&&" cmdB
|
||||||
|
|
||||||
infixr 0 #!&&
|
infixr 0 #!&&
|
||||||
|
|
||||||
(#!|) :: String -> String -> String
|
(#!|) :: T.Text -> T.Text -> T.Text
|
||||||
cmdA #!| cmdB = cmdA ++ " | " ++ cmdB
|
cmdA #!| cmdB = op cmdA "|" cmdB
|
||||||
|
|
||||||
infixr 0 #!|
|
infixr 0 #!|
|
||||||
|
|
||||||
(#!||) :: String -> String -> String
|
(#!||) :: T.Text -> T.Text -> T.Text
|
||||||
cmdA #!|| cmdB = cmdA ++ " || " ++ cmdB
|
cmdA #!|| cmdB = op cmdA "||" cmdB
|
||||||
|
|
||||||
infixr 0 #!||
|
infixr 0 #!||
|
||||||
|
|
||||||
(#!>>) :: String -> String -> String
|
(#!>>) :: T.Text -> T.Text -> T.Text
|
||||||
cmdA #!>> cmdB = cmdA ++ "; " ++ cmdB
|
cmdA #!>> cmdB = op cmdA ";" cmdB
|
||||||
|
|
||||||
infixr 0 #!>>
|
infixr 0 #!>>
|
||||||
|
|
||||||
doubleQuote :: String -> String
|
doubleQuote :: T.Text -> T.Text
|
||||||
doubleQuote s = "\"" ++ s ++ "\""
|
doubleQuote s = T.concat ["\"", s, "\""]
|
||||||
|
|
||||||
singleQuote :: String -> String
|
singleQuote :: T.Text -> T.Text
|
||||||
singleQuote s = "'" ++ s ++ "'"
|
singleQuote s = T.concat ["'", s, "'"]
|
||||||
|
|
||||||
skip :: Monad m => m ()
|
skip :: Monad m => m ()
|
||||||
skip = return ()
|
skip = return ()
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Theme for XMonad and Xmobar
|
-- | Theme for XMonad and Xmobar
|
||||||
|
|
||||||
|
|
@ -28,10 +30,10 @@ module XMonad.Internal.Theme
|
||||||
, promptTheme
|
, promptTheme
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Char
|
|
||||||
import Data.Colour
|
import Data.Colour
|
||||||
import Data.Colour.SRGB
|
import Data.Colour.SRGB
|
||||||
import Data.List
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import qualified XMonad.Layout.Decoration as D
|
import qualified XMonad.Layout.Decoration as D
|
||||||
import qualified XMonad.Prompt as P
|
import qualified XMonad.Prompt as P
|
||||||
|
|
@ -39,50 +41,56 @@ import qualified XMonad.Prompt as P
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Colors - vocabulary roughly based on GTK themes
|
-- | Colors - vocabulary roughly based on GTK themes
|
||||||
|
|
||||||
baseColor :: String
|
baseColor :: T.Text
|
||||||
baseColor = "#f7f7f7"
|
baseColor = "#f7f7f7"
|
||||||
|
|
||||||
bgColor :: String
|
bgColor :: T.Text
|
||||||
bgColor = "#d6d6d6"
|
bgColor = "#d6d6d6"
|
||||||
|
|
||||||
fgColor :: String
|
fgColor :: T.Text
|
||||||
fgColor = "#2c2c2c"
|
fgColor = "#2c2c2c"
|
||||||
|
|
||||||
bordersColor :: String
|
bordersColor :: T.Text
|
||||||
bordersColor = darken' 0.3 bgColor
|
bordersColor = darken' 0.3 bgColor
|
||||||
|
|
||||||
warningColor :: String
|
warningColor :: T.Text
|
||||||
warningColor = "#ffca28"
|
warningColor = "#ffca28"
|
||||||
|
|
||||||
errorColor :: String
|
errorColor :: T.Text
|
||||||
errorColor = "#e53935"
|
errorColor = "#e53935"
|
||||||
|
|
||||||
selectedFgColor :: String
|
selectedFgColor :: T.Text
|
||||||
selectedFgColor = "#ffffff"
|
selectedFgColor = "#ffffff"
|
||||||
|
|
||||||
selectedBgColor :: String
|
selectedBgColor :: T.Text
|
||||||
selectedBgColor = "#4a79c7"
|
selectedBgColor = "#4a79c7"
|
||||||
|
|
||||||
selectedBordersColor :: String
|
selectedBordersColor :: T.Text
|
||||||
selectedBordersColor = "#4a79c7"
|
selectedBordersColor = "#4a79c7"
|
||||||
|
|
||||||
backdropBaseColor :: String
|
backdropBaseColor :: T.Text
|
||||||
backdropBaseColor = baseColor
|
backdropBaseColor = baseColor
|
||||||
|
|
||||||
backdropTextColor :: String
|
backdropTextColor :: T.Text
|
||||||
backdropTextColor = blend' 0.95 fgColor backdropBaseColor
|
backdropTextColor = blend' 0.95 fgColor backdropBaseColor
|
||||||
|
|
||||||
backdropFgColor :: String
|
backdropFgColor :: T.Text
|
||||||
backdropFgColor = blend' 0.75 fgColor bgColor
|
backdropFgColor = blend' 0.75 fgColor bgColor
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Color functions
|
-- | Color functions
|
||||||
|
|
||||||
blend' :: Float -> String -> String -> String
|
blend' :: Float -> T.Text -> T.Text -> T.Text
|
||||||
blend' wt c0 c1 = sRGB24show $ blend wt (sRGB24read c0) (sRGB24read c1)
|
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
|
||||||
|
|
||||||
darken' :: Float -> String -> String
|
darken' :: Float -> T.Text -> T.Text
|
||||||
darken' wt = sRGB24show . darken wt . sRGB24read
|
darken' wt = sRGB24showT . darken wt . sRGB24readT
|
||||||
|
|
||||||
|
sRGB24readT :: (RealFrac a, Floating a) => T.Text -> Colour a
|
||||||
|
sRGB24readT = sRGB24read . T.unpack
|
||||||
|
|
||||||
|
sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
|
||||||
|
sRGB24showT = T.pack . sRGB24show
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Fonts
|
-- | Fonts
|
||||||
|
|
@ -107,9 +115,9 @@ data FontData = FontData
|
||||||
, antialias :: Maybe Bool
|
, antialias :: Maybe Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
type FontBuilder = FontData -> String
|
type FontBuilder = FontData -> T.Text
|
||||||
|
|
||||||
buildFont :: Maybe String -> FontData -> String
|
buildFont :: Maybe T.Text -> FontData -> T.Text
|
||||||
buildFont Nothing _ = "fixed"
|
buildFont Nothing _ = "fixed"
|
||||||
buildFont (Just fam) FontData { weight = w
|
buildFont (Just fam) FontData { weight = w
|
||||||
, slant = l
|
, slant = l
|
||||||
|
|
@ -117,17 +125,17 @@ buildFont (Just fam) FontData { weight = w
|
||||||
, pixelsize = p
|
, pixelsize = p
|
||||||
, antialias = a
|
, antialias = a
|
||||||
}
|
}
|
||||||
= intercalate ":" $ ["xft", fam] ++ elems
|
= T.intercalate ":" $ ["xft", fam] ++ elems
|
||||||
where
|
where
|
||||||
elems = [ k ++ "=" ++ v | (k, Just v) <- [ ("weight", showLower w)
|
elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w)
|
||||||
, ("slant", showLower l)
|
, ("slant", showLower l)
|
||||||
, ("size", showLower s)
|
, ("size", showLower s)
|
||||||
, ("pixelsize", showLower p)
|
, ("pixelsize", showLower p)
|
||||||
, ("antialias", showLower a)
|
, ("antialias", showLower a)
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
showLower :: Show a => Maybe a -> Maybe String
|
showLower :: Show a => Maybe a -> Maybe T.Text
|
||||||
showLower = fmap (fmap toLower . show)
|
showLower = fmap (T.toLower . T.pack . show)
|
||||||
|
|
||||||
fallbackFont :: FontBuilder
|
fallbackFont :: FontBuilder
|
||||||
fallbackFont = buildFont Nothing
|
fallbackFont = buildFont Nothing
|
||||||
|
|
@ -144,7 +152,7 @@ defFontData = FontData
|
||||||
, pixelsize = Nothing
|
, pixelsize = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
defFontFamily :: String
|
defFontFamily :: T.Text
|
||||||
defFontFamily = "DejaVu Sans"
|
defFontFamily = "DejaVu Sans"
|
||||||
|
|
||||||
-- defFontDep :: IODependency FontBuilder
|
-- defFontDep :: IODependency FontBuilder
|
||||||
|
|
@ -158,19 +166,19 @@ defFontFamily = "DejaVu Sans"
|
||||||
|
|
||||||
tabbedTheme :: FontBuilder -> D.Theme
|
tabbedTheme :: FontBuilder -> D.Theme
|
||||||
tabbedTheme fb = D.def
|
tabbedTheme fb = D.def
|
||||||
{ D.fontName = fb $ defFontData { weight = Just Bold }
|
{ D.fontName = T.unpack $ fb $ defFontData { weight = Just Bold }
|
||||||
|
|
||||||
, D.activeTextColor = fgColor
|
, D.activeTextColor = T.unpack fgColor
|
||||||
, D.activeColor = bgColor
|
, D.activeColor = T.unpack bgColor
|
||||||
, D.activeBorderColor = bgColor
|
, D.activeBorderColor = T.unpack bgColor
|
||||||
|
|
||||||
, D.inactiveTextColor = backdropTextColor
|
, D.inactiveTextColor = T.unpack backdropTextColor
|
||||||
, D.inactiveColor = backdropFgColor
|
, D.inactiveColor = T.unpack backdropFgColor
|
||||||
, D.inactiveBorderColor = backdropFgColor
|
, D.inactiveBorderColor = T.unpack backdropFgColor
|
||||||
|
|
||||||
, D.urgentTextColor = darken' 0.5 errorColor
|
, D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
|
||||||
, D.urgentColor = errorColor
|
, D.urgentColor = T.unpack errorColor
|
||||||
, D.urgentBorderColor = errorColor
|
, D.urgentBorderColor = T.unpack errorColor
|
||||||
|
|
||||||
-- this is in a newer version
|
-- this is in a newer version
|
||||||
-- , D.activeBorderWidth = 0
|
-- , D.activeBorderWidth = 0
|
||||||
|
|
@ -184,12 +192,12 @@ tabbedTheme fb = D.def
|
||||||
|
|
||||||
promptTheme :: FontBuilder -> P.XPConfig
|
promptTheme :: FontBuilder -> P.XPConfig
|
||||||
promptTheme fb = P.def
|
promptTheme fb = P.def
|
||||||
{ P.font = fb $ defFontData { size = Just 12 }
|
{ P.font = T.unpack $ fb $ defFontData { size = Just 12 }
|
||||||
, P.bgColor = bgColor
|
, P.bgColor = T.unpack bgColor
|
||||||
, P.fgColor = fgColor
|
, P.fgColor = T.unpack fgColor
|
||||||
, P.fgHLight = selectedFgColor
|
, P.fgHLight = T.unpack selectedFgColor
|
||||||
, P.bgHLight = selectedBgColor
|
, P.bgHLight = T.unpack selectedBgColor
|
||||||
, P.borderColor = bordersColor
|
, P.borderColor = T.unpack bordersColor
|
||||||
, P.promptBorderWidth = 1
|
, P.promptBorderWidth = 1
|
||||||
, P.height = 35
|
, P.height = 35
|
||||||
, P.position = P.CenteredAt 0.5 0.5
|
, P.position = P.CenteredAt 0.5 0.5
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Common backlight plugin bits
|
-- | Common backlight plugin bits
|
||||||
--
|
--
|
||||||
|
|
@ -8,14 +10,16 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
|
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
|
||||||
-> (SesClient -> IO (Maybe a)) -> String -> Callback -> IO ()
|
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
|
||||||
startBacklight matchSignal callGetBrightness icon cb = do
|
startBacklight matchSignal callGetBrightness icon cb = do
|
||||||
withDBusClientConnection cb $ \c -> do
|
withDBusClientConnection cb $ \c -> do
|
||||||
matchSignal display c
|
matchSignal display c
|
||||||
display =<< callGetBrightness c
|
display =<< callGetBrightness c
|
||||||
where
|
where
|
||||||
formatBrightness b = return $ icon ++ show (round b :: Integer) ++ "%"
|
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
|
||||||
display = displayMaybe cb formatBrightness
|
display = displayMaybe cb formatBrightness
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Bluetooth plugin
|
-- | Bluetooth plugin
|
||||||
--
|
--
|
||||||
|
|
@ -49,11 +51,13 @@ import Data.Maybe
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
btAlias :: String
|
btAlias :: T.Text
|
||||||
btAlias = "bluetooth"
|
btAlias = "bluetooth"
|
||||||
|
|
||||||
btDep :: DBusDependency_ SysClient
|
btDep :: DBusDependency_ SysClient
|
||||||
|
|
@ -63,7 +67,7 @@ btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
|
||||||
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||||
|
|
||||||
instance Exec Bluetooth where
|
instance Exec Bluetooth where
|
||||||
alias (Bluetooth _ _) = btAlias
|
alias (Bluetooth _ _) = T.unpack btAlias
|
||||||
start (Bluetooth icons colors) cb =
|
start (Bluetooth icons colors) cb =
|
||||||
withDBusClientConnection cb $ startAdapter icons colors cb
|
withDBusClientConnection cb $ startAdapter icons colors cb
|
||||||
|
|
||||||
|
|
@ -91,13 +95,13 @@ startAdapter is cs cb cl = do
|
||||||
-- Color corresponds to the adaptor powered state, and the icon corresponds to
|
-- Color corresponds to the adaptor powered state, and the icon corresponds to
|
||||||
-- if it is paired or not. If the adaptor state is undefined, display "N/A"
|
-- if it is paired or not. If the adaptor state is undefined, display "N/A"
|
||||||
|
|
||||||
type IconFormatter = (Maybe Bool -> Bool -> String)
|
type IconFormatter = (Maybe Bool -> Bool -> T.Text)
|
||||||
|
|
||||||
type Icons = (String, String)
|
type Icons = (T.Text, T.Text)
|
||||||
|
|
||||||
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
|
displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
|
||||||
displayIcon callback formatter =
|
displayIcon callback formatter =
|
||||||
callback . uncurry formatter <=< readState
|
callback . T.unpack . uncurry formatter <=< readState
|
||||||
|
|
||||||
-- TODO maybe I want this to fail when any of the device statuses are Nothing
|
-- TODO maybe I want this to fail when any of the device statuses are Nothing
|
||||||
iconFormatter :: Icons -> Colors -> IconFormatter
|
iconFormatter :: Icons -> Colors -> IconFormatter
|
||||||
|
|
@ -154,8 +158,8 @@ adaptorHasDevice adaptor device = case splitPath device of
|
||||||
[org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
|
[org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
splitPath :: ObjectPath -> [String]
|
splitPath :: ObjectPath -> [T.Text]
|
||||||
splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
|
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
|
||||||
|
|
||||||
getBtObjectTree :: SysClient -> IO ObjectTree
|
getBtObjectTree :: SysClient -> IO ObjectTree
|
||||||
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
||||||
|
|
@ -207,7 +211,7 @@ addAdaptorListener state display adaptor sys = do
|
||||||
|
|
||||||
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
|
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
|
||||||
$ memberName_ adaptorPowered
|
$ memberName_ $ T.unpack adaptorPowered
|
||||||
|
|
||||||
matchPowered :: [Variant] -> SignalMatch Bool
|
matchPowered :: [Variant] -> SignalMatch Bool
|
||||||
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
||||||
|
|
@ -221,7 +225,7 @@ readPowered = fmap btPowered . readMVar
|
||||||
adapterInterface :: InterfaceName
|
adapterInterface :: InterfaceName
|
||||||
adapterInterface = interfaceName_ "org.bluez.Adapter1"
|
adapterInterface = interfaceName_ "org.bluez.Adapter1"
|
||||||
|
|
||||||
adaptorPowered :: String
|
adaptorPowered :: T.Text
|
||||||
adaptorPowered = "Powered"
|
adaptorPowered = "Powered"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
@ -253,7 +257,8 @@ matchConnected :: [Variant] -> SignalMatch Bool
|
||||||
matchConnected = matchPropertyChanged devInterface devConnected
|
matchConnected = matchPropertyChanged devInterface devConnected
|
||||||
|
|
||||||
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
callGetConnected p = callPropertyGet btBus p devInterface $ memberName_ devConnected
|
callGetConnected p = callPropertyGet btBus p devInterface
|
||||||
|
$ memberName_ (T.unpack devConnected)
|
||||||
|
|
||||||
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
||||||
insertDevice m device dev = modifyMVar m $ \s -> do
|
insertDevice m device dev = modifyMVar m $ \s -> do
|
||||||
|
|
@ -279,5 +284,5 @@ readDevices = fmap btDevices . readMVar
|
||||||
devInterface :: InterfaceName
|
devInterface :: InterfaceName
|
||||||
devInterface = interfaceName_ "org.bluez.Device1"
|
devInterface = interfaceName_ "org.bluez.Device1"
|
||||||
|
|
||||||
devConnected :: String
|
devConnected :: T.Text
|
||||||
devConnected = "Connected"
|
devConnected = "Connected"
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Clevo Keyboard plugin
|
-- | Clevo Keyboard plugin
|
||||||
--
|
--
|
||||||
|
|
@ -9,18 +11,20 @@ module Xmobar.Plugins.ClevoKeyboard
|
||||||
, ckAlias
|
, ckAlias
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
|
||||||
import Xmobar.Plugins.BacklightCommon
|
import Xmobar.Plugins.BacklightCommon
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
|
|
||||||
newtype ClevoKeyboard = ClevoKeyboard String deriving (Read, Show)
|
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
|
||||||
|
|
||||||
ckAlias :: String
|
ckAlias :: T.Text
|
||||||
ckAlias = "clevokeyboard"
|
ckAlias = "clevokeyboard"
|
||||||
|
|
||||||
instance Exec ClevoKeyboard where
|
instance Exec ClevoKeyboard where
|
||||||
alias (ClevoKeyboard _) = ckAlias
|
alias (ClevoKeyboard _) = T.unpack ckAlias
|
||||||
start (ClevoKeyboard icon) =
|
start (ClevoKeyboard icon) =
|
||||||
startBacklight matchSignalCK callGetBrightnessCK icon
|
startBacklight matchSignalCK callGetBrightnessCK icon
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Xmobar.Plugins.Common
|
module Xmobar.Plugins.Common
|
||||||
( colorText
|
( colorText
|
||||||
, startListener
|
, startListener
|
||||||
|
|
@ -20,18 +22,21 @@ import Data.Internal.DBus
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||||
|
|
||||||
|
-- use string here since all the callbacks in xmobar use strings :(
|
||||||
type Callback = String -> IO ()
|
type Callback = String -> IO ()
|
||||||
|
|
||||||
data Colors = Colors
|
data Colors = Colors
|
||||||
{ colorsOn :: String
|
{ colorsOn :: T.Text
|
||||||
, colorsOff :: String
|
, colorsOff :: T.Text
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read)
|
deriving (Eq, Show, Read)
|
||||||
|
|
||||||
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
|
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
|
||||||
-> ([Variant] -> SignalMatch a) -> (a -> IO String) -> Callback
|
-> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
|
||||||
-> c -> IO ()
|
-> c -> IO ()
|
||||||
startListener rule getProp fromSignal toColor cb client = do
|
startListener rule getProp fromSignal toColor cb client = do
|
||||||
reply <- getProp client
|
reply <- getProp client
|
||||||
|
|
@ -40,24 +45,24 @@ startListener rule getProp fromSignal toColor cb client = do
|
||||||
where
|
where
|
||||||
procMatch = procSignalMatch cb toColor
|
procMatch = procSignalMatch cb toColor
|
||||||
|
|
||||||
procSignalMatch :: Callback -> (a -> IO String) -> SignalMatch a -> IO ()
|
procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
|
||||||
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
|
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
|
||||||
|
|
||||||
colorText :: Colors -> Bool -> String -> String
|
colorText :: Colors -> Bool -> T.Text -> T.Text
|
||||||
colorText Colors { colorsOn = c } True = xmobarFGColor c
|
colorText Colors { colorsOn = c } True = xmobarFGColor c
|
||||||
colorText Colors { colorsOff = c } False = xmobarFGColor c
|
colorText Colors { colorsOff = c } False = xmobarFGColor c
|
||||||
|
|
||||||
xmobarFGColor :: String -> String -> String
|
xmobarFGColor :: T.Text -> T.Text -> T.Text
|
||||||
xmobarFGColor c = xmobarColor c ""
|
xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
|
||||||
|
|
||||||
na :: String
|
na :: T.Text
|
||||||
na = "N/A"
|
na = "N/A"
|
||||||
|
|
||||||
displayMaybe :: Callback -> (a -> IO String) -> Maybe a -> IO ()
|
displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
|
||||||
displayMaybe cb f = cb <=< maybe (return na) f
|
displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
|
||||||
|
|
||||||
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
|
displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
|
||||||
displayMaybe' cb = maybe (cb na)
|
displayMaybe' cb = maybe (cb $ T.unpack na)
|
||||||
|
|
||||||
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
|
withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
|
||||||
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
|
withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Device plugin
|
-- | Device plugin
|
||||||
--
|
--
|
||||||
|
|
@ -17,12 +19,14 @@ import Data.Word
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
newtype Device = Device (String, String, Colors) deriving (Read, Show)
|
newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
|
||||||
|
|
||||||
nmPath :: ObjectPath
|
nmPath :: ObjectPath
|
||||||
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
||||||
|
|
@ -36,14 +40,14 @@ nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
|
||||||
getByIP :: MemberName
|
getByIP :: MemberName
|
||||||
getByIP = memberName_ "GetDeviceByIpIface"
|
getByIP = memberName_ "GetDeviceByIpIface"
|
||||||
|
|
||||||
devSignal :: String
|
devSignal :: T.Text
|
||||||
devSignal = "Ip4Connectivity"
|
devSignal = "Ip4Connectivity"
|
||||||
|
|
||||||
devDep :: DBusDependency_ SysClient
|
devDep :: DBusDependency_ SysClient
|
||||||
devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
|
devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
|
||||||
$ Method_ getByIP
|
$ Method_ getByIP
|
||||||
|
|
||||||
getDevice :: SysClient -> String -> IO (Maybe ObjectPath)
|
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
|
||||||
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
||||||
where
|
where
|
||||||
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
||||||
|
|
@ -52,13 +56,13 @@ getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
||||||
|
|
||||||
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
|
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
|
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
|
||||||
$ memberName_ devSignal
|
$ memberName_ $ T.unpack devSignal
|
||||||
|
|
||||||
matchStatus :: [Variant] -> SignalMatch Word32
|
matchStatus :: [Variant] -> SignalMatch Word32
|
||||||
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
||||||
|
|
||||||
instance Exec Device where
|
instance Exec Device where
|
||||||
alias (Device (iface, _, _)) = iface
|
alias (Device (iface, _, _)) = T.unpack iface
|
||||||
start (Device (iface, text, colors)) cb = do
|
start (Device (iface, text, colors)) cb = do
|
||||||
withDBusClientConnection cb $ \sys -> do
|
withDBusClientConnection cb $ \sys -> do
|
||||||
path <- getDevice sys iface
|
path <- getDevice sys iface
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Intel backlight plugin
|
-- | Intel backlight plugin
|
||||||
--
|
--
|
||||||
|
|
@ -9,18 +11,20 @@ module Xmobar.Plugins.IntelBacklight
|
||||||
, blAlias
|
, blAlias
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
|
||||||
import Xmobar.Plugins.BacklightCommon
|
import Xmobar.Plugins.BacklightCommon
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
|
|
||||||
newtype IntelBacklight = IntelBacklight String deriving (Read, Show)
|
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
|
||||||
|
|
||||||
blAlias :: String
|
blAlias :: T.Text
|
||||||
blAlias = "intelbacklight"
|
blAlias = "intelbacklight"
|
||||||
|
|
||||||
instance Exec IntelBacklight where
|
instance Exec IntelBacklight where
|
||||||
alias (IntelBacklight _) = blAlias
|
alias (IntelBacklight _) = T.unpack blAlias
|
||||||
start (IntelBacklight icon) =
|
start (IntelBacklight icon) =
|
||||||
startBacklight matchSignalIB callGetBrightnessIB icon
|
startBacklight matchSignalIB callGetBrightnessIB icon
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Screensaver plugin
|
-- | Screensaver plugin
|
||||||
--
|
--
|
||||||
|
|
@ -9,18 +11,20 @@ module Xmobar.Plugins.Screensaver
|
||||||
, ssAlias
|
, ssAlias
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Screensaver
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
newtype Screensaver = Screensaver (String, Colors) deriving (Read, Show)
|
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
|
||||||
|
|
||||||
ssAlias :: String
|
ssAlias :: T.Text
|
||||||
ssAlias = "screensaver"
|
ssAlias = "screensaver"
|
||||||
|
|
||||||
instance Exec Screensaver where
|
instance Exec Screensaver where
|
||||||
alias (Screensaver _) = ssAlias
|
alias (Screensaver _) = T.unpack ssAlias
|
||||||
start (Screensaver (text, colors)) cb = do
|
start (Screensaver (text, colors)) cb = do
|
||||||
withDBusClientConnection cb $ \sys -> do
|
withDBusClientConnection cb $ \sys -> do
|
||||||
matchSignal display sys
|
matchSignal display sys
|
||||||
|
|
|
||||||
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VPN plugin
|
-- | VPN plugin
|
||||||
--
|
--
|
||||||
|
|
@ -22,15 +24,17 @@ import qualified Data.Set as S
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
newtype VPN = VPN (String, Colors) deriving (Read, Show)
|
newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
|
||||||
|
|
||||||
instance Exec VPN where
|
instance Exec VPN where
|
||||||
alias (VPN _) = vpnAlias
|
alias (VPN _) = T.unpack vpnAlias
|
||||||
start (VPN (text, colors)) cb =
|
start (VPN (text, colors)) cb =
|
||||||
withDBusClientConnection cb $ \c -> do
|
withDBusClientConnection cb $ \c -> do
|
||||||
state <- initState c
|
state <- initState c
|
||||||
|
|
@ -84,7 +88,7 @@ vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
|
||||||
addedCallback :: MutableVPNState -> IO () -> SignalCallback
|
addedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||||
addedCallback state display [device, added] = update >> display
|
addedCallback state display [device, added] = update >> display
|
||||||
where
|
where
|
||||||
added' = fromVariant added :: Maybe (M.Map String (M.Map String Variant))
|
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
||||||
is = M.keys $ fromMaybe M.empty added'
|
is = M.keys $ fromMaybe M.empty added'
|
||||||
update = updateDevice S.insert state device is
|
update = updateDevice S.insert state device is
|
||||||
addedCallback _ _ _ = return ()
|
addedCallback _ _ _ = return ()
|
||||||
|
|
@ -92,12 +96,12 @@ addedCallback _ _ _ = return ()
|
||||||
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||||
removedCallback state display [device, interfaces] = update >> display
|
removedCallback state display [device, interfaces] = update >> display
|
||||||
where
|
where
|
||||||
is = fromMaybe [] $ fromVariant interfaces :: [String]
|
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
|
||||||
update = updateDevice S.delete state device is
|
update = updateDevice S.delete state device is
|
||||||
removedCallback _ _ _ = return ()
|
removedCallback _ _ _ = return ()
|
||||||
|
|
||||||
updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
||||||
-> Variant -> [String] -> IO ()
|
-> Variant -> [T.Text] -> IO ()
|
||||||
updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
|
updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
|
||||||
forM_ d $ updateState f state
|
forM_ d $ updateState f state
|
||||||
where
|
where
|
||||||
|
|
@ -113,10 +117,10 @@ vpnBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
vpnPath :: ObjectPath
|
vpnPath :: ObjectPath
|
||||||
vpnPath = objectPath_ "/org/freedesktop"
|
vpnPath = objectPath_ "/org/freedesktop"
|
||||||
|
|
||||||
vpnDeviceTun :: String
|
vpnDeviceTun :: T.Text
|
||||||
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
||||||
|
|
||||||
vpnAlias :: String
|
vpnAlias :: T.Text
|
||||||
vpnAlias = "vpn"
|
vpnAlias = "vpn"
|
||||||
|
|
||||||
vpnDep :: DBusDependency_ SysClient
|
vpnDep :: DBusDependency_ SysClient
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue