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 #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Start a VirtualBox instance with a sentinel wrapper process.
|
-- | Start a VirtualBox instance with a sentinel wrapper process.
|
||||||
--
|
--
|
||||||
-- The only reason why this is needed is because I want to manage virtualboxes
|
-- The only reason why this is needed is because I want to manage virtualboxes
|
||||||
|
@ -15,19 +14,14 @@
|
||||||
-- until its PID exits. By monitoring this wrapper, the dynamic workspace only
|
-- until its PID exits. By monitoring this wrapper, the dynamic workspace only
|
||||||
-- has one process to track and will maintain the workspace throughout the
|
-- has one process to track and will maintain the workspace throughout the
|
||||||
-- lifetime of the VM.
|
-- lifetime of the VM.
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as BU
|
import qualified Data.ByteString.Lazy.UTF8 as BU
|
||||||
|
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.Process
|
import RIO.Process
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Text.XML.Light
|
|
||||||
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
import Text.XML.Light
|
||||||
import XMonad.Internal.Concurrent.VirtualBox
|
import XMonad.Internal.Concurrent.VirtualBox
|
||||||
import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
|
|
||||||
|
@ -48,7 +42,6 @@ runAndWait [n] = do
|
||||||
p <- vmPID i
|
p <- vmPID i
|
||||||
liftIO $ mapM_ waitUntilExit p
|
liftIO $ mapM_ waitUntilExit p
|
||||||
err = logError "Could not get machine ID"
|
err = logError "Could not get machine ID"
|
||||||
|
|
||||||
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
|
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
|
||||||
|
|
||||||
vmLaunch :: T.Text -> RIO SimpleApp ()
|
vmLaunch :: T.Text -> RIO SimpleApp ()
|
||||||
|
@ -56,7 +49,9 @@ vmLaunch i = do
|
||||||
rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
|
rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
|
||||||
case rc of
|
case rc of
|
||||||
ExitSuccess -> return ()
|
ExitSuccess -> return ()
|
||||||
_ -> logError $ "Failed to start VM: "
|
_ ->
|
||||||
|
logError $
|
||||||
|
"Failed to start VM: "
|
||||||
<> displayBytesUtf8 (encodeUtf8 i)
|
<> displayBytesUtf8 (encodeUtf8 i)
|
||||||
|
|
||||||
vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
|
vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
|
||||||
|
@ -73,7 +68,8 @@ vmMachineID iPath = do
|
||||||
Right contents -> return $ findMachineID contents
|
Right contents -> return $ findMachineID contents
|
||||||
Left e -> logError (displayShow e) >> return Nothing
|
Left e -> logError (displayShow e) >> return Nothing
|
||||||
where
|
where
|
||||||
findMachineID c = T.stripSuffix "}"
|
findMachineID c =
|
||||||
|
T.stripSuffix "}"
|
||||||
=<< T.stripPrefix "{"
|
=<< T.stripPrefix "{"
|
||||||
=<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
|
=<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
|
||||||
=<< (\e -> findChild (qual e "Machine") e)
|
=<< (\e -> findChild (qual e "Machine") e)
|
||||||
|
|
326
bin/xmobar.hs
326
bin/xmobar.hs
|
@ -1,8 +1,5 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Main (main) where
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Xmobar binary
|
-- | Xmobar binary
|
||||||
--
|
--
|
||||||
-- Features:
|
-- Features:
|
||||||
|
@ -12,29 +9,19 @@ module Main (main) where
|
||||||
-- * Some custom plugins (imported below)
|
-- * Some custom plugins (imported below)
|
||||||
-- * Theme integration with xmonad (shared module imported below)
|
-- * Theme integration with xmonad (shared module imported below)
|
||||||
-- * A custom Locks plugin from my own forked repo
|
-- * A custom Locks plugin from my own forked repo
|
||||||
|
module Main (main) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import RIO hiding (hFlush)
|
import RIO hiding (hFlush)
|
||||||
import qualified RIO.ByteString.Lazy as BL
|
import qualified RIO.ByteString.Lazy as BL
|
||||||
import RIO.Process
|
import RIO.Process
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.IO
|
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.Core hiding (config)
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.Command.Power
|
import XMonad.Internal.Command.Power
|
||||||
|
@ -47,8 +34,13 @@ import Xmobar hiding
|
||||||
( iconOffset
|
( iconOffset
|
||||||
, run
|
, run
|
||||||
)
|
)
|
||||||
|
import Xmobar.Plugins.Bluetooth
|
||||||
|
import Xmobar.Plugins.ClevoKeyboard
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
import Xmobar.Plugins.Device
|
||||||
|
import Xmobar.Plugins.IntelBacklight
|
||||||
|
import Xmobar.Plugins.Screensaver
|
||||||
|
import Xmobar.Plugins.VPN
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = getArgs >>= parse
|
main = getArgs >>= parse
|
||||||
|
@ -84,13 +76,16 @@ printDeps = do
|
||||||
io $ disconnectDBus db
|
io $ disconnectDBus db
|
||||||
|
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
usage = putStrLn $ intercalate "\n"
|
usage =
|
||||||
|
putStrLn $
|
||||||
|
intercalate
|
||||||
|
"\n"
|
||||||
[ "xmobar: run greatest taskbar"
|
[ "xmobar: run greatest taskbar"
|
||||||
, "xmobar --deps: print dependencies"
|
, "xmobar --deps: print dependencies"
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | toplevel configuration
|
-- toplevel configuration
|
||||||
|
|
||||||
-- | The text font family
|
-- | The text font family
|
||||||
textFont :: Always XT.FontBuilder
|
textFont :: Always XT.FontBuilder
|
||||||
|
@ -106,7 +101,10 @@ textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 }
|
||||||
|
|
||||||
-- | The icon font family
|
-- | The icon font family
|
||||||
iconFont :: Sometimes XT.FontBuilder
|
iconFont :: Sometimes XT.FontBuilder
|
||||||
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
|
iconFont =
|
||||||
|
fontSometimes
|
||||||
|
"XMobar Icon Font"
|
||||||
|
"Symbols Nerd Font"
|
||||||
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
||||||
|
|
||||||
-- | Offsets for the icons in the bar (relative to the text offset)
|
-- | Offsets for the icons in the bar (relative to the text offset)
|
||||||
|
@ -132,7 +130,8 @@ iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }
|
||||||
-- only one) text font, and all other fonts are icon fonts. If this assumption
|
-- only one) text font, and all other fonts are icon fonts. If this assumption
|
||||||
-- changes the code will need to change significantly
|
-- changes the code will need to change significantly
|
||||||
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
|
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
|
||||||
config bf ifs ios br confDir = defaultConfig
|
config bf ifs ios br confDir =
|
||||||
|
defaultConfig
|
||||||
{ font = T.unpack bf
|
{ font = T.unpack bf
|
||||||
, additionalFonts = fmap T.unpack ifs
|
, additionalFonts = fmap T.unpack ifs
|
||||||
, textOffset = textFontOffset
|
, textOffset = textFontOffset
|
||||||
|
@ -142,32 +141,31 @@ config bf ifs ios br confDir = defaultConfig
|
||||||
, position = BottomSize C 100 24
|
, position = BottomSize C 100 24
|
||||||
, border = NoBorder
|
, border = NoBorder
|
||||||
, borderColor = T.unpack XT.bordersColor
|
, borderColor = T.unpack XT.bordersColor
|
||||||
|
|
||||||
, sepChar = T.unpack pSep
|
, sepChar = T.unpack pSep
|
||||||
, alignSep = [lSep, rSep]
|
, alignSep = [lSep, rSep]
|
||||||
, template = T.unpack $ fmtRegions br
|
, template = T.unpack $ fmtRegions br
|
||||||
|
|
||||||
, lowerOnStart = False
|
, lowerOnStart = False
|
||||||
, hideOnStart = False
|
, hideOnStart = False
|
||||||
, allDesktops = True
|
, allDesktops = True
|
||||||
, overrideRedirect = True
|
, overrideRedirect = True
|
||||||
, pickBroadest = False
|
, pickBroadest = False
|
||||||
, persistent = True
|
, persistent = True
|
||||||
-- store the icons with the xmonad/xmobar stack project
|
, -- store the icons with the xmonad/xmobar stack project
|
||||||
, iconRoot = confDir ++ "/icons"
|
iconRoot = confDir ++ "/icons"
|
||||||
|
|
||||||
, commands = csRunnable <$> concatRegions br
|
, commands = csRunnable <$> concatRegions br
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | plugin features
|
-- plugin features
|
||||||
--
|
--
|
||||||
-- some commands depend on the presence of interfaces that can only be
|
-- some commands depend on the presence of interfaces that can only be
|
||||||
-- determined at runtime; define these checks here
|
-- determined at runtime; define these checks here
|
||||||
|
|
||||||
getAllCommands :: [Maybe CmdSpec] -> BarRegions
|
getAllCommands :: [Maybe CmdSpec] -> BarRegions
|
||||||
getAllCommands right = BarRegions
|
getAllCommands right =
|
||||||
{ brLeft = [ CmdSpec
|
BarRegions
|
||||||
|
{ brLeft =
|
||||||
|
[ CmdSpec
|
||||||
{ csAlias = "UnsafeStdinReader"
|
{ csAlias = "UnsafeStdinReader"
|
||||||
, csRunnable = Run UnsafeStdinReader
|
, csRunnable = Run UnsafeStdinReader
|
||||||
}
|
}
|
||||||
|
@ -177,7 +175,9 @@ getAllCommands right = BarRegions
|
||||||
}
|
}
|
||||||
|
|
||||||
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
|
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
|
||||||
rightPlugins db = mapM evalFeature $ allFeatures db
|
rightPlugins db =
|
||||||
|
mapM evalFeature $
|
||||||
|
allFeatures db
|
||||||
++ [always' "date indicator" dateCmd]
|
++ [always' "date indicator" dateCmd]
|
||||||
where
|
where
|
||||||
always' n = Right . Always n . Always_ . FallbackAlone
|
always' n = Right . Always n . Always_ . FallbackAlone
|
||||||
|
@ -200,7 +200,10 @@ type BarFeature = Sometimes CmdSpec
|
||||||
|
|
||||||
-- TODO what if I don't have a wireless card?
|
-- TODO what if I don't have a wireless card?
|
||||||
getWireless :: BarFeature
|
getWireless :: BarFeature
|
||||||
getWireless = Sometimes "wireless status indicator" xpfWireless
|
getWireless =
|
||||||
|
Sometimes
|
||||||
|
"wireless status indicator"
|
||||||
|
xpfWireless
|
||||||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||||
|
|
||||||
getEthernet :: Maybe SysClient -> BarFeature
|
getEthernet :: Maybe SysClient -> BarFeature
|
||||||
|
@ -213,32 +216,49 @@ getBattery :: BarFeature
|
||||||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||||
where
|
where
|
||||||
root useIcon = IORoot_ (batteryCmd useIcon)
|
root useIcon = IORoot_ (batteryCmd useIcon)
|
||||||
tree = Only_ $ IOTest_ "Test if battery is present" []
|
tree =
|
||||||
$ io $ fmap (Msg LevelError) <$> hasBattery
|
Only_ $
|
||||||
|
IOTest_ "Test if battery is present" [] $
|
||||||
|
io $
|
||||||
|
fmap (Msg LevelError) <$> hasBattery
|
||||||
|
|
||||||
getVPN :: Maybe SysClient -> BarFeature
|
getVPN :: Maybe SysClient -> BarFeature
|
||||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
||||||
where
|
where
|
||||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||||
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
|
test =
|
||||||
networkManagerPkgs vpnPresent
|
DBusIO $
|
||||||
|
IOTest_
|
||||||
|
"Use nmcli to test if VPN is present"
|
||||||
|
networkManagerPkgs
|
||||||
|
vpnPresent
|
||||||
|
|
||||||
getBt :: Maybe SysClient -> BarFeature
|
getBt :: Maybe SysClient -> BarFeature
|
||||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
getAlsa = iconIO_ "volume level indicator" (const True) root
|
getAlsa =
|
||||||
$ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
|
iconIO_ "volume level indicator" (const True) root $
|
||||||
|
Only_ $
|
||||||
|
sysExe [Package Official "alsa-utils"] "alsactl"
|
||||||
where
|
where
|
||||||
root useIcon = IORoot_ (alsaCmd useIcon)
|
root useIcon = IORoot_ (alsaCmd useIcon)
|
||||||
|
|
||||||
getBl :: Maybe SesClient -> BarFeature
|
getBl :: Maybe SesClient -> BarFeature
|
||||||
getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
|
getBl =
|
||||||
intelBacklightSignalDep blCmd
|
xmobarDBus
|
||||||
|
"Intel backlight indicator"
|
||||||
|
xpfIntelBacklight
|
||||||
|
intelBacklightSignalDep
|
||||||
|
blCmd
|
||||||
|
|
||||||
getCk :: Maybe SesClient -> BarFeature
|
getCk :: Maybe SesClient -> BarFeature
|
||||||
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
|
getCk =
|
||||||
clevoKeyboardSignalDep ckCmd
|
xmobarDBus
|
||||||
|
"Clevo keyboard indicator"
|
||||||
|
xpfClevoBacklight
|
||||||
|
clevoKeyboardSignalDep
|
||||||
|
ckCmd
|
||||||
|
|
||||||
getSs :: Maybe SesClient -> BarFeature
|
getSs :: Maybe SesClient -> BarFeature
|
||||||
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
||||||
|
@ -249,29 +269,58 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
|
||||||
root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
|
root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | bar feature constructors
|
-- bar feature constructors
|
||||||
|
|
||||||
xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
|
xmobarDBus
|
||||||
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
|
:: SafeClient c
|
||||||
|
=> T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> DBusDependency_ c
|
||||||
|
-> (Fontifier -> CmdSpec)
|
||||||
|
-> Maybe c
|
||||||
|
-> BarFeature
|
||||||
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
||||||
where
|
where
|
||||||
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
||||||
|
|
||||||
iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
|
iconIO_
|
||||||
-> IOTree_ -> BarFeature
|
:: T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> (Fontifier -> IOTree_ -> Root CmdSpec)
|
||||||
|
-> IOTree_
|
||||||
|
-> BarFeature
|
||||||
iconIO_ = iconSometimes' And_ Only_
|
iconIO_ = iconSometimes' And_ Only_
|
||||||
|
|
||||||
iconDBus :: SafeClient c => T.Text -> XPQuery
|
iconDBus
|
||||||
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
|
:: SafeClient c
|
||||||
|
=> T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||||
|
-> DBusTree c p
|
||||||
|
-> BarFeature
|
||||||
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||||
|
|
||||||
iconDBus_ :: SafeClient c => T.Text -> XPQuery
|
iconDBus_
|
||||||
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
|
:: SafeClient c
|
||||||
|
=> T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
|
||||||
|
-> DBusTree_ c
|
||||||
|
-> BarFeature
|
||||||
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
||||||
|
|
||||||
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery
|
iconSometimes'
|
||||||
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
|
:: (t -> t_ -> t)
|
||||||
iconSometimes' c d n q r t = Sometimes n q
|
-> (IODependency_ -> t_)
|
||||||
|
-> T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> (Fontifier -> t -> Root CmdSpec)
|
||||||
|
-> t
|
||||||
|
-> BarFeature
|
||||||
|
iconSometimes' c d n q r t =
|
||||||
|
Sometimes
|
||||||
|
n
|
||||||
|
q
|
||||||
[ Subfeature icon "icon indicator"
|
[ Subfeature icon "icon indicator"
|
||||||
, Subfeature text "text indicator"
|
, Subfeature text "text indicator"
|
||||||
]
|
]
|
||||||
|
@ -280,125 +329,170 @@ iconSometimes' c d n q r t = Sometimes n q
|
||||||
text = r fontifyAlt t
|
text = r fontifyAlt t
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | command specifications
|
-- command specifications
|
||||||
|
|
||||||
data BarRegions = BarRegions
|
data BarRegions = BarRegions
|
||||||
{ brLeft :: [CmdSpec]
|
{ brLeft :: [CmdSpec]
|
||||||
, brCenter :: [CmdSpec]
|
, brCenter :: [CmdSpec]
|
||||||
, brRight :: [CmdSpec]
|
, brRight :: [CmdSpec]
|
||||||
} deriving Show
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data CmdSpec = CmdSpec
|
data CmdSpec = CmdSpec
|
||||||
{ csAlias :: T.Text
|
{ csAlias :: T.Text
|
||||||
, csRunnable :: Runnable
|
, csRunnable :: Runnable
|
||||||
} deriving Show
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
concatRegions :: BarRegions -> [CmdSpec]
|
concatRegions :: BarRegions -> [CmdSpec]
|
||||||
concatRegions (BarRegions l c r) = l ++ c ++ r
|
concatRegions (BarRegions l c r) = l ++ c ++ r
|
||||||
|
|
||||||
wirelessCmd :: T.Text -> CmdSpec
|
wirelessCmd :: T.Text -> CmdSpec
|
||||||
wirelessCmd iface = CmdSpec
|
wirelessCmd iface =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = T.append iface "wi"
|
{ csAlias = T.append iface "wi"
|
||||||
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
args = fmap T.unpack
|
args =
|
||||||
[ "-t", "<qualityipat><essid>"
|
fmap
|
||||||
|
T.unpack
|
||||||
|
[ "-t"
|
||||||
|
, "<qualityipat><essid>"
|
||||||
, "--"
|
, "--"
|
||||||
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
|
, "--quality-icon-pattern"
|
||||||
|
, "<icon=wifi_%%.xpm/>"
|
||||||
]
|
]
|
||||||
|
|
||||||
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
||||||
ethernetCmd fontify iface = CmdSpec
|
ethernetCmd fontify iface =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = iface
|
{ csAlias = iface
|
||||||
, csRunnable = Run
|
, csRunnable =
|
||||||
$ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
|
Run $
|
||||||
|
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
|
||||||
}
|
}
|
||||||
|
|
||||||
batteryCmd :: Fontifier -> CmdSpec
|
batteryCmd :: Fontifier -> CmdSpec
|
||||||
batteryCmd fontify = CmdSpec
|
batteryCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = "battery"
|
{ csAlias = "battery"
|
||||||
, csRunnable = Run $ Battery args 50
|
, csRunnable = Run $ Battery args 50
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
fontify' = fontify IconSmall
|
fontify' = fontify IconSmall
|
||||||
args = fmap T.unpack
|
args =
|
||||||
[ "--template", "<acstatus><left>"
|
fmap
|
||||||
, "--Low", "10"
|
T.unpack
|
||||||
, "--High", "80"
|
[ "--template"
|
||||||
, "--low", "red"
|
, "<acstatus><left>"
|
||||||
, "--normal", XT.fgColor
|
, "--Low"
|
||||||
, "--high", XT.fgColor
|
, "10"
|
||||||
|
, "--High"
|
||||||
|
, "80"
|
||||||
|
, "--low"
|
||||||
|
, "red"
|
||||||
|
, "--normal"
|
||||||
|
, XT.fgColor
|
||||||
|
, "--high"
|
||||||
|
, XT.fgColor
|
||||||
, "--"
|
, "--"
|
||||||
, "-P"
|
, "-P"
|
||||||
, "-o" , fontify' "\xf0e7" "BAT"
|
, "-o"
|
||||||
, "-O" , fontify' "\xf1e6" "AC"
|
, fontify' "\xf0e7" "BAT"
|
||||||
, "-i" , fontify' "\xf1e6" "AC"
|
, "-O"
|
||||||
|
, fontify' "\xf1e6" "AC"
|
||||||
|
, "-i"
|
||||||
|
, fontify' "\xf1e6" "AC"
|
||||||
]
|
]
|
||||||
|
|
||||||
vpnCmd :: Fontifier -> CmdSpec
|
vpnCmd :: Fontifier -> CmdSpec
|
||||||
vpnCmd fontify = CmdSpec
|
vpnCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = vpnAlias
|
{ csAlias = vpnAlias
|
||||||
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
||||||
}
|
}
|
||||||
|
|
||||||
btCmd :: Fontifier -> CmdSpec
|
btCmd :: Fontifier -> CmdSpec
|
||||||
btCmd fontify = CmdSpec
|
btCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = btAlias
|
{ csAlias = btAlias
|
||||||
, csRunnable = Run
|
, csRunnable =
|
||||||
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
Run $
|
||||||
|
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
fontify' i = fontify IconLarge i . T.append "BT"
|
fontify' i = fontify IconLarge i . T.append "BT"
|
||||||
|
|
||||||
alsaCmd :: Fontifier -> CmdSpec
|
alsaCmd :: Fontifier -> CmdSpec
|
||||||
alsaCmd fontify = CmdSpec
|
alsaCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = "alsa:default:Master"
|
{ csAlias = "alsa:default:Master"
|
||||||
, csRunnable = Run
|
, csRunnable =
|
||||||
$ Alsa "default" "Master"
|
Run $
|
||||||
$ fmap T.unpack
|
Alsa "default" "Master" $
|
||||||
[ "-t", "<status><volume>%"
|
fmap
|
||||||
|
T.unpack
|
||||||
|
[ "-t"
|
||||||
|
, "<status><volume>%"
|
||||||
, "--"
|
, "--"
|
||||||
, "-O", fontify' "\xf028" "+"
|
, "-O"
|
||||||
, "-o", T.append (fontify' "\xf026" "-") " "
|
, fontify' "\xf028" "+"
|
||||||
, "-c", XT.fgColor
|
, "-o"
|
||||||
, "-C", XT.fgColor
|
, T.append (fontify' "\xf026" "-") " "
|
||||||
|
, "-c"
|
||||||
|
, XT.fgColor
|
||||||
|
, "-C"
|
||||||
|
, XT.fgColor
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
fontify' i = fontify IconSmall i . T.append "VOL"
|
fontify' i = fontify IconSmall i . T.append "VOL"
|
||||||
|
|
||||||
blCmd :: Fontifier -> CmdSpec
|
blCmd :: Fontifier -> CmdSpec
|
||||||
blCmd fontify = CmdSpec
|
blCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = blAlias
|
{ csAlias = blAlias
|
||||||
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
|
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
|
||||||
}
|
}
|
||||||
|
|
||||||
ckCmd :: Fontifier -> CmdSpec
|
ckCmd :: Fontifier -> CmdSpec
|
||||||
ckCmd fontify = CmdSpec
|
ckCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = ckAlias
|
{ csAlias = ckAlias
|
||||||
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
|
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
|
||||||
}
|
}
|
||||||
|
|
||||||
ssCmd :: Fontifier -> CmdSpec
|
ssCmd :: Fontifier -> CmdSpec
|
||||||
ssCmd fontify = CmdSpec
|
ssCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = ssAlias
|
{ csAlias = ssAlias
|
||||||
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
|
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
|
||||||
}
|
}
|
||||||
|
|
||||||
lockCmd :: Fontifier -> CmdSpec
|
lockCmd :: Fontifier -> CmdSpec
|
||||||
lockCmd fontify = CmdSpec
|
lockCmd fontify =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = "locks"
|
{ csAlias = "locks"
|
||||||
, csRunnable = Run
|
, csRunnable =
|
||||||
$ Locks
|
Run $
|
||||||
$ fmap T.unpack
|
Locks $
|
||||||
[ "-N", numIcon
|
fmap
|
||||||
, "-n", disabledColor numIcon
|
T.unpack
|
||||||
, "-C", capIcon
|
[ "-N"
|
||||||
, "-c", disabledColor capIcon
|
, numIcon
|
||||||
, "-s", ""
|
, "-n"
|
||||||
, "-S", ""
|
, disabledColor numIcon
|
||||||
, "-d", " "
|
, "-C"
|
||||||
|
, capIcon
|
||||||
|
, "-c"
|
||||||
|
, disabledColor capIcon
|
||||||
|
, "-s"
|
||||||
|
, ""
|
||||||
|
, "-S"
|
||||||
|
, ""
|
||||||
|
, "-d"
|
||||||
|
, " "
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
|
@ -408,33 +502,37 @@ lockCmd fontify = CmdSpec
|
||||||
disabledColor = xmobarFGColor XT.backdropFgColor
|
disabledColor = xmobarFGColor XT.backdropFgColor
|
||||||
|
|
||||||
dateCmd :: CmdSpec
|
dateCmd :: CmdSpec
|
||||||
dateCmd = CmdSpec
|
dateCmd =
|
||||||
|
CmdSpec
|
||||||
{ csAlias = "date"
|
{ csAlias = "date"
|
||||||
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | low-level testing functions
|
-- low-level testing functions
|
||||||
|
|
||||||
vpnPresent :: FIO (Maybe Msg)
|
vpnPresent :: FIO (Maybe Msg)
|
||||||
vpnPresent = do
|
vpnPresent = do
|
||||||
res <- proc "nmcli" args readProcess
|
res <- proc "nmcli" args readProcess
|
||||||
return $ case res of
|
return $ case res of
|
||||||
(ExitSuccess, out, _) | "vpn" `elem` BL.split 10 out -> Nothing
|
(ExitSuccess, out, _)
|
||||||
|
| "vpn" `elem` BL.split 10 out -> Nothing
|
||||||
| otherwise -> Just $ Msg LevelError "vpn not found"
|
| otherwise -> Just $ Msg LevelError "vpn not found"
|
||||||
(ExitFailure c, _, err) -> Just $ Msg LevelError
|
(ExitFailure c, _, err) ->
|
||||||
$ T.concat
|
Just $
|
||||||
|
Msg LevelError $
|
||||||
|
T.concat
|
||||||
[ "vpn search exited with code "
|
[ "vpn search exited with code "
|
||||||
, T.pack $ show c
|
, T.pack $ show c
|
||||||
, ": "
|
, ": "
|
||||||
, T.decodeUtf8With T.lenientDecode
|
, T.decodeUtf8With T.lenientDecode $
|
||||||
$ BL.toStrict err
|
BL.toStrict err
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | text font
|
-- text font
|
||||||
--
|
--
|
||||||
-- ASSUME there is only one text font for this entire configuration. This
|
-- ASSUME there is only one text font for this entire configuration. This
|
||||||
-- will correspond to the first font/offset parameters in the config record.
|
-- will correspond to the first font/offset parameters in the config record.
|
||||||
|
@ -445,17 +543,20 @@ getTextFont = do
|
||||||
return $ fb textFontData
|
return $ fb textFontData
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | icon fonts
|
-- icon fonts
|
||||||
|
|
||||||
getIconFonts :: FIO ([T.Text], [Int])
|
getIconFonts :: FIO ([T.Text], [Int])
|
||||||
getIconFonts = do
|
getIconFonts = do
|
||||||
fb <- evalSometimes iconFont
|
fb <- evalSometimes iconFont
|
||||||
return $ maybe ([], []) apply fb
|
return $ maybe ([], []) apply fb
|
||||||
where
|
where
|
||||||
apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
|
apply fb =
|
||||||
|
unzip $
|
||||||
|
(\i -> (iconString fb i, iconOffset i + textFontOffset))
|
||||||
<$> iconFonts
|
<$> iconFonts
|
||||||
|
|
||||||
data BarFont = IconSmall
|
data BarFont
|
||||||
|
= IconSmall
|
||||||
| IconMedium
|
| IconMedium
|
||||||
| IconLarge
|
| IconLarge
|
||||||
| IconXLarge
|
| IconXLarge
|
||||||
|
@ -483,7 +584,7 @@ fontifyIcon :: Fontifier
|
||||||
fontifyIcon f i _ = fontifyText f i
|
fontifyIcon f i _ = fontifyText f i
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | various formatting things
|
-- various formatting things
|
||||||
|
|
||||||
colors :: Colors
|
colors :: Colors
|
||||||
colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
|
colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
|
||||||
|
@ -506,5 +607,6 @@ fmtSpecs = T.intercalate sep . fmap go
|
||||||
go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
|
go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
|
||||||
|
|
||||||
fmtRegions :: BarRegions -> T.Text
|
fmtRegions :: BarRegions -> T.Text
|
||||||
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat
|
fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
|
||||||
|
T.concat
|
||||||
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
|
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
|
||||||
|
|
319
bin/xmonad.hs
319
bin/xmonad.hs
|
@ -4,35 +4,30 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | XMonad binary
|
-- XMonad binary
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Text.IO (hPutStrLn)
|
import Data.Text.IO (hPutStrLn)
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
|
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
import RIO.Process
|
import RIO.Process
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Posix.Signals
|
import System.Posix.Signals
|
||||||
import System.Process
|
import System.Process
|
||||||
( getPid
|
( getPid
|
||||||
, getProcessExitCode
|
, getProcessExitCode
|
||||||
)
|
)
|
||||||
|
|
||||||
import XMonad
|
import XMonad
|
||||||
import XMonad.Actions.CopyWindow
|
import XMonad.Actions.CopyWindow
|
||||||
import XMonad.Actions.CycleWS
|
import XMonad.Actions.CycleWS
|
||||||
|
@ -110,10 +105,12 @@ run = do
|
||||||
sk <- evalAlways $ fsShowKeys fs
|
sk <- evalAlways $ fsShowKeys fs
|
||||||
ha <- evalAlways $ fsACPIHandler fs
|
ha <- evalAlways $ fsACPIHandler fs
|
||||||
tt <- evalAlways $ fsTabbedTheme fs
|
tt <- evalAlways $ fsTabbedTheme fs
|
||||||
let conf = ewmh
|
let conf =
|
||||||
$ addKeymap dws sk kbs
|
ewmh $
|
||||||
$ docks
|
addKeymap dws sk kbs $
|
||||||
$ def { terminal = myTerm
|
docks $
|
||||||
|
def
|
||||||
|
{ terminal = myTerm
|
||||||
, modMask = myModMask
|
, modMask = myModMask
|
||||||
, layoutHook = myLayouts tt
|
, layoutHook = myLayouts tt
|
||||||
, manageHook = myManageHook dws
|
, manageHook = myManageHook dws
|
||||||
|
@ -128,8 +125,11 @@ run = do
|
||||||
}
|
}
|
||||||
io $ runXMonad conf
|
io $ runXMonad conf
|
||||||
where
|
where
|
||||||
startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs
|
startRemovableMon db fs =
|
||||||
$ dbSysClient db
|
void $
|
||||||
|
executeSometimes $
|
||||||
|
fsRemovableMon fs $
|
||||||
|
dbSysClient db
|
||||||
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
|
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
|
||||||
startDynWorkspaces fs = do
|
startDynWorkspaces fs = do
|
||||||
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
|
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
|
||||||
|
@ -142,8 +142,9 @@ runXMonad conf = do
|
||||||
launch conf dirs
|
launch conf dirs
|
||||||
|
|
||||||
startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
|
startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
|
||||||
startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
|
startDBusInterfaces db fs =
|
||||||
$ fsDBusExporters fs
|
mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
|
||||||
|
fsDBusExporters fs
|
||||||
|
|
||||||
getCreateDirectories :: IO Directories
|
getCreateDirectories :: IO Directories
|
||||||
getCreateDirectories = do
|
getCreateDirectories = do
|
||||||
|
@ -178,7 +179,8 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
||||||
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
|
||||||
|
|
||||||
features :: Maybe SysClient -> FeatureSet
|
features :: Maybe SysClient -> FeatureSet
|
||||||
features cl = FeatureSet
|
features cl =
|
||||||
|
FeatureSet
|
||||||
{ fsKeys = externalBindings
|
{ fsKeys = externalBindings
|
||||||
, fsDBusExporters = dbusExporters
|
, fsDBusExporters = dbusExporters
|
||||||
, fsPowerMon = runPowermon
|
, fsPowerMon = runPowermon
|
||||||
|
@ -196,7 +198,8 @@ startXmobar = do
|
||||||
io $ hSetBuffering (getStdin p) LineBuffering
|
io $ hSetBuffering (getStdin p) LineBuffering
|
||||||
return p
|
return p
|
||||||
where
|
where
|
||||||
start = startProcess
|
start =
|
||||||
|
startProcess
|
||||||
. setStdin createPipe
|
. setStdin createPipe
|
||||||
. setCreateGroup True
|
. setCreateGroup True
|
||||||
|
|
||||||
|
@ -228,18 +231,20 @@ printDeps :: FIO ()
|
||||||
printDeps = do
|
printDeps = do
|
||||||
db <- io connectDBus
|
db <- io connectDBus
|
||||||
(i, f, d) <- allFeatures db
|
(i, f, d) <- allFeatures db
|
||||||
io $ mapM_ (putStrLn . T.unpack)
|
io $
|
||||||
$ fmap showFulfillment
|
mapM_ (putStrLn . T.unpack) $
|
||||||
$ sort
|
fmap showFulfillment $
|
||||||
$ nub
|
sort $
|
||||||
$ concat
|
nub $
|
||||||
$ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
|
concat $
|
||||||
|
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
|
||||||
io $ disconnectDBus db
|
io $ disconnectDBus db
|
||||||
|
|
||||||
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
||||||
allFeatures db = do
|
allFeatures db = do
|
||||||
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
let bfs =
|
||||||
$ externalBindings ts db
|
concatMap (fmap kbMaybeAction . kgBindings) $
|
||||||
|
externalBindings ts db
|
||||||
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
|
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
|
||||||
let others = [runRemovableMon $ dbSysClient db, runPowermon]
|
let others = [runRemovableMon $ dbSysClient db, runPowermon]
|
||||||
return (dbus ++ others, Left runScreenLock : bfs, allDWs')
|
return (dbus ++ others, Left runScreenLock : bfs, allDWs')
|
||||||
|
@ -247,13 +252,16 @@ allFeatures db = do
|
||||||
ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
|
ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
|
||||||
|
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
usage = putStrLn $ intercalate "\n"
|
usage =
|
||||||
|
putStrLn $
|
||||||
|
intercalate
|
||||||
|
"\n"
|
||||||
[ "xmonad: run greatest window manager"
|
[ "xmonad: run greatest window manager"
|
||||||
, "xmonad --deps: print dependencies"
|
, "xmonad --deps: print dependencies"
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Concurrency configuration
|
-- Concurrency configuration
|
||||||
|
|
||||||
data ThreadState = ThreadState
|
data ThreadState = ThreadState
|
||||||
{ tsChildPIDs :: [Process () () ()]
|
{ tsChildPIDs :: [Process () () ()]
|
||||||
|
@ -294,15 +302,16 @@ killNoWait p = do
|
||||||
handleIO (\_ -> return ()) $ stopProcess p
|
handleIO (\_ -> return ()) $ stopProcess p
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Startuphook configuration
|
-- Startuphook configuration
|
||||||
|
|
||||||
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
|
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
|
||||||
myStartupHook :: X ()
|
myStartupHook :: X ()
|
||||||
myStartupHook = setDefaultCursor xC_left_ptr
|
myStartupHook =
|
||||||
|
setDefaultCursor xC_left_ptr
|
||||||
<+> startupHook def
|
<+> startupHook def
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Workspace configuration
|
-- Workspace configuration
|
||||||
|
|
||||||
myWorkspaces :: [WorkspaceId]
|
myWorkspaces :: [WorkspaceId]
|
||||||
myWorkspaces = map show [1 .. 10 :: Int]
|
myWorkspaces = map show [1 .. 10 :: Int]
|
||||||
|
@ -323,7 +332,8 @@ gimpDynamicWorkspace :: Sometimes DynWorkspace
|
||||||
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
|
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
|
||||||
where
|
where
|
||||||
tree = Only_ $ sysExe [Package Official "gimp"] exe
|
tree = Only_ $ sysExe [Package Official "gimp"] exe
|
||||||
dw = DynWorkspace
|
dw =
|
||||||
|
DynWorkspace
|
||||||
{ dwName = "Gimp"
|
{ dwName = "Gimp"
|
||||||
, dwTag = gimpTag
|
, dwTag = gimpTag
|
||||||
, dwClass = c
|
, dwClass = c
|
||||||
|
@ -337,21 +347,32 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
|
||||||
, dwCmd = Just $ spawnCmd exe []
|
, dwCmd = Just $ spawnCmd exe []
|
||||||
}
|
}
|
||||||
exe = "gimp-2.10"
|
exe = "gimp-2.10"
|
||||||
matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
|
matchGimpRole role =
|
||||||
<&&> className =? c
|
isPrefixOf role
|
||||||
|
<$> stringProperty "WM_WINDOW_ROLE"
|
||||||
|
<&&> className
|
||||||
|
=? c
|
||||||
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
|
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
|
||||||
|
|
||||||
-- TODO don't hardcode the VM name/title/shortcut
|
-- TODO don't hardcode the VM name/title/shortcut
|
||||||
vmDynamicWorkspace :: Sometimes DynWorkspace
|
vmDynamicWorkspace :: Sometimes DynWorkspace
|
||||||
vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
|
vmDynamicWorkspace =
|
||||||
|
Sometimes
|
||||||
|
"virtualbox workspace"
|
||||||
|
xpfVirtualBox
|
||||||
[Subfeature root "windows 8 VM"]
|
[Subfeature root "windows 8 VM"]
|
||||||
where
|
where
|
||||||
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
|
root =
|
||||||
$ IOTest_ name [] $ io $ vmExists vm
|
IORoot_ dw $
|
||||||
|
toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $
|
||||||
|
IOTest_ name [] $
|
||||||
|
io $
|
||||||
|
vmExists vm
|
||||||
name = T.unwords ["test if", vm, "exists"]
|
name = T.unwords ["test if", vm, "exists"]
|
||||||
c = "VirtualBoxVM"
|
c = "VirtualBoxVM"
|
||||||
vm = "win8raw"
|
vm = "win8raw"
|
||||||
dw = DynWorkspace
|
dw =
|
||||||
|
DynWorkspace
|
||||||
{ dwName = "Windows VirtualBox"
|
{ dwName = "Windows VirtualBox"
|
||||||
, dwTag = vmTag
|
, dwTag = vmTag
|
||||||
, dwClass = c
|
, dwClass = c
|
||||||
|
@ -361,11 +382,15 @@ vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
|
||||||
}
|
}
|
||||||
|
|
||||||
xsaneDynamicWorkspace :: Sometimes DynWorkspace
|
xsaneDynamicWorkspace :: Sometimes DynWorkspace
|
||||||
xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
|
xsaneDynamicWorkspace =
|
||||||
|
Sometimes
|
||||||
|
"scanner workspace"
|
||||||
|
xpfXSANE
|
||||||
[Subfeature (IORoot_ dw tree) "xsane"]
|
[Subfeature (IORoot_ dw tree) "xsane"]
|
||||||
where
|
where
|
||||||
tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
|
tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
|
||||||
dw = DynWorkspace
|
dw =
|
||||||
|
DynWorkspace
|
||||||
{ dwName = "XSane"
|
{ dwName = "XSane"
|
||||||
, dwTag = xsaneTag
|
, dwTag = xsaneTag
|
||||||
, dwClass = c
|
, dwClass = c
|
||||||
|
@ -376,11 +401,15 @@ xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE
|
||||||
c = "Xsane"
|
c = "Xsane"
|
||||||
|
|
||||||
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
|
f5vpnDynamicWorkspace :: Sometimes DynWorkspace
|
||||||
f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
|
f5vpnDynamicWorkspace =
|
||||||
|
Sometimes
|
||||||
|
"F5 VPN workspace"
|
||||||
|
xpfF5VPN
|
||||||
[Subfeature (IORoot_ dw tree) "f5vpn"]
|
[Subfeature (IORoot_ dw tree) "f5vpn"]
|
||||||
where
|
where
|
||||||
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
|
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
|
||||||
dw = DynWorkspace
|
dw =
|
||||||
|
DynWorkspace
|
||||||
{ dwName = "F5Vpn"
|
{ dwName = "F5Vpn"
|
||||||
, dwTag = f5Tag
|
, dwTag = f5Tag
|
||||||
, dwClass = c
|
, dwClass = c
|
||||||
|
@ -391,42 +420,48 @@ f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN
|
||||||
c = "F5 VPN"
|
c = "F5 VPN"
|
||||||
|
|
||||||
allDWs' :: [Sometimes DynWorkspace]
|
allDWs' :: [Sometimes DynWorkspace]
|
||||||
allDWs' = [xsaneDynamicWorkspace
|
allDWs' =
|
||||||
|
[ xsaneDynamicWorkspace
|
||||||
, vmDynamicWorkspace
|
, vmDynamicWorkspace
|
||||||
, gimpDynamicWorkspace
|
, gimpDynamicWorkspace
|
||||||
, f5vpnDynamicWorkspace
|
, f5vpnDynamicWorkspace
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Layout configuration
|
-- Layout configuration
|
||||||
|
|
||||||
-- NOTE this will have all available layouts, even those that may be for
|
-- NOTE this will have all available layouts, even those that may be for
|
||||||
-- features that failed. Trying to dynamically take out a layout seems to
|
-- features that failed. Trying to dynamically take out a layout seems to
|
||||||
-- make a new type :/
|
-- make a new type :/
|
||||||
myLayouts tt = onWorkspace vmTag vmLayout
|
myLayouts tt =
|
||||||
$ onWorkspace gimpTag gimpLayout
|
onWorkspace vmTag vmLayout $
|
||||||
$ mkToggle (single HIDE)
|
onWorkspace gimpTag gimpLayout $
|
||||||
$ tall ||| fulltab ||| full
|
mkToggle (single HIDE) $
|
||||||
|
tall ||| fulltab ||| full
|
||||||
where
|
where
|
||||||
addTopBar = noFrillsDeco shrinkText tt
|
addTopBar = noFrillsDeco shrinkText tt
|
||||||
tall = renamed [Replace "Tall"]
|
tall =
|
||||||
$ avoidStruts
|
renamed [Replace "Tall"] $
|
||||||
$ addTopBar
|
avoidStruts $
|
||||||
$ noBorders
|
addTopBar $
|
||||||
$ Tall 1 0.03 0.5
|
noBorders $
|
||||||
fulltab = renamed [Replace "Tabbed"]
|
Tall 1 0.03 0.5
|
||||||
$ avoidStruts
|
fulltab =
|
||||||
$ noBorders
|
renamed [Replace "Tabbed"] $
|
||||||
$ tabbedAlways shrinkText tt
|
avoidStruts $
|
||||||
full = renamed [Replace "Full"]
|
noBorders $
|
||||||
$ noBorders Full
|
tabbedAlways shrinkText tt
|
||||||
|
full =
|
||||||
|
renamed [Replace "Full"] $
|
||||||
|
noBorders Full
|
||||||
vmLayout = noBorders Full
|
vmLayout = noBorders Full
|
||||||
-- TODO use a tabbed layout for multiple master windows
|
-- TODO use a tabbed layout for multiple master windows
|
||||||
gimpLayout = renamed [Replace "Gimp Layout"]
|
gimpLayout =
|
||||||
$ avoidStruts
|
renamed [Replace "Gimp Layout"] $
|
||||||
$ noBorders
|
avoidStruts $
|
||||||
$ addTopBar
|
noBorders $
|
||||||
$ Tall 1 0.025 0.8
|
addTopBar $
|
||||||
|
Tall 1 0.025 0.8
|
||||||
|
|
||||||
-- | Make a new empty layout and add a message to show/hide it. This is useful
|
-- | Make a new empty layout and add a message to show/hide it. This is useful
|
||||||
-- for quickly showing conky.
|
-- for quickly showing conky.
|
||||||
|
@ -448,8 +483,7 @@ runHide :: X ()
|
||||||
runHide = sendMessage $ Toggle HIDE
|
runHide = sendMessage $ Toggle HIDE
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Loghook configuration
|
-- Loghook configuration
|
||||||
--
|
|
||||||
|
|
||||||
myLoghook :: Process Handle () () -> X ()
|
myLoghook :: Process Handle () () -> X ()
|
||||||
myLoghook h = do
|
myLoghook h = do
|
||||||
|
@ -467,7 +501,7 @@ myLoghook h = do
|
||||||
-- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why
|
-- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why
|
||||||
-- bother...(if that were necessary it would go in the startup hook)
|
-- bother...(if that were necessary it would go in the startup hook)
|
||||||
newtype DesktopViewports = DesktopViewports [Int]
|
newtype DesktopViewports = DesktopViewports [Int]
|
||||||
deriving Eq
|
deriving (Eq)
|
||||||
|
|
||||||
instance ExtensionClass DesktopViewports where
|
instance ExtensionClass DesktopViewports where
|
||||||
initialValue = DesktopViewports []
|
initialValue = DesktopViewports []
|
||||||
|
@ -480,8 +514,9 @@ logViewports = withWindowSet $ \s -> do
|
||||||
whenChanged (DesktopViewports desktopViewports) $
|
whenChanged (DesktopViewports desktopViewports) $
|
||||||
setDesktopViewports desktopViewports
|
setDesktopViewports desktopViewports
|
||||||
where
|
where
|
||||||
wsToViewports s w = let cur = W.current s in
|
wsToViewports s w =
|
||||||
if W.tag w == currentTag cur then currentPos cur else [0, 0]
|
let cur = W.current s
|
||||||
|
in if W.tag w == currentTag cur then currentPos cur else [0, 0]
|
||||||
currentTag = W.tag . W.workspace
|
currentTag = W.tag . W.workspace
|
||||||
currentPos = rectXY . screenRect . W.screenDetail
|
currentPos = rectXY . screenRect . W.screenDetail
|
||||||
rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y]
|
rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y]
|
||||||
|
@ -507,20 +542,22 @@ whenChanged v action = do
|
||||||
-- currently visible and the order reflects the physical location of each
|
-- currently visible and the order reflects the physical location of each
|
||||||
-- screen. The "<>" is the workspace that currently has focus. N is the number
|
-- screen. The "<>" is the workspace that currently has focus. N is the number
|
||||||
-- of windows on the current workspace.
|
-- of windows on the current workspace.
|
||||||
|
|
||||||
logXinerama :: Process Handle () () -> X ()
|
logXinerama :: Process Handle () () -> X ()
|
||||||
logXinerama p = withWindowSet $ \ws -> io
|
logXinerama p = withWindowSet $ \ws ->
|
||||||
$ hPutStrLn (getStdin p)
|
io $
|
||||||
$ T.unwords
|
hPutStrLn (getStdin p) $
|
||||||
$ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
|
T.unwords $
|
||||||
|
filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
|
||||||
where
|
where
|
||||||
onScreen ws = xmobarColor_ hilightFgColor hilightBgColor
|
onScreen ws =
|
||||||
$ (T.pack . pad . T.unpack)
|
xmobarColor_ hilightFgColor hilightBgColor $
|
||||||
$ T.unwords
|
(T.pack . pad . T.unpack) $
|
||||||
$ map (fmtTags ws . W.tag . W.workspace)
|
T.unwords $
|
||||||
$ sortBy compareXCoord
|
map (fmtTags ws . W.tag . W.workspace) $
|
||||||
$ W.current ws : W.visible ws
|
sortBy compareXCoord $
|
||||||
offScreen = xmobarColor_ XT.backdropFgColor ""
|
W.current ws : W.visible ws
|
||||||
|
offScreen =
|
||||||
|
xmobarColor_ XT.backdropFgColor ""
|
||||||
. T.unwords
|
. T.unwords
|
||||||
. fmap (T.pack . W.tag)
|
. fmap (T.pack . W.tag)
|
||||||
. filter (isJust . W.stack)
|
. filter (isJust . W.stack)
|
||||||
|
@ -528,7 +565,8 @@ logXinerama p = withWindowSet $ \ws -> io
|
||||||
. W.hidden
|
. W.hidden
|
||||||
sep = xmobarColor_ XT.backdropFgColor "" ":"
|
sep = xmobarColor_ XT.backdropFgColor "" ":"
|
||||||
layout = T.pack . description . W.layout . W.workspace . W.current
|
layout = T.pack . description . W.layout . W.workspace . W.current
|
||||||
nWindows = (\x -> T.concat ["(", x, ")"])
|
nWindows =
|
||||||
|
(\x -> T.concat ["(", x, ")"])
|
||||||
. T.pack
|
. T.pack
|
||||||
. show
|
. show
|
||||||
. length
|
. length
|
||||||
|
@ -538,46 +576,50 @@ logXinerama p = withWindowSet $ \ws -> io
|
||||||
. W.current
|
. W.current
|
||||||
hilightBgColor = "#A6D3FF"
|
hilightBgColor = "#A6D3FF"
|
||||||
hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
|
hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
|
||||||
fmtTags ws t = let t_ = T.pack t in
|
fmtTags ws t =
|
||||||
if t == W.currentTag ws
|
let t_ = T.pack t
|
||||||
|
in if t == W.currentTag ws
|
||||||
then xmobarColor_ XT.fgColor hilightBgColor t_
|
then xmobarColor_ XT.fgColor hilightBgColor t_
|
||||||
else t_
|
else t_
|
||||||
xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c)
|
xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c)
|
||||||
|
|
||||||
compareXCoord
|
compareXCoord
|
||||||
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
|
:: W.Screen i1 l1 a1 ScreenId ScreenDetail
|
||||||
-> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering
|
-> W.Screen i2 l2 a2 ScreenId ScreenDetail
|
||||||
|
-> Ordering
|
||||||
compareXCoord s0 s1 = compare (go s0) (go s1)
|
compareXCoord s0 s1 = compare (go s0) (go s1)
|
||||||
where
|
where
|
||||||
go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle
|
go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Managehook configuration
|
-- Managehook configuration
|
||||||
|
|
||||||
myManageHook :: [DynWorkspace] -> ManageHook
|
myManageHook :: [DynWorkspace] -> ManageHook
|
||||||
myManageHook dws = manageApps dws <+> manageHook def
|
myManageHook dws = manageApps dws <+> manageHook def
|
||||||
|
|
||||||
manageApps :: [DynWorkspace] -> ManageHook
|
manageApps :: [DynWorkspace] -> ManageHook
|
||||||
manageApps dws = composeOne $ concatMap dwHook dws ++
|
manageApps dws =
|
||||||
[ isDialog -?> doCenterFloat
|
composeOne $
|
||||||
-- the seafile applet
|
concatMap dwHook dws
|
||||||
, className =? "Seafile Client" -?> doFloat
|
++ [ isDialog -?> doCenterFloat
|
||||||
-- gnucash
|
, -- the seafile applet
|
||||||
, (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
|
className =? "Seafile Client" -?> doFloat
|
||||||
-- plots and graphics
|
, -- gnucash
|
||||||
, className =? "R_x11" -?> doFloat
|
(className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
|
||||||
|
, -- plots and graphics
|
||||||
|
className =? "R_x11" -?> doFloat
|
||||||
, className =? "Matplotlib" -?> doFloat
|
, className =? "Matplotlib" -?> doFloat
|
||||||
, className =? "mpv" -?> doFloat
|
, className =? "mpv" -?> doFloat
|
||||||
-- the floating windows created by the brave browser
|
, -- the floating windows created by the brave browser
|
||||||
, stringProperty "WM_NAME" =? "Brave" -?> doFloat
|
stringProperty "WM_NAME" =? "Brave" -?> doFloat
|
||||||
-- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
|
, -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
|
||||||
-- <&&> className =? "Brave-browser") -?> doFloat
|
-- <&&> className =? "Brave-browser") -?> doFloat
|
||||||
-- the dialog windows created by the zotero addon in Google Docs
|
-- the dialog windows created by the zotero addon in Google Docs
|
||||||
, (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
|
(className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
|
||||||
]
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Eventhook configuration
|
-- Eventhook configuration
|
||||||
|
|
||||||
myEventHook :: (String -> X ()) -> Event -> X All
|
myEventHook :: (String -> X ()) -> Event -> X All
|
||||||
myEventHook handler = xMsgEventHook handler <+> handleEventHook def
|
myEventHook handler = xMsgEventHook handler <+> handleEventHook def
|
||||||
|
@ -595,19 +637,26 @@ xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
|
||||||
xMsgEventHook _ _ = return (All True)
|
xMsgEventHook _ _ = return (All True)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Keymap configuration
|
-- Keymap configuration
|
||||||
|
|
||||||
myModMask :: KeyMask
|
myModMask :: KeyMask
|
||||||
myModMask = mod4Mask
|
myModMask = mod4Mask
|
||||||
|
|
||||||
addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ())
|
addKeymap
|
||||||
-> [KeyGroup (X ())] -> XConfig l -> XConfig l
|
:: [DynWorkspace]
|
||||||
addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys)
|
-> ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
|
-> [KeyGroup (X ())]
|
||||||
|
-> XConfig l
|
||||||
|
-> XConfig l
|
||||||
|
addKeymap dws showKeys external =
|
||||||
|
addDescrKeys'
|
||||||
|
((myModMask, xK_F1), showKeys)
|
||||||
(\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external)
|
(\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external)
|
||||||
|
|
||||||
internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
|
internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
|
||||||
internalBindings dws c =
|
internalBindings dws c =
|
||||||
[ KeyGroup "Window Layouts"
|
[ KeyGroup
|
||||||
|
"Window Layouts"
|
||||||
[ KeyBinding "M-j" "focus down" $ windows W.focusDown
|
[ KeyBinding "M-j" "focus down" $ windows W.focusDown
|
||||||
, KeyBinding "M-k" "focus up" $ windows W.focusUp
|
, KeyBinding "M-k" "focus up" $ windows W.focusUp
|
||||||
, KeyBinding "M-m" "focus master" $ windows W.focusMaster
|
, KeyBinding "M-m" "focus master" $ windows W.focusMaster
|
||||||
|
@ -624,32 +673,36 @@ internalBindings dws c =
|
||||||
, KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1)
|
, KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1)
|
||||||
, KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1
|
, KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1
|
||||||
]
|
]
|
||||||
|
, KeyGroup
|
||||||
, KeyGroup "Workspaces"
|
"Workspaces"
|
||||||
-- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get
|
-- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get
|
||||||
-- valid keysyms)
|
-- valid keysyms)
|
||||||
([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces
|
( [ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces, (mods, msg, f) <-
|
||||||
, (mods, msg, f) <-
|
|
||||||
[ ("M-", "switch to workspace ", windows . W.view)
|
[ ("M-", "switch to workspace ", windows . W.view)
|
||||||
, ("M-S-", "move client to workspace ", windows . W.shift)
|
, ("M-S-", "move client to workspace ", windows . W.shift)
|
||||||
, ("M-C-", "follow client to workspace ", \n' -> do
|
,
|
||||||
|
( "M-C-"
|
||||||
|
, "follow client to workspace "
|
||||||
|
, \n' -> do
|
||||||
windows $ W.shift n'
|
windows $ W.shift n'
|
||||||
windows $ W.view n')
|
windows $ W.view n'
|
||||||
|
)
|
||||||
]
|
]
|
||||||
] ++
|
]
|
||||||
[ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
|
++ [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
|
||||||
, KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS)
|
, KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS)
|
||||||
])
|
]
|
||||||
|
)
|
||||||
, KeyGroup "Dynamic Workspaces"
|
, KeyGroup
|
||||||
|
"Dynamic Workspaces"
|
||||||
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
|
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
|
||||||
| DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws,
|
| DynWorkspace {dwTag = t, dwKey = k, dwCmd = a, dwName = n} <- dws
|
||||||
let cmd = case a of
|
, let cmd = case a of
|
||||||
Just a' -> spawnOrSwitch t a'
|
Just a' -> spawnOrSwitch t a'
|
||||||
Nothing -> windows $ W.view t
|
Nothing -> windows $ W.view t
|
||||||
]
|
]
|
||||||
|
, KeyGroup
|
||||||
, KeyGroup "Screens"
|
"Screens"
|
||||||
[ KeyBinding "M-l" "move up screen" nextScr
|
[ KeyBinding "M-l" "move up screen" nextScr
|
||||||
, KeyBinding "M-h" "move down screen" prevScr
|
, KeyBinding "M-h" "move down screen" prevScr
|
||||||
, KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift
|
, KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift
|
||||||
|
@ -668,8 +721,9 @@ internalBindings dws c =
|
||||||
|
|
||||||
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
|
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
|
||||||
mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} =
|
mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} =
|
||||||
(subtitle h:) $ mkNamedKeymap c
|
(subtitle h :) $
|
||||||
$ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
|
mkNamedKeymap c $
|
||||||
|
(\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
|
||||||
<$> b
|
<$> b
|
||||||
|
|
||||||
data KeyBinding a = KeyBinding
|
data KeyBinding a = KeyBinding
|
||||||
|
@ -697,14 +751,17 @@ filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
|
||||||
filterExternal = fmap go
|
filterExternal = fmap go
|
||||||
where
|
where
|
||||||
go k@KeyGroup {kgBindings = bs} =
|
go k@KeyGroup {kgBindings = bs} =
|
||||||
k { kgBindings = [ kb { kbMaybeAction = x }
|
k
|
||||||
|
{ kgBindings =
|
||||||
|
[ kb {kbMaybeAction = x}
|
||||||
| kb@KeyBinding {kbMaybeAction = Just x} <- bs
|
| kb@KeyBinding {kbMaybeAction = Just x} <- bs
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
|
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
|
||||||
externalBindings ts db =
|
externalBindings ts db =
|
||||||
[ KeyGroup "Launchers"
|
[ KeyGroup
|
||||||
|
"Launchers"
|
||||||
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
||||||
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
|
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
|
||||||
, KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
|
, KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
|
||||||
|
@ -720,8 +777,8 @@ externalBindings ts db =
|
||||||
, KeyBinding "M-C-q" "launch calc" $ Left runCalc
|
, KeyBinding "M-C-q" "launch calc" $ Left runCalc
|
||||||
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
|
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
|
||||||
]
|
]
|
||||||
|
, KeyGroup
|
||||||
, KeyGroup "Actions"
|
"Actions"
|
||||||
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
|
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
|
||||||
, KeyBinding "M-r" "run program" $ Left runCmdMenu
|
, KeyBinding "M-r" "run program" $ Left runCmdMenu
|
||||||
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
|
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
|
||||||
|
@ -731,8 +788,8 @@ externalBindings ts db =
|
||||||
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
|
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
|
||||||
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
|
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
|
||||||
]
|
]
|
||||||
|
, KeyGroup
|
||||||
, KeyGroup "Multimedia"
|
"Multimedia"
|
||||||
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
|
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
|
||||||
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
|
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
|
||||||
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
|
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
|
||||||
|
@ -741,15 +798,15 @@ externalBindings ts db =
|
||||||
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
|
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
|
||||||
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
|
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
|
||||||
]
|
]
|
||||||
|
, KeyGroup
|
||||||
, KeyGroup "Dunst"
|
"Dunst"
|
||||||
[ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
|
[ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
|
||||||
, KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
|
, KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
|
||||||
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
|
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
|
||||||
, KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
|
, KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
|
||||||
]
|
]
|
||||||
|
, KeyGroup
|
||||||
, KeyGroup "System"
|
"System"
|
||||||
[ KeyBinding "M-." "backlight up" $ ib bctlInc
|
[ KeyBinding "M-." "backlight up" $ ib bctlInc
|
||||||
, KeyBinding "M-," "backlight down" $ ib bctlDec
|
, KeyBinding "M-," "backlight down" $ ib bctlDec
|
||||||
, KeyBinding "M-M1-," "backlight min" $ ib bctlMin
|
, KeyBinding "M-M1-," "backlight min" $ ib bctlMin
|
||||||
|
@ -761,8 +818,8 @@ externalBindings ts db =
|
||||||
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
|
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
|
||||||
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
|
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
|
||||||
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
||||||
-- M-<F1> reserved for showing the keymap
|
, -- M-<F1> reserved for showing the keymap
|
||||||
, KeyBinding "M-<F2>" "restart xmonad" restartf
|
KeyBinding "M-<F2>" "restart xmonad" restartf
|
||||||
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
||||||
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
||||||
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
|
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
|
||||||
|
|
|
@ -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,5 +1,5 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Common internal DBus functions
|
-- Common internal DBus functions
|
||||||
|
|
||||||
module Data.Internal.DBus
|
module Data.Internal.DBus
|
||||||
( SafeClient (..)
|
( SafeClient (..)
|
||||||
|
@ -25,22 +25,20 @@ module Data.Internal.DBus
|
||||||
, addInterfaceRemovedListener
|
, addInterfaceRemovedListener
|
||||||
, fromSingletonVariant
|
, fromSingletonVariant
|
||||||
, bodyToMaybe
|
, bodyToMaybe
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
|
import DBus.Client
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import DBus
|
|
||||||
import DBus.Client
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Type-safe client
|
-- Type-safe client
|
||||||
|
|
||||||
class SafeClient c where
|
class SafeClient c where
|
||||||
toClient :: c -> Client
|
toClient :: c -> Client
|
||||||
|
@ -86,24 +84,33 @@ getDBusClient' sys = do
|
||||||
Right c -> return $ Just c
|
Right c -> return $ Just c
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Methods
|
-- Methods
|
||||||
|
|
||||||
type MethodBody = Either T.Text [Variant]
|
type MethodBody = Either T.Text [Variant]
|
||||||
|
|
||||||
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
||||||
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
callMethod' cl =
|
||||||
|
fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||||
. call (toClient cl)
|
. call (toClient cl)
|
||||||
|
|
||||||
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
|
callMethod
|
||||||
-> MemberName -> IO MethodBody
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> ObjectPath
|
||||||
|
-> InterfaceName
|
||||||
|
-> MemberName
|
||||||
|
-> IO MethodBody
|
||||||
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
|
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
|
||||||
|
|
||||||
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
||||||
methodCallBus b p i m = (methodCall p i m)
|
methodCallBus b p i m =
|
||||||
{ methodCallDestination = Just b }
|
(methodCall p i m)
|
||||||
|
{ methodCallDestination = Just b
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Bus names
|
-- Bus names
|
||||||
|
|
||||||
dbusInterface :: InterfaceName
|
dbusInterface :: InterfaceName
|
||||||
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
||||||
|
@ -111,12 +118,14 @@ dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
||||||
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
|
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
|
||||||
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
|
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
|
||||||
where
|
where
|
||||||
mc = (methodCallBus dbusName dbusPath dbusInterface mem)
|
mc =
|
||||||
{ methodCallBody = [toVariant name] }
|
(methodCallBus dbusName dbusPath dbusInterface mem)
|
||||||
|
{ methodCallBody = [toVariant name]
|
||||||
|
}
|
||||||
mem = memberName_ "GetNameOwner"
|
mem = memberName_ "GetNameOwner"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Variant parsing
|
-- Variant parsing
|
||||||
|
|
||||||
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
||||||
fromSingletonVariant = fromVariant <=< listToMaybe
|
fromSingletonVariant = fromVariant <=< listToMaybe
|
||||||
|
@ -125,30 +134,45 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
|
||||||
bodyToMaybe = either (const Nothing) fromSingletonVariant
|
bodyToMaybe = either (const Nothing) fromSingletonVariant
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Signals
|
-- Signals
|
||||||
|
|
||||||
type SignalCallback = [Variant] -> IO ()
|
type SignalCallback = [Variant] -> IO ()
|
||||||
|
|
||||||
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
|
addMatchCallback
|
||||||
|
:: SafeClient c
|
||||||
|
=> MatchRule
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
-> IO SignalHandler
|
-> IO SignalHandler
|
||||||
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
|
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
|
||||||
|
|
||||||
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
|
matchSignal
|
||||||
-> Maybe MemberName -> MatchRule
|
:: Maybe BusName
|
||||||
matchSignal b p i m = matchAny
|
-> Maybe ObjectPath
|
||||||
|
-> Maybe InterfaceName
|
||||||
|
-> Maybe MemberName
|
||||||
|
-> MatchRule
|
||||||
|
matchSignal b p i m =
|
||||||
|
matchAny
|
||||||
{ matchPath = p
|
{ matchPath = p
|
||||||
, matchSender = b
|
, matchSender = b
|
||||||
, matchInterface = i
|
, matchInterface = i
|
||||||
, matchMember = m
|
, matchMember = m
|
||||||
}
|
}
|
||||||
|
|
||||||
matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
|
matchSignalFull
|
||||||
-> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> Maybe ObjectPath
|
||||||
|
-> Maybe InterfaceName
|
||||||
|
-> Maybe MemberName
|
||||||
|
-> IO (Maybe MatchRule)
|
||||||
matchSignalFull client b p i m =
|
matchSignalFull client b p i m =
|
||||||
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
|
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Properties
|
-- Properties
|
||||||
|
|
||||||
propertyInterface :: InterfaceName
|
propertyInterface :: InterfaceName
|
||||||
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
||||||
|
@ -156,16 +180,28 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
||||||
propertySignal :: MemberName
|
propertySignal :: MemberName
|
||||||
propertySignal = memberName_ "PropertiesChanged"
|
propertySignal = memberName_ "PropertiesChanged"
|
||||||
|
|
||||||
callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
|
callPropertyGet
|
||||||
-> MemberName -> c -> IO [Variant]
|
:: SafeClient c
|
||||||
callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
|
=> BusName
|
||||||
$ getProperty (toClient cl) $ methodCallBus bus path iface property
|
-> ObjectPath
|
||||||
|
-> InterfaceName
|
||||||
|
-> MemberName
|
||||||
|
-> c
|
||||||
|
-> IO [Variant]
|
||||||
|
callPropertyGet bus path iface property cl =
|
||||||
|
fmap (either (const []) (: [])) $
|
||||||
|
getProperty (toClient cl) $
|
||||||
|
methodCallBus bus path iface property
|
||||||
|
|
||||||
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
||||||
matchProperty b p =
|
matchProperty b p =
|
||||||
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
||||||
|
|
||||||
matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
|
matchPropertyFull
|
||||||
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> Maybe ObjectPath
|
||||||
-> IO (Maybe MatchRule)
|
-> IO (Maybe MatchRule)
|
||||||
matchPropertyFull cl b p =
|
matchPropertyFull cl b p =
|
||||||
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
|
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
|
||||||
|
@ -177,14 +213,19 @@ withSignalMatch f (Match x) = f (Just x)
|
||||||
withSignalMatch f Failure = f Nothing
|
withSignalMatch f Failure = f Nothing
|
||||||
withSignalMatch _ NoMatch = return ()
|
withSignalMatch _ NoMatch = return ()
|
||||||
|
|
||||||
matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant]
|
matchPropertyChanged
|
||||||
|
:: IsVariant a
|
||||||
|
=> InterfaceName
|
||||||
|
-> T.Text
|
||||||
|
-> [Variant]
|
||||||
-> SignalMatch a
|
-> SignalMatch a
|
||||||
matchPropertyChanged iface property [i, body, _] =
|
matchPropertyChanged iface property [i, body, _] =
|
||||||
let i' = (fromVariant i :: Maybe T.Text)
|
let i' = (fromVariant i :: Maybe T.Text)
|
||||||
b = toMap body in
|
b = toMap body
|
||||||
case (i', b) of
|
in case (i', b) of
|
||||||
(Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then
|
(Just i'', Just b') ->
|
||||||
maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
if i'' == T.pack (formatInterfaceName iface)
|
||||||
|
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
||||||
else NoMatch
|
else NoMatch
|
||||||
_ -> Failure
|
_ -> Failure
|
||||||
where
|
where
|
||||||
|
@ -192,7 +233,7 @@ matchPropertyChanged iface property [i, body, _] =
|
||||||
matchPropertyChanged _ _ _ = Failure
|
matchPropertyChanged _ _ _ = Failure
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Object Manager
|
-- Object Manager
|
||||||
|
|
||||||
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
||||||
|
|
||||||
|
@ -208,24 +249,44 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
|
||||||
omInterfacesRemoved :: MemberName
|
omInterfacesRemoved :: MemberName
|
||||||
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
||||||
|
|
||||||
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
|
callGetManagedObjects
|
||||||
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> ObjectPath
|
||||||
-> IO ObjectTree
|
-> IO ObjectTree
|
||||||
callGetManagedObjects cl bus path =
|
callGetManagedObjects cl bus path =
|
||||||
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
||||||
<$> callMethod cl bus path omInterface getManagedObjects
|
<$> callMethod cl bus path omInterface getManagedObjects
|
||||||
|
|
||||||
addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
|
addInterfaceChangedListener
|
||||||
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
|
:: SafeClient c
|
||||||
|
=> BusName
|
||||||
|
-> MemberName
|
||||||
|
-> ObjectPath
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
|
-> IO (Maybe SignalHandler)
|
||||||
addInterfaceChangedListener bus prop path sc cl = do
|
addInterfaceChangedListener bus prop path sc cl = do
|
||||||
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
|
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
|
||||||
forM rule $ \r -> addMatchCallback r sc cl
|
forM rule $ \r -> addMatchCallback r sc cl
|
||||||
|
|
||||||
addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
|
addInterfaceAddedListener
|
||||||
-> SignalCallback -> c -> IO (Maybe SignalHandler)
|
:: SafeClient c
|
||||||
|
=> BusName
|
||||||
|
-> ObjectPath
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
|
-> IO (Maybe SignalHandler)
|
||||||
addInterfaceAddedListener bus =
|
addInterfaceAddedListener bus =
|
||||||
addInterfaceChangedListener bus omInterfacesAdded
|
addInterfaceChangedListener bus omInterfacesAdded
|
||||||
|
|
||||||
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
|
addInterfaceRemovedListener
|
||||||
-> SignalCallback -> c -> IO (Maybe SignalHandler)
|
:: SafeClient c
|
||||||
|
=> BusName
|
||||||
|
-> ObjectPath
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
|
-> IO (Maybe SignalHandler)
|
||||||
addInterfaceRemovedListener bus =
|
addInterfaceRemovedListener bus =
|
||||||
addInterfaceChangedListener bus omInterfacesRemoved
|
addInterfaceChangedListener bus omInterfacesRemoved
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for handling dependencies
|
-- Functions for handling dependencies
|
||||||
|
|
||||||
module Data.Internal.Dependency
|
module Data.Internal.Dependency
|
||||||
-- feature types
|
-- feature types
|
||||||
|
@ -25,12 +25,10 @@ module Data.Internal.Dependency
|
||||||
, Subfeature (..)
|
, Subfeature (..)
|
||||||
, SubfeatureRoot
|
, SubfeatureRoot
|
||||||
, Msg (..)
|
, Msg (..)
|
||||||
|
|
||||||
-- configuration
|
-- configuration
|
||||||
, XParams (..)
|
, XParams (..)
|
||||||
, XPFeatures (..)
|
, XPFeatures (..)
|
||||||
, XPQuery
|
, XPQuery
|
||||||
|
|
||||||
-- dependency tree types
|
-- dependency tree types
|
||||||
, Root (..)
|
, Root (..)
|
||||||
, Tree (..)
|
, Tree (..)
|
||||||
|
@ -49,13 +47,11 @@ module Data.Internal.Dependency
|
||||||
, Result
|
, Result
|
||||||
, Fulfillment (..)
|
, Fulfillment (..)
|
||||||
, ArchPkg (..)
|
, ArchPkg (..)
|
||||||
|
|
||||||
-- dumping
|
-- dumping
|
||||||
, dumpFeature
|
, dumpFeature
|
||||||
, dumpAlways
|
, dumpAlways
|
||||||
, dumpSometimes
|
, dumpSometimes
|
||||||
, showFulfillment
|
, showFulfillment
|
||||||
|
|
||||||
-- testing
|
-- testing
|
||||||
, FIO
|
, FIO
|
||||||
, withCache
|
, withCache
|
||||||
|
@ -72,11 +68,9 @@ module Data.Internal.Dependency
|
||||||
, readEthernet
|
, readEthernet
|
||||||
, readWireless
|
, readWireless
|
||||||
, socketExists
|
, socketExists
|
||||||
|
|
||||||
-- lifting
|
-- lifting
|
||||||
, ioSometimes
|
, ioSometimes
|
||||||
, ioAlways
|
, ioAlways
|
||||||
|
|
||||||
-- feature construction
|
-- feature construction
|
||||||
, always1
|
, always1
|
||||||
, sometimes1
|
, sometimes1
|
||||||
|
@ -86,7 +80,6 @@ module Data.Internal.Dependency
|
||||||
, sometimesExe
|
, sometimesExe
|
||||||
, sometimesExeArgs
|
, sometimesExeArgs
|
||||||
, sometimesEndpoint
|
, sometimesEndpoint
|
||||||
|
|
||||||
-- dependency construction
|
-- dependency construction
|
||||||
, sysExe
|
, sysExe
|
||||||
, localExe
|
, localExe
|
||||||
|
@ -101,15 +94,16 @@ module Data.Internal.Dependency
|
||||||
, voidResult
|
, voidResult
|
||||||
, voidRead
|
, voidRead
|
||||||
, process
|
, process
|
||||||
|
|
||||||
-- misc
|
-- misc
|
||||||
, shellTest
|
, shellTest
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
import DBus hiding (typeOf)
|
||||||
|
import qualified DBus.Introspection as I
|
||||||
import Data.Aeson hiding (Error, Result)
|
import Data.Aeson hiding (Error, Result)
|
||||||
import Data.Aeson.Key
|
import Data.Aeson.Key
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
|
@ -118,30 +112,23 @@ import Data.Internal.DBus
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Yaml
|
import Data.Yaml
|
||||||
|
|
||||||
import GHC.IO.Exception (ioe_description)
|
import GHC.IO.Exception (ioe_description)
|
||||||
|
|
||||||
import DBus hiding (typeOf)
|
|
||||||
import qualified DBus.Introspection as I
|
|
||||||
|
|
||||||
import RIO hiding (bracket, fromString)
|
import RIO hiding (bracket, fromString)
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import RIO.Process hiding (findExecutable)
|
import RIO.Process hiding (findExecutable)
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import System.Process.Typed (nullStream)
|
import System.Process.Typed (nullStream)
|
||||||
|
|
||||||
import XMonad.Core (X, io)
|
import XMonad.Core (X, io)
|
||||||
import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
import XMonad.Internal.Shell hiding (proc, runProcess)
|
import XMonad.Internal.Shell hiding (proc, runProcess)
|
||||||
import XMonad.Internal.Theme
|
import XMonad.Internal.Theme
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature Evaluation
|
-- Feature Evaluation
|
||||||
--
|
--
|
||||||
-- Here we attempt to build and return the monadic actions encoded by each
|
-- Here we attempt to build and return the monadic actions encoded by each
|
||||||
-- feature.
|
-- feature.
|
||||||
|
@ -195,7 +182,8 @@ logMsg (FMsg fn n (Msg ll m)) = do
|
||||||
llFun LevelWarn = ("WARN", logWarn)
|
llFun LevelWarn = ("WARN", logWarn)
|
||||||
llFun _ = ("DEBUG", logDebug)
|
llFun _ = ("DEBUG", logDebug)
|
||||||
(s, f) = llFun ll
|
(s, f) = llFun ll
|
||||||
fmt p l = [ bracket p
|
fmt p l =
|
||||||
|
[ bracket p
|
||||||
, bracket l
|
, bracket l
|
||||||
, bracket fn
|
, bracket fn
|
||||||
]
|
]
|
||||||
|
@ -203,7 +191,7 @@ logMsg (FMsg fn n (Msg ll m)) = do
|
||||||
++ [m]
|
++ [m]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Package status
|
-- Package status
|
||||||
|
|
||||||
showFulfillment :: Fulfillment -> T.Text
|
showFulfillment :: Fulfillment -> T.Text
|
||||||
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
|
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
|
||||||
|
@ -220,7 +208,7 @@ dumpSometimes :: Sometimes a -> [Fulfillment]
|
||||||
dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs
|
dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Wrapper types
|
-- Wrapper types
|
||||||
|
|
||||||
type AlwaysX = Always (X ())
|
type AlwaysX = Always (X ())
|
||||||
|
|
||||||
|
@ -233,7 +221,7 @@ type SometimesIO = Sometimes (FIO ())
|
||||||
type Feature a = Either (Sometimes a) (Always a)
|
type Feature a = Either (Sometimes a) (Always a)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature declaration
|
-- Feature declaration
|
||||||
|
|
||||||
-- | Feature that is guaranteed to work
|
-- | Feature that is guaranteed to work
|
||||||
-- This is composed of sub-features that are tested in order, and if all fail
|
-- This is composed of sub-features that are tested in order, and if all fail
|
||||||
|
@ -241,17 +229,20 @@ type Feature a = Either (Sometimes a) (Always a)
|
||||||
data Always a = Always T.Text (Always_ a)
|
data Always a = Always T.Text (Always_ a)
|
||||||
|
|
||||||
-- | Feature that is guaranteed to work (inner data)
|
-- | Feature that is guaranteed to work (inner data)
|
||||||
data Always_ a = Option (SubfeatureRoot a) (Always_ a)
|
data Always_ a
|
||||||
|
= Option (SubfeatureRoot a) (Always_ a)
|
||||||
| Always_ (FallbackRoot a)
|
| Always_ (FallbackRoot a)
|
||||||
|
|
||||||
-- | Root of a fallback action for an always
|
-- | Root of a fallback action for an always
|
||||||
-- This may either be a lone action or a function that depends on the results
|
-- This may either be a lone action or a function that depends on the results
|
||||||
-- from other Always features.
|
-- from other Always features.
|
||||||
data FallbackRoot a = FallbackAlone a
|
data FallbackRoot a
|
||||||
|
= FallbackAlone a
|
||||||
| forall p. FallbackTree (p -> a) (FallbackStack p)
|
| forall p. FallbackTree (p -> a) (FallbackStack p)
|
||||||
|
|
||||||
-- | Always features that are used as a payload for a fallback action
|
-- | Always features that are used as a payload for a fallback action
|
||||||
data FallbackStack p = FallbackBottom (Always p)
|
data FallbackStack p
|
||||||
|
= FallbackBottom (Always p)
|
||||||
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
|
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
|
||||||
|
|
||||||
-- | Feature that might not be present
|
-- | Feature that might not be present
|
||||||
|
@ -276,14 +267,15 @@ type SubfeatureRoot a = Subfeature (Root a)
|
||||||
-- | An action and its dependencies
|
-- | An action and its dependencies
|
||||||
-- May be a plain old monad or be DBus-dependent, in which case a client is
|
-- May be a plain old monad or be DBus-dependent, in which case a client is
|
||||||
-- needed
|
-- needed
|
||||||
data Root a = forall p. IORoot (p -> a) (IOTree p)
|
data Root a
|
||||||
|
= forall p. IORoot (p -> a) (IOTree p)
|
||||||
| IORoot_ a IOTree_
|
| IORoot_ a IOTree_
|
||||||
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
|
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
|
||||||
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
|
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
|
||||||
|
|
||||||
-- | The dependency tree with rule to merge results when needed
|
-- | The dependency tree with rule to merge results when needed
|
||||||
data Tree d d_ p =
|
data Tree d d_ p
|
||||||
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
|
= forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
|
||||||
| And1 (Tree d d_ p) (Tree_ d_)
|
| And1 (Tree d d_ p) (Tree_ d_)
|
||||||
| And2 (Tree_ d_) (Tree d d_ p)
|
| And2 (Tree_ d_) (Tree d d_ p)
|
||||||
| Or (Tree d d_ p) (Tree d d_ p)
|
| Or (Tree d d_ p) (Tree d d_ p)
|
||||||
|
@ -294,36 +286,41 @@ data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
|
||||||
|
|
||||||
-- | Shorthand tree types for lazy typers
|
-- | Shorthand tree types for lazy typers
|
||||||
type IOTree p = Tree IODependency IODependency_ p
|
type IOTree p = Tree IODependency IODependency_ p
|
||||||
|
|
||||||
type DBusTree c p = Tree IODependency (DBusDependency_ c) p
|
type DBusTree c p = Tree IODependency (DBusDependency_ c) p
|
||||||
|
|
||||||
type IOTree_ = Tree_ IODependency_
|
type IOTree_ = Tree_ IODependency_
|
||||||
|
|
||||||
type DBusTree_ c = Tree_ (DBusDependency_ c)
|
type DBusTree_ c = Tree_ (DBusDependency_ c)
|
||||||
|
|
||||||
-- | A dependency that only requires IO to evaluate (with payload)
|
-- | A dependency that only requires IO to evaluate (with payload)
|
||||||
data IODependency p =
|
data IODependency p
|
||||||
-- an IO action that yields a payload
|
= -- an IO action that yields a payload
|
||||||
IORead T.Text [Fulfillment] (FIO (Result p))
|
IORead T.Text [Fulfillment] (FIO (Result p))
|
||||||
-- always yields a payload
|
| -- always yields a payload
|
||||||
| IOConst p
|
IOConst p
|
||||||
-- an always that yields a payload
|
| -- an always that yields a payload
|
||||||
| forall a. IOAlways (Always a) (a -> p)
|
forall a. IOAlways (Always a) (a -> p)
|
||||||
-- a sometimes that yields a payload
|
| -- a sometimes that yields a payload
|
||||||
| forall a. IOSometimes (Sometimes a) (a -> p)
|
forall a. IOSometimes (Sometimes a) (a -> p)
|
||||||
|
|
||||||
-- | A dependency pertaining to the DBus
|
-- | A dependency pertaining to the DBus
|
||||||
data DBusDependency_ c = Bus [Fulfillment] BusName
|
data DBusDependency_ c
|
||||||
|
= Bus [Fulfillment] BusName
|
||||||
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
|
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
|
||||||
| DBusIO IODependency_
|
| DBusIO IODependency_
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
-- | A dependency that only requires IO to evaluate (no payload)
|
-- | A dependency that only requires IO to evaluate (no payload)
|
||||||
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
|
data IODependency_
|
||||||
|
= IOSystem_ [Fulfillment] SystemDependency
|
||||||
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
|
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
|
||||||
| forall a. IOSometimes_ (Sometimes a)
|
| forall a. IOSometimes_ (Sometimes a)
|
||||||
|
|
||||||
-- | A system component to an IODependency
|
-- | A system component to an IODependency
|
||||||
-- This name is dumb, but most constructors should be obvious
|
-- This name is dumb, but most constructors should be obvious
|
||||||
data SystemDependency =
|
data SystemDependency
|
||||||
Executable Bool FilePath
|
= Executable Bool FilePath
|
||||||
| AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
| Systemd UnitType T.Text
|
| Systemd UnitType T.Text
|
||||||
| Process T.Text
|
| Process T.Text
|
||||||
|
@ -333,7 +330,8 @@ data SystemDependency =
|
||||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
|
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
|
||||||
|
|
||||||
-- | Wrapper type to describe and endpoint
|
-- | Wrapper type to describe and endpoint
|
||||||
data DBusMember = Method_ MemberName
|
data DBusMember
|
||||||
|
= Method_ MemberName
|
||||||
| Signal_ MemberName
|
| Signal_ MemberName
|
||||||
| Property_ T.Text
|
| Property_ T.Text
|
||||||
deriving (Eq, Show, Generic)
|
deriving (Eq, Show, Generic)
|
||||||
|
@ -345,7 +343,7 @@ data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
|
||||||
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
|
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Tested dependency tree
|
-- Tested dependency tree
|
||||||
--
|
--
|
||||||
-- The main reason I need this is so I have a "result" I can convert to JSON
|
-- The main reason I need this is so I have a "result" I can convert to JSON
|
||||||
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
||||||
|
@ -357,7 +355,8 @@ data Msg = Msg LogLevel T.Text
|
||||||
data FMsg = FMsg T.Text (Maybe T.Text) Msg
|
data FMsg = FMsg T.Text (Maybe T.Text) Msg
|
||||||
|
|
||||||
-- | Tested Always feature
|
-- | Tested Always feature
|
||||||
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
|
data PostAlways a
|
||||||
|
= Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
|
||||||
| Fallback a [SubfeatureFail]
|
| Fallback a [SubfeatureFail]
|
||||||
|
|
||||||
-- | Tested Sometimes feature
|
-- | Tested Sometimes feature
|
||||||
|
@ -382,7 +381,7 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
|
||||||
data PostFail = PostFail [Msg] | PostMissing Msg
|
data PostFail = PostFail [Msg] | PostMissing Msg
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Configuration
|
-- Configuration
|
||||||
|
|
||||||
type FIO a = RIO DepStage a
|
type FIO a = RIO DepStage a
|
||||||
|
|
||||||
|
@ -434,34 +433,48 @@ data XPFeatures = XPFeatures
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON XPFeatures where
|
instance FromJSON XPFeatures where
|
||||||
parseJSON = withObject "features" $ \o -> XPFeatures
|
parseJSON = withObject "features" $ \o ->
|
||||||
<$> o .:+ "optimus"
|
XPFeatures
|
||||||
<*> o .:+ "virtualbox"
|
<$> o
|
||||||
<*> o .:+ "xsane"
|
.:+ "optimus"
|
||||||
<*> o .:+ "ethernet"
|
<*> o
|
||||||
<*> o .:+ "wireless"
|
.:+ "virtualbox"
|
||||||
<*> o .:+ "vpn"
|
<*> o
|
||||||
<*> o .:+ "bluetooth"
|
.:+ "xsane"
|
||||||
<*> o .:+ "intel_backlight"
|
<*> o
|
||||||
<*> o .:+ "clevo_backlight"
|
.:+ "ethernet"
|
||||||
<*> o .:+ "battery"
|
<*> o
|
||||||
<*> o .:+ "f5vpn"
|
.:+ "wireless"
|
||||||
|
<*> o
|
||||||
|
.:+ "vpn"
|
||||||
|
<*> o
|
||||||
|
.:+ "bluetooth"
|
||||||
|
<*> o
|
||||||
|
.:+ "intel_backlight"
|
||||||
|
<*> o
|
||||||
|
.:+ "clevo_backlight"
|
||||||
|
<*> o
|
||||||
|
.:+ "battery"
|
||||||
|
<*> o
|
||||||
|
.:+ "f5vpn"
|
||||||
|
|
||||||
defParams :: XParams
|
defParams :: XParams
|
||||||
defParams = XParams
|
defParams =
|
||||||
|
XParams
|
||||||
{ xpLogLevel = LevelError
|
{ xpLogLevel = LevelError
|
||||||
, xpFeatures = defXPFeatures
|
, xpFeatures = defXPFeatures
|
||||||
}
|
}
|
||||||
|
|
||||||
defXPFeatures :: XPFeatures
|
defXPFeatures :: XPFeatures
|
||||||
defXPFeatures = XPFeatures
|
defXPFeatures =
|
||||||
|
XPFeatures
|
||||||
{ xpfOptimus = False
|
{ xpfOptimus = False
|
||||||
, xpfVirtualBox = False
|
, xpfVirtualBox = False
|
||||||
, xpfXSANE = False
|
, xpfXSANE = False
|
||||||
, xpfEthernet = False
|
, xpfEthernet = False
|
||||||
, xpfWireless = False
|
, xpfWireless = False
|
||||||
-- TODO this might be broken down into different flags (expressvpn, etc)
|
, -- TODO this might be broken down into different flags (expressvpn, etc)
|
||||||
, xpfVPN = False
|
xpfVPN = False
|
||||||
, xpfBluetooth = False
|
, xpfBluetooth = False
|
||||||
, xpfIntelBacklight = False
|
, xpfIntelBacklight = False
|
||||||
, xpfClevoBacklight = False
|
, xpfClevoBacklight = False
|
||||||
|
@ -476,7 +489,8 @@ getParams = do
|
||||||
p <- getParamFile
|
p <- getParamFile
|
||||||
maybe (return defParams) decodeYaml p
|
maybe (return defParams) decodeYaml p
|
||||||
where
|
where
|
||||||
decodeYaml p = either (\e -> print e >> return defParams) return
|
decodeYaml p =
|
||||||
|
either (\e -> print e >> return defParams) return
|
||||||
=<< decodeFileEither p
|
=<< decodeFileEither p
|
||||||
|
|
||||||
getParamFile :: IO (Maybe FilePath)
|
getParamFile :: IO (Maybe FilePath)
|
||||||
|
@ -495,15 +509,17 @@ getParamFile = do
|
||||||
(.:+) :: Object -> String -> Parser Bool
|
(.:+) :: Object -> String -> Parser Bool
|
||||||
(.:+) o n = o .:? fromString n .!= False
|
(.:+) o n = o .:? fromString n .!= False
|
||||||
|
|
||||||
infix .:+
|
infix 9 .:+
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Testing pipeline
|
-- Testing pipeline
|
||||||
|
|
||||||
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
|
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
|
||||||
evalSometimesMsg (Sometimes n u xs) = do
|
evalSometimesMsg (Sometimes n u xs) = do
|
||||||
r <- asks (u . xpFeatures . dsParams)
|
r <- asks (u . xpFeatures . dsParams)
|
||||||
if not r then return $ Left [dis n] else do
|
if not r
|
||||||
|
then return $ Left [dis n]
|
||||||
|
else do
|
||||||
PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs
|
PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs
|
||||||
let fs' = failedMsgs n fs
|
let fs' = failedMsgs n fs
|
||||||
return $ case s of
|
return $ case s of
|
||||||
|
@ -576,8 +592,11 @@ testRoot r = do
|
||||||
(IORoot_ a t) -> go_ a testIODep_ t
|
(IORoot_ a t) -> go_ a testIODep_ t
|
||||||
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
|
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
|
||||||
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
|
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
|
||||||
_ -> return $ Left $ PostMissing
|
_ ->
|
||||||
$ Msg LevelError "client not available"
|
return $
|
||||||
|
Left $
|
||||||
|
PostMissing $
|
||||||
|
Msg LevelError "client not available"
|
||||||
where
|
where
|
||||||
-- rank N polymorphism is apparently undecidable...gross
|
-- rank N polymorphism is apparently undecidable...gross
|
||||||
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
|
go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
|
||||||
|
@ -585,13 +604,15 @@ testRoot r = do
|
||||||
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
|
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Payloaded dependency testing
|
-- Payloaded dependency testing
|
||||||
|
|
||||||
type Result p = Either [Msg] (PostPass p)
|
type Result p = Either [Msg] (PostPass p)
|
||||||
|
|
||||||
type MResult p = Memoized (Result p)
|
type MResult p = Memoized (Result p)
|
||||||
|
|
||||||
testTree :: forall d d_ p. (d_ -> FIO MResult_)
|
testTree
|
||||||
|
:: forall d d_ p
|
||||||
|
. (d_ -> FIO MResult_)
|
||||||
-> (forall q. d q -> FIO (MResult q))
|
-> (forall q. d q -> FIO (MResult q))
|
||||||
-> Tree d d_ p
|
-> Tree d d_ p
|
||||||
-> FIO (Either [Msg] (PostPass p))
|
-> FIO (Either [Msg] (PostPass p))
|
||||||
|
@ -622,18 +643,22 @@ testIODep d = memoizeMVar $ case d of
|
||||||
-- succeed, which kinda makes this pointless. The only reason I would want
|
-- succeed, which kinda makes this pointless. The only reason I would want
|
||||||
-- this is if I want to have a built-in logic to "choose" a payload to use in
|
-- this is if I want to have a built-in logic to "choose" a payload to use in
|
||||||
-- building a higher-level feature
|
-- building a higher-level feature
|
||||||
IOAlways a f -> Right . uncurry PostPass
|
IOAlways a f ->
|
||||||
|
Right
|
||||||
|
. uncurry PostPass
|
||||||
-- TODO this is wetter than Taco Bell shit
|
-- TODO this is wetter than Taco Bell shit
|
||||||
. bimap f (fmap stripMsg) <$> evalAlwaysMsg a
|
. bimap f (fmap stripMsg)
|
||||||
IOSometimes x f -> bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
|
<$> evalAlwaysMsg a
|
||||||
|
IOSometimes x f ->
|
||||||
|
bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
|
||||||
<$> evalSometimesMsg x
|
<$> evalSometimesMsg x
|
||||||
|
|
||||||
stripMsg :: FMsg -> Msg
|
stripMsg :: FMsg -> Msg
|
||||||
stripMsg (FMsg _ _ m) = m
|
stripMsg (FMsg _ _ m) = m
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Standalone dependency testing
|
|
||||||
|
|
||||||
|
-- | Standalone dependency testing
|
||||||
type Result_ = Either [Msg] [Msg]
|
type Result_ = Either [Msg] [Msg]
|
||||||
|
|
||||||
type MResult_ = Memoized Result_
|
type MResult_ = Memoized Result_
|
||||||
|
@ -652,14 +677,17 @@ testIODep_ d = memoizeMVar $ testIODepNoCache_ d
|
||||||
testIODepNoCache_ :: IODependency_ -> FIO Result_
|
testIODepNoCache_ :: IODependency_ -> FIO Result_
|
||||||
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
|
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
|
||||||
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
|
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
|
||||||
testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
|
testIODepNoCache_ (IOSometimes_ x) =
|
||||||
|
bimap (fmap stripMsg) (fmap stripMsg . snd)
|
||||||
<$> evalSometimesMsg x
|
<$> evalSometimesMsg x
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | System Dependency Testing
|
|
||||||
|
|
||||||
|
-- | System Dependency Testing
|
||||||
testSysDependency :: SystemDependency -> FIO (Maybe Msg)
|
testSysDependency :: SystemDependency -> FIO (Maybe Msg)
|
||||||
testSysDependency (Executable sys bin) = io $ maybe (Just msg) (const Nothing)
|
testSysDependency (Executable sys bin) =
|
||||||
|
io $
|
||||||
|
maybe (Just msg) (const Nothing)
|
||||||
<$> findExecutable bin
|
<$> findExecutable bin
|
||||||
where
|
where
|
||||||
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
|
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
|
||||||
|
@ -668,8 +696,9 @@ testSysDependency (Systemd t n) = shellTest "systemctl" args msg
|
||||||
where
|
where
|
||||||
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
|
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
|
||||||
args = ["--user" | t == UserUnit] ++ ["status", n]
|
args = ["--user" | t == UserUnit] ++ ["status", n]
|
||||||
testSysDependency (Process n) = shellTest "pidof" [n]
|
testSysDependency (Process n) =
|
||||||
$ T.unwords ["Process", singleQuote n, "not found"]
|
shellTest "pidof" [n] $
|
||||||
|
T.unwords ["Process", singleQuote n, "not found"]
|
||||||
testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
|
testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
|
||||||
where
|
where
|
||||||
testPerm False _ _ = Nothing
|
testPerm False _ _ = Nothing
|
||||||
|
@ -696,7 +725,7 @@ unitType SystemUnit = "system"
|
||||||
unitType UserUnit = "user"
|
unitType UserUnit = "user"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Font testers
|
-- Font testers
|
||||||
--
|
--
|
||||||
-- Make a special case for these since we end up testing the font alot, and it
|
-- Make a special case for these since we end up testing the font alot, and it
|
||||||
-- would be nice if I can cache them.
|
-- would be nice if I can cache them.
|
||||||
|
@ -744,7 +773,7 @@ testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg
|
||||||
pass = Right $ PostPass (buildFont $ Just fam) []
|
pass = Right $ PostPass (buildFont $ Just fam) []
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Network Testers
|
-- Network Testers
|
||||||
--
|
--
|
||||||
-- ASSUME that the system uses systemd in which case ethernet interfaces always
|
-- ASSUME that the system uses systemd in which case ethernet interfaces always
|
||||||
-- start with "en" and wireless interfaces always start with "wl"
|
-- start with "en" and wireless interfaces always start with "wl"
|
||||||
|
@ -762,7 +791,8 @@ isEthernet :: T.Text -> Bool
|
||||||
isEthernet = T.isPrefixOf "en"
|
isEthernet = T.isPrefixOf "en"
|
||||||
|
|
||||||
listInterfaces :: IO [T.Text]
|
listInterfaces :: IO [T.Text]
|
||||||
listInterfaces = fromRight []
|
listInterfaces =
|
||||||
|
fromRight []
|
||||||
<$> tryIOError (fmap T.pack <$> listDirectory sysfsNet)
|
<$> tryIOError (fmap T.pack <$> listDirectory sysfsNet)
|
||||||
|
|
||||||
sysfsNet :: FilePath
|
sysfsNet :: FilePath
|
||||||
|
@ -778,15 +808,19 @@ readInterface n f = IORead n [] go
|
||||||
case ns of
|
case ns of
|
||||||
[] -> return $ Left [Msg LevelError "no interfaces found"]
|
[] -> return $ Left [Msg LevelError "no interfaces found"]
|
||||||
(x : xs) -> do
|
(x : xs) -> do
|
||||||
return $ Right $ PostPass x
|
return $
|
||||||
$ fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
|
Right $
|
||||||
|
PostPass x $
|
||||||
|
fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Misc testers
|
-- Misc testers
|
||||||
|
|
||||||
socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
|
socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
|
||||||
socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
|
socketExists n ful =
|
||||||
. io . socketExists'
|
IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
|
||||||
|
. io
|
||||||
|
. socketExists'
|
||||||
|
|
||||||
socketExists' :: IO FilePath -> IO (Maybe Msg)
|
socketExists' :: IO FilePath -> IO (Maybe Msg)
|
||||||
socketExists' getPath = do
|
socketExists' getPath = do
|
||||||
|
@ -799,7 +833,7 @@ socketExists' getPath = do
|
||||||
toErr = Just . Msg LevelError
|
toErr = Just . Msg LevelError
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Dependency Testing
|
-- DBus Dependency Testing
|
||||||
|
|
||||||
introspectInterface :: InterfaceName
|
introspectInterface :: InterfaceName
|
||||||
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||||
|
@ -815,10 +849,13 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
|
||||||
ret <- callMethod cl queryBus queryPath queryIface queryMem
|
ret <- callMethod cl queryBus queryPath queryIface queryMem
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> Left [Msg LevelError e]
|
Left e -> Left [Msg LevelError e]
|
||||||
Right b -> let ns = bodyGetNames b in
|
Right b ->
|
||||||
if bus' `elem` ns then Right []
|
let ns = bodyGetNames b
|
||||||
else Left [
|
in if bus' `elem` ns
|
||||||
Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
|
then Right []
|
||||||
|
else
|
||||||
|
Left
|
||||||
|
[ Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
bus' = T.pack $ formatBusName bus
|
bus' = T.pack $ formatBusName bus
|
||||||
|
@ -828,19 +865,23 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
|
||||||
queryMem = memberName_ "ListNames"
|
queryMem = memberName_ "ListNames"
|
||||||
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
|
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
|
||||||
bodyGetNames _ = []
|
bodyGetNames _ = []
|
||||||
|
|
||||||
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
||||||
ret <- callMethod cl busname objpath introspectInterface introspectMethod
|
ret <- callMethod cl busname objpath introspectInterface introspectMethod
|
||||||
return $ case ret of
|
return $ case ret of
|
||||||
Left e -> Left [Msg LevelError e]
|
Left e -> Left [Msg LevelError e]
|
||||||
Right body -> procBody body
|
Right body -> procBody body
|
||||||
where
|
where
|
||||||
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant
|
procBody body =
|
||||||
=<< listToMaybe body in
|
let res =
|
||||||
case res of
|
findMem
|
||||||
|
=<< I.parseXML objpath
|
||||||
|
=<< fromVariant
|
||||||
|
=<< listToMaybe body
|
||||||
|
in case res of
|
||||||
Just True -> Right []
|
Just True -> Right []
|
||||||
_ -> Left [Msg LevelError $ fmtMsg' mem]
|
_ -> Left [Msg LevelError $ fmtMsg' mem]
|
||||||
findMem = fmap (matchMem mem)
|
findMem =
|
||||||
|
fmap (matchMem mem)
|
||||||
. find (\i -> I.interfaceName i == iface)
|
. find (\i -> I.interfaceName i == iface)
|
||||||
. I.objectInterfaces
|
. I.objectInterfaces
|
||||||
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
|
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
|
||||||
|
@ -850,7 +891,8 @@ testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
||||||
fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)]
|
fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)]
|
||||||
fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)]
|
fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)]
|
||||||
fmtMem (Property_ n) = T.unwords ["property", singleQuote n]
|
fmtMem (Property_ n) = T.unwords ["property", singleQuote n]
|
||||||
fmtMsg' m = T.unwords
|
fmtMsg' m =
|
||||||
|
T.unwords
|
||||||
[ "could not find"
|
[ "could not find"
|
||||||
, fmtMem m
|
, fmtMem m
|
||||||
, "on interface"
|
, "on interface"
|
||||||
|
@ -858,11 +900,10 @@ testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
|
||||||
, "on bus"
|
, "on bus"
|
||||||
, T.pack $ formatBusName busname
|
, T.pack $ formatBusName busname
|
||||||
]
|
]
|
||||||
|
|
||||||
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
|
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | IO Lifting functions
|
-- IO Lifting functions
|
||||||
|
|
||||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||||
ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs
|
ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs
|
||||||
|
@ -888,15 +929,19 @@ ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
||||||
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature constructors
|
-- Feature constructors
|
||||||
|
|
||||||
sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a
|
sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a
|
||||||
sometimes1_ x fn n t = Sometimes fn x
|
sometimes1_ x fn n t =
|
||||||
|
Sometimes
|
||||||
|
fn
|
||||||
|
x
|
||||||
[Subfeature {sfData = t, sfName = n}]
|
[Subfeature {sfData = t, sfName = n}]
|
||||||
|
|
||||||
always1_ :: T.Text -> T.Text -> Root a -> a -> Always a
|
always1_ :: T.Text -> T.Text -> Root a -> a -> Always a
|
||||||
always1_ fn n t x = Always fn
|
always1_ fn n t x =
|
||||||
$ Option (Subfeature{ sfData = t, sfName = n }) (Always_ $ FallbackAlone x)
|
Always fn $
|
||||||
|
Option (Subfeature {sfData = t, sfName = n}) (Always_ $ FallbackAlone x)
|
||||||
|
|
||||||
sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a
|
sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a
|
||||||
sometimes1 = sometimes1_ (const True)
|
sometimes1 = sometimes1_ (const True)
|
||||||
|
@ -910,22 +955,49 @@ sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
|
||||||
sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a
|
sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a
|
||||||
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
|
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
|
||||||
|
|
||||||
sometimesExe :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool
|
sometimesExe
|
||||||
-> FilePath -> Sometimes (m ())
|
:: MonadIO m
|
||||||
|
=> T.Text
|
||||||
|
-> T.Text
|
||||||
|
-> [Fulfillment]
|
||||||
|
-> Bool
|
||||||
|
-> FilePath
|
||||||
|
-> Sometimes (m ())
|
||||||
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
|
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
|
||||||
|
|
||||||
sometimesExeArgs :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool
|
sometimesExeArgs
|
||||||
-> FilePath -> [T.Text] -> Sometimes (m ())
|
:: MonadIO m
|
||||||
|
=> T.Text
|
||||||
|
-> T.Text
|
||||||
|
-> [Fulfillment]
|
||||||
|
-> Bool
|
||||||
|
-> FilePath
|
||||||
|
-> [T.Text]
|
||||||
|
-> Sometimes (m ())
|
||||||
sometimesExeArgs fn n ful sys path args =
|
sometimesExeArgs fn n ful sys path args =
|
||||||
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
|
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
|
||||||
|
|
||||||
sometimesDBus :: SafeClient c => Maybe c -> T.Text -> T.Text
|
sometimesDBus
|
||||||
-> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a
|
:: SafeClient c
|
||||||
|
=> Maybe c
|
||||||
|
-> T.Text
|
||||||
|
-> T.Text
|
||||||
|
-> Tree_ (DBusDependency_ c)
|
||||||
|
-> (c -> a)
|
||||||
|
-> Sometimes a
|
||||||
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||||
|
|
||||||
sometimesEndpoint :: (SafeClient c, MonadIO m) => T.Text -> T.Text
|
sometimesEndpoint
|
||||||
-> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName
|
:: (SafeClient c, MonadIO m)
|
||||||
-> Maybe c -> Sometimes (m ())
|
=> T.Text
|
||||||
|
-> T.Text
|
||||||
|
-> [Fulfillment]
|
||||||
|
-> BusName
|
||||||
|
-> ObjectPath
|
||||||
|
-> InterfaceName
|
||||||
|
-> MemberName
|
||||||
|
-> Maybe c
|
||||||
|
-> Sometimes (m ())
|
||||||
sometimesEndpoint fn name ful busname path iface mem cl =
|
sometimesEndpoint fn name ful busname path iface mem cl =
|
||||||
sometimesDBus cl fn name deps cmd
|
sometimesDBus cl fn name deps cmd
|
||||||
where
|
where
|
||||||
|
@ -933,7 +1005,7 @@ sometimesEndpoint fn name ful busname path iface mem cl =
|
||||||
cmd c = io $ void $ callMethod c busname path iface mem
|
cmd c = io $ void $ callMethod c busname path iface mem
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dependency Tree Constructors
|
-- Dependency Tree Constructors
|
||||||
|
|
||||||
listToAnds :: d -> [d] -> Tree_ d
|
listToAnds :: d -> [d] -> Tree_ d
|
||||||
listToAnds i = foldr (And_ . Only_) (Only_ i)
|
listToAnds i = foldr (And_ . Only_) (Only_ i)
|
||||||
|
@ -958,7 +1030,7 @@ readResult_ (Just w) = Left [w]
|
||||||
readResult_ _ = Right []
|
readResult_ _ = Right []
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | IO Dependency Constructors
|
-- IO Dependency Constructors
|
||||||
|
|
||||||
exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_
|
exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_
|
||||||
exe b ful = IOSystem_ ful . Executable b
|
exe b ful = IOSystem_ ful . Executable b
|
||||||
|
@ -994,7 +1066,7 @@ process :: [Fulfillment] -> T.Text -> IODependency_
|
||||||
process ful = IOSystem_ ful . Process
|
process ful = IOSystem_ ful . Process
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dependency data for JSON
|
-- Dependency data for JSON
|
||||||
|
|
||||||
type DependencyData = [Fulfillment]
|
type DependencyData = [Fulfillment]
|
||||||
|
|
||||||
|
@ -1007,8 +1079,12 @@ dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
|
||||||
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
|
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
|
||||||
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
|
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
|
||||||
|
|
||||||
dataTree :: forall d d_ p. (forall q. d q -> DependencyData)
|
dataTree
|
||||||
-> (d_ -> DependencyData) -> Tree d d_ p -> DependencyData
|
:: forall d d_ p
|
||||||
|
. (forall q. d q -> DependencyData)
|
||||||
|
-> (d_ -> DependencyData)
|
||||||
|
-> Tree d d_ p
|
||||||
|
-> DependencyData
|
||||||
dataTree f f_ = go
|
dataTree f f_ = go
|
||||||
where
|
where
|
||||||
go :: forall q. Tree d d_ q -> DependencyData
|
go :: forall q. Tree d d_ q -> DependencyData
|
||||||
|
@ -1045,8 +1121,7 @@ dataDBusDependency d = case d of
|
||||||
(DBusIO x) -> dataIODependency_ x
|
(DBusIO x) -> dataIODependency_ x
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | JSON formatting
|
-- formatting
|
||||||
|
|
||||||
bracket :: T.Text -> T.Text
|
bracket :: T.Text -> T.Text
|
||||||
bracket s = T.concat ["[", s, "]"]
|
bracket s = T.concat ["[", s, "]"]
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dmenu (Rofi) Commands
|
-- Dmenu (Rofi) Commands
|
||||||
|
|
||||||
module XMonad.Internal.Command.DMenu
|
module XMonad.Internal.Command.DMenu
|
||||||
( runCmdMenu
|
( runCmdMenu
|
||||||
|
@ -15,23 +15,19 @@ module XMonad.Internal.Command.DMenu
|
||||||
, runBTMenu
|
, runBTMenu
|
||||||
, runShowKeys
|
, runShowKeys
|
||||||
, runAutorandrMenu
|
, runAutorandrMenu
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import Data.Internal.DBus
|
|
||||||
import Data.Internal.Dependency
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
( XdgDirectory (..)
|
( XdgDirectory (..)
|
||||||
, getXdgDirectory
|
, getXdgDirectory
|
||||||
)
|
)
|
||||||
import System.IO
|
import System.IO
|
||||||
|
|
||||||
import XMonad.Core hiding (spawn)
|
import XMonad.Core hiding (spawn)
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
@ -40,7 +36,7 @@ import XMonad.Internal.Shell
|
||||||
import XMonad.Util.NamedActions
|
import XMonad.Util.NamedActions
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DMenu executables
|
-- DMenu executables
|
||||||
|
|
||||||
myDmenuCmd :: FilePath
|
myDmenuCmd :: FilePath
|
||||||
myDmenuCmd = "rofi"
|
myDmenuCmd = "rofi"
|
||||||
|
@ -67,7 +63,7 @@ myClipboardManager :: FilePath
|
||||||
myClipboardManager = "greenclip"
|
myClipboardManager = "greenclip"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Packages
|
-- Packages
|
||||||
|
|
||||||
dmenuPkgs :: [Fulfillment]
|
dmenuPkgs :: [Fulfillment]
|
||||||
dmenuPkgs = [Package Official "rofi"]
|
dmenuPkgs = [Package Official "rofi"]
|
||||||
|
@ -76,7 +72,7 @@ clipboardPkgs :: [Fulfillment]
|
||||||
clipboardPkgs = [Package AUR "rofi-greenclip"]
|
clipboardPkgs = [Package AUR "rofi-greenclip"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Other internal functions
|
-- Other internal functions
|
||||||
|
|
||||||
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
|
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
|
||||||
spawnDmenuCmd n =
|
spawnDmenuCmd n =
|
||||||
|
@ -98,7 +94,7 @@ dmenuDep :: IODependency_
|
||||||
dmenuDep = sysExe dmenuPkgs myDmenuCmd
|
dmenuDep = sysExe dmenuPkgs myDmenuCmd
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported Commands
|
-- Exported Commands
|
||||||
|
|
||||||
-- TODO test that veracrypt and friends are installed
|
-- TODO test that veracrypt and friends are installed
|
||||||
runDevMenu :: SometimesX
|
runDevMenu :: SometimesX
|
||||||
|
@ -107,28 +103,38 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
|
||||||
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
|
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
|
||||||
x = do
|
x = do
|
||||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
|
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
|
||||||
spawnCmd myDmenuDevices
|
spawnCmd myDmenuDevices $
|
||||||
$ ["-c", T.pack c]
|
["-c", T.pack c]
|
||||||
++ "--" : themeArgs "#999933"
|
++ "--"
|
||||||
|
: themeArgs "#999933"
|
||||||
++ myDmenuMatchingArgs
|
++ myDmenuMatchingArgs
|
||||||
|
|
||||||
-- TODO test that bluetooth interface exists
|
-- TODO test that bluetooth interface exists
|
||||||
runBTMenu :: SometimesX
|
runBTMenu :: SometimesX
|
||||||
runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
|
runBTMenu =
|
||||||
|
Sometimes
|
||||||
|
"bluetooth selector"
|
||||||
|
xpfBluetooth
|
||||||
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
|
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
|
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
|
||||||
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
|
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
|
||||||
|
|
||||||
runVPNMenu :: SometimesX
|
runVPNMenu :: SometimesX
|
||||||
runVPNMenu = Sometimes "VPN selector" xpfVPN
|
runVPNMenu =
|
||||||
|
Sometimes
|
||||||
|
"VPN selector"
|
||||||
|
xpfVPN
|
||||||
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
|
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myDmenuVPN
|
cmd =
|
||||||
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuVPN $
|
||||||
tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
|
["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||||
$ socketExists "expressVPN" []
|
tree =
|
||||||
$ return "/var/lib/expressvpn/expressvpnd.socket"
|
dmenuTree $
|
||||||
|
toAnd_ (localExe [] myDmenuVPN) $
|
||||||
|
socketExists "expressVPN" [] $
|
||||||
|
return "/var/lib/expressvpn/expressvpnd.socket"
|
||||||
|
|
||||||
runCmdMenu :: SometimesX
|
runCmdMenu :: SometimesX
|
||||||
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
||||||
|
@ -140,15 +146,20 @@ runWinMenu :: SometimesX
|
||||||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
||||||
|
|
||||||
runNetMenu :: Maybe SysClient -> SometimesX
|
runNetMenu :: Maybe SysClient -> SometimesX
|
||||||
runNetMenu cl = Sometimes "network control menu" enabled
|
runNetMenu cl =
|
||||||
|
Sometimes
|
||||||
|
"network control menu"
|
||||||
|
enabled
|
||||||
[Subfeature root "network control menu"]
|
[Subfeature root "network control menu"]
|
||||||
where
|
where
|
||||||
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
|
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
|
||||||
root = DBusRoot_ cmd tree cl
|
root = DBusRoot_ cmd tree cl
|
||||||
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
|
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
|
||||||
tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus)
|
tree =
|
||||||
$ toAnd_ (DBusIO dmenuDep) $ DBusIO
|
And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
|
||||||
$ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
|
toAnd_ (DBusIO dmenuDep) $
|
||||||
|
DBusIO $
|
||||||
|
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
|
||||||
|
|
||||||
runAutorandrMenu :: SometimesX
|
runAutorandrMenu :: SometimesX
|
||||||
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||||
|
@ -157,44 +168,60 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||||
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
|
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Password manager
|
-- Password manager
|
||||||
|
|
||||||
runBwMenu :: Maybe SesClient -> SometimesX
|
runBwMenu :: Maybe SesClient -> SometimesX
|
||||||
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myDmenuPasswords
|
cmd _ =
|
||||||
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuPasswords $
|
||||||
tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
|
["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||||
$ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
|
tree =
|
||||||
|
And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
|
||||||
|
toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Clipboard
|
-- Clipboard
|
||||||
|
|
||||||
runClipMenu :: SometimesX
|
runClipMenu :: SometimesX
|
||||||
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
||||||
where
|
where
|
||||||
act = spawnCmd myDmenuCmd args
|
act = spawnCmd myDmenuCmd args
|
||||||
tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
|
tree =
|
||||||
|
listToAnds
|
||||||
|
dmenuDep
|
||||||
|
[ sysExe clipboardPkgs myClipboardManager
|
||||||
, process [] $ T.pack myClipboardManager
|
, process [] $ T.pack myClipboardManager
|
||||||
]
|
]
|
||||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
args =
|
||||||
, "-show", "clipboard"
|
[ "-modi"
|
||||||
, "-run-command", "'{cmd}'"
|
, "\"clipboard:greenclip print\""
|
||||||
] ++ themeArgs "#00c44e"
|
, "-show"
|
||||||
|
, "clipboard"
|
||||||
|
, "-run-command"
|
||||||
|
, "'{cmd}'"
|
||||||
|
]
|
||||||
|
++ themeArgs "#00c44e"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Shortcut menu
|
-- Shortcut menu
|
||||||
|
|
||||||
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
|
runShowKeys =
|
||||||
$ FallbackAlone fallback
|
Always "keyboard menu" $
|
||||||
|
Option showKeysDMenu $
|
||||||
|
Always_ $
|
||||||
|
FallbackAlone fallback
|
||||||
where
|
where
|
||||||
-- TODO this should technically depend on dunst
|
-- TODO this should technically depend on dunst
|
||||||
fallback = const $ spawnNotify
|
fallback =
|
||||||
$ defNoteError { body = Just $ Text "could not display keymap" }
|
const $
|
||||||
|
spawnNotify $
|
||||||
|
defNoteError {body = Just $ Text "could not display keymap"}
|
||||||
|
|
||||||
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
|
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
showKeysDMenu = Subfeature
|
showKeysDMenu =
|
||||||
|
Subfeature
|
||||||
{ sfName = "keyboard shortcut menu"
|
{ sfName = "keyboard shortcut menu"
|
||||||
, sfData = IORoot_ showKeys $ Only_ dmenuDep
|
, sfData = IORoot_ showKeys $ Only_ dmenuDep
|
||||||
}
|
}
|
||||||
|
@ -205,5 +232,8 @@ showKeys kbs = do
|
||||||
io $ hPutStr h $ unlines $ showKm kbs
|
io $ hPutStr h $ unlines $ showKm kbs
|
||||||
io $ hClose h
|
io $ hClose h
|
||||||
where
|
where
|
||||||
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
|
cmd =
|
||||||
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
|
fmtCmd myDmenuCmd $
|
||||||
|
["-dmenu", "-p", "commands"]
|
||||||
|
++ themeArgs "#7f66ff"
|
||||||
|
++ myDmenuMatchingArgs
|
||||||
|
|
|
@ -1,12 +1,11 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | General commands
|
-- General commands
|
||||||
|
|
||||||
module XMonad.Internal.Command.Desktop
|
module XMonad.Internal.Command.Desktop
|
||||||
( myTerm
|
( myTerm
|
||||||
, playSound
|
, playSound
|
||||||
|
|
||||||
-- commands
|
-- commands
|
||||||
, runTerm
|
, runTerm
|
||||||
, runTMux
|
, runTMux
|
||||||
|
@ -33,28 +32,23 @@ module XMonad.Internal.Command.Desktop
|
||||||
, runNotificationCloseAll
|
, runNotificationCloseAll
|
||||||
, runNotificationHistory
|
, runNotificationHistory
|
||||||
, runNotificationContext
|
, runNotificationContext
|
||||||
|
|
||||||
-- daemons
|
-- daemons
|
||||||
, runNetAppDaemon
|
, runNetAppDaemon
|
||||||
|
|
||||||
-- packages
|
-- packages
|
||||||
, networkManagerPkgs
|
, networkManagerPkgs
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import Data.Internal.DBus
|
|
||||||
import Data.Internal.Dependency
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import qualified RIO.Process as P
|
import qualified RIO.Process as P
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.Posix.User
|
import System.Posix.User
|
||||||
|
|
||||||
import XMonad.Actions.Volume
|
import XMonad.Actions.Volume
|
||||||
import XMonad.Core hiding (spawn)
|
import XMonad.Core hiding (spawn)
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
@ -63,7 +57,7 @@ import XMonad.Internal.Shell as S
|
||||||
import XMonad.Operations
|
import XMonad.Operations
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | My Executables
|
-- My Executables
|
||||||
|
|
||||||
myTerm :: FilePath
|
myTerm :: FilePath
|
||||||
myTerm = "urxvt"
|
myTerm = "urxvt"
|
||||||
|
@ -96,10 +90,11 @@ myNotificationCtrl :: FilePath
|
||||||
myNotificationCtrl = "dunstctl"
|
myNotificationCtrl = "dunstctl"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Packages
|
-- Packages
|
||||||
|
|
||||||
myTermPkgs :: [Fulfillment]
|
myTermPkgs :: [Fulfillment]
|
||||||
myTermPkgs = [ Package Official "rxvt-unicode"
|
myTermPkgs =
|
||||||
|
[ Package Official "rxvt-unicode"
|
||||||
, Package Official "urxvt-perls"
|
, Package Official "urxvt-perls"
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -116,13 +111,13 @@ networkManagerPkgs :: [Fulfillment]
|
||||||
networkManagerPkgs = [Package Official "networkmanager"]
|
networkManagerPkgs = [Package Official "networkmanager"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Misc constants
|
-- Misc constants
|
||||||
|
|
||||||
volumeChangeSound :: FilePath
|
volumeChangeSound :: FilePath
|
||||||
volumeChangeSound = "smb_fireball.wav"
|
volumeChangeSound = "smb_fireball.wav"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Some nice apps
|
-- Some nice apps
|
||||||
|
|
||||||
runTerm :: SometimesX
|
runTerm :: SometimesX
|
||||||
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
||||||
|
@ -130,10 +125,12 @@ runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
||||||
runTMux :: SometimesX
|
runTMux :: SometimesX
|
||||||
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||||
where
|
where
|
||||||
deps = listToAnds (socketExists "tmux" [] socketName)
|
deps =
|
||||||
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
|
listToAnds (socketExists "tmux" [] socketName) $
|
||||||
act = S.spawn
|
fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
|
||||||
$ fmtCmd "tmux" ["has-session"]
|
act =
|
||||||
|
S.spawn $
|
||||||
|
fmtCmd "tmux" ["has-session"]
|
||||||
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
||||||
#!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
|
#!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
|
||||||
c = "exec tmux attach-session -d"
|
c = "exec tmux attach-session -d"
|
||||||
|
@ -150,28 +147,46 @@ runCalc = sometimesIO_ "calculator" "bc" deps act
|
||||||
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
|
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
|
||||||
|
|
||||||
runBrowser :: SometimesX
|
runBrowser :: SometimesX
|
||||||
runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
|
runBrowser =
|
||||||
False myBrowser
|
sometimesExe
|
||||||
|
"web browser"
|
||||||
|
"brave"
|
||||||
|
[Package AUR "brave-bin"]
|
||||||
|
False
|
||||||
|
myBrowser
|
||||||
|
|
||||||
runEditor :: SometimesX
|
runEditor :: SometimesX
|
||||||
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myEditor
|
cmd =
|
||||||
|
spawnCmd
|
||||||
|
myEditor
|
||||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
||||||
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
|
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
|
||||||
-- before xmonad starts, so just check to see if the process has started
|
-- before xmonad starts, so just check to see if the process has started
|
||||||
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
|
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
|
||||||
|
|
||||||
runFileManager :: SometimesX
|
runFileManager :: SometimesX
|
||||||
runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
|
runFileManager =
|
||||||
True "pcmanfm"
|
sometimesExe
|
||||||
|
"file browser"
|
||||||
|
"pcmanfm"
|
||||||
|
[Package Official "pcmanfm"]
|
||||||
|
True
|
||||||
|
"pcmanfm"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Multimedia Commands
|
-- Multimedia Commands
|
||||||
|
|
||||||
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
|
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
|
||||||
runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control")
|
runMultimediaIfInstalled n cmd =
|
||||||
"playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
|
sometimesExeArgs
|
||||||
|
(T.append n " multimedia control")
|
||||||
|
"playerctl"
|
||||||
|
[Package Official "playerctl"]
|
||||||
|
True
|
||||||
|
myMultimediaCtl
|
||||||
|
[cmd]
|
||||||
|
|
||||||
runTogglePlay :: SometimesX
|
runTogglePlay :: SometimesX
|
||||||
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
||||||
|
@ -186,7 +201,7 @@ runStopPlay :: SometimesX
|
||||||
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
|
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Volume Commands
|
-- Volume Commands
|
||||||
|
|
||||||
soundDir :: FilePath
|
soundDir :: FilePath
|
||||||
soundDir = "sound"
|
soundDir = "sound"
|
||||||
|
@ -200,8 +215,8 @@ playSound file = do
|
||||||
|
|
||||||
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
|
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
|
||||||
featureSound n file pre post =
|
featureSound n file pre post =
|
||||||
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree
|
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
|
||||||
$ pre >> playSound file >> post
|
pre >> playSound file >> post
|
||||||
where
|
where
|
||||||
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
|
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
|
||||||
-- to play sound (duh) but libpulse is the package with the paplay binary
|
-- to play sound (duh) but libpulse is the package with the paplay binary
|
||||||
|
@ -217,16 +232,18 @@ runVolumeMute :: SometimesX
|
||||||
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
|
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Notification control
|
-- Notification control
|
||||||
|
|
||||||
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
runNotificationCmd n arg cl =
|
runNotificationCmd n arg cl =
|
||||||
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myNotificationCtrl [arg]
|
cmd _ = spawnCmd myNotificationCtrl [arg]
|
||||||
tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
|
tree =
|
||||||
$ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
|
toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
|
||||||
$ Method_ $ memberName_ "NotificationAction"
|
Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
|
||||||
|
Method_ $
|
||||||
|
memberName_ "NotificationAction"
|
||||||
|
|
||||||
runNotificationClose :: Maybe SesClient -> SometimesX
|
runNotificationClose :: Maybe SesClient -> SometimesX
|
||||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||||
|
@ -244,11 +261,14 @@ runNotificationContext =
|
||||||
runNotificationCmd "open notification context" "context"
|
runNotificationCmd "open notification context" "context"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | System commands
|
-- System commands
|
||||||
|
|
||||||
-- this is required for some vpn's to work properly with network-manager
|
-- this is required for some vpn's to work properly with network-manager
|
||||||
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
|
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
|
||||||
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
|
runNetAppDaemon cl =
|
||||||
|
Sometimes
|
||||||
|
"network applet"
|
||||||
|
xpfVPN
|
||||||
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
||||||
where
|
where
|
||||||
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
||||||
|
@ -256,12 +276,16 @@ runNetAppDaemon cl = Sometimes "network applet" xpfVPN
|
||||||
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
||||||
|
|
||||||
runToggleBluetooth :: Maybe SysClient -> SometimesX
|
runToggleBluetooth :: Maybe SysClient -> SometimesX
|
||||||
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
|
runToggleBluetooth cl =
|
||||||
|
Sometimes
|
||||||
|
"bluetooth toggle"
|
||||||
|
xpfBluetooth
|
||||||
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
|
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
|
||||||
where
|
where
|
||||||
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
|
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
|
||||||
cmd _ = S.spawn
|
cmd _ =
|
||||||
$ fmtCmd myBluetooth ["show"]
|
S.spawn $
|
||||||
|
fmtCmd myBluetooth ["show"]
|
||||||
#!| "grep -q \"Powered: no\""
|
#!| "grep -q \"Powered: no\""
|
||||||
#!&& "a=on"
|
#!&& "a=on"
|
||||||
#!|| "a=off"
|
#!|| "a=off"
|
||||||
|
@ -269,14 +293,21 @@ runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
|
||||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
|
||||||
|
|
||||||
runToggleEthernet :: SometimesX
|
runToggleEthernet :: SometimesX
|
||||||
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
|
runToggleEthernet =
|
||||||
|
Sometimes
|
||||||
|
"ethernet toggle"
|
||||||
|
xpfEthernet
|
||||||
[Subfeature root "nmcli"]
|
[Subfeature root "nmcli"]
|
||||||
where
|
where
|
||||||
root = IORoot cmd $ And1 (Only readEthernet) $ Only_
|
root =
|
||||||
$ sysExe networkManagerPkgs "nmcli"
|
IORoot cmd $
|
||||||
|
And1 (Only readEthernet) $
|
||||||
|
Only_ $
|
||||||
|
sysExe networkManagerPkgs "nmcli"
|
||||||
-- TODO make this less noisy
|
-- TODO make this less noisy
|
||||||
cmd iface = S.spawn
|
cmd iface =
|
||||||
$ fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
|
S.spawn $
|
||||||
|
fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
|
||||||
#!| "grep -q disconnected"
|
#!| "grep -q disconnected"
|
||||||
#!&& "a=connect"
|
#!&& "a=connect"
|
||||||
#!|| "a=disconnect"
|
#!|| "a=disconnect"
|
||||||
|
@ -284,7 +315,7 @@ runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
|
||||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Configuration commands
|
-- Configuration commands
|
||||||
|
|
||||||
runRestart :: X ()
|
runRestart :: X ()
|
||||||
runRestart = restart "xmonad" True
|
runRestart = restart "xmonad" True
|
||||||
|
@ -294,14 +325,14 @@ runRecompile :: X ()
|
||||||
runRecompile = do
|
runRecompile = do
|
||||||
-- assume that the conf directory contains a valid stack project
|
-- assume that the conf directory contains a valid stack project
|
||||||
confDir <- asks (cfgDir . directories)
|
confDir <- asks (cfgDir . directories)
|
||||||
spawn
|
spawn $
|
||||||
$ fmtCmd "cd" [T.pack confDir]
|
fmtCmd "cd" [T.pack confDir]
|
||||||
#!&& fmtCmd "stack" ["install"]
|
#!&& fmtCmd "stack" ["install"]
|
||||||
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
|
||||||
#!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
|
#!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Screen capture commands
|
-- Screen capture commands
|
||||||
|
|
||||||
getCaptureDir :: IO FilePath
|
getCaptureDir :: IO FilePath
|
||||||
getCaptureDir = do
|
getCaptureDir = do
|
||||||
|
@ -321,8 +352,10 @@ runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myCapture [mode]
|
cmd _ = spawnCmd myCapture [mode]
|
||||||
tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
|
tree =
|
||||||
$ Bus [] $ busName_ "org.flameshot.Flameshot"
|
toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
|
||||||
|
Bus [] $
|
||||||
|
busName_ "org.flameshot.Flameshot"
|
||||||
|
|
||||||
-- TODO this will steal focus from the current window (and puts it
|
-- TODO this will steal focus from the current window (and puts it
|
||||||
-- in the root window?) ...need to fix
|
-- in the root window?) ...need to fix
|
||||||
|
@ -338,7 +371,10 @@ runScreenCapture :: Maybe SesClient -> SometimesX
|
||||||
runScreenCapture = runFlameshot "screen capture" "screen"
|
runScreenCapture = runFlameshot "screen capture" "screen"
|
||||||
|
|
||||||
runCaptureBrowser :: SometimesX
|
runCaptureBrowser :: SometimesX
|
||||||
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
|
runCaptureBrowser = sometimesIO_
|
||||||
(Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
|
"screen capture browser"
|
||||||
|
"feh"
|
||||||
|
(Only_ $ sysExe [Package Official "feh"] myImageBrowser)
|
||||||
|
$ do
|
||||||
dir <- io getCaptureDir
|
dir <- io getCaptureDir
|
||||||
spawnCmd myImageBrowser [T.pack dir]
|
spawnCmd myImageBrowser [T.pack dir]
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Commands for controlling power
|
-- Commands for controlling power
|
||||||
|
|
||||||
module XMonad.Internal.Command.Power
|
module XMonad.Internal.Command.Power
|
||||||
-- commands
|
-- commands
|
||||||
|
@ -14,10 +14,8 @@ module XMonad.Internal.Command.Power
|
||||||
, runSuspend
|
, runSuspend
|
||||||
, runSuspendPrompt
|
, runSuspendPrompt
|
||||||
, runQuitPrompt
|
, runQuitPrompt
|
||||||
|
|
||||||
-- daemons
|
-- daemons
|
||||||
, runAutolock
|
, runAutolock
|
||||||
|
|
||||||
-- functions
|
-- functions
|
||||||
, hasBattery
|
, hasBattery
|
||||||
, suspendPrompt
|
, suspendPrompt
|
||||||
|
@ -25,23 +23,19 @@ module XMonad.Internal.Command.Power
|
||||||
, powerPrompt
|
, powerPrompt
|
||||||
, defFontPkgs
|
, defFontPkgs
|
||||||
, promptFontDep
|
, promptFontDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import Data.Internal.Dependency
|
|
||||||
|
|
||||||
import Data.Either
|
import Data.Either
|
||||||
|
import Data.Internal.Dependency
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
|
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import qualified RIO.Process as P
|
import qualified RIO.Process as P
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
|
|
||||||
import XMonad.Core hiding (spawn)
|
import XMonad.Core hiding (spawn)
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
import qualified XMonad.Internal.Theme as XT
|
import qualified XMonad.Internal.Theme as XT
|
||||||
|
@ -49,8 +43,7 @@ import XMonad.Prompt
|
||||||
import XMonad.Prompt.ConfirmPrompt
|
import XMonad.Prompt.ConfirmPrompt
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Executables
|
-- Executables
|
||||||
|
|
||||||
myScreenlock :: FilePath
|
myScreenlock :: FilePath
|
||||||
myScreenlock = "screenlock"
|
myScreenlock = "screenlock"
|
||||||
|
|
||||||
|
@ -61,17 +54,22 @@ myPrimeOffload :: FilePath
|
||||||
myPrimeOffload = "prime-offload"
|
myPrimeOffload = "prime-offload"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Packages
|
-- Packages
|
||||||
|
|
||||||
optimusPackages :: [Fulfillment]
|
optimusPackages :: [Fulfillment]
|
||||||
optimusPackages = [Package AUR "optimus-manager"]
|
optimusPackages = [Package AUR "optimus-manager"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Core commands
|
-- Core commands
|
||||||
|
|
||||||
runScreenLock :: SometimesX
|
runScreenLock :: SometimesX
|
||||||
runScreenLock = sometimesExe "screen locker" "i3lock script"
|
runScreenLock =
|
||||||
[Package AUR "i3lock-color"] False myScreenlock
|
sometimesExe
|
||||||
|
"screen locker"
|
||||||
|
"i3lock script"
|
||||||
|
[Package AUR "i3lock-color"]
|
||||||
|
False
|
||||||
|
myScreenlock
|
||||||
|
|
||||||
runPowerOff :: X ()
|
runPowerOff :: X ()
|
||||||
runPowerOff = spawn "systemctl poweroff"
|
runPowerOff = spawn "systemctl poweroff"
|
||||||
|
@ -86,17 +84,19 @@ runReboot :: X ()
|
||||||
runReboot = spawn "systemctl reboot"
|
runReboot = spawn "systemctl reboot"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Autolock
|
-- Autolock
|
||||||
|
|
||||||
runAutolock :: Sometimes (FIO (P.Process () () ()))
|
runAutolock :: Sometimes (FIO (P.Process () () ()))
|
||||||
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
||||||
where
|
where
|
||||||
tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
|
tree =
|
||||||
$ Only_ $ IOSometimes_ runScreenLock
|
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
|
||||||
|
Only_ $
|
||||||
|
IOSometimes_ runScreenLock
|
||||||
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
|
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Confirmation prompts
|
-- Confirmation prompts
|
||||||
|
|
||||||
promptFontDep :: IOTree XT.FontBuilder
|
promptFontDep :: IOTree XT.FontBuilder
|
||||||
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
|
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
|
||||||
|
@ -124,7 +124,7 @@ runQuitPrompt :: SometimesX
|
||||||
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
|
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Nvidia Optimus
|
-- Nvidia Optimus
|
||||||
|
|
||||||
-- TODO for some reason the screen never wakes up after suspend when
|
-- TODO for some reason the screen never wakes up after suspend when
|
||||||
-- the nvidia card is up, so block suspend if nvidia card is running
|
-- the nvidia card is up, so block suspend if nvidia card is running
|
||||||
|
@ -148,26 +148,32 @@ runOptimusPrompt' fb = do
|
||||||
where
|
where
|
||||||
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
|
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
|
||||||
prompt mode = T.concat ["gpu switch to ", mode, "?"]
|
prompt mode = T.concat ["gpu switch to ", mode, "?"]
|
||||||
cmd mode = spawn
|
cmd mode =
|
||||||
$ T.pack myPrimeOffload
|
spawn $
|
||||||
|
T.pack myPrimeOffload
|
||||||
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
|
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
|
||||||
#!&& "killall xmonad"
|
#!&& "killall xmonad"
|
||||||
|
|
||||||
runOptimusPrompt :: SometimesX
|
runOptimusPrompt :: SometimesX
|
||||||
runOptimusPrompt = Sometimes "graphics switcher"
|
runOptimusPrompt =
|
||||||
(\x -> xpfOptimus x && xpfBattery x) [s]
|
Sometimes
|
||||||
|
"graphics switcher"
|
||||||
|
(\x -> xpfOptimus x && xpfBattery x)
|
||||||
|
[s]
|
||||||
where
|
where
|
||||||
s = Subfeature {sfData = r, sfName = "optimus manager"}
|
s = Subfeature {sfData = r, sfName = "optimus manager"}
|
||||||
r = IORoot runOptimusPrompt' t
|
r = IORoot runOptimusPrompt' t
|
||||||
t = And1 promptFontDep
|
t =
|
||||||
$ listToAnds (socketExists "optimus-manager" [] socketName)
|
And1 promptFontDep $
|
||||||
$ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
|
listToAnds (socketExists "optimus-manager" [] socketName) $
|
||||||
|
sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
|
||||||
socketName = (</> "optimus-manager") <$> getTemporaryDirectory
|
socketName = (</> "optimus-manager") <$> getTemporaryDirectory
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Universal power prompt
|
-- Universal power prompt
|
||||||
|
|
||||||
data PowerMaybeAction = Poweroff
|
data PowerMaybeAction
|
||||||
|
= Poweroff
|
||||||
| Shutdown
|
| Shutdown
|
||||||
| Hibernate
|
| Hibernate
|
||||||
| Reboot
|
| Reboot
|
||||||
|
@ -203,9 +209,11 @@ powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
||||||
where
|
where
|
||||||
comp = mkComplFunFromList theme []
|
comp = mkComplFunFromList theme []
|
||||||
theme = (XT.promptTheme fb) {promptKeymap = keymap}
|
theme = (XT.promptTheme fb) {promptKeymap = keymap}
|
||||||
keymap = M.fromList
|
keymap =
|
||||||
$ ((controlMask, xK_g), quit) :
|
M.fromList $
|
||||||
map (first $ (,) 0)
|
((controlMask, xK_g), quit)
|
||||||
|
: map
|
||||||
|
(first $ (,) 0)
|
||||||
[ (xK_p, sendMaybeAction Poweroff)
|
[ (xK_p, sendMaybeAction Poweroff)
|
||||||
, (xK_s, sendMaybeAction Shutdown)
|
, (xK_s, sendMaybeAction Shutdown)
|
||||||
, (xK_h, sendMaybeAction Hibernate)
|
, (xK_h, sendMaybeAction Hibernate)
|
||||||
|
|
|
@ -2,21 +2,19 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Concurrent module to handle events from acpid
|
-- Concurrent module to handle events from acpid
|
||||||
|
|
||||||
module XMonad.Internal.Concurrent.ACPIEvent
|
module XMonad.Internal.Concurrent.ACPIEvent
|
||||||
( runPowermon
|
( runPowermon
|
||||||
, runHandleACPI
|
, runHandleACPI
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
|
|
||||||
import Network.Socket
|
import Network.Socket
|
||||||
import Network.Socket.ByteString
|
import Network.Socket.ByteString
|
||||||
|
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.ByteString as B
|
import qualified RIO.ByteString as B
|
||||||
|
|
||||||
import XMonad.Core
|
import XMonad.Core
|
||||||
import XMonad.Internal.Command.Power
|
import XMonad.Internal.Command.Power
|
||||||
import XMonad.Internal.Concurrent.ClientMessage
|
import XMonad.Internal.Concurrent.ClientMessage
|
||||||
|
@ -24,12 +22,13 @@ import XMonad.Internal.Shell
|
||||||
import XMonad.Internal.Theme (FontBuilder)
|
import XMonad.Internal.Theme (FontBuilder)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Data structure to hold the ACPI events I care about
|
-- Data structure to hold the ACPI events I care about
|
||||||
--
|
--
|
||||||
-- Enumerate so these can be converted to strings and back when sent in a
|
-- Enumerate so these can be converted to strings and back when sent in a
|
||||||
-- ClientMessage event to X
|
-- ClientMessage event to X
|
||||||
|
|
||||||
data ACPIEvent = Power
|
data ACPIEvent
|
||||||
|
= Power
|
||||||
| Sleep
|
| Sleep
|
||||||
| LidClose
|
| LidClose
|
||||||
deriving (Eq)
|
deriving (Eq)
|
||||||
|
@ -45,7 +44,7 @@ instance Enum ACPIEvent where
|
||||||
fromEnum LidClose = 2
|
fromEnum LidClose = 2
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Internal functions
|
-- Internal functions
|
||||||
|
|
||||||
-- | Convert a string to an ACPI event (this string is assumed to come from
|
-- | Convert a string to an ACPI event (this string is assumed to come from
|
||||||
-- the acpid socket)
|
-- the acpid socket)
|
||||||
|
@ -103,7 +102,7 @@ handleACPI fb lock tag = do
|
||||||
lock
|
lock
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported API
|
-- Exported API
|
||||||
|
|
||||||
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
||||||
-- and send ClientMessage events when it receives them
|
-- and send ClientMessage events when it receives them
|
||||||
|
@ -114,7 +113,9 @@ runHandleACPI :: Always (String -> X ())
|
||||||
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
||||||
where
|
where
|
||||||
sf = Subfeature withLock "acpid prompt"
|
sf = Subfeature withLock "acpid prompt"
|
||||||
withLock = IORoot (uncurry handleACPI)
|
withLock =
|
||||||
$ And12 (,) promptFontDep $ Only
|
IORoot (uncurry handleACPI) $
|
||||||
$ IOSometimes runScreenLock id
|
And12 (,) promptFontDep $
|
||||||
|
Only $
|
||||||
|
IOSometimes runScreenLock id
|
||||||
fallback = Always_ $ FallbackAlone $ const skip
|
fallback = Always_ $ FallbackAlone $ const skip
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Core ClientMessage module to 'achieve' concurrency in XMonad
|
-- Core ClientMessage module to 'achieve' concurrency in XMonad
|
||||||
--
|
--
|
||||||
-- Since XMonad is single threaded, the only way to have multiple threads that
|
-- Since XMonad is single threaded, the only way to have multiple threads that
|
||||||
-- listen/react to non-X events is to spawn other threads the run outside of
|
-- listen/react to non-X events is to spawn other threads the run outside of
|
||||||
|
@ -19,26 +19,26 @@ module XMonad.Internal.Concurrent.ClientMessage
|
||||||
( XMsgType (..)
|
( XMsgType (..)
|
||||||
, sendXMsg
|
, sendXMsg
|
||||||
, splitXMsg
|
, splitXMsg
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Display
|
||||||
import Graphics.X11.Xlib.Event
|
import Graphics.X11.Xlib.Event
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
import Graphics.X11.Xlib.Types
|
import Graphics.X11.Xlib.Types
|
||||||
|
|
||||||
import RIO hiding (Display)
|
import RIO hiding (Display)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Data structure for the ClientMessage
|
-- Data structure for the ClientMessage
|
||||||
--
|
--
|
||||||
-- These are the "types" of client messages to send; add more here as needed
|
-- These are the "types" of client messages to send; add more here as needed
|
||||||
|
|
||||||
-- TODO is there a way to do this in the libraries that import this one?
|
-- TODO is there a way to do this in the libraries that import this one?
|
||||||
data XMsgType = ACPI
|
data XMsgType
|
||||||
|
= ACPI
|
||||||
| Workspace
|
| Workspace
|
||||||
| Unknown
|
| Unknown
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
@ -53,7 +53,7 @@ instance Enum XMsgType where
|
||||||
fromEnum Unknown = 2
|
fromEnum Unknown = 2
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported API
|
-- Exported API
|
||||||
|
|
||||||
-- | Given a string from the data field in a ClientMessage event, return the
|
-- | Given a string from the data field in a ClientMessage event, return the
|
||||||
-- type and payload
|
-- type and payload
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Automatically Manage Dynamic Workspaces
|
-- Automatically Manage Dynamic Workspaces
|
||||||
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
|
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
|
||||||
-- in the contrib library. The general behavior this allows:
|
-- in the contrib library. The general behavior this allows:
|
||||||
-- 1) launch app
|
-- 1) launch app
|
||||||
|
@ -31,34 +31,28 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
|
||||||
, runWorkspaceMon
|
, runWorkspaceMon
|
||||||
, spawnOrSwitch
|
, spawnOrSwitch
|
||||||
, doSink
|
, doSink
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import Data.List (deleteBy, find)
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Maybe
|
|
||||||
|
|
||||||
-- import Control.Concurrent
|
-- import Control.Concurrent
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
import Data.List (deleteBy, find)
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import Data.Maybe
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Types
|
||||||
|
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Display
|
||||||
import Graphics.X11.Xlib.Event
|
import Graphics.X11.Xlib.Event
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
import Graphics.X11.Xlib.Misc
|
import Graphics.X11.Xlib.Misc
|
||||||
import Graphics.X11.Xlib.Types
|
import Graphics.X11.Xlib.Types
|
||||||
|
|
||||||
import RIO hiding
|
import RIO hiding
|
||||||
( Display
|
( Display
|
||||||
, display
|
, display
|
||||||
)
|
)
|
||||||
import qualified RIO.Set as S
|
import qualified RIO.Set as S
|
||||||
|
|
||||||
import System.Process
|
import System.Process
|
||||||
|
|
||||||
import XMonad.Actions.DynamicWorkspaces
|
import XMonad.Actions.DynamicWorkspaces
|
||||||
import XMonad.Core
|
import XMonad.Core
|
||||||
( ManageHook
|
( ManageHook
|
||||||
|
@ -75,8 +69,8 @@ import XMonad.Operations
|
||||||
import qualified XMonad.StackSet as W
|
import qualified XMonad.StackSet as W
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dynamic Workspace datatype
|
-- Dynamic Workspace datatype
|
||||||
-- This hold all the data needed to tie an app to a particular dynamic workspace
|
-- This holds all the data needed to tie an app to a particular dynamic workspace
|
||||||
|
|
||||||
data DynWorkspace = DynWorkspace
|
data DynWorkspace = DynWorkspace
|
||||||
{ dwName :: String
|
{ dwName :: String
|
||||||
|
@ -89,7 +83,7 @@ data DynWorkspace = DynWorkspace
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Manager thread
|
-- Manager thread
|
||||||
-- The main thread that watches for new windows. When a match is found, this
|
-- The main thread that watches for new windows. When a match is found, this
|
||||||
-- thread spawns a new thread the waits for the PID of the window to exit. When
|
-- thread spawns a new thread the waits for the PID of the window to exit. When
|
||||||
-- the PID exits, it sends a ClientMessage event to X
|
-- the PID exits, it sends a ClientMessage event to X
|
||||||
|
@ -121,9 +115,9 @@ runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
|
||||||
withEvents dpy e = do
|
withEvents dpy e = do
|
||||||
ps <- newMVar S.empty
|
ps <- newMVar S.empty
|
||||||
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
|
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
|
||||||
runRIO c
|
runRIO c $
|
||||||
$ forever
|
forever $
|
||||||
$ handleEvent =<< io (nextEvent dpy e >> getEvent e)
|
handleEvent =<< io (nextEvent dpy e >> getEvent e)
|
||||||
|
|
||||||
handleEvent :: Event -> W ()
|
handleEvent :: Event -> W ()
|
||||||
|
|
||||||
|
@ -133,9 +127,10 @@ handleEvent MapNotifyEvent { ev_window = w } = do
|
||||||
dpy <- asks display
|
dpy <- asks display
|
||||||
hint <- io $ getClassHint dpy w
|
hint <- io $ getClassHint dpy w
|
||||||
dws <- asks dynWorkspaces
|
dws <- asks dynWorkspaces
|
||||||
let tag = M.lookup (resClass hint)
|
let tag =
|
||||||
$ M.fromList
|
M.lookup (resClass hint) $
|
||||||
$ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
|
M.fromList $
|
||||||
|
fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
|
||||||
forM_ tag $ \t -> do
|
forM_ tag $ \t -> do
|
||||||
a <- io $ internAtom dpy "_NET_WM_PID" False
|
a <- io $ internAtom dpy "_NET_WM_PID" False
|
||||||
pid <- io $ getWindowProperty32 dpy a w
|
pid <- io $ getWindowProperty32 dpy a w
|
||||||
|
@ -143,28 +138,32 @@ handleEvent MapNotifyEvent { ev_window = w } = do
|
||||||
-- ASSUMPTION windows will only have one PID at one time
|
-- ASSUMPTION windows will only have one PID at one time
|
||||||
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
|
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
handleEvent _ = return ()
|
handleEvent _ = return ()
|
||||||
|
|
||||||
withUniquePid :: Pid -> String -> W ()
|
withUniquePid :: Pid -> String -> W ()
|
||||||
withUniquePid pid tag = do
|
withUniquePid pid tag = do
|
||||||
ps <- asks curPIDs
|
ps <- asks curPIDs
|
||||||
pids <- readMVar ps
|
pids <- readMVar ps
|
||||||
io $ unless (pid `elem` pids) $ bracket_
|
io
|
||||||
|
$ unless (pid `elem` pids)
|
||||||
|
$ bracket_
|
||||||
(modifyMVar_ ps (return . S.insert pid))
|
(modifyMVar_ ps (return . S.insert pid))
|
||||||
(modifyMVar_ ps (return . S.delete pid))
|
(modifyMVar_ ps (return . S.delete pid))
|
||||||
$ waitUntilExit pid >> sendXMsg Workspace tag
|
$ waitUntilExit pid >> sendXMsg Workspace tag
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Launching apps
|
-- Launching apps
|
||||||
-- When launching apps on dymamic workspaces, first check if they are running
|
-- When launching apps on dymamic workspaces, first check if they are running
|
||||||
-- and launch if not, then switch to their workspace
|
-- and launch if not, then switch to their workspace
|
||||||
|
|
||||||
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
|
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
|
||||||
wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack)
|
wsOccupied tag ws =
|
||||||
|
elem tag $
|
||||||
|
map W.tag $
|
||||||
|
filter (isJust . W.stack)
|
||||||
-- list of all workspaces with windows on them
|
-- list of all workspaces with windows on them
|
||||||
-- TODO is there not a better way to do this?
|
-- TODO is there not a better way to do this?
|
||||||
$ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
|
$
|
||||||
|
W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
|
||||||
|
|
||||||
spawnOrSwitch :: WorkspaceId -> X () -> X ()
|
spawnOrSwitch :: WorkspaceId -> X () -> X ()
|
||||||
spawnOrSwitch tag cmd = do
|
spawnOrSwitch tag cmd = do
|
||||||
|
@ -172,7 +171,7 @@ spawnOrSwitch tag cmd = do
|
||||||
if occupied then windows $ W.view tag else cmd
|
if occupied then windows $ W.view tag else cmd
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Managehook
|
-- Managehook
|
||||||
-- Move windows to new workspace if they are part of a dynamic workspace
|
-- Move windows to new workspace if they are part of a dynamic workspace
|
||||||
|
|
||||||
-- shamelessly ripped off from appendWorkspace (this analogue doesn't exist)
|
-- shamelessly ripped off from appendWorkspace (this analogue doesn't exist)
|
||||||
|
@ -197,25 +196,27 @@ doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
|
||||||
Nothing -> s
|
Nothing -> s
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Eventhook
|
-- Eventhook
|
||||||
|
|
||||||
-- When an app is closed, this will respond the event that is sent in the main
|
-- When an app is closed, this will respond the event that is sent in the main
|
||||||
-- XMonad thread
|
-- XMonad thread
|
||||||
|
|
||||||
removeDynamicWorkspace :: WorkspaceId -> X ()
|
removeDynamicWorkspace :: WorkspaceId -> X ()
|
||||||
removeDynamicWorkspace target = windows removeIfEmpty
|
removeDynamicWorkspace target = windows removeIfEmpty
|
||||||
where
|
where
|
||||||
-- remove workspace if it is empty and if there are hidden workspaces
|
-- remove workspace if it is empty and if there are hidden workspaces
|
||||||
removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)}
|
removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)}
|
||||||
-- if hidden, delete from hidden
|
-- if hidden, delete from hidden
|
||||||
| Just x <- find isEmptyTarget hall
|
| Just x <- find isEmptyTarget hall =
|
||||||
= s { W.hidden = deleteBy (eq W.tag) x hall }
|
s {W.hidden = deleteBy (eq W.tag) x hall}
|
||||||
-- if visible, delete from visible and move first hidden to its place
|
-- if visible, delete from visible and move first hidden to its place
|
||||||
| Just x <- find (isEmptyTarget . W.workspace) vis
|
| Just x <- find (isEmptyTarget . W.workspace) vis =
|
||||||
= s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis
|
s
|
||||||
, W.hidden = hs }
|
{ W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis
|
||||||
|
, W.hidden = hs
|
||||||
|
}
|
||||||
-- if current, move the first hidden workspace to the current
|
-- if current, move the first hidden workspace to the current
|
||||||
| isEmptyTarget $ W.workspace $ W.current s
|
| isEmptyTarget $ W.workspace $ W.current s =
|
||||||
= s { W.current = (W.current s) { W.workspace = h }, W.hidden = hs }
|
s {W.current = (W.current s) {W.workspace = h}, W.hidden = hs}
|
||||||
-- otherwise do nothing
|
-- otherwise do nothing
|
||||||
| otherwise = s
|
| otherwise = s
|
||||||
removeIfEmpty s = s
|
removeIfEmpty s = s
|
||||||
|
|
|
@ -2,23 +2,21 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VirtualBox-specific functions
|
-- VirtualBox-specific functions
|
||||||
|
|
||||||
module XMonad.Internal.Concurrent.VirtualBox
|
module XMonad.Internal.Concurrent.VirtualBox
|
||||||
( vmExists
|
( vmExists
|
||||||
, vmInstanceConfig
|
, vmInstanceConfig
|
||||||
, qual
|
, qual
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
|
|
||||||
import Text.XML.Light
|
|
||||||
|
|
||||||
import RIO hiding (try)
|
import RIO hiding (try)
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
import Text.XML.Light
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
vmExists :: T.Text -> IO (Maybe Msg)
|
vmExists :: T.Text -> IO (Maybe Msg)
|
||||||
|
@ -41,10 +39,12 @@ vmDirectory = do
|
||||||
s <- tryIO $ readFile p
|
s <- tryIO $ readFile p
|
||||||
return $ case s of
|
return $ case s of
|
||||||
(Left _) -> Left "could not read VirtualBox config file"
|
(Left _) -> Left "could not read VirtualBox config file"
|
||||||
(Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
|
(Right x) ->
|
||||||
$ findDir =<< parseXMLDoc x
|
maybe (Left "Could not parse VirtualBox config file") Right $
|
||||||
|
findDir =<< parseXMLDoc x
|
||||||
where
|
where
|
||||||
findDir e = findAttr (unqual "defaultMachineFolder")
|
findDir e =
|
||||||
|
findAttr (unqual "defaultMachineFolder")
|
||||||
=<< findChild (qual e "SystemProperties")
|
=<< findChild (qual e "SystemProperties")
|
||||||
=<< findChild (qual e "Global") e
|
=<< findChild (qual e "Global") e
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for Clevo Keyboard control
|
-- DBus module for Clevo Keyboard control
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
( callGetBrightnessCK
|
( callGetBrightnessCK
|
||||||
|
@ -10,24 +10,21 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
, clevoKeyboardControls
|
, clevoKeyboardControls
|
||||||
, clevoKeyboardSignalDep
|
, clevoKeyboardSignalDep
|
||||||
, blPath
|
, blPath
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
|
import DBus
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
|
|
||||||
import DBus
|
|
||||||
|
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.Common
|
import XMonad.Internal.DBus.Brightness.Common
|
||||||
import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Low level sysfs functions
|
-- Low level sysfs functions
|
||||||
--
|
|
||||||
type Brightness = Float
|
type Brightness = Float
|
||||||
|
|
||||||
type RawBrightness = Int32
|
type RawBrightness = Int32
|
||||||
|
@ -84,7 +81,7 @@ decBrightness bounds = do
|
||||||
return b
|
return b
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus interface
|
-- DBus interface
|
||||||
|
|
||||||
blPath :: ObjectPath
|
blPath :: ObjectPath
|
||||||
blPath = objectPath_ "/clevo_keyboard"
|
blPath = objectPath_ "/clevo_keyboard"
|
||||||
|
@ -93,7 +90,8 @@ interface :: InterfaceName
|
||||||
interface = interfaceName_ "org.xmonad.Brightness"
|
interface = interfaceName_ "org.xmonad.Brightness"
|
||||||
|
|
||||||
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
|
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
|
||||||
clevoKeyboardConfig = BrightnessConfig
|
clevoKeyboardConfig =
|
||||||
|
BrightnessConfig
|
||||||
{ bcMin = minBrightness
|
{ bcMin = minBrightness
|
||||||
, bcMax = maxBrightness
|
, bcMax = maxBrightness
|
||||||
, bcInc = incBrightness
|
, bcInc = incBrightness
|
||||||
|
@ -107,7 +105,7 @@ clevoKeyboardConfig = BrightnessConfig
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- Exported haskell API
|
||||||
|
|
||||||
stateFileDep :: IODependency_
|
stateFileDep :: IODependency_
|
||||||
stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
|
stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
|
||||||
|
@ -119,8 +117,12 @@ clevoKeyboardSignalDep :: DBusDependency_ SesClient
|
||||||
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||||
|
|
||||||
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
|
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
|
||||||
exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
|
exportClevoKeyboard =
|
||||||
[stateFileDep, brightnessFileDep] clevoKeyboardConfig
|
brightnessExporter
|
||||||
|
xpfClevoBacklight
|
||||||
|
[]
|
||||||
|
[stateFileDep, brightnessFileDep]
|
||||||
|
clevoKeyboardConfig
|
||||||
|
|
||||||
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
|
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
|
||||||
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for DBus brightness controls
|
-- DBus module for DBus brightness controls
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Brightness.Common
|
module XMonad.Internal.DBus.Brightness.Common
|
||||||
( BrightnessConfig (..)
|
( BrightnessConfig (..)
|
||||||
|
@ -11,25 +11,22 @@ module XMonad.Internal.DBus.Brightness.Common
|
||||||
, callGetBrightness
|
, callGetBrightness
|
||||||
, matchSignal
|
, matchSignal
|
||||||
, signalDep
|
, signalDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
|
|
||||||
import Data.Int (Int32)
|
|
||||||
import Data.Internal.DBus
|
|
||||||
import Data.Internal.Dependency
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified DBus.Introspection as I
|
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 qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Core (io)
|
import XMonad.Core (io)
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | External API
|
-- External API
|
||||||
--
|
--
|
||||||
-- Define four methods to increase, decrease, maximize, or minimize the
|
-- Define four methods to increase, decrease, maximize, or minimize the
|
||||||
-- brightness. These methods will all return the current brightness as a 32-bit
|
-- brightness. These methods will all return the current brightness as a 32-bit
|
||||||
|
@ -56,7 +53,10 @@ data BrightnessControls = BrightnessControls
|
||||||
, bctlDec :: SometimesX
|
, bctlDec :: SometimesX
|
||||||
}
|
}
|
||||||
|
|
||||||
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
|
brightnessControls
|
||||||
|
:: XPQuery
|
||||||
|
-> BrightnessConfig a b
|
||||||
|
-> Maybe SesClient
|
||||||
-> BrightnessControls
|
-> BrightnessControls
|
||||||
brightnessControls q bc cl =
|
brightnessControls q bc cl =
|
||||||
BrightnessControls
|
BrightnessControls
|
||||||
|
@ -68,7 +68,10 @@ brightnessControls q bc cl =
|
||||||
where
|
where
|
||||||
cb = callBacklight q cl bc
|
cb = callBacklight q cl bc
|
||||||
|
|
||||||
callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
|
callGetBrightness
|
||||||
|
:: (SafeClient c, Num n)
|
||||||
|
=> BrightnessConfig a b
|
||||||
|
-> c
|
||||||
-> IO (Maybe n)
|
-> IO (Maybe n)
|
||||||
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
|
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
|
||||||
either (const Nothing) bodyGetBrightness
|
either (const Nothing) bodyGetBrightness
|
||||||
|
@ -78,23 +81,34 @@ signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
|
||||||
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
||||||
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
||||||
|
|
||||||
matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b
|
matchSignal
|
||||||
-> (Maybe n-> IO ()) -> c -> IO ()
|
:: (SafeClient c, Num n)
|
||||||
|
=> BrightnessConfig a b
|
||||||
|
-> (Maybe n -> IO ())
|
||||||
|
-> c
|
||||||
|
-> IO ()
|
||||||
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
|
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
|
||||||
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
|
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
|
||||||
where
|
where
|
||||||
-- TODO add busname to this
|
-- TODO add busname to this
|
||||||
brMatcher = matchAny
|
brMatcher =
|
||||||
|
matchAny
|
||||||
{ matchPath = Just p
|
{ matchPath = Just p
|
||||||
, matchInterface = Just i
|
, matchInterface = Just i
|
||||||
, matchMember = Just memCur
|
, matchMember = Just memCur
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Internal DBus Crap
|
-- Internal DBus Crap
|
||||||
|
|
||||||
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
|
brightnessExporter
|
||||||
-> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
|
:: RealFrac b
|
||||||
|
=> XPQuery
|
||||||
|
-> [Fulfillment]
|
||||||
|
-> [IODependency_]
|
||||||
|
-> BrightnessConfig a b
|
||||||
|
-> Maybe SesClient
|
||||||
|
-> SometimesIO
|
||||||
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
||||||
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
||||||
where
|
where
|
||||||
|
@ -108,7 +122,10 @@ exportBrightnessControls' bc cl = io $ do
|
||||||
let bounds = (bcMinRaw bc, maxval)
|
let bounds = (bcMinRaw bc, maxval)
|
||||||
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
|
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
|
||||||
let funget = bcGet bc
|
let funget = bcGet bc
|
||||||
export ses (bcPath bc) defaultInterface
|
export
|
||||||
|
ses
|
||||||
|
(bcPath bc)
|
||||||
|
defaultInterface
|
||||||
{ interfaceName = bcInterface bc
|
{ interfaceName = bcInterface bc
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
[ autoMethod' memMax bcMax
|
[ autoMethod' memMax bcMax
|
||||||
|
@ -120,11 +137,11 @@ exportBrightnessControls' bc cl = io $ do
|
||||||
, interfaceSignals = [sig]
|
, interfaceSignals = [sig]
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
sig = I.Signal
|
sig =
|
||||||
|
I.Signal
|
||||||
{ I.signalName = memCur
|
{ I.signalName = memCur
|
||||||
, I.signalArgs =
|
, I.signalArgs =
|
||||||
[
|
[ I.SignalArg
|
||||||
I.SignalArg
|
|
||||||
{ I.signalArgName = "brightness"
|
{ I.signalArgName = "brightness"
|
||||||
, I.signalArgType = TypeInt32
|
, I.signalArgType = TypeInt32
|
||||||
}
|
}
|
||||||
|
@ -137,11 +154,23 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
|
||||||
where
|
where
|
||||||
sig = signal p i memCur
|
sig = signal p i memCur
|
||||||
|
|
||||||
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
|
callBacklight
|
||||||
-> MemberName -> SometimesX
|
:: XPQuery
|
||||||
callBacklight q cl BrightnessConfig { bcPath = p
|
-> Maybe SesClient
|
||||||
|
-> BrightnessConfig a b
|
||||||
|
-> T.Text
|
||||||
|
-> MemberName
|
||||||
|
-> SometimesX
|
||||||
|
callBacklight
|
||||||
|
q
|
||||||
|
cl
|
||||||
|
BrightnessConfig
|
||||||
|
{ bcPath = p
|
||||||
, bcInterface = i
|
, bcInterface = i
|
||||||
, bcName = n } controlName m =
|
, bcName = n
|
||||||
|
}
|
||||||
|
controlName
|
||||||
|
m =
|
||||||
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
|
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
|
||||||
where
|
where
|
||||||
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
||||||
|
@ -152,7 +181,7 @@ bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||||
bodyGetBrightness _ = Nothing
|
bodyGetBrightness _ = Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Members
|
-- DBus Members
|
||||||
|
|
||||||
memCur :: MemberName
|
memCur :: MemberName
|
||||||
memCur = memberName_ "CurrentBrightness"
|
memCur = memberName_ "CurrentBrightness"
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for Intel Backlight control
|
-- DBus module for Intel Backlight control
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Brightness.IntelBacklight
|
module XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
( callGetBrightnessIB
|
( callGetBrightnessIB
|
||||||
|
@ -10,22 +10,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
, intelBacklightControls
|
, intelBacklightControls
|
||||||
, intelBacklightSignalDep
|
, intelBacklightSignalDep
|
||||||
, blPath
|
, blPath
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import DBus
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
|
|
||||||
import DBus
|
|
||||||
|
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.Common
|
import XMonad.Internal.DBus.Brightness.Common
|
||||||
import XMonad.Internal.IO
|
import XMonad.Internal.IO
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Low level sysfs functions
|
-- Low level sysfs functions
|
||||||
--
|
|
||||||
type Brightness = Float
|
type Brightness = Float
|
||||||
|
|
||||||
type RawBrightness = Int32
|
type RawBrightness = Int32
|
||||||
|
@ -66,7 +64,7 @@ decBrightness :: RawBounds -> IO Brightness
|
||||||
decBrightness = decPercent steps curFile
|
decBrightness = decPercent steps curFile
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus interface
|
-- DBus interface
|
||||||
|
|
||||||
blPath :: ObjectPath
|
blPath :: ObjectPath
|
||||||
blPath = objectPath_ "/intelbacklight"
|
blPath = objectPath_ "/intelbacklight"
|
||||||
|
@ -75,7 +73,8 @@ interface :: InterfaceName
|
||||||
interface = interfaceName_ "org.xmonad.Brightness"
|
interface = interfaceName_ "org.xmonad.Brightness"
|
||||||
|
|
||||||
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
|
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
|
||||||
intelBacklightConfig = BrightnessConfig
|
intelBacklightConfig =
|
||||||
|
BrightnessConfig
|
||||||
{ bcMin = minBrightness
|
{ bcMin = minBrightness
|
||||||
, bcMax = maxBrightness
|
, bcMax = maxBrightness
|
||||||
, bcInc = incBrightness
|
, bcInc = incBrightness
|
||||||
|
@ -89,7 +88,7 @@ intelBacklightConfig = BrightnessConfig
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- Exported haskell API
|
||||||
|
|
||||||
curFileDep :: IODependency_
|
curFileDep :: IODependency_
|
||||||
curFileDep = pathRW curFile []
|
curFileDep = pathRW curFile []
|
||||||
|
@ -101,8 +100,12 @@ intelBacklightSignalDep :: DBusDependency_ SesClient
|
||||||
intelBacklightSignalDep = signalDep intelBacklightConfig
|
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||||
|
|
||||||
exportIntelBacklight :: Maybe SesClient -> SometimesIO
|
exportIntelBacklight :: Maybe SesClient -> SometimesIO
|
||||||
exportIntelBacklight = brightnessExporter xpfIntelBacklight []
|
exportIntelBacklight =
|
||||||
[curFileDep, maxFileDep] intelBacklightConfig
|
brightnessExporter
|
||||||
|
xpfIntelBacklight
|
||||||
|
[]
|
||||||
|
[curFileDep, maxFileDep]
|
||||||
|
intelBacklightConfig
|
||||||
|
|
||||||
intelBacklightControls :: Maybe SesClient -> BrightnessControls
|
intelBacklightControls :: Maybe SesClient -> BrightnessControls
|
||||||
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | High-level interface for managing XMonad's DBus
|
-- High-level interface for managing XMonad's DBus
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Common
|
module XMonad.Internal.DBus.Common
|
||||||
( xmonadBusName
|
( xmonadBusName
|
||||||
|
@ -7,7 +7,8 @@ module XMonad.Internal.DBus.Common
|
||||||
, notifyBus
|
, notifyBus
|
||||||
, notifyPath
|
, notifyPath
|
||||||
, networkManagerBus
|
, networkManagerBus
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
|
||||||
|
@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
|
||||||
|
|
||||||
networkManagerBus :: BusName
|
networkManagerBus :: BusName
|
||||||
networkManagerBus = busName_ "org.freedesktop.NetworkManager"
|
networkManagerBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | High-level interface for managing XMonad's DBus
|
-- High-level interface for managing XMonad's DBus
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Control
|
module XMonad.Internal.DBus.Control
|
||||||
( Client
|
( Client
|
||||||
|
@ -15,16 +15,14 @@ module XMonad.Internal.DBus.Control
|
||||||
, withDBusClient_
|
, withDBusClient_
|
||||||
, disconnect
|
, disconnect
|
||||||
, dbusExporters
|
, dbusExporters
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
|
||||||
import Data.Internal.DBus
|
|
||||||
import Data.Internal.Dependency
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
@ -73,10 +71,12 @@ requestXMonadName :: SesClient -> IO ()
|
||||||
requestXMonadName ses = do
|
requestXMonadName ses = do
|
||||||
res <- requestName (toClient ses) xmonadBusName []
|
res <- requestName (toClient ses) xmonadBusName []
|
||||||
-- TODO if the client is not released on shutdown the owner will be different
|
-- TODO if the client is not released on shutdown the owner will be different
|
||||||
let msg | res == NamePrimaryOwner = Nothing
|
let msg
|
||||||
|
| res == NamePrimaryOwner = Nothing
|
||||||
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
|
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
|
||||||
| res == NameInQueue
|
| res == NameInQueue
|
||||||
|| res == NameExists = Just $ "another process owns " ++ xn
|
|| res == NameExists =
|
||||||
|
Just $ "another process owns " ++ xn
|
||||||
| otherwise = Just $ "unknown error when requesting " ++ xn
|
| otherwise = Just $ "unknown error when requesting " ++ xn
|
||||||
forM_ msg putStrLn
|
forM_ msg putStrLn
|
||||||
where
|
where
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Module for monitoring removable drive events
|
-- Module for monitoring removable drive events
|
||||||
--
|
--
|
||||||
-- Currently, its only purpose is to play Super Mario sounds when a drive is
|
-- Currently, its only purpose is to play Super Mario sounds when a drive is
|
||||||
-- inserted or removed. Why? Because I can.
|
-- inserted or removed. Why? Because I can.
|
||||||
|
@ -9,14 +9,11 @@
|
||||||
module XMonad.Internal.DBus.Removable (runRemovableMon) where
|
module XMonad.Internal.DBus.Removable (runRemovableMon) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
|
import DBus.Client
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import Data.Map.Strict (Map, member)
|
import Data.Map.Strict (Map, member)
|
||||||
|
|
||||||
import DBus
|
|
||||||
import DBus.Client
|
|
||||||
|
|
||||||
import XMonad.Core (io)
|
import XMonad.Core (io)
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
|
|
||||||
|
@ -51,7 +48,8 @@ driveRemovedSound :: FilePath
|
||||||
driveRemovedSound = "smb_pipe.wav"
|
driveRemovedSound = "smb_pipe.wav"
|
||||||
|
|
||||||
ruleUdisks :: MatchRule
|
ruleUdisks :: MatchRule
|
||||||
ruleUdisks = matchAny
|
ruleUdisks =
|
||||||
|
matchAny
|
||||||
{ matchPath = Just path
|
{ matchPath = Just path
|
||||||
, matchInterface = Just interface
|
, matchInterface = Just interface
|
||||||
}
|
}
|
||||||
|
@ -60,12 +58,18 @@ driveFlag :: String
|
||||||
driveFlag = "org.freedesktop.UDisks2.Drive"
|
driveFlag = "org.freedesktop.UDisks2.Drive"
|
||||||
|
|
||||||
addedHasDrive :: [Variant] -> Bool
|
addedHasDrive :: [Variant] -> Bool
|
||||||
addedHasDrive [_, a] = maybe False (member driveFlag)
|
addedHasDrive [_, a] =
|
||||||
|
maybe
|
||||||
|
False
|
||||||
|
(member driveFlag)
|
||||||
(fromVariant a :: Maybe (Map String (Map String Variant)))
|
(fromVariant a :: Maybe (Map String (Map String Variant)))
|
||||||
addedHasDrive _ = False
|
addedHasDrive _ = False
|
||||||
|
|
||||||
removedHasDrive :: [Variant] -> Bool
|
removedHasDrive :: [Variant] -> Bool
|
||||||
removedHasDrive [_, a] = maybe False (driveFlag `elem`)
|
removedHasDrive [_, a] =
|
||||||
|
maybe
|
||||||
|
False
|
||||||
|
(driveFlag `elem`)
|
||||||
(fromVariant a :: Maybe [String])
|
(fromVariant a :: Maybe [String])
|
||||||
removedHasDrive _ = False
|
removedHasDrive _ = False
|
||||||
|
|
||||||
|
@ -81,8 +85,10 @@ listenDevices cl = do
|
||||||
addMatch' memAdded driveInsertedSound addedHasDrive
|
addMatch' memAdded driveInsertedSound addedHasDrive
|
||||||
addMatch' memRemoved driveRemovedSound removedHasDrive
|
addMatch' memRemoved driveRemovedSound removedHasDrive
|
||||||
where
|
where
|
||||||
addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
|
addMatch' m p f =
|
||||||
$ playSoundMaybe p . f . signalBody
|
void $
|
||||||
|
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
|
||||||
|
playSoundMaybe p . f . signalBody
|
||||||
|
|
||||||
runRemovableMon :: Maybe SysClient -> SometimesIO
|
runRemovableMon :: Maybe SysClient -> SometimesIO
|
||||||
runRemovableMon cl =
|
runRemovableMon cl =
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for X11 screensave/DPMS control
|
-- DBus module for X11 screensave/DPMS control
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Screensaver
|
module XMonad.Internal.DBus.Screensaver
|
||||||
( exportScreensaver
|
( exportScreensaver
|
||||||
|
@ -9,25 +9,22 @@ module XMonad.Internal.DBus.Screensaver
|
||||||
, callQuery
|
, callQuery
|
||||||
, matchSignal
|
, matchSignal
|
||||||
, ssSignalDep
|
, ssSignalDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import Data.Internal.DBus
|
|
||||||
import Data.Internal.Dependency
|
|
||||||
|
|
||||||
import RIO
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
import qualified DBus.Introspection as I
|
import qualified DBus.Introspection as I
|
||||||
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import Graphics.X11.XScreenSaver
|
import Graphics.X11.XScreenSaver
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Display
|
||||||
|
import RIO
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Low-level functions
|
-- Low-level functions
|
||||||
|
|
||||||
type SSState = Bool -- true is enabled
|
type SSState = Bool -- true is enabled
|
||||||
|
|
||||||
|
@ -56,7 +53,7 @@ query = do
|
||||||
Nothing -> False
|
Nothing -> False
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Interface
|
-- DBus Interface
|
||||||
--
|
--
|
||||||
-- Define a methods to toggle the screensaver. This methods will emit signal
|
-- Define a methods to toggle the screensaver. This methods will emit signal
|
||||||
-- with the new state when called. Define another method to get the current
|
-- with the new state when called. Define another method to get the current
|
||||||
|
@ -81,7 +78,8 @@ sigCurrentState :: Signal
|
||||||
sigCurrentState = signal ssPath interface memState
|
sigCurrentState = signal ssPath interface memState
|
||||||
|
|
||||||
ruleCurrentState :: MatchRule
|
ruleCurrentState :: MatchRule
|
||||||
ruleCurrentState = matchAny
|
ruleCurrentState =
|
||||||
|
matchAny
|
||||||
{ matchPath = Just ssPath
|
{ matchPath = Just ssPath
|
||||||
, matchInterface = Just interface
|
, matchInterface = Just interface
|
||||||
, matchMember = Just memState
|
, matchMember = Just memState
|
||||||
|
@ -95,14 +93,19 @@ bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
|
||||||
bodyGetCurrentState _ = Nothing
|
bodyGetCurrentState _ = Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- Exported haskell API
|
||||||
|
|
||||||
exportScreensaver :: Maybe SesClient -> SometimesIO
|
exportScreensaver :: Maybe SesClient -> SometimesIO
|
||||||
exportScreensaver ses =
|
exportScreensaver ses =
|
||||||
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
||||||
where
|
where
|
||||||
cmd cl = let cl' = toClient cl in
|
cmd cl =
|
||||||
liftIO $ export cl' ssPath defaultInterface
|
let cl' = toClient cl
|
||||||
|
in liftIO $
|
||||||
|
export
|
||||||
|
cl'
|
||||||
|
ssPath
|
||||||
|
defaultInterface
|
||||||
{ interfaceName = interface
|
{ interfaceName = interface
|
||||||
, interfaceMethods =
|
, interfaceMethods =
|
||||||
[ autoMethod memToggle $ emitState cl' =<< toggle
|
[ autoMethod memToggle $ emitState cl' =<< toggle
|
||||||
|
@ -110,11 +113,11 @@ exportScreensaver ses =
|
||||||
]
|
]
|
||||||
, interfaceSignals = [sig]
|
, interfaceSignals = [sig]
|
||||||
}
|
}
|
||||||
sig = I.Signal
|
sig =
|
||||||
|
I.Signal
|
||||||
{ I.signalName = memState
|
{ I.signalName = memState
|
||||||
, I.signalArgs =
|
, I.signalArgs =
|
||||||
[
|
[ I.SignalArg
|
||||||
I.SignalArg
|
|
||||||
{ I.signalArgName = "enabled"
|
{ I.signalArgName = "enabled"
|
||||||
, I.signalArgType = TypeBoolean
|
, I.signalArgType = TypeBoolean
|
||||||
}
|
}
|
||||||
|
@ -124,8 +127,15 @@ exportScreensaver ses =
|
||||||
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
||||||
|
|
||||||
callToggle :: Maybe SesClient -> SometimesX
|
callToggle :: Maybe SesClient -> SometimesX
|
||||||
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
|
callToggle =
|
||||||
xmonadBusName ssPath interface memToggle
|
sometimesEndpoint
|
||||||
|
"screensaver toggle"
|
||||||
|
"dbus switch"
|
||||||
|
[]
|
||||||
|
xmonadBusName
|
||||||
|
ssPath
|
||||||
|
interface
|
||||||
|
memToggle
|
||||||
|
|
||||||
callQuery :: SesClient -> IO (Maybe SSState)
|
callQuery :: SesClient -> IO (Maybe SSState)
|
||||||
callQuery ses = do
|
callQuery ses = do
|
||||||
|
@ -133,8 +143,12 @@ callQuery ses = do
|
||||||
return $ either (const Nothing) bodyGetCurrentState reply
|
return $ either (const Nothing) bodyGetCurrentState reply
|
||||||
|
|
||||||
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
|
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
|
||||||
matchSignal cb ses = void $ addMatchCallback ruleCurrentState
|
matchSignal cb ses =
|
||||||
(cb . bodyGetCurrentState) ses
|
void $
|
||||||
|
addMatchCallback
|
||||||
|
ruleCurrentState
|
||||||
|
(cb . bodyGetCurrentState)
|
||||||
|
ses
|
||||||
|
|
||||||
ssSignalDep :: DBusDependency_ SesClient
|
ssSignalDep :: DBusDependency_ SesClient
|
||||||
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
|
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Random IO-ish functions used throughtout xmonad
|
-- Random IO-ish functions used throughtout xmonad
|
||||||
--
|
--
|
||||||
-- Most (probably all) of these functions are intended to work with sysfs where
|
-- Most (probably all) of these functions are intended to work with sysfs where
|
||||||
-- some safe assumptions can be made about file contents.
|
-- some safe assumptions can be made about file contents.
|
||||||
|
@ -22,20 +22,19 @@ module XMonad.Internal.IO
|
||||||
, PermResult (..)
|
, PermResult (..)
|
||||||
, getPermissionsSafe
|
, getPermissionsSafe
|
||||||
, waitUntilExit
|
, waitUntilExit
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Text (pack, unpack)
|
import Data.Text (pack, unpack)
|
||||||
import Data.Text.IO as T (readFile, writeFile)
|
import Data.Text.IO as T (readFile, writeFile)
|
||||||
|
|
||||||
import RIO
|
import RIO
|
||||||
import RIO.Directory
|
import RIO.Directory
|
||||||
import RIO.FilePath
|
import RIO.FilePath
|
||||||
|
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | read
|
-- read
|
||||||
|
|
||||||
readInt :: (Read a, Integral a) => FilePath -> IO a
|
readInt :: (Read a, Integral a) => FilePath -> IO a
|
||||||
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
|
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
|
||||||
|
@ -44,7 +43,7 @@ readBool :: FilePath -> IO Bool
|
||||||
readBool = fmap (== (1 :: Int)) . readInt
|
readBool = fmap (== (1 :: Int)) . readInt
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | write
|
-- write
|
||||||
|
|
||||||
writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
|
writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
|
||||||
writeInt f = T.writeFile f . pack . show
|
writeInt f = T.writeFile f . pack . show
|
||||||
|
@ -53,16 +52,16 @@ writeBool :: FilePath -> Bool -> IO ()
|
||||||
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
|
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | percent-based read/write
|
-- percent-based read/write
|
||||||
--
|
--
|
||||||
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
|
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
|
||||||
-- value. Assume that the file being read has a min of 0 and an unchanging max
|
-- value. Assume that the file being read has a min of 0 and an unchanging max
|
||||||
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
||||||
-- (percent).
|
-- (percent).
|
||||||
|
|
||||||
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
|
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
|
||||||
rawToPercent (lower, upper) raw =
|
rawToPercent (lower, upper) raw =
|
||||||
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
||||||
|
|
||||||
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
|
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
|
||||||
|
|
||||||
readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
||||||
|
@ -71,12 +70,14 @@ readPercent bounds path = do
|
||||||
return $ rawToPercent bounds (i :: Integer)
|
return $ rawToPercent bounds (i :: Integer)
|
||||||
|
|
||||||
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
|
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
|
||||||
percentToRaw (lower, upper) perc = round $
|
percentToRaw (lower, upper) perc =
|
||||||
|
round $
|
||||||
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
|
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
|
||||||
|
|
||||||
writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
|
writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
|
||||||
writePercent bounds path perc = do
|
writePercent bounds path perc = do
|
||||||
let t | perc > 100 = 100
|
let t
|
||||||
|
| perc > 100 = 100
|
||||||
| perc < 0 = 0
|
| perc < 0 = 0
|
||||||
| otherwise = perc
|
| otherwise = perc
|
||||||
writeInt path (percentToRaw bounds t :: Int)
|
writeInt path (percentToRaw bounds t :: Int)
|
||||||
|
@ -88,9 +89,15 @@ writePercentMin bounds path = writePercent bounds path 0
|
||||||
writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
||||||
writePercentMax bounds path = writePercent bounds path 100
|
writePercentMax bounds path = writePercent bounds path 100
|
||||||
|
|
||||||
shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath
|
shiftPercent
|
||||||
-> (a, a) -> IO b
|
:: (Integral a, RealFrac b)
|
||||||
shiftPercent f steps path bounds = writePercent bounds path . f stepsize
|
=> (b -> b -> b)
|
||||||
|
-> Int
|
||||||
|
-> FilePath
|
||||||
|
-> (a, a)
|
||||||
|
-> IO b
|
||||||
|
shiftPercent f steps path bounds =
|
||||||
|
writePercent bounds path . f stepsize
|
||||||
=<< readPercent bounds path
|
=<< readPercent bounds path
|
||||||
where
|
where
|
||||||
stepsize = 100 / fromIntegral steps
|
stepsize = 100 / fromIntegral steps
|
||||||
|
@ -102,7 +109,7 @@ decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
|
||||||
decPercent = shiftPercent subtract -- silly (-) operator thingy error
|
decPercent = shiftPercent subtract -- silly (-) operator thingy error
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | permission query
|
-- permission query
|
||||||
|
|
||||||
data PermResult a = PermResult a | NotFoundError | PermError
|
data PermResult a = PermResult a | NotFoundError | PermError
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for formatting and sending notifications
|
-- Functions for formatting and sending notifications
|
||||||
--
|
--
|
||||||
-- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for
|
-- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for
|
||||||
-- notifications (just formation them into 'notify-send' commands and spawn a
|
-- notifications (just formation them into 'notify-send' commands and spawn a
|
||||||
|
@ -16,31 +16,34 @@ module XMonad.Internal.Notify
|
||||||
, defNoteError
|
, defNoteError
|
||||||
, fmtNotifyCmd
|
, fmtNotifyCmd
|
||||||
, spawnNotify
|
, spawnNotify
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import DBus.Notify
|
import DBus.Notify
|
||||||
|
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Some nice default notes
|
-- Some nice default notes
|
||||||
|
|
||||||
defNote :: Note
|
defNote :: Note
|
||||||
defNote = blankNote {summary = "\"xmonad\""}
|
defNote = blankNote {summary = "\"xmonad\""}
|
||||||
|
|
||||||
defNoteInfo :: Note
|
defNoteInfo :: Note
|
||||||
defNoteInfo = defNote
|
defNoteInfo =
|
||||||
{ appImage = Just $ Icon "dialog-information-symbolic" }
|
defNote
|
||||||
|
{ appImage = Just $ Icon "dialog-information-symbolic"
|
||||||
|
}
|
||||||
|
|
||||||
defNoteError :: Note
|
defNoteError :: Note
|
||||||
defNoteError = defNote
|
defNoteError =
|
||||||
{ appImage = Just $ Icon "dialog-error-symbolic" }
|
defNote
|
||||||
|
{ appImage = Just $ Icon "dialog-error-symbolic"
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Format a 'notify-send' command to be send to the shell
|
-- Format a 'notify-send' command to be send to the shell
|
||||||
|
|
||||||
parseBody :: Body -> Maybe T.Text
|
parseBody :: Body -> Maybe T.Text
|
||||||
parseBody (Text s) = Just $ T.pack s
|
parseBody (Text s) = Just $ T.pack s
|
||||||
|
@ -58,6 +61,6 @@ fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
|
||||||
-- TODO add the rest of the options as needed
|
-- TODO add the rest of the options as needed
|
||||||
getSummary = (: []) . doubleQuote . T.pack . summary
|
getSummary = (: []) . doubleQuote . T.pack . summary
|
||||||
getIcon n' =
|
getIcon n' =
|
||||||
maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }])
|
maybe [] (\i -> ["-i", T.pack $ case i of Icon s -> s; File s -> s]) $
|
||||||
$ appImage n'
|
appImage n'
|
||||||
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'
|
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'
|
||||||
|
|
|
@ -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 #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
-- Functions for formatting and spawning shell commands
|
||||||
|
|
||||||
module XMonad.Internal.Shell
|
module XMonad.Internal.Shell
|
||||||
( fmtCmd
|
( fmtCmd
|
||||||
, spawnCmd
|
, spawnCmd
|
||||||
|
@ -68,80 +17,117 @@ module XMonad.Internal.Shell
|
||||||
, (#!||)
|
, (#!||)
|
||||||
, (#!|)
|
, (#!|)
|
||||||
, (#!>>)
|
, (#!>>)
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import qualified System.Process.Typed as P
|
import qualified System.Process.Typed as P
|
||||||
|
|
||||||
import qualified XMonad.Core as X
|
import qualified XMonad.Core as X
|
||||||
import qualified XMonad.Util.Run as XR
|
import qualified XMonad.Util.Run as XR
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
-- | Fork a new process and wait for its exit code.
|
||||||
-- | Opening subshell
|
--
|
||||||
-- https://github.com/xmonad/xmonad/issues/113
|
-- 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 :: IO a -> IO a
|
||||||
withDefaultSignalHandlers =
|
withDefaultSignalHandlers =
|
||||||
bracket_ X.uninstallSignalHandlers X.installSignalHandlers
|
bracket_ X.uninstallSignalHandlers X.installSignalHandlers
|
||||||
|
|
||||||
|
-- | Set a child process to create a new group and session
|
||||||
addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z
|
addGroupSession :: P.ProcessConfig x y z -> P.ProcessConfig x y z
|
||||||
addGroupSession = P.setCreateGroup True . P.setNewSession True
|
addGroupSession = P.setCreateGroup True . P.setNewSession True
|
||||||
|
|
||||||
runProcess :: P.ProcessConfig a b c -> IO ExitCode
|
-- | Create a 'ProcessConfig' for a shell command
|
||||||
runProcess = withDefaultSignalHandlers . P.runProcess
|
|
||||||
|
|
||||||
shell :: T.Text -> P.ProcessConfig () () ()
|
shell :: T.Text -> P.ProcessConfig () () ()
|
||||||
shell = addGroupSession . P.shell . T.unpack
|
shell = addGroupSession . P.shell . T.unpack
|
||||||
|
|
||||||
|
-- | Create a 'ProcessConfig' for a command with arguments
|
||||||
proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
|
proc :: FilePath -> [T.Text] -> P.ProcessConfig () () ()
|
||||||
proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
|
proc cmd args = addGroupSession $ P.proc cmd (T.unpack <$> args)
|
||||||
|
|
||||||
|
-- | Run 'XMonad.Core.spawn' with 'Text' input.
|
||||||
spawn :: MonadIO m => T.Text -> m ()
|
spawn :: MonadIO m => T.Text -> m ()
|
||||||
spawn = X.spawn . T.unpack
|
spawn = X.spawn . T.unpack
|
||||||
|
|
||||||
-- spawnAt :: MonadIO m => FilePath -> T.Text -> m ()
|
-- | Run 'XMonad.Run.Utils.spawnPipe' with 'Text' input.
|
||||||
-- spawnAt fp = liftIO . void . startProcess . P.setWorkingDir fp . shell
|
|
||||||
|
|
||||||
spawnPipe :: MonadIO m => T.Text -> m Handle
|
spawnPipe :: MonadIO m => T.Text -> m Handle
|
||||||
spawnPipe = XR.spawnPipe . T.unpack
|
spawnPipe = XR.spawnPipe . T.unpack
|
||||||
|
|
||||||
|
-- | Run 'XMonad.Core.spawn' with a command and arguments
|
||||||
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
|
spawnCmd :: MonadIO m => FilePath -> [T.Text] -> m ()
|
||||||
spawnCmd cmd = spawn . fmtCmd cmd
|
spawnCmd cmd = spawn . fmtCmd cmd
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
-- | Format a command and list of arguments as 'Text'
|
||||||
-- | Formatting commands
|
|
||||||
|
|
||||||
fmtCmd :: FilePath -> [T.Text] -> T.Text
|
fmtCmd :: FilePath -> [T.Text] -> T.Text
|
||||||
fmtCmd cmd args = T.unwords $ T.pack cmd : args
|
fmtCmd cmd args = T.unwords $ T.pack cmd : args
|
||||||
|
|
||||||
op :: T.Text -> T.Text -> T.Text -> T.Text
|
op :: T.Text -> T.Text -> T.Text -> T.Text
|
||||||
op a x b = T.unwords [a, x, b]
|
op a x b = T.unwords [a, x, b]
|
||||||
|
|
||||||
|
-- | Format two shell expressions separated by "&&"
|
||||||
(#!&&) :: T.Text -> T.Text -> T.Text
|
(#!&&) :: T.Text -> T.Text -> T.Text
|
||||||
cmdA #!&& cmdB = op cmdA "&&" cmdB
|
cmdA #!&& cmdB = op cmdA "&&" cmdB
|
||||||
|
|
||||||
infixr 0 #!&&
|
infixr 0 #!&&
|
||||||
|
|
||||||
|
-- | Format two shell expressions separated by "|"
|
||||||
(#!|) :: T.Text -> T.Text -> T.Text
|
(#!|) :: T.Text -> T.Text -> T.Text
|
||||||
cmdA #!| cmdB = op cmdA "|" cmdB
|
cmdA #!| cmdB = op cmdA "|" cmdB
|
||||||
|
|
||||||
infixr 0 #!|
|
infixr 0 #!|
|
||||||
|
|
||||||
|
-- | Format two shell expressions separated by "||"
|
||||||
(#!||) :: T.Text -> T.Text -> T.Text
|
(#!||) :: T.Text -> T.Text -> T.Text
|
||||||
cmdA #!|| cmdB = op cmdA "||" cmdB
|
cmdA #!|| cmdB = op cmdA "||" cmdB
|
||||||
|
|
||||||
infixr 0 #!||
|
infixr 0 #!||
|
||||||
|
|
||||||
|
-- | Format two shell expressions separated by ";"
|
||||||
(#!>>) :: T.Text -> T.Text -> T.Text
|
(#!>>) :: T.Text -> T.Text -> T.Text
|
||||||
cmdA #!>> cmdB = op cmdA ";" cmdB
|
cmdA #!>> cmdB = op cmdA ";" cmdB
|
||||||
|
|
||||||
infixr 0 #!>>
|
infixr 0 #!>>
|
||||||
|
|
||||||
|
-- | Wrap input in double quotes
|
||||||
doubleQuote :: T.Text -> T.Text
|
doubleQuote :: T.Text -> T.Text
|
||||||
doubleQuote s = T.concat ["\"", s, "\""]
|
doubleQuote s = T.concat ["\"", s, "\""]
|
||||||
|
|
||||||
|
-- | Wrap input in single quotes
|
||||||
singleQuote :: T.Text -> T.Text
|
singleQuote :: T.Text -> T.Text
|
||||||
singleQuote s = T.concat ["'", s, "'"]
|
singleQuote s = T.concat ["'", s, "'"]
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Theme for XMonad and Xmobar
|
-- Theme for XMonad and Xmobar
|
||||||
|
|
||||||
module XMonad.Internal.Theme
|
module XMonad.Internal.Theme
|
||||||
( baseColor
|
( baseColor
|
||||||
|
@ -28,18 +28,17 @@ module XMonad.Internal.Theme
|
||||||
, defFontData
|
, defFontData
|
||||||
, tabbedTheme
|
, tabbedTheme
|
||||||
, promptTheme
|
, promptTheme
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Colour
|
import Data.Colour
|
||||||
import Data.Colour.SRGB
|
import Data.Colour.SRGB
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import qualified XMonad.Layout.Decoration as D
|
import qualified XMonad.Layout.Decoration as D
|
||||||
import qualified XMonad.Prompt as P
|
import qualified XMonad.Prompt as P
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Colors - vocabulary roughly based on GTK themes
|
-- Colors - vocabulary roughly based on GTK themes
|
||||||
|
|
||||||
baseColor :: T.Text
|
baseColor :: T.Text
|
||||||
baseColor = "#f7f7f7"
|
baseColor = "#f7f7f7"
|
||||||
|
@ -78,7 +77,7 @@ backdropFgColor :: T.Text
|
||||||
backdropFgColor = blend' 0.75 fgColor bgColor
|
backdropFgColor = blend' 0.75 fgColor bgColor
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Color functions
|
-- Color functions
|
||||||
|
|
||||||
blend' :: Float -> T.Text -> T.Text -> T.Text
|
blend' :: Float -> T.Text -> T.Text -> T.Text
|
||||||
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
|
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
|
||||||
|
@ -93,14 +92,16 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
|
||||||
sRGB24showT = T.pack . sRGB24show
|
sRGB24showT = T.pack . sRGB24show
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Fonts
|
-- Fonts
|
||||||
|
|
||||||
data Slant = Roman
|
data Slant
|
||||||
|
= Roman
|
||||||
| Italic
|
| Italic
|
||||||
| Oblique
|
| Oblique
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data Weight = Light
|
data Weight
|
||||||
|
= Light
|
||||||
| Medium
|
| Medium
|
||||||
| Demibold
|
| Demibold
|
||||||
| Bold
|
| Bold
|
||||||
|
@ -119,15 +120,21 @@ type FontBuilder = FontData -> T.Text
|
||||||
|
|
||||||
buildFont :: Maybe T.Text -> FontData -> T.Text
|
buildFont :: Maybe T.Text -> FontData -> T.Text
|
||||||
buildFont Nothing _ = "fixed"
|
buildFont Nothing _ = "fixed"
|
||||||
buildFont (Just fam) FontData { weight = w
|
buildFont
|
||||||
|
(Just fam)
|
||||||
|
FontData
|
||||||
|
{ weight = w
|
||||||
, slant = l
|
, slant = l
|
||||||
, size = s
|
, size = s
|
||||||
, pixelsize = p
|
, pixelsize = p
|
||||||
, antialias = a
|
, antialias = a
|
||||||
}
|
} =
|
||||||
= T.intercalate ":" $ ["xft", fam] ++ elems
|
T.intercalate ":" $ ["xft", fam] ++ elems
|
||||||
where
|
where
|
||||||
elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w)
|
elems =
|
||||||
|
[ T.concat [k, "=", v]
|
||||||
|
| (k, Just v) <-
|
||||||
|
[ ("weight", showLower w)
|
||||||
, ("slant", showLower l)
|
, ("slant", showLower l)
|
||||||
, ("size", showLower s)
|
, ("size", showLower s)
|
||||||
, ("pixelsize", showLower p)
|
, ("pixelsize", showLower p)
|
||||||
|
@ -141,10 +148,11 @@ fallbackFont :: FontBuilder
|
||||||
fallbackFont = buildFont Nothing
|
fallbackFont = buildFont Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Default font and data
|
-- Default font and data
|
||||||
|
|
||||||
defFontData :: FontData
|
defFontData :: FontData
|
||||||
defFontData = FontData
|
defFontData =
|
||||||
|
FontData
|
||||||
{ size = Just 10
|
{ size = Just 10
|
||||||
, antialias = Just True
|
, antialias = Just True
|
||||||
, weight = Nothing
|
, weight = Nothing
|
||||||
|
@ -162,36 +170,34 @@ defFontFamily = "DejaVu Sans"
|
||||||
-- defFontTree = fontTree "DejaVu Sans"
|
-- defFontTree = fontTree "DejaVu Sans"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Complete themes
|
-- Complete themes
|
||||||
|
|
||||||
tabbedTheme :: FontBuilder -> D.Theme
|
tabbedTheme :: FontBuilder -> D.Theme
|
||||||
tabbedTheme fb = D.def
|
tabbedTheme fb =
|
||||||
|
D.def
|
||||||
{ D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold}
|
{ D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold}
|
||||||
|
|
||||||
, D.activeTextColor = T.unpack fgColor
|
, D.activeTextColor = T.unpack fgColor
|
||||||
, D.activeColor = T.unpack bgColor
|
, D.activeColor = T.unpack bgColor
|
||||||
, D.activeBorderColor = T.unpack bgColor
|
, D.activeBorderColor = T.unpack bgColor
|
||||||
|
|
||||||
, D.inactiveTextColor = T.unpack backdropTextColor
|
, D.inactiveTextColor = T.unpack backdropTextColor
|
||||||
, D.inactiveColor = T.unpack backdropFgColor
|
, D.inactiveColor = T.unpack backdropFgColor
|
||||||
, D.inactiveBorderColor = T.unpack backdropFgColor
|
, D.inactiveBorderColor = T.unpack backdropFgColor
|
||||||
|
|
||||||
, D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
|
, D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
|
||||||
, D.urgentColor = T.unpack errorColor
|
, D.urgentColor = T.unpack errorColor
|
||||||
, D.urgentBorderColor = T.unpack errorColor
|
, D.urgentBorderColor = T.unpack errorColor
|
||||||
|
, -- this is in a newer version
|
||||||
-- this is in a newer version
|
|
||||||
-- , D.activeBorderWidth = 0
|
-- , D.activeBorderWidth = 0
|
||||||
-- , D.inactiveBorderWidth = 0
|
-- , D.inactiveBorderWidth = 0
|
||||||
-- , D.urgentBorderWidth = 0
|
-- , D.urgentBorderWidth = 0
|
||||||
|
|
||||||
, D.decoHeight = 20
|
D.decoHeight = 20
|
||||||
, D.windowTitleAddons = []
|
, D.windowTitleAddons = []
|
||||||
, D.windowTitleIcons = []
|
, D.windowTitleIcons = []
|
||||||
}
|
}
|
||||||
|
|
||||||
promptTheme :: FontBuilder -> P.XPConfig
|
promptTheme :: FontBuilder -> P.XPConfig
|
||||||
promptTheme fb = P.def
|
promptTheme fb =
|
||||||
|
P.def
|
||||||
{ P.font = T.unpack $ fb $ defFontData {size = Just 12}
|
{ P.font = T.unpack $ fb $ defFontData {size = Just 12}
|
||||||
, P.bgColor = T.unpack bgColor
|
, P.bgColor = T.unpack bgColor
|
||||||
, P.fgColor = T.unpack fgColor
|
, P.fgColor = T.unpack fgColor
|
||||||
|
|
|
@ -1,21 +1,22 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
-- Common backlight plugin bits
|
||||||
-- | Common backlight plugin bits
|
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
|
||||||
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
|
startBacklight
|
||||||
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
|
:: RealFrac a
|
||||||
|
=> ((Maybe a -> IO ()) -> SesClient -> IO ())
|
||||||
|
-> (SesClient -> IO (Maybe a))
|
||||||
|
-> T.Text
|
||||||
|
-> Callback
|
||||||
|
-> IO ()
|
||||||
startBacklight matchSignal callGetBrightness icon cb = do
|
startBacklight matchSignal callGetBrightness icon cb = do
|
||||||
withDBusClientConnection cb $ \c -> do
|
withDBusClientConnection cb $ \c -> do
|
||||||
matchSignal display c
|
matchSignal display c
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Bluetooth plugin
|
-- Bluetooth plugin
|
||||||
--
|
--
|
||||||
-- Use the bluez interface on DBus to check status
|
-- Use the bluez interface on DBus to check status
|
||||||
--
|
--
|
||||||
|
@ -36,23 +36,20 @@ module Xmobar.Plugins.Bluetooth
|
||||||
( Bluetooth (..)
|
( Bluetooth (..)
|
||||||
, btAlias
|
, btAlias
|
||||||
, btDep
|
, btDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
|
import DBus.Client
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.List.Split
|
import Data.List.Split
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
|
||||||
import DBus
|
|
||||||
import DBus.Client
|
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
@ -61,8 +58,9 @@ btAlias :: T.Text
|
||||||
btAlias = "bluetooth"
|
btAlias = "bluetooth"
|
||||||
|
|
||||||
btDep :: DBusDependency_ SysClient
|
btDep :: DBusDependency_ SysClient
|
||||||
btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
|
btDep =
|
||||||
$ Method_ getManagedObjects
|
Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
|
||||||
|
Method_ getManagedObjects
|
||||||
|
|
||||||
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -90,7 +88,7 @@ startAdapter is cs cb cl = do
|
||||||
display
|
display
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Icon Display
|
-- Icon Display
|
||||||
--
|
--
|
||||||
-- Color corresponds to the adaptor powered state, and the icon corresponds to
|
-- Color corresponds to the adaptor powered state, and the icon corresponds to
|
||||||
-- if it is paired or not. If the adaptor state is undefined, display "N/A"
|
-- if it is paired or not. If the adaptor state is undefined, display "N/A"
|
||||||
|
@ -111,7 +109,7 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
|
||||||
icon = if connected then iconConn else iconDisc
|
icon = if connected then iconConn else iconDisc
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Connection State
|
-- Connection State
|
||||||
--
|
--
|
||||||
-- The signal handlers all run on separate threads, yet the icon depends on
|
-- The signal handlers all run on separate threads, yet the icon depends on
|
||||||
-- the state reflected by all these signals. The best (only?) way to do this is
|
-- the state reflected by all these signals. The best (only?) way to do this is
|
||||||
|
@ -133,7 +131,8 @@ data BtState = BtState
|
||||||
type MutableBtState = MVar BtState
|
type MutableBtState = MVar BtState
|
||||||
|
|
||||||
emptyState :: BtState
|
emptyState :: BtState
|
||||||
emptyState = BtState
|
emptyState =
|
||||||
|
BtState
|
||||||
{ btDevices = M.empty
|
{ btDevices = M.empty
|
||||||
, btPowered = Nothing
|
, btPowered = Nothing
|
||||||
}
|
}
|
||||||
|
@ -145,7 +144,7 @@ readState state = do
|
||||||
return (p, anyDevicesConnected c)
|
return (p, anyDevicesConnected c)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Object manager
|
-- Object manager
|
||||||
|
|
||||||
findAdapter :: ObjectTree -> Maybe ObjectPath
|
findAdapter :: ObjectTree -> Maybe ObjectPath
|
||||||
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
||||||
|
@ -191,7 +190,7 @@ pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||||
pathCallback _ _ _ _ = return ()
|
pathCallback _ _ _ _ = return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Adapter
|
-- Adapter
|
||||||
|
|
||||||
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
|
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
|
||||||
initAdapter state adapter client = do
|
initAdapter state adapter client = do
|
||||||
|
@ -201,7 +200,11 @@ initAdapter state adapter client = do
|
||||||
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
|
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
|
||||||
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
|
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
|
||||||
|
|
||||||
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
|
addAdaptorListener
|
||||||
|
:: MutableBtState
|
||||||
|
-> IO ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
-> IO (Maybe SignalHandler)
|
-> IO (Maybe SignalHandler)
|
||||||
addAdaptorListener state display adaptor sys = do
|
addAdaptorListener state display adaptor sys = do
|
||||||
rule <- matchBTProperty sys adaptor
|
rule <- matchBTProperty sys adaptor
|
||||||
|
@ -210,8 +213,10 @@ addAdaptorListener state display adaptor sys = do
|
||||||
procMatch = withSignalMatch $ \b -> putPowered state b >> display
|
procMatch = withSignalMatch $ \b -> putPowered state b >> display
|
||||||
|
|
||||||
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
|
callGetPowered adapter =
|
||||||
$ memberName_ $ T.unpack adaptorPowered
|
callPropertyGet btBus adapter adapterInterface $
|
||||||
|
memberName_ $
|
||||||
|
T.unpack adaptorPowered
|
||||||
|
|
||||||
matchPowered :: [Variant] -> SignalMatch Bool
|
matchPowered :: [Variant] -> SignalMatch Bool
|
||||||
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
||||||
|
@ -229,7 +234,7 @@ adaptorPowered :: T.Text
|
||||||
adaptorPowered = "Powered"
|
adaptorPowered = "Powered"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Devices
|
-- Devices
|
||||||
|
|
||||||
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||||
addAndInitDevice state display device client = do
|
addAndInitDevice state display device client = do
|
||||||
|
@ -240,12 +245,18 @@ addAndInitDevice state display device client = do
|
||||||
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
|
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
|
||||||
initDevice state sh device sys = do
|
initDevice state sh device sys = do
|
||||||
reply <- callGetConnected device sys
|
reply <- callGetConnected device sys
|
||||||
void $ insertDevice state device $
|
void $
|
||||||
BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
|
insertDevice state device $
|
||||||
|
BTDevice
|
||||||
|
{ btDevConnected = fromVariant =<< listToMaybe reply
|
||||||
, btDevSigHandler = sh
|
, btDevSigHandler = sh
|
||||||
}
|
}
|
||||||
|
|
||||||
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
|
addDeviceListener
|
||||||
|
:: MutableBtState
|
||||||
|
-> IO ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
-> IO (Maybe SignalHandler)
|
-> IO (Maybe SignalHandler)
|
||||||
addDeviceListener state display device sys = do
|
addDeviceListener state display device sys = do
|
||||||
rule <- matchBTProperty sys device
|
rule <- matchBTProperty sys device
|
||||||
|
@ -257,8 +268,9 @@ matchConnected :: [Variant] -> SignalMatch Bool
|
||||||
matchConnected = matchPropertyChanged devInterface devConnected
|
matchConnected = matchPropertyChanged devInterface devConnected
|
||||||
|
|
||||||
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
callGetConnected p = callPropertyGet btBus p devInterface
|
callGetConnected p =
|
||||||
$ memberName_ (T.unpack devConnected)
|
callPropertyGet btBus p devInterface $
|
||||||
|
memberName_ (T.unpack devConnected)
|
||||||
|
|
||||||
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
||||||
insertDevice m device dev = modifyMVar m $ \s -> do
|
insertDevice m device dev = modifyMVar m $ \s -> do
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Clevo Keyboard plugin
|
-- Clevo Keyboard plugin
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
@ -9,15 +9,13 @@
|
||||||
module Xmobar.Plugins.ClevoKeyboard
|
module Xmobar.Plugins.ClevoKeyboard
|
||||||
( ClevoKeyboard (..)
|
( ClevoKeyboard (..)
|
||||||
, ckAlias
|
, ckAlias
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar
|
|
||||||
|
|
||||||
import Xmobar.Plugins.BacklightCommon
|
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.BacklightCommon
|
||||||
|
|
||||||
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
|
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
|
||||||
|
|
||||||
|
|
|
@ -16,14 +16,10 @@ module Xmobar.Plugins.Common
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
|
||||||
import Data.Internal.DBus
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
import Data.Internal.DBus
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||||
|
|
||||||
-- use string here since all the callbacks in xmobar use strings :(
|
-- use string here since all the callbacks in xmobar use strings :(
|
||||||
|
@ -35,9 +31,15 @@ data Colors = Colors
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read)
|
deriving (Eq, Show, Read)
|
||||||
|
|
||||||
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
|
startListener
|
||||||
-> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
|
:: (SafeClient c, IsVariant a)
|
||||||
-> c -> IO ()
|
=> MatchRule
|
||||||
|
-> (c -> IO [Variant])
|
||||||
|
-> ([Variant] -> SignalMatch a)
|
||||||
|
-> (a -> IO T.Text)
|
||||||
|
-> Callback
|
||||||
|
-> c
|
||||||
|
-> IO ()
|
||||||
startListener rule getProp fromSignal toColor cb client = do
|
startListener rule getProp fromSignal toColor cb client = do
|
||||||
reply <- getProp client
|
reply <- getProp client
|
||||||
displayMaybe cb toColor $ fromSingletonVariant reply
|
displayMaybe cb toColor $ fromSingletonVariant reply
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Device plugin
|
-- Device plugin
|
||||||
--
|
--
|
||||||
-- Display different text depending on whether or not the interface has
|
-- Display different text depending on whether or not the interface has
|
||||||
-- connectivity
|
-- connectivity
|
||||||
|
@ -9,18 +9,15 @@
|
||||||
module Xmobar.Plugins.Device
|
module Xmobar.Plugins.Device
|
||||||
( Device (..)
|
( Device (..)
|
||||||
, devDep
|
, devDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
|
||||||
import DBus
|
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
@ -44,19 +41,23 @@ devSignal :: T.Text
|
||||||
devSignal = "Ip4Connectivity"
|
devSignal = "Ip4Connectivity"
|
||||||
|
|
||||||
devDep :: DBusDependency_ SysClient
|
devDep :: DBusDependency_ SysClient
|
||||||
devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
|
devDep =
|
||||||
$ Method_ getByIP
|
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
|
||||||
|
Method_ getByIP
|
||||||
|
|
||||||
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
|
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
|
||||||
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
||||||
where
|
where
|
||||||
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
mc =
|
||||||
|
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
||||||
{ methodCallBody = [toVariant iface]
|
{ methodCallBody = [toVariant iface]
|
||||||
}
|
}
|
||||||
|
|
||||||
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
|
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
|
getDeviceConnected path =
|
||||||
$ memberName_ $ T.unpack devSignal
|
callPropertyGet networkManagerBus path nmDeviceInterface $
|
||||||
|
memberName_ $
|
||||||
|
T.unpack devSignal
|
||||||
|
|
||||||
matchStatus :: [Variant] -> SignalMatch Word32
|
matchStatus :: [Variant] -> SignalMatch Word32
|
||||||
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Intel backlight plugin
|
-- Intel backlight plugin
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
@ -9,15 +9,13 @@
|
||||||
module Xmobar.Plugins.IntelBacklight
|
module Xmobar.Plugins.IntelBacklight
|
||||||
( IntelBacklight (..)
|
( IntelBacklight (..)
|
||||||
, blAlias
|
, blAlias
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar
|
|
||||||
|
|
||||||
import Xmobar.Plugins.BacklightCommon
|
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.BacklightCommon
|
||||||
|
|
||||||
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
|
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Screensaver plugin
|
-- Screensaver plugin
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
@ -9,13 +9,12 @@
|
||||||
module Xmobar.Plugins.Screensaver
|
module Xmobar.Plugins.Screensaver
|
||||||
( Screensaver (..)
|
( Screensaver (..)
|
||||||
, ssAlias
|
, ssAlias
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import Xmobar
|
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Screensaver
|
import XMonad.Internal.DBus.Screensaver
|
||||||
|
import Xmobar
|
||||||
import Xmobar.Plugins.Common
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
|
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
|
||||||
|
@ -31,4 +30,3 @@ instance Exec Screensaver where
|
||||||
display =<< callQuery sys
|
display =<< callQuery sys
|
||||||
where
|
where
|
||||||
display = displayMaybe cb $ return . (\s -> colorText colors s text)
|
display = displayMaybe cb $ return . (\s -> colorText colors s text)
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VPN plugin
|
-- VPN plugin
|
||||||
--
|
--
|
||||||
-- Use the networkmanager to detect when a VPN interface is added or removed.
|
-- Use the networkmanager to detect when a VPN interface is added or removed.
|
||||||
-- Specifically, monitor the object tree to detect paths with the interface
|
-- Specifically, monitor the object tree to detect paths with the interface
|
||||||
|
@ -11,21 +11,18 @@ module Xmobar.Plugins.VPN
|
||||||
( VPN (..)
|
( VPN (..)
|
||||||
, vpnAlias
|
, vpnAlias
|
||||||
, vpnDep
|
, vpnDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
|
|
||||||
import DBus
|
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
@ -47,7 +44,7 @@ instance Exec VPN where
|
||||||
iconFormatter b = return $ colorText colors b text
|
iconFormatter b = return $ colorText colors b text
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VPN State
|
-- VPN State
|
||||||
--
|
--
|
||||||
-- Maintain a set of paths which are the currently active VPNs. Most of the time
|
-- Maintain a set of paths which are the currently active VPNs. Most of the time
|
||||||
-- this will be a null or singleton set, but this setup could handle the edge
|
-- this will be a null or singleton set, but this setup could handle the edge
|
||||||
|
@ -65,13 +62,15 @@ initState client = do
|
||||||
readState :: MutableVPNState -> IO Bool
|
readState :: MutableVPNState -> IO Bool
|
||||||
readState = fmap (not . null) . readMVar
|
readState = fmap (not . null) . readMVar
|
||||||
|
|
||||||
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
updateState
|
||||||
-> ObjectPath -> IO ()
|
:: (ObjectPath -> VPNState -> VPNState)
|
||||||
|
-> MutableVPNState
|
||||||
|
-> ObjectPath
|
||||||
|
-> IO ()
|
||||||
updateState f state op = modifyMVar_ state $ return . f op
|
updateState f state op = modifyMVar_ state $ return . f op
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Tunnel Device Detection
|
-- Tunnel Device Detection
|
||||||
--
|
|
||||||
|
|
||||||
getVPNObjectTree :: SysClient -> IO ObjectTree
|
getVPNObjectTree :: SysClient -> IO ObjectTree
|
||||||
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
|
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
|
||||||
|
@ -100,16 +99,21 @@ removedCallback state display [device, interfaces] = update >> display
|
||||||
update = updateDevice S.delete state device is
|
update = updateDevice S.delete state device is
|
||||||
removedCallback _ _ _ = return ()
|
removedCallback _ _ _ = return ()
|
||||||
|
|
||||||
updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
updateDevice
|
||||||
-> Variant -> [T.Text] -> IO ()
|
:: (ObjectPath -> VPNState -> VPNState)
|
||||||
updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
|
-> MutableVPNState
|
||||||
forM_ d $ updateState f state
|
-> Variant
|
||||||
|
-> [T.Text]
|
||||||
|
-> IO ()
|
||||||
|
updateDevice f state device interfaces =
|
||||||
|
when (vpnDeviceTun `elem` interfaces) $
|
||||||
|
forM_ d $
|
||||||
|
updateState f state
|
||||||
where
|
where
|
||||||
d = fromVariant device :: Maybe ObjectPath
|
d = fromVariant device :: Maybe ObjectPath
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Interface
|
-- DBus Interface
|
||||||
--
|
|
||||||
|
|
||||||
vpnBus :: BusName
|
vpnBus :: BusName
|
||||||
vpnBus = busName_ "org.freedesktop.NetworkManager"
|
vpnBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
|
@ -124,5 +128,6 @@ vpnAlias :: T.Text
|
||||||
vpnAlias = "vpn"
|
vpnAlias = "vpn"
|
||||||
|
|
||||||
vpnDep :: DBusDependency_ SysClient
|
vpnDep :: DBusDependency_ SysClient
|
||||||
vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
|
vpnDep =
|
||||||
$ Method_ getManagedObjects
|
Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
|
||||||
|
Method_ getManagedObjects
|
||||||
|
|
|
@ -7,7 +7,7 @@ copyright: "2022 Nathan Dwarshuis"
|
||||||
|
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
- README.md
|
- README.md
|
||||||
- .stylish-haskell.yaml
|
- fourmolu.yaml
|
||||||
- make_pkgs
|
- make_pkgs
|
||||||
- icons/*
|
- icons/*
|
||||||
- scripts/*
|
- scripts/*
|
||||||
|
|
Loading…
Reference in New Issue