ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: ndwarshuis:aa3979b36fa756f08a8e43fbe041dfb118eef361
Branches Tags
ndwarshuis:master
ndwarshuis:fix_dbus
ndwarshuis:fix_rio_run
ndwarshuis:fix_process
ndwarshuis:use_nix
..
compare: ndwarshuis:adf0257533a750b91e6e7076fa6228f030b4a777
Branches Tags
ndwarshuis:master
ndwarshuis:fix_dbus
ndwarshuis:fix_rio_run
ndwarshuis:fix_process
ndwarshuis:use_nix

5 Commits
aa3979b36f ... adf0257533

Author SHA1 Message Date
Nathan Dwarshuis adf0257533 REF reformat everything with fourmolu 2022-12-30 14:58:23 -05:00
Nathan Dwarshuis b2b0f72178 ENH use fourmolu 2022-12-30 12:21:53 -05:00
Nathan Dwarshuis d560db1548 Revert "WIP use unliftio everywhere-ish" 
This reverts commit 769df2fb00.
 2022-12-30 10:56:09 -05:00
Nathan Dwarshuis 769df2fb00 WIP use unliftio everywhere-ish 2022-12-30 10:38:21 -05:00
Nathan Dwarshuis 017d13d80c ENH clean up docs in shell 2022-12-29 15:22:48 -05:00
35 changed files with 2534 additions and 2456 deletions
Show Stats Expand all files Collapse all files

357
.stylish-haskell.yaml
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

46
bin/vbox-start.hs
View File

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

562
bin/xmobar.hs
View File

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

887
bin/xmonad.hs
View File

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

193
lib/Data/Internal/DBus.hs
View File

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

691
lib/Data/Internal/Dependency.hs
View File

File diff suppressed because it is too large Load Diff

170
lib/XMonad/Internal/Command/DMenu.hs
View File

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

216
lib/XMonad/Internal/Command/Desktop.hs
View File

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

148
lib/XMonad/Internal/Command/Power.hs
View File

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

71
lib/XMonad/Internal/Concurrent/ACPIEvent.hs
View File

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

46
lib/XMonad/Internal/Concurrent/ClientMessage.hs
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
-- listen/react to non-X events is to spawn other threads the run outside of
@ -16,50 +16,50 @@
-- much like something from X even though it isn't
module XMonad.Internal.Concurrent.ClientMessage
( XMsgType(..)
( XMsgType (..)
, sendXMsg
, splitXMsg
) where
)
where
import Data.Char
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Types
import RIO hiding (Display)
import Data.Char
import Graphics.X11.Types
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib.Types
import RIO hiding (Display)
--------------------------------------------------------------------------------
-- | Data structure for the ClientMessage
-- Data structure for the ClientMessage
--
-- These are the "types" of client messages to send; add more here as needed
-- TODO is there a way to do this in the libraries that import this one?
data XMsgType = ACPI
| Workspace
| Unknown
deriving (Eq, Show)
data XMsgType
= ACPI
| Workspace
| Unknown
deriving (Eq, Show)
instance Enum XMsgType where
toEnum 0 = ACPI
toEnum 1 = Workspace
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
fromEnum ACPI = 0
fromEnum ACPI = 0
fromEnum Workspace = 1
fromEnum Unknown = 2
fromEnum Unknown = 2
--------------------------------------------------------------------------------
-- | Exported API
-- Exported API
-- | Given a string from the data field in a ClientMessage event, return the
-- type and payload
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
splitXMsg [] = (Unknown, "")
splitXMsg (x:xs) = (xtype, tag)
splitXMsg (x : xs) = (xtype, tag)
where
xtype = toEnum $ fromIntegral x
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
@ -91,7 +91,7 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
-- longer will be clipped to 19, and anything less than 19 will be padded
-- with 0 (note this used to be random garbage before). See this function
-- for more details.
setClientMessageEvent' e root bITMAP 8 (x:t)
setClientMessageEvent' e root bITMAP 8 (x : t)
sendEvent dpy root False substructureNotifyMask e
where
x = fromIntegral $ fromEnum xtype

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

40
lib/XMonad/Internal/Concurrent/VirtualBox.hs
View File

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

66
lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
View File

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

197
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

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

63
lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
View File

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

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

48
lib/XMonad/Internal/DBus/Control.hs
View File

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

50
lib/XMonad/Internal/DBus/Removable.hs
View File

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

118
lib/XMonad/Internal/DBus/Screensaver.hs
View File

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

61
lib/XMonad/Internal/IO.hs
View File

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

45
lib/XMonad/Internal/Notify.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Functions for formatting and sending notifications
-- Functions for formatting and sending notifications
--
-- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for
-- notifications (just formation them into 'notify-send' commands and spawn a
@ -9,42 +9,45 @@
-- decide to switch to using the DBus it will be easy.
module XMonad.Internal.Notify
( Note(..)
, Body(..)
( Note (..)
, Body (..)
, defNote
, defNoteInfo
, defNoteError
, fmtNotifyCmd
, spawnNotify
) where
)
where
import DBus.Notify
import RIO
import qualified RIO.Text as T
import XMonad.Internal.Shell
import DBus.Notify
import RIO
import qualified RIO.Text as T
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
-- | Some nice default notes
-- Some nice default notes
defNote :: Note
defNote = blankNote { summary = "\"xmonad\"" }
defNote = blankNote {summary = "\"xmonad\""}
defNoteInfo :: Note
defNoteInfo = defNote
{ appImage = Just $ Icon "dialog-information-symbolic" }
defNoteInfo =
defNote
{ appImage = Just $ Icon "dialog-information-symbolic"
}
defNoteError :: Note
defNoteError = defNote
{ appImage = Just $ Icon "dialog-error-symbolic" }
defNoteError =
defNote
{ appImage = Just $ Icon "dialog-error-symbolic"
}
--------------------------------------------------------------------------------
-- | Format a 'notify-send' command to be send to the shell
-- Format a 'notify-send' command to be send to the shell
parseBody :: Body -> Maybe T.Text
parseBody (Text s) = Just $ T.pack s
parseBody _ = Nothing
parseBody _ = Nothing
fmtNotifyCmd :: Note -> T.Text
fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
@ -56,8 +59,8 @@ fmtNotifyArgs :: Note -> [T.Text]
fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
where
-- TODO add the rest of the options as needed
getSummary = (:[]) . doubleQuote . T.pack . summary
getSummary = (: []) . doubleQuote . T.pack . summary
getIcon n' =
maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }])
$ appImage n'
maybe [] (\i -> ["-i", T.pack $ case i of Icon s -> s; File s -> s]) $
appImage n'
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'

17
lib/XMonad/Internal/Process.hs
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)

130
lib/XMonad/Internal/Shell.hs
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 #-}
-- Functions for formatting and spawning shell commands
module XMonad.Internal.Shell
( fmtCmd
, spawnCmd
@ -68,80 +17,117 @@ module XMonad.Internal.Shell
, (#!||)
, (#!|)
, (#!>>)
) where
import RIO
import qualified RIO.Text as T
)
where
import RIO
import qualified RIO.Text as T
import qualified System.Process.Typed as P
import qualified XMonad.Core as X
import qualified XMonad.Util.Run as XR
import qualified XMonad.Core as X
import qualified XMonad.Util.Run as XR
--------------------------------------------------------------------------------
-- | Opening subshell
-- https://github.com/xmonad/xmonad/issues/113
-- | Fork a new process and wait for its exit code.
--
-- This function will work despite xmonad ignoring SIGCHLD.
--
-- 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 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 =
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.setCreateGroup True . P.setNewSession True
runProcess :: P.ProcessConfig a b c -> IO ExitCode
runProcess = withDefaultSignalHandlers . P.runProcess
-- | Create a 'ProcessConfig' for a shell command
shell :: T.Text -> P.ProcessConfig () () ()
shell = addGroupSession . P.shell . T.unpack
-- | Create a 'ProcessConfig' for a command with arguments
proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
-- | Run 'XMonad.Core.spawn' with 'Text' input.
spawn :: MonadIO m => T.Text -> m ()
spawn = X.spawn . T.unpack
-- spawnAt :: MonadIO m => FilePath -> T.Text -> m ()
-- spawnAt fp = liftIO . void . startProcess . P.setWorkingDir fp . shell
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
spawnPipe :: MonadIO m => T.Text -> m Handle
spawnPipe = XR.spawnPipe . T.unpack
-- | Run 'XMonad.Core.spawn' with a command and arguments
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
spawnCmd cmd = spawn . fmtCmd cmd
--------------------------------------------------------------------------------
-- | Formatting commands
-- | Format a command and list of arguments as 'Text'
fmtCmd :: FilePath -> [T.Text] -> T.Text
fmtCmd cmd args = T.unwords $ T.pack cmd : args
op :: T.Text -> T.Text -> T.Text -> T.Text
op a x b = T.unwords [a, x, b]
-- | Format two shell expressions separated by "&&"
(#!&&) :: T.Text -> T.Text -> T.Text
cmdA #!&& cmdB = op cmdA "&&" cmdB
infixr 0 #!&&
-- | Format two shell expressions separated by "|"
(#!|) :: T.Text -> T.Text -> T.Text
cmdA #!| cmdB = op cmdA "|" cmdB
infixr 0 #!|
-- | Format two shell expressions separated by "||"
(#!||) :: T.Text -> T.Text -> T.Text
cmdA #!|| cmdB = op cmdA "||" cmdB
infixr 0 #!||
-- | Format two shell expressions separated by ";"
(#!>>) :: T.Text -> T.Text -> T.Text
cmdA #!>> cmdB = op cmdA ";" cmdB
infixr 0 #!>>
-- | Wrap input in double quotes
doubleQuote :: T.Text -> T.Text
doubleQuote s = T.concat ["\"", s, "\""]
-- | Wrap input in single quotes
singleQuote :: T.Text -> T.Text
singleQuote s = T.concat ["'", s, "'"]

188
lib/XMonad/Internal/Theme.hs
View File

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

33
lib/Xmobar/Plugins/BacklightCommon.hs
View File

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

112
lib/Xmobar/Plugins/Bluetooth.hs
View File

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

20
lib/Xmobar/Plugins/ClevoKeyboard.hs
View File

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

38
lib/Xmobar/Plugins/Common.hs
View File

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

49
lib/Xmobar/Plugins/Device.hs
View File

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

20
lib/Xmobar/Plugins/IntelBacklight.hs
View File

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

18
lib/Xmobar/Plugins/Screensaver.hs
View File

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

87
lib/Xmobar/Plugins/VPN.hs
View File

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

2
package.yaml
View File

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