Compare commits
5 Commits
aa3979b36f
...
adf0257533
Author | SHA1 | Date |
---|---|---|
Nathan Dwarshuis | adf0257533 | |
Nathan Dwarshuis | b2b0f72178 | |
Nathan Dwarshuis | d560db1548 | |
Nathan Dwarshuis | 769df2fb00 | |
Nathan Dwarshuis | 017d13d80c |
|
@ -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
|
|
@ -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
562
bin/xmobar.hs
|
@ -1,8 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Xmobar binary
|
||||
--
|
||||
-- Features:
|
||||
|
@ -12,52 +9,47 @@ module Main (main) where
|
|||
-- * Some custom plugins (imported below)
|
||||
-- * Theme integration with xmonad (shared module imported below)
|
||||
-- * A custom Locks plugin from my own forked repo
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
|
||||
import RIO hiding (hFlush)
|
||||
import qualified RIO.ByteString.Lazy as BL
|
||||
import RIO.Process
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Environment
|
||||
import System.IO
|
||||
|
||||
import Xmobar.Plugins.Bluetooth
|
||||
import Xmobar.Plugins.ClevoKeyboard
|
||||
import Xmobar.Plugins.Device
|
||||
import Xmobar.Plugins.IntelBacklight
|
||||
import Xmobar.Plugins.Screensaver
|
||||
import Xmobar.Plugins.VPN
|
||||
|
||||
import XMonad.Core hiding (config)
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.Command.Power
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Control
|
||||
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
||||
import qualified XMonad.Internal.Theme as XT
|
||||
import Xmobar hiding
|
||||
( iconOffset
|
||||
, run
|
||||
)
|
||||
import Xmobar.Plugins.Common
|
||||
|
||||
import Control.Monad
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import RIO hiding (hFlush)
|
||||
import qualified RIO.ByteString.Lazy as BL
|
||||
import RIO.Process
|
||||
import qualified RIO.Text as T
|
||||
import System.Environment
|
||||
import System.IO
|
||||
import XMonad.Core hiding (config)
|
||||
import XMonad.Internal.Command.Desktop
|
||||
import XMonad.Internal.Command.Power
|
||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||
import XMonad.Internal.DBus.Control
|
||||
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
||||
import qualified XMonad.Internal.Theme as XT
|
||||
import Xmobar hiding
|
||||
( iconOffset
|
||||
, run
|
||||
)
|
||||
import Xmobar.Plugins.Bluetooth
|
||||
import Xmobar.Plugins.ClevoKeyboard
|
||||
import Xmobar.Plugins.Common
|
||||
import Xmobar.Plugins.Device
|
||||
import Xmobar.Plugins.IntelBacklight
|
||||
import Xmobar.Plugins.Screensaver
|
||||
import Xmobar.Plugins.VPN
|
||||
|
||||
main :: IO ()
|
||||
main = getArgs >>= parse
|
||||
|
||||
parse :: [String] -> IO ()
|
||||
parse [] = run
|
||||
parse [] = run
|
||||
parse ["--deps"] = withCache printDeps
|
||||
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
|
||||
parse _ = usage
|
||||
parse _ = usage
|
||||
|
||||
run :: IO ()
|
||||
run = do
|
||||
|
@ -84,13 +76,16 @@ printDeps = do
|
|||
io $ disconnectDBus db
|
||||
|
||||
usage :: IO ()
|
||||
usage = putStrLn $ intercalate "\n"
|
||||
[ "xmobar: run greatest taskbar"
|
||||
, "xmobar --deps: print dependencies"
|
||||
]
|
||||
usage =
|
||||
putStrLn $
|
||||
intercalate
|
||||
"\n"
|
||||
[ "xmobar: run greatest taskbar"
|
||||
, "xmobar --deps: print dependencies"
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | toplevel configuration
|
||||
-- toplevel configuration
|
||||
|
||||
-- | The text font family
|
||||
textFont :: Always XT.FontBuilder
|
||||
|
@ -102,88 +97,93 @@ textFontOffset = 16
|
|||
|
||||
-- | Attributes for the bar font (size, weight, etc)
|
||||
textFontData :: XT.FontData
|
||||
textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 }
|
||||
textFontData = XT.defFontData {XT.weight = Just XT.Bold, XT.size = Just 11}
|
||||
|
||||
-- | The icon font family
|
||||
iconFont :: Sometimes XT.FontBuilder
|
||||
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
|
||||
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
||||
iconFont =
|
||||
fontSometimes
|
||||
"XMobar Icon Font"
|
||||
"Symbols Nerd Font"
|
||||
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
||||
|
||||
-- | Offsets for the icons in the bar (relative to the text offset)
|
||||
iconOffset :: BarFont -> Int
|
||||
iconOffset IconSmall = 0
|
||||
iconOffset IconSmall = 0
|
||||
iconOffset IconMedium = 1
|
||||
iconOffset IconLarge = 1
|
||||
iconOffset IconLarge = 1
|
||||
iconOffset IconXLarge = 2
|
||||
|
||||
-- | Sizes (in pixels) for the icon fonts
|
||||
iconSize :: BarFont -> Int
|
||||
iconSize IconSmall = 13
|
||||
iconSize IconSmall = 13
|
||||
iconSize IconMedium = 15
|
||||
iconSize IconLarge = 18
|
||||
iconSize IconLarge = 18
|
||||
iconSize IconXLarge = 20
|
||||
|
||||
-- | Attributes for icon fonts
|
||||
iconFontData :: Int -> XT.FontData
|
||||
iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }
|
||||
iconFontData s = XT.defFontData {XT.pixelsize = Just s, XT.size = Nothing}
|
||||
|
||||
-- | Global configuration
|
||||
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
|
||||
-- only one) text font, and all other fonts are icon fonts. If this assumption
|
||||
-- changes the code will need to change significantly
|
||||
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
|
||||
config bf ifs ios br confDir = defaultConfig
|
||||
{ font = T.unpack bf
|
||||
, additionalFonts = fmap T.unpack ifs
|
||||
, textOffset = textFontOffset
|
||||
, textOffsets = ios
|
||||
, bgColor = T.unpack XT.bgColor
|
||||
, fgColor = T.unpack XT.fgColor
|
||||
, position = BottomSize C 100 24
|
||||
, border = NoBorder
|
||||
, borderColor = T.unpack XT.bordersColor
|
||||
|
||||
, sepChar = T.unpack pSep
|
||||
, alignSep = [lSep, rSep]
|
||||
, template = T.unpack $ fmtRegions br
|
||||
|
||||
, lowerOnStart = False
|
||||
, hideOnStart = False
|
||||
, allDesktops = True
|
||||
, overrideRedirect = True
|
||||
, pickBroadest = False
|
||||
, persistent = True
|
||||
-- store the icons with the xmonad/xmobar stack project
|
||||
, iconRoot = confDir ++ "/icons"
|
||||
|
||||
, commands = csRunnable <$> concatRegions br
|
||||
}
|
||||
config bf ifs ios br confDir =
|
||||
defaultConfig
|
||||
{ font = T.unpack bf
|
||||
, additionalFonts = fmap T.unpack ifs
|
||||
, textOffset = textFontOffset
|
||||
, textOffsets = ios
|
||||
, bgColor = T.unpack XT.bgColor
|
||||
, fgColor = T.unpack XT.fgColor
|
||||
, position = BottomSize C 100 24
|
||||
, border = NoBorder
|
||||
, borderColor = T.unpack XT.bordersColor
|
||||
, sepChar = T.unpack pSep
|
||||
, alignSep = [lSep, rSep]
|
||||
, template = T.unpack $ fmtRegions br
|
||||
, lowerOnStart = False
|
||||
, hideOnStart = False
|
||||
, allDesktops = True
|
||||
, overrideRedirect = True
|
||||
, pickBroadest = False
|
||||
, persistent = True
|
||||
, -- store the icons with the xmonad/xmobar stack project
|
||||
iconRoot = confDir ++ "/icons"
|
||||
, commands = csRunnable <$> concatRegions br
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | plugin features
|
||||
-- plugin features
|
||||
--
|
||||
-- some commands depend on the presence of interfaces that can only be
|
||||
-- determined at runtime; define these checks here
|
||||
|
||||
getAllCommands :: [Maybe CmdSpec] -> BarRegions
|
||||
getAllCommands right = BarRegions
|
||||
{ brLeft = [ CmdSpec
|
||||
{ csAlias = "UnsafeStdinReader"
|
||||
, csRunnable = Run UnsafeStdinReader
|
||||
}
|
||||
]
|
||||
, brCenter = []
|
||||
, brRight = catMaybes right
|
||||
}
|
||||
getAllCommands right =
|
||||
BarRegions
|
||||
{ brLeft =
|
||||
[ CmdSpec
|
||||
{ csAlias = "UnsafeStdinReader"
|
||||
, csRunnable = Run UnsafeStdinReader
|
||||
}
|
||||
]
|
||||
, brCenter = []
|
||||
, brRight = catMaybes right
|
||||
}
|
||||
|
||||
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
|
||||
rightPlugins db = mapM evalFeature $ allFeatures db
|
||||
++ [always' "date indicator" dateCmd]
|
||||
rightPlugins db =
|
||||
mapM evalFeature $
|
||||
allFeatures db
|
||||
++ [always' "date indicator" dateCmd]
|
||||
where
|
||||
always' n = Right . Always n . Always_ . FallbackAlone
|
||||
|
||||
allFeatures :: DBusState -> [Feature CmdSpec]
|
||||
allFeatures DBusState { dbSesClient = ses, dbSysClient = sys } =
|
||||
allFeatures DBusState {dbSesClient = ses, dbSysClient = sys} =
|
||||
[ Left getWireless
|
||||
, Left $ getEthernet sys
|
||||
, Left $ getVPN sys
|
||||
|
@ -200,8 +200,11 @@ type BarFeature = Sometimes CmdSpec
|
|||
|
||||
-- TODO what if I don't have a wireless card?
|
||||
getWireless :: BarFeature
|
||||
getWireless = Sometimes "wireless status indicator" xpfWireless
|
||||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||
getWireless =
|
||||
Sometimes
|
||||
"wireless status indicator"
|
||||
xpfWireless
|
||||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||
|
||||
getEthernet :: Maybe SysClient -> BarFeature
|
||||
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
|
||||
|
@ -213,32 +216,49 @@ getBattery :: BarFeature
|
|||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||
where
|
||||
root useIcon = IORoot_ (batteryCmd useIcon)
|
||||
tree = Only_ $ IOTest_ "Test if battery is present" []
|
||||
$ io $ fmap (Msg LevelError) <$> hasBattery
|
||||
tree =
|
||||
Only_ $
|
||||
IOTest_ "Test if battery is present" [] $
|
||||
io $
|
||||
fmap (Msg LevelError) <$> hasBattery
|
||||
|
||||
getVPN :: Maybe SysClient -> BarFeature
|
||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
||||
where
|
||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
|
||||
networkManagerPkgs vpnPresent
|
||||
test =
|
||||
DBusIO $
|
||||
IOTest_
|
||||
"Use nmcli to test if VPN is present"
|
||||
networkManagerPkgs
|
||||
vpnPresent
|
||||
|
||||
getBt :: Maybe SysClient -> BarFeature
|
||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||
|
||||
getAlsa :: BarFeature
|
||||
getAlsa = iconIO_ "volume level indicator" (const True) root
|
||||
$ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
|
||||
getAlsa =
|
||||
iconIO_ "volume level indicator" (const True) root $
|
||||
Only_ $
|
||||
sysExe [Package Official "alsa-utils"] "alsactl"
|
||||
where
|
||||
root useIcon = IORoot_ (alsaCmd useIcon)
|
||||
|
||||
getBl :: Maybe SesClient -> BarFeature
|
||||
getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
|
||||
intelBacklightSignalDep blCmd
|
||||
getBl =
|
||||
xmobarDBus
|
||||
"Intel backlight indicator"
|
||||
xpfIntelBacklight
|
||||
intelBacklightSignalDep
|
||||
blCmd
|
||||
|
||||
getCk :: Maybe SesClient -> BarFeature
|
||||
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
|
||||
clevoKeyboardSignalDep ckCmd
|
||||
getCk =
|
||||
xmobarDBus
|
||||
"Clevo keyboard indicator"
|
||||
xpfClevoBacklight
|
||||
clevoKeyboardSignalDep
|
||||
ckCmd
|
||||
|
||||
getSs :: Maybe SesClient -> BarFeature
|
||||
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
||||
|
@ -249,158 +269,232 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
|
|||
root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | bar feature constructors
|
||||
-- bar feature constructors
|
||||
|
||||
xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
|
||||
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
|
||||
xmobarDBus
|
||||
:: SafeClient c
|
||||
=> T.Text
|
||||
-> XPQuery
|
||||
-> DBusDependency_ c
|
||||
-> (Fontifier -> CmdSpec)
|
||||
-> Maybe c
|
||||
-> BarFeature
|
||||
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
||||
where
|
||||
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
||||
|
||||
iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
|
||||
-> IOTree_ -> BarFeature
|
||||
iconIO_
|
||||
:: T.Text
|
||||
-> XPQuery
|
||||
-> (Fontifier -> IOTree_ -> Root CmdSpec)
|
||||
-> IOTree_
|
||||
-> BarFeature
|
||||
iconIO_ = iconSometimes' And_ Only_
|
||||
|
||||
iconDBus :: SafeClient c => T.Text -> XPQuery
|
||||
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
|
||||
iconDBus
|
||||
:: SafeClient c
|
||||
=> T.Text
|
||||
-> XPQuery
|
||||
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||
-> DBusTree c p
|
||||
-> BarFeature
|
||||
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||
|
||||
iconDBus_ :: SafeClient c => T.Text -> XPQuery
|
||||
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
|
||||
iconDBus_
|
||||
:: SafeClient c
|
||||
=> T.Text
|
||||
-> XPQuery
|
||||
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
|
||||
-> DBusTree_ c
|
||||
-> BarFeature
|
||||
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
||||
|
||||
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery
|
||||
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
|
||||
iconSometimes' c d n q r t = Sometimes n q
|
||||
[ Subfeature icon "icon indicator"
|
||||
, Subfeature text "text indicator"
|
||||
]
|
||||
iconSometimes'
|
||||
:: (t -> t_ -> t)
|
||||
-> (IODependency_ -> t_)
|
||||
-> T.Text
|
||||
-> XPQuery
|
||||
-> (Fontifier -> t -> Root CmdSpec)
|
||||
-> t
|
||||
-> BarFeature
|
||||
iconSometimes' c d n q r t =
|
||||
Sometimes
|
||||
n
|
||||
q
|
||||
[ Subfeature icon "icon indicator"
|
||||
, Subfeature text "text indicator"
|
||||
]
|
||||
where
|
||||
icon = r fontifyIcon $ c t $ d iconDependency
|
||||
text = r fontifyAlt t
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | command specifications
|
||||
-- command specifications
|
||||
|
||||
data BarRegions = BarRegions
|
||||
{ brLeft :: [CmdSpec]
|
||||
{ brLeft :: [CmdSpec]
|
||||
, brCenter :: [CmdSpec]
|
||||
, brRight :: [CmdSpec]
|
||||
} deriving Show
|
||||
, brRight :: [CmdSpec]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data CmdSpec = CmdSpec
|
||||
{ csAlias :: T.Text
|
||||
{ csAlias :: T.Text
|
||||
, csRunnable :: Runnable
|
||||
} deriving Show
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
concatRegions :: BarRegions -> [CmdSpec]
|
||||
concatRegions (BarRegions l c r) = l ++ c ++ r
|
||||
|
||||
wirelessCmd :: T.Text -> CmdSpec
|
||||
wirelessCmd iface = CmdSpec
|
||||
{ csAlias = T.append iface "wi"
|
||||
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
||||
}
|
||||
wirelessCmd iface =
|
||||
CmdSpec
|
||||
{ csAlias = T.append iface "wi"
|
||||
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
||||
}
|
||||
where
|
||||
args = fmap T.unpack
|
||||
[ "-t", "<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
887
bin/xmonad.hs
File diff suppressed because it is too large
Load Diff
|
@ -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
|
|
@ -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
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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 ++ "'"
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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'
|
||||
|
|
|
@ -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)
|
||||
|
|
@ -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, "'"]
|
||||
|
||||
|
|
|
@ -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
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -7,7 +7,7 @@ copyright: "2022 Nathan Dwarshuis"
|
|||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
- .stylish-haskell.yaml
|
||||
- fourmolu.yaml
|
||||
- make_pkgs
|
||||
- icons/*
|
||||
- scripts/*
|
||||
|
|
Loading…
Reference in New Issue