Compare commits

..

5 Commits

35 changed files with 2534 additions and 2456 deletions

View File

@ -1,357 +0,0 @@
# stylish-haskell configuration file
# ==================================
# The stylish-haskell tool is mainly configured by specifying steps. These steps
# are a list, so they have an order, and one specific step may appear more than
# once (if needed). Each file is processed by these steps in the given order.
steps:
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
# by default.
# - unicode_syntax:
# # In order to make this work, we also need to insert the UnicodeSyntax
# # language pragma. If this flag is set to true, we insert it when it's
# # not already present. You may want to disable it if you configure
# # language extensions using some other method than pragmas. Default:
# # true.
# add_language_pragma: true
# Format module header
#
# Currently, this option is not configurable and will format all exports and
# module declarations to minimize diffs
#
# - module_header:
# # How many spaces use for indentation in the module header.
# indent: 4
#
# # Should export lists be sorted? Sorting is only performed within the
# # export section, as delineated by Haddock comments.
# sort: true
#
# # See `separate_lists` for the `imports` step.
# separate_lists: true
# Format record definitions. This is disabled by default.
#
# You can control the layout of record fields. The only rules that can't be configured
# are these:
#
# - "|" is always aligned with "="
# - "," in fields is always aligned with "{"
# - "}" is likewise always aligned with "{"
#
# - records:
# # How to format equals sign between type constructor and data constructor.
# # Possible values:
# # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor.
# # - "indent N" -- insert a new line and N spaces from the beginning of the next line.
# equals: "indent 2"
#
# # How to format first field of each record constructor.
# # Possible values:
# # - "same_line" -- "{" and first field goes on the same line as the data constructor.
# # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
# first_field: "indent 2"
#
# # How many spaces to insert between the column with "," and the beginning of the comment in the next line.
# field_comment: 2
#
# # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
# deriving: 2
#
# # How many spaces to insert before "via" clause counted from indentation of deriving clause
# # Possible values:
# # - "same_line" -- "via" part goes on the same line as "deriving" keyword.
# # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword.
# via: "indent 2"
#
# # Sort typeclass names in the "deriving" list alphabetically.
# sort_deriving: true
#
# # Wheter or not to break enums onto several lines
# #
# # Default: false
# break_enums: false
#
# # Whether or not to break single constructor data types before `=` sign
# #
# # Default: true
# break_single_constructors: true
#
# # Whether or not to curry constraints on function.
# #
# # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@
# #
# # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@
# #
# # Default: false
# curried_context: false
# Align the right hand side of some elements. This is quite conservative
# and only applies to statements where each element occupies a single
# line.
# Possible values:
# - always - Always align statements.
# - adjacent - Align statements that are on adjacent lines in groups.
# - never - Never align statements.
# All default to always.
- simple_align:
cases: always
top_level_patterns: always
records: always
multi_way_if: always
# Import cleanup
- imports:
# There are different ways we can align names and lists.
#
# - global: Align the import names and import list throughout the entire
# file.
#
# - file: Like global, but don't add padding when there are no qualified
# imports in the file.
#
# - group: Only align the imports per group (a group is formed by adjacent
# import lines).
#
# - none: Do not perform any alignment.
#
# Default: global.
align: global
# The following options affect only import list alignment.
#
# List align has following options:
#
# - after_alias: Import list is aligned with end of import including
# 'as' and 'hiding' keywords.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - with_alias: Import list is aligned with start of alias or hiding.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# > init, last, length)
#
# - with_module_name: Import list is aligned `list_padding` spaces after
# the module name.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# init, last, length)
#
# This is mainly intended for use with `pad_module_names: false`.
#
# > import qualified Data.List as List (concat, foldl, foldr, head,
# init, last, length, scanl, scanr, take, drop,
# sort, nub)
#
# - new_line: Import list starts always on new line.
#
# > import qualified Data.List as List
# > (concat, foldl, foldr, head, init, last, length)
#
# - repeat: Repeat the module name to align the import list.
#
# > import qualified Data.List as List (concat, foldl, foldr, head)
# > import qualified Data.List as List (init, last, length)
#
# Default: after_alias
list_align: after_alias
# Right-pad the module names to align imports in a group:
#
# - true: a little more readable
#
# > import qualified Data.List as List (concat, foldl, foldr,
# > init, last, length)
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
# > init, last, length)
#
# - false: diff-safe
#
# > import qualified Data.List as List (concat, foldl, foldr, init,
# > last, length)
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
# > init, last, length)
#
# Default: true
pad_module_names: true
# Long list align style takes effect when import is too long. This is
# determined by 'columns' setting.
#
# - inline: This option will put as much specs on same line as possible.
#
# - new_line: Import list will start on new line.
#
# - new_line_multiline: Import list will start on new line when it's
# short enough to fit to single line. Otherwise it'll be multiline.
#
# - multiline: One line per import list entry.
# Type with constructor list acts like single import.
#
# > import qualified Data.Map as M
# > ( empty
# > , singleton
# > , ...
# > , delete
# > )
#
# Default: inline
long_list_align: multiline
# Align empty list (importing instances)
#
# Empty list align has following options
#
# - inherit: inherit list_align setting
#
# - right_after: () is right after the module name:
#
# > import Vector.Instances ()
#
# Default: inherit
empty_list_align: inherit
# List padding determines indentation of import list on lines after import.
# This option affects 'long_list_align'.
#
# - <integer>: constant value
#
# - module_name: align under start of module name.
# Useful for 'file' and 'group' align settings.
#
# Default: 4
list_padding: 4
# Separate lists option affects formatting of import list for type
# or class. The only difference is single space between type and list
# of constructors, selectors and class functions.
#
# - true: There is single space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable (fold, foldl, foldMap))
#
# - false: There is no space between Foldable type and list of it's
# functions.
#
# > import Data.Foldable (Foldable(fold, foldl, foldMap))
#
# Default: true
separate_lists: true
# Space surround option affects formatting of import lists on a single
# line. The only difference is single space after the initial
# parenthesis and a single space before the terminal parenthesis.
#
# - true: There is single space associated with the enclosing
# parenthesis.
#
# > import Data.Foo ( foo )
#
# - false: There is no space associated with the enclosing parenthesis
#
# > import Data.Foo (foo)
#
# Default: false
space_surround: false
# Enabling this argument will use the new GHC lib parse to format imports.
#
# This currently assumes a few things, it will assume that you want post
# qualified imports. It is also not as feature complete as the old
# imports formatting.
#
# It does not remove redundant lines or merge lines. As such, the full
# feature scope is still pending.
#
# It _is_ however, a fine alternative if you are using features that are
# not parseable by haskell src extensions and you're comfortable with the
# presets.
#
# Default: false
ghc_lib_parser: false
# Language pragmas
- language_pragmas:
# We can generate different styles of language pragma lists.
#
# - vertical: Vertical-spaced language pragmas, one per line.
#
# - compact: A more compact style.
#
# - compact_line: Similar to compact, but wrap each line with
# `{-#LANGUAGE #-}'.
#
# Default: vertical.
style: vertical
# Align affects alignment of closing pragma brackets.
#
# - true: Brackets are aligned in same column.
#
# - false: Brackets are not aligned together. There is only one space
# between actual import and closing bracket.
#
# Default: true
align: true
# stylish-haskell can detect redundancy of some language pragmas. If this
# is set to true, it will remove those redundant pragmas. Default: true.
remove_redundant: true
# Language prefix to be used for pragma declaration, this allows you to
# use other options non case-sensitive like "language" or "Language".
# If a non correct String is provided, it will default to: LANGUAGE.
language_prefix: LANGUAGE
# Replace tabs by spaces. This is disabled by default.
# - tabs:
# # Number of spaces to use for each tab. Default: 8, as specified by the
# # Haskell report.
# spaces: 8
# Remove trailing whitespace
- trailing_whitespace: {}
# Squash multiple spaces between the left and right hand sides of some
# elements into single spaces. Basically, this undoes the effect of
# simple_align but is a bit less conservative.
# - squash: {}
# A common setting is the number of columns (parts of) code will be wrapped
# to. Different steps take this into account.
#
# Set this to null to disable all line wrapping.
#
# Default: 80.
columns: 80
# By default, line endings are converted according to the OS. You can override
# preferred format here.
#
# - native: Native newline format. CRLF on Windows, LF on other OSes.
#
# - lf: Convert to LF ("\n").
#
# - crlf: Convert to CRLF ("\r\n").
#
# Default: native.
newline: native
# Sometimes, language extensions are specified in a cabal file or from the
# command line instead of using language pragmas in the file. stylish-haskell
# needs to be aware of these, so it can parse the file correctly.
#
# No language extensions are enabled by default.
# language_extensions:
# - TemplateHaskell
# - QuasiQuotes
# Attempt to find the cabal file in ancestors of the current directory, and
# parse options (currently only language extensions) from that.
#
# Default: true
cabal: true

View File

@ -1,7 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | Start a VirtualBox instance with a sentinel wrapper process. -- | Start a VirtualBox instance with a sentinel wrapper process.
-- --
-- The only reason why this is needed is because I want to manage virtualboxes -- 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 -- until its PID exits. By monitoring this wrapper, the dynamic workspace only
-- has one process to track and will maintain the workspace throughout the -- has one process to track and will maintain the workspace throughout the
-- lifetime of the VM. -- lifetime of the VM.
module Main (main) where module Main (main) where
import qualified Data.ByteString.Lazy.UTF8 as BU import qualified Data.ByteString.Lazy.UTF8 as BU
import RIO
import RIO import RIO.Process
import RIO.Process import qualified RIO.Text as T
import qualified RIO.Text as T import System.Environment
import Text.XML.Light
import Text.XML.Light import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.IO
import System.Environment
import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.IO
main :: IO () main :: IO ()
main = do main = do
@ -48,7 +42,6 @@ runAndWait [n] = do
p <- vmPID i p <- vmPID i
liftIO $ mapM_ waitUntilExit p liftIO $ mapM_ waitUntilExit p
err = logError "Could not get machine ID" err = logError "Could not get machine ID"
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME" runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
vmLaunch :: T.Text -> RIO SimpleApp () vmLaunch :: T.Text -> RIO SimpleApp ()
@ -56,25 +49,28 @@ vmLaunch i = do
rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
case rc of case rc of
ExitSuccess -> return () 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 :: T.Text -> RIO SimpleApp (Maybe Int)
vmPID vid = do vmPID vid = do
(rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout (rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
return $ case rc of return $ case rc of
ExitSuccess -> readMaybe $ BU.toString out ExitSuccess -> readMaybe $ BU.toString out
_ -> Nothing _ -> Nothing
vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text) vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text)
vmMachineID iPath = do vmMachineID iPath = do
res <- tryAny $ readFileUtf8 iPath res <- tryAny $ readFileUtf8 iPath
case res of case res of
Right contents -> return $ findMachineID contents Right contents -> return $ findMachineID contents
Left e -> logError (displayShow e) >> return Nothing Left e -> logError (displayShow e) >> return Nothing
where where
findMachineID c = T.stripSuffix "}" findMachineID c =
=<< T.stripPrefix "{" T.stripSuffix "}"
=<< (fmap T.pack . findAttr (blank_name { qName = "uuid" })) =<< T.stripPrefix "{"
=<< (\e -> findChild (qual e "Machine") e) =<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
=<< parseXMLDoc c =<< (\e -> findChild (qual e "Machine") e)
=<< parseXMLDoc c

View File

@ -1,8 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Main (main) where
--------------------------------------------------------------------------------
-- | Xmobar binary -- | Xmobar binary
-- --
-- Features: -- Features:
@ -12,52 +9,47 @@ module Main (main) where
-- * Some custom plugins (imported below) -- * Some custom plugins (imported below)
-- * Theme integration with xmonad (shared module imported below) -- * Theme integration with xmonad (shared module imported below)
-- * A custom Locks plugin from my own forked repo -- * A custom Locks plugin from my own forked repo
module Main (main) where
import Control.Monad import Control.Monad
import Data.Internal.DBus
import Data.Internal.DBus import Data.Internal.Dependency
import Data.Internal.Dependency import Data.List
import Data.List import Data.Maybe
import Data.Maybe import RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL
import RIO hiding (hFlush) import RIO.Process
import qualified RIO.ByteString.Lazy as BL import qualified RIO.Text as T
import RIO.Process import System.Environment
import qualified RIO.Text as T import System.IO
import XMonad.Core hiding (config)
import System.Environment import XMonad.Internal.Command.Desktop
import System.IO import XMonad.Internal.Command.Power
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Xmobar.Plugins.Bluetooth import XMonad.Internal.DBus.Brightness.IntelBacklight
import Xmobar.Plugins.ClevoKeyboard import XMonad.Internal.DBus.Control
import Xmobar.Plugins.Device import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import Xmobar.Plugins.IntelBacklight import qualified XMonad.Internal.Theme as XT
import Xmobar.Plugins.Screensaver import Xmobar hiding
import Xmobar.Plugins.VPN ( iconOffset
, run
import XMonad.Core hiding (config) )
import XMonad.Internal.Command.Desktop import Xmobar.Plugins.Bluetooth
import XMonad.Internal.Command.Power import Xmobar.Plugins.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import Xmobar.Plugins.Common
import XMonad.Internal.DBus.Brightness.IntelBacklight import Xmobar.Plugins.Device
import XMonad.Internal.DBus.Control import Xmobar.Plugins.IntelBacklight
import XMonad.Internal.DBus.Screensaver (ssSignalDep) import Xmobar.Plugins.Screensaver
import qualified XMonad.Internal.Theme as XT import Xmobar.Plugins.VPN
import Xmobar hiding
( iconOffset
, run
)
import Xmobar.Plugins.Common
main :: IO () main :: IO ()
main = getArgs >>= parse main = getArgs >>= parse
parse :: [String] -> IO () parse :: [String] -> IO ()
parse [] = run parse [] = run
parse ["--deps"] = withCache printDeps parse ["--deps"] = withCache printDeps
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
parse _ = usage parse _ = usage
run :: IO () run :: IO ()
run = do run = do
@ -84,13 +76,16 @@ printDeps = do
io $ disconnectDBus db io $ disconnectDBus db
usage :: IO () usage :: IO ()
usage = putStrLn $ intercalate "\n" usage =
[ "xmobar: run greatest taskbar" putStrLn $
, "xmobar --deps: print dependencies" intercalate
] "\n"
[ "xmobar: run greatest taskbar"
, "xmobar --deps: print dependencies"
]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | toplevel configuration -- toplevel configuration
-- | The text font family -- | The text font family
textFont :: Always XT.FontBuilder textFont :: Always XT.FontBuilder
@ -102,88 +97,93 @@ textFontOffset = 16
-- | Attributes for the bar font (size, weight, etc) -- | Attributes for the bar font (size, weight, etc)
textFontData :: XT.FontData 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 -- | The icon font family
iconFont :: Sometimes XT.FontBuilder iconFont :: Sometimes XT.FontBuilder
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font" iconFont =
[Package Official "ttf-nerd-fonts-symbols-2048-em"] 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) -- | Offsets for the icons in the bar (relative to the text offset)
iconOffset :: BarFont -> Int iconOffset :: BarFont -> Int
iconOffset IconSmall = 0 iconOffset IconSmall = 0
iconOffset IconMedium = 1 iconOffset IconMedium = 1
iconOffset IconLarge = 1 iconOffset IconLarge = 1
iconOffset IconXLarge = 2 iconOffset IconXLarge = 2
-- | Sizes (in pixels) for the icon fonts -- | Sizes (in pixels) for the icon fonts
iconSize :: BarFont -> Int iconSize :: BarFont -> Int
iconSize IconSmall = 13 iconSize IconSmall = 13
iconSize IconMedium = 15 iconSize IconMedium = 15
iconSize IconLarge = 18 iconSize IconLarge = 18
iconSize IconXLarge = 20 iconSize IconXLarge = 20
-- | Attributes for icon fonts -- | Attributes for icon fonts
iconFontData :: Int -> XT.FontData 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 -- | Global configuration
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and -- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
-- only one) text font, and all other fonts are icon fonts. If this assumption -- only one) text font, and all other fonts are icon fonts. If this assumption
-- changes the code will need to change significantly -- changes the code will need to change significantly
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
config bf ifs ios br confDir = defaultConfig config bf ifs ios br confDir =
{ font = T.unpack bf defaultConfig
, additionalFonts = fmap T.unpack ifs { font = T.unpack bf
, textOffset = textFontOffset , additionalFonts = fmap T.unpack ifs
, textOffsets = ios , textOffset = textFontOffset
, bgColor = T.unpack XT.bgColor , textOffsets = ios
, fgColor = T.unpack XT.fgColor , bgColor = T.unpack XT.bgColor
, position = BottomSize C 100 24 , fgColor = T.unpack XT.fgColor
, border = NoBorder , position = BottomSize C 100 24
, borderColor = T.unpack XT.bordersColor , border = NoBorder
, borderColor = T.unpack XT.bordersColor
, sepChar = T.unpack pSep , sepChar = T.unpack pSep
, alignSep = [lSep, rSep] , alignSep = [lSep, rSep]
, template = T.unpack $ fmtRegions br , template = T.unpack $ fmtRegions br
, lowerOnStart = False
, lowerOnStart = False , hideOnStart = False
, hideOnStart = False , allDesktops = True
, allDesktops = True , overrideRedirect = True
, overrideRedirect = True , pickBroadest = False
, pickBroadest = False , persistent = True
, persistent = True , -- store the icons with the xmonad/xmobar stack project
-- store the icons with the xmonad/xmobar stack project iconRoot = confDir ++ "/icons"
, iconRoot = confDir ++ "/icons" , commands = csRunnable <$> concatRegions br
}
, commands = csRunnable <$> concatRegions br
}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | plugin features -- plugin features
-- --
-- some commands depend on the presence of interfaces that can only be -- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here -- determined at runtime; define these checks here
getAllCommands :: [Maybe CmdSpec] -> BarRegions getAllCommands :: [Maybe CmdSpec] -> BarRegions
getAllCommands right = BarRegions getAllCommands right =
{ brLeft = [ CmdSpec BarRegions
{ csAlias = "UnsafeStdinReader" { brLeft =
, csRunnable = Run UnsafeStdinReader [ CmdSpec
} { csAlias = "UnsafeStdinReader"
] , csRunnable = Run UnsafeStdinReader
, brCenter = [] }
, brRight = catMaybes right ]
} , brCenter = []
, brRight = catMaybes right
}
rightPlugins :: DBusState -> FIO [Maybe CmdSpec] rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins db = mapM evalFeature $ allFeatures db rightPlugins db =
++ [always' "date indicator" dateCmd] mapM evalFeature $
allFeatures db
++ [always' "date indicator" dateCmd]
where where
always' n = Right . Always n . Always_ . FallbackAlone always' n = Right . Always n . Always_ . FallbackAlone
allFeatures :: DBusState -> [Feature CmdSpec] allFeatures :: DBusState -> [Feature CmdSpec]
allFeatures DBusState { dbSesClient = ses, dbSysClient = sys } = allFeatures DBusState {dbSesClient = ses, dbSysClient = sys} =
[ Left getWireless [ Left getWireless
, Left $ getEthernet sys , Left $ getEthernet sys
, Left $ getVPN sys , Left $ getVPN sys
@ -200,8 +200,11 @@ type BarFeature = Sometimes CmdSpec
-- TODO what if I don't have a wireless card? -- TODO what if I don't have a wireless card?
getWireless :: BarFeature getWireless :: BarFeature
getWireless = Sometimes "wireless status indicator" xpfWireless getWireless =
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"] Sometimes
"wireless status indicator"
xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe SysClient -> BarFeature getEthernet :: Maybe SysClient -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
@ -213,32 +216,49 @@ getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree getBattery = iconIO_ "battery level indicator" xpfBattery root tree
where where
root useIcon = IORoot_ (batteryCmd useIcon) root useIcon = IORoot_ (batteryCmd useIcon)
tree = Only_ $ IOTest_ "Test if battery is present" [] tree =
$ io $ fmap (Msg LevelError) <$> hasBattery Only_ $
IOTest_ "Test if battery is present" [] $
io $
fmap (Msg LevelError) <$> hasBattery
getVPN :: Maybe SysClient -> BarFeature getVPN :: Maybe SysClient -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
where where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" test =
networkManagerPkgs vpnPresent DBusIO $
IOTest_
"Use nmcli to test if VPN is present"
networkManagerPkgs
vpnPresent
getBt :: Maybe SysClient -> BarFeature getBt :: Maybe SysClient -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = iconIO_ "volume level indicator" (const True) root getAlsa =
$ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl" iconIO_ "volume level indicator" (const True) root $
Only_ $
sysExe [Package Official "alsa-utils"] "alsactl"
where where
root useIcon = IORoot_ (alsaCmd useIcon) root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe SesClient -> BarFeature getBl :: Maybe SesClient -> BarFeature
getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight getBl =
intelBacklightSignalDep blCmd xmobarDBus
"Intel backlight indicator"
xpfIntelBacklight
intelBacklightSignalDep
blCmd
getCk :: Maybe SesClient -> BarFeature getCk :: Maybe SesClient -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight getCk =
clevoKeyboardSignalDep ckCmd xmobarDBus
"Clevo keyboard indicator"
xpfClevoBacklight
clevoKeyboardSignalDep
ckCmd
getSs :: Maybe SesClient -> BarFeature getSs :: Maybe SesClient -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd 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 root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | bar feature constructors -- bar feature constructors
xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c xmobarDBus
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature :: SafeClient c
=> T.Text
-> XPQuery
-> DBusDependency_ c
-> (Fontifier -> CmdSpec)
-> Maybe c
-> BarFeature
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep) xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
where where
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec) iconIO_
-> IOTree_ -> BarFeature :: T.Text
-> XPQuery
-> (Fontifier -> IOTree_ -> Root CmdSpec)
-> IOTree_
-> BarFeature
iconIO_ = iconSometimes' And_ Only_ iconIO_ = iconSometimes' And_ Only_
iconDBus :: SafeClient c => T.Text -> XPQuery iconDBus
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature :: SafeClient c
=> T.Text
-> XPQuery
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
-> DBusTree c p
-> BarFeature
iconDBus = iconSometimes' And1 $ Only_ . DBusIO iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus_ :: SafeClient c => T.Text -> XPQuery iconDBus_
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature :: SafeClient c
=> T.Text
-> XPQuery
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
-> DBusTree_ c
-> BarFeature
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery iconSometimes'
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature :: (t -> t_ -> t)
iconSometimes' c d n q r t = Sometimes n q -> (IODependency_ -> t_)
[ Subfeature icon "icon indicator" -> T.Text
, Subfeature text "text indicator" -> 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 where
icon = r fontifyIcon $ c t $ d iconDependency icon = r fontifyIcon $ c t $ d iconDependency
text = r fontifyAlt t text = r fontifyAlt t
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | command specifications -- command specifications
data BarRegions = BarRegions data BarRegions = BarRegions
{ brLeft :: [CmdSpec] { brLeft :: [CmdSpec]
, brCenter :: [CmdSpec] , brCenter :: [CmdSpec]
, brRight :: [CmdSpec] , brRight :: [CmdSpec]
} deriving Show }
deriving (Show)
data CmdSpec = CmdSpec data CmdSpec = CmdSpec
{ csAlias :: T.Text { csAlias :: T.Text
, csRunnable :: Runnable , csRunnable :: Runnable
} deriving Show }
deriving (Show)
concatRegions :: BarRegions -> [CmdSpec] concatRegions :: BarRegions -> [CmdSpec]
concatRegions (BarRegions l c r) = l ++ c ++ r concatRegions (BarRegions l c r) = l ++ c ++ r
wirelessCmd :: T.Text -> CmdSpec wirelessCmd :: T.Text -> CmdSpec
wirelessCmd iface = CmdSpec wirelessCmd iface =
{ csAlias = T.append iface "wi" CmdSpec
, csRunnable = Run $ Wireless (T.unpack iface) args 5 { csAlias = T.append iface "wi"
} , csRunnable = Run $ Wireless (T.unpack iface) args 5
}
where where
args = fmap T.unpack args =
[ "-t", "<qualityipat><essid>" fmap
, "--" T.unpack
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>" [ "-t"
] , "<qualityipat><essid>"
, "--"
, "--quality-icon-pattern"
, "<icon=wifi_%%.xpm/>"
]
ethernetCmd :: Fontifier -> T.Text -> CmdSpec ethernetCmd :: Fontifier -> T.Text -> CmdSpec
ethernetCmd fontify iface = CmdSpec ethernetCmd fontify iface =
{ csAlias = iface CmdSpec
, csRunnable = Run { csAlias = iface
$ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors) , csRunnable =
} Run $
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
}
batteryCmd :: Fontifier -> CmdSpec batteryCmd :: Fontifier -> CmdSpec
batteryCmd fontify = CmdSpec batteryCmd fontify =
{ csAlias = "battery" CmdSpec
, csRunnable = Run $ Battery args 50 { csAlias = "battery"
} , csRunnable = Run $ Battery args 50
}
where where
fontify' = fontify IconSmall fontify' = fontify IconSmall
args = fmap T.unpack args =
[ "--template", "<acstatus><left>" fmap
, "--Low", "10" T.unpack
, "--High", "80" [ "--template"
, "--low", "red" , "<acstatus><left>"
, "--normal", XT.fgColor , "--Low"
, "--high", XT.fgColor , "10"
, "--" , "--High"
, "-P" , "80"
, "-o" , fontify' "\xf0e7" "BAT" , "--low"
, "-O" , fontify' "\xf1e6" "AC" , "red"
, "-i" , fontify' "\xf1e6" "AC" , "--normal"
] , XT.fgColor
, "--high"
, XT.fgColor
, "--"
, "-P"
, "-o"
, fontify' "\xf0e7" "BAT"
, "-O"
, fontify' "\xf1e6" "AC"
, "-i"
, fontify' "\xf1e6" "AC"
]
vpnCmd :: Fontifier -> CmdSpec vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify = CmdSpec vpnCmd fontify =
{ csAlias = vpnAlias CmdSpec
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors) { csAlias = vpnAlias
} , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
btCmd :: Fontifier -> CmdSpec btCmd :: Fontifier -> CmdSpec
btCmd fontify = CmdSpec btCmd fontify =
{ csAlias = btAlias CmdSpec
, csRunnable = Run { csAlias = btAlias
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors , csRunnable =
} Run $
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
}
where where
fontify' i = fontify IconLarge i . T.append "BT" fontify' i = fontify IconLarge i . T.append "BT"
alsaCmd :: Fontifier -> CmdSpec alsaCmd :: Fontifier -> CmdSpec
alsaCmd fontify = CmdSpec alsaCmd fontify =
{ csAlias = "alsa:default:Master" CmdSpec
, csRunnable = Run { csAlias = "alsa:default:Master"
$ Alsa "default" "Master" , csRunnable =
$ fmap T.unpack Run $
[ "-t", "<status><volume>%" Alsa "default" "Master" $
, "--" fmap
, "-O", fontify' "\xf028" "+" T.unpack
, "-o", T.append (fontify' "\xf026" "-") " " [ "-t"
, "-c", XT.fgColor , "<status><volume>%"
, "-C", XT.fgColor , "--"
] , "-O"
} , fontify' "\xf028" "+"
, "-o"
, T.append (fontify' "\xf026" "-") " "
, "-c"
, XT.fgColor
, "-C"
, XT.fgColor
]
}
where where
fontify' i = fontify IconSmall i . T.append "VOL" fontify' i = fontify IconSmall i . T.append "VOL"
blCmd :: Fontifier -> CmdSpec blCmd :: Fontifier -> CmdSpec
blCmd fontify = CmdSpec blCmd fontify =
{ csAlias = blAlias CmdSpec
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: " { csAlias = blAlias
} , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
}
ckCmd :: Fontifier -> CmdSpec ckCmd :: Fontifier -> CmdSpec
ckCmd fontify = CmdSpec ckCmd fontify =
{ csAlias = ckAlias CmdSpec
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: " { csAlias = ckAlias
} , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
}
ssCmd :: Fontifier -> CmdSpec ssCmd :: Fontifier -> CmdSpec
ssCmd fontify = CmdSpec ssCmd fontify =
{ csAlias = ssAlias CmdSpec
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors) { csAlias = ssAlias
} , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
}
lockCmd :: Fontifier -> CmdSpec lockCmd :: Fontifier -> CmdSpec
lockCmd fontify = CmdSpec lockCmd fontify =
{ csAlias = "locks" CmdSpec
, csRunnable = Run { csAlias = "locks"
$ Locks , csRunnable =
$ fmap T.unpack Run $
[ "-N", numIcon Locks $
, "-n", disabledColor numIcon fmap
, "-C", capIcon T.unpack
, "-c", disabledColor capIcon [ "-N"
, "-s", "" , numIcon
, "-S", "" , "-n"
, "-d", " " , disabledColor numIcon
] , "-C"
} , capIcon
, "-c"
, disabledColor capIcon
, "-s"
, ""
, "-S"
, ""
, "-d"
, " "
]
}
where where
numIcon = fontify' "\xf8a5" "N" numIcon = fontify' "\xf8a5" "N"
capIcon = fontify' "\xf657" "C" capIcon = fontify' "\xf657" "C"
@ -408,33 +502,37 @@ lockCmd fontify = CmdSpec
disabledColor = xmobarFGColor XT.backdropFgColor disabledColor = xmobarFGColor XT.backdropFgColor
dateCmd :: CmdSpec dateCmd :: CmdSpec
dateCmd = CmdSpec dateCmd =
{ csAlias = "date" CmdSpec
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10 { 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 :: FIO (Maybe Msg)
vpnPresent = do vpnPresent = do
res <- proc "nmcli" args readProcess res <- proc "nmcli" args readProcess
return $ case res of return $ case res of
(ExitSuccess, out, _) | "vpn" `elem` BL.split 10 out -> Nothing (ExitSuccess, out, _)
| otherwise -> Just $ Msg LevelError "vpn not found" | "vpn" `elem` BL.split 10 out -> Nothing
(ExitFailure c, _, err) -> Just $ Msg LevelError | otherwise -> Just $ Msg LevelError "vpn not found"
$ T.concat (ExitFailure c, _, err) ->
["vpn search exited with code " Just $
, T.pack $ show c Msg LevelError $
, ": " T.concat
, T.decodeUtf8With T.lenientDecode [ "vpn search exited with code "
$ BL.toStrict err , T.pack $ show c
] , ": "
, T.decodeUtf8With T.lenientDecode $
BL.toStrict err
]
where where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | text font -- text font
-- --
-- ASSUME there is only one text font for this entire configuration. This -- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record. -- will correspond to the first font/offset parameters in the config record.
@ -445,17 +543,20 @@ getTextFont = do
return $ fb textFontData return $ fb textFontData
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | icon fonts -- icon fonts
getIconFonts :: FIO ([T.Text], [Int]) getIconFonts :: FIO ([T.Text], [Int])
getIconFonts = do getIconFonts = do
fb <- evalSometimes iconFont fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb return $ maybe ([], []) apply fb
where where
apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset)) apply fb =
<$> iconFonts unzip $
(\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts
data BarFont = IconSmall data BarFont
= IconSmall
| IconMedium | IconMedium
| IconLarge | IconLarge
| IconXLarge | IconXLarge
@ -483,10 +584,10 @@ fontifyIcon :: Fontifier
fontifyIcon f i _ = fontifyText f i fontifyIcon f i _ = fontifyText f i
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | various formatting things -- various formatting things
colors :: Colors colors :: Colors
colors = Colors { colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor } colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
sep :: T.Text sep :: T.Text
sep = xmobarFGColor XT.backdropFgColor " : " sep = xmobarFGColor XT.backdropFgColor " : "
@ -503,8 +604,9 @@ pSep = "%"
fmtSpecs :: [CmdSpec] -> T.Text fmtSpecs :: [CmdSpec] -> T.Text
fmtSpecs = T.intercalate sep . fmap go fmtSpecs = T.intercalate sep . fmap go
where 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 -> T.Text
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r] T.concat
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]

File diff suppressed because it is too large Load Diff

14
fourmolu.yaml Normal file
View File

@ -0,0 +1,14 @@
indentation: 2
function-arrows: leading
comma-style: leading
import-export-style: leading
indent-wheres: true
record-brace-space: true
newlines-between-decls: 1
haddock-style: single-line
haddock-style-module:
let-style: inline
in-style: right-align
respectful: false
fixities: []
unicode: never

View File

@ -1,15 +1,15 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Common internal DBus functions -- Common internal DBus functions
module Data.Internal.DBus module Data.Internal.DBus
( SafeClient(..) ( SafeClient (..)
, SysClient(..) , SysClient (..)
, SesClient(..) , SesClient (..)
, addMatchCallback , addMatchCallback
, matchProperty , matchProperty
, matchPropertyFull , matchPropertyFull
, matchPropertyChanged , matchPropertyChanged
, SignalMatch(..) , SignalMatch (..)
, SignalCallback , SignalCallback
, MethodBody , MethodBody
, withSignalMatch , withSignalMatch
@ -25,22 +25,20 @@ module Data.Internal.DBus
, addInterfaceRemovedListener , addInterfaceRemovedListener
, fromSingletonVariant , fromSingletonVariant
, bodyToMaybe , bodyToMaybe
) where )
where
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import DBus
import Data.Bifunctor import DBus.Client
import qualified Data.Map.Strict as M import Data.Bifunctor
import Data.Maybe import qualified Data.Map.Strict as M
import Data.Maybe
import qualified RIO.Text as T import qualified RIO.Text as T
import DBus
import DBus.Client
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Type-safe client -- Type-safe client
class SafeClient c where class SafeClient c where
toClient :: c -> Client toClient :: c -> Client
@ -82,28 +80,37 @@ getDBusClient' :: Bool -> IO (Maybe Client)
getDBusClient' sys = do getDBusClient' sys = do
res <- try $ if sys then connectSystem else connectSession res <- try $ if sys then connectSystem else connectSession
case res of case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c Right c -> return $ Just c
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Methods -- Methods
type MethodBody = Either T.Text [Variant] type MethodBody = Either T.Text [Variant]
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody) callMethod' cl =
. call (toClient cl) fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl)
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName callMethod
-> MemberName -> IO MethodBody :: SafeClient c
=> c
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> IO MethodBody
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCallBus b p i m = (methodCall p i m) methodCallBus b p i m =
{ methodCallDestination = Just b } (methodCall p i m)
{ methodCallDestination = Just b
}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Bus names -- Bus names
dbusInterface :: InterfaceName dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus" dbusInterface = interfaceName_ "org.freedesktop.DBus"
@ -111,12 +118,14 @@ dbusInterface = interfaceName_ "org.freedesktop.DBus"
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName) callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
where where
mc = (methodCallBus dbusName dbusPath dbusInterface mem) mc =
{ methodCallBody = [toVariant name] } (methodCallBus dbusName dbusPath dbusInterface mem)
{ methodCallBody = [toVariant name]
}
mem = memberName_ "GetNameOwner" mem = memberName_ "GetNameOwner"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Variant parsing -- Variant parsing
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe fromSingletonVariant = fromVariant <=< listToMaybe
@ -125,30 +134,45 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
bodyToMaybe = either (const Nothing) fromSingletonVariant bodyToMaybe = either (const Nothing) fromSingletonVariant
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Signals -- Signals
type SignalCallback = [Variant] -> IO () type SignalCallback = [Variant] -> IO ()
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c addMatchCallback
:: SafeClient c
=> MatchRule
-> SignalCallback
-> c
-> IO SignalHandler -> IO SignalHandler
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName matchSignal
-> Maybe MemberName -> MatchRule :: Maybe BusName
matchSignal b p i m = matchAny -> Maybe ObjectPath
{ matchPath = p -> Maybe InterfaceName
, matchSender = b -> Maybe MemberName
, matchInterface = i -> MatchRule
, matchMember = m matchSignal b p i m =
} matchAny
{ matchPath = p
, matchSender = b
, matchInterface = i
, matchMember = m
}
matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath matchSignalFull
-> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule) :: SafeClient c
=> c
-> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> IO (Maybe MatchRule)
matchSignalFull client b p i m = matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Properties -- Properties
propertyInterface :: InterfaceName propertyInterface :: InterfaceName
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties" propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
@ -156,16 +180,28 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged" propertySignal = memberName_ "PropertiesChanged"
callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName callPropertyGet
-> MemberName -> c -> IO [Variant] :: SafeClient c
callPropertyGet bus path iface property cl = fmap (either (const []) (:[])) => BusName
$ getProperty (toClient cl) $ methodCallBus bus path iface property -> 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 :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p = matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal) matchSignal b p (Just propertyInterface) (Just propertySignal)
matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath matchPropertyFull
:: SafeClient c
=> c
-> BusName
-> Maybe ObjectPath
-> IO (Maybe MatchRule) -> IO (Maybe MatchRule)
matchPropertyFull cl b p = matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal) 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 :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
withSignalMatch f (Match x) = f (Just x) withSignalMatch f (Match x) = f (Just x)
withSignalMatch f Failure = f Nothing withSignalMatch f Failure = f Nothing
withSignalMatch _ NoMatch = return () withSignalMatch _ NoMatch = return ()
matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant] matchPropertyChanged
:: IsVariant a
=> InterfaceName
-> T.Text
-> [Variant]
-> SignalMatch a -> SignalMatch a
matchPropertyChanged iface property [i, body, _] = matchPropertyChanged iface property [i, body, _] =
let i' = (fromVariant i :: Maybe T.Text) let i' = (fromVariant i :: Maybe T.Text)
b = toMap body in b = toMap body
case (i', b) of in case (i', b) of
(Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then (Just i'', Just b') ->
maybe NoMatch Match $ fromVariant =<< M.lookup property b' if i'' == T.pack (formatInterfaceName iface)
else NoMatch then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
_ -> Failure else NoMatch
_ -> Failure
where where
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant) toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
matchPropertyChanged _ _ _ = Failure matchPropertyChanged _ _ _ = Failure
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Object Manager -- Object Manager
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant)) 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
omInterfacesRemoved = memberName_ "InterfacesRemoved" omInterfacesRemoved = memberName_ "InterfacesRemoved"
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath callGetManagedObjects
:: SafeClient c
=> c
-> BusName
-> ObjectPath
-> IO ObjectTree -> IO ObjectTree
callGetManagedObjects cl bus path = callGetManagedObjects cl bus path =
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant) 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 addInterfaceChangedListener
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler) :: SafeClient c
=> BusName
-> MemberName
-> ObjectPath
-> SignalCallback
-> c
-> IO (Maybe SignalHandler)
addInterfaceChangedListener bus prop path sc cl = do addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop) rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl forM rule $ \r -> addMatchCallback r sc cl
addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath addInterfaceAddedListener
-> SignalCallback -> c -> IO (Maybe SignalHandler) :: SafeClient c
=> BusName
-> ObjectPath
-> SignalCallback
-> c
-> IO (Maybe SignalHandler)
addInterfaceAddedListener bus = addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded addInterfaceChangedListener bus omInterfacesAdded
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath addInterfaceRemovedListener
-> SignalCallback -> c -> IO (Maybe SignalHandler) :: SafeClient c
=> BusName
-> ObjectPath
-> SignalCallback
-> c
-> IO (Maybe SignalHandler)
addInterfaceRemovedListener bus = addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved addInterfaceChangedListener bus omInterfacesRemoved

File diff suppressed because it is too large Load Diff

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dmenu (Rofi) Commands -- Dmenu (Rofi) Commands
module XMonad.Internal.Command.DMenu module XMonad.Internal.Command.DMenu
( runCmdMenu ( runCmdMenu
@ -15,32 +15,28 @@ module XMonad.Internal.Command.DMenu
, runBTMenu , runBTMenu
, runShowKeys , runShowKeys
, runAutorandrMenu , runAutorandrMenu
) where )
where
import Data.Internal.DBus import DBus
import Data.Internal.Dependency import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import Graphics.X11.Types
import qualified RIO.Text as T
import Graphics.X11.Types import System.Directory
( XdgDirectory (..)
import qualified RIO.Text as T , getXdgDirectory
)
import System.Directory import System.IO
( XdgDirectory (..) import XMonad.Core hiding (spawn)
, getXdgDirectory import XMonad.Internal.Command.Desktop
) import XMonad.Internal.DBus.Common
import System.IO import XMonad.Internal.Notify
import XMonad.Internal.Shell
import XMonad.Core hiding (spawn) import XMonad.Util.NamedActions
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 :: FilePath
myDmenuCmd = "rofi" myDmenuCmd = "rofi"
@ -67,7 +63,7 @@ myClipboardManager :: FilePath
myClipboardManager = "greenclip" myClipboardManager = "greenclip"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Packages -- Packages
dmenuPkgs :: [Fulfillment] dmenuPkgs :: [Fulfillment]
dmenuPkgs = [Package Official "rofi"] dmenuPkgs = [Package Official "rofi"]
@ -76,7 +72,7 @@ clipboardPkgs :: [Fulfillment]
clipboardPkgs = [Package AUR "rofi-greenclip"] clipboardPkgs = [Package AUR "rofi-greenclip"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Other internal functions -- Other internal functions
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
spawnDmenuCmd n = spawnDmenuCmd n =
@ -98,7 +94,7 @@ dmenuDep :: IODependency_
dmenuDep = sysExe dmenuPkgs myDmenuCmd dmenuDep = sysExe dmenuPkgs myDmenuCmd
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported Commands -- Exported Commands
-- TODO test that veracrypt and friends are installed -- TODO test that veracrypt and friends are installed
runDevMenu :: SometimesX runDevMenu :: SometimesX
@ -107,28 +103,38 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
t = dmenuTree $ Only_ (localExe [] myDmenuDevices) t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
x = do x = do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall" c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
spawnCmd myDmenuDevices spawnCmd myDmenuDevices $
$ ["-c", T.pack c] ["-c", T.pack c]
++ "--" : themeArgs "#999933" ++ "--"
++ myDmenuMatchingArgs : themeArgs "#999933"
++ myDmenuMatchingArgs
-- TODO test that bluetooth interface exists -- TODO test that bluetooth interface exists
runBTMenu :: SometimesX runBTMenu :: SometimesX
runBTMenu = Sometimes "bluetooth selector" xpfBluetooth runBTMenu =
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"] Sometimes
"bluetooth selector"
xpfBluetooth
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
where where
cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb" cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
runVPNMenu :: SometimesX runVPNMenu :: SometimesX
runVPNMenu = Sometimes "VPN selector" xpfVPN runVPNMenu =
[Subfeature (IORoot_ cmd tree) "rofi VPN"] Sometimes
"VPN selector"
xpfVPN
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
where where
cmd = spawnCmd myDmenuVPN cmd =
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs spawnCmd myDmenuVPN $
tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN) ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
$ socketExists "expressVPN" [] tree =
$ return "/var/lib/expressvpn/expressvpnd.socket" dmenuTree $
toAnd_ (localExe [] myDmenuVPN) $
socketExists "expressVPN" [] $
return "/var/lib/expressvpn/expressvpnd.socket"
runCmdMenu :: SometimesX runCmdMenu :: SometimesX
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
@ -140,15 +146,20 @@ runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: Maybe SysClient -> SometimesX runNetMenu :: Maybe SysClient -> SometimesX
runNetMenu cl = Sometimes "network control menu" enabled runNetMenu cl =
[Subfeature root "network control menu"] Sometimes
"network control menu"
enabled
[Subfeature root "network control menu"]
where where
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
root = DBusRoot_ cmd tree cl root = DBusRoot_ cmd tree cl
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333" cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) tree =
$ toAnd_ (DBusIO dmenuDep) $ DBusIO And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
$ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks toAnd_ (DBusIO dmenuDep) $
DBusIO $
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
runAutorandrMenu :: SometimesX runAutorandrMenu :: SometimesX
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd 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 tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Password manager -- Password manager
runBwMenu :: Maybe SesClient -> SometimesX runBwMenu :: Maybe SesClient -> SometimesX
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
where where
cmd _ = spawnCmd myDmenuPasswords cmd _ =
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs spawnCmd myDmenuPasswords $
tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
$ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords) tree =
And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Clipboard -- Clipboard
runClipMenu :: SometimesX runClipMenu :: SometimesX
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
where where
act = spawnCmd myDmenuCmd args act = spawnCmd myDmenuCmd args
tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager tree =
, process [] $ T.pack myClipboardManager listToAnds
] dmenuDep
args = [ "-modi", "\"clipboard:greenclip print\"" [ sysExe clipboardPkgs myClipboardManager
, "-show", "clipboard" , process [] $ T.pack myClipboardManager
, "-run-command", "'{cmd}'" ]
] ++ themeArgs "#00c44e" args =
[ "-modi"
, "\"clipboard:greenclip print\""
, "-show"
, "clipboard"
, "-run-command"
, "'{cmd}'"
]
++ themeArgs "#00c44e"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Shortcut menu -- Shortcut menu
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_ runShowKeys =
$ FallbackAlone fallback Always "keyboard menu" $
Option showKeysDMenu $
Always_ $
FallbackAlone fallback
where where
-- TODO this should technically depend on dunst -- TODO this should technically depend on dunst
fallback = const $ spawnNotify fallback =
$ defNoteError { body = Just $ Text "could not display keymap" } const $
spawnNotify $
defNoteError {body = Just $ Text "could not display keymap"}
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ()) showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
showKeysDMenu = Subfeature showKeysDMenu =
{ sfName = "keyboard shortcut menu" Subfeature
, sfData = IORoot_ showKeys $ Only_ dmenuDep { sfName = "keyboard shortcut menu"
} , sfData = IORoot_ showKeys $ Only_ dmenuDep
}
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X () showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
showKeys kbs = do showKeys kbs = do
@ -205,5 +232,8 @@ showKeys kbs = do
io $ hPutStr h $ unlines $ showKm kbs io $ hPutStr h $ unlines $ showKm kbs
io $ hClose h io $ hClose h
where where
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] cmd =
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs fmtCmd myDmenuCmd $
["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff"
++ myDmenuMatchingArgs

View File

@ -1,12 +1,11 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | General commands -- General commands
module XMonad.Internal.Command.Desktop module XMonad.Internal.Command.Desktop
( myTerm ( myTerm
, playSound , playSound
-- commands -- commands
, runTerm , runTerm
, runTMux , runTMux
@ -33,37 +32,32 @@ module XMonad.Internal.Command.Desktop
, runNotificationCloseAll , runNotificationCloseAll
, runNotificationHistory , runNotificationHistory
, runNotificationContext , runNotificationContext
-- daemons -- daemons
, runNetAppDaemon , runNetAppDaemon
-- packages -- packages
, networkManagerPkgs , networkManagerPkgs
) where )
where
import Data.Internal.DBus import DBus
import Data.Internal.Dependency import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import RIO
import RIO.FilePath
import RIO import qualified RIO.Process as P
import RIO.FilePath import qualified RIO.Text as T
import qualified RIO.Process as P import System.Directory
import qualified RIO.Text as T import System.Environment
import System.Posix.User
import System.Directory import XMonad.Actions.Volume
import System.Environment import XMonad.Core hiding (spawn)
import System.Posix.User import XMonad.Internal.DBus.Common
import XMonad.Internal.Notify
import XMonad.Actions.Volume import XMonad.Internal.Shell as S
import XMonad.Core hiding (spawn) import XMonad.Operations
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 :: FilePath
myTerm = "urxvt" myTerm = "urxvt"
@ -96,12 +90,13 @@ myNotificationCtrl :: FilePath
myNotificationCtrl = "dunstctl" myNotificationCtrl = "dunstctl"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Packages -- Packages
myTermPkgs :: [Fulfillment] myTermPkgs :: [Fulfillment]
myTermPkgs = [ Package Official "rxvt-unicode" myTermPkgs =
, Package Official "urxvt-perls" [ Package Official "rxvt-unicode"
] , Package Official "urxvt-perls"
]
myEditorPkgs :: [Fulfillment] myEditorPkgs :: [Fulfillment]
myEditorPkgs = [Package Official "emacs-nativecomp"] myEditorPkgs = [Package Official "emacs-nativecomp"]
@ -116,13 +111,13 @@ networkManagerPkgs :: [Fulfillment]
networkManagerPkgs = [Package Official "networkmanager"] networkManagerPkgs = [Package Official "networkmanager"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Misc constants -- Misc constants
volumeChangeSound :: FilePath volumeChangeSound :: FilePath
volumeChangeSound = "smb_fireball.wav" volumeChangeSound = "smb_fireball.wav"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Some nice apps -- Some nice apps
runTerm :: SometimesX runTerm :: SometimesX
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
@ -130,12 +125,14 @@ runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
runTMux :: SometimesX runTMux :: SometimesX
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
where where
deps = listToAnds (socketExists "tmux" [] socketName) deps =
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"] listToAnds (socketExists "tmux" [] socketName) $
act = S.spawn fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
$ fmtCmd "tmux" ["has-session"] act =
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] S.spawn $
#!|| fmtNotifyCmd defNoteError { body = Just $ Text msg } fmtCmd "tmux" ["has-session"]
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
#!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
c = "exec tmux attach-session -d" c = "exec tmux attach-session -d"
msg = "could not connect to tmux session" msg = "could not connect to tmux session"
socketName = do socketName = do
@ -150,28 +147,46 @@ runCalc = sometimesIO_ "calculator" "bc" deps act
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"] act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
runBrowser :: SometimesX runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"] runBrowser =
False myBrowser sometimesExe
"web browser"
"brave"
[Package AUR "brave-bin"]
False
myBrowser
runEditor :: SometimesX runEditor :: SometimesX
runEditor = sometimesIO_ "text editor" "emacs" tree cmd runEditor = sometimesIO_ "text editor" "emacs" tree cmd
where where
cmd = spawnCmd myEditor cmd =
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] 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 -- NOTE 1: we could test if the emacs socket exists, but it won't come up
-- before xmonad starts, so just check to see if the process has started -- before xmonad starts, so just check to see if the process has started
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
runFileManager :: SometimesX runFileManager :: SometimesX
runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"] runFileManager =
True "pcmanfm" sometimesExe
"file browser"
"pcmanfm"
[Package Official "pcmanfm"]
True
"pcmanfm"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Multimedia Commands -- Multimedia Commands
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control") runMultimediaIfInstalled n cmd =
"playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd] sometimesExeArgs
(T.append n " multimedia control")
"playerctl"
[Package Official "playerctl"]
True
myMultimediaCtl
[cmd]
runTogglePlay :: SometimesX runTogglePlay :: SometimesX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
@ -186,7 +201,7 @@ runStopPlay :: SometimesX
runStopPlay = runMultimediaIfInstalled "stop playback" "stop" runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Volume Commands -- Volume Commands
soundDir :: FilePath soundDir :: FilePath
soundDir = "sound" soundDir = "sound"
@ -200,8 +215,8 @@ playSound file = do
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
featureSound n file pre post = featureSound n file pre post =
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
$ pre >> playSound file >> post pre >> playSound file >> post
where where
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed -- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
-- to play sound (duh) but libpulse is the package with the paplay binary -- 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 () runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Notification control -- Notification control
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
runNotificationCmd n arg cl = runNotificationCmd n arg cl =
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
where where
cmd _ = spawnCmd myNotificationCtrl [arg] cmd _ = spawnCmd myNotificationCtrl [arg]
tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) tree =
$ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
$ Method_ $ memberName_ "NotificationAction" Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
Method_ $
memberName_ "NotificationAction"
runNotificationClose :: Maybe SesClient -> SometimesX runNotificationClose :: Maybe SesClient -> SometimesX
runNotificationClose = runNotificationCmd "close notification" "close" runNotificationClose = runNotificationCmd "close notification" "close"
@ -244,47 +261,61 @@ runNotificationContext =
runNotificationCmd "open notification context" "context" runNotificationCmd "open notification context" "context"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | System commands -- System commands
-- this is required for some vpn's to work properly with network-manager -- this is required for some vpn's to work properly with network-manager
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ())) runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
runNetAppDaemon cl = Sometimes "network applet" xpfVPN runNetAppDaemon cl =
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"] Sometimes
"network applet"
xpfVPN
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
where where
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet" app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True) cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
runToggleBluetooth :: Maybe SysClient -> SometimesX runToggleBluetooth :: Maybe SysClient -> SometimesX
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth runToggleBluetooth cl =
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"] Sometimes
"bluetooth toggle"
xpfBluetooth
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
where where
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus) tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
cmd _ = S.spawn cmd _ =
$ fmtCmd myBluetooth ["show"] S.spawn $
#!| "grep -q \"Powered: no\"" fmtCmd myBluetooth ["show"]
#!&& "a=on" #!| "grep -q \"Powered: no\""
#!|| "a=off" #!&& "a=on"
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] #!|| "a=off"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
runToggleEthernet :: SometimesX runToggleEthernet :: SometimesX
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet runToggleEthernet =
[Subfeature root "nmcli"] Sometimes
"ethernet toggle"
xpfEthernet
[Subfeature root "nmcli"]
where where
root = IORoot cmd $ And1 (Only readEthernet) $ Only_ root =
$ sysExe networkManagerPkgs "nmcli" IORoot cmd $
And1 (Only readEthernet) $
Only_ $
sysExe networkManagerPkgs "nmcli"
-- TODO make this less noisy -- TODO make this less noisy
cmd iface = S.spawn cmd iface =
$ fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface] S.spawn $
#!| "grep -q disconnected" fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
#!&& "a=connect" #!| "grep -q disconnected"
#!|| "a=disconnect" #!&& "a=connect"
#!>> fmtCmd "nmcli" ["device", "$a", iface] #!|| "a=disconnect"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!>> fmtCmd "nmcli" ["device", "$a", iface]
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Configuration commands -- Configuration commands
runRestart :: X () runRestart :: X ()
runRestart = restart "xmonad" True runRestart = restart "xmonad" True
@ -294,14 +325,14 @@ runRecompile :: X ()
runRecompile = do runRecompile = do
-- assume that the conf directory contains a valid stack project -- assume that the conf directory contains a valid stack project
confDir <- asks (cfgDir . directories) confDir <- asks (cfgDir . directories)
spawn spawn $
$ fmtCmd "cd" [T.pack confDir] fmtCmd "cd" [T.pack confDir]
#!&& fmtCmd "stack" ["install"] #!&& fmtCmd "stack" ["install"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" } #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" } #!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Screen capture commands -- Screen capture commands
getCaptureDir :: IO FilePath getCaptureDir :: IO FilePath
getCaptureDir = do 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 runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
where where
cmd _ = spawnCmd myCapture [mode] cmd _ = spawnCmd myCapture [mode]
tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) tree =
$ Bus [] $ busName_ "org.flameshot.Flameshot" toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
Bus [] $
busName_ "org.flameshot.Flameshot"
-- TODO this will steal focus from the current window (and puts it -- TODO this will steal focus from the current window (and puts it
-- in the root window?) ...need to fix -- in the root window?) ...need to fix
@ -338,7 +371,10 @@ runScreenCapture :: Maybe SesClient -> SometimesX
runScreenCapture = runFlameshot "screen capture" "screen" runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX runCaptureBrowser :: SometimesX
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh" runCaptureBrowser = sometimesIO_
(Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do "screen capture browser"
dir <- io getCaptureDir "feh"
spawnCmd myImageBrowser [T.pack dir] (Only_ $ sysExe [Package Official "feh"] myImageBrowser)
$ do
dir <- io getCaptureDir
spawnCmd myImageBrowser [T.pack dir]

View File

@ -1,10 +1,10 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Commands for controlling power -- Commands for controlling power
module XMonad.Internal.Command.Power module XMonad.Internal.Command.Power
-- commands -- commands
( runHibernate ( runHibernate
, runOptimusPrompt , runOptimusPrompt
, runPowerOff , runPowerOff
@ -14,10 +14,8 @@ module XMonad.Internal.Command.Power
, runSuspend , runSuspend
, runSuspendPrompt , runSuspendPrompt
, runQuitPrompt , runQuitPrompt
-- daemons -- daemons
, runAutolock , runAutolock
-- functions -- functions
, hasBattery , hasBattery
, suspendPrompt , suspendPrompt
@ -25,32 +23,27 @@ module XMonad.Internal.Command.Power
, powerPrompt , powerPrompt
, defFontPkgs , defFontPkgs
, promptFontDep , promptFontDep
) where )
where
import Data.Internal.Dependency import Data.Either
import Data.Internal.Dependency
import Data.Either import qualified Data.Map as M
import qualified Data.Map as M import Graphics.X11.Types
import RIO
import Graphics.X11.Types import RIO.FilePath
import qualified RIO.Process as P
import RIO import qualified RIO.Text as T
import RIO.FilePath import System.Directory
import qualified RIO.Process as P import System.IO.Error
import qualified RIO.Text as T import XMonad.Core hiding (spawn)
import XMonad.Internal.Shell
import System.Directory import qualified XMonad.Internal.Theme as XT
import System.IO.Error import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt
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 :: FilePath
myScreenlock = "screenlock" myScreenlock = "screenlock"
@ -61,17 +54,22 @@ myPrimeOffload :: FilePath
myPrimeOffload = "prime-offload" myPrimeOffload = "prime-offload"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Packages -- Packages
optimusPackages :: [Fulfillment] optimusPackages :: [Fulfillment]
optimusPackages = [Package AUR "optimus-manager"] optimusPackages = [Package AUR "optimus-manager"]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Core commands -- Core commands
runScreenLock :: SometimesX runScreenLock :: SometimesX
runScreenLock = sometimesExe "screen locker" "i3lock script" runScreenLock =
[Package AUR "i3lock-color"] False myScreenlock sometimesExe
"screen locker"
"i3lock script"
[Package AUR "i3lock-color"]
False
myScreenlock
runPowerOff :: X () runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff" runPowerOff = spawn "systemctl poweroff"
@ -86,17 +84,19 @@ runReboot :: X ()
runReboot = spawn "systemctl reboot" runReboot = spawn "systemctl reboot"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Autolock -- Autolock
runAutolock :: Sometimes (FIO (P.Process () () ())) runAutolock :: Sometimes (FIO (P.Process () () ()))
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
where where
tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") tree =
$ Only_ $ IOSometimes_ runScreenLock 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) cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Confirmation prompts -- Confirmation prompts
promptFontDep :: IOTree XT.FontBuilder promptFontDep :: IOTree XT.FontBuilder
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
@ -124,7 +124,7 @@ runQuitPrompt :: SometimesX
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Nvidia Optimus -- Nvidia Optimus
-- TODO for some reason the screen never wakes up after suspend when -- 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 -- the nvidia card is up, so block suspend if nvidia card is running
@ -148,30 +148,36 @@ runOptimusPrompt' fb = do
where where
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
prompt mode = T.concat ["gpu switch to ", mode, "?"] prompt mode = T.concat ["gpu switch to ", mode, "?"]
cmd mode = spawn cmd mode =
$ T.pack myPrimeOffload spawn $
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"] T.pack myPrimeOffload
#!&& "killall xmonad" #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad"
runOptimusPrompt :: SometimesX runOptimusPrompt :: SometimesX
runOptimusPrompt = Sometimes "graphics switcher" runOptimusPrompt =
(\x -> xpfOptimus x && xpfBattery x) [s] Sometimes
"graphics switcher"
(\x -> xpfOptimus x && xpfBattery x)
[s]
where where
s = Subfeature { sfData = r, sfName = "optimus manager" } s = Subfeature {sfData = r, sfName = "optimus manager"}
r = IORoot runOptimusPrompt' t r = IORoot runOptimusPrompt' t
t = And1 promptFontDep t =
$ listToAnds (socketExists "optimus-manager" [] socketName) And1 promptFontDep $
$ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload] listToAnds (socketExists "optimus-manager" [] socketName) $
sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
socketName = (</> "optimus-manager") <$> getTemporaryDirectory socketName = (</> "optimus-manager") <$> getTemporaryDirectory
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Universal power prompt -- Universal power prompt
data PowerMaybeAction = Poweroff data PowerMaybeAction
| Shutdown = Poweroff
| Hibernate | Shutdown
| Reboot | Hibernate
deriving (Eq) | Reboot
deriving (Eq)
instance Enum PowerMaybeAction where instance Enum PowerMaybeAction where
toEnum 0 = Poweroff toEnum 0 = Poweroff
@ -180,15 +186,15 @@ instance Enum PowerMaybeAction where
toEnum 3 = Reboot toEnum 3 = Reboot
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument" toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
fromEnum Poweroff = 0 fromEnum Poweroff = 0
fromEnum Shutdown = 1 fromEnum Shutdown = 1
fromEnum Hibernate = 2 fromEnum Hibernate = 2
fromEnum Reboot = 3 fromEnum Reboot = 3
data PowerPrompt = PowerPrompt data PowerPrompt = PowerPrompt
instance XPrompt PowerPrompt where 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 :: SometimesX
runPowerPrompt = Sometimes "power prompt" (const True) [sf] runPowerPrompt = Sometimes "power prompt" (const True) [sf]
@ -202,20 +208,22 @@ powerPrompt :: X () -> XT.FontBuilder -> X ()
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
where where
comp = mkComplFunFromList theme [] comp = mkComplFunFromList theme []
theme = (XT.promptTheme fb) { promptKeymap = keymap } theme = (XT.promptTheme fb) {promptKeymap = keymap}
keymap = M.fromList keymap =
$ ((controlMask, xK_g), quit) : M.fromList $
map (first $ (,) 0) ((controlMask, xK_g), quit)
[ (xK_p, sendMaybeAction Poweroff) : map
, (xK_s, sendMaybeAction Shutdown) (first $ (,) 0)
, (xK_h, sendMaybeAction Hibernate) [ (xK_p, sendMaybeAction Poweroff)
, (xK_r, sendMaybeAction Reboot) , (xK_s, sendMaybeAction Shutdown)
, (xK_Return, quit) , (xK_h, sendMaybeAction Hibernate)
, (xK_Escape, quit) , (xK_r, sendMaybeAction Reboot)
] , (xK_Return, quit)
, (xK_Escape, quit)
]
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
executeMaybeAction a = case toEnum $ read a of executeMaybeAction a = case toEnum $ read a of
Poweroff -> runPowerOff Poweroff -> runPowerOff
Shutdown -> lock >> runSuspend Shutdown -> lock >> runSuspend
Hibernate -> lock >> runHibernate Hibernate -> lock >> runHibernate
Reboot -> runReboot Reboot -> runReboot

View File

@ -1,38 +1,37 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Concurrent module to handle events from acpid -- Concurrent module to handle events from acpid
module XMonad.Internal.Concurrent.ACPIEvent module XMonad.Internal.Concurrent.ACPIEvent
( runPowermon ( runPowermon
, runHandleACPI , runHandleACPI
) where )
where
import Data.Internal.Dependency import Data.Internal.Dependency
import Network.Socket
import Network.Socket import Network.Socket.ByteString
import Network.Socket.ByteString import RIO
import qualified RIO.ByteString as B
import RIO import XMonad.Core
import qualified RIO.ByteString as B import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage
import XMonad.Core import XMonad.Internal.Shell
import XMonad.Internal.Command.Power import XMonad.Internal.Theme (FontBuilder)
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 -- Enumerate so these can be converted to strings and back when sent in a
-- ClientMessage event to X -- ClientMessage event to X
data ACPIEvent = Power data ACPIEvent
| Sleep = Power
| LidClose | Sleep
deriving (Eq) | LidClose
deriving (Eq)
instance Enum ACPIEvent where instance Enum ACPIEvent where
toEnum 0 = Power toEnum 0 = Power
@ -40,24 +39,24 @@ instance Enum ACPIEvent where
toEnum 2 = LidClose toEnum 2 = LidClose
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument" toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
fromEnum Power = 0 fromEnum Power = 0
fromEnum Sleep = 1 fromEnum Sleep = 1
fromEnum LidClose = 2 fromEnum LidClose = 2
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Internal functions -- Internal functions
-- | Convert a string to an ACPI event (this string is assumed to come from -- | Convert a string to an ACPI event (this string is assumed to come from
-- the acpid socket) -- the acpid socket)
parseLine :: ByteString -> Maybe ACPIEvent parseLine :: ByteString -> Maybe ACPIEvent
parseLine line = parseLine line =
case splitLine line of case splitLine line of
(_:"PBTN":_) -> Just Power (_ : "PBTN" : _) -> Just Power
(_:"PWRF":_) -> Just Power (_ : "PWRF" : _) -> Just Power
(_:"SLPB":_) -> Just Sleep (_ : "SLPB" : _) -> Just Sleep
(_:"SBTN":_) -> Just Sleep (_ : "SBTN" : _) -> Just Sleep
(_:"LID":"close":_) -> Just LidClose (_ : "LID" : "close" : _) -> Just LidClose
_ -> Nothing _ -> Nothing
where where
splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
newline = 10 newline = 10
@ -71,7 +70,7 @@ isDischarging :: IO (Maybe Bool)
isDischarging = do isDischarging = do
status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status" status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
case status of case status of
Left _ -> return Nothing Left _ -> return Nothing
Right s -> return $ Just (s == "Discharging") Right s -> return $ Just (s == "Discharging")
listenACPI :: IO () listenACPI :: IO ()
@ -103,7 +102,7 @@ handleACPI fb lock tag = do
lock lock
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported API -- Exported API
-- | Spawn a new thread that will listen for ACPI events on the acpid socket -- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them -- and send ClientMessage events when it receives them
@ -114,7 +113,9 @@ runHandleACPI :: Always (String -> X ())
runHandleACPI = Always "ACPI event handler" $ Option sf fallback runHandleACPI = Always "ACPI event handler" $ Option sf fallback
where where
sf = Subfeature withLock "acpid prompt" sf = Subfeature withLock "acpid prompt"
withLock = IORoot (uncurry handleACPI) withLock =
$ And12 (,) promptFontDep $ Only IORoot (uncurry handleACPI) $
$ IOSometimes runScreenLock id And12 (,) promptFontDep $
Only $
IOSometimes runScreenLock id
fallback = Always_ $ FallbackAlone $ const skip fallback = Always_ $ FallbackAlone $ const skip

View File

@ -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 -- 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 -- 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 -- much like something from X even though it isn't
module XMonad.Internal.Concurrent.ClientMessage module XMonad.Internal.Concurrent.ClientMessage
( XMsgType(..) ( XMsgType (..)
, sendXMsg , sendXMsg
, splitXMsg , splitXMsg
) where )
where
import Data.Char import Data.Char
import Graphics.X11.Types
import Graphics.X11.Types import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Event import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Types
import Graphics.X11.Xlib.Types import RIO hiding (Display)
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 -- 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? -- TODO is there a way to do this in the libraries that import this one?
data XMsgType = ACPI data XMsgType
| Workspace = ACPI
| Unknown | Workspace
deriving (Eq, Show) | Unknown
deriving (Eq, Show)
instance Enum XMsgType where instance Enum XMsgType where
toEnum 0 = ACPI toEnum 0 = ACPI
toEnum 1 = Workspace toEnum 1 = Workspace
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument" toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
fromEnum ACPI = 0 fromEnum ACPI = 0
fromEnum Workspace = 1 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 -- | Given a string from the data field in a ClientMessage event, return the
-- type and payload -- type and payload
splitXMsg :: (Integral a) => [a] -> (XMsgType, String) splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
splitXMsg [] = (Unknown, "") splitXMsg [] = (Unknown, "")
splitXMsg (x:xs) = (xtype, tag) splitXMsg (x : xs) = (xtype, tag)
where where
xtype = toEnum $ fromIntegral x xtype = toEnum $ fromIntegral x
tag = chr . fromIntegral <$> takeWhile (/= 0) xs 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 -- 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 -- with 0 (note this used to be random garbage before). See this function
-- for more details. -- for more details.
setClientMessageEvent' e root bITMAP 8 (x:t) setClientMessageEvent' e root bITMAP 8 (x : t)
sendEvent dpy root False substructureNotifyMask e sendEvent dpy root False substructureNotifyMask e
where where
x = fromIntegral $ fromEnum xtype x = fromIntegral $ fromEnum xtype

View File

@ -1,5 +1,5 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Automatically Manage Dynamic Workspaces -- Automatically Manage Dynamic Workspaces
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module -- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
-- in the contrib library. The general behavior this allows: -- in the contrib library. The general behavior this allows:
-- 1) launch app -- 1) launch app
@ -24,72 +24,66 @@
-- 3) Virtualbox (should always be by itself anyways) -- 3) Virtualbox (should always be by itself anyways)
module XMonad.Internal.Concurrent.DynamicWorkspaces module XMonad.Internal.Concurrent.DynamicWorkspaces
( DynWorkspace(..) ( DynWorkspace (..)
, appendShift , appendShift
, appendViewShift , appendViewShift
, removeDynamicWorkspace , removeDynamicWorkspace
, runWorkspaceMon , runWorkspaceMon
, spawnOrSwitch , spawnOrSwitch
, doSink , doSink
) where )
where
import Data.List (deleteBy, find)
import qualified Data.Map as M
import Data.Maybe
-- import Control.Concurrent -- import Control.Concurrent
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import Data.List (deleteBy, find)
import qualified Data.Map as M
import Graphics.X11.Types import Data.Maybe
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Misc import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Types import Graphics.X11.Xlib.Types
import RIO hiding
import RIO hiding ( Display
( Display , display
, display )
) import qualified RIO.Set as S
import qualified RIO.Set as S import System.Process
import XMonad.Actions.DynamicWorkspaces
import System.Process import XMonad.Core
( ManageHook
import XMonad.Actions.DynamicWorkspaces , WorkspaceId
import XMonad.Core , X
( ManageHook , io
, WorkspaceId , withWindowSet
, X )
, io import XMonad.Hooks.ManageHelpers (MaybeManageHook)
, withWindowSet import XMonad.Internal.Concurrent.ClientMessage
) import XMonad.Internal.IO
import XMonad.Hooks.ManageHelpers (MaybeManageHook) import XMonad.ManageHook
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Operations
import XMonad.Internal.IO import qualified XMonad.StackSet as W
import XMonad.ManageHook
import XMonad.Operations
import qualified XMonad.StackSet as W
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dynamic Workspace datatype -- Dynamic Workspace datatype
-- This hold all the data needed to tie an app to a particular dynamic workspace -- This holds all the data needed to tie an app to a particular dynamic workspace
data DynWorkspace = DynWorkspace data DynWorkspace = DynWorkspace
{ dwName :: String { dwName :: String
, dwTag :: WorkspaceId , dwTag :: WorkspaceId
, dwClass :: String , dwClass :: String
, dwHook :: [MaybeManageHook] , dwHook :: [MaybeManageHook]
, dwKey :: Char , dwKey :: Char
, dwCmd :: Maybe (X ()) , dwCmd :: Maybe (X ())
-- TODO this should also have the layout for this workspace -- 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 -- 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 -- 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 -- the PID exits, it sends a ClientMessage event to X
@ -99,10 +93,10 @@ data DynWorkspace = DynWorkspace
-- type MatchTags = M.Map String String -- type MatchTags = M.Map String String
data WConf = WConf data WConf = WConf
{ display :: Display { display :: Display
, dynWorkspaces :: [DynWorkspace] , dynWorkspaces :: [DynWorkspace]
, curPIDs :: MVar (S.Set Pid) , curPIDs :: MVar (S.Set Pid)
} }
type W a = RIO WConf () type W a = RIO WConf ()
@ -120,51 +114,56 @@ runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
where where
withEvents dpy e = do withEvents dpy e = do
ps <- newMVar S.empty ps <- newMVar S.empty
let c = WConf { display = dpy, dynWorkspaces = dws, curPIDs = ps } let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
runRIO c runRIO c $
$ forever forever $
$ handleEvent =<< io (nextEvent dpy e >> getEvent e) handleEvent =<< io (nextEvent dpy e >> getEvent e)
handleEvent :: Event -> W () handleEvent :: Event -> W ()
-- | assume this fires at least once when a new window is created (also could -- | assume this fires at least once when a new window is created (also could
-- use CreateNotify but that is really noisy) -- use CreateNotify but that is really noisy)
handleEvent MapNotifyEvent { ev_window = w } = do handleEvent MapNotifyEvent {ev_window = w} = do
dpy <- asks display dpy <- asks display
hint <- io $ getClassHint dpy w hint <- io $ getClassHint dpy w
dws <- asks dynWorkspaces dws <- asks dynWorkspaces
let tag = M.lookup (resClass hint) let tag =
$ M.fromList M.lookup (resClass hint) $
$ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws M.fromList $
fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
forM_ tag $ \t -> do forM_ tag $ \t -> do
a <- io $ internAtom dpy "_NET_WM_PID" False a <- io $ internAtom dpy "_NET_WM_PID" False
pid <- io $ getWindowProperty32 dpy a w pid <- io $ getWindowProperty32 dpy a w
case pid of case pid of
-- ASSUMPTION windows will only have one PID at one time -- ASSUMPTION windows will only have one PID at one time
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
_ -> return () _ -> return ()
handleEvent _ = return () handleEvent _ = return ()
withUniquePid :: Pid -> String -> W () withUniquePid :: Pid -> String -> W ()
withUniquePid pid tag = do withUniquePid pid tag = do
ps <- asks curPIDs ps <- asks curPIDs
pids <- readMVar ps pids <- readMVar ps
io $ unless (pid `elem` pids) $ bracket_ io
(modifyMVar_ ps (return . S.insert pid)) $ unless (pid `elem` pids)
(modifyMVar_ ps (return . S.delete pid)) $ bracket_
(modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete pid))
$ waitUntilExit pid >> sendXMsg Workspace tag $ waitUntilExit pid >> sendXMsg Workspace tag
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Launching apps -- Launching apps
-- When launching apps on dymamic workspaces, first check if they are running -- When launching apps on dymamic workspaces, first check if they are running
-- and launch if not, then switch to their workspace -- and launch if not, then switch to their workspace
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack) wsOccupied tag ws =
-- list of all workspaces with windows on them elem tag $
-- TODO is there not a better way to do this? map W.tag $
$ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws) 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 :: WorkspaceId -> X () -> X ()
spawnOrSwitch tag cmd = do spawnOrSwitch tag cmd = do
@ -172,7 +171,7 @@ spawnOrSwitch tag cmd = do
if occupied then windows $ W.view tag else cmd if occupied then windows $ W.view tag else cmd
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Managehook -- Managehook
-- Move windows to new workspace if they are part of a dynamic workspace -- Move windows to new workspace if they are part of a dynamic workspace
-- shamelessly ripped off from appendWorkspace (this analogue doesn't exist) -- 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 -- TODO surprisingly this doesn't exist? We shouldn't need to TBH
doSink :: ManageHook doSink :: ManageHook
doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
Just s' -> W.sink (W.focus s') s Just s' -> W.sink (W.focus s') s
Nothing -> s Nothing -> s
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Eventhook -- Eventhook
-- When an app is closed, this will respond the event that is sent in the main -- When an app is closed, this will respond the event that is sent in the main
-- XMonad thread -- XMonad thread
removeDynamicWorkspace :: WorkspaceId -> X () removeDynamicWorkspace :: WorkspaceId -> X ()
removeDynamicWorkspace target = windows removeIfEmpty removeDynamicWorkspace target = windows removeIfEmpty
where where
-- remove workspace if it is empty and if there are hidden workspaces -- 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 -- if hidden, delete from hidden
| Just x <- find isEmptyTarget hall | Just x <- find isEmptyTarget hall =
= s { W.hidden = deleteBy (eq W.tag) x hall } s {W.hidden = deleteBy (eq W.tag) x hall}
-- if visible, delete from visible and move first hidden to its place -- if visible, delete from visible and move first hidden to its place
| Just x <- find (isEmptyTarget . W.workspace) vis | Just x <- find (isEmptyTarget . W.workspace) vis =
= s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis s
, W.hidden = hs } { 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 -- if current, move the first hidden workspace to the current
| isEmptyTarget $ W.workspace $ W.current s | isEmptyTarget $ W.workspace $ W.current s =
= s { W.current = (W.current s) { W.workspace = h }, W.hidden = hs } s {W.current = (W.current s) {W.workspace = h}, W.hidden = hs}
-- otherwise do nothing -- otherwise do nothing
| otherwise = s | otherwise = s
removeIfEmpty s = s removeIfEmpty s = s

View File

@ -1,25 +1,23 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | VirtualBox-specific functions -- VirtualBox-specific functions
module XMonad.Internal.Concurrent.VirtualBox module XMonad.Internal.Concurrent.VirtualBox
( vmExists ( vmExists
, vmInstanceConfig , vmInstanceConfig
, qual , qual
) where )
where
import Data.Internal.Dependency import Data.Internal.Dependency
import RIO hiding (try)
import Text.XML.Light import RIO.Directory
import RIO.FilePath
import RIO hiding (try) import qualified RIO.Text as T
import RIO.Directory import Text.XML.Light
import RIO.FilePath import XMonad.Internal.Shell
import qualified RIO.Text as T
import XMonad.Internal.Shell
vmExists :: T.Text -> IO (Maybe Msg) vmExists :: T.Text -> IO (Maybe Msg)
vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm
@ -32,7 +30,7 @@ vmInstanceConfig vmName = do
findInstance dir = do findInstance dir = do
res <- findFile [dir] path res <- findFile [dir] path
return $ case res of return $ case res of
Just p -> Right p Just p -> Right p
Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName
vmDirectory :: IO (Either String String) vmDirectory :: IO (Either String String)
@ -41,15 +39,17 @@ vmDirectory = do
s <- tryIO $ readFile p s <- tryIO $ readFile p
return $ case s of return $ case s of
(Left _) -> Left "could not read VirtualBox config file" (Left _) -> Left "could not read VirtualBox config file"
(Right x) -> maybe (Left "Could not parse VirtualBox config file") Right (Right x) ->
$ findDir =<< parseXMLDoc x maybe (Left "Could not parse VirtualBox config file") Right $
findDir =<< parseXMLDoc x
where where
findDir e = findAttr (unqual "defaultMachineFolder") findDir e =
=<< findChild (qual e "SystemProperties") findAttr (unqual "defaultMachineFolder")
=<< findChild (qual e "Global") e =<< findChild (qual e "SystemProperties")
=<< findChild (qual e "Global") e
qual :: Element -> String -> QName qual :: Element -> String -> QName
qual e n = (elName e) { qName = n } qual e n = (elName e) {qName = n}
vmConfig :: IO FilePath vmConfig :: IO FilePath
vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml" vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml"

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus module for Clevo Keyboard control -- DBus module for Clevo Keyboard control
module XMonad.Internal.DBus.Brightness.ClevoKeyboard module XMonad.Internal.DBus.Brightness.ClevoKeyboard
( callGetBrightnessCK ( callGetBrightnessCK
@ -10,24 +10,21 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
, clevoKeyboardControls , clevoKeyboardControls
, clevoKeyboardSignalDep , clevoKeyboardSignalDep
, blPath , blPath
) where )
where
import Control.Monad (when) import Control.Monad (when)
import DBus
import Data.Int (Int32) import Data.Int (Int32)
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import RIO.FilePath
import DBus import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO
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 Brightness = Float
type RawBrightness = Int32 type RawBrightness = Int32
@ -84,7 +81,7 @@ decBrightness bounds = do
return b return b
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus interface -- DBus interface
blPath :: ObjectPath blPath :: ObjectPath
blPath = objectPath_ "/clevo_keyboard" blPath = objectPath_ "/clevo_keyboard"
@ -93,21 +90,22 @@ interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
clevoKeyboardConfig = BrightnessConfig clevoKeyboardConfig =
{ bcMin = minBrightness BrightnessConfig
, bcMax = maxBrightness { bcMin = minBrightness
, bcInc = incBrightness , bcMax = maxBrightness
, bcDec = decBrightness , bcInc = incBrightness
, bcGet = getBrightness , bcDec = decBrightness
, bcGetMax = return maxRawBrightness , bcGet = getBrightness
, bcMinRaw = minRawBrightness , bcGetMax = return maxRawBrightness
, bcPath = blPath , bcMinRaw = minRawBrightness
, bcInterface = interface , bcPath = blPath
, bcName = "Clevo keyboard" , bcInterface = interface
} , bcName = "Clevo keyboard"
}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- Exported haskell API
stateFileDep :: IODependency_ stateFileDep :: IODependency_
stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"] stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
@ -119,8 +117,12 @@ clevoKeyboardSignalDep :: DBusDependency_ SesClient
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
exportClevoKeyboard :: Maybe SesClient -> SometimesIO exportClevoKeyboard :: Maybe SesClient -> SometimesIO
exportClevoKeyboard = brightnessExporter xpfClevoBacklight [] exportClevoKeyboard =
[stateFileDep, brightnessFileDep] clevoKeyboardConfig brightnessExporter
xpfClevoBacklight
[]
[stateFileDep, brightnessFileDep]
clevoKeyboardConfig
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig

View File

@ -1,35 +1,32 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus module for DBus brightness controls -- DBus module for DBus brightness controls
module XMonad.Internal.DBus.Brightness.Common module XMonad.Internal.DBus.Brightness.Common
( BrightnessConfig(..) ( BrightnessConfig (..)
, BrightnessControls(..) , BrightnessControls (..)
, brightnessControls , brightnessControls
, brightnessExporter , brightnessExporter
, callGetBrightness , callGetBrightness
, matchSignal , matchSignal
, signalDep , signalDep
) where )
where
import Control.Monad (void) import Control.Monad (void)
import DBus
import Data.Int (Int32) import DBus.Client
import Data.Internal.DBus import qualified DBus.Introspection as I
import Data.Internal.Dependency import Data.Int (Int32)
import Data.Internal.DBus
import DBus import Data.Internal.Dependency
import DBus.Client import qualified RIO.Text as T
import qualified DBus.Introspection as I import XMonad.Core (io)
import XMonad.Internal.DBus.Common
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 -- Define four methods to increase, decrease, maximize, or minimize the
-- brightness. These methods will all return the current brightness as a 32-bit -- 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. -- is one method to get the current brightness.
data BrightnessConfig a b = BrightnessConfig data BrightnessConfig a b = BrightnessConfig
{ bcMin :: (a, a) -> IO b { bcMin :: (a, a) -> IO b
, bcMax :: (a, a) -> IO b , bcMax :: (a, a) -> IO b
, bcDec :: (a, a) -> IO b , bcDec :: (a, a) -> IO b
, bcInc :: (a, a) -> IO b , bcInc :: (a, a) -> IO b
, bcGet :: (a, a) -> IO b , bcGet :: (a, a) -> IO b
, bcMinRaw :: a , bcMinRaw :: a
, bcGetMax :: IO a , bcGetMax :: IO a
, bcPath :: ObjectPath , bcPath :: ObjectPath
, bcInterface :: InterfaceName , bcInterface :: InterfaceName
, bcName :: T.Text , bcName :: T.Text
} }
data BrightnessControls = BrightnessControls data BrightnessControls = BrightnessControls
@ -56,46 +53,63 @@ data BrightnessControls = BrightnessControls
, bctlDec :: SometimesX , bctlDec :: SometimesX
} }
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient brightnessControls
:: XPQuery
-> BrightnessConfig a b
-> Maybe SesClient
-> BrightnessControls -> BrightnessControls
brightnessControls q bc cl = brightnessControls q bc cl =
BrightnessControls BrightnessControls
{ bctlMax = cb "max brightness" memMax { bctlMax = cb "max brightness" memMax
, bctlMin = cb "min brightness" memMin , bctlMin = cb "min brightness" memMin
, bctlInc = cb "increase brightness" memInc , bctlInc = cb "increase brightness" memInc
, bctlDec = cb "decrease brightness" memDec , bctlDec = cb "decrease brightness" memDec
} }
where where
cb = callBacklight q cl bc 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) -> IO (Maybe n)
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
either (const Nothing) bodyGetBrightness either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet <$> callMethod client xmonadBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadBusName p i $ Signal_ memCur Endpoint [] xmonadBusName p i $ Signal_ memCur
matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b matchSignal
-> (Maybe n-> IO ()) -> c -> IO () :: (SafeClient c, Num n)
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = => BrightnessConfig a b
-> (Maybe n -> IO ())
-> c
-> IO ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness) void . addMatchCallback brMatcher (cb . bodyGetBrightness)
where where
-- TODO add busname to this -- TODO add busname to this
brMatcher = matchAny brMatcher =
{ matchPath = Just p matchAny
, matchInterface = Just i { matchPath = Just p
, matchMember = Just memCur , matchInterface = Just i
} , matchMember = Just memCur
}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Internal DBus Crap -- Internal DBus Crap
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_] brightnessExporter
-> BrightnessConfig a b -> Maybe SesClient -> SometimesIO :: RealFrac b
brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl = => 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"] Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
where where
root = DBusRoot_ (exportBrightnessControls' bc) tree cl root = DBusRoot_ (exportBrightnessControls' bc) tree cl
@ -108,51 +122,66 @@ exportBrightnessControls' bc cl = io $ do
let bounds = (bcMinRaw bc, maxval) let bounds = (bcMinRaw bc, maxval)
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
let funget = bcGet bc let funget = bcGet bc
export ses (bcPath bc) defaultInterface export
{ interfaceName = bcInterface bc ses
, interfaceMethods = (bcPath bc)
[ autoMethod' memMax bcMax defaultInterface
, autoMethod' memMin bcMin { interfaceName = bcInterface bc
, autoMethod' memInc bcInc , interfaceMethods =
, autoMethod' memDec bcDec [ autoMethod' memMax bcMax
, autoMethod memGet (round <$> funget bounds :: IO Int32) , autoMethod' memMin bcMin
] , autoMethod' memInc bcInc
, interfaceSignals = [sig] , autoMethod' memDec bcDec
} , autoMethod memGet (round <$> funget bounds :: IO Int32)
where ]
sig = I.Signal , interfaceSignals = [sig]
{ I.signalName = memCur
, I.signalArgs =
[
I.SignalArg
{ I.signalArgName = "brightness"
, I.signalArgType = TypeInt32
}
]
} }
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 :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
emit client $ sig { signalBody = [toVariant (round cur :: Int32)] } emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
where where
sig = signal p i memCur sig = signal p i memCur
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text callBacklight
-> MemberName -> SometimesX :: XPQuery
callBacklight q cl BrightnessConfig { bcPath = p -> Maybe SesClient
, bcInterface = i -> BrightnessConfig a b
, bcName = n } controlName m = -> T.Text
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"] -> MemberName
where -> SometimesX
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl callBacklight
cmd c = io $ void $ callMethod c xmonadBusName p i m 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 :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
bodyGetBrightness _ = Nothing bodyGetBrightness _ = Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus Members -- DBus Members
memCur :: MemberName memCur :: MemberName
memCur = memberName_ "CurrentBrightness" memCur = memberName_ "CurrentBrightness"

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus module for Intel Backlight control -- DBus module for Intel Backlight control
module XMonad.Internal.DBus.Brightness.IntelBacklight module XMonad.Internal.DBus.Brightness.IntelBacklight
( callGetBrightnessIB ( callGetBrightnessIB
@ -10,22 +10,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
, intelBacklightControls , intelBacklightControls
, intelBacklightSignalDep , intelBacklightSignalDep
, blPath , blPath
) where )
where
import Data.Int (Int32) import DBus
import Data.Internal.DBus import Data.Int (Int32)
import Data.Internal.Dependency import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common
import RIO.FilePath import XMonad.Internal.IO
import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Low level sysfs functions -- Low level sysfs functions
--
type Brightness = Float type Brightness = Float
type RawBrightness = Int32 type RawBrightness = Int32
@ -66,7 +64,7 @@ decBrightness :: RawBounds -> IO Brightness
decBrightness = decPercent steps curFile decBrightness = decPercent steps curFile
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus interface -- DBus interface
blPath :: ObjectPath blPath :: ObjectPath
blPath = objectPath_ "/intelbacklight" blPath = objectPath_ "/intelbacklight"
@ -75,21 +73,22 @@ interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
intelBacklightConfig = BrightnessConfig intelBacklightConfig =
{ bcMin = minBrightness BrightnessConfig
, bcMax = maxBrightness { bcMin = minBrightness
, bcInc = incBrightness , bcMax = maxBrightness
, bcDec = decBrightness , bcInc = incBrightness
, bcGet = getBrightness , bcDec = decBrightness
, bcGetMax = getMaxRawBrightness , bcGet = getBrightness
, bcMinRaw = minRawBrightness , bcGetMax = getMaxRawBrightness
, bcPath = blPath , bcMinRaw = minRawBrightness
, bcInterface = interface , bcPath = blPath
, bcName = "Intel backlight" , bcInterface = interface
} , bcName = "Intel backlight"
}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- Exported haskell API
curFileDep :: IODependency_ curFileDep :: IODependency_
curFileDep = pathRW curFile [] curFileDep = pathRW curFile []
@ -101,8 +100,12 @@ intelBacklightSignalDep :: DBusDependency_ SesClient
intelBacklightSignalDep = signalDep intelBacklightConfig intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Maybe SesClient -> SometimesIO exportIntelBacklight :: Maybe SesClient -> SometimesIO
exportIntelBacklight = brightnessExporter xpfIntelBacklight [] exportIntelBacklight =
[curFileDep, maxFileDep] intelBacklightConfig brightnessExporter
xpfIntelBacklight
[]
[curFileDep, maxFileDep]
intelBacklightConfig
intelBacklightControls :: Maybe SesClient -> BrightnessControls intelBacklightControls :: Maybe SesClient -> BrightnessControls
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig

View File

@ -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 module XMonad.Internal.DBus.Common
( xmonadBusName ( xmonadBusName
@ -7,9 +7,10 @@ module XMonad.Internal.DBus.Common
, notifyBus , notifyBus
, notifyPath , notifyPath
, networkManagerBus , networkManagerBus
) where )
where
import DBus import DBus
xmonadBusName :: BusName xmonadBusName :: BusName
xmonadBusName = busName_ "org.xmonad" xmonadBusName = busName_ "org.xmonad"
@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
networkManagerBus :: BusName networkManagerBus :: BusName
networkManagerBus = busName_ "org.freedesktop.NetworkManager" networkManagerBus = busName_ "org.freedesktop.NetworkManager"

View File

@ -1,11 +1,11 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus -- High-level interface for managing XMonad's DBus
module XMonad.Internal.DBus.Control module XMonad.Internal.DBus.Control
( Client ( Client
, DBusState(..) , DBusState (..)
, connectDBus , connectDBus
, connectDBusX , connectDBusX
, disconnectDBus , disconnectDBus
@ -15,33 +15,31 @@ module XMonad.Internal.DBus.Control
, withDBusClient_ , withDBusClient_
, disconnect , disconnect
, dbusExporters , dbusExporters
) where )
where
import Control.Monad import Control.Monad
import DBus
import Data.Internal.DBus import DBus.Client
import Data.Internal.Dependency import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import DBus.Client import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Screensaver
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) -- | Current connections to the DBus (session and system buses)
data DBusState = DBusState data DBusState = DBusState
{ dbSesClient :: Maybe SesClient { dbSesClient :: Maybe SesClient
, dbSysClient :: Maybe SysClient , dbSysClient :: Maybe SysClient
} }
-- | Connect to the DBus -- | Connect to the DBus
connectDBus :: IO DBusState connectDBus :: IO DBusState
connectDBus = do connectDBus = do
ses <- getDBusClient ses <- getDBusClient
sys <- getDBusClient sys <- getDBusClient
return DBusState { dbSesClient = ses, dbSysClient = sys } return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus -- | Disconnect from the DBus
disconnectDBus :: DBusState -> IO () disconnectDBus :: DBusState -> IO ()
@ -73,11 +71,13 @@ requestXMonadName :: SesClient -> IO ()
requestXMonadName ses = do requestXMonadName ses = do
res <- requestName (toClient ses) xmonadBusName [] res <- requestName (toClient ses) xmonadBusName []
-- TODO if the client is not released on shutdown the owner will be different -- TODO if the client is not released on shutdown the owner will be different
let msg | res == NamePrimaryOwner = Nothing let msg
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn | res == NamePrimaryOwner = Nothing
| res == NameInQueue | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
|| res == NameExists = Just $ "another process owns " ++ xn | res == NameInQueue
| otherwise = Just $ "unknown error when requesting " ++ xn || res == NameExists =
Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn forM_ msg putStrLn
where where
xn = "'" ++ formatBusName xmonadBusName ++ "'" xn = "'" ++ formatBusName xmonadBusName ++ "'"

View File

@ -1,24 +1,21 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 -- Currently, its only purpose is to play Super Mario sounds when a drive is
-- inserted or removed. Why? Because I can. -- inserted or removed. Why? Because I can.
module XMonad.Internal.DBus.Removable (runRemovableMon) where module XMonad.Internal.DBus.Removable (runRemovableMon) where
import Control.Monad import Control.Monad
import DBus
import Data.Internal.DBus import DBus.Client
import Data.Internal.Dependency import Data.Internal.DBus
import Data.Map.Strict (Map, member) import Data.Internal.Dependency
import Data.Map.Strict (Map, member)
import DBus import XMonad.Core (io)
import DBus.Client import XMonad.Internal.Command.Desktop
import XMonad.Core (io)
import XMonad.Internal.Command.Desktop
bus :: BusName bus :: BusName
bus = busName_ "org.freedesktop.UDisks2" bus = busName_ "org.freedesktop.UDisks2"
@ -51,22 +48,29 @@ driveRemovedSound :: FilePath
driveRemovedSound = "smb_pipe.wav" driveRemovedSound = "smb_pipe.wav"
ruleUdisks :: MatchRule ruleUdisks :: MatchRule
ruleUdisks = matchAny ruleUdisks =
{ matchPath = Just path matchAny
, matchInterface = Just interface { matchPath = Just path
} , matchInterface = Just interface
}
driveFlag :: String driveFlag :: String
driveFlag = "org.freedesktop.UDisks2.Drive" driveFlag = "org.freedesktop.UDisks2.Drive"
addedHasDrive :: [Variant] -> Bool addedHasDrive :: [Variant] -> Bool
addedHasDrive [_, a] = maybe False (member driveFlag) addedHasDrive [_, a] =
(fromVariant a :: Maybe (Map String (Map String Variant))) maybe
False
(member driveFlag)
(fromVariant a :: Maybe (Map String (Map String Variant)))
addedHasDrive _ = False addedHasDrive _ = False
removedHasDrive :: [Variant] -> Bool removedHasDrive :: [Variant] -> Bool
removedHasDrive [_, a] = maybe False (driveFlag `elem`) removedHasDrive [_, a] =
(fromVariant a :: Maybe [String]) maybe
False
(driveFlag `elem`)
(fromVariant a :: Maybe [String])
removedHasDrive _ = False removedHasDrive _ = False
playSoundMaybe :: FilePath -> Bool -> IO () playSoundMaybe :: FilePath -> Bool -> IO ()
@ -81,8 +85,10 @@ listenDevices cl = do
addMatch' memAdded driveInsertedSound addedHasDrive addMatch' memAdded driveInsertedSound addedHasDrive
addMatch' memRemoved driveRemovedSound removedHasDrive addMatch' memRemoved driveRemovedSound removedHasDrive
where where
addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m } addMatch' m p f =
$ playSoundMaybe p . f . signalBody void $
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
playSoundMaybe p . f . signalBody
runRemovableMon :: Maybe SysClient -> SometimesIO runRemovableMon :: Maybe SysClient -> SometimesIO
runRemovableMon cl = runRemovableMon cl =

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus module for X11 screensave/DPMS control -- DBus module for X11 screensave/DPMS control
module XMonad.Internal.DBus.Screensaver module XMonad.Internal.DBus.Screensaver
( exportScreensaver ( exportScreensaver
@ -9,25 +9,22 @@ module XMonad.Internal.DBus.Screensaver
, callQuery , callQuery
, matchSignal , matchSignal
, ssSignalDep , ssSignalDep
) where )
where
import Data.Internal.DBus import DBus
import Data.Internal.Dependency import DBus.Client
import qualified DBus.Introspection as I
import RIO import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import Graphics.X11.XScreenSaver
import DBus.Client import Graphics.X11.Xlib.Display
import qualified DBus.Introspection as I import RIO
import XMonad.Internal.DBus.Common
import Graphics.X11.XScreenSaver import XMonad.Internal.Shell
import Graphics.X11.Xlib.Display
import XMonad.Internal.DBus.Common
import XMonad.Internal.Shell
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Low-level functions -- Low-level functions
type SSState = Bool -- true is enabled type SSState = Bool -- true is enabled
@ -50,13 +47,13 @@ query = do
xssi <- xScreenSaverQueryInfo dpy xssi <- xScreenSaverQueryInfo dpy
closeDisplay dpy closeDisplay dpy
return $ case xssi of return $ case xssi of
Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False
Just XScreenSaverInfo { xssi_state = _ } -> True Just XScreenSaverInfo {xssi_state = _} -> True
-- TODO handle errors better (at least log them?) -- 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 -- 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 -- with the new state when called. Define another method to get the current
@ -81,51 +78,64 @@ sigCurrentState :: Signal
sigCurrentState = signal ssPath interface memState sigCurrentState = signal ssPath interface memState
ruleCurrentState :: MatchRule ruleCurrentState :: MatchRule
ruleCurrentState = matchAny ruleCurrentState =
{ matchPath = Just ssPath matchAny
, matchInterface = Just interface { matchPath = Just ssPath
, matchMember = Just memState , matchInterface = Just interface
} , matchMember = Just memState
}
emitState :: Client -> SSState -> IO () 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 :: [Variant] -> Maybe SSState
bodyGetCurrentState [b] = fromVariant b :: Maybe SSState bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
bodyGetCurrentState _ = Nothing bodyGetCurrentState _ = Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- Exported haskell API
exportScreensaver :: Maybe SesClient -> SometimesIO exportScreensaver :: Maybe SesClient -> SometimesIO
exportScreensaver ses = exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
where where
cmd cl = let cl' = toClient cl in cmd cl =
liftIO $ export cl' ssPath defaultInterface let cl' = toClient cl
{ interfaceName = interface in liftIO $
, interfaceMethods = export
[ autoMethod memToggle $ emitState cl' =<< toggle cl'
, autoMethod memQuery query ssPath
] defaultInterface
, interfaceSignals = [sig] { interfaceName = interface
} , interfaceMethods =
sig = I.Signal [ autoMethod memToggle $ emitState cl' =<< toggle
{ I.signalName = memState , autoMethod memQuery query
, I.signalArgs = ]
[ , interfaceSignals = [sig]
I.SignalArg }
{ I.signalArgName = "enabled" sig =
, I.signalArgType = TypeBoolean I.Signal
} { I.signalName = memState
] , I.signalArgs =
} [ I.SignalArg
{ I.signalArgName = "enabled"
, I.signalArgType = TypeBoolean
}
]
}
bus = Bus [] xmonadBusName bus = Bus [] xmonadBusName
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
callToggle :: Maybe SesClient -> SometimesX callToggle :: Maybe SesClient -> SometimesX
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" [] callToggle =
xmonadBusName ssPath interface memToggle sometimesEndpoint
"screensaver toggle"
"dbus switch"
[]
xmonadBusName
ssPath
interface
memToggle
callQuery :: SesClient -> IO (Maybe SSState) callQuery :: SesClient -> IO (Maybe SSState)
callQuery ses = do callQuery ses = do
@ -133,8 +143,12 @@ callQuery ses = do
return $ either (const Nothing) bodyGetCurrentState reply return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO () matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
matchSignal cb ses = void $ addMatchCallback ruleCurrentState matchSignal cb ses =
(cb . bodyGetCurrentState) ses void $
addMatchCallback
ruleCurrentState
(cb . bodyGetCurrentState)
ses
ssSignalDep :: DBusDependency_ SesClient ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

View File

@ -1,7 +1,7 @@
{-# LANGUAGE ViewPatterns #-} {-# 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 -- Most (probably all) of these functions are intended to work with sysfs where
-- some safe assumptions can be made about file contents. -- some safe assumptions can be made about file contents.
@ -19,32 +19,31 @@ module XMonad.Internal.IO
, incPercent , incPercent
-- , isReadable -- , isReadable
-- , isWritable -- , isWritable
, PermResult(..) , PermResult (..)
, getPermissionsSafe , getPermissionsSafe
, waitUntilExit , waitUntilExit
) where )
where
import Data.Char import Data.Char
import Data.Text (pack, unpack) import Data.Text (pack, unpack)
import Data.Text.IO as T (readFile, writeFile) import Data.Text.IO as T (readFile, writeFile)
import RIO
import RIO import RIO.Directory
import RIO.Directory import RIO.FilePath
import RIO.FilePath import System.IO.Error
import System.IO.Error
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | read -- read
readInt :: (Read a, Integral a) => FilePath -> IO a readInt :: (Read a, Integral a) => FilePath -> IO a
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
readBool :: FilePath -> IO Bool 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 :: (Show a, Integral a) => FilePath -> a -> IO ()
writeInt f = T.writeFile f . pack . show 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) 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 -- "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 -- 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 -- given by a runtime argument, which is scaled linearly to the range 0-100
-- (percent). -- (percent).
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
rawToPercent (lower, upper) raw = rawToPercent (lower, upper) raw =
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower) 100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper -- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
@ -71,12 +70,14 @@ readPercent bounds path = do
return $ rawToPercent bounds (i :: Integer) return $ rawToPercent bounds (i :: Integer)
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
percentToRaw (lower, upper) perc = round $ percentToRaw (lower, upper) perc =
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower) round $
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
writePercent bounds path perc = do writePercent bounds path perc = do
let t | perc > 100 = 100 let t
| perc > 100 = 100
| perc < 0 = 0 | perc < 0 = 0
| otherwise = perc | otherwise = perc
writeInt path (percentToRaw bounds t :: Int) 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 :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
writePercentMax bounds path = writePercent bounds path 100 writePercentMax bounds path = writePercent bounds path 100
shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath shiftPercent
-> (a, a) -> IO b :: (Integral a, RealFrac b)
shiftPercent f steps path bounds = writePercent bounds path . f stepsize => (b -> b -> b)
-> Int
-> FilePath
-> (a, a)
-> IO b
shiftPercent f steps path bounds =
writePercent bounds path . f stepsize
=<< readPercent bounds path =<< readPercent bounds path
where where
stepsize = 100 / fromIntegral steps 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 decPercent = shiftPercent subtract -- silly (-) operator thingy error
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | permission query -- permission query
data PermResult a = PermResult a | NotFoundError | PermError data PermResult a = PermResult a | NotFoundError | PermError
deriving (Show, Eq) deriving (Show, Eq)
@ -116,12 +123,12 @@ getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
getPermissionsSafe f = do getPermissionsSafe f = do
r <- tryIOError $ getPermissions f r <- tryIOError $ getPermissions f
return $ case r of return $ case r of
Right z -> PermResult z Right z -> PermResult z
Left (isPermissionError -> True) -> PermError Left (isPermissionError -> True) -> PermError
Left (isDoesNotExistError -> True) -> NotFoundError Left (isDoesNotExistError -> True) -> NotFoundError
-- the above error should be the only ones thrown by getPermission, -- the above error should be the only ones thrown by getPermission,
-- so the catchall case should never happen -- so the catchall case should never happen
_ -> error "Unknown permission error" _ -> error "Unknown permission error"
-- isReadable :: FilePath -> IO (PermResult Bool) -- isReadable :: FilePath -> IO (PermResult Bool)
-- isReadable = fmap (fmap readable) . getPermissionsSafe -- isReadable = fmap (fmap readable) . getPermissionsSafe

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 -- 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 -- 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. -- decide to switch to using the DBus it will be easy.
module XMonad.Internal.Notify module XMonad.Internal.Notify
( Note(..) ( Note (..)
, Body(..) , Body (..)
, defNote , defNote
, defNoteInfo , defNoteInfo
, defNoteError , defNoteError
, fmtNotifyCmd , fmtNotifyCmd
, spawnNotify , spawnNotify
) where )
where
import DBus.Notify import DBus.Notify
import RIO
import RIO import qualified RIO.Text as T
import qualified RIO.Text as T import XMonad.Internal.Shell
import XMonad.Internal.Shell
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Some nice default notes -- Some nice default notes
defNote :: Note defNote :: Note
defNote = blankNote { summary = "\"xmonad\"" } defNote = blankNote {summary = "\"xmonad\""}
defNoteInfo :: Note defNoteInfo :: Note
defNoteInfo = defNote defNoteInfo =
{ appImage = Just $ Icon "dialog-information-symbolic" } defNote
{ appImage = Just $ Icon "dialog-information-symbolic"
}
defNoteError :: Note defNoteError :: Note
defNoteError = defNote defNoteError =
{ appImage = Just $ Icon "dialog-error-symbolic" } 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 :: Body -> Maybe T.Text
parseBody (Text s) = Just $ T.pack s parseBody (Text s) = Just $ T.pack s
parseBody _ = Nothing parseBody _ = Nothing
fmtNotifyCmd :: Note -> T.Text fmtNotifyCmd :: Note -> T.Text
fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
@ -56,8 +59,8 @@ fmtNotifyArgs :: Note -> [T.Text]
fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
where where
-- TODO add the rest of the options as needed -- TODO add the rest of the options as needed
getSummary = (:[]) . doubleQuote . T.pack . summary getSummary = (: []) . doubleQuote . T.pack . summary
getIcon n' = getIcon n' =
maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }]) maybe [] (\i -> ["-i", T.pack $ case i of Icon s -> s; File s -> s]) $
$ appImage n' appImage n'
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n' getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'

View File

@ -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)

View File

@ -1,58 +1,7 @@
-- | Functions for formatting and spawning shell commands
--
-- TLDR: spawning a "command" in xmonad is complicated for weird reasons, and
-- this solution is the most sane (for me) given the constraints of the xmonad
-- codebase.
--
-- A few facts about xmonad (and window managers in general):
-- 1) It is single-threaded (since X is single threaded)
-- 2) Because of (1), it ignores SIGCHLD, which means any subprocess started
-- by xmonad will instantly be reaped after spawning. This guarantees the
-- main thread running the WM will never be blocked.
--
-- In general, this means that 'System.Process.waitForProcess' (and similar)
-- will not work since these call wait() on the child process, which will fail
-- because the child has already been cleared and thus there is nothing on which
-- to wait. By extension this also means we don't have access to a child's exit
-- code.
--
-- XMonad and contrib use their own method of spawning subprocesses using the
-- extremely low-level 'System.Process.Posix' API. See the code for
-- 'XMonad.Core.spawn' or 'XMonad.Util.Run.safeSpawn'. Specifically, the
-- sequence is (in terms of the low level Linux API):
-- 1) call fork()
-- 2) uninstall signal handlers
-- 3) call setsid()
-- 4) start new thing with exec()
--
-- In practice, I'm guessing the main reason for 2 and 3 is so that child
-- processes don't inherit the weird SIGCHLD behavior of xmonad itself. The
-- setsid thing is one way to guarantee that killing the child thread will also
-- kill its children (if any). Note that this obviously will not block since
-- we are calling fork() without wait() (which would throw an error anyways).
--
-- What if I actually want the exit code?
--
-- The best solution (I can come up with), is to use bracket to uninstall
-- handlers, run process (with wait), and then reinstall handlers. I can use
-- this with a much higher-level interface which will make things easier. This
-- obviously means that if the process is running in the main thread, it needs
-- to be almost instantaneous (since it actually will be blocking). NOTE: I
-- shouldn't use this to replace the existing functions in xmonad since
-- 'spawning' a new process in a non-blocking manner with a higher-level API
-- will produce lots of Haskell objects that need to be cleaned, and it will be
-- hard (perhaps impossible) to keep track and deal with these after spawning.
--
-- This works, albeit with the cost of using almost every process API in Haskell.
--
-- Briefly:
-- 1) 'System.Process.Posix' (where xmonad lives)
-- 2) 'System.Process' (wraps 1)
-- 2) 'System.Process.Typed' (wraps 2, which I prefer for getting exit codes)
-- 3) 'RIO.Process' (wraps 3, which I prefer at the app level)
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- Functions for formatting and spawning shell commands
module XMonad.Internal.Shell module XMonad.Internal.Shell
( fmtCmd ( fmtCmd
, spawnCmd , spawnCmd
@ -68,80 +17,117 @@ module XMonad.Internal.Shell
, (#!||) , (#!||)
, (#!|) , (#!|)
, (#!>>) , (#!>>)
) where )
where
import RIO
import qualified RIO.Text as T
import RIO
import qualified RIO.Text as T
import qualified System.Process.Typed as P 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 -- | Fork a new process and wait for its exit code.
import qualified XMonad.Util.Run as XR --
-- This function will work despite xmonad ignoring SIGCHLD.
-------------------------------------------------------------------------------- --
-- | Opening subshell -- A few facts about xmonad (and window managers in general):
-- https://github.com/xmonad/xmonad/issues/113 -- 1) It is single-threaded (since X is single threaded)
-- 2) Because of (1), it ignores SIGCHLD, which means any subprocess started
-- by xmonad will instantly be reaped after spawning. This guarantees the
-- main thread running the WM will never be blocked.
--
-- In general, this means I can't wait for exit codes (since wait() doesn't
-- work) See https://github.com/xmonad/xmonad/issues/113.
--
-- If I want an exit code, The best solution (I can come up with), is to use
-- bracket to uninstall handlers, run process (with wait), and then reinstall
-- handlers. I can use this with a much higher-level interface which will make
-- things easier. This obviously means that if the process is running in the
-- main thread, it needs to be almost instantaneous. Note if using a high-level
-- API for this, the process needs to spawn, finish, and be reaped by the
-- xmonad process all while the signal handlers are 'disabled' (which limits
-- the functions I can use to those that call waitForProcess).
--
-- XMonad and contrib use their own method of spawning subprocesses using the
-- extremely low-level 'System.Process.Posix' API. See the code for
-- 'XMonad.Core.spawn' or 'XMonad.Util.Run.safeSpawn'. Specifically, the
-- sequence is (in terms of the low level Linux API):
-- 1) call fork()
-- 2) uninstall signal handlers (to allow wait() to work in subprocesses)
-- 3) call setsid() (so killing the child will kill its children, if any)
-- 4) start new thing with exec()
--
-- In contrast with high-level APIs like 'System.Process', this will leave no
-- trailing data structures to clean up, at the cost of being gross to look at
-- and possibly more error-prone.
runProcess :: P.ProcessConfig a b c -> IO ExitCode
runProcess = withDefaultSignalHandlers . P.runProcess
-- | Run an action without xmonad's signal handlers.
withDefaultSignalHandlers :: IO a -> IO a withDefaultSignalHandlers :: IO a -> IO a
withDefaultSignalHandlers = withDefaultSignalHandlers =
bracket_ X.uninstallSignalHandlers X.installSignalHandlers bracket_ X.uninstallSignalHandlers X.installSignalHandlers
-- | Set a child process to create a new group and session
addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z
addGroupSession = P.setCreateGroup True . P.setNewSession True addGroupSession = P.setCreateGroup True . P.setNewSession True
runProcess :: P.ProcessConfig a b c -> IO ExitCode -- | Create a 'ProcessConfig' for a shell command
runProcess = withDefaultSignalHandlers . P.runProcess
shell :: T.Text -> P.ProcessConfig () () () shell :: T.Text -> P.ProcessConfig () () ()
shell = addGroupSession . P.shell . T.unpack shell = addGroupSession . P.shell . T.unpack
-- | Create a 'ProcessConfig' for a command with arguments
proc :: FilePath -> [T.Text] -> P.ProcessConfig () () () proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args) proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
-- | Run 'XMonad.Core.spawn' with 'Text' input.
spawn :: MonadIO m => T.Text -> m () spawn :: MonadIO m => T.Text -> m ()
spawn = X.spawn . T.unpack spawn = X.spawn . T.unpack
-- spawnAt :: MonadIO m => FilePath -> T.Text -> m () -- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
-- spawnAt fp = liftIO . void . startProcess . P.setWorkingDir fp . shell
spawnPipe :: MonadIO m => T.Text -> m Handle spawnPipe :: MonadIO m => T.Text -> m Handle
spawnPipe = XR.spawnPipe . T.unpack spawnPipe = XR.spawnPipe . T.unpack
-- | Run 'XMonad.Core.spawn' with a command and arguments
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m () spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd = spawn . fmtCmd cmd spawnCmd cmd = spawn . fmtCmd cmd
-------------------------------------------------------------------------------- -- | Format a command and list of arguments as 'Text'
-- | Formatting commands
fmtCmd :: FilePath -> [T.Text] -> T.Text fmtCmd :: FilePath -> [T.Text] -> T.Text
fmtCmd cmd args = T.unwords $ T.pack cmd : args fmtCmd cmd args = T.unwords $ T.pack cmd : args
op :: T.Text -> T.Text -> T.Text -> T.Text op :: T.Text -> T.Text -> T.Text -> T.Text
op a x b = T.unwords [a, x, b] op a x b = T.unwords [a, x, b]
-- | Format two shell expressions separated by "&&"
(#!&&) :: T.Text -> T.Text -> T.Text (#!&&) :: T.Text -> T.Text -> T.Text
cmdA #!&& cmdB = op cmdA "&&" cmdB cmdA #!&& cmdB = op cmdA "&&" cmdB
infixr 0 #!&& infixr 0 #!&&
-- | Format two shell expressions separated by "|"
(#!|) :: T.Text -> T.Text -> T.Text (#!|) :: T.Text -> T.Text -> T.Text
cmdA #!| cmdB = op cmdA "|" cmdB cmdA #!| cmdB = op cmdA "|" cmdB
infixr 0 #!| infixr 0 #!|
-- | Format two shell expressions separated by "||"
(#!||) :: T.Text -> T.Text -> T.Text (#!||) :: T.Text -> T.Text -> T.Text
cmdA #!|| cmdB = op cmdA "||" cmdB cmdA #!|| cmdB = op cmdA "||" cmdB
infixr 0 #!|| infixr 0 #!||
-- | Format two shell expressions separated by ";"
(#!>>) :: T.Text -> T.Text -> T.Text (#!>>) :: T.Text -> T.Text -> T.Text
cmdA #!>> cmdB = op cmdA ";" cmdB cmdA #!>> cmdB = op cmdA ";" cmdB
infixr 0 #!>> infixr 0 #!>>
-- | Wrap input in double quotes
doubleQuote :: T.Text -> T.Text doubleQuote :: T.Text -> T.Text
doubleQuote s = T.concat ["\"", s, "\""] doubleQuote s = T.concat ["\"", s, "\""]
-- | Wrap input in single quotes
singleQuote :: T.Text -> T.Text singleQuote :: T.Text -> T.Text
singleQuote s = T.concat ["'", s, "'"] singleQuote s = T.concat ["'", s, "'"]

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Theme for XMonad and Xmobar -- Theme for XMonad and Xmobar
module XMonad.Internal.Theme module XMonad.Internal.Theme
( baseColor ( baseColor
@ -18,9 +18,9 @@ module XMonad.Internal.Theme
, backdropTextColor , backdropTextColor
, blend' , blend'
, darken' , darken'
, Slant(..) , Slant (..)
, Weight(..) , Weight (..)
, FontData(..) , FontData (..)
, FontBuilder , FontBuilder
, buildFont , buildFont
, fallbackFont , fallbackFont
@ -28,18 +28,17 @@ module XMonad.Internal.Theme
, defFontData , defFontData
, tabbedTheme , tabbedTheme
, promptTheme , promptTheme
) where )
where
import Data.Colour
import Data.Colour.SRGB
import qualified RIO.Text as T
import Data.Colour
import Data.Colour.SRGB
import qualified RIO.Text as T
import qualified XMonad.Layout.Decoration as D import qualified XMonad.Layout.Decoration as D
import qualified XMonad.Prompt as P import qualified XMonad.Prompt as P
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Colors - vocabulary roughly based on GTK themes -- Colors - vocabulary roughly based on GTK themes
baseColor :: T.Text baseColor :: T.Text
baseColor = "#f7f7f7" baseColor = "#f7f7f7"
@ -78,7 +77,7 @@ backdropFgColor :: T.Text
backdropFgColor = blend' 0.75 fgColor bgColor backdropFgColor = blend' 0.75 fgColor bgColor
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Color functions -- Color functions
blend' :: Float -> T.Text -> T.Text -> T.Text blend' :: Float -> T.Text -> T.Text -> T.Text
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1) 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 sRGB24showT = T.pack . sRGB24show
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Fonts -- Fonts
data Slant = Roman data Slant
| Italic = Roman
| Oblique | Italic
deriving (Eq, Show) | Oblique
deriving (Eq, Show)
data Weight = Light data Weight
| Medium = Light
| Demibold | Medium
| Bold | Demibold
| Black | Bold
deriving (Eq, Show) | Black
deriving (Eq, Show)
data FontData = FontData data FontData = FontData
{ weight :: Maybe Weight { weight :: Maybe Weight
, slant :: Maybe Slant , slant :: Maybe Slant
, size :: Maybe Int , size :: Maybe Int
, pixelsize :: Maybe Int , pixelsize :: Maybe Int
, antialias :: Maybe Bool , antialias :: Maybe Bool
} }
type FontBuilder = FontData -> T.Text type FontBuilder = FontData -> T.Text
buildFont :: Maybe T.Text -> FontData -> T.Text buildFont :: Maybe T.Text -> FontData -> T.Text
buildFont Nothing _ = "fixed" buildFont Nothing _ = "fixed"
buildFont (Just fam) FontData { weight = w buildFont
, slant = l (Just fam)
, size = s FontData
, pixelsize = p { weight = w
, antialias = a , slant = l
} , size = s
= T.intercalate ":" $ ["xft", fam] ++ elems , pixelsize = p
where , antialias = a
elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w) } =
, ("slant", showLower l) T.intercalate ":" $ ["xft", fam] ++ elems
, ("size", showLower s) where
, ("pixelsize", showLower p) elems =
, ("antialias", showLower a) [ T.concat [k, "=", v]
] | (k, Just v) <-
] [ ("weight", showLower w)
showLower :: Show a => Maybe a -> Maybe T.Text , ("slant", showLower l)
showLower = fmap (T.toLower . T.pack . show) , ("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 :: FontBuilder
fallbackFont = buildFont Nothing fallbackFont = buildFont Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Default font and data -- Default font and data
defFontData :: FontData defFontData :: FontData
defFontData = FontData defFontData =
{ size = Just 10 FontData
, antialias = Just True { size = Just 10
, weight = Nothing , antialias = Just True
, slant = Nothing , weight = Nothing
, pixelsize = Nothing , slant = Nothing
} , pixelsize = Nothing
}
defFontFamily :: T.Text defFontFamily :: T.Text
defFontFamily = "DejaVu Sans" defFontFamily = "DejaVu Sans"
@ -162,44 +170,42 @@ defFontFamily = "DejaVu Sans"
-- defFontTree = fontTree "DejaVu Sans" -- defFontTree = fontTree "DejaVu Sans"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Complete themes -- Complete themes
tabbedTheme :: FontBuilder -> D.Theme tabbedTheme :: FontBuilder -> D.Theme
tabbedTheme fb = D.def tabbedTheme fb =
{ D.fontName = T.unpack $ fb $ defFontData { weight = Just Bold } 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.decoHeight = 20
, D.activeColor = T.unpack bgColor , D.windowTitleAddons = []
, D.activeBorderColor = T.unpack bgColor , D.windowTitleIcons = []
}
, 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 = []
}
promptTheme :: FontBuilder -> P.XPConfig promptTheme :: FontBuilder -> P.XPConfig
promptTheme fb = P.def promptTheme fb =
{ P.font = T.unpack $ fb $ defFontData { size = Just 12 } P.def
, P.bgColor = T.unpack bgColor { P.font = T.unpack $ fb $ defFontData {size = Just 12}
, P.fgColor = T.unpack fgColor , P.bgColor = T.unpack bgColor
, P.fgHLight = T.unpack selectedFgColor , P.fgColor = T.unpack fgColor
, P.bgHLight = T.unpack selectedBgColor , P.fgHLight = T.unpack selectedFgColor
, P.borderColor = T.unpack bordersColor , P.bgHLight = T.unpack selectedBgColor
, P.promptBorderWidth = 1 , P.borderColor = T.unpack bordersColor
, P.height = 35 , P.promptBorderWidth = 1
, P.position = P.CenteredAt 0.5 0.5 , P.height = 35
, P.historySize = 0 , P.position = P.CenteredAt 0.5 0.5
} , P.historySize = 0
}

View File

@ -1,25 +1,26 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- -- Common backlight plugin bits
-- | Common backlight plugin bits
-- --
-- Use the custom DBus interface exported by the XMonad process so I can react -- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands -- to signals spawned by commands
module Xmobar.Plugins.BacklightCommon (startBacklight) where 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 startBacklight
:: RealFrac a
import Xmobar.Plugins.Common => ((Maybe a -> IO ()) -> SesClient -> IO ())
-> (SesClient -> IO (Maybe a))
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ()) -> T.Text
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO () -> Callback
-> IO ()
startBacklight matchSignal callGetBrightness icon cb = do startBacklight matchSignal callGetBrightness icon cb = do
withDBusClientConnection cb $ \c -> do withDBusClientConnection cb $ \c -> do
matchSignal display c matchSignal display c
display =<< callGetBrightness c display =<< callGetBrightness c
where where
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"] formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
display = displayMaybe cb formatBrightness display = displayMaybe cb formatBrightness

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Bluetooth plugin -- Bluetooth plugin
-- --
-- Use the bluez interface on DBus to check status -- Use the bluez interface on DBus to check status
-- --
@ -33,36 +33,34 @@
-- adapter changing. -- adapter changing.
module Xmobar.Plugins.Bluetooth module Xmobar.Plugins.Bluetooth
( Bluetooth(..) ( Bluetooth (..)
, btAlias , btAlias
, btDep , btDep
) where )
where
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Monad import Control.Monad
import DBus
import Data.Internal.DBus import DBus.Client
import Data.Internal.Dependency import Data.Internal.DBus
import Data.List import Data.Internal.Dependency
import Data.List.Split import Data.List
import qualified Data.Map as M import Data.List.Split
import Data.Maybe import qualified Data.Map as M
import Data.Maybe
import DBus import qualified RIO.Text as T
import DBus.Client import XMonad.Internal.DBus.Common
import Xmobar
import qualified RIO.Text as T import Xmobar.Plugins.Common
import XMonad.Internal.DBus.Common
import Xmobar
import Xmobar.Plugins.Common
btAlias :: T.Text btAlias :: T.Text
btAlias = "bluetooth" btAlias = "bluetooth"
btDep :: DBusDependency_ SysClient btDep :: DBusDependency_ SysClient
btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface btDep =
$ Method_ getManagedObjects Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
Method_ getManagedObjects
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
@ -90,7 +88,7 @@ startAdapter is cs cb cl = do
display display
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Icon Display -- Icon Display
-- --
-- Color corresponds to the adaptor powered state, and the icon corresponds to -- Color corresponds to the adaptor powered state, and the icon corresponds to
-- if it is paired or not. If the adaptor state is undefined, display "N/A" -- if it is paired or not. If the adaptor state is undefined, display "N/A"
@ -111,7 +109,7 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
icon = if connected then iconConn else iconDisc 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 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 -- 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. -- an MVar.
data BTDevice = BTDevice data BTDevice = BTDevice
{ btDevConnected :: Maybe Bool { btDevConnected :: Maybe Bool
, btDevSigHandler :: SignalHandler , btDevSigHandler :: SignalHandler
} }
@ -133,10 +131,11 @@ data BtState = BtState
type MutableBtState = MVar BtState type MutableBtState = MVar BtState
emptyState :: BtState emptyState :: BtState
emptyState = BtState emptyState =
{ btDevices = M.empty BtState
, btPowered = Nothing { btDevices = M.empty
} , btPowered = Nothing
}
readState :: MutableBtState -> IO (Maybe Bool, Bool) readState :: MutableBtState -> IO (Maybe Bool, Bool)
readState state = do readState state = do
@ -145,7 +144,7 @@ readState state = do
return (p, anyDevicesConnected c) return (p, anyDevicesConnected c)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Object manager -- Object manager
findAdapter :: ObjectTree -> Maybe ObjectPath findAdapter :: ObjectTree -> Maybe ObjectPath
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys 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 :: ObjectPath -> ObjectPath -> Bool
adaptorHasDevice adaptor device = case splitPath device of adaptorHasDevice adaptor device = case splitPath device of
[org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX] [org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
_ -> False _ -> False
splitPath :: ObjectPath -> [T.Text] splitPath :: ObjectPath -> [T.Text]
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
getBtObjectTree :: SysClient -> IO ObjectTree getBtObjectTree :: SysClient -> IO ObjectTree
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
@ -191,7 +190,7 @@ pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
pathCallback _ _ _ _ = return () pathCallback _ _ _ _ = return ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Adapter -- Adapter
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO () initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
initAdapter state adapter client = do initAdapter state adapter client = do
@ -201,7 +200,11 @@ initAdapter state adapter client = do
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule) matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
matchBTProperty sys p = matchPropertyFull sys btBus (Just p) matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient addAdaptorListener
:: MutableBtState
-> IO ()
-> ObjectPath
-> SysClient
-> IO (Maybe SignalHandler) -> IO (Maybe SignalHandler)
addAdaptorListener state display adaptor sys = do addAdaptorListener state display adaptor sys = do
rule <- matchBTProperty sys adaptor rule <- matchBTProperty sys adaptor
@ -210,14 +213,16 @@ addAdaptorListener state display adaptor sys = do
procMatch = withSignalMatch $ \b -> putPowered state b >> display procMatch = withSignalMatch $ \b -> putPowered state b >> display
callGetPowered :: ObjectPath -> SysClient -> IO [Variant] callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface callGetPowered adapter =
$ memberName_ $ T.unpack adaptorPowered callPropertyGet btBus adapter adapterInterface $
memberName_ $
T.unpack adaptorPowered
matchPowered :: [Variant] -> SignalMatch Bool matchPowered :: [Variant] -> SignalMatch Bool
matchPowered = matchPropertyChanged adapterInterface adaptorPowered matchPowered = matchPropertyChanged adapterInterface adaptorPowered
putPowered :: MutableBtState -> Maybe Bool -> IO () 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 :: MutableBtState -> IO (Maybe Bool)
readPowered = fmap btPowered . readMVar readPowered = fmap btPowered . readMVar
@ -229,7 +234,7 @@ adaptorPowered :: T.Text
adaptorPowered = "Powered" adaptorPowered = "Powered"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Devices -- Devices
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO () addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
addAndInitDevice state display device client = do addAndInitDevice state display device client = do
@ -240,12 +245,18 @@ addAndInitDevice state display device client = do
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO () initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
initDevice state sh device sys = do initDevice state sh device sys = do
reply <- callGetConnected device sys reply <- callGetConnected device sys
void $ insertDevice state device $ void $
BTDevice { btDevConnected = fromVariant =<< listToMaybe reply insertDevice state device $
, btDevSigHandler = sh BTDevice
} { btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh
}
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient addDeviceListener
:: MutableBtState
-> IO ()
-> ObjectPath
-> SysClient
-> IO (Maybe SignalHandler) -> IO (Maybe SignalHandler)
addDeviceListener state display device sys = do addDeviceListener state display device sys = do
rule <- matchBTProperty sys device rule <- matchBTProperty sys device
@ -257,18 +268,19 @@ matchConnected :: [Variant] -> SignalMatch Bool
matchConnected = matchPropertyChanged devInterface devConnected matchConnected = matchPropertyChanged devInterface devConnected
callGetConnected :: ObjectPath -> SysClient -> IO [Variant] callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
callGetConnected p = callPropertyGet btBus p devInterface callGetConnected p =
$ memberName_ (T.unpack devConnected) callPropertyGet btBus p devInterface $
memberName_ (T.unpack devConnected)
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
insertDevice m device dev = modifyMVar m $ \s -> do insertDevice m device dev = modifyMVar m $ \s -> do
let new = M.insert device dev $ btDevices s 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 :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
updateDevice m device status = modifyMVar m $ \s -> do updateDevice m device status = modifyMVar m $ \s -> do
let new = M.update (\d -> Just d { btDevConnected = status }) device $ btDevices s let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
return (s { btDevices = new }, anyDevicesConnected new) return (s {btDevices = new}, anyDevicesConnected new)
anyDevicesConnected :: ConnectedDevices -> Bool anyDevicesConnected :: ConnectedDevices -> Bool
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
@ -276,7 +288,7 @@ anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice) removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
removeDevice m device = modifyMVar m $ \s -> do removeDevice m device = modifyMVar m $ \s -> do
let devs = btDevices s 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 :: MutableBtState -> IO ConnectedDevices
readDevices = fmap btDevices . readMVar readDevices = fmap btDevices . readMVar

View File

@ -1,23 +1,21 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Clevo Keyboard plugin -- Clevo Keyboard plugin
-- --
-- Use the custom DBus interface exported by the XMonad process so I can react -- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands -- to signals spawned by commands
module Xmobar.Plugins.ClevoKeyboard module Xmobar.Plugins.ClevoKeyboard
( ClevoKeyboard(..) ( ClevoKeyboard (..)
, ckAlias , ckAlias
) where )
where
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Xmobar import Xmobar
import Xmobar.Plugins.BacklightCommon
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show) newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = T.unpack ckAlias alias (ClevoKeyboard _) = T.unpack ckAlias
start (ClevoKeyboard icon) = start (ClevoKeyboard icon) =
startBacklight matchSignalCK callGetBrightnessCK icon startBacklight matchSignalCK callGetBrightnessCK icon

View File

@ -8,36 +8,38 @@ module Xmobar.Plugins.Common
, fromSingletonVariant , fromSingletonVariant
, withDBusClientConnection , withDBusClientConnection
, Callback , Callback
, Colors(..) , Colors (..)
, displayMaybe , displayMaybe
, displayMaybe' , displayMaybe'
, xmobarFGColor , xmobarFGColor
) )
where where
import Control.Monad import Control.Monad
import DBus
import Data.Internal.DBus import DBus.Client
import Data.Internal.DBus
import DBus import qualified RIO.Text as T
import DBus.Client import XMonad.Hooks.DynamicLog (xmobarColor)
import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor)
-- use string here since all the callbacks in xmobar use strings :( -- use string here since all the callbacks in xmobar use strings :(
type Callback = String -> IO () type Callback = String -> IO ()
data Colors = Colors data Colors = Colors
{ colorsOn :: T.Text { colorsOn :: T.Text
, colorsOff :: T.Text , colorsOff :: T.Text
} }
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant]) startListener
-> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback :: (SafeClient c, IsVariant a)
-> c -> IO () => MatchRule
-> (c -> IO [Variant])
-> ([Variant] -> SignalMatch a)
-> (a -> IO T.Text)
-> Callback
-> c
-> IO ()
startListener rule getProp fromSignal toColor cb client = do startListener rule getProp fromSignal toColor cb client = do
reply <- getProp client reply <- getProp client
displayMaybe cb toColor $ fromSingletonVariant reply 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) procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
colorText :: Colors -> Bool -> T.Text -> T.Text colorText :: Colors -> Bool -> T.Text -> T.Text
colorText Colors { colorsOn = c } True = xmobarFGColor c colorText Colors {colorsOn = c} True = xmobarFGColor c
colorText Colors { colorsOff = c } False = xmobarFGColor c colorText Colors {colorsOff = c} False = xmobarFGColor c
xmobarFGColor :: T.Text -> T.Text -> T.Text xmobarFGColor :: T.Text -> T.Text -> T.Text
xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack

View File

@ -1,30 +1,27 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Device plugin -- Device plugin
-- --
-- Display different text depending on whether or not the interface has -- Display different text depending on whether or not the interface has
-- connectivity -- connectivity
module Xmobar.Plugins.Device module Xmobar.Plugins.Device
( Device(..) ( Device (..)
, devDep , devDep
) where )
where
import Control.Monad import Control.Monad
import DBus
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.Word import Data.Word
import qualified RIO.Text as T
import DBus import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import qualified RIO.Text as T import Xmobar
import Xmobar.Plugins.Common
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) newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
@ -44,19 +41,23 @@ devSignal :: T.Text
devSignal = "Ip4Connectivity" devSignal = "Ip4Connectivity"
devDep :: DBusDependency_ SysClient devDep :: DBusDependency_ SysClient
devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface devDep =
$ Method_ getByIP Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
Method_ getByIP
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath) getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
where where
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP) mc =
{ methodCallBody = [toVariant iface] (methodCallBus networkManagerBus nmPath nmInterface getByIP)
} { methodCallBody = [toVariant iface]
}
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant] getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface getDeviceConnected path =
$ memberName_ $ T.unpack devSignal callPropertyGet networkManagerBus path nmDeviceInterface $
memberName_ $
T.unpack devSignal
matchStatus :: [Variant] -> SignalMatch Word32 matchStatus :: [Variant] -> SignalMatch Word32
matchStatus = matchPropertyChanged nmDeviceInterface devSignal matchStatus = matchPropertyChanged nmDeviceInterface devSignal

View File

@ -1,23 +1,21 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Intel backlight plugin -- Intel backlight plugin
-- --
-- Use the custom DBus interface exported by the XMonad process so I can react -- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands -- to signals spawned by commands
module Xmobar.Plugins.IntelBacklight module Xmobar.Plugins.IntelBacklight
( IntelBacklight(..) ( IntelBacklight (..)
, blAlias , blAlias
) where )
where
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Brightness.IntelBacklight
import Xmobar import Xmobar
import Xmobar.Plugins.BacklightCommon
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.IntelBacklight
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show) newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
@ -27,4 +25,4 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where instance Exec IntelBacklight where
alias (IntelBacklight _) = T.unpack blAlias alias (IntelBacklight _) = T.unpack blAlias
start (IntelBacklight icon) = start (IntelBacklight icon) =
startBacklight matchSignalIB callGetBrightnessIB icon startBacklight matchSignalIB callGetBrightnessIB icon

View File

@ -1,22 +1,21 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Screensaver plugin -- Screensaver plugin
-- --
-- Use the custom DBus interface exported by the XMonad process so I can react -- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands -- to signals spawned by commands
module Xmobar.Plugins.Screensaver module Xmobar.Plugins.Screensaver
( Screensaver(..) ( Screensaver (..)
, ssAlias , ssAlias
) where )
where
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Screensaver
import Xmobar import Xmobar
import Xmobar.Plugins.Common
import XMonad.Internal.DBus.Screensaver
import Xmobar.Plugins.Common
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show) newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
@ -31,4 +30,3 @@ instance Exec Screensaver where
display =<< callQuery sys display =<< callQuery sys
where where
display = displayMaybe cb $ return . (\s -> colorText colors s text) display = displayMaybe cb $ return . (\s -> colorText colors s text)

View File

@ -1,35 +1,32 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | VPN plugin -- VPN plugin
-- --
-- Use the networkmanager to detect when a VPN interface is added or removed. -- Use the networkmanager to detect when a VPN interface is added or removed.
-- Specifically, monitor the object tree to detect paths with the interface -- Specifically, monitor the object tree to detect paths with the interface
-- "org.freedesktop.NetworkManager.Device.Tun". -- "org.freedesktop.NetworkManager.Device.Tun".
module Xmobar.Plugins.VPN module Xmobar.Plugins.VPN
( VPN(..) ( VPN (..)
, vpnAlias , vpnAlias
, vpnDep , vpnDep
) where )
where
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Monad import Control.Monad
import DBus
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import qualified Data.Set as S import qualified Data.Set as S
import qualified RIO.Text as T
import DBus import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common
import qualified RIO.Text as T import Xmobar
import Xmobar.Plugins.Common
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) newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
@ -37,17 +34,17 @@ instance Exec VPN where
alias (VPN _) = T.unpack vpnAlias alias (VPN _) = T.unpack vpnAlias
start (VPN (text, colors)) cb = start (VPN (text, colors)) cb =
withDBusClientConnection cb $ \c -> do withDBusClientConnection cb $ \c -> do
state <- initState c state <- initState c
let display = displayMaybe cb iconFormatter . Just =<< readState state let display = displayMaybe cb iconFormatter . Just =<< readState state
let signalCallback' f = f state display let signalCallback' f = f state display
vpnAddedListener (signalCallback' addedCallback) c vpnAddedListener (signalCallback' addedCallback) c
vpnRemovedListener (signalCallback' removedCallback) c vpnRemovedListener (signalCallback' removedCallback) c
display display
where where
iconFormatter b = return $ colorText colors b text 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 -- 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 -- 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 :: MutableVPNState -> IO Bool
readState = fmap (not . null) . readMVar readState = fmap (not . null) . readMVar
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState updateState
-> ObjectPath -> IO () :: (ObjectPath -> VPNState -> VPNState)
-> MutableVPNState
-> ObjectPath
-> IO ()
updateState f state op = modifyMVar_ state $ return . f op updateState f state op = modifyMVar_ state $ return . f op
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Tunnel Device Detection -- Tunnel Device Detection
--
getVPNObjectTree :: SysClient -> IO ObjectTree getVPNObjectTree :: SysClient -> IO ObjectTree
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath 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)) added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
is = M.keys $ fromMaybe M.empty added' is = M.keys $ fromMaybe M.empty added'
update = updateDevice S.insert state device is update = updateDevice S.insert state device is
addedCallback _ _ _ = return () addedCallback _ _ _ = return ()
removedCallback :: MutableVPNState -> IO () -> SignalCallback removedCallback :: MutableVPNState -> IO () -> SignalCallback
removedCallback state display [device, interfaces] = update >> display removedCallback state display [device, interfaces] = update >> display
where where
is = fromMaybe [] $ fromVariant interfaces :: [T.Text] is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
update = updateDevice S.delete state device is update = updateDevice S.delete state device is
removedCallback _ _ _ = return () removedCallback _ _ _ = return ()
updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState updateDevice
-> Variant -> [T.Text] -> IO () :: (ObjectPath -> VPNState -> VPNState)
updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $ -> MutableVPNState
forM_ d $ updateState f state -> Variant
-> [T.Text]
-> IO ()
updateDevice f state device interfaces =
when (vpnDeviceTun `elem` interfaces) $
forM_ d $
updateState f state
where where
d = fromVariant device :: Maybe ObjectPath d = fromVariant device :: Maybe ObjectPath
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus Interface -- DBus Interface
--
vpnBus :: BusName vpnBus :: BusName
vpnBus = busName_ "org.freedesktop.NetworkManager" vpnBus = busName_ "org.freedesktop.NetworkManager"
@ -124,5 +128,6 @@ vpnAlias :: T.Text
vpnAlias = "vpn" vpnAlias = "vpn"
vpnDep :: DBusDependency_ SysClient vpnDep :: DBusDependency_ SysClient
vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface vpnDep =
$ Method_ getManagedObjects Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
Method_ getManagedObjects

View File

@ -7,7 +7,7 @@ copyright: "2022 Nathan Dwarshuis"
extra-source-files: extra-source-files:
- README.md - README.md
- .stylish-haskell.yaml - fourmolu.yaml
- make_pkgs - make_pkgs
- icons/* - icons/*
- scripts/* - scripts/*