From e76ace03adf897294575f1f40cc24ef4f84fb89c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 26 Dec 2022 14:45:49 -0500 Subject: [PATCH] REF use RIO text pretty much everywhere --- bin/vbox-start.hs | 4 +- bin/xmobar.hs | 149 ++++++++------- bin/xmonad.hs | 70 +++---- lib/Data/Internal/DBus.hs | 16 +- lib/Data/Internal/Dependency.hs | 179 +++++++++--------- lib/XMonad/Internal/Command/DMenu.hs | 34 ++-- lib/XMonad/Internal/Command/Desktop.hs | 62 +++--- lib/XMonad/Internal/Command/Power.hs | 43 +++-- lib/XMonad/Internal/Concurrent/VirtualBox.hs | 14 +- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 2 + lib/XMonad/Internal/DBus/Brightness/Common.hs | 12 +- .../DBus/Brightness/IntelBacklight.hs | 2 + lib/XMonad/Internal/DBus/Removable.hs | 2 + lib/XMonad/Internal/DBus/Screensaver.hs | 2 + lib/XMonad/Internal/Notify.hs | 17 +- lib/XMonad/Internal/Shell.hs | 39 ++-- lib/XMonad/Internal/Theme.hs | 100 +++++----- lib/Xmobar/Plugins/BacklightCommon.hs | 8 +- lib/Xmobar/Plugins/Bluetooth.hs | 27 +-- lib/Xmobar/Plugins/ClevoKeyboard.hs | 10 +- lib/Xmobar/Plugins/Common.hs | 27 +-- lib/Xmobar/Plugins/Device.hs | 14 +- lib/Xmobar/Plugins/IntelBacklight.hs | 10 +- lib/Xmobar/Plugins/Screensaver.hs | 10 +- lib/Xmobar/Plugins/VPN.hs | 18 +- 25 files changed, 489 insertions(+), 382 deletions(-) diff --git a/bin/vbox-start.hs b/bin/vbox-start.hs index cdd2b88..fd09d35 100644 --- a/bin/vbox-start.hs +++ b/bin/vbox-start.hs @@ -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 diff --git a/bin/xmobar.hs b/bin/xmobar.hs index b269565..5c858dc 100644 --- a/bin/xmobar.hs +++ b/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 - [ "-t", "" - , "--" - , "--quality-icon-pattern", "" - ] 5 + { csAlias = T.append iface "wi" + , csRunnable = Run $ Wireless (T.unpack iface) args 5 } + where + args = fmap T.unpack + [ "-t", "" + , "--" + , "--quality-icon-pattern", "" + ] -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 - [ "--template", "" - , "--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 + , csRunnable = Run $ Battery args 50 } where fontify' = fontify IconSmall + args = fmap T.unpack + [ "--template", "" + , "--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 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", "%" , "--" , "-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 ["", txt, ""] +fontifyText :: BarFont -> T.Text -> T.Text +fontifyText fnt txt = + T.concat ["", txt, ""] -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] diff --git a/bin/xmonad.hs b/bin/xmonad.hs index f4fa328..b967584 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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) diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index bfdb0e0..0bfe459 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -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" diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 40b062a..b6bce7b 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -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, "]"] diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index e8b2179..bad578e 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -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"] diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 42f3d5a..c9c691e 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index b25223a..6e27a57 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -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) diff --git a/lib/XMonad/Internal/Concurrent/VirtualBox.hs b/lib/XMonad/Internal/Concurrent/VirtualBox.hs index a41c244..79b6a58 100644 --- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs +++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 46717c1..af1d1c2 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -------------------------------------------------------------------------------- -- | DBus module for Clevo Keyboard control diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 91c9593..7e43837 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index e7db071..b5c59e1 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -------------------------------------------------------------------------------- -- | DBus module for Intel Backlight control diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index bf78ea3..f909346 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -------------------------------------------------------------------------------- -- | Module for monitoring removable drive events -- diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index d77bab4..83463f2 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -------------------------------------------------------------------------------- -- | DBus module for X11 screensave/DPMS control diff --git a/lib/XMonad/Internal/Notify.hs b/lib/XMonad/Internal/Notify.hs index 7e0bd2a..91c1c61 100644 --- a/lib/XMonad/Internal/Notify.hs +++ b/lib/XMonad/Internal/Notify.hs @@ -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' diff --git a/lib/XMonad/Internal/Shell.hs b/lib/XMonad/Internal/Shell.hs index 4c09b18..9f3bc5b 100644 --- a/lib/XMonad/Internal/Shell.hs +++ b/lib/XMonad/Internal/Shell.hs @@ -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 () diff --git a/lib/XMonad/Internal/Theme.hs b/lib/XMonad/Internal/Theme.hs index 377142b..165b75a 100644 --- a/lib/XMonad/Internal/Theme.hs +++ b/lib/XMonad/Internal/Theme.hs @@ -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) - , ("slant", showLower l) - , ("size", showLower s) - , ("pixelsize", showLower p) - , ("antialias", showLower a) - ] + 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 diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 71a9991..b8f9f7f 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 8f073f1..9a9dbd9 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -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" diff --git a/lib/Xmobar/Plugins/ClevoKeyboard.hs b/lib/Xmobar/Plugins/ClevoKeyboard.hs index 58d3123..92a8f12 100644 --- a/lib/Xmobar/Plugins/ClevoKeyboard.hs +++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index 8aa99e9..d28ee2b 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 284c09a..13abdb0 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -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 diff --git a/lib/Xmobar/Plugins/IntelBacklight.hs b/lib/Xmobar/Plugins/IntelBacklight.hs index 48814c9..e60a0fd 100644 --- a/lib/Xmobar/Plugins/IntelBacklight.hs +++ b/lib/Xmobar/Plugins/IntelBacklight.hs @@ -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 diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index 454a1db..ef125cb 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -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 diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 46f2cbf..625abf8 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -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