From adf0257533a750b91e6e7076fa6228f030b4a777 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 30 Dec 2022 14:58:23 -0500 Subject: [PATCH] REF reformat everything with fourmolu --- bin/vbox-start.hs | 46 +- bin/xmobar.hs | 562 ++++++----- bin/xmonad.hs | 887 ++++++++++-------- fourmolu.yaml | 4 +- lib/Data/Internal/DBus.hs | 193 ++-- lib/Data/Internal/Dependency.hs | 691 ++++++++------ lib/XMonad/Internal/Command/DMenu.hs | 170 ++-- lib/XMonad/Internal/Command/Desktop.hs | 216 +++-- lib/XMonad/Internal/Command/Power.hs | 148 +-- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 71 +- .../Internal/Concurrent/ClientMessage.hs | 46 +- .../Internal/Concurrent/DynamicWorkspaces.hs | 179 ++-- lib/XMonad/Internal/Concurrent/VirtualBox.hs | 40 +- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 66 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 197 ++-- .../DBus/Brightness/IntelBacklight.hs | 63 +- lib/XMonad/Internal/DBus/Common.hs | 8 +- lib/XMonad/Internal/DBus/Control.hs | 48 +- lib/XMonad/Internal/DBus/Removable.hs | 50 +- lib/XMonad/Internal/DBus/Screensaver.hs | 118 ++- lib/XMonad/Internal/IO.hs | 61 +- lib/XMonad/Internal/Notify.hs | 45 +- lib/XMonad/Internal/Process.hs | 17 - lib/XMonad/Internal/Shell.hs | 17 +- lib/XMonad/Internal/Theme.hs | 188 ++-- lib/Xmobar/Plugins/BacklightCommon.hs | 33 +- lib/Xmobar/Plugins/Bluetooth.hs | 112 ++- lib/Xmobar/Plugins/ClevoKeyboard.hs | 20 +- lib/Xmobar/Plugins/Common.hs | 38 +- lib/Xmobar/Plugins/Device.hs | 49 +- lib/Xmobar/Plugins/IntelBacklight.hs | 20 +- lib/Xmobar/Plugins/Screensaver.hs | 18 +- lib/Xmobar/Plugins/VPN.hs | 87 +- package.yaml | 2 +- 34 files changed, 2472 insertions(+), 2038 deletions(-) delete mode 100644 lib/XMonad/Internal/Process.hs diff --git a/bin/vbox-start.hs b/bin/vbox-start.hs index cb82926..c918f38 100644 --- a/bin/vbox-start.hs +++ b/bin/vbox-start.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------------------------------- -- | Start a VirtualBox instance with a sentinel wrapper process. -- -- The only reason why this is needed is because I want to manage virtualboxes @@ -15,21 +14,16 @@ -- until its PID exits. By monitoring this wrapper, the dynamic workspace only -- has one process to track and will maintain the workspace throughout the -- lifetime of the VM. - module Main (main) where -import qualified Data.ByteString.Lazy.UTF8 as BU - -import RIO -import RIO.Process -import qualified RIO.Text as T - -import Text.XML.Light - -import System.Environment - -import XMonad.Internal.Concurrent.VirtualBox -import XMonad.Internal.IO +import qualified Data.ByteString.Lazy.UTF8 as BU +import RIO +import RIO.Process +import qualified RIO.Text as T +import System.Environment +import Text.XML.Light +import XMonad.Internal.Concurrent.VirtualBox +import XMonad.Internal.IO main :: IO () main = do @@ -48,7 +42,6 @@ runAndWait [n] = do p <- vmPID i liftIO $ mapM_ waitUntilExit p err = logError "Could not get machine ID" - runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME" vmLaunch :: T.Text -> RIO SimpleApp () @@ -56,25 +49,28 @@ vmLaunch i = do rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess case rc of ExitSuccess -> return () - _ -> logError $ "Failed to start VM: " - <> displayBytesUtf8 (encodeUtf8 i) + _ -> + logError $ + "Failed to start VM: " + <> displayBytesUtf8 (encodeUtf8 i) vmPID :: T.Text -> RIO SimpleApp (Maybe Int) vmPID vid = do (rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout return $ case rc of ExitSuccess -> readMaybe $ BU.toString out - _ -> Nothing + _ -> Nothing vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text) vmMachineID iPath = do res <- tryAny $ readFileUtf8 iPath case res of Right contents -> return $ findMachineID contents - Left e -> logError (displayShow e) >> return Nothing + Left e -> logError (displayShow e) >> return Nothing where - findMachineID c = T.stripSuffix "}" - =<< T.stripPrefix "{" - =<< (fmap T.pack . findAttr (blank_name { qName = "uuid" })) - =<< (\e -> findChild (qual e "Machine") e) - =<< parseXMLDoc c + findMachineID c = + T.stripSuffix "}" + =<< T.stripPrefix "{" + =<< (fmap T.pack . findAttr (blank_name {qName = "uuid"})) + =<< (\e -> findChild (qual e "Machine") e) + =<< parseXMLDoc c diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 4a56132..f2621a5 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -1,8 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Main (main) where - --------------------------------------------------------------------------------- -- | Xmobar binary -- -- Features: @@ -12,52 +9,47 @@ module Main (main) where -- * Some custom plugins (imported below) -- * Theme integration with xmonad (shared module imported below) -- * A custom Locks plugin from my own forked repo +module Main (main) where -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency -import Data.List -import Data.Maybe - -import RIO hiding (hFlush) -import qualified RIO.ByteString.Lazy as BL -import RIO.Process -import qualified RIO.Text as T - -import System.Environment -import System.IO - -import Xmobar.Plugins.Bluetooth -import Xmobar.Plugins.ClevoKeyboard -import Xmobar.Plugins.Device -import Xmobar.Plugins.IntelBacklight -import Xmobar.Plugins.Screensaver -import Xmobar.Plugins.VPN - -import XMonad.Core hiding (config) -import XMonad.Internal.Command.Desktop -import XMonad.Internal.Command.Power -import XMonad.Internal.DBus.Brightness.ClevoKeyboard -import XMonad.Internal.DBus.Brightness.IntelBacklight -import XMonad.Internal.DBus.Control -import XMonad.Internal.DBus.Screensaver (ssSignalDep) -import qualified XMonad.Internal.Theme as XT -import Xmobar hiding - ( iconOffset - , run - ) -import Xmobar.Plugins.Common - +import Control.Monad +import Data.Internal.DBus +import Data.Internal.Dependency +import Data.List +import Data.Maybe +import RIO hiding (hFlush) +import qualified RIO.ByteString.Lazy as BL +import RIO.Process +import qualified RIO.Text as T +import System.Environment +import System.IO +import XMonad.Core hiding (config) +import XMonad.Internal.Command.Desktop +import XMonad.Internal.Command.Power +import XMonad.Internal.DBus.Brightness.ClevoKeyboard +import XMonad.Internal.DBus.Brightness.IntelBacklight +import XMonad.Internal.DBus.Control +import XMonad.Internal.DBus.Screensaver (ssSignalDep) +import qualified XMonad.Internal.Theme as XT +import Xmobar hiding + ( iconOffset + , run + ) +import Xmobar.Plugins.Bluetooth +import Xmobar.Plugins.ClevoKeyboard +import Xmobar.Plugins.Common +import Xmobar.Plugins.Device +import Xmobar.Plugins.IntelBacklight +import Xmobar.Plugins.Screensaver +import Xmobar.Plugins.VPN main :: IO () main = getArgs >>= parse parse :: [String] -> IO () -parse [] = run +parse [] = run parse ["--deps"] = withCache printDeps parse ["--test"] = void $ withCache . evalConfig =<< connectDBus -parse _ = usage +parse _ = usage run :: IO () run = do @@ -84,13 +76,16 @@ printDeps = do io $ disconnectDBus db usage :: IO () -usage = putStrLn $ intercalate "\n" - [ "xmobar: run greatest taskbar" - , "xmobar --deps: print dependencies" - ] +usage = + putStrLn $ + intercalate + "\n" + [ "xmobar: run greatest taskbar" + , "xmobar --deps: print dependencies" + ] -------------------------------------------------------------------------------- --- | toplevel configuration +-- toplevel configuration -- | The text font family textFont :: Always XT.FontBuilder @@ -102,88 +97,93 @@ textFontOffset = 16 -- | Attributes for the bar font (size, weight, etc) textFontData :: XT.FontData -textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 } +textFontData = XT.defFontData {XT.weight = Just XT.Bold, XT.size = Just 11} -- | The icon font family iconFont :: Sometimes XT.FontBuilder -iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font" - [Package Official "ttf-nerd-fonts-symbols-2048-em"] +iconFont = + fontSometimes + "XMobar Icon Font" + "Symbols Nerd Font" + [Package Official "ttf-nerd-fonts-symbols-2048-em"] -- | Offsets for the icons in the bar (relative to the text offset) iconOffset :: BarFont -> Int -iconOffset IconSmall = 0 +iconOffset IconSmall = 0 iconOffset IconMedium = 1 -iconOffset IconLarge = 1 +iconOffset IconLarge = 1 iconOffset IconXLarge = 2 -- | Sizes (in pixels) for the icon fonts iconSize :: BarFont -> Int -iconSize IconSmall = 13 +iconSize IconSmall = 13 iconSize IconMedium = 15 -iconSize IconLarge = 18 +iconSize IconLarge = 18 iconSize IconXLarge = 20 -- | Attributes for icon fonts iconFontData :: Int -> XT.FontData -iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing } +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 :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config -config bf ifs ios br confDir = defaultConfig - { font = T.unpack bf - , additionalFonts = fmap T.unpack ifs - , textOffset = textFontOffset - , textOffsets = ios - , bgColor = T.unpack XT.bgColor - , fgColor = T.unpack XT.fgColor - , position = BottomSize C 100 24 - , border = NoBorder - , borderColor = T.unpack XT.bordersColor - - , sepChar = T.unpack pSep - , alignSep = [lSep, rSep] - , template = T.unpack $ fmtRegions br - - , lowerOnStart = False - , hideOnStart = False - , allDesktops = True - , overrideRedirect = True - , pickBroadest = False - , persistent = True - -- store the icons with the xmonad/xmobar stack project - , iconRoot = confDir ++ "/icons" - - , commands = csRunnable <$> concatRegions br - } +config bf ifs ios br confDir = + defaultConfig + { font = T.unpack bf + , additionalFonts = fmap T.unpack ifs + , textOffset = textFontOffset + , textOffsets = ios + , bgColor = T.unpack XT.bgColor + , fgColor = T.unpack XT.fgColor + , position = BottomSize C 100 24 + , border = NoBorder + , borderColor = T.unpack XT.bordersColor + , sepChar = T.unpack pSep + , alignSep = [lSep, rSep] + , template = T.unpack $ fmtRegions br + , lowerOnStart = False + , hideOnStart = False + , allDesktops = True + , overrideRedirect = True + , pickBroadest = False + , persistent = True + , -- store the icons with the xmonad/xmobar stack project + iconRoot = confDir ++ "/icons" + , commands = csRunnable <$> concatRegions br + } -------------------------------------------------------------------------------- --- | plugin features +-- plugin features -- -- some commands depend on the presence of interfaces that can only be -- determined at runtime; define these checks here getAllCommands :: [Maybe CmdSpec] -> BarRegions -getAllCommands right = BarRegions - { brLeft = [ CmdSpec - { csAlias = "UnsafeStdinReader" - , csRunnable = Run UnsafeStdinReader - } - ] - , brCenter = [] - , brRight = catMaybes right - } +getAllCommands right = + BarRegions + { brLeft = + [ CmdSpec + { csAlias = "UnsafeStdinReader" + , csRunnable = Run UnsafeStdinReader + } + ] + , brCenter = [] + , brRight = catMaybes right + } rightPlugins :: DBusState -> FIO [Maybe CmdSpec] -rightPlugins db = mapM evalFeature $ allFeatures db - ++ [always' "date indicator" dateCmd] +rightPlugins db = + mapM evalFeature $ + allFeatures db + ++ [always' "date indicator" dateCmd] where always' n = Right . Always n . Always_ . FallbackAlone allFeatures :: DBusState -> [Feature CmdSpec] -allFeatures DBusState { dbSesClient = ses, dbSysClient = sys } = +allFeatures DBusState {dbSesClient = ses, dbSysClient = sys} = [ Left getWireless , Left $ getEthernet sys , Left $ getVPN sys @@ -200,8 +200,11 @@ type BarFeature = Sometimes CmdSpec -- TODO what if I don't have a wireless card? getWireless :: BarFeature -getWireless = Sometimes "wireless status indicator" xpfWireless - [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"] +getWireless = + Sometimes + "wireless status indicator" + xpfWireless + [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"] getEthernet :: Maybe SysClient -> BarFeature getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree @@ -213,32 +216,49 @@ getBattery :: BarFeature getBattery = iconIO_ "battery level indicator" xpfBattery root tree where root useIcon = IORoot_ (batteryCmd useIcon) - tree = Only_ $ IOTest_ "Test if battery is present" [] - $ io $ fmap (Msg LevelError) <$> hasBattery + tree = + Only_ $ + IOTest_ "Test if battery is present" [] $ + io $ + fmap (Msg LevelError) <$> hasBattery getVPN :: Maybe SysClient -> BarFeature getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test where root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl - test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" - networkManagerPkgs vpnPresent + test = + DBusIO $ + IOTest_ + "Use nmcli to test if VPN is present" + networkManagerPkgs + vpnPresent getBt :: Maybe SysClient -> BarFeature getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd getAlsa :: BarFeature -getAlsa = iconIO_ "volume level indicator" (const True) root - $ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl" +getAlsa = + iconIO_ "volume level indicator" (const True) root $ + Only_ $ + sysExe [Package Official "alsa-utils"] "alsactl" where root useIcon = IORoot_ (alsaCmd useIcon) getBl :: Maybe SesClient -> BarFeature -getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight - intelBacklightSignalDep blCmd +getBl = + xmobarDBus + "Intel backlight indicator" + xpfIntelBacklight + intelBacklightSignalDep + blCmd getCk :: Maybe SesClient -> BarFeature -getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight - clevoKeyboardSignalDep ckCmd +getCk = + xmobarDBus + "Clevo keyboard indicator" + xpfClevoBacklight + clevoKeyboardSignalDep + ckCmd getSs :: Maybe SesClient -> BarFeature getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd @@ -249,158 +269,232 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency -------------------------------------------------------------------------------- --- | bar feature constructors +-- bar feature constructors -xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c - -> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature +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_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec) - -> IOTree_ -> BarFeature +iconIO_ + :: T.Text + -> XPQuery + -> (Fontifier -> IOTree_ -> Root CmdSpec) + -> IOTree_ + -> BarFeature iconIO_ = iconSometimes' And_ Only_ -iconDBus :: SafeClient c => T.Text -> XPQuery - -> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature +iconDBus + :: SafeClient c + => T.Text + -> XPQuery + -> (Fontifier -> DBusTree c p -> Root CmdSpec) + -> DBusTree c p + -> BarFeature iconDBus = iconSometimes' And1 $ Only_ . DBusIO -iconDBus_ :: SafeClient c => T.Text -> XPQuery - -> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature +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_) -> T.Text -> XPQuery - -> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature -iconSometimes' c d n q r t = Sometimes n q - [ Subfeature icon "icon indicator" - , Subfeature text "text indicator" - ] +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" + , Subfeature text "text indicator" + ] where icon = r fontifyIcon $ c t $ d iconDependency text = r fontifyAlt t -------------------------------------------------------------------------------- --- | command specifications +-- command specifications data BarRegions = BarRegions - { brLeft :: [CmdSpec] + { brLeft :: [CmdSpec] , brCenter :: [CmdSpec] - , brRight :: [CmdSpec] - } deriving Show + , brRight :: [CmdSpec] + } + deriving (Show) data CmdSpec = CmdSpec - { csAlias :: T.Text + { csAlias :: T.Text , csRunnable :: Runnable - } deriving Show + } + deriving (Show) concatRegions :: BarRegions -> [CmdSpec] concatRegions (BarRegions l c r) = l ++ c ++ r wirelessCmd :: T.Text -> CmdSpec -wirelessCmd iface = CmdSpec - { csAlias = T.append iface "wi" - , csRunnable = Run $ Wireless (T.unpack iface) args 5 - } +wirelessCmd iface = + CmdSpec + { csAlias = T.append iface "wi" + , csRunnable = Run $ Wireless (T.unpack iface) args 5 + } where - args = fmap T.unpack - [ "-t", "" - , "--" - , "--quality-icon-pattern", "" - ] + args = + fmap + T.unpack + [ "-t" + , "" + , "--" + , "--quality-icon-pattern" + , "" + ] ethernetCmd :: Fontifier -> T.Text -> CmdSpec -ethernetCmd fontify iface = CmdSpec - { csAlias = iface - , csRunnable = Run - $ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors) - } +ethernetCmd fontify iface = + CmdSpec + { csAlias = iface + , csRunnable = + Run $ + Device (iface, fontify IconMedium "\xf0e8" "ETH", colors) + } batteryCmd :: Fontifier -> CmdSpec -batteryCmd fontify = CmdSpec - { csAlias = "battery" - , csRunnable = Run $ Battery args 50 - } +batteryCmd fontify = + CmdSpec + { csAlias = "battery" + , 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" - ] + 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 - { csAlias = vpnAlias - , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors) - } +vpnCmd fontify = + CmdSpec + { csAlias = vpnAlias + , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors) + } btCmd :: Fontifier -> CmdSpec -btCmd fontify = CmdSpec - { csAlias = btAlias - , csRunnable = Run - $ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors - } +btCmd fontify = + CmdSpec + { csAlias = btAlias + , csRunnable = + Run $ + Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors + } where 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", T.append (fontify' "\xf026" "-") " " - , "-c", XT.fgColor - , "-C", XT.fgColor - ] - } +alsaCmd fontify = + CmdSpec + { csAlias = "alsa:default:Master" + , csRunnable = + Run $ + Alsa "default" "Master" $ + fmap + T.unpack + [ "-t" + , "%" + , "--" + , "-O" + , fontify' "\xf028" "+" + , "-o" + , T.append (fontify' "\xf026" "-") " " + , "-c" + , XT.fgColor + , "-C" + , XT.fgColor + ] + } where fontify' i = fontify IconSmall i . T.append "VOL" blCmd :: Fontifier -> CmdSpec -blCmd fontify = CmdSpec - { csAlias = blAlias - , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: " - } +blCmd fontify = + CmdSpec + { csAlias = blAlias + , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: " + } ckCmd :: Fontifier -> CmdSpec -ckCmd fontify = CmdSpec - { csAlias = ckAlias - , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: " - } +ckCmd fontify = + CmdSpec + { csAlias = ckAlias + , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: " + } ssCmd :: Fontifier -> CmdSpec -ssCmd fontify = CmdSpec - { csAlias = ssAlias - , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors) - } +ssCmd fontify = + CmdSpec + { csAlias = ssAlias + , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors) + } lockCmd :: Fontifier -> CmdSpec -lockCmd fontify = CmdSpec - { csAlias = "locks" - , csRunnable = Run - $ Locks - $ fmap T.unpack - [ "-N", numIcon - , "-n", disabledColor numIcon - , "-C", capIcon - , "-c", disabledColor capIcon - , "-s", "" - , "-S", "" - , "-d", " " - ] - } +lockCmd fontify = + CmdSpec + { csAlias = "locks" + , csRunnable = + Run $ + Locks $ + fmap + T.unpack + [ "-N" + , numIcon + , "-n" + , disabledColor numIcon + , "-C" + , capIcon + , "-c" + , disabledColor capIcon + , "-s" + , "" + , "-S" + , "" + , "-d" + , " " + ] + } where numIcon = fontify' "\xf8a5" "N" capIcon = fontify' "\xf657" "C" @@ -408,33 +502,37 @@ lockCmd fontify = CmdSpec disabledColor = xmobarFGColor XT.backdropFgColor dateCmd :: CmdSpec -dateCmd = CmdSpec - { csAlias = "date" - , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10 - } +dateCmd = + CmdSpec + { csAlias = "date" + , csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10 + } -------------------------------------------------------------------------------- --- | low-level testing functions +-- low-level testing functions vpnPresent :: FIO (Maybe Msg) vpnPresent = do res <- proc "nmcli" args readProcess return $ case res of - (ExitSuccess, out, _) | "vpn" `elem` BL.split 10 out -> Nothing - | otherwise -> Just $ Msg LevelError "vpn not found" - (ExitFailure c, _, err) -> Just $ Msg LevelError - $ T.concat - ["vpn search exited with code " - , T.pack $ show c - , ": " - , T.decodeUtf8With T.lenientDecode - $ BL.toStrict err - ] + (ExitSuccess, out, _) + | "vpn" `elem` BL.split 10 out -> Nothing + | otherwise -> Just $ Msg LevelError "vpn not found" + (ExitFailure c, _, err) -> + Just $ + Msg LevelError $ + T.concat + [ "vpn search exited with code " + , T.pack $ show c + , ": " + , T.decodeUtf8With T.lenientDecode $ + BL.toStrict err + ] where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] -------------------------------------------------------------------------------- --- | text font +-- text font -- -- ASSUME there is only one text font for this entire configuration. This -- will correspond to the first font/offset parameters in the config record. @@ -445,17 +543,20 @@ getTextFont = do return $ fb textFontData -------------------------------------------------------------------------------- --- | icon fonts +-- icon fonts getIconFonts :: FIO ([T.Text], [Int]) getIconFonts = do fb <- evalSometimes iconFont return $ maybe ([], []) apply fb where - apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset)) - <$> iconFonts + apply fb = + unzip $ + (\i -> (iconString fb i, iconOffset i + textFontOffset)) + <$> iconFonts -data BarFont = IconSmall +data BarFont + = IconSmall | IconMedium | IconLarge | IconXLarge @@ -483,10 +584,10 @@ fontifyIcon :: Fontifier fontifyIcon f i _ = fontifyText f i -------------------------------------------------------------------------------- --- | various formatting things +-- various formatting things colors :: Colors -colors = Colors { colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor } +colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor} sep :: T.Text sep = xmobarFGColor XT.backdropFgColor " : " @@ -503,8 +604,9 @@ pSep = "%" fmtSpecs :: [CmdSpec] -> T.Text fmtSpecs = T.intercalate sep . fmap go where - go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep] + go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep] 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] +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 316b242..5bd7d16 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -1,84 +1,79 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | XMonad binary +-- XMonad binary module Main (main) where -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Text.IO (hPutStrLn) - -import Graphics.X11.Types -import Graphics.X11.Xlib.Atom -import Graphics.X11.Xlib.Extras - -import RIO -import RIO.Directory -import RIO.Process -import qualified RIO.Text as T - -import System.Environment -import System.Posix.Signals -import System.Process - ( getPid - , getProcessExitCode - ) - -import XMonad -import XMonad.Actions.CopyWindow -import XMonad.Actions.CycleWS -import XMonad.Actions.PhysicalScreens -import XMonad.Actions.Warp -import XMonad.Hooks.DynamicLog -import XMonad.Hooks.EwmhDesktops -import XMonad.Hooks.ManageDocks -import XMonad.Hooks.ManageHelpers -import XMonad.Internal.Command.DMenu -import XMonad.Internal.Command.Desktop -import XMonad.Internal.Command.Power -import XMonad.Internal.Concurrent.ACPIEvent -import XMonad.Internal.Concurrent.ClientMessage -import XMonad.Internal.Concurrent.DynamicWorkspaces -import XMonad.Internal.Concurrent.VirtualBox -import XMonad.Internal.DBus.Brightness.ClevoKeyboard -import XMonad.Internal.DBus.Brightness.Common -import XMonad.Internal.DBus.Brightness.IntelBacklight -import XMonad.Internal.DBus.Control -import XMonad.Internal.DBus.Removable -import XMonad.Internal.DBus.Screensaver -import XMonad.Internal.Shell hiding (proc) -import qualified XMonad.Internal.Theme as XT -import XMonad.Layout.MultiToggle -import XMonad.Layout.NoBorders -import XMonad.Layout.NoFrillsDecoration -import XMonad.Layout.PerWorkspace -import XMonad.Layout.Renamed -import XMonad.Layout.Tabbed -import qualified XMonad.Operations as O -import qualified XMonad.StackSet as W -import XMonad.Util.Cursor -import XMonad.Util.EZConfig -import qualified XMonad.Util.ExtensibleState as E -import XMonad.Util.NamedActions -import XMonad.Util.WorkspaceCompare +import Control.Monad +import Data.Internal.DBus +import Data.Internal.Dependency +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Text.IO (hPutStrLn) +import Graphics.X11.Types +import Graphics.X11.Xlib.Atom +import Graphics.X11.Xlib.Extras +import RIO +import RIO.Directory +import RIO.Process +import qualified RIO.Text as T +import System.Environment +import System.Posix.Signals +import System.Process + ( getPid + , getProcessExitCode + ) +import XMonad +import XMonad.Actions.CopyWindow +import XMonad.Actions.CycleWS +import XMonad.Actions.PhysicalScreens +import XMonad.Actions.Warp +import XMonad.Hooks.DynamicLog +import XMonad.Hooks.EwmhDesktops +import XMonad.Hooks.ManageDocks +import XMonad.Hooks.ManageHelpers +import XMonad.Internal.Command.DMenu +import XMonad.Internal.Command.Desktop +import XMonad.Internal.Command.Power +import XMonad.Internal.Concurrent.ACPIEvent +import XMonad.Internal.Concurrent.ClientMessage +import XMonad.Internal.Concurrent.DynamicWorkspaces +import XMonad.Internal.Concurrent.VirtualBox +import XMonad.Internal.DBus.Brightness.ClevoKeyboard +import XMonad.Internal.DBus.Brightness.Common +import XMonad.Internal.DBus.Brightness.IntelBacklight +import XMonad.Internal.DBus.Control +import XMonad.Internal.DBus.Removable +import XMonad.Internal.DBus.Screensaver +import XMonad.Internal.Shell hiding (proc) +import qualified XMonad.Internal.Theme as XT +import XMonad.Layout.MultiToggle +import XMonad.Layout.NoBorders +import XMonad.Layout.NoFrillsDecoration +import XMonad.Layout.PerWorkspace +import XMonad.Layout.Renamed +import XMonad.Layout.Tabbed +import qualified XMonad.Operations as O +import qualified XMonad.StackSet as W +import XMonad.Util.Cursor +import XMonad.Util.EZConfig +import qualified XMonad.Util.ExtensibleState as E +import XMonad.Util.NamedActions +import XMonad.Util.WorkspaceCompare main :: IO () main = getArgs >>= parse parse :: [String] -> IO () -parse [] = run +parse [] = run parse ["--deps"] = withCache printDeps -- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX -parse _ = usage +parse _ = usage run :: IO () run = do @@ -110,26 +105,31 @@ run = do sk <- evalAlways $ fsShowKeys fs ha <- evalAlways $ fsACPIHandler fs tt <- evalAlways $ fsTabbedTheme fs - let conf = ewmh - $ addKeymap dws sk kbs - $ docks - $ def { terminal = myTerm - , modMask = myModMask - , layoutHook = myLayouts tt - , manageHook = myManageHook dws - , handleEventHook = myEventHook ha - , startupHook = myStartupHook - , workspaces = myWorkspaces - , logHook = myLoghook xmobarP - , clickJustFocuses = False - , focusFollowsMouse = False - , normalBorderColor = T.unpack XT.bordersColor - , focusedBorderColor = T.unpack XT.selectedBordersColor - } + let conf = + ewmh $ + addKeymap dws sk kbs $ + docks $ + def + { terminal = myTerm + , modMask = myModMask + , layoutHook = myLayouts tt + , manageHook = myManageHook dws + , handleEventHook = myEventHook ha + , startupHook = myStartupHook + , workspaces = myWorkspaces + , logHook = myLoghook xmobarP + , clickJustFocuses = False + , focusFollowsMouse = False + , normalBorderColor = T.unpack XT.bordersColor + , focusedBorderColor = T.unpack XT.selectedBordersColor + } io $ runXMonad conf where - startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs - $ dbSysClient db + startRemovableMon db fs = + void $ + executeSometimes $ + fsRemovableMon fs $ + dbSysClient db startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs startDynWorkspaces fs = do dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) @@ -142,8 +142,9 @@ runXMonad conf = do launch conf dirs startDBusInterfaces :: DBusState -> FeatureSet -> FIO () -startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) - $ fsDBusExporters fs +startDBusInterfaces db fs = + mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $ + fsDBusExporters fs getCreateDirectories :: IO Directories getCreateDirectories = do @@ -156,18 +157,18 @@ getCreateDirectories = do r <- tryIO $ createDirectoryIfMissing True d case r of (Left e) -> print e - _ -> return () + _ -> return () data FeatureSet = FeatureSet - { fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX] + { fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX] , fsDBusExporters :: [Maybe SesClient -> SometimesIO] - , fsPowerMon :: SometimesIO - , fsRemovableMon :: Maybe SysClient -> SometimesIO - , fsDaemons :: [Sometimes (FIO (Process () () ()))] - , fsACPIHandler :: Always (String -> X ()) - , fsTabbedTheme :: Always Theme + , fsPowerMon :: SometimesIO + , fsRemovableMon :: Maybe SysClient -> SometimesIO + , fsDaemons :: [Sometimes (FIO (Process () () ()))] + , fsACPIHandler :: Always (String -> X ()) + , fsTabbedTheme :: Always Theme , fsDynWorkspaces :: [Sometimes DynWorkspace] - , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) + , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) } tabbedFeature :: Always Theme @@ -178,17 +179,18 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont features :: Maybe SysClient -> FeatureSet -features cl = FeatureSet - { fsKeys = externalBindings - , fsDBusExporters = dbusExporters - , fsPowerMon = runPowermon - , fsRemovableMon = runRemovableMon - , fsACPIHandler = runHandleACPI - , fsDynWorkspaces = allDWs' - , fsTabbedTheme = tabbedFeature - , fsShowKeys = runShowKeys - , fsDaemons = [runNetAppDaemon cl, runAutolock] - } +features cl = + FeatureSet + { fsKeys = externalBindings + , fsDBusExporters = dbusExporters + , fsPowerMon = runPowermon + , fsRemovableMon = runRemovableMon + , fsACPIHandler = runHandleACPI + , fsDynWorkspaces = allDWs' + , fsTabbedTheme = tabbedFeature + , fsShowKeys = runShowKeys + , fsDaemons = [runNetAppDaemon cl, runAutolock] + } startXmobar :: FIO (Process Handle () ()) startXmobar = do @@ -196,9 +198,10 @@ startXmobar = do io $ hSetBuffering (getStdin p) LineBuffering return p where - start = startProcess - . setStdin createPipe - . setCreateGroup True + start = + startProcess + . setStdin createPipe + . setCreateGroup True startChildDaemons :: FeatureSet -> FIO [Process () () ()] startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs) @@ -228,37 +231,42 @@ printDeps :: FIO () printDeps = do db <- io connectDBus (i, f, d) <- allFeatures db - io $ mapM_ (putStrLn . T.unpack) - $ fmap showFulfillment - $ sort - $ nub - $ concat - $ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d + io $ + mapM_ (putStrLn . T.unpack) $ + fmap showFulfillment $ + sort $ + nub $ + concat $ + fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d io $ disconnectDBus db allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures db = do - let bfs = concatMap (fmap kbMaybeAction . kgBindings) - $ externalBindings ts db + let bfs = + concatMap (fmap kbMaybeAction . kgBindings) $ + externalBindings ts db let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters let others = [runRemovableMon $ dbSysClient db, runPowermon] - return (dbus ++ others, Left runScreenLock:bfs, allDWs') + return (dbus ++ others, Left runScreenLock : bfs, allDWs') where - ts = ThreadState { tsChildPIDs = [], tsXmobar = Nothing } + ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing} usage :: IO () -usage = putStrLn $ intercalate "\n" - [ "xmonad: run greatest window manager" - , "xmonad --deps: print dependencies" - ] +usage = + putStrLn $ + intercalate + "\n" + [ "xmonad: run greatest window manager" + , "xmonad --deps: print dependencies" + ] -------------------------------------------------------------------------------- --- | Concurrency configuration +-- Concurrency configuration data ThreadState = ThreadState - { tsChildPIDs :: [Process () () ()] - , tsXmobar :: Maybe (Process Handle () ()) - } + { tsChildPIDs :: [Process () () ()] + , tsXmobar :: Maybe (Process Handle () ()) + } runCleanup :: ThreadState -> DBusState -> X () runCleanup ts db = io $ do @@ -294,18 +302,19 @@ killNoWait p = do handleIO (\_ -> return ()) $ stopProcess p -------------------------------------------------------------------------------- --- | Startuphook configuration +-- Startuphook configuration -- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED? myStartupHook :: X () -myStartupHook = setDefaultCursor xC_left_ptr - <+> startupHook def +myStartupHook = + setDefaultCursor xC_left_ptr + <+> startupHook def -------------------------------------------------------------------------------- --- | Workspace configuration +-- Workspace configuration myWorkspaces :: [WorkspaceId] -myWorkspaces = map show [1..10 :: Int] +myWorkspaces = map show [1 .. 10 :: Int] gimpTag :: String gimpTag = "GIMP" @@ -323,122 +332,148 @@ gimpDynamicWorkspace :: Sometimes DynWorkspace gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw where tree = Only_ $ sysExe [Package Official "gimp"] exe - dw = DynWorkspace - { dwName = "Gimp" - , dwTag = gimpTag - , dwClass = c - , dwHook = - [ matchGimpRole "gimp-image-window" -?> appendViewShift gimpTag - , matchGimpRole "gimp-dock" -?> doF W.swapDown - , matchGimpRole "gimp-toolbox" -?> doF W.swapDown - , className =? c -?> appendViewShift gimpTag - ] - , dwKey = 'g' - , dwCmd = Just $ spawnCmd exe [] - } + dw = + DynWorkspace + { dwName = "Gimp" + , dwTag = gimpTag + , dwClass = c + , dwHook = + [ matchGimpRole "gimp-image-window" -?> appendViewShift gimpTag + , matchGimpRole "gimp-dock" -?> doF W.swapDown + , matchGimpRole "gimp-toolbox" -?> doF W.swapDown + , className =? c -?> appendViewShift gimpTag + ] + , dwKey = 'g' + , dwCmd = Just $ spawnCmd exe [] + } exe = "gimp-2.10" - matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE" - <&&> className =? c + matchGimpRole role = + isPrefixOf role + <$> stringProperty "WM_WINDOW_ROLE" + <&&> className + =? c c = "Gimp-2.10" -- TODO I don't feel like changing the version long term -- TODO don't hardcode the VM name/title/shortcut vmDynamicWorkspace :: Sometimes DynWorkspace -vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox - [Subfeature root "windows 8 VM"] +vmDynamicWorkspace = + Sometimes + "virtualbox workspace" + xpfVirtualBox + [Subfeature root "windows 8 VM"] where - root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") - $ IOTest_ name [] $ io $ vmExists vm + root = + IORoot_ dw $ + toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $ + IOTest_ name [] $ + io $ + vmExists vm name = T.unwords ["test if", vm, "exists"] c = "VirtualBoxVM" vm = "win8raw" - dw = DynWorkspace - { dwName = "Windows VirtualBox" - , dwTag = vmTag - , dwClass = c - , dwHook = [ className =? c -?> appendViewShift vmTag ] - , dwKey = 'v' - , dwCmd = Just $ spawnCmd "vbox-start" [vm] - } + dw = + DynWorkspace + { dwName = "Windows VirtualBox" + , dwTag = vmTag + , dwClass = c + , dwHook = [className =? c -?> appendViewShift vmTag] + , dwKey = 'v' + , dwCmd = Just $ spawnCmd "vbox-start" [vm] + } xsaneDynamicWorkspace :: Sometimes DynWorkspace -xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE - [Subfeature (IORoot_ dw tree) "xsane"] +xsaneDynamicWorkspace = + Sometimes + "scanner workspace" + xpfXSANE + [Subfeature (IORoot_ dw tree) "xsane"] where tree = Only_ $ sysExe [Package Official "xsane"] "xsane" - dw = DynWorkspace - { dwName = "XSane" - , dwTag = xsaneTag - , dwClass = c - , dwHook = [ className =? c -?> appendViewShift xsaneTag >> doFloat ] - , dwKey = 'x' - , dwCmd = Just $ spawnCmd "xsane" [] - } + dw = + DynWorkspace + { dwName = "XSane" + , dwTag = xsaneTag + , dwClass = c + , dwHook = [className =? c -?> appendViewShift xsaneTag >> doFloat] + , dwKey = 'x' + , dwCmd = Just $ spawnCmd "xsane" [] + } c = "Xsane" f5vpnDynamicWorkspace :: Sometimes DynWorkspace -f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN - [Subfeature (IORoot_ dw tree) "f5vpn"] +f5vpnDynamicWorkspace = + Sometimes + "F5 VPN workspace" + xpfF5VPN + [Subfeature (IORoot_ dw tree) "f5vpn"] where tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn" - dw = DynWorkspace - { dwName = "F5Vpn" - , dwTag = f5Tag - , dwClass = c - , dwHook = [ className =? c -?> appendShift f5Tag ] - , dwKey = 'i' - , dwCmd = Just skip - } + dw = + DynWorkspace + { dwName = "F5Vpn" + , dwTag = f5Tag + , dwClass = c + , dwHook = [className =? c -?> appendShift f5Tag] + , dwKey = 'i' + , dwCmd = Just skip + } c = "F5 VPN" allDWs' :: [Sometimes DynWorkspace] -allDWs' = [xsaneDynamicWorkspace - , vmDynamicWorkspace - , gimpDynamicWorkspace - , f5vpnDynamicWorkspace - ] +allDWs' = + [ xsaneDynamicWorkspace + , vmDynamicWorkspace + , gimpDynamicWorkspace + , f5vpnDynamicWorkspace + ] -------------------------------------------------------------------------------- --- | Layout configuration +-- Layout configuration -- NOTE this will have all available layouts, even those that may be for -- features that failed. Trying to dynamically take out a layout seems to -- make a new type :/ -myLayouts tt = onWorkspace vmTag vmLayout - $ onWorkspace gimpTag gimpLayout - $ mkToggle (single HIDE) - $ tall ||| fulltab ||| full +myLayouts tt = + onWorkspace vmTag vmLayout $ + onWorkspace gimpTag gimpLayout $ + mkToggle (single HIDE) $ + tall ||| fulltab ||| full where addTopBar = noFrillsDeco shrinkText tt - tall = renamed [Replace "Tall"] - $ avoidStruts - $ addTopBar - $ noBorders - $ Tall 1 0.03 0.5 - fulltab = renamed [Replace "Tabbed"] - $ avoidStruts - $ noBorders - $ tabbedAlways shrinkText tt - full = renamed [Replace "Full"] - $ noBorders Full + tall = + renamed [Replace "Tall"] $ + avoidStruts $ + addTopBar $ + noBorders $ + Tall 1 0.03 0.5 + fulltab = + renamed [Replace "Tabbed"] $ + avoidStruts $ + noBorders $ + tabbedAlways shrinkText tt + full = + renamed [Replace "Full"] $ + noBorders Full vmLayout = noBorders Full -- TODO use a tabbed layout for multiple master windows - gimpLayout = renamed [Replace "Gimp Layout"] - $ avoidStruts - $ noBorders - $ addTopBar - $ Tall 1 0.025 0.8 + gimpLayout = + renamed [Replace "Gimp Layout"] $ + avoidStruts $ + noBorders $ + addTopBar $ + Tall 1 0.025 0.8 -- | Make a new empty layout and add a message to show/hide it. This is useful -- for quickly showing conky. data EmptyLayout a = EmptyLayout - deriving (Show, Read) + deriving (Show, Read) instance LayoutClass EmptyLayout a where doLayout a b _ = emptyLayout a b description _ = "Desktop" data HIDE = HIDE - deriving (Read, Show, Eq, Typeable) + deriving (Read, Show, Eq, Typeable) instance Transformer HIDE Window where transform _ x k = k EmptyLayout (\EmptyLayout -> x) @@ -448,8 +483,7 @@ runHide :: X () runHide = sendMessage $ Toggle HIDE -------------------------------------------------------------------------------- --- | Loghook configuration --- +-- Loghook configuration myLoghook :: Process Handle () () -> X () myLoghook h = do @@ -467,10 +501,10 @@ myLoghook h = do -- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why -- bother...(if that were necessary it would go in the startup hook) newtype DesktopViewports = DesktopViewports [Int] - deriving Eq + deriving (Eq) instance ExtensionClass DesktopViewports where - initialValue = DesktopViewports [] + initialValue = DesktopViewports [] logViewports :: X () logViewports = withWindowSet $ \s -> do @@ -478,28 +512,29 @@ logViewports = withWindowSet $ \s -> do let ws = sort' $ W.workspaces s let desktopViewports = concatMap (wsToViewports s) ws whenChanged (DesktopViewports desktopViewports) $ - setDesktopViewports desktopViewports + setDesktopViewports desktopViewports where - wsToViewports s w = let cur = W.current s in - if W.tag w == currentTag cur then currentPos cur else [0, 0] + wsToViewports s w = + let cur = W.current s + in if W.tag w == currentTag cur then currentPos cur else [0, 0] currentTag = W.tag . W.workspace currentPos = rectXY . screenRect . W.screenDetail rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y] setDesktopViewports :: [Int] -> X () setDesktopViewports vps = withDisplay $ \dpy -> do - r <- asks theRoot - a <- getAtom "_NET_DESKTOP_VIEWPORT" - c <- getAtom "CARDINAL" - io $ changeProperty32 dpy r a c propModeReplace $ map fromIntegral vps + r <- asks theRoot + a <- getAtom "_NET_DESKTOP_VIEWPORT" + c <- getAtom "CARDINAL" + io $ changeProperty32 dpy r a c propModeReplace $ map fromIntegral vps -- stolen from XMonad.Hooks.EwmhDesktops whenChanged :: (Eq a, ExtensionClass a) => a -> X () -> X () whenChanged v action = do - v0 <- E.get - unless (v == v0) $ do - action - E.put v + v0 <- E.get + unless (v == v0) $ do + action + E.put v -- | Xinerama loghook (for xmobar) -- The format will be like "[<1> 2 3] 4 5 | LAYOUT (N)" where each digit is the @@ -507,156 +542,174 @@ whenChanged v action = do -- currently visible and the order reflects the physical location of each -- screen. The "<>" is the workspace that currently has focus. N is the number -- of windows on the current workspace. - logXinerama :: Process Handle () () -> X () -logXinerama p = withWindowSet $ \ws -> io - $ hPutStrLn (getStdin p) - $ T.unwords - $ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws] +logXinerama p = withWindowSet $ \ws -> + io $ + hPutStrLn (getStdin p) $ + T.unwords $ + filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws] where - 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 = xmobarColor_ XT.backdropFgColor "" - . T.unwords - . fmap (T.pack . W.tag) - . filter (isJust . W.stack) - . sortOn W.tag - . W.hidden + 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 = + 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 + nWindows = + (\x -> T.concat ["(", x, ")"]) + . T.pack + . show + . length + . W.integrate' + . W.stack + . W.workspace + . W.current hilightBgColor = "#A6D3FF" 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_ + 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 - -> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering + -> W.Screen i2 l2 a2 ScreenId ScreenDetail + -> Ordering compareXCoord s0 s1 = compare (go s0) (go s1) where go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle -------------------------------------------------------------------------------- --- | Managehook configuration +-- Managehook configuration myManageHook :: [DynWorkspace] -> ManageHook myManageHook dws = manageApps dws <+> manageHook def manageApps :: [DynWorkspace] -> ManageHook -manageApps dws = composeOne $ concatMap dwHook dws ++ - [ isDialog -?> doCenterFloat - -- the seafile applet - , className =? "Seafile Client" -?> doFloat - -- gnucash - , (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat - -- plots and graphics - , className =? "R_x11" -?> doFloat - , className =? "Matplotlib" -?> doFloat - , className =? "mpv" -?> doFloat - -- the floating windows created by the brave browser - , stringProperty "WM_NAME" =? "Brave" -?> doFloat - -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up" - -- <&&> className =? "Brave-browser") -?> doFloat - -- the dialog windows created by the zotero addon in Google Docs - , (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat - ] +manageApps dws = + composeOne $ + concatMap dwHook dws + ++ [ isDialog -?> doCenterFloat + , -- the seafile applet + className =? "Seafile Client" -?> doFloat + , -- gnucash + (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat + , -- plots and graphics + className =? "R_x11" -?> doFloat + , className =? "Matplotlib" -?> doFloat + , className =? "mpv" -?> doFloat + , -- the floating windows created by the brave browser + stringProperty "WM_NAME" =? "Brave" -?> doFloat + , -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up" + -- <&&> className =? "Brave-browser") -?> doFloat + -- the dialog windows created by the zotero addon in Google Docs + (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat + ] -------------------------------------------------------------------------------- --- | Eventhook configuration +-- Eventhook configuration myEventHook :: (String -> X ()) -> Event -> X All myEventHook handler = xMsgEventHook handler <+> handleEventHook def -- | React to ClientMessage events from concurrent threads xMsgEventHook :: (String -> X ()) -> Event -> X All -xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d } +xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d} | t == bITMAP = do - let (xtype, tag) = splitXMsg d - case xtype of - Workspace -> removeDynamicWorkspace tag - ACPI -> handler tag - Unknown -> io $ putStrLn "WARNING: unknown concurrent message" - return (All True) + let (xtype, tag) = splitXMsg d + case xtype of + Workspace -> removeDynamicWorkspace tag + ACPI -> handler tag + Unknown -> io $ putStrLn "WARNING: unknown concurrent message" + return (All True) xMsgEventHook _ _ = return (All True) -------------------------------------------------------------------------------- --- | Keymap configuration +-- Keymap configuration myModMask :: KeyMask myModMask = mod4Mask -addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ()) - -> [KeyGroup (X ())] -> XConfig l -> XConfig l -addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys) - (\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external) +addKeymap + :: [DynWorkspace] + -> ([((KeyMask, KeySym), NamedAction)] -> X ()) + -> [KeyGroup (X ())] + -> XConfig l + -> XConfig l +addKeymap dws showKeys external = + addDescrKeys' + ((myModMask, xK_F1), showKeys) + (\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external) internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())] internalBindings dws c = - [ KeyGroup "Window Layouts" - [ KeyBinding "M-j" "focus down" $ windows W.focusDown - , KeyBinding "M-k" "focus up" $ windows W.focusUp - , KeyBinding "M-m" "focus master" $ windows W.focusMaster - , KeyBinding "M-d" "focus master" runHide - , KeyBinding "M-S-j" "swap down" $ windows W.swapDown - , KeyBinding "M-S-k" "swap up" $ windows W.swapUp - , KeyBinding "M-S-m" "swap master" $ windows W.swapMaster - , KeyBinding "M-" "next layout" $ sendMessage NextLayout - , KeyBinding "M-S-" "reset layout" $ setLayout $ layoutHook c - , KeyBinding "M-t" "sink tiling" $ withFocused $ windows . W.sink - , KeyBinding "M-S-t" "float tiling" $ withFocused O.float - , KeyBinding "M--" "shrink" $ sendMessage Shrink - , KeyBinding "M-=" "expand" $ sendMessage Expand - , KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1) - , KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1 - ] - - , KeyGroup "Workspaces" - -- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get - -- valid keysyms) - ([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces - , (mods, msg, f) <- - [ ("M-", "switch to workspace ", windows . W.view) - , ("M-S-", "move client to workspace ", windows . W.shift) - , ("M-C-", "follow client to workspace ", \n' -> do - windows $ W.shift n' - windows $ W.view n') + [ KeyGroup + "Window Layouts" + [ KeyBinding "M-j" "focus down" $ windows W.focusDown + , KeyBinding "M-k" "focus up" $ windows W.focusUp + , KeyBinding "M-m" "focus master" $ windows W.focusMaster + , KeyBinding "M-d" "focus master" runHide + , KeyBinding "M-S-j" "swap down" $ windows W.swapDown + , KeyBinding "M-S-k" "swap up" $ windows W.swapUp + , KeyBinding "M-S-m" "swap master" $ windows W.swapMaster + , KeyBinding "M-" "next layout" $ sendMessage NextLayout + , KeyBinding "M-S-" "reset layout" $ setLayout $ layoutHook c + , KeyBinding "M-t" "sink tiling" $ withFocused $ windows . W.sink + , KeyBinding "M-S-t" "float tiling" $ withFocused O.float + , KeyBinding "M--" "shrink" $ sendMessage Shrink + , KeyBinding "M-=" "expand" $ sendMessage Expand + , KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1) + , KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1 + ] + , KeyGroup + "Workspaces" + -- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get + -- valid keysyms) + ( [ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces, (mods, msg, f) <- + [ ("M-", "switch to workspace ", windows . W.view) + , ("M-S-", "move client to workspace ", windows . W.shift) + , + ( "M-C-" + , "follow client to workspace " + , \n' -> do + windows $ W.shift n' + windows $ W.view n' + ) + ] ] - ] ++ - [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS) - , KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS) - ]) - - , KeyGroup "Dynamic Workspaces" - [ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd - | DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws, - let cmd = case a of - Just a' -> spawnOrSwitch t a' - Nothing -> windows $ W.view t - ] - - , KeyGroup "Screens" - [ KeyBinding "M-l" "move up screen" nextScr - , KeyBinding "M-h" "move down screen" prevScr - , KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift - , KeyBinding "M-C-h" "follow client down screen" $ prevScr' W.shift - , KeyBinding "M-S-l" "shift workspace up screen" $ nextScr' W.greedyView - , KeyBinding "M-S-h" "shift workspace down screen" $ prevScr' W.greedyView - ] + ++ [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS) + , KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS) + ] + ) + , KeyGroup + "Dynamic Workspaces" + [ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd + | DynWorkspace {dwTag = t, dwKey = k, dwCmd = a, dwName = n} <- dws + , let cmd = case a of + Just a' -> spawnOrSwitch t a' + Nothing -> windows $ W.view t + ] + , KeyGroup + "Screens" + [ KeyBinding "M-l" "move up screen" nextScr + , KeyBinding "M-h" "move down screen" prevScr + , KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift + , KeyBinding "M-C-h" "follow client down screen" $ prevScr' W.shift + , KeyBinding "M-S-l" "shift workspace up screen" $ nextScr' W.greedyView + , KeyBinding "M-S-h" "shift workspace down screen" $ prevScr' W.greedyView + ] ] where prev = onPrevNeighbour horizontalScreenOrderer @@ -666,110 +719,114 @@ internalBindings dws c = prevScr' f = prev f >> prevScr nextScr' f = next f >> nextScr -mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)] -mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } = - (subtitle h:) $ mkNamedKeymap c - $ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a)) - <$> b +mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)] +mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} = + (subtitle h :) $ + mkNamedKeymap c $ + (\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a)) + <$> b data KeyBinding a = KeyBinding - { kbSyms :: String - , kbDesc :: String + { kbSyms :: String + , kbDesc :: String , kbMaybeAction :: a } data KeyGroup a = KeyGroup - { kgHeader :: String + { kgHeader :: String , kgBindings :: [KeyBinding a] } evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX] evalExternal = mapM go where - go k@KeyGroup { kgBindings = bs } = - (\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs + go k@KeyGroup {kgBindings = bs} = + (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX) -evalKeyBinding k@KeyBinding { kbMaybeAction = a } = - (\f -> k { kbMaybeAction = f }) <$> evalFeature a +evalKeyBinding k@KeyBinding {kbMaybeAction = a} = + (\f -> k {kbMaybeAction = f}) <$> evalFeature a filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())] filterExternal = fmap go where - go k@KeyGroup { kgBindings = bs } = - k { kgBindings = [ kb { kbMaybeAction = x } - | kb@KeyBinding { kbMaybeAction = Just x } <- bs - ] + go k@KeyGroup {kgBindings = bs} = + k + { kgBindings = + [ kb {kbMaybeAction = x} + | kb@KeyBinding {kbMaybeAction = Just x} <- bs + ] } externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX] externalBindings ts db = - [ KeyGroup "Launchers" - [ KeyBinding "" "select/launch app" $ Left runAppMenu - , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu - , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys - , KeyBinding "M-w" "launch window selector" $ Left runWinMenu - , KeyBinding "M-u" "launch device selector" $ Left runDevMenu - , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses - , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu - , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu - , KeyBinding "M-C-e" "launch editor" $ Left runEditor - , KeyBinding "M-C-w" "launch browser" $ Left runBrowser - , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux - , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm - , KeyBinding "M-C-q" "launch calc" $ Left runCalc - , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager - ] - - , KeyGroup "Actions" - [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1 - , KeyBinding "M-r" "run program" $ Left runCmdMenu - , KeyBinding "M-" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5 - , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses - , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses - , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses - , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser - -- , ("M-C-S-s", "capture focused window", spawn myWindowCap) - ] - - , KeyGroup "Multimedia" - [ KeyBinding "" "toggle play/pause" $ Left runTogglePlay - , KeyBinding "" "previous track" $ Left runPrevTrack - , KeyBinding "" "next track" $ Left runNextTrack - , KeyBinding "" "stop" $ Left runStopPlay - , KeyBinding "" "volume down" $ Left runVolumeDown - , KeyBinding "" "volume up" $ Left runVolumeUp - , KeyBinding "" "volume mute" $ Left runVolumeMute - ] - - , KeyGroup "Dunst" - [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses - , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses - , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses - , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses - ] - - , KeyGroup "System" - [ KeyBinding "M-." "backlight up" $ ib bctlInc - , KeyBinding "M-," "backlight down" $ ib bctlDec - , KeyBinding "M-M1-," "backlight min" $ ib bctlMin - , KeyBinding "M-M1-." "backlight max" $ ib bctlMax - , KeyBinding "M-S-." "keyboard up" $ ck bctlInc - , KeyBinding "M-S-," "keyboard down" $ ck bctlDec - , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin - , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax - , KeyBinding "M-" "power menu" $ Left runPowerPrompt - , KeyBinding "M-" "quit xmonad" $ Left runQuitPrompt - , KeyBinding "M-" "lock screen" $ Left runScreenLock - -- M- reserved for showing the keymap - , KeyBinding "M-" "restart xmonad" restartf - , KeyBinding "M-" "recompile xmonad" recompilef - , KeyBinding "M-" "select autorandr profile" $ Left runAutorandrMenu - , KeyBinding "M-" "toggle ethernet" $ Left runToggleEthernet - , KeyBinding "M-" "toggle bluetooth" $ Left $ runToggleBluetooth sys - , KeyBinding "M-" "toggle screensaver" $ Left $ callToggle ses - , KeyBinding "M-" "switch gpu" $ Left runOptimusPrompt - ] + [ KeyGroup + "Launchers" + [ KeyBinding "" "select/launch app" $ Left runAppMenu + , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu + , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys + , KeyBinding "M-w" "launch window selector" $ Left runWinMenu + , KeyBinding "M-u" "launch device selector" $ Left runDevMenu + , KeyBinding "M-b" "launch bitwarden selector" $ Left $ runBwMenu ses + , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu + , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu + , KeyBinding "M-C-e" "launch editor" $ Left runEditor + , KeyBinding "M-C-w" "launch browser" $ Left runBrowser + , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux + , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm + , KeyBinding "M-C-q" "launch calc" $ Left runCalc + , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager + ] + , KeyGroup + "Actions" + [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1 + , KeyBinding "M-r" "run program" $ Left runCmdMenu + , KeyBinding "M-" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5 + , KeyBinding "M-C-s" "capture area" $ Left $ runAreaCapture ses + , KeyBinding "M-C-S-s" "capture screen" $ Left $ runScreenCapture ses + , KeyBinding "M-C-d" "capture desktop" $ Left $ runDesktopCapture ses + , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser + -- , ("M-C-S-s", "capture focused window", spawn myWindowCap) + ] + , KeyGroup + "Multimedia" + [ KeyBinding "" "toggle play/pause" $ Left runTogglePlay + , KeyBinding "" "previous track" $ Left runPrevTrack + , KeyBinding "" "next track" $ Left runNextTrack + , KeyBinding "" "stop" $ Left runStopPlay + , KeyBinding "" "volume down" $ Left runVolumeDown + , KeyBinding "" "volume up" $ Left runVolumeUp + , KeyBinding "" "volume mute" $ Left runVolumeMute + ] + , KeyGroup + "Dunst" + [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses + , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses + , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses + , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses + ] + , KeyGroup + "System" + [ KeyBinding "M-." "backlight up" $ ib bctlInc + , KeyBinding "M-," "backlight down" $ ib bctlDec + , KeyBinding "M-M1-," "backlight min" $ ib bctlMin + , KeyBinding "M-M1-." "backlight max" $ ib bctlMax + , KeyBinding "M-S-." "keyboard up" $ ck bctlInc + , KeyBinding "M-S-," "keyboard down" $ ck bctlDec + , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin + , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax + , KeyBinding "M-" "power menu" $ Left runPowerPrompt + , KeyBinding "M-" "quit xmonad" $ Left runQuitPrompt + , KeyBinding "M-" "lock screen" $ Left runScreenLock + , -- M- reserved for showing the keymap + KeyBinding "M-" "restart xmonad" restartf + , KeyBinding "M-" "recompile xmonad" recompilef + , KeyBinding "M-" "select autorandr profile" $ Left runAutorandrMenu + , KeyBinding "M-" "toggle ethernet" $ Left runToggleEthernet + , KeyBinding "M-" "toggle bluetooth" $ Left $ runToggleBluetooth sys + , KeyBinding "M-" "toggle screensaver" $ Left $ callToggle ses + , KeyBinding "M-" "switch gpu" $ Left runOptimusPrompt + ] ] where ses = dbSesClient db diff --git a/fourmolu.yaml b/fourmolu.yaml index 8a4d94e..190e1ca 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,7 +1,7 @@ indentation: 2 -function-arrows: trailing +function-arrows: leading comma-style: leading -import-export-style: trailing +import-export-style: leading indent-wheres: true record-brace-space: true newlines-between-decls: 1 diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 0bfe459..7015065 100644 --- a/lib/Data/Internal/DBus.hs +++ b/lib/Data/Internal/DBus.hs @@ -1,15 +1,15 @@ -------------------------------------------------------------------------------- --- | Common internal DBus functions +-- Common internal DBus functions module Data.Internal.DBus - ( SafeClient(..) - , SysClient(..) - , SesClient(..) + ( SafeClient (..) + , SysClient (..) + , SesClient (..) , addMatchCallback , matchProperty , matchPropertyFull , matchPropertyChanged - , SignalMatch(..) + , SignalMatch (..) , SignalCallback , MethodBody , withSignalMatch @@ -25,22 +25,20 @@ module Data.Internal.DBus , addInterfaceRemovedListener , fromSingletonVariant , bodyToMaybe - ) where + ) +where -import Control.Exception -import Control.Monad - -import Data.Bifunctor -import qualified Data.Map.Strict as M -import Data.Maybe - -import qualified RIO.Text as T - -import DBus -import DBus.Client +import Control.Exception +import Control.Monad +import DBus +import DBus.Client +import Data.Bifunctor +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified RIO.Text as T -------------------------------------------------------------------------------- --- | Type-safe client +-- Type-safe client class SafeClient c where toClient :: c -> Client @@ -82,28 +80,37 @@ getDBusClient' :: Bool -> IO (Maybe Client) getDBusClient' sys = do res <- try $ if sys then connectSystem else connectSession case res of - Left e -> putStrLn (clientErrorMessage e) >> return Nothing + Left e -> putStrLn (clientErrorMessage e) >> return Nothing Right c -> return $ Just c -------------------------------------------------------------------------------- --- | Methods +-- Methods type MethodBody = Either T.Text [Variant] callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody -callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) - . call (toClient cl) +callMethod' cl = + fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) + . call (toClient cl) -callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName - -> MemberName -> IO MethodBody +callMethod + :: SafeClient c + => c + -> BusName + -> ObjectPath + -> InterfaceName + -> MemberName + -> IO MethodBody callMethod client bus path iface = callMethod' client . methodCallBus bus path iface methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall -methodCallBus b p i m = (methodCall p i m) - { methodCallDestination = Just b } +methodCallBus b p i m = + (methodCall p i m) + { methodCallDestination = Just b + } -------------------------------------------------------------------------------- --- | Bus names +-- Bus names dbusInterface :: InterfaceName dbusInterface = interfaceName_ "org.freedesktop.DBus" @@ -111,12 +118,14 @@ dbusInterface = interfaceName_ "org.freedesktop.DBus" callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName) callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc where - mc = (methodCallBus dbusName dbusPath dbusInterface mem) - { methodCallBody = [toVariant name] } + mc = + (methodCallBus dbusName dbusPath dbusInterface mem) + { methodCallBody = [toVariant name] + } mem = memberName_ "GetNameOwner" -------------------------------------------------------------------------------- --- | Variant parsing +-- Variant parsing fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a fromSingletonVariant = fromVariant <=< listToMaybe @@ -125,30 +134,45 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a bodyToMaybe = either (const Nothing) fromSingletonVariant -------------------------------------------------------------------------------- --- | Signals +-- Signals type SignalCallback = [Variant] -> IO () -addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c +addMatchCallback + :: SafeClient c + => MatchRule + -> SignalCallback + -> c -> IO SignalHandler addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody -matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName - -> Maybe MemberName -> MatchRule -matchSignal b p i m = matchAny - { matchPath = p - , matchSender = b - , matchInterface = i - , matchMember = m - } +matchSignal + :: Maybe BusName + -> Maybe ObjectPath + -> Maybe InterfaceName + -> Maybe MemberName + -> MatchRule +matchSignal b p i m = + matchAny + { matchPath = p + , matchSender = b + , matchInterface = i + , matchMember = m + } -matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath - -> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule) +matchSignalFull + :: SafeClient c + => c + -> BusName + -> Maybe ObjectPath + -> Maybe InterfaceName + -> Maybe MemberName + -> IO (Maybe MatchRule) matchSignalFull client b p i m = fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b -------------------------------------------------------------------------------- --- | Properties +-- Properties propertyInterface :: InterfaceName propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" @@ -156,16 +180,28 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" propertySignal :: MemberName propertySignal = memberName_ "PropertiesChanged" -callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName - -> MemberName -> c -> IO [Variant] -callPropertyGet bus path iface property cl = fmap (either (const []) (:[])) - $ getProperty (toClient cl) $ methodCallBus bus path iface property +callPropertyGet + :: SafeClient c + => BusName + -> ObjectPath + -> InterfaceName + -> MemberName + -> c + -> IO [Variant] +callPropertyGet bus path iface property cl = + fmap (either (const []) (: [])) $ + getProperty (toClient cl) $ + methodCallBus bus path iface property matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule matchProperty b p = matchSignal b p (Just propertyInterface) (Just propertySignal) -matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath +matchPropertyFull + :: SafeClient c + => c + -> BusName + -> Maybe ObjectPath -> IO (Maybe MatchRule) matchPropertyFull cl b p = matchSignalFull cl b p (Just propertyInterface) (Just propertySignal) @@ -174,25 +210,30 @@ data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show) withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO () withSignalMatch f (Match x) = f (Just x) -withSignalMatch f Failure = f Nothing -withSignalMatch _ NoMatch = return () +withSignalMatch f Failure = f Nothing +withSignalMatch _ NoMatch = return () -matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant] +matchPropertyChanged + :: IsVariant a + => InterfaceName + -> T.Text + -> [Variant] -> SignalMatch a matchPropertyChanged iface property [i, body, _] = let i' = (fromVariant i :: Maybe T.Text) - b = toMap body in - case (i', b) of - (Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then - maybe NoMatch Match $ fromVariant =<< M.lookup property b' - else NoMatch - _ -> Failure + b = toMap body + in case (i', b) of + (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 T.Text Variant) matchPropertyChanged _ _ _ = Failure -------------------------------------------------------------------------------- --- | Object Manager +-- Object Manager type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant)) @@ -208,24 +249,44 @@ omInterfacesAdded = memberName_ "InterfacesAdded" omInterfacesRemoved :: MemberName omInterfacesRemoved = memberName_ "InterfacesRemoved" -callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath +callGetManagedObjects + :: SafeClient c + => c + -> BusName + -> ObjectPath -> IO ObjectTree callGetManagedObjects cl bus path = either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) - <$> callMethod cl bus path omInterface getManagedObjects + <$> callMethod cl bus path omInterface getManagedObjects -addInterfaceChangedListener :: SafeClient c => BusName -> MemberName - -> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler) +addInterfaceChangedListener + :: SafeClient c + => BusName + -> MemberName + -> ObjectPath + -> SignalCallback + -> c + -> IO (Maybe SignalHandler) addInterfaceChangedListener bus prop path sc cl = do rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop) forM rule $ \r -> addMatchCallback r sc cl -addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath - -> SignalCallback -> c -> IO (Maybe SignalHandler) +addInterfaceAddedListener + :: SafeClient c + => BusName + -> ObjectPath + -> SignalCallback + -> c + -> IO (Maybe SignalHandler) addInterfaceAddedListener bus = addInterfaceChangedListener bus omInterfacesAdded -addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath - -> SignalCallback -> c -> IO (Maybe SignalHandler) +addInterfaceRemovedListener + :: SafeClient c + => BusName + -> ObjectPath + -> SignalCallback + -> c + -> IO (Maybe SignalHandler) addInterfaceRemovedListener bus = addInterfaceChangedListener bus omInterfacesRemoved diff --git a/lib/Data/Internal/Dependency.hs b/lib/Data/Internal/Dependency.hs index 930ce34..8ba3d44 100644 --- a/lib/Data/Internal/Dependency.hs +++ b/lib/Data/Internal/Dependency.hs @@ -1,61 +1,57 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- --- | Functions for handling dependencies +-- Functions for handling dependencies module Data.Internal.Dependency - -- feature types +-- feature types ( Feature - , Always(..) - , Always_(..) - , FallbackRoot(..) - , FallbackStack(..) - , Sometimes(..) + , Always (..) + , Always_ (..) + , FallbackRoot (..) + , FallbackStack (..) + , Sometimes (..) , Sometimes_ , AlwaysX , AlwaysIO , SometimesX , SometimesIO - , PostPass(..) - , Subfeature(..) + , PostPass (..) + , Subfeature (..) , SubfeatureRoot - , Msg(..) - + , Msg (..) -- configuration - , XParams(..) - , XPFeatures(..) + , XParams (..) + , XPFeatures (..) , XPQuery - -- dependency tree types - , Root(..) - , Tree(..) - , Tree_(..) + , Root (..) + , Tree (..) + , Tree_ (..) , IOTree , IOTree_ , DBusTree , DBusTree_ - , SafeClient(..) - , IODependency(..) - , IODependency_(..) - , SystemDependency(..) - , DBusDependency_(..) - , DBusMember(..) - , UnitType(..) + , SafeClient (..) + , IODependency (..) + , IODependency_ (..) + , SystemDependency (..) + , DBusDependency_ (..) + , DBusMember (..) + , UnitType (..) , Result - , Fulfillment(..) - , ArchPkg(..) - + , Fulfillment (..) + , ArchPkg (..) -- dumping , dumpFeature , dumpAlways , dumpSometimes , showFulfillment - -- testing , FIO , withCache @@ -72,11 +68,9 @@ module Data.Internal.Dependency , readEthernet , readWireless , socketExists - -- lifting , ioSometimes , ioAlways - -- feature construction , always1 , sometimes1 @@ -86,7 +80,6 @@ module Data.Internal.Dependency , sometimesExe , sometimesExeArgs , sometimesEndpoint - -- dependency construction , sysExe , localExe @@ -101,47 +94,41 @@ module Data.Internal.Dependency , voidResult , voidRead , process - -- misc , shellTest - ) where + ) +where -import Control.Monad.IO.Class -import Control.Monad.Identity -import Control.Monad.Reader - -import Data.Aeson hiding (Error, Result) -import Data.Aeson.Key -import Data.Bifunctor -import Data.Either -import Data.Internal.DBus -import Data.List -import Data.Maybe -import Data.Yaml - -import GHC.IO.Exception (ioe_description) - -import DBus hiding (typeOf) -import qualified DBus.Introspection as I - -import RIO hiding (bracket, fromString) -import RIO.FilePath -import RIO.Process hiding (findExecutable) -import qualified RIO.Text as T - -import System.Directory -import System.Environment -import System.IO.Error -import System.Posix.Files -import System.Process.Typed (nullStream) - -import XMonad.Core (X, io) -import XMonad.Internal.IO -import XMonad.Internal.Shell hiding (proc, runProcess) -import XMonad.Internal.Theme +import Control.Monad.IO.Class +import Control.Monad.Identity +import Control.Monad.Reader +import DBus hiding (typeOf) +import qualified DBus.Introspection as I +import Data.Aeson hiding (Error, Result) +import Data.Aeson.Key +import Data.Bifunctor +import Data.Either +import Data.Internal.DBus +import Data.List +import Data.Maybe +import Data.Yaml +import GHC.IO.Exception (ioe_description) +import RIO hiding (bracket, fromString) +import RIO.FilePath +import RIO.Process hiding (findExecutable) +import qualified RIO.Text as T +import System.Directory +import System.Environment +import System.IO.Error +import System.Posix.Files +import System.Process.Typed (nullStream) +import XMonad.Core (X, io) +import XMonad.Internal.IO +import XMonad.Internal.Shell hiding (proc, runProcess) +import XMonad.Internal.Theme -------------------------------------------------------------------------------- --- | Feature Evaluation +-- Feature Evaluation -- -- Here we attempt to build and return the monadic actions encoded by each -- feature. @@ -168,7 +155,7 @@ executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a -- | Possibly return the action of an Always/Sometimes evalFeature :: Feature a -> FIO (Maybe a) evalFeature (Right a) = Just <$> evalAlways a -evalFeature (Left s) = evalSometimes s +evalFeature (Left s) = evalSometimes s -- | Possibly return the action of a Sometimes evalSometimes :: Sometimes a -> FIO (Maybe a) @@ -191,19 +178,20 @@ logMsg (FMsg fn n (Msg ll m)) = do f $ Utf8Builder $ encodeUtf8Builder $ T.unwords $ fmt s (T.pack p) where llFun LevelError = ("ERROR", logError) - llFun LevelInfo = ("INFO", logInfo) - llFun LevelWarn = ("WARN", logWarn) - llFun _ = ("DEBUG", logDebug) + llFun LevelInfo = ("INFO", logInfo) + llFun LevelWarn = ("WARN", logWarn) + llFun _ = ("DEBUG", logDebug) (s, f) = llFun ll - fmt p l = [ bracket p - , bracket l - , bracket fn - ] - ++ maybe [] ((:[]) . bracket) n - ++ [m] + fmt p l = + [ bracket p + , bracket l + , bracket fn + ] + ++ maybe [] ((: []) . bracket) n + ++ [m] -------------------------------------------------------------------------------- --- | Package status +-- Package status showFulfillment :: Fulfillment -> T.Text showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n] @@ -214,13 +202,13 @@ dumpFeature = either dumpSometimes dumpAlways dumpAlways :: Always a -> [Fulfillment] dumpAlways (Always _ x) = case x of (Option o _) -> nub $ dataSubfeatureRoot o - _ -> [] + _ -> [] dumpSometimes :: Sometimes a -> [Fulfillment] dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs -------------------------------------------------------------------------------- --- | Wrapper types +-- Wrapper types type AlwaysX = Always (X ()) @@ -233,7 +221,7 @@ type SometimesIO = Sometimes (FIO ()) type Feature a = Either (Sometimes a) (Always a) -------------------------------------------------------------------------------- --- | Feature declaration +-- Feature declaration -- | Feature that is guaranteed to work -- This is composed of sub-features that are tested in order, and if all fail @@ -241,17 +229,20 @@ type Feature a = Either (Sometimes a) (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) +data Always_ a + = Option (SubfeatureRoot a) (Always_ a) | Always_ (FallbackRoot a) -- | Root of a fallback action for an always -- This may either be a lone action or a function that depends on the results -- from other Always features. -data FallbackRoot a = FallbackAlone a +data FallbackRoot a + = FallbackAlone a | forall p. FallbackTree (p -> a) (FallbackStack p) -- | Always features that are used as a payload for a fallback action -data FallbackStack p = FallbackBottom (Always p) +data FallbackStack p + = FallbackBottom (Always p) | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y) -- | Feature that might not be present @@ -276,14 +267,15 @@ type SubfeatureRoot a = Subfeature (Root a) -- | An action and its dependencies -- May be a plain old monad or be DBus-dependent, in which case a client is -- needed -data Root a = forall p. IORoot (p -> a) (IOTree p) +data Root a + = forall p. IORoot (p -> a) (IOTree p) | IORoot_ a IOTree_ | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c) | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c) -- | The dependency tree with rule to merge results when needed -data Tree d d_ p = - forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) +data Tree d d_ p + = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) | And1 (Tree d d_ p) (Tree_ d_) | And2 (Tree_ d_) (Tree d d_ p) | Or (Tree d d_ p) (Tree d d_ p) @@ -294,36 +286,41 @@ data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d -- | Shorthand tree types for lazy typers type IOTree p = Tree IODependency IODependency_ p + type DBusTree c p = Tree IODependency (DBusDependency_ c) p + type IOTree_ = Tree_ IODependency_ + 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 T.Text [Fulfillment] (FIO (Result p)) - -- always yields a payload - | IOConst p - -- an always that yields a payload - | forall a. IOAlways (Always a) (a -> p) - -- a sometimes that yields a payload - | forall a. IOSometimes (Sometimes a) (a -> p) +data IODependency p + = -- an IO action that yields a payload + IORead T.Text [Fulfillment] (FIO (Result p)) + | -- always yields a payload + IOConst p + | -- an always that yields a payload + forall a. IOAlways (Always a) (a -> p) + | -- a sometimes that yields a payload + forall a. IOSometimes (Sometimes a) (a -> p) -- | A dependency pertaining to the DBus -data DBusDependency_ c = Bus [Fulfillment] BusName +data DBusDependency_ c + = Bus [Fulfillment] BusName | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember | DBusIO IODependency_ deriving (Generic) -- | A dependency that only requires IO to evaluate (no payload) -data IODependency_ = IOSystem_ [Fulfillment] SystemDependency +data IODependency_ + = IOSystem_ [Fulfillment] SystemDependency | IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg)) | forall a. IOSometimes_ (Sometimes a) -- | A system component to an IODependency -- This name is dumb, but most constructors should be obvious -data SystemDependency = - Executable Bool FilePath +data SystemDependency + = Executable Bool FilePath | AccessiblePath FilePath Bool Bool | Systemd UnitType T.Text | Process T.Text @@ -333,7 +330,8 @@ data SystemDependency = data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic) -- | Wrapper type to describe and endpoint -data DBusMember = Method_ MemberName +data DBusMember + = Method_ MemberName | Signal_ MemberName | Property_ T.Text deriving (Eq, Show, Generic) @@ -345,7 +343,7 @@ data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord) data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord) -------------------------------------------------------------------------------- --- | Tested dependency tree +-- Tested dependency tree -- -- The main reason I need this is so I have a "result" I can convert to JSON -- and dump on the CLI (unless there is a way to make Aeson work inside an IO) @@ -357,13 +355,14 @@ data Msg = Msg LogLevel T.Text data FMsg = FMsg T.Text (Maybe T.Text) Msg -- | Tested Always feature -data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) +data PostAlways a + = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) | Fallback a [SubfeatureFail] -- | Tested Sometimes feature data PostSometimes a = PostSometimes { psSuccess :: Maybe (SubfeaturePass a) - , psFailed :: [SubfeatureFail] + , psFailed :: [SubfeatureFail] } -- | Passing subfeature @@ -382,21 +381,21 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms' data PostFail = PostFail [Msg] | PostMissing Msg -------------------------------------------------------------------------------- --- | Configuration +-- Configuration type FIO a = RIO DepStage a data DepStage = DepStage - { dsLogFun :: !LogFunc + { dsLogFun :: !LogFunc , dsProcCxt :: !ProcessContext - , dsParams :: !XParams + , dsParams :: !XParams } instance HasLogFunc DepStage where - logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y }) + logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y}) instance HasProcessContext DepStage where - processContextL = lens dsProcCxt (\x y -> x { dsProcCxt = y }) + processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y}) data XParams = XParams { xpLogLevel :: LogLevel @@ -413,61 +412,75 @@ instance FromJSON XParams where ll <- mapLevel <$> o .: fromString "loglevel" fs <- o .: fromString "features" return $ XParams ll fs - where - mapLevel Info = LevelInfo - mapLevel Error = LevelError - mapLevel Warn = LevelWarn - mapLevel Debug = LevelDebug + where + mapLevel Info = LevelInfo + mapLevel Error = LevelError + mapLevel Warn = LevelWarn + mapLevel Debug = LevelDebug data XPFeatures = XPFeatures - { xpfOptimus :: Bool - , xpfVirtualBox :: Bool - , xpfXSANE :: Bool - , xpfEthernet :: Bool - , xpfWireless :: Bool - , xpfVPN :: Bool - , xpfBluetooth :: Bool + { xpfOptimus :: Bool + , xpfVirtualBox :: Bool + , xpfXSANE :: Bool + , xpfEthernet :: Bool + , xpfWireless :: Bool + , xpfVPN :: Bool + , xpfBluetooth :: Bool , xpfIntelBacklight :: Bool , xpfClevoBacklight :: Bool - , xpfBattery :: Bool - , xpfF5VPN :: Bool + , xpfBattery :: Bool + , xpfF5VPN :: Bool } instance FromJSON XPFeatures where - parseJSON = withObject "features" $ \o -> XPFeatures - <$> o .:+ "optimus" - <*> o .:+ "virtualbox" - <*> o .:+ "xsane" - <*> o .:+ "ethernet" - <*> o .:+ "wireless" - <*> o .:+ "vpn" - <*> o .:+ "bluetooth" - <*> o .:+ "intel_backlight" - <*> o .:+ "clevo_backlight" - <*> o .:+ "battery" - <*> o .:+ "f5vpn" + parseJSON = withObject "features" $ \o -> + XPFeatures + <$> o + .:+ "optimus" + <*> o + .:+ "virtualbox" + <*> o + .:+ "xsane" + <*> o + .:+ "ethernet" + <*> o + .:+ "wireless" + <*> o + .:+ "vpn" + <*> o + .:+ "bluetooth" + <*> o + .:+ "intel_backlight" + <*> o + .:+ "clevo_backlight" + <*> o + .:+ "battery" + <*> o + .:+ "f5vpn" defParams :: XParams -defParams = XParams - { xpLogLevel = LevelError - , xpFeatures = defXPFeatures - } +defParams = + XParams + { xpLogLevel = LevelError + , xpFeatures = defXPFeatures + } defXPFeatures :: XPFeatures -defXPFeatures = XPFeatures - { xpfOptimus = False - , xpfVirtualBox = False - , xpfXSANE = False - , xpfEthernet = False - , xpfWireless = False - -- TODO this might be broken down into different flags (expressvpn, etc) - , xpfVPN = False - , xpfBluetooth = False - , xpfIntelBacklight = False - , xpfClevoBacklight = False - , xpfBattery = False - , xpfF5VPN = False - } +defXPFeatures = + XPFeatures + { xpfOptimus = False + , xpfVirtualBox = False + , xpfXSANE = False + , xpfEthernet = False + , xpfWireless = False + , -- TODO this might be broken down into different flags (expressvpn, etc) + xpfVPN = False + , xpfBluetooth = False + , xpfIntelBacklight = False + , xpfClevoBacklight = False + , xpfBattery = False + , xpfF5VPN = False + } type XPQuery = XPFeatures -> Bool @@ -476,8 +489,9 @@ getParams = do p <- getParamFile maybe (return defParams) decodeYaml p where - decodeYaml p = either (\e -> print e >> return defParams) return - =<< decodeFileEither p + decodeYaml p = + either (\e -> print e >> return defParams) return + =<< decodeFileEither p getParamFile :: IO (Maybe FilePath) getParamFile = do @@ -495,20 +509,22 @@ getParamFile = do (.:+) :: Object -> String -> Parser Bool (.:+) o n = o .:? fromString n .!= False -infix .:+ +infix 9 .:+ -------------------------------------------------------------------------------- --- | Testing pipeline +-- Testing pipeline evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg])) evalSometimesMsg (Sometimes n u xs) = do r <- asks (u . xpFeatures . dsParams) - if not r then return $ Left [dis n] else do - PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs - let fs' = failedMsgs n fs - return $ case s of - (Just p) -> Right $ second (++ fs') $ passActMsg n p - _ -> Left fs' + if not r + then return $ Left [dis n] + else do + PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs + let fs' = failedMsgs n fs + return $ case s of + (Just p) -> Right $ second (++ fs') $ passActMsg n p + _ -> Left fs' where dis name = FMsg name Nothing (Msg LevelDebug "feature disabled") @@ -516,18 +532,18 @@ evalAlwaysMsg :: Always a -> FIO (a, [FMsg]) evalAlwaysMsg (Always n x) = do r <- testAlways x return $ case r of - (Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p + (Primary p fs _) -> second (++ failedMsgs n fs) $ passActMsg n p (Fallback act fs) -> (act, failedMsgs n fs) passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg]) -passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn (Just n)) ws) +passActMsg fn Subfeature {sfData = PostPass a ws, sfName = n} = (a, fmap (FMsg fn (Just n)) ws) failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg] failedMsgs n = concatMap (failedMsg n) failedMsg :: T.Text -> SubfeatureFail -> [FMsg] -failedMsg fn Subfeature { sfData = d, sfName = n } = case d of - (PostFail es) -> f es +failedMsg fn Subfeature {sfData = d, sfName = n} = case d of + (PostFail es) -> f es (PostMissing e) -> f [e] where f = fmap (FMsg fn (Just n)) @@ -538,12 +554,12 @@ testAlways = go [] go failed (Option fd next) = do r <- testSubfeature fd case r of - (Left l) -> go (l:failed) next + (Left l) -> go (l : failed) next (Right pass) -> return $ Primary pass failed next go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar evalFallbackRoot :: FallbackRoot a -> FIO a -evalFallbackRoot (FallbackAlone a) = return a +evalFallbackRoot (FallbackAlone a) = return a evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s evalFallbackStack :: FallbackStack p -> FIO p @@ -557,27 +573,30 @@ testSometimes :: Sometimes_ a -> FIO (PostSometimes a) testSometimes = go (PostSometimes Nothing []) where go ts [] = return ts - go ts (x:xs) = do + go ts (x : xs) = do sf <- testSubfeature x case sf of - (Left l) -> go (ts { psFailed = l:psFailed ts }) xs - (Right pass) -> return $ ts { psSuccess = Just pass } + (Left l) -> go (ts {psFailed = l : psFailed ts}) xs + (Right pass) -> return $ ts {psSuccess = Just pass} testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a)) -testSubfeature sf@Subfeature{ sfData = t } = do +testSubfeature sf@Subfeature {sfData = t} = do t' <- testRoot t -- monomorphism restriction :( - return $ bimap (\n -> sf { sfData = n }) (\n -> sf { sfData = n }) t' + return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t' testRoot :: Root a -> FIO (Either PostFail (PostPass a)) testRoot r = do case r of - (IORoot a t) -> go a testIODep_ testIODep t - (IORoot_ a t) -> go_ a testIODep_ t - (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t + (IORoot a t) -> go a testIODep_ testIODep t + (IORoot_ a t) -> go_ a testIODep_ t + (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t - _ -> return $ Left $ PostMissing - $ Msg LevelError "client not available" + _ -> + return $ + Left $ + PostMissing $ + Msg LevelError "client not available" where -- rank N polymorphism is apparently undecidable...gross go a f_ (f :: forall q. d q -> FIO (MResult q)) t = @@ -585,13 +604,15 @@ testRoot r = do go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t -------------------------------------------------------------------------------- --- | Payloaded dependency testing +-- Payloaded dependency testing type Result p = Either [Msg] (PostPass p) type MResult p = Memoized (Result p) -testTree :: forall d d_ p. (d_ -> FIO MResult_) +testTree + :: forall d d_ p + . (d_ -> FIO MResult_) -> (forall q. d q -> FIO (MResult q)) -> Tree d d_ p -> FIO (Either [Msg] (PostPass p)) @@ -610,30 +631,34 @@ testTree test_ test = go go (Or a b) = do ra <- go a either (\ea -> fmap (`addMsgs` ea) <$> go b) (return . Right) ra - go (Only a) = runMemoized =<< test a + go (Only a) = runMemoized =<< test a and2nd f (PostPass pa wa) (PostPass pb wb) = Right $ PostPass (f pa pb) $ wa ++ wb liftRight = either (return . Left) testIODep :: IODependency p -> FIO (MResult p) testIODep d = memoizeMVar $ case d of IORead _ _ t -> t - IOConst c -> return $ Right $ PostPass c [] + IOConst c -> return $ Right $ PostPass c [] -- TODO this is a bit odd because this is a dependency that will always -- succeed, which kinda makes this pointless. The only reason I would want -- this is if I want to have a built-in logic to "choose" a payload to use in -- building a higher-level feature - IOAlways a f -> Right . uncurry PostPass - -- TODO this is wetter than Taco Bell shit - . bimap f (fmap stripMsg) <$> evalAlwaysMsg a - IOSometimes x f -> bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg)) - <$> evalSometimesMsg x + IOAlways a f -> + Right + . uncurry PostPass + -- TODO this is wetter than Taco Bell shit + . bimap f (fmap stripMsg) + <$> evalAlwaysMsg a + IOSometimes x f -> + bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg)) + <$> evalSometimesMsg x stripMsg :: FMsg -> Msg stripMsg (FMsg _ _ m) = m -------------------------------------------------------------------------------- --- | Standalone dependency testing +-- | Standalone dependency testing type Result_ = Either [Msg] [Msg] type MResult_ = Memoized Result_ @@ -642,8 +667,8 @@ testTree_ :: (d -> FIO MResult_) -> Tree_ d -> FIO Result_ testTree_ test = go where go (And_ a b) = either (return . Left) (`test2nd` b) =<< go a - go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a - go (Only_ a) = runMemoized =<< test a + go (Or_ a b) = either (`test2nd` b) (return . Right) =<< go a + go (Only_ a) = runMemoized =<< test a test2nd ws = fmap ((Right . (ws ++)) =<<) . go testIODep_ :: IODependency_ -> FIO MResult_ @@ -652,15 +677,18 @@ testIODep_ d = memoizeMVar $ testIODepNoCache_ d testIODepNoCache_ :: IODependency_ -> FIO Result_ testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t -testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) - <$> evalSometimesMsg x +testIODepNoCache_ (IOSometimes_ x) = + bimap (fmap stripMsg) (fmap stripMsg . snd) + <$> evalSometimesMsg x -------------------------------------------------------------------------------- --- | System Dependency Testing +-- | System Dependency Testing testSysDependency :: SystemDependency -> FIO (Maybe Msg) -testSysDependency (Executable sys bin) = io $ maybe (Just msg) (const Nothing) - <$> findExecutable bin +testSysDependency (Executable sys bin) = + io $ + maybe (Just msg) (const Nothing) + <$> findExecutable bin where msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"] e = if sys then "system" else "local" @@ -668,35 +696,36 @@ testSysDependency (Systemd t n) = shellTest "systemctl" args msg where msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"] args = ["--user" | t == UserUnit] ++ ["status", n] -testSysDependency (Process n) = shellTest "pidof" [n] - $ T.unwords ["Process", singleQuote n, "not found"] +testSysDependency (Process n) = + shellTest "pidof" [n] $ + T.unwords ["Process", singleQuote n, "not found"] testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p where - testPerm False _ _ = Nothing + testPerm False _ _ = Nothing testPerm True f res = Just $ f res mkErr = Just . Msg LevelError - permMsg NotFoundError = mkErr "file not found" - permMsg PermError = mkErr "could not get permissions" + permMsg NotFoundError = mkErr "file not found" + permMsg PermError = mkErr "could not get permissions" permMsg (PermResult res) = case (testPerm r readable res, testPerm w writable res) of (Just False, Just False) -> mkErr "file not readable or writable" - (Just False, _) -> mkErr "file not readable" - (_, Just False) -> mkErr "file not writable" - _ -> Nothing + (Just False, _) -> mkErr "file not readable" + (_, Just False) -> mkErr "file not writable" + _ -> Nothing shellTest :: FilePath -> [T.Text] -> T.Text -> FIO (Maybe Msg) shellTest cmd args msg = do rc <- proc cmd (T.unpack <$> args) (runProcess . setStdout nullStream) return $ case rc of ExitSuccess -> Nothing - _ -> Just $ Msg LevelError msg + _ -> Just $ Msg LevelError msg unitType :: UnitType -> T.Text unitType SystemUnit = "system" -unitType UserUnit = "user" +unitType UserUnit = "user" -------------------------------------------------------------------------------- --- | Font testers +-- Font testers -- -- Make a special case for these since we end up testing the font alot, and it -- would be nice if I can cache them. @@ -706,7 +735,7 @@ fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont where root = IORoot id $ fontTree fam ful -fontSometimes :: T.Text -> T.Text -> [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 @@ -736,7 +765,7 @@ fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"] -- testFont = liftIO . testFont' testFont :: T.Text -> FIO (Result FontBuilder) -testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg +testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg where msg = T.unwords ["font family", qFam, "not found"] args = [qFam] @@ -744,7 +773,7 @@ testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg pass = Right $ PostPass (buildFont $ Just fam) [] -------------------------------------------------------------------------------- --- | Network Testers +-- Network Testers -- -- ASSUME that the system uses systemd in which case ethernet interfaces always -- start with "en" and wireless interfaces always start with "wl" @@ -762,8 +791,9 @@ isEthernet :: T.Text -> Bool isEthernet = T.isPrefixOf "en" listInterfaces :: IO [T.Text] -listInterfaces = fromRight [] - <$> tryIOError (fmap T.pack <$> listDirectory sysfsNet) +listInterfaces = + fromRight [] + <$> tryIOError (fmap T.pack <$> listDirectory sysfsNet) sysfsNet :: FilePath sysfsNet = "/sys/class/net" @@ -777,29 +807,33 @@ readInterface n f = IORead n [] go ns <- filter f <$> listInterfaces case ns of [] -> return $ Left [Msg LevelError "no interfaces found"] - (x:xs) -> do - return $ Right $ PostPass x - $ fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs + (x : xs) -> do + return $ + Right $ + PostPass x $ + fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs -------------------------------------------------------------------------------- --- | Misc testers +-- Misc testers socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_ -socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful - . io . socketExists' +socketExists n ful = + IOTest_ (T.unwords ["test if", n, "socket exists"]) ful + . io + . socketExists' socketExists' :: IO FilePath -> IO (Maybe Msg) socketExists' getPath = do p <- getPath r <- tryIOError $ getFileStatus p return $ case r of - Left e -> toErr $ T.pack $ ioe_description e + 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 LevelError -------------------------------------------------------------------------------- --- | DBus Dependency Testing +-- DBus Dependency Testing introspectInterface :: InterfaceName introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" @@ -814,12 +848,15 @@ testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_ testDBusDepNoCache_ cl (Bus _ bus) = io $ do ret <- callMethod cl queryBus queryPath queryIface queryMem return $ case ret of - Left e -> Left [Msg LevelError e] - Right b -> let ns = bodyGetNames b in - if bus' `elem` ns then Right [] - else Left [ - Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"] - ] + Left e -> Left [Msg LevelError e] + Right b -> + let ns = bodyGetNames b + in if bus' `elem` ns + then Right [] + else + Left + [ Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"] + ] where bus' = T.pack $ formatBusName bus queryBus = busName_ "org.freedesktop.DBus" @@ -827,76 +864,84 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do queryPath = objectPath_ "/" queryMem = memberName_ "ListNames" bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text] - bodyGetNames _ = [] - + bodyGetNames _ = [] testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do ret <- callMethod cl busname objpath introspectInterface introspectMethod return $ case ret of - Left e -> Left [Msg LevelError e] - Right body -> procBody body + Left e -> Left [Msg LevelError e] + Right body -> procBody body where - procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant - =<< listToMaybe body in - case res of - Just True -> Right [] - _ -> Left [Msg LevelError $ fmtMsg' mem] - findMem = fmap (matchMem mem) - . find (\i -> I.interfaceName i == iface) - . I.objectInterfaces - matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods - matchMem (Signal_ n) = elemMember n I.signalName I.interfaceSignals + procBody body = + let res = + findMem + =<< I.parseXML objpath + =<< fromVariant + =<< listToMaybe body + in case res of + Just True -> Right [] + _ -> Left [Msg LevelError $ fmtMsg' mem] + findMem = + fmap (matchMem mem) + . find (\i -> I.interfaceName i == iface) + . 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 (T.pack . I.propertyName) I.interfaceProperties elemMember n fname fmember = elem n . fmap fname . fmember - fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)] - fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)] + 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 $ T.pack $ formatInterfaceName iface - , "on bus" - , T.pack $ formatBusName busname - ] - + fmtMsg' m = + T.unwords + [ "could not find" + , fmtMem m + , "on interface" + , singleQuote $ T.pack $ formatInterfaceName iface + , "on bus" + , T.pack $ formatBusName busname + ] testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i -------------------------------------------------------------------------------- --- | IO Lifting functions +-- IO Lifting functions ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a) ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs ioAlways :: MonadIO m => Always (IO a) -> Always (m a) -ioAlways (Always n x) = Always n $ ioAlways' x +ioAlways (Always n x) = Always n $ ioAlways' x ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a) -ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar +ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a ioFallbackRoot :: MonadIO m => FallbackRoot (IO a) -> FallbackRoot (m a) -ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a +ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a) -ioSubfeature sf = sf { sfData = ioRoot $ sfData sf } +ioSubfeature sf = sf {sfData = ioRoot $ sfData sf} ioRoot :: MonadIO m => Root (IO a) -> Root (m a) -ioRoot (IORoot a t) = IORoot (io . a) t -ioRoot (IORoot_ a t) = IORoot_ (io a) t -ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl +ioRoot (IORoot a t) = IORoot (io . a) t +ioRoot (IORoot_ a t) = IORoot_ (io a) t +ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl -------------------------------------------------------------------------------- --- | Feature constructors +-- Feature constructors sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a -sometimes1_ x fn n t = Sometimes fn x - [Subfeature{ sfData = t, sfName = n }] +sometimes1_ x fn n t = + Sometimes + fn + x + [Subfeature {sfData = t, sfName = n}] 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) +always1_ fn n t x = + Always fn $ + Option (Subfeature {sfData = t, sfName = n}) (Always_ $ FallbackAlone x) sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a sometimes1 = sometimes1_ (const True) @@ -910,22 +955,49 @@ sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t 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 => T.Text -> T.Text -> [Fulfillment] -> Bool - -> FilePath -> Sometimes (m ()) +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 => T.Text -> T.Text -> [Fulfillment] -> Bool - -> FilePath -> [T.Text] -> 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 -> T.Text -> T.Text - -> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a +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) => T.Text -> T.Text - -> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName - -> Maybe c -> Sometimes (m ()) +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 = sometimesDBus cl fn name deps cmd where @@ -933,7 +1005,7 @@ sometimesEndpoint fn name ful busname path iface mem cl = cmd c = io $ void $ callMethod c busname path iface mem -------------------------------------------------------------------------------- --- | Dependency Tree Constructors +-- Dependency Tree Constructors listToAnds :: d -> [d] -> Tree_ d listToAnds i = foldr (And_ . Only_) (Only_ i) @@ -945,20 +1017,20 @@ toFallback :: IODependency p -> p -> Tree IODependency d_ p toFallback a = Or (Only a) . Only . IOConst voidResult :: Result p -> Result_ -voidResult (Left es) = Left es +voidResult (Left es) = Left es voidResult (Right (PostPass _ ws)) = Right ws voidRead :: Result p -> Maybe Msg -voidRead (Left []) = Just $ Msg LevelError "unspecified error" -voidRead (Left (e:_)) = Just e -voidRead (Right _) = Nothing +voidRead (Left []) = Just $ Msg LevelError "unspecified error" +voidRead (Left (e : _)) = Just e +voidRead (Right _) = Nothing readResult_ :: Maybe Msg -> Result_ readResult_ (Just w) = Left [w] -readResult_ _ = Right [] +readResult_ _ = Right [] -------------------------------------------------------------------------------- --- | IO Dependency Constructors +-- IO Dependency Constructors exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_ exe b ful = IOSystem_ ful . Executable b @@ -994,59 +1066,62 @@ process :: [Fulfillment] -> T.Text -> IODependency_ process ful = IOSystem_ ful . Process -------------------------------------------------------------------------------- --- | Dependency data for JSON +-- Dependency data for JSON type DependencyData = [Fulfillment] dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData -dataSubfeatureRoot Subfeature { sfData = r } = dataRoot r +dataSubfeatureRoot Subfeature {sfData = r} = dataRoot r dataRoot :: Root a -> DependencyData -dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t -dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t -dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t +dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t +dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t +dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t -dataTree :: forall d d_ p. (forall q. d q -> DependencyData) - -> (d_ -> DependencyData) -> Tree d d_ p -> DependencyData +dataTree + :: forall d d_ p + . (forall q. d q -> DependencyData) + -> (d_ -> DependencyData) + -> Tree d d_ p + -> DependencyData dataTree f f_ = go where go :: forall q. Tree d d_ q -> DependencyData go (And12 _ a b) = go a ++ go b - go (And1 a b) = go a ++ dataTree_ f_ b - go (And2 a b) = dataTree_ f_ a ++ go b - go (Or a _) = go a - go (Only d) = f d + go (And1 a b) = go a ++ dataTree_ f_ b + go (And2 a b) = dataTree_ f_ a ++ go b + go (Or a _) = go a + go (Only d) = f d dataTree_ :: (d_ -> DependencyData) -> Tree_ d_ -> DependencyData dataTree_ f_ = go where go (And_ a b) = go a ++ go b - go (Or_ a _) = go a - go (Only_ d) = f_ d + go (Or_ a _) = go a + go (Only_ d) = f_ d dataIODependency :: IODependency p -> DependencyData dataIODependency d = case d of - (IORead _ f _) -> f + (IORead _ f _) -> f (IOSometimes x _) -> dumpSometimes x - (IOAlways x _) -> dumpAlways x - _ -> [] + (IOAlways x _) -> dumpAlways x + _ -> [] dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ d = case d of - (IOSystem_ f _) -> f - (IOTest_ _ f _) -> f + (IOSystem_ f _) -> f + (IOTest_ _ f _) -> f (IOSometimes_ x) -> dumpSometimes x dataDBusDependency :: DBusDependency_ c -> DependencyData dataDBusDependency d = case d of - (Bus f _) -> f - (Endpoint f _ _ _ _) -> f - (DBusIO x) -> dataIODependency_ x + (Bus f _) -> f + (Endpoint f _ _ _ _) -> f + (DBusIO x) -> dataIODependency_ x -------------------------------------------------------------------------------- --- | JSON formatting +-- formatting 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 2fb2477..d4333bd 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Dmenu (Rofi) Commands +-- Dmenu (Rofi) Commands module XMonad.Internal.Command.DMenu ( runCmdMenu @@ -15,32 +15,28 @@ module XMonad.Internal.Command.DMenu , runBTMenu , runShowKeys , runAutorandrMenu - ) where + ) +where -import Data.Internal.DBus -import Data.Internal.Dependency - -import DBus - -import Graphics.X11.Types - -import qualified RIO.Text as T - -import System.Directory - ( XdgDirectory (..) - , getXdgDirectory - ) -import System.IO - -import XMonad.Core hiding (spawn) -import XMonad.Internal.Command.Desktop -import XMonad.Internal.DBus.Common -import XMonad.Internal.Notify -import XMonad.Internal.Shell -import XMonad.Util.NamedActions +import DBus +import Data.Internal.DBus +import Data.Internal.Dependency +import Graphics.X11.Types +import qualified RIO.Text as T +import System.Directory + ( XdgDirectory (..) + , getXdgDirectory + ) +import System.IO +import XMonad.Core hiding (spawn) +import XMonad.Internal.Command.Desktop +import XMonad.Internal.DBus.Common +import XMonad.Internal.Notify +import XMonad.Internal.Shell +import XMonad.Util.NamedActions -------------------------------------------------------------------------------- --- | DMenu executables +-- DMenu executables myDmenuCmd :: FilePath myDmenuCmd = "rofi" @@ -67,7 +63,7 @@ myClipboardManager :: FilePath myClipboardManager = "greenclip" -------------------------------------------------------------------------------- --- | Packages +-- Packages dmenuPkgs :: [Fulfillment] dmenuPkgs = [Package Official "rofi"] @@ -76,7 +72,7 @@ clipboardPkgs :: [Fulfillment] clipboardPkgs = [Package AUR "rofi-greenclip"] -------------------------------------------------------------------------------- --- | Other internal functions +-- Other internal functions spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX spawnDmenuCmd n = @@ -98,7 +94,7 @@ dmenuDep :: IODependency_ dmenuDep = sysExe dmenuPkgs myDmenuCmd -------------------------------------------------------------------------------- --- | Exported Commands +-- Exported Commands -- TODO test that veracrypt and friends are installed runDevMenu :: SometimesX @@ -107,28 +103,38 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x t = dmenuTree $ Only_ (localExe [] myDmenuDevices) x = do c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall" - spawnCmd myDmenuDevices - $ ["-c", T.pack c] - ++ "--" : themeArgs "#999933" - ++ myDmenuMatchingArgs + spawnCmd myDmenuDevices $ + ["-c", T.pack c] + ++ "--" + : themeArgs "#999933" + ++ myDmenuMatchingArgs -- TODO test that bluetooth interface exists runBTMenu :: SometimesX -runBTMenu = Sometimes "bluetooth selector" xpfBluetooth - [Subfeature (IORoot_ cmd tree) "rofi bluetooth"] +runBTMenu = + Sometimes + "bluetooth selector" + xpfBluetooth + [Subfeature (IORoot_ cmd tree) "rofi bluetooth"] where - cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb" + cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb" tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth runVPNMenu :: SometimesX -runVPNMenu = Sometimes "VPN selector" xpfVPN - [Subfeature (IORoot_ cmd tree) "rofi VPN"] +runVPNMenu = + Sometimes + "VPN selector" + xpfVPN + [Subfeature (IORoot_ cmd tree) "rofi VPN"] where - cmd = spawnCmd myDmenuVPN - $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs - tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN) - $ socketExists "expressVPN" [] - $ return "/var/lib/expressvpn/expressvpnd.socket" + cmd = + spawnCmd myDmenuVPN $ + ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs + tree = + dmenuTree $ + toAnd_ (localExe [] myDmenuVPN) $ + socketExists "expressVPN" [] $ + return "/var/lib/expressvpn/expressvpnd.socket" runCmdMenu :: SometimesX runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] @@ -140,15 +146,20 @@ runWinMenu :: SometimesX runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runNetMenu :: Maybe SysClient -> SometimesX -runNetMenu cl = Sometimes "network control menu" enabled - [Subfeature root "network control menu"] +runNetMenu cl = + Sometimes + "network control menu" + enabled + [Subfeature root "network control menu"] where enabled f = xpfEthernet f || xpfWireless f || xpfVPN f root = DBusRoot_ cmd tree cl cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333" - tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) - $ toAnd_ (DBusIO dmenuDep) $ DBusIO - $ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks + tree = + And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $ + toAnd_ (DBusIO dmenuDep) $ + DBusIO $ + sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks runAutorandrMenu :: SometimesX runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd @@ -157,47 +168,63 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors -------------------------------------------------------------------------------- --- | Password manager +-- Password manager runBwMenu :: Maybe SesClient -> SometimesX runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd where - cmd _ = spawnCmd myDmenuPasswords - $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs - tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") - $ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords) + cmd _ = + spawnCmd myDmenuPasswords $ + ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs + tree = + And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $ + toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords) -------------------------------------------------------------------------------- --- | Clipboard +-- Clipboard runClipMenu :: SometimesX runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act where act = spawnCmd myDmenuCmd args - tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager - , process [] $ T.pack myClipboardManager - ] - args = [ "-modi", "\"clipboard:greenclip print\"" - , "-show", "clipboard" - , "-run-command", "'{cmd}'" - ] ++ themeArgs "#00c44e" + tree = + listToAnds + dmenuDep + [ sysExe clipboardPkgs myClipboardManager + , process [] $ T.pack myClipboardManager + ] + args = + [ "-modi" + , "\"clipboard:greenclip print\"" + , "-show" + , "clipboard" + , "-run-command" + , "'{cmd}'" + ] + ++ themeArgs "#00c44e" -------------------------------------------------------------------------------- --- | Shortcut menu +-- Shortcut menu runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) -runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_ - $ FallbackAlone fallback +runShowKeys = + Always "keyboard menu" $ + Option showKeysDMenu $ + Always_ $ + FallbackAlone fallback where -- TODO this should technically depend on dunst - fallback = const $ spawnNotify - $ defNoteError { body = Just $ Text "could not display keymap" } + fallback = + const $ + spawnNotify $ + defNoteError {body = Just $ Text "could not display keymap"} showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ()) -showKeysDMenu = Subfeature - { sfName = "keyboard shortcut menu" - , sfData = IORoot_ showKeys $ Only_ dmenuDep - } +showKeysDMenu = + Subfeature + { sfName = "keyboard shortcut menu" + , sfData = IORoot_ showKeys $ Only_ dmenuDep + } showKeys :: [((KeyMask, KeySym), NamedAction)] -> X () showKeys kbs = do @@ -205,5 +232,8 @@ showKeys kbs = do io $ hPutStr h $ unlines $ showKm kbs io $ hClose h where - cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] - ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs + cmd = + fmtCmd myDmenuCmd $ + ["-dmenu", "-p", "commands"] + ++ themeArgs "#7f66ff" + ++ myDmenuMatchingArgs diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 6a4d00c..7efebab 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -1,12 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | General commands +-- General commands module XMonad.Internal.Command.Desktop ( myTerm , playSound - -- commands , runTerm , runTMux @@ -33,37 +32,32 @@ module XMonad.Internal.Command.Desktop , runNotificationCloseAll , runNotificationHistory , runNotificationContext - -- daemons , runNetAppDaemon - -- packages , networkManagerPkgs - ) where + ) +where -import Data.Internal.DBus -import Data.Internal.Dependency - -import DBus - -import RIO -import RIO.FilePath -import qualified RIO.Process as P -import qualified RIO.Text as T - -import System.Directory -import System.Environment -import System.Posix.User - -import XMonad.Actions.Volume -import XMonad.Core hiding (spawn) -import XMonad.Internal.DBus.Common -import XMonad.Internal.Notify -import XMonad.Internal.Shell as S -import XMonad.Operations +import DBus +import Data.Internal.DBus +import Data.Internal.Dependency +import RIO +import RIO.FilePath +import qualified RIO.Process as P +import qualified RIO.Text as T +import System.Directory +import System.Environment +import System.Posix.User +import XMonad.Actions.Volume +import XMonad.Core hiding (spawn) +import XMonad.Internal.DBus.Common +import XMonad.Internal.Notify +import XMonad.Internal.Shell as S +import XMonad.Operations -------------------------------------------------------------------------------- --- | My Executables +-- My Executables myTerm :: FilePath myTerm = "urxvt" @@ -96,12 +90,13 @@ myNotificationCtrl :: FilePath myNotificationCtrl = "dunstctl" -------------------------------------------------------------------------------- --- | Packages +-- Packages myTermPkgs :: [Fulfillment] -myTermPkgs = [ Package Official "rxvt-unicode" - , Package Official "urxvt-perls" - ] +myTermPkgs = + [ Package Official "rxvt-unicode" + , Package Official "urxvt-perls" + ] myEditorPkgs :: [Fulfillment] myEditorPkgs = [Package Official "emacs-nativecomp"] @@ -116,13 +111,13 @@ networkManagerPkgs :: [Fulfillment] networkManagerPkgs = [Package Official "networkmanager"] -------------------------------------------------------------------------------- --- | Misc constants +-- Misc constants volumeChangeSound :: FilePath volumeChangeSound = "smb_fireball.wav" -------------------------------------------------------------------------------- --- | Some nice apps +-- Some nice apps runTerm :: SometimesX runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm @@ -130,12 +125,14 @@ runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm runTMux :: SometimesX runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act where - deps = listToAnds (socketExists "tmux" [] socketName) - $ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"] - act = S.spawn - $ fmtCmd "tmux" ["has-session"] - #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] - #!|| fmtNotifyCmd defNoteError { body = Just $ Text msg } + deps = + listToAnds (socketExists "tmux" [] socketName) $ + fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"] + act = + S.spawn $ + fmtCmd "tmux" ["has-session"] + #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] + #!|| fmtNotifyCmd defNoteError {body = Just $ Text msg} c = "exec tmux attach-session -d" msg = "could not connect to tmux session" socketName = do @@ -150,28 +147,46 @@ runCalc = sometimesIO_ "calculator" "bc" deps act act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"] runBrowser :: SometimesX -runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"] - False myBrowser +runBrowser = + sometimesExe + "web browser" + "brave" + [Package AUR "brave-bin"] + False + myBrowser runEditor :: SometimesX runEditor = sometimesIO_ "text editor" "emacs" tree cmd where - cmd = spawnCmd myEditor - ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] + cmd = + spawnCmd + myEditor + ["-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 [] $ T.pack myEditorServer runFileManager :: SometimesX -runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"] - True "pcmanfm" +runFileManager = + sometimesExe + "file browser" + "pcmanfm" + [Package Official "pcmanfm"] + True + "pcmanfm" -------------------------------------------------------------------------------- --- | Multimedia Commands +-- Multimedia Commands runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX -runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control") - "playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd] +runMultimediaIfInstalled n cmd = + sometimesExeArgs + (T.append n " multimedia control") + "playerctl" + [Package Official "playerctl"] + True + myMultimediaCtl + [cmd] runTogglePlay :: SometimesX runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" @@ -186,7 +201,7 @@ runStopPlay :: SometimesX runStopPlay = runMultimediaIfInstalled "stop playback" "stop" -------------------------------------------------------------------------------- --- | Volume Commands +-- Volume Commands soundDir :: FilePath soundDir = "sound" @@ -200,8 +215,8 @@ playSound file = do featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX featureSound n file pre post = - sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree - $ pre >> playSound file >> post + 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 -- to play sound (duh) but libpulse is the package with the paplay binary @@ -217,16 +232,18 @@ runVolumeMute :: SometimesX runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return () -------------------------------------------------------------------------------- --- | Notification control +-- Notification control runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX runNotificationCmd n arg cl = sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd where cmd _ = spawnCmd myNotificationCtrl [arg] - tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) - $ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") - $ Method_ $ memberName_ "NotificationAction" + tree = + toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $ + Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $ + Method_ $ + memberName_ "NotificationAction" runNotificationClose :: Maybe SesClient -> SometimesX runNotificationClose = runNotificationCmd "close notification" "close" @@ -244,47 +261,61 @@ runNotificationContext = runNotificationCmd "open notification context" "context" -------------------------------------------------------------------------------- --- | System commands +-- System commands -- this is required for some vpn's to work properly with network-manager runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ())) -runNetAppDaemon cl = Sometimes "network applet" xpfVPN - [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"] +runNetAppDaemon cl = + Sometimes + "network applet" + xpfVPN + [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"] where tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet" cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True) runToggleBluetooth :: Maybe SysClient -> SometimesX -runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth - [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"] +runToggleBluetooth cl = + Sometimes + "bluetooth toggle" + xpfBluetooth + [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"] where tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus) - cmd _ = S.spawn - $ fmtCmd myBluetooth ["show"] - #!| "grep -q \"Powered: no\"" - #!&& "a=on" - #!|| "a=off" - #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } + cmd _ = + S.spawn $ + fmtCmd myBluetooth ["show"] + #!| "grep -q \"Powered: no\"" + #!&& "a=on" + #!|| "a=off" + #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] + #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"} runToggleEthernet :: SometimesX -runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet - [Subfeature root "nmcli"] +runToggleEthernet = + Sometimes + "ethernet toggle" + xpfEthernet + [Subfeature root "nmcli"] where - root = IORoot cmd $ And1 (Only readEthernet) $ Only_ - $ sysExe networkManagerPkgs "nmcli" + root = + IORoot cmd $ + And1 (Only readEthernet) $ + Only_ $ + sysExe networkManagerPkgs "nmcli" -- TODO make this less noisy - cmd iface = S.spawn - $ fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface] - #!| "grep -q disconnected" - #!&& "a=connect" - #!|| "a=disconnect" - #!>> fmtCmd "nmcli" ["device", "$a", iface] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } + cmd iface = + S.spawn $ + fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface] + #!| "grep -q disconnected" + #!&& "a=connect" + #!|| "a=disconnect" + #!>> fmtCmd "nmcli" ["device", "$a", iface] + #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"} -------------------------------------------------------------------------------- --- | Configuration commands +-- Configuration commands runRestart :: X () runRestart = restart "xmonad" True @@ -294,14 +325,14 @@ runRecompile :: X () runRecompile = do -- assume that the conf directory contains a valid stack project confDir <- asks (cfgDir . directories) - spawn - $ fmtCmd "cd" [T.pack confDir] - #!&& fmtCmd "stack" ["install"] - #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" } - #!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" } + spawn $ + fmtCmd "cd" [T.pack confDir] + #!&& fmtCmd "stack" ["install"] + #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"} + #!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"} -------------------------------------------------------------------------------- --- | Screen capture commands +-- Screen capture commands getCaptureDir :: IO FilePath getCaptureDir = do @@ -321,8 +352,10 @@ 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) - $ Bus [] $ busName_ "org.flameshot.Flameshot" + tree = + toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $ + Bus [] $ + busName_ "org.flameshot.Flameshot" -- TODO this will steal focus from the current window (and puts it -- in the root window?) ...need to fix @@ -338,7 +371,10 @@ runScreenCapture :: Maybe SesClient -> SometimesX runScreenCapture = runFlameshot "screen capture" "screen" runCaptureBrowser :: SometimesX -runCaptureBrowser = sometimesIO_ "screen capture browser" "feh" - (Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do - dir <- io getCaptureDir - spawnCmd myImageBrowser [T.pack dir] +runCaptureBrowser = sometimesIO_ + "screen capture browser" + "feh" + (Only_ $ sysExe [Package Official "feh"] myImageBrowser) + $ do + dir <- io getCaptureDir + spawnCmd myImageBrowser [T.pack dir] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index f9a83b2..a26ac1f 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Commands for controlling power +-- Commands for controlling power module XMonad.Internal.Command.Power - -- commands +-- commands ( runHibernate , runOptimusPrompt , runPowerOff @@ -14,10 +14,8 @@ module XMonad.Internal.Command.Power , runSuspend , runSuspendPrompt , runQuitPrompt - -- daemons , runAutolock - -- functions , hasBattery , suspendPrompt @@ -25,32 +23,27 @@ module XMonad.Internal.Command.Power , powerPrompt , defFontPkgs , promptFontDep - ) where + ) +where -import Data.Internal.Dependency - -import Data.Either -import qualified Data.Map as M - -import Graphics.X11.Types - -import RIO -import RIO.FilePath -import qualified RIO.Process as P -import qualified RIO.Text as T - -import System.Directory -import System.IO.Error - -import XMonad.Core hiding (spawn) -import XMonad.Internal.Shell -import qualified XMonad.Internal.Theme as XT -import XMonad.Prompt -import XMonad.Prompt.ConfirmPrompt +import Data.Either +import Data.Internal.Dependency +import qualified Data.Map as M +import Graphics.X11.Types +import RIO +import RIO.FilePath +import qualified RIO.Process as P +import qualified RIO.Text as T +import System.Directory +import System.IO.Error +import XMonad.Core hiding (spawn) +import XMonad.Internal.Shell +import qualified XMonad.Internal.Theme as XT +import XMonad.Prompt +import XMonad.Prompt.ConfirmPrompt -------------------------------------------------------------------------------- --- | Executables - +-- Executables myScreenlock :: FilePath myScreenlock = "screenlock" @@ -61,17 +54,22 @@ myPrimeOffload :: FilePath myPrimeOffload = "prime-offload" -------------------------------------------------------------------------------- --- | Packages +-- Packages optimusPackages :: [Fulfillment] optimusPackages = [Package AUR "optimus-manager"] -------------------------------------------------------------------------------- --- | Core commands +-- Core commands runScreenLock :: SometimesX -runScreenLock = sometimesExe "screen locker" "i3lock script" - [Package AUR "i3lock-color"] False myScreenlock +runScreenLock = + sometimesExe + "screen locker" + "i3lock script" + [Package AUR "i3lock-color"] + False + myScreenlock runPowerOff :: X () runPowerOff = spawn "systemctl poweroff" @@ -86,17 +84,19 @@ runReboot :: X () runReboot = spawn "systemctl reboot" -------------------------------------------------------------------------------- --- | Autolock +-- Autolock runAutolock :: Sometimes (FIO (P.Process () () ())) runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd where - tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") - $ Only_ $ IOSometimes_ runScreenLock + tree = + And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $ + Only_ $ + IOSometimes_ runScreenLock cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True) -------------------------------------------------------------------------------- --- | Confirmation prompts +-- Confirmation prompts promptFontDep :: IOTree XT.FontBuilder promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs @@ -124,7 +124,7 @@ runQuitPrompt :: SometimesX runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt -------------------------------------------------------------------------------- --- | Nvidia Optimus +-- Nvidia Optimus -- TODO for some reason the screen never wakes up after suspend when -- the nvidia card is up, so block suspend if nvidia card is running @@ -148,30 +148,36 @@ runOptimusPrompt' fb = do where switch mode = confirmPrompt' (prompt mode) (cmd mode) fb prompt mode = T.concat ["gpu switch to ", mode, "?"] - cmd mode = spawn - $ T.pack myPrimeOffload - #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"] - #!&& "killall xmonad" + cmd mode = + spawn $ + T.pack myPrimeOffload + #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"] + #!&& "killall xmonad" runOptimusPrompt :: SometimesX -runOptimusPrompt = Sometimes "graphics switcher" - (\x -> xpfOptimus x && xpfBattery x) [s] +runOptimusPrompt = + Sometimes + "graphics switcher" + (\x -> xpfOptimus x && xpfBattery x) + [s] where - s = Subfeature { sfData = r, sfName = "optimus manager" } + s = Subfeature {sfData = r, sfName = "optimus manager"} r = IORoot runOptimusPrompt' t - t = And1 promptFontDep - $ listToAnds (socketExists "optimus-manager" [] socketName) - $ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload] + t = + And1 promptFontDep $ + listToAnds (socketExists "optimus-manager" [] socketName) $ + sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload] socketName = ( "optimus-manager") <$> getTemporaryDirectory -------------------------------------------------------------------------------- --- | Universal power prompt +-- Universal power prompt -data PowerMaybeAction = Poweroff - | Shutdown - | Hibernate - | Reboot - deriving (Eq) +data PowerMaybeAction + = Poweroff + | Shutdown + | Hibernate + | Reboot + deriving (Eq) instance Enum PowerMaybeAction where toEnum 0 = Poweroff @@ -180,15 +186,15 @@ instance Enum PowerMaybeAction where toEnum 3 = Reboot toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument" - fromEnum Poweroff = 0 - fromEnum Shutdown = 1 + fromEnum Poweroff = 0 + fromEnum Shutdown = 1 fromEnum Hibernate = 2 - fromEnum Reboot = 3 + fromEnum Reboot = 3 data PowerPrompt = PowerPrompt instance XPrompt PowerPrompt where - showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" + showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" runPowerPrompt :: SometimesX runPowerPrompt = Sometimes "power prompt" (const True) [sf] @@ -202,20 +208,22 @@ powerPrompt :: X () -> XT.FontBuilder -> X () powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction where comp = mkComplFunFromList theme [] - theme = (XT.promptTheme fb) { promptKeymap = keymap } - keymap = M.fromList - $ ((controlMask, xK_g), quit) : - map (first $ (,) 0) - [ (xK_p, sendMaybeAction Poweroff) - , (xK_s, sendMaybeAction Shutdown) - , (xK_h, sendMaybeAction Hibernate) - , (xK_r, sendMaybeAction Reboot) - , (xK_Return, quit) - , (xK_Escape, quit) - ] + theme = (XT.promptTheme fb) {promptKeymap = keymap} + keymap = + M.fromList $ + ((controlMask, xK_g), quit) + : map + (first $ (,) 0) + [ (xK_p, sendMaybeAction Poweroff) + , (xK_s, sendMaybeAction Shutdown) + , (xK_h, sendMaybeAction Hibernate) + , (xK_r, sendMaybeAction Reboot) + , (xK_Return, quit) + , (xK_Escape, quit) + ] sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True executeMaybeAction a = case toEnum $ read a of - Poweroff -> runPowerOff - Shutdown -> lock >> runSuspend + Poweroff -> runPowerOff + Shutdown -> lock >> runSuspend Hibernate -> lock >> runHibernate - Reboot -> runReboot + Reboot -> runReboot diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index 485ecd9..d32edee 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -1,38 +1,37 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Concurrent module to handle events from acpid +-- Concurrent module to handle events from acpid module XMonad.Internal.Concurrent.ACPIEvent ( runPowermon , runHandleACPI - ) where + ) +where -import Data.Internal.Dependency - -import Network.Socket -import Network.Socket.ByteString - -import RIO -import qualified RIO.ByteString as B - -import XMonad.Core -import XMonad.Internal.Command.Power -import XMonad.Internal.Concurrent.ClientMessage -import XMonad.Internal.Shell -import XMonad.Internal.Theme (FontBuilder) +import Data.Internal.Dependency +import Network.Socket +import Network.Socket.ByteString +import RIO +import qualified RIO.ByteString as B +import XMonad.Core +import XMonad.Internal.Command.Power +import XMonad.Internal.Concurrent.ClientMessage +import XMonad.Internal.Shell +import XMonad.Internal.Theme (FontBuilder) -------------------------------------------------------------------------------- --- | Data structure to hold the ACPI events I care about +-- Data structure to hold the ACPI events I care about -- -- Enumerate so these can be converted to strings and back when sent in a -- ClientMessage event to X -data ACPIEvent = Power - | Sleep - | LidClose - deriving (Eq) +data ACPIEvent + = Power + | Sleep + | LidClose + deriving (Eq) instance Enum ACPIEvent where toEnum 0 = Power @@ -40,24 +39,24 @@ instance Enum ACPIEvent where toEnum 2 = LidClose toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument" - fromEnum Power = 0 - fromEnum Sleep = 1 + fromEnum Power = 0 + fromEnum Sleep = 1 fromEnum LidClose = 2 -------------------------------------------------------------------------------- --- | Internal functions +-- Internal functions -- | Convert a string to an ACPI event (this string is assumed to come from -- the acpid socket) parseLine :: ByteString -> Maybe ACPIEvent parseLine line = case splitLine line of - (_:"PBTN":_) -> Just Power - (_:"PWRF":_) -> Just Power - (_:"SLPB":_) -> Just Sleep - (_:"SBTN":_) -> Just Sleep - (_:"LID":"close":_) -> Just LidClose - _ -> Nothing + (_ : "PBTN" : _) -> Just Power + (_ : "PWRF" : _) -> Just Power + (_ : "SLPB" : _) -> Just Sleep + (_ : "SBTN" : _) -> Just Sleep + (_ : "LID" : "close" : _) -> Just LidClose + _ -> Nothing where splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse newline = 10 @@ -71,7 +70,7 @@ isDischarging :: IO (Maybe Bool) isDischarging = do status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status" case status of - Left _ -> return Nothing + Left _ -> return Nothing Right s -> return $ Just (s == "Discharging") listenACPI :: IO () @@ -103,7 +102,7 @@ handleACPI fb lock tag = do lock -------------------------------------------------------------------------------- --- | Exported API +-- Exported API -- | Spawn a new thread that will listen for ACPI events on the acpid socket -- and send ClientMessage events when it receives them @@ -114,7 +113,9 @@ runHandleACPI :: Always (String -> X ()) runHandleACPI = Always "ACPI event handler" $ Option sf fallback where sf = Subfeature withLock "acpid prompt" - withLock = IORoot (uncurry handleACPI) - $ And12 (,) promptFontDep $ Only - $ IOSometimes runScreenLock id + withLock = + IORoot (uncurry handleACPI) $ + And12 (,) promptFontDep $ + Only $ + IOSometimes runScreenLock id fallback = Always_ $ FallbackAlone $ const skip diff --git a/lib/XMonad/Internal/Concurrent/ClientMessage.hs b/lib/XMonad/Internal/Concurrent/ClientMessage.hs index d5ee052..37e85c9 100644 --- a/lib/XMonad/Internal/Concurrent/ClientMessage.hs +++ b/lib/XMonad/Internal/Concurrent/ClientMessage.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- --- | Core ClientMessage module to 'achieve' concurrency in XMonad +-- Core ClientMessage module to 'achieve' concurrency in XMonad -- -- Since XMonad is single threaded, the only way to have multiple threads that -- listen/react to non-X events is to spawn other threads the run outside of @@ -16,50 +16,50 @@ -- much like something from X even though it isn't module XMonad.Internal.Concurrent.ClientMessage - ( XMsgType(..) + ( XMsgType (..) , sendXMsg , splitXMsg - ) where + ) +where -import Data.Char - -import Graphics.X11.Types -import Graphics.X11.Xlib.Atom -import Graphics.X11.Xlib.Display -import Graphics.X11.Xlib.Event -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xlib.Types - -import RIO hiding (Display) +import Data.Char +import Graphics.X11.Types +import Graphics.X11.Xlib.Atom +import Graphics.X11.Xlib.Display +import Graphics.X11.Xlib.Event +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xlib.Types +import RIO hiding (Display) -------------------------------------------------------------------------------- --- | Data structure for the ClientMessage +-- Data structure for the ClientMessage -- -- These are the "types" of client messages to send; add more here as needed -- TODO is there a way to do this in the libraries that import this one? -data XMsgType = ACPI - | Workspace - | Unknown - deriving (Eq, Show) +data XMsgType + = ACPI + | Workspace + | Unknown + deriving (Eq, Show) instance Enum XMsgType where toEnum 0 = ACPI toEnum 1 = Workspace toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument" - fromEnum ACPI = 0 + fromEnum ACPI = 0 fromEnum Workspace = 1 - fromEnum Unknown = 2 + fromEnum Unknown = 2 -------------------------------------------------------------------------------- --- | Exported API +-- Exported API -- | Given a string from the data field in a ClientMessage event, return the -- type and payload splitXMsg :: (Integral a) => [a] -> (XMsgType, String) splitXMsg [] = (Unknown, "") -splitXMsg (x:xs) = (xtype, tag) +splitXMsg (x : xs) = (xtype, tag) where xtype = toEnum $ fromIntegral x tag = chr . fromIntegral <$> takeWhile (/= 0) xs @@ -91,7 +91,7 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do -- longer will be clipped to 19, and anything less than 19 will be padded -- with 0 (note this used to be random garbage before). See this function -- for more details. - setClientMessageEvent' e root bITMAP 8 (x:t) + setClientMessageEvent' e root bITMAP 8 (x : t) sendEvent dpy root False substructureNotifyMask e where x = fromIntegral $ fromEnum xtype diff --git a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs index 4944611..d5e1c13 100644 --- a/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs +++ b/lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- --- | Automatically Manage Dynamic Workspaces +-- Automatically Manage Dynamic Workspaces -- This is a somewhat convoluted wrapper for the Dymamic Workspaces module -- in the contrib library. The general behavior this allows: -- 1) launch app @@ -24,72 +24,66 @@ -- 3) Virtualbox (should always be by itself anyways) module XMonad.Internal.Concurrent.DynamicWorkspaces - ( DynWorkspace(..) + ( DynWorkspace (..) , appendShift , appendViewShift , removeDynamicWorkspace , runWorkspaceMon , spawnOrSwitch , doSink - ) where - -import Data.List (deleteBy, find) -import qualified Data.Map as M -import Data.Maybe + ) +where -- import Control.Concurrent -import Control.Monad -import Control.Monad.Reader - - -import Graphics.X11.Types - -import Graphics.X11.Xlib.Atom -import Graphics.X11.Xlib.Display -import Graphics.X11.Xlib.Event -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xlib.Misc -import Graphics.X11.Xlib.Types - -import RIO hiding - ( Display - , display - ) -import qualified RIO.Set as S - -import System.Process - -import XMonad.Actions.DynamicWorkspaces -import XMonad.Core - ( ManageHook - , WorkspaceId - , X - , io - , withWindowSet - ) -import XMonad.Hooks.ManageHelpers (MaybeManageHook) -import XMonad.Internal.Concurrent.ClientMessage -import XMonad.Internal.IO -import XMonad.ManageHook -import XMonad.Operations -import qualified XMonad.StackSet as W +import Control.Monad +import Control.Monad.Reader +import Data.List (deleteBy, find) +import qualified Data.Map as M +import Data.Maybe +import Graphics.X11.Types +import Graphics.X11.Xlib.Atom +import Graphics.X11.Xlib.Display +import Graphics.X11.Xlib.Event +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xlib.Misc +import Graphics.X11.Xlib.Types +import RIO hiding + ( Display + , display + ) +import qualified RIO.Set as S +import System.Process +import XMonad.Actions.DynamicWorkspaces +import XMonad.Core + ( ManageHook + , WorkspaceId + , X + , io + , withWindowSet + ) +import XMonad.Hooks.ManageHelpers (MaybeManageHook) +import XMonad.Internal.Concurrent.ClientMessage +import XMonad.Internal.IO +import XMonad.ManageHook +import XMonad.Operations +import qualified XMonad.StackSet as W -------------------------------------------------------------------------------- --- | Dynamic Workspace datatype --- This hold all the data needed to tie an app to a particular dynamic workspace +-- Dynamic Workspace datatype +-- This holds all the data needed to tie an app to a particular dynamic workspace data DynWorkspace = DynWorkspace - { dwName :: String - , dwTag :: WorkspaceId - , dwClass :: String - , dwHook :: [MaybeManageHook] - , dwKey :: Char - , dwCmd :: Maybe (X ()) - -- TODO this should also have the layout for this workspace - } + { dwName :: String + , dwTag :: WorkspaceId + , dwClass :: String + , dwHook :: [MaybeManageHook] + , dwKey :: Char + , dwCmd :: Maybe (X ()) + -- TODO this should also have the layout for this workspace + } -------------------------------------------------------------------------------- --- | Manager thread +-- Manager thread -- The main thread that watches for new windows. When a match is found, this -- thread spawns a new thread the waits for the PID of the window to exit. When -- the PID exits, it sends a ClientMessage event to X @@ -99,10 +93,10 @@ data DynWorkspace = DynWorkspace -- type MatchTags = M.Map String String data WConf = WConf - { display :: Display - , dynWorkspaces :: [DynWorkspace] - , curPIDs :: MVar (S.Set Pid) - } + { display :: Display + , dynWorkspaces :: [DynWorkspace] + , curPIDs :: MVar (S.Set Pid) + } type W a = RIO WConf () @@ -120,51 +114,56 @@ runWorkspaceMon dws = withOpenDisplay $ \dpy -> do where withEvents dpy e = do ps <- newMVar S.empty - let c = WConf { display = dpy, dynWorkspaces = dws, curPIDs = ps } - runRIO c - $ forever - $ handleEvent =<< io (nextEvent dpy e >> getEvent e) + let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps} + runRIO c $ + forever $ + handleEvent =<< io (nextEvent dpy e >> getEvent e) handleEvent :: Event -> W () -- | assume this fires at least once when a new window is created (also could -- use CreateNotify but that is really noisy) -handleEvent MapNotifyEvent { ev_window = w } = do +handleEvent MapNotifyEvent {ev_window = w} = do dpy <- asks display hint <- io $ getClassHint dpy w dws <- asks dynWorkspaces - let tag = M.lookup (resClass hint) - $ M.fromList - $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws + let tag = + M.lookup (resClass hint) $ + M.fromList $ + fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws forM_ tag $ \t -> do a <- io $ internAtom dpy "_NET_WM_PID" False pid <- io $ getWindowProperty32 dpy a w case pid of -- ASSUMPTION windows will only have one PID at one time Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t - _ -> return () - + _ -> return () handleEvent _ = return () withUniquePid :: Pid -> String -> W () withUniquePid pid tag = do ps <- asks curPIDs pids <- readMVar ps - io $ unless (pid `elem` pids) $ bracket_ - (modifyMVar_ ps (return . S.insert pid)) - (modifyMVar_ ps (return . S.delete pid)) + io + $ unless (pid `elem` pids) + $ bracket_ + (modifyMVar_ ps (return . S.insert pid)) + (modifyMVar_ ps (return . S.delete pid)) $ waitUntilExit pid >> sendXMsg Workspace tag -------------------------------------------------------------------------------- --- | Launching apps +-- Launching apps -- When launching apps on dymamic workspaces, first check if they are running -- and launch if not, then switch to their workspace - wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool -wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack) - -- list of all workspaces with windows on them - -- TODO is there not a better way to do this? - $ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws) +wsOccupied tag ws = + elem tag $ + map W.tag $ + filter (isJust . W.stack) + -- list of all workspaces with windows on them + -- TODO is there not a better way to do this? + $ + W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws) spawnOrSwitch :: WorkspaceId -> X () -> X () spawnOrSwitch tag cmd = do @@ -172,7 +171,7 @@ spawnOrSwitch tag cmd = do if occupied then windows $ W.view tag else cmd -------------------------------------------------------------------------------- --- | Managehook +-- Managehook -- Move windows to new workspace if they are part of a dynamic workspace -- shamelessly ripped off from appendWorkspace (this analogue doesn't exist) @@ -193,29 +192,31 @@ appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag -- TODO surprisingly this doesn't exist? We shouldn't need to TBH doSink :: ManageHook doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of - Just s' -> W.sink (W.focus s') s - Nothing -> s + Just s' -> W.sink (W.focus s') s + Nothing -> s -------------------------------------------------------------------------------- --- | Eventhook +-- Eventhook + -- When an app is closed, this will respond the event that is sent in the main -- XMonad thread - removeDynamicWorkspace :: WorkspaceId -> X () removeDynamicWorkspace target = windows removeIfEmpty where -- remove workspace if it is empty and if there are hidden workspaces - removeIfEmpty s@W.StackSet { W.visible = vis, W.hidden = hall@(h:hs) } + removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)} -- if hidden, delete from hidden - | Just x <- find isEmptyTarget hall - = s { W.hidden = deleteBy (eq W.tag) x hall } + | Just x <- find isEmptyTarget hall = + s {W.hidden = deleteBy (eq W.tag) x hall} -- if visible, delete from visible and move first hidden to its place - | Just x <- find (isEmptyTarget . W.workspace) vis - = s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis - , W.hidden = hs } + | Just x <- find (isEmptyTarget . W.workspace) vis = + s + { W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis + , W.hidden = hs + } -- if current, move the first hidden workspace to the current - | isEmptyTarget $ W.workspace $ W.current s - = s { W.current = (W.current s) { W.workspace = h }, W.hidden = hs } + | isEmptyTarget $ W.workspace $ W.current s = + s {W.current = (W.current s) {W.workspace = h}, W.hidden = hs} -- otherwise do nothing | otherwise = s removeIfEmpty s = s diff --git a/lib/XMonad/Internal/Concurrent/VirtualBox.hs b/lib/XMonad/Internal/Concurrent/VirtualBox.hs index 7d1f857..6940e60 100644 --- a/lib/XMonad/Internal/Concurrent/VirtualBox.hs +++ b/lib/XMonad/Internal/Concurrent/VirtualBox.hs @@ -1,25 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- --- | VirtualBox-specific functions +-- VirtualBox-specific functions module XMonad.Internal.Concurrent.VirtualBox ( vmExists , vmInstanceConfig , qual - ) where + ) +where -import Data.Internal.Dependency - -import Text.XML.Light - -import RIO hiding (try) -import RIO.Directory -import RIO.FilePath -import qualified RIO.Text as T - -import XMonad.Internal.Shell +import Data.Internal.Dependency +import RIO hiding (try) +import RIO.Directory +import RIO.FilePath +import qualified RIO.Text as T +import Text.XML.Light +import XMonad.Internal.Shell vmExists :: T.Text -> IO (Maybe Msg) vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm @@ -32,7 +30,7 @@ vmInstanceConfig vmName = do findInstance dir = do res <- findFile [dir] path return $ case res of - Just p -> Right p + Just p -> Right p Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName vmDirectory :: IO (Either String String) @@ -41,15 +39,17 @@ vmDirectory = do s <- tryIO $ readFile p return $ case s of (Left _) -> Left "could not read VirtualBox config file" - (Right x) -> maybe (Left "Could not parse VirtualBox config file") Right - $ findDir =<< parseXMLDoc x + (Right x) -> + maybe (Left "Could not parse VirtualBox config file") Right $ + findDir =<< parseXMLDoc x where - findDir e = findAttr (unqual "defaultMachineFolder") - =<< findChild (qual e "SystemProperties") - =<< findChild (qual e "Global") e + findDir e = + findAttr (unqual "defaultMachineFolder") + =<< findChild (qual e "SystemProperties") + =<< findChild (qual e "Global") e qual :: Element -> String -> QName -qual e n = (elName e) { qName = n } +qual e n = (elName e) {qName = n} vmConfig :: IO FilePath vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml" diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 3395f4b..c673898 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | DBus module for Clevo Keyboard control +-- DBus module for Clevo Keyboard control module XMonad.Internal.DBus.Brightness.ClevoKeyboard ( callGetBrightnessCK @@ -10,24 +10,21 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard , clevoKeyboardControls , clevoKeyboardSignalDep , blPath - ) where + ) +where -import Control.Monad (when) - -import Data.Int (Int32) -import Data.Internal.DBus -import Data.Internal.Dependency - -import DBus - -import RIO.FilePath - -import XMonad.Internal.DBus.Brightness.Common -import XMonad.Internal.IO +import Control.Monad (when) +import DBus +import Data.Int (Int32) +import Data.Internal.DBus +import Data.Internal.Dependency +import RIO.FilePath +import XMonad.Internal.DBus.Brightness.Common +import XMonad.Internal.IO -------------------------------------------------------------------------------- --- | Low level sysfs functions --- +-- Low level sysfs functions + type Brightness = Float type RawBrightness = Int32 @@ -84,7 +81,7 @@ decBrightness bounds = do return b -------------------------------------------------------------------------------- --- | DBus interface +-- DBus interface blPath :: ObjectPath blPath = objectPath_ "/clevo_keyboard" @@ -93,21 +90,22 @@ interface :: InterfaceName interface = interfaceName_ "org.xmonad.Brightness" clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness -clevoKeyboardConfig = BrightnessConfig - { bcMin = minBrightness - , bcMax = maxBrightness - , bcInc = incBrightness - , bcDec = decBrightness - , bcGet = getBrightness - , bcGetMax = return maxRawBrightness - , bcMinRaw = minRawBrightness - , bcPath = blPath - , bcInterface = interface - , bcName = "Clevo keyboard" - } +clevoKeyboardConfig = + BrightnessConfig + { bcMin = minBrightness + , bcMax = maxBrightness + , bcInc = incBrightness + , bcDec = decBrightness + , bcGet = getBrightness + , bcGetMax = return maxRawBrightness + , bcMinRaw = minRawBrightness + , bcPath = blPath + , bcInterface = interface + , bcName = "Clevo keyboard" + } -------------------------------------------------------------------------------- --- | Exported haskell API +-- Exported haskell API stateFileDep :: IODependency_ stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"] @@ -119,8 +117,12 @@ clevoKeyboardSignalDep :: DBusDependency_ SesClient clevoKeyboardSignalDep = signalDep clevoKeyboardConfig exportClevoKeyboard :: Maybe SesClient -> SometimesIO -exportClevoKeyboard = brightnessExporter xpfClevoBacklight [] - [stateFileDep, brightnessFileDep] clevoKeyboardConfig +exportClevoKeyboard = + brightnessExporter + xpfClevoBacklight + [] + [stateFileDep, brightnessFileDep] + clevoKeyboardConfig clevoKeyboardControls :: Maybe SesClient -> BrightnessControls clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 8146055..e767c77 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -1,35 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | DBus module for DBus brightness controls +-- DBus module for DBus brightness controls module XMonad.Internal.DBus.Brightness.Common - ( BrightnessConfig(..) - , BrightnessControls(..) + ( BrightnessConfig (..) + , BrightnessControls (..) , brightnessControls , brightnessExporter , callGetBrightness , matchSignal , signalDep - ) where + ) +where -import Control.Monad (void) - -import Data.Int (Int32) -import Data.Internal.DBus -import Data.Internal.Dependency - -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 +import Control.Monad (void) +import DBus +import DBus.Client +import qualified DBus.Introspection as I +import Data.Int (Int32) +import Data.Internal.DBus +import Data.Internal.Dependency +import qualified RIO.Text as T +import XMonad.Core (io) +import XMonad.Internal.DBus.Common -------------------------------------------------------------------------------- --- | External API +-- External API -- -- Define four methods to increase, decrease, maximize, or minimize the -- brightness. These methods will all return the current brightness as a 32-bit @@ -37,16 +34,16 @@ import XMonad.Internal.DBus.Common -- is one method to get the current brightness. data BrightnessConfig a b = BrightnessConfig - { bcMin :: (a, a) -> IO b - , bcMax :: (a, a) -> IO b - , bcDec :: (a, a) -> IO b - , bcInc :: (a, a) -> IO b - , bcGet :: (a, a) -> IO b - , bcMinRaw :: a - , bcGetMax :: IO a - , bcPath :: ObjectPath + { bcMin :: (a, a) -> IO b + , bcMax :: (a, a) -> IO b + , bcDec :: (a, a) -> IO b + , bcInc :: (a, a) -> IO b + , bcGet :: (a, a) -> IO b + , bcMinRaw :: a + , bcGetMax :: IO a + , bcPath :: ObjectPath , bcInterface :: InterfaceName - , bcName :: T.Text + , bcName :: T.Text } data BrightnessControls = BrightnessControls @@ -56,46 +53,63 @@ data BrightnessControls = BrightnessControls , bctlDec :: SometimesX } -brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient +brightnessControls + :: XPQuery + -> BrightnessConfig a b + -> Maybe SesClient -> BrightnessControls brightnessControls q bc cl = BrightnessControls - { bctlMax = cb "max brightness" memMax - , bctlMin = cb "min brightness" memMin - , bctlInc = cb "increase brightness" memInc - , bctlDec = cb "decrease brightness" memDec - } + { bctlMax = cb "max brightness" memMax + , bctlMin = cb "min brightness" memMin + , bctlInc = cb "increase brightness" memInc + , bctlDec = cb "decrease brightness" memDec + } where cb = callBacklight q cl bc -callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c +callGetBrightness + :: (SafeClient c, Num n) + => BrightnessConfig a b + -> c -> IO (Maybe n) -callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = +callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client = either (const Nothing) bodyGetBrightness - <$> callMethod client xmonadBusName p i memGet + <$> callMethod client xmonadBusName p i memGet signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient -signalDep BrightnessConfig { bcPath = p, bcInterface = i } = +signalDep BrightnessConfig {bcPath = p, bcInterface = i} = Endpoint [] xmonadBusName p i $ Signal_ memCur -matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b - -> (Maybe n-> IO ()) -> c -> IO () -matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = +matchSignal + :: (SafeClient c, Num n) + => BrightnessConfig a b + -> (Maybe n -> IO ()) + -> c + -> IO () +matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb = void . addMatchCallback brMatcher (cb . bodyGetBrightness) where -- TODO add busname to this - brMatcher = matchAny - { matchPath = Just p - , matchInterface = Just i - , matchMember = Just memCur - } + brMatcher = + matchAny + { matchPath = Just p + , matchInterface = Just i + , matchMember = Just memCur + } -------------------------------------------------------------------------------- --- | Internal DBus Crap +-- Internal DBus Crap -brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_] - -> BrightnessConfig a b -> Maybe SesClient -> SometimesIO -brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl = +brightnessExporter + :: RealFrac b + => XPQuery + -> [Fulfillment] + -> [IODependency_] + -> BrightnessConfig a b + -> Maybe SesClient + -> SometimesIO +brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl = Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"] where root = DBusRoot_ (exportBrightnessControls' bc) tree cl @@ -108,51 +122,66 @@ exportBrightnessControls' bc cl = io $ do let bounds = (bcMinRaw bc, maxval) let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds let funget = bcGet bc - export ses (bcPath bc) defaultInterface - { interfaceName = bcInterface bc - , interfaceMethods = - [ autoMethod' memMax bcMax - , autoMethod' memMin bcMin - , autoMethod' memInc bcInc - , autoMethod' memDec bcDec - , autoMethod memGet (round <$> funget bounds :: IO Int32) - ] - , interfaceSignals = [sig] - } - where - sig = I.Signal - { I.signalName = memCur - , I.signalArgs = - [ - I.SignalArg - { I.signalArgName = "brightness" - , I.signalArgType = TypeInt32 - } - ] + export + ses + (bcPath bc) + defaultInterface + { interfaceName = bcInterface bc + , interfaceMethods = + [ autoMethod' memMax bcMax + , autoMethod' memMin bcMin + , autoMethod' memInc bcInc + , autoMethod' memDec bcDec + , autoMethod memGet (round <$> funget bounds :: IO Int32) + ] + , interfaceSignals = [sig] } + where + sig = + I.Signal + { I.signalName = memCur + , I.signalArgs = + [ I.SignalArg + { I.signalArgName = "brightness" + , I.signalArgType = TypeInt32 + } + ] + } emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO () -emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = - emit client $ sig { signalBody = [toVariant (round cur :: Int32)] } +emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur = + emit client $ sig {signalBody = [toVariant (round cur :: Int32)]} where sig = signal p i memCur -callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text - -> MemberName -> SometimesX -callBacklight q cl BrightnessConfig { bcPath = p - , bcInterface = i - , bcName = n } controlName m = - 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 +callBacklight + :: XPQuery + -> Maybe SesClient + -> BrightnessConfig a b + -> T.Text + -> MemberName + -> SometimesX +callBacklight + q + cl + BrightnessConfig + { bcPath = p + , bcInterface = i + , bcName = n + } + controlName + m = + 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 bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) -bodyGetBrightness _ = Nothing +bodyGetBrightness _ = Nothing -------------------------------------------------------------------------------- --- | DBus Members +-- DBus Members memCur :: MemberName memCur = memberName_ "CurrentBrightness" diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 9c29cae..21a3f94 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | DBus module for Intel Backlight control +-- DBus module for Intel Backlight control module XMonad.Internal.DBus.Brightness.IntelBacklight ( callGetBrightnessIB @@ -10,22 +10,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight , intelBacklightControls , intelBacklightSignalDep , blPath - ) where + ) +where -import Data.Int (Int32) -import Data.Internal.DBus -import Data.Internal.Dependency - -import DBus - -import RIO.FilePath - -import XMonad.Internal.DBus.Brightness.Common -import XMonad.Internal.IO +import DBus +import Data.Int (Int32) +import Data.Internal.DBus +import Data.Internal.Dependency +import RIO.FilePath +import XMonad.Internal.DBus.Brightness.Common +import XMonad.Internal.IO -------------------------------------------------------------------------------- --- | Low level sysfs functions --- +-- Low level sysfs functions + type Brightness = Float type RawBrightness = Int32 @@ -66,7 +64,7 @@ decBrightness :: RawBounds -> IO Brightness decBrightness = decPercent steps curFile -------------------------------------------------------------------------------- --- | DBus interface +-- DBus interface blPath :: ObjectPath blPath = objectPath_ "/intelbacklight" @@ -75,21 +73,22 @@ interface :: InterfaceName interface = interfaceName_ "org.xmonad.Brightness" intelBacklightConfig :: BrightnessConfig RawBrightness Brightness -intelBacklightConfig = BrightnessConfig - { bcMin = minBrightness - , bcMax = maxBrightness - , bcInc = incBrightness - , bcDec = decBrightness - , bcGet = getBrightness - , bcGetMax = getMaxRawBrightness - , bcMinRaw = minRawBrightness - , bcPath = blPath - , bcInterface = interface - , bcName = "Intel backlight" - } +intelBacklightConfig = + BrightnessConfig + { bcMin = minBrightness + , bcMax = maxBrightness + , bcInc = incBrightness + , bcDec = decBrightness + , bcGet = getBrightness + , bcGetMax = getMaxRawBrightness + , bcMinRaw = minRawBrightness + , bcPath = blPath + , bcInterface = interface + , bcName = "Intel backlight" + } -------------------------------------------------------------------------------- --- | Exported haskell API +-- Exported haskell API curFileDep :: IODependency_ curFileDep = pathRW curFile [] @@ -101,8 +100,12 @@ intelBacklightSignalDep :: DBusDependency_ SesClient intelBacklightSignalDep = signalDep intelBacklightConfig exportIntelBacklight :: Maybe SesClient -> SometimesIO -exportIntelBacklight = brightnessExporter xpfIntelBacklight [] - [curFileDep, maxFileDep] intelBacklightConfig +exportIntelBacklight = + brightnessExporter + xpfIntelBacklight + [] + [curFileDep, maxFileDep] + intelBacklightConfig intelBacklightControls :: Maybe SesClient -> BrightnessControls intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 4fb4b0a..65c6006 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- --- | High-level interface for managing XMonad's DBus +-- High-level interface for managing XMonad's DBus module XMonad.Internal.DBus.Common ( xmonadBusName @@ -7,9 +7,10 @@ module XMonad.Internal.DBus.Common , notifyBus , notifyPath , networkManagerBus - ) where + ) +where -import DBus +import DBus xmonadBusName :: BusName xmonadBusName = busName_ "org.xmonad" @@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications" networkManagerBus :: BusName networkManagerBus = busName_ "org.freedesktop.NetworkManager" - diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 719a4c4..cc910e6 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -1,11 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- --- | High-level interface for managing XMonad's DBus +-- High-level interface for managing XMonad's DBus module XMonad.Internal.DBus.Control ( Client - , DBusState(..) + , DBusState (..) , connectDBus , connectDBusX , disconnectDBus @@ -15,33 +15,31 @@ module XMonad.Internal.DBus.Control , withDBusClient_ , disconnect , dbusExporters - ) where + ) +where -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency - -import DBus -import DBus.Client - -import XMonad.Internal.DBus.Brightness.ClevoKeyboard -import XMonad.Internal.DBus.Brightness.IntelBacklight -import XMonad.Internal.DBus.Common -import XMonad.Internal.DBus.Screensaver +import Control.Monad +import DBus +import DBus.Client +import Data.Internal.DBus +import Data.Internal.Dependency +import XMonad.Internal.DBus.Brightness.ClevoKeyboard +import XMonad.Internal.DBus.Brightness.IntelBacklight +import XMonad.Internal.DBus.Common +import XMonad.Internal.DBus.Screensaver -- | Current connections to the DBus (session and system buses) data DBusState = DBusState - { dbSesClient :: Maybe SesClient - , dbSysClient :: Maybe SysClient - } + { dbSesClient :: Maybe SesClient + , dbSysClient :: Maybe SysClient + } -- | Connect to the DBus connectDBus :: IO DBusState connectDBus = do ses <- getDBusClient sys <- getDBusClient - return DBusState { dbSesClient = ses, dbSysClient = sys } + return DBusState {dbSesClient = ses, dbSysClient = sys} -- | Disconnect from the DBus disconnectDBus :: DBusState -> IO () @@ -73,11 +71,13 @@ requestXMonadName :: SesClient -> IO () requestXMonadName ses = do res <- requestName (toClient ses) xmonadBusName [] -- TODO if the client is not released on shutdown the owner will be different - let msg | res == NamePrimaryOwner = Nothing - | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn - | res == NameInQueue - || res == NameExists = Just $ "another process owns " ++ xn - | otherwise = Just $ "unknown error when requesting " ++ xn + let msg + | res == NamePrimaryOwner = Nothing + | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn + | res == NameInQueue + || res == NameExists = + Just $ "another process owns " ++ xn + | otherwise = Just $ "unknown error when requesting " ++ xn forM_ msg putStrLn where xn = "'" ++ formatBusName xmonadBusName ++ "'" diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index e891314..87c0766 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -1,24 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Module for monitoring removable drive events +-- Module for monitoring removable drive events -- -- Currently, its only purpose is to play Super Mario sounds when a drive is -- inserted or removed. Why? Because I can. module XMonad.Internal.DBus.Removable (runRemovableMon) where -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency -import Data.Map.Strict (Map, member) - -import DBus -import DBus.Client - -import XMonad.Core (io) -import XMonad.Internal.Command.Desktop +import Control.Monad +import DBus +import DBus.Client +import Data.Internal.DBus +import Data.Internal.Dependency +import Data.Map.Strict (Map, member) +import XMonad.Core (io) +import XMonad.Internal.Command.Desktop bus :: BusName bus = busName_ "org.freedesktop.UDisks2" @@ -51,22 +48,29 @@ driveRemovedSound :: FilePath driveRemovedSound = "smb_pipe.wav" ruleUdisks :: MatchRule -ruleUdisks = matchAny - { matchPath = Just path - , matchInterface = Just interface - } +ruleUdisks = + matchAny + { matchPath = Just path + , matchInterface = Just interface + } driveFlag :: String driveFlag = "org.freedesktop.UDisks2.Drive" addedHasDrive :: [Variant] -> Bool -addedHasDrive [_, a] = maybe False (member driveFlag) - (fromVariant a :: Maybe (Map String (Map String Variant))) +addedHasDrive [_, a] = + maybe + False + (member driveFlag) + (fromVariant a :: Maybe (Map String (Map String Variant))) addedHasDrive _ = False removedHasDrive :: [Variant] -> Bool -removedHasDrive [_, a] = maybe False (driveFlag `elem`) - (fromVariant a :: Maybe [String]) +removedHasDrive [_, a] = + maybe + False + (driveFlag `elem`) + (fromVariant a :: Maybe [String]) removedHasDrive _ = False playSoundMaybe :: FilePath -> Bool -> IO () @@ -81,8 +85,10 @@ listenDevices cl = do addMatch' memAdded driveInsertedSound addedHasDrive addMatch' memRemoved driveRemovedSound removedHasDrive where - addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m } - $ playSoundMaybe p . f . signalBody + addMatch' m p f = + void $ + addMatch (toClient cl) ruleUdisks {matchMember = Just m} $ + playSoundMaybe p . f . signalBody runRemovableMon :: Maybe SysClient -> SometimesIO runRemovableMon cl = diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 81e8bab..a38a7f2 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | DBus module for X11 screensave/DPMS control +-- DBus module for X11 screensave/DPMS control module XMonad.Internal.DBus.Screensaver ( exportScreensaver @@ -9,25 +9,22 @@ module XMonad.Internal.DBus.Screensaver , callQuery , matchSignal , ssSignalDep - ) where + ) +where -import Data.Internal.DBus -import Data.Internal.Dependency - -import RIO - -import DBus -import DBus.Client -import qualified DBus.Introspection as I - -import Graphics.X11.XScreenSaver -import Graphics.X11.Xlib.Display - -import XMonad.Internal.DBus.Common -import XMonad.Internal.Shell +import DBus +import DBus.Client +import qualified DBus.Introspection as I +import Data.Internal.DBus +import Data.Internal.Dependency +import Graphics.X11.XScreenSaver +import Graphics.X11.Xlib.Display +import RIO +import XMonad.Internal.DBus.Common +import XMonad.Internal.Shell -------------------------------------------------------------------------------- --- | Low-level functions +-- Low-level functions type SSState = Bool -- true is enabled @@ -50,13 +47,13 @@ query = do xssi <- xScreenSaverQueryInfo dpy closeDisplay dpy return $ case xssi of - Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False - Just XScreenSaverInfo { xssi_state = _ } -> True + Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False + Just XScreenSaverInfo {xssi_state = _} -> True -- TODO handle errors better (at least log them?) - Nothing -> False + Nothing -> False -------------------------------------------------------------------------------- --- | DBus Interface +-- DBus Interface -- -- Define a methods to toggle the screensaver. This methods will emit signal -- with the new state when called. Define another method to get the current @@ -81,51 +78,64 @@ sigCurrentState :: Signal sigCurrentState = signal ssPath interface memState ruleCurrentState :: MatchRule -ruleCurrentState = matchAny - { matchPath = Just ssPath - , matchInterface = Just interface - , matchMember = Just memState - } +ruleCurrentState = + matchAny + { matchPath = Just ssPath + , matchInterface = Just interface + , matchMember = Just memState + } emitState :: Client -> SSState -> IO () -emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant sss] } +emitState client sss = emit client $ sigCurrentState {signalBody = [toVariant sss]} bodyGetCurrentState :: [Variant] -> Maybe SSState bodyGetCurrentState [b] = fromVariant b :: Maybe SSState -bodyGetCurrentState _ = Nothing +bodyGetCurrentState _ = Nothing -------------------------------------------------------------------------------- --- | Exported haskell API +-- Exported haskell API exportScreensaver :: Maybe SesClient -> SometimesIO exportScreensaver ses = sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd where - cmd cl = let cl' = toClient cl in - liftIO $ export cl' ssPath defaultInterface - { interfaceName = interface - , interfaceMethods = - [ autoMethod memToggle $ emitState cl' =<< toggle - , autoMethod memQuery query - ] - , interfaceSignals = [sig] - } - sig = I.Signal - { I.signalName = memState - , I.signalArgs = - [ - I.SignalArg - { I.signalArgName = "enabled" - , I.signalArgType = TypeBoolean - } - ] - } + cmd cl = + let cl' = toClient cl + in liftIO $ + export + cl' + ssPath + defaultInterface + { interfaceName = interface + , interfaceMethods = + [ autoMethod memToggle $ emitState cl' =<< toggle + , autoMethod memQuery query + ] + , interfaceSignals = [sig] + } + sig = + I.Signal + { I.signalName = memState + , I.signalArgs = + [ I.SignalArg + { I.signalArgName = "enabled" + , I.signalArgType = TypeBoolean + } + ] + } bus = Bus [] xmonadBusName ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable callToggle :: Maybe SesClient -> SometimesX -callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" [] - xmonadBusName ssPath interface memToggle +callToggle = + sometimesEndpoint + "screensaver toggle" + "dbus switch" + [] + xmonadBusName + ssPath + interface + memToggle callQuery :: SesClient -> IO (Maybe SSState) callQuery ses = do @@ -133,8 +143,12 @@ callQuery ses = do return $ either (const Nothing) bodyGetCurrentState reply matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO () -matchSignal cb ses = void $ addMatchCallback ruleCurrentState - (cb . bodyGetCurrentState) ses +matchSignal cb ses = + void $ + addMatchCallback + ruleCurrentState + (cb . bodyGetCurrentState) + ses ssSignalDep :: DBusDependency_ SesClient ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState diff --git a/lib/XMonad/Internal/IO.hs b/lib/XMonad/Internal/IO.hs index 00e212f..ed6a8a9 100644 --- a/lib/XMonad/Internal/IO.hs +++ b/lib/XMonad/Internal/IO.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ViewPatterns #-} -------------------------------------------------------------------------------- --- | Random IO-ish functions used throughtout xmonad +-- Random IO-ish functions used throughtout xmonad -- -- Most (probably all) of these functions are intended to work with sysfs where -- some safe assumptions can be made about file contents. @@ -19,32 +19,31 @@ module XMonad.Internal.IO , incPercent -- , isReadable -- , isWritable - , PermResult(..) + , PermResult (..) , getPermissionsSafe , waitUntilExit - ) where + ) +where -import Data.Char -import Data.Text (pack, unpack) -import Data.Text.IO as T (readFile, writeFile) - -import RIO -import RIO.Directory -import RIO.FilePath - -import System.IO.Error +import Data.Char +import Data.Text (pack, unpack) +import Data.Text.IO as T (readFile, writeFile) +import RIO +import RIO.Directory +import RIO.FilePath +import System.IO.Error -------------------------------------------------------------------------------- --- | read +-- read readInt :: (Read a, Integral a) => FilePath -> IO a readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile readBool :: FilePath -> IO Bool -readBool = fmap (==(1 :: Int)) . readInt +readBool = fmap (== (1 :: Int)) . readInt -------------------------------------------------------------------------------- --- | write +-- write writeInt :: (Show a, Integral a) => FilePath -> a -> IO () writeInt f = T.writeFile f . pack . show @@ -53,16 +52,16 @@ writeBool :: FilePath -> Bool -> IO () writeBool f b = writeInt f ((if b then 1 else 0) :: Int) -------------------------------------------------------------------------------- --- | percent-based read/write +-- percent-based read/write -- -- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing -- value. Assume that the file being read has a min of 0 and an unchanging max -- given by a runtime argument, which is scaled linearly to the range 0-100 -- (percent). - rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c rawToPercent (lower, upper) raw = 100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower) + -- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b @@ -71,12 +70,14 @@ readPercent bounds path = do return $ rawToPercent bounds (i :: Integer) percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c -percentToRaw (lower, upper) perc = round $ - fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower) +percentToRaw (lower, upper) perc = + round $ + fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower) writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b writePercent bounds path perc = do - let t | perc > 100 = 100 + let t + | perc > 100 = 100 | perc < 0 = 0 | otherwise = perc writeInt path (percentToRaw bounds t :: Int) @@ -88,9 +89,15 @@ writePercentMin bounds path = writePercent bounds path 0 writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b writePercentMax bounds path = writePercent bounds path 100 -shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath - -> (a, a) -> IO b -shiftPercent f steps path bounds = writePercent bounds path . f stepsize +shiftPercent + :: (Integral a, RealFrac b) + => (b -> b -> b) + -> Int + -> FilePath + -> (a, a) + -> IO b +shiftPercent f steps path bounds = + writePercent bounds path . f stepsize =<< readPercent bounds path where stepsize = 100 / fromIntegral steps @@ -102,7 +109,7 @@ decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b decPercent = shiftPercent subtract -- silly (-) operator thingy error -------------------------------------------------------------------------------- --- | permission query +-- permission query data PermResult a = PermResult a | NotFoundError | PermError deriving (Show, Eq) @@ -116,12 +123,12 @@ getPermissionsSafe :: FilePath -> IO (PermResult Permissions) getPermissionsSafe f = do r <- tryIOError $ getPermissions f return $ case r of - Right z -> PermResult z - Left (isPermissionError -> True) -> PermError + Right z -> PermResult z + Left (isPermissionError -> True) -> PermError Left (isDoesNotExistError -> True) -> NotFoundError -- the above error should be the only ones thrown by getPermission, -- so the catchall case should never happen - _ -> error "Unknown permission error" + _ -> error "Unknown permission error" -- isReadable :: FilePath -> IO (PermResult Bool) -- isReadable = fmap (fmap readable) . getPermissionsSafe diff --git a/lib/XMonad/Internal/Notify.hs b/lib/XMonad/Internal/Notify.hs index f4063f2..cd2f540 100644 --- a/lib/XMonad/Internal/Notify.hs +++ b/lib/XMonad/Internal/Notify.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Functions for formatting and sending notifications +-- Functions for formatting and sending notifications -- -- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for -- notifications (just formation them into 'notify-send' commands and spawn a @@ -9,42 +9,45 @@ -- decide to switch to using the DBus it will be easy. module XMonad.Internal.Notify - ( Note(..) - , Body(..) + ( Note (..) + , Body (..) , defNote , defNoteInfo , defNoteError , fmtNotifyCmd , spawnNotify - ) where + ) +where -import DBus.Notify - -import RIO -import qualified RIO.Text as T - -import XMonad.Internal.Shell +import DBus.Notify +import RIO +import qualified RIO.Text as T +import XMonad.Internal.Shell -------------------------------------------------------------------------------- --- | Some nice default notes +-- Some nice default notes defNote :: Note -defNote = blankNote { summary = "\"xmonad\"" } +defNote = blankNote {summary = "\"xmonad\""} defNoteInfo :: Note -defNoteInfo = defNote - { appImage = Just $ Icon "dialog-information-symbolic" } +defNoteInfo = + defNote + { appImage = Just $ Icon "dialog-information-symbolic" + } defNoteError :: Note -defNoteError = defNote - { appImage = Just $ Icon "dialog-error-symbolic" } +defNoteError = + defNote + { appImage = Just $ Icon "dialog-error-symbolic" + } -------------------------------------------------------------------------------- --- | Format a 'notify-send' command to be send to the shell +-- Format a 'notify-send' command to be send to the shell parseBody :: Body -> Maybe T.Text parseBody (Text s) = Just $ T.pack s -parseBody _ = Nothing +parseBody _ = Nothing fmtNotifyCmd :: Note -> T.Text fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs @@ -56,8 +59,8 @@ fmtNotifyArgs :: Note -> [T.Text] fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n where -- TODO add the rest of the options as needed - getSummary = (:[]) . doubleQuote . T.pack . summary + getSummary = (: []) . doubleQuote . T.pack . summary getIcon n' = - maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }]) - $ appImage 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/Process.hs b/lib/XMonad/Internal/Process.hs deleted file mode 100644 index 1e493d6..0000000 --- a/lib/XMonad/Internal/Process.hs +++ /dev/null @@ -1,17 +0,0 @@ --------------------------------------------------------------------------------- --- | Functions for managing processes - -module XMonad.Internal.Process where - --- import Control.Exception --- import Control.Monad --- import Control.Monad.IO.Class - --- import qualified RIO.Text as T - --- import System.Exit --- import System.IO --- import System.Process - --- import XMonad.Core hiding (spawn) - diff --git a/lib/XMonad/Internal/Shell.hs b/lib/XMonad/Internal/Shell.hs index 00264ee..d44249f 100644 --- a/lib/XMonad/Internal/Shell.hs +++ b/lib/XMonad/Internal/Shell.hs @@ -1,7 +1,7 @@ --- | Functions for formatting and spawning shell commands - {-# LANGUAGE OverloadedStrings #-} +-- Functions for formatting and spawning shell commands + module XMonad.Internal.Shell ( fmtCmd , spawnCmd @@ -17,15 +17,14 @@ module XMonad.Internal.Shell , (#!||) , (#!|) , (#!>>) - ) where - -import RIO -import qualified RIO.Text as T + ) +where +import RIO +import qualified RIO.Text as T import qualified System.Process.Typed as P - -import qualified XMonad.Core as X -import qualified XMonad.Util.Run as XR +import qualified XMonad.Core as X +import qualified XMonad.Util.Run as XR -- | Fork a new process and wait for its exit code. -- diff --git a/lib/XMonad/Internal/Theme.hs b/lib/XMonad/Internal/Theme.hs index 165b75a..4e38c47 100644 --- a/lib/XMonad/Internal/Theme.hs +++ b/lib/XMonad/Internal/Theme.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Theme for XMonad and Xmobar +-- Theme for XMonad and Xmobar module XMonad.Internal.Theme ( baseColor @@ -18,9 +18,9 @@ module XMonad.Internal.Theme , backdropTextColor , blend' , darken' - , Slant(..) - , Weight(..) - , FontData(..) + , Slant (..) + , Weight (..) + , FontData (..) , FontBuilder , buildFont , fallbackFont @@ -28,18 +28,17 @@ module XMonad.Internal.Theme , defFontData , tabbedTheme , promptTheme - ) where - -import Data.Colour -import Data.Colour.SRGB - -import qualified RIO.Text as T + ) +where +import Data.Colour +import Data.Colour.SRGB +import qualified RIO.Text as T import qualified XMonad.Layout.Decoration as D -import qualified XMonad.Prompt as P +import qualified XMonad.Prompt as P -------------------------------------------------------------------------------- --- | Colors - vocabulary roughly based on GTK themes +-- Colors - vocabulary roughly based on GTK themes baseColor :: T.Text baseColor = "#f7f7f7" @@ -78,7 +77,7 @@ backdropFgColor :: T.Text backdropFgColor = blend' 0.75 fgColor bgColor -------------------------------------------------------------------------------- --- | Color functions +-- Color functions blend' :: Float -> T.Text -> T.Text -> T.Text blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1) @@ -93,64 +92,73 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text sRGB24showT = T.pack . sRGB24show -------------------------------------------------------------------------------- --- | Fonts +-- Fonts -data Slant = Roman - | Italic - | Oblique - deriving (Eq, Show) +data Slant + = Roman + | Italic + | Oblique + deriving (Eq, Show) -data Weight = Light - | Medium - | Demibold - | Bold - | Black - deriving (Eq, Show) +data Weight + = Light + | Medium + | Demibold + | Bold + | Black + deriving (Eq, Show) data FontData = FontData - { weight :: Maybe Weight - , slant :: Maybe Slant - , size :: Maybe Int - , pixelsize :: Maybe Int - , antialias :: Maybe Bool - } + { weight :: Maybe Weight + , slant :: Maybe Slant + , size :: Maybe Int + , pixelsize :: Maybe Int + , antialias :: Maybe Bool + } type FontBuilder = FontData -> T.Text buildFont :: Maybe T.Text -> FontData -> T.Text buildFont Nothing _ = "fixed" -buildFont (Just fam) FontData { weight = w - , slant = l - , size = s - , pixelsize = p - , antialias = a - } - = T.intercalate ":" $ ["xft", fam] ++ elems - where - 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 T.Text - showLower = fmap (T.toLower . T.pack . show) +buildFont + (Just fam) + FontData + { weight = w + , slant = l + , size = s + , pixelsize = p + , antialias = a + } = + T.intercalate ":" $ ["xft", fam] ++ elems + where + 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 T.Text + showLower = fmap (T.toLower . T.pack . show) fallbackFont :: FontBuilder fallbackFont = buildFont Nothing -------------------------------------------------------------------------------- --- | Default font and data +-- Default font and data defFontData :: FontData -defFontData = FontData - { size = Just 10 - , antialias = Just True - , weight = Nothing - , slant = Nothing - , pixelsize = Nothing - } +defFontData = + FontData + { size = Just 10 + , antialias = Just True + , weight = Nothing + , slant = Nothing + , pixelsize = Nothing + } defFontFamily :: T.Text defFontFamily = "DejaVu Sans" @@ -162,44 +170,42 @@ defFontFamily = "DejaVu Sans" -- defFontTree = fontTree "DejaVu Sans" -------------------------------------------------------------------------------- --- | Complete themes +-- Complete themes tabbedTheme :: FontBuilder -> D.Theme -tabbedTheme fb = D.def - { D.fontName = T.unpack $ fb $ defFontData { weight = Just Bold } +tabbedTheme fb = + D.def + { D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold} + , D.activeTextColor = T.unpack fgColor + , D.activeColor = T.unpack bgColor + , D.activeBorderColor = T.unpack bgColor + , D.inactiveTextColor = T.unpack backdropTextColor + , D.inactiveColor = T.unpack backdropFgColor + , D.inactiveBorderColor = T.unpack backdropFgColor + , 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 + -- , D.inactiveBorderWidth = 0 + -- , D.urgentBorderWidth = 0 - , D.activeTextColor = T.unpack fgColor - , D.activeColor = T.unpack bgColor - , D.activeBorderColor = T.unpack bgColor - - , D.inactiveTextColor = T.unpack backdropTextColor - , D.inactiveColor = T.unpack backdropFgColor - , D.inactiveBorderColor = T.unpack backdropFgColor - - , 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 - -- , D.inactiveBorderWidth = 0 - -- , D.urgentBorderWidth = 0 - - , D.decoHeight = 20 - , D.windowTitleAddons = [] - , D.windowTitleIcons = [] - } + D.decoHeight = 20 + , D.windowTitleAddons = [] + , D.windowTitleIcons = [] + } promptTheme :: FontBuilder -> P.XPConfig -promptTheme fb = P.def - { 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 - , P.historySize = 0 - } +promptTheme fb = + P.def + { 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 + , P.historySize = 0 + } diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index b8f9f7f..f496fe3 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -1,25 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- | Common backlight plugin bits +-- Common backlight plugin bits -- -- Use the custom DBus interface exported by the XMonad process so I can react -- to signals spawned by commands - module Xmobar.Plugins.BacklightCommon (startBacklight) where -import Data.Internal.DBus +import Data.Internal.DBus +import qualified RIO.Text as T +import Xmobar.Plugins.Common -import qualified RIO.Text as T - -import Xmobar.Plugins.Common - -startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ()) - -> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO () +startBacklight + :: RealFrac a + => ((Maybe a -> IO ()) -> SesClient -> 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 $ T.concat [icon, T.pack $ show (round b :: Integer), "%"] - display = displayMaybe cb formatBrightness + withDBusClientConnection cb $ \c -> do + matchSignal display c + display =<< callGetBrightness c + where + 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 9a9dbd9..0ae39e0 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Bluetooth plugin +-- Bluetooth plugin -- -- Use the bluez interface on DBus to check status -- @@ -33,36 +33,34 @@ -- adapter changing. module Xmobar.Plugins.Bluetooth - ( Bluetooth(..) + ( Bluetooth (..) , btAlias , btDep - ) where + ) +where -import Control.Concurrent.MVar -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency -import Data.List -import Data.List.Split -import qualified Data.Map as M -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 +import Control.Concurrent.MVar +import Control.Monad +import DBus +import DBus.Client +import Data.Internal.DBus +import Data.Internal.Dependency +import Data.List +import Data.List.Split +import qualified Data.Map as M +import Data.Maybe +import qualified RIO.Text as T +import XMonad.Internal.DBus.Common +import Xmobar +import Xmobar.Plugins.Common btAlias :: T.Text btAlias = "bluetooth" btDep :: DBusDependency_ SysClient -btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface - $ Method_ getManagedObjects +btDep = + Endpoint [Package Official "bluez"] btBus btOMPath omInterface $ + Method_ getManagedObjects data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) @@ -90,7 +88,7 @@ startAdapter is cs cb cl = do display -------------------------------------------------------------------------------- --- | Icon Display +-- Icon Display -- -- 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" @@ -111,7 +109,7 @@ iconFormatter (iconConn, iconDisc) cs powered connected = icon = if connected then iconConn else iconDisc -------------------------------------------------------------------------------- --- | Connection State +-- Connection State -- -- The signal handlers all run on separate threads, yet the icon depends on -- the state reflected by all these signals. The best (only?) way to do this is @@ -119,7 +117,7 @@ iconFormatter (iconConn, iconDisc) cs powered connected = -- an MVar. data BTDevice = BTDevice - { btDevConnected :: Maybe Bool + { btDevConnected :: Maybe Bool , btDevSigHandler :: SignalHandler } @@ -133,10 +131,11 @@ data BtState = BtState type MutableBtState = MVar BtState emptyState :: BtState -emptyState = BtState - { btDevices = M.empty - , btPowered = Nothing - } +emptyState = + BtState + { btDevices = M.empty + , btPowered = Nothing + } readState :: MutableBtState -> IO (Maybe Bool, Bool) readState state = do @@ -145,7 +144,7 @@ readState state = do return (p, anyDevicesConnected c) -------------------------------------------------------------------------------- --- | Object manager +-- Object manager findAdapter :: ObjectTree -> Maybe ObjectPath findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys @@ -156,10 +155,10 @@ findDevices adapter = filter (adaptorHasDevice adapter) . M.keys adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool adaptorHasDevice adaptor device = case splitPath device of [org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX] - _ -> False + _ -> False splitPath :: ObjectPath -> [T.Text] -splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath +splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath getBtObjectTree :: SysClient -> IO ObjectTree getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath @@ -191,7 +190,7 @@ pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d -> pathCallback _ _ _ _ = return () -------------------------------------------------------------------------------- --- | Adapter +-- Adapter initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO () initAdapter state adapter client = do @@ -201,7 +200,11 @@ initAdapter state adapter client = do matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule) matchBTProperty sys p = matchPropertyFull sys btBus (Just p) -addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient +addAdaptorListener + :: MutableBtState + -> IO () + -> ObjectPath + -> SysClient -> IO (Maybe SignalHandler) addAdaptorListener state display adaptor sys = do rule <- matchBTProperty sys adaptor @@ -210,14 +213,16 @@ addAdaptorListener state display adaptor sys = do procMatch = withSignalMatch $ \b -> putPowered state b >> display callGetPowered :: ObjectPath -> SysClient -> IO [Variant] -callGetPowered adapter = callPropertyGet btBus adapter adapterInterface - $ memberName_ $ T.unpack adaptorPowered +callGetPowered adapter = + callPropertyGet btBus adapter adapterInterface $ + memberName_ $ + T.unpack adaptorPowered matchPowered :: [Variant] -> SignalMatch Bool matchPowered = matchPropertyChanged adapterInterface adaptorPowered putPowered :: MutableBtState -> Maybe Bool -> IO () -putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds }) +putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds}) readPowered :: MutableBtState -> IO (Maybe Bool) readPowered = fmap btPowered . readMVar @@ -229,7 +234,7 @@ adaptorPowered :: T.Text adaptorPowered = "Powered" -------------------------------------------------------------------------------- --- | Devices +-- Devices addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () addAndInitDevice state display device client = do @@ -240,12 +245,18 @@ addAndInitDevice state display device client = do initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO () initDevice state sh device sys = do reply <- callGetConnected device sys - void $ insertDevice state device $ - BTDevice { btDevConnected = fromVariant =<< listToMaybe reply - , btDevSigHandler = sh - } + void $ + insertDevice state device $ + BTDevice + { btDevConnected = fromVariant =<< listToMaybe reply + , btDevSigHandler = sh + } -addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient +addDeviceListener + :: MutableBtState + -> IO () + -> ObjectPath + -> SysClient -> IO (Maybe SignalHandler) addDeviceListener state display device sys = do rule <- matchBTProperty sys device @@ -257,18 +268,19 @@ matchConnected :: [Variant] -> SignalMatch Bool matchConnected = matchPropertyChanged devInterface devConnected callGetConnected :: ObjectPath -> SysClient -> IO [Variant] -callGetConnected p = callPropertyGet btBus p devInterface - $ memberName_ (T.unpack 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 let new = M.insert device dev $ btDevices s - return (s { btDevices = new }, anyDevicesConnected new) + return (s {btDevices = new}, anyDevicesConnected new) updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool updateDevice m device status = modifyMVar m $ \s -> do - let new = M.update (\d -> Just d { btDevConnected = status }) device $ btDevices s - return (s { btDevices = new }, anyDevicesConnected new) + let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s + return (s {btDevices = new}, anyDevicesConnected new) anyDevicesConnected :: ConnectedDevices -> Bool anyDevicesConnected = or . mapMaybe btDevConnected . M.elems @@ -276,7 +288,7 @@ anyDevicesConnected = or . mapMaybe btDevConnected . M.elems removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice) removeDevice m device = modifyMVar m $ \s -> do let devs = btDevices s - return (s { btDevices = M.delete device devs }, M.lookup device devs) + return (s {btDevices = M.delete device devs}, M.lookup device devs) readDevices :: MutableBtState -> IO ConnectedDevices readDevices = fmap btDevices . readMVar diff --git a/lib/Xmobar/Plugins/ClevoKeyboard.hs b/lib/Xmobar/Plugins/ClevoKeyboard.hs index 92a8f12..3f98f34 100644 --- a/lib/Xmobar/Plugins/ClevoKeyboard.hs +++ b/lib/Xmobar/Plugins/ClevoKeyboard.hs @@ -1,23 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Clevo Keyboard plugin +-- Clevo Keyboard plugin -- -- Use the custom DBus interface exported by the XMonad process so I can react -- to signals spawned by commands module Xmobar.Plugins.ClevoKeyboard - ( ClevoKeyboard(..) + ( ClevoKeyboard (..) , ckAlias - ) where + ) +where -import qualified RIO.Text as T - -import Xmobar - -import Xmobar.Plugins.BacklightCommon - -import XMonad.Internal.DBus.Brightness.ClevoKeyboard +import qualified RIO.Text as T +import XMonad.Internal.DBus.Brightness.ClevoKeyboard +import Xmobar +import Xmobar.Plugins.BacklightCommon newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show) @@ -27,4 +25,4 @@ ckAlias = "clevokeyboard" instance Exec ClevoKeyboard where alias (ClevoKeyboard _) = T.unpack ckAlias start (ClevoKeyboard icon) = - startBacklight matchSignalCK callGetBrightnessCK icon + startBacklight matchSignalCK callGetBrightnessCK icon diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index d28ee2b..f6bde99 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -8,36 +8,38 @@ module Xmobar.Plugins.Common , fromSingletonVariant , withDBusClientConnection , Callback - , Colors(..) + , Colors (..) , displayMaybe , displayMaybe' , xmobarFGColor ) - where +where -import Control.Monad - -import Data.Internal.DBus - -import DBus -import DBus.Client - -import qualified RIO.Text as T - -import XMonad.Hooks.DynamicLog (xmobarColor) +import Control.Monad +import DBus +import DBus.Client +import Data.Internal.DBus +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 :: T.Text + { colorsOn :: T.Text , colorsOff :: T.Text } deriving (Eq, Show, Read) -startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant]) - -> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback - -> c -> IO () +startListener + :: (SafeClient c, IsVariant a) + => MatchRule + -> (c -> IO [Variant]) + -> ([Variant] -> SignalMatch a) + -> (a -> IO T.Text) + -> Callback + -> c + -> IO () startListener rule getProp fromSignal toColor cb client = do reply <- getProp client displayMaybe cb toColor $ fromSingletonVariant reply @@ -49,8 +51,8 @@ procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO () procSignalMatch cb f = withSignalMatch (displayMaybe cb f) colorText :: Colors -> Bool -> T.Text -> T.Text -colorText Colors { colorsOn = c } True = xmobarFGColor c -colorText Colors { colorsOff = c } False = xmobarFGColor c +colorText Colors {colorsOn = c} True = xmobarFGColor c +colorText Colors {colorsOff = c} False = xmobarFGColor c xmobarFGColor :: T.Text -> T.Text -> T.Text xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 13abdb0..42e992b 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -1,30 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Device plugin +-- Device plugin -- -- Display different text depending on whether or not the interface has -- connectivity module Xmobar.Plugins.Device - ( Device(..) + ( Device (..) , devDep - ) where + ) +where -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency -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 +import Control.Monad +import DBus +import Data.Internal.DBus +import Data.Internal.Dependency +import Data.Word +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 (T.Text, T.Text, Colors) deriving (Read, Show) @@ -44,19 +41,23 @@ devSignal :: T.Text devSignal = "Ip4Connectivity" devDep :: DBusDependency_ SysClient -devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface - $ Method_ getByIP +devDep = + Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $ + Method_ getByIP getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath) getDevice sys iface = bodyToMaybe <$> callMethod' sys mc where - mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP) - { methodCallBody = [toVariant iface] - } + mc = + (methodCallBus networkManagerBus nmPath nmInterface getByIP) + { methodCallBody = [toVariant iface] + } getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant] -getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface - $ memberName_ $ T.unpack devSignal +getDeviceConnected path = + callPropertyGet networkManagerBus path nmDeviceInterface $ + memberName_ $ + T.unpack devSignal matchStatus :: [Variant] -> SignalMatch Word32 matchStatus = matchPropertyChanged nmDeviceInterface devSignal diff --git a/lib/Xmobar/Plugins/IntelBacklight.hs b/lib/Xmobar/Plugins/IntelBacklight.hs index e60a0fd..a4a777a 100644 --- a/lib/Xmobar/Plugins/IntelBacklight.hs +++ b/lib/Xmobar/Plugins/IntelBacklight.hs @@ -1,23 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Intel backlight plugin +-- Intel backlight plugin -- -- Use the custom DBus interface exported by the XMonad process so I can react -- to signals spawned by commands module Xmobar.Plugins.IntelBacklight - ( IntelBacklight(..) + ( IntelBacklight (..) , blAlias - ) where + ) +where -import qualified RIO.Text as T - -import Xmobar - -import Xmobar.Plugins.BacklightCommon - -import XMonad.Internal.DBus.Brightness.IntelBacklight +import qualified RIO.Text as T +import XMonad.Internal.DBus.Brightness.IntelBacklight +import Xmobar +import Xmobar.Plugins.BacklightCommon newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show) @@ -27,4 +25,4 @@ blAlias = "intelbacklight" instance Exec IntelBacklight where alias (IntelBacklight _) = T.unpack blAlias start (IntelBacklight icon) = - startBacklight matchSignalIB callGetBrightnessIB icon + startBacklight matchSignalIB callGetBrightnessIB icon diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index ef125cb..70fa3c1 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -1,22 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | Screensaver plugin +-- Screensaver plugin -- -- Use the custom DBus interface exported by the XMonad process so I can react -- to signals spawned by commands module Xmobar.Plugins.Screensaver - ( Screensaver(..) + ( Screensaver (..) , ssAlias - ) where + ) +where -import qualified RIO.Text as T - -import Xmobar - -import XMonad.Internal.DBus.Screensaver -import Xmobar.Plugins.Common +import qualified RIO.Text as T +import XMonad.Internal.DBus.Screensaver +import Xmobar +import Xmobar.Plugins.Common newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show) @@ -31,4 +30,3 @@ instance Exec Screensaver where display =<< callQuery sys where display = displayMaybe cb $ return . (\s -> colorText colors s text) - diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 625abf8..a742134 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -1,35 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- --- | VPN plugin +-- VPN plugin -- -- Use the networkmanager to detect when a VPN interface is added or removed. -- Specifically, monitor the object tree to detect paths with the interface -- "org.freedesktop.NetworkManager.Device.Tun". module Xmobar.Plugins.VPN - ( VPN(..) + ( VPN (..) , vpnAlias , vpnDep - ) where + ) +where -import Control.Concurrent.MVar -import Control.Monad - -import Data.Internal.DBus -import Data.Internal.Dependency -import qualified Data.Map as M -import Data.Maybe -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 +import Control.Concurrent.MVar +import Control.Monad +import DBus +import Data.Internal.DBus +import Data.Internal.Dependency +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +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 (T.Text, Colors) deriving (Read, Show) @@ -37,17 +34,17 @@ instance Exec VPN where alias (VPN _) = T.unpack vpnAlias start (VPN (text, colors)) cb = withDBusClientConnection cb $ \c -> do - state <- initState c - let display = displayMaybe cb iconFormatter . Just =<< readState state - let signalCallback' f = f state display - vpnAddedListener (signalCallback' addedCallback) c - vpnRemovedListener (signalCallback' removedCallback) c - display + state <- initState c + let display = displayMaybe cb iconFormatter . Just =<< readState state + let signalCallback' f = f state display + vpnAddedListener (signalCallback' addedCallback) c + vpnRemovedListener (signalCallback' removedCallback) c + display where iconFormatter b = return $ colorText colors b text -------------------------------------------------------------------------------- --- | VPN State +-- VPN State -- -- Maintain a set of paths which are the currently active VPNs. Most of the time -- this will be a null or singleton set, but this setup could handle the edge @@ -65,13 +62,15 @@ initState client = do readState :: MutableVPNState -> IO Bool readState = fmap (not . null) . readMVar -updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState - -> ObjectPath -> IO () +updateState + :: (ObjectPath -> VPNState -> VPNState) + -> MutableVPNState + -> ObjectPath + -> IO () updateState f state op = modifyMVar_ state $ return . f op -------------------------------------------------------------------------------- --- | Tunnel Device Detection --- +-- Tunnel Device Detection getVPNObjectTree :: SysClient -> IO ObjectTree getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath @@ -91,25 +90,30 @@ addedCallback state display [device, added] = update >> display 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 () +addedCallback _ _ _ = return () removedCallback :: MutableVPNState -> IO () -> SignalCallback removedCallback state display [device, interfaces] = update >> display where is = fromMaybe [] $ fromVariant interfaces :: [T.Text] update = updateDevice S.delete state device is -removedCallback _ _ _ = return () +removedCallback _ _ _ = return () -updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState - -> Variant -> [T.Text] -> IO () -updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $ - forM_ d $ updateState f state +updateDevice + :: (ObjectPath -> VPNState -> VPNState) + -> MutableVPNState + -> Variant + -> [T.Text] + -> IO () +updateDevice f state device interfaces = + when (vpnDeviceTun `elem` interfaces) $ + forM_ d $ + updateState f state where d = fromVariant device :: Maybe ObjectPath -------------------------------------------------------------------------------- --- | DBus Interface --- +-- DBus Interface vpnBus :: BusName vpnBus = busName_ "org.freedesktop.NetworkManager" @@ -124,5 +128,6 @@ vpnAlias :: T.Text vpnAlias = "vpn" vpnDep :: DBusDependency_ SysClient -vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface - $ Method_ getManagedObjects +vpnDep = + Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $ + Method_ getManagedObjects diff --git a/package.yaml b/package.yaml index 3885185..e299e06 100644 --- a/package.yaml +++ b/package.yaml @@ -7,7 +7,7 @@ copyright: "2022 Nathan Dwarshuis" extra-source-files: - README.md -- .stylish-haskell.yaml +- fourmolu.yaml - make_pkgs - icons/* - scripts/*