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