twin/xmonad-contrib
1
0
Fork 0
mirror of https://github.com/xmonad/xmonad-contrib.git synced 2025-05-19 03:20:21 -07:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into module-MutexScratchpads

Browse Source
This commit is contained in:
Brent Yorgey 2019-03-06 15:14:27 -06:00 committed by GitHub
commit 66c1977c29
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
52 changed files with 4561 additions and 943 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
.travis.yml
View File

@ -13,27 +13,32 @@ before_cache:
matrix:
include:
- env: CABALVER=1.16 GHCVER=7.6.3
compiler: ": #GHC 7.6.3"
addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}
- env: CABALVER=1.18 GHCVER=7.8.4
compiler: ": #GHC 7.8.4"
addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
- env: CABALVER=1.22 GHCVER=7.10.3
compiler: ": #GHC 7.10.3"
addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
- env: CABALVER=1.24 GHCVER=8.0.1
- env: GHCVER=8.6.1 CABALVER=2.4
compiler: ": #GHC 8.6.1"
addons: { apt: { packages: [cabal-install-2.4, ghc-8.6.1, libxrandr-dev]
, sources: [hvr-ghc]
} }
- env: GHCVER=8.4.3 CABALVER=2.2
compiler: ": #GHC 8.4.3"
addons: { apt: { packages: [cabal-install-2.2, ghc-8.4.3, libxrandr-dev]
, sources: [hvr-ghc]
} }
- env: GHCVER=8.2.2 CABALVER=2.0
compiler: ": #GHC 8.2.2"
addons: { apt: { packages: [cabal-install-2.0, ghc-8.2.2, libxrandr-dev]
, sources: [hvr-ghc]
} }
- env: GHCVER=8.0.1 CABALVER=1.24
compiler: ": #GHC 8.0.1"
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
addons: { apt: { packages: [cabal-install-1.24, ghc-8.0.1, libxrandr-dev]
, sources: [hvr-ghc]
} }
before_install:
- unset CC
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
install:
# build xmonad from HEAD
- git clone https://github.com/xmonad/xmonad.git
- cabal --version
- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
@ -42,6 +47,11 @@ install:
$HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
fi
- travis_retry cabal update -v
# build xmonad from HEAD
- git clone https://github.com/xmonad/xmonad.git
- cabal install xmonad/
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
- sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
@ -57,8 +67,8 @@ install:
echo "cabal build-cache MISS";
rm -rf $HOME/.cabsnap;
mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
cabal install --only-dependencies --enable-tests --enable-benchmarks;
fi
- cabal install --only-dependencies --enable-tests --enable-benchmarks;
# snapshot package-db on cache miss
- if [ ! -d $HOME/.cabsnap ];
@ -69,8 +79,6 @@ install:
cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
fi
- cabal install xmonad/
# Here starts the actual work to be performed for the package under test;
# any command which exits with a non-zero exit code causes the build to fail.
script:

406
CHANGES.md
View File

@ -1,27 +1,143 @@
# Change Log / Release Notes
## 0.14 (Not Yet)
## unknown
### Breaking Changes
* `XMonad.Prompt`
- Prompt ships a vim-like keymap, see `vimLikeXPKeymap` and
`vimLikeXPKeymap'`. A reworked event loop supports new vim-like prompt
actions.
- Prompt supports dynamic colors. Colors are now specified by the `XPColor`
type in `XPState` while `XPConfig` colors remain unchanged for backwards
compatibility.
- Fixes `showCompletionOnTab`.
- The behavior of `moveWord` and `moveWord'` has changed; brought in line
with the documentation and now internally consistent. The old keymaps
retain the original behavior; see the documentation to do the same your
XMonad configuration.
### New Modules
* `XMonad.Layout.TwoPanePersistent`
A layout that is like TwoPane but keeps track of the slave window that is
currently beside the master. In TwoPane, the default behavior when the master
is focused is to display the next window in the stack on the slave pane. This
is a problem when a different slave window is selected without changing the stack
order.
* `XMonad.Util.ExclusiveScratchpads`
Named scratchpads that can be mutually exclusive: This new module extends the
idea of named scratchpads such that you can define "families of scratchpads"
that are exclusive on the same screen. It also allows to remove this
constraint of being mutually exclusive with another scratchpad.
### Bug Fixes and Minor Changes
* `XMonad.Prompt`
Added `sorter` to `XPConfig` used to sort the possible completions by how
well they match the search string (example: `XMonad.Prompt.FuzzyMatch`).
Fixes a potential bug where an error during prompt execution would
leave the window open and keep the keyboard grabbed. See issue
[#180](https://github.com/xmonad/xmonad-contrib/issues/180).
Fixes [issue #217](https://github.com/xmonad/xmonad-contrib/issues/217), where
using tab to wrap around the completion rows would fail when maxComplRows is
restricting the number of rows of output.
* `XMonad.Actions.DynamicProjects`
Make the input directory read from the prompt in `DynamicProjects`
absolute wrt the current directory.
Before this, the directory set by the prompt was treated like a relative
directory. This means that when you switch from a project with directory
`foo` into a project with directory `bar`, xmonad actually tries to `cd`
into `foo/bar`, instead of `~/bar` as expected.
* `XMonad.Actions.DynamicWorkspaceOrder`
Add a version of `withNthWorkspace` that takes a `[WorkspaceId] ->
[WorkspaceId]` transformation to apply over the list of workspace tags
resulting from the dynamic order.
* `XMonad.Actions.GroupNavigation`
Add a utility function `isOnAnyVisibleWS :: Query Bool` to allow easy
cycling between all windows on all visible workspaces.
## 0.15
### Breaking Changes
* `XMonad.Layout.Groups` & `XMonad.Layout.Groups.Helpers`
The layout will no longer perform refreshes inside of its message handling.
If you have been relying on it to in your xmonad.hs, you will need to start
sending its messages in a manner that properly handles refreshing, e.g. with
`sendMessage`.
### New Modules
* `XMonad.Util.Purex`
Unlike the opaque `IO` actions that `X` actions can wrap, regular reads from
the `XConf` and modifications to the `XState` are fundamentally pure --
contrary to the current treatment of such actions in most xmonad code. Pure
modifications to the `WindowSet` can be readily composed, but due to the
need for those modifications to be properly handled by `windows`, other pure
changes to the `XState` cannot be interleaved with those changes to the
`WindowSet` without superfluous refreshes, hence breaking composability.
This module aims to rectify that situation by drawing attention to it and
providing `PureX`: a pure type with the same monadic interface to state as
`X`. The `XLike` typeclass enables writing actions generic over the two
monads; if pure, existing `X` actions can be generalised with only a change
to the type signature. Various other utilities are provided, in particular
the `defile` function which is needed by end-users.
### Bug Fixes and Minor Changes
* Add support for GHC 8.6.1.
* `XMonad.Actions.MessageHandling`
Refresh-performing functions updated to better reflect the new `sendMessage`.
## 0.14
### Breaking Changes
* `XMonad.Layout.Spacing`
Rewrite `XMonad.Layout.Spacing`. Borders are no longer uniform but composed
of four sides each with its own border width. The screen and window borders
are now separate and can be independently toggled on/off. The screen border
examines the window/rectangle list resulting from 'runLayout' rather than
the stack, which makes it compatible with layouts such as the builtin
`Full`. The child layout will always be called with the screen border. If
only a single window is displayed (and `smartBorder` enabled), it will be
expanded into the original layout rectangle. Windows that are displayed but
not part of the stack, such as those created by 'XMonad.Layout.Decoration',
will be shifted out of the way, but not scaled (not possible for windows
created by XMonad). This isn't perfect, so you might want to disable
`Spacing` on such layouts.
* `XMonad.Util.SpawnOnce`
- Added `spawnOnOnce`, `spawnNOnOnce` and `spawnAndDoOnce`. These are useful in startup hooks
to shift spawned windows to a specific workspace.
* Adding handling of modifySpacing message in smartSpacing and smartSpacingWithEdge layout modifier
* `XMonad.Actions.GridSelect`
- Added field `gs_bordercolor` to `GSConfig` to specify border color.
* `ewmh` function from `X.H.EwmhDesktops` will use `manageHook` for handling
activated window. That means, actions, which you don't want to happen on
activated windows, should be guarded by
not <$> activated
predicate. By default, with empty `ManageHook`, window activation will do
nothing.
Also, you can use regular 'ManageHook' combinators for changing window
activation behavior.
* `XMonad.Layout.Minimize`
Though the interface it offers is quite similar, this module has been
@ -32,27 +148,105 @@
sending messages to `Minimized` layout. `XMonad.Hooks.RestoreMinimized` has
been completely deprecated, and its functions have no effect.
* `XMonad.Prompt.Unicode`
- `unicodePrompt :: String -> XPConfig -> X ()` now additionally takes a
filepath to the `UnicodeData.txt` file containing unicode data.
* `XMonad.Actions.PhysicalScreens`
`getScreen`, `viewScreen`, `sendToScreen`, `onNextNeighbour`, `onPrevNeighbour` now need a extra parameter
of type `ScreenComparator`. This allow the user to specify how he want his screen to be ordered default
value are:
- `def`(same as verticalScreenOrderer) will keep previous behavior
- `verticalScreenOrderer`
- `horizontalScreenOrderer`
One can build his custom ScreenOrderer using:
- `screenComparatorById` (allow to order by Xinerama id)
- `screenComparatorByRectangle` (allow to order by screen coordonate)
- `ScreenComparator` (allow to mix ordering by screen coordonate and xinerama id)
* `XMonad.Util.WorkspaceCompare`
`getXineramaPhysicalWsCompare` now need a extra argument of type `ScreenComparator` defined in
`XMonad.Actions.PhysicalScreens` (see changelog of this module for more information)
* `XMonad.Hooks.EwmhDesktops`
- Simplify ewmhDesktopsLogHookCustom, and remove the gnome-panel specific
remapping of all visible windows to the active workspace (#216).
- Handle workspace renames that might be occuring in the custom function
that is provided to ewmhDesktopsLogHookCustom.
* `XMonad.Hooks.DynamicLog`
- Support xmobar's \<action> and \<raw> tags; see `xmobarAction` and
`xmobarRaw`.
* `XMonad.Layout.NoBorders`
The layout now maintains a list of windows that never have borders, and a
list of windows that always have borders. Use `BorderMessage` to manage
these lists and the accompanying event hook (`borderEventHook`) to remove
destroyed windows from them. Also provides the `hasBorder` manage hook.
Two new conditions have been added to `Ambiguity`: `OnlyLayoutFloat` and
`OnlyLayoutFloatBelow`; `OnlyFloat` was renamed to `OnlyScreenFloat`. See
the documentation for more information.
The type signature of `hiddens` was changed to accept a new `Rectangle`
parameter representing the bounds of the parent layout, placed after the
`WindowSet` parameter. Anyone defining a new instance of `SetsAmbiguous`
will need to update their configuration. For example, replace "`hiddens amb
wset mst wrs =`" either with "`hiddens amb wset _ mst wrs =`" or to make
use of the new parameter with "`hiddens amb wset lr mst wrs =`".
* `XMonad.Actions.MessageFeedback`
- Follow the naming conventions of `XMonad.Operations`. Functions returning
`X ()` are named regularly (previously these ended in underscore) while
those returning `X Bool` are suffixed with an uppercase 'B'.
- Provide all `X Bool` and `SomeMessage` variations for `sendMessage` and
`sendMessageWithNoRefresh`, not just `sendMessageWithNoRefreshToCurrent`
(renamed from `send`).
- The new `tryInOrderB` and `tryMessageB` functions accept a parameter of
type `SomeMessage -> X Bool`, which means you are no longer constrained
to the behavior of the `sendMessageWithNoRefreshToCurrent` dispatcher.
- The `send*Messages*` family of funtions allows for sequencing arbitrary
sets of messages with minimal refresh. It makes little sense for these
functions to support custom message dispatchers.
- Remain backwards compatible. Maintain deprecated aliases of all renamed
functions:
- `send` -> `sendMessageWithNoRefreshToCurrentB`
- `sendSM` -> `sendSomeMessageWithNoRefreshToCurrentB`
- `sendSM_` -> `sendSomeMessageWithNoRefreshToCurrent`
- `tryInOrder` -> `tryInOrderWithNoRefreshToCurrentB`
- `tryInOrder_` -> `tryInOrderWithNoRefreshToCurrent`
- `tryMessage` -> `tryMessageWithNoRefreshToCurrentB`
- `tryMessage_` -> `tryMessageWithNoRefreshToCurrent`
### New Modules
* `XMonad.Util.ExclusiveScratchpads`
* `XMonad.Layout.MultiToggle.TabBarDecoration`
Named scratchpads that can be mutually exclusive: This new module extends the
idea of named scratchpads such that you can define "families of scratchpads"
that are exclusive on the same screen. It also allows to remove this
constraint of being mutually exclusive with another scratchpad.
Provides a simple transformer for use with `XMonad.Layout.MultiToggle` to
dynamically toggle `XMonad.Layout.TabBarDecoration`.
* `XMonad.Hooks.Focus`
* `XMonad.Layout.StateFull`
A new module extending ManageHook EDSL to work on focused windows and
current workspace.
Provides `StateFull`: a stateful form of `Full` that does not misbehave when
floats are focused, and the `FocusTracking` layout transformer by means of
which `StateFull` is implemented. `FocusTracking` simply holds onto the last
true focus it was given and continues to use it as the focus for the
transformed layout until it sees another. It can be used to improve the
behaviour of a child layout that has not been given the focused window.
This module will enable window activation (`_NET_ACTIVE_WINDOW`) and apply
`manageHook` to activated window too. Thus, it may lead to unexpected
results, when `manageHook` previously working only for new windows, start
working for activated windows too. It may be solved, by adding
`not <$> activated` before those part of `manageHook`, which should not be
called for activated windows. But this lifts `manageHook` into
`FocusHook` and it needs to be converted back later using `manageFocus`.
* `XMonad.Actions.SwapPromote`
Module for tracking master window history per workspace, and associated
functions for manipulating the stack using such history.
* `XMonad.Actions.CycleWorkspaceByScreen`
@ -63,8 +257,98 @@
Also provides the `repeatableAction` helper function which can be used to
build actions that can be repeated while a modifier key is held down.
* `XMonad.Prompt.FuzzyMatch`
Provides a predicate `fuzzyMatch` that is much more lenient in matching
completions in `XMonad.Prompt` than the default prefix match. Also provides
a function `fuzzySort` that allows sorting the fuzzy matches by "how well"
they match.
* `XMonad.Utils.SessionStart`
A new module that allows to query if this is the first time xmonad is
started of the session, or a xmonad restart.
Currently needs manual setting of the session start flag. This could be
automated when this moves to the core repository.
* `XMonad.Layout.MultiDishes`
A new layout based on Dishes, however it accepts additional configuration
to allow multiple windows within a single stack.
* `XMonad.Util.Rectangle`
A new module for handling pixel rectangles.
* `XMonad.Layout.BinaryColumn`
A new module which provides a simple grid layout, halving the window
sizes of each window after master.
This is similar to Column, but splits the window in a way
that maintains window sizes upon adding & removing windows as well as the
option to specify a minimum window size.
### Bug Fixes and Minor Changes
* `XMonad.Layout.Grid`
Fix as per issue #223; Grid will no longer calculate more columns than there
are windows.
* `XMonad.Hooks.FadeWindows`
Added support for GHC version 8.4.x by adding a Semigroup instance for
Monoids
* `XMonad.Hooks.WallpaperSetter`
Added support for GHC version 8.4.x by adding a Semigroup instance for
Monoids
* `XMonad.Hooks.Mosaic`
Added support for GHC version 8.4.x by adding a Semigroup instance for
Monoids
* `XMonad.Actions.Navigation2D`
Added `sideNavigation` and a parameterised variant, providing a navigation
strategy with fewer quirks for tiled layouts using X.L.Spacing.
* `XMonad.Layout.Fullscreen`
The fullscreen layouts will now not render any window that is totally
obscured by fullscreen windows.
* `XMonad.Layout.Gaps`
Extended the sendMessage interface with `ModifyGaps` to allow arbitrary
modifications to the `GapSpec`.
* `XMonad.Layout.Groups`
Added a new `ModifyX` message type that allows the modifying
function to return values in the `X` monad.
* `XMonad.Actions.Navigation2D`
Generalised (and hence deprecated) hybridNavigation to hybridOf.
* `XMonad.Layout.LayoutHints`
Preserve the window order of the modified layout, except for the focused
window that is placed on top. This fixes an issue where the border of the
focused window in certain situations could be rendered below borders of
unfocused windows. It also has a lower risk of interfering with the
modified layout.
* `XMonad.Layout.MultiColumns`
The focused window is placed above the other windows if they would be made to
overlap due to a layout modifier. (As long as it preserves the window order.)
* `XMonad.Actions.GridSelect`
- The vertical centring of text in each cell has been improved.
@ -102,6 +386,10 @@
Make type of ManageHook combinators more general.
* `XMonad.Prompt`
Export `insertString`.
* `XMonad.Prompt.Window`
- New function: `windowMultiPrompt` for using `mkXPromptWithModes`
@ -118,6 +406,68 @@
changed and you want to re-sort windows into the appropriate
sub-layout.
* `XMonad.Actions.Minimize`
- Now has `withFirstMinimized` and `withFirstMinimized'` so you can perform
actions with both the last and first minimized windows easily.
* `XMonad.Config.Gnome`
- Update logout key combination (modm+shift+Q) to work with modern
* `XMonad.Prompt.Pass`
- New function `passTypePrompt` which uses `xdotool` to type in a password
from the store, bypassing the clipboard.
- New function `passEditPrompt` for editing a password from the
store.
- Now handles password labels with spaces and special characters inside
them.
* `XMonad.Prompt.Unicode`
- Persist unicode data cache across XMonad instances due to
`ExtensibleState` now used instead of `unsafePerformIO`.
- `typeUnicodePrompt :: String -> XPConfig -> X ()` provided to insert the
Unicode character via `xdotool` instead of copying it to the paste buffer.
- `mkUnicodePrompt :: String -> [String] -> String -> XPConfig -> X ()`
acts as a generic function to pass the selected Unicode character to any
program.
* `XMonad.Prompt.AppendFile`
- New function `appendFilePrompt'` which allows for transformation of the
string passed by a user before writing to a file.
* `XMonad.Hooks.DynamicLog`
- Added a new function `dzenWithFlags` which allows specifying the arguments
passed to `dzen2` invocation. The behaviour of current `dzen` function is
unchanged.
* `XMonad.Util.Dzen`
- Now provides functions `fgColor` and `bgColor` to specify foreground and
background color, `align` and `slaveAlign` to set text alignment, and
`lineCount` to enable a second (slave) window that displays lines beyond
the initial (title) one.
* `XMonad.Hooks.DynamicLog`
- Added optional `ppVisibleNoWindows` to differentiate between empty
and non-empty visible workspaces in pretty printing.
* `XMonad.Actions.DynamicWorkspaceOrder`
- Added `updateName` and `removeName` to better control ordering when
workspace names are changed or workspaces are removed.
* `XMonad.Config.Azerty`
* Added `belgianConfig` and `belgianKeys` to support Belgian AZERTY
keyboards, which are slightly different from the French ones in the top
row.
## 0.13 (February 10, 2017)
### Breaking Changes

19
README.md
View File

@ -1,14 +1,15 @@
# xmonad-contrib: Third Party Extensions to the xmonad Window Manager
[![Build Status](https://travis-ci.org/xmonad/xmonad-contrib.svg?branch=master)](https://travis-ci.org/xmonad/xmonad-contrib)
[![Open Source Helpers](https://www.codetriage.com/xmonad/xmonad-contrib/badges/users.svg)](https://www.codetriage.com/xmonad/xmonad-contrib)
You need the ghc compiler and xmonad window manager installed in
order to use these extensions.
For installation and configuration instructions, please see the
[xmonad website] [xmonad], the documents included with the
[xmonad source distribution] [xmonad-git], and the
[online haddock documentation] [xmonad-docs].
[xmonad website][xmonad], the documents included with the
[xmonad source distribution][xmonad-git], and the
[online haddock documentation][xmonad-docs].
## Getting or Updating XMonadContrib
@ -17,7 +18,7 @@ For installation and configuration instructions, please see the
* Git version: <https://github.com/xmonad/xmonad-contrib>
(To use git xmonad-contrib you must also use the
[git version of xmonad] [xmonad-git].)
[git version of xmonad][xmonad-git].)
## Contributing
@ -28,15 +29,15 @@ example, to use the Grid layout, one would import:
XMonad.Layout.Grid
For further details, see the [documentation] [developing] for the
`XMonad.Doc.Developing` module and the [xmonad website] [xmonad].
For further details, see the [documentation][developing] for the
`XMonad.Doc.Developing` module, XMonad's [CONTRIBUTING.md](https://github.com/xmonad/xmonad/blob/master/CONTRIBUTING.md) and the [xmonad website][xmonad].
## License
Code submitted to the contrib repo is licensed under the same license as
xmonad itself, with copyright held by the authors.
[xmonad]: http://xmonad.org
[xmonad-git]: https://github.com/xmonad/xmonad
[xmonad-docs]: http://www.xmonad.org/xmonad-docs
[developing]: http://xmonad.org/xmonad-docs/xmonad-contrib/XMonad-Doc-Developing.html
[xmonad-docs]: http://hackage.haskell.org/package/xmonad
[developing]: http://hackage.haskell.org/package/xmonad-contrib/docs/XMonad-Doc-Developing.html

14
XMonad/Actions/Commands.hs
View File

@ -19,6 +19,7 @@ module XMonad.Actions.Commands (
-- $usage
commandMap,
runCommand,
runCommandConfig,
runCommand',
workspaceCommands,
screenCommands,
@ -103,11 +104,18 @@ defaultCommands = do
]
-- | Given a list of command\/action pairs, prompt the user to choose a
-- command and return the corresponding action.
-- command using dmenu and return the corresponding action.
runCommand :: [(String, X ())] -> X ()
runCommand cl = do
runCommand = runCommandConfig dmenu
-- | Given a list of command\/action pairs, prompt the user to choose a
-- command using dmenu-compatible launcher and return the corresponding action.
-- See X.U.Dmenu for compatible launchers.
runCommandConfig :: ([String] -> X String) -> [(String, X ())] -> X()
runCommandConfig f cl = do
let m = commandMap cl
choice <- dmenu (M.keys m)
choice <- f (M.keys m)
fromMaybe (return ()) (M.lookup choice m)
-- | Given the name of a command from 'defaultCommands', return the

5
XMonad/Actions/DynamicProjects.hs
View File

@ -50,7 +50,7 @@ import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid ((<>))
import System.Directory (setCurrentDirectory, getHomeDirectory)
import System.Directory (setCurrentDirectory, getHomeDirectory, makeAbsolute)
import XMonad
import XMonad.Actions.DynamicWorkspaces
import XMonad.Prompt
@ -182,7 +182,8 @@ instance XPrompt ProjectPrompt where
modifyProject (\p -> p { projectName = name })
modeAction (ProjectPrompt DirMode _) buf auto = do
let dir = if null auto then buf else auto
let dir' = if null auto then buf else auto
dir <- io $ makeAbsolute dir'
modifyProject (\p -> p { projectDirectory = dir })
--------------------------------------------------------------------------------

36
XMonad/Actions/DynamicWorkspaceOrder.hs
View File

@ -23,11 +23,14 @@ module XMonad.Actions.DynamicWorkspaceOrder
getWsCompareByOrder
, getSortByOrder
, swapWith
, updateName
, removeName
, moveTo
, moveToGreedy
, shiftTo
, withNthWorkspace'
, withNthWorkspace
) where
@ -152,6 +155,21 @@ swapOrder w1 w2 = do
XS.modify (withWSO (M.insert w1 i2 . M.insert w2 i1))
windows id -- force a status bar update
-- | Update the name of a workspace in the stored order.
updateName :: WorkspaceId -> WorkspaceId -> X ()
updateName oldId newId = XS.modify . withWSO $ changeKey oldId newId
-- | Remove a workspace from the stored order.
removeName :: WorkspaceId -> X ()
removeName = XS.modify . withWSO . M.delete
-- | Update a key in a Map.
changeKey :: Ord k => k -> k -> M.Map k a -> M.Map k a
changeKey oldKey newKey oldMap =
case M.updateLookupWithKey (\_ _ -> Nothing) oldKey oldMap of
(Nothing, _) -> oldMap
(Just val, newMap) -> M.insert newKey val newMap
-- | View the next workspace of the given type in the given direction,
-- where \"next\" is determined using the dynamic workspace order.
moveTo :: Direction1D -> WSType -> X ()
@ -166,13 +184,19 @@ moveToGreedy dir t = doTo dir t getSortByOrder (windows . W.greedyView)
shiftTo :: Direction1D -> WSType -> X ()
shiftTo dir t = doTo dir t getSortByOrder (windows . W.shift)
-- | Do something with the nth workspace in the dynamic order after
-- transforming it. The callback is given the workspace's tag as well
-- as the 'WindowSet' of the workspace itself.
withNthWorkspace' :: ([WorkspaceId] -> [WorkspaceId]) -> (String -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace' tr job wnum = do
sort <- getSortByOrder
ws <- gets (tr . map W.tag . sort . W.workspaces . windowset)
case drop wnum ws of
(w:_) -> windows $ job w
[] -> return ()
-- | Do something with the nth workspace in the dynamic order. The
-- callback is given the workspace's tag as well as the 'WindowSet'
-- of the workspace itself.
withNthWorkspace :: (String -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace job wnum = do
sort <- getSortByOrder
ws <- gets (map W.tag . sort . W.workspaces . windowset)
case drop wnum ws of
(w:_) -> windows $ job w
[] -> return ()
withNthWorkspace = withNthWorkspace' id

30
XMonad/Actions/GroupNavigation.hs
View File

@ -16,7 +16,7 @@
-- query.
--
-- Also provides a method for jumping back to the most recently used
-- window in any given group.
-- window in any given group, and predefined groups.
--
----------------------------------------------------------------------
@ -27,9 +27,14 @@ module XMonad.Actions.GroupNavigation ( -- * Usage
, nextMatchOrDo
, nextMatchWithThis
, historyHook
-- * Utilities
-- $utilities
, isOnAnyVisibleWS
) where
import Control.Monad.Reader
import Control.Monad.State
import Data.Foldable as Fold
import Data.Map as Map
import Data.Sequence as Seq
@ -142,7 +147,7 @@ orderedWorkspaceList ss wsids = rotateTo isCurWS wspcs'
where
wspcs = SS.workspaces ss
wspcsMap = Fold.foldl' (\m ws -> Map.insert (SS.tag ws) ws m) Map.empty wspcs
wspcs' = fmap (\wsid -> wspcsMap ! wsid) wsids
wspcs' = fmap (wspcsMap !) wsids
isCurWS ws = SS.tag ws == SS.tag (SS.workspace $ SS.current ss)
--- History navigation, requires a layout modifier -------------------
@ -167,7 +172,7 @@ updateHistory :: HistoryDB -> X HistoryDB
updateHistory (HistoryDB oldcur oldhist) = withWindowSet $ \ss -> do
let newcur = SS.peek ss
wins = Set.fromList $ SS.allWindows ss
newhist = flt (flip Set.member wins) (ins oldcur oldhist)
newhist = flt (`Set.member` wins) (ins oldcur oldhist)
return $ HistoryDB newcur (del newcur newhist)
where
ins x xs = maybe xs (<| xs) x
@ -216,3 +221,22 @@ findM cond xs = findM' cond (viewl xs)
if isMatch
then return (Just x')
else findM qry xs'
-- $utilities
-- #utilities#
-- Below are handy queries for use with 'nextMatch', 'nextMatchOrDo',
-- and 'nextMatchWithThis'.
-- | A query that matches all windows on visible workspaces. This is
-- useful for configurations with multiple screens, and matches even
-- invisible windows.
isOnAnyVisibleWS :: Query Bool
isOnAnyVisibleWS = do
w <- ask
ws <- liftX $ gets windowset
let allVisible = concat $ maybe [] SS.integrate . SS.stack . SS.workspace <$> SS.current ws:SS.visible ws
visibleWs = w `elem` allVisible
unfocused = maybe True (w /=) $ SS.peek ws
return $ visibleWs && unfocused

283
XMonad/Actions/MessageFeedback.hs
View File

@ -1,7 +1,8 @@
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Actions.MessageFeedback
-- Copyright : (c) Quentin Moser <moserq@gmail.com>
-- Copyright : (c) -- Quentin Moser <moserq@gmail.com>
-- 2018 Yclept Nemo
-- License : BSD3
--
-- Maintainer : orphaned
@ -13,87 +14,263 @@
-- this facility.
-----------------------------------------------------------------------------
module XMonad.Actions.MessageFeedback (
-- * Usage
-- $usage
module XMonad.Actions.MessageFeedback
( -- * Usage
-- $usage
send
, tryMessage
, tryMessage_
, tryInOrder
, tryInOrder_
, sm
, sendSM
, sendSM_
) where
-- * Messaging variants
import XMonad.Core ( X (), Message, SomeMessage(..), LayoutClass(..), windowset, catchX )
import XMonad.StackSet ( current, workspace, layout, tag )
import XMonad.Operations ( updateLayout )
-- ** 'SomeMessage'
sendSomeMessageB, sendSomeMessage
, sendSomeMessageWithNoRefreshB, sendSomeMessageWithNoRefresh
, sendSomeMessageWithNoRefreshToCurrentB, sendSomeMessageWithNoRefreshToCurrent
import Control.Monad.State ( gets )
import Data.Maybe ( isJust )
import Control.Applicative ((<$>))
-- ** 'Message'
, sendMessageB
, sendMessageWithNoRefreshB
, sendMessageWithNoRefreshToCurrentB, sendMessageWithNoRefreshToCurrent
-- * Utility Functions
-- ** Send All
, sendSomeMessagesB, sendSomeMessages, sendMessagesB, sendMessages
-- ** Send Until
, tryInOrderB, tryInOrderWithNoRefreshToCurrentB, tryInOrderWithNoRefreshToCurrent
, tryMessageB, tryMessageWithNoRefreshToCurrentB, tryMessageWithNoRefreshToCurrent
-- ** Aliases
, sm
-- * Backwards Compatibility
-- $backwardsCompatibility
, send, sendSM, sendSM_
, tryInOrder, tryInOrder_
, tryMessage, tryMessage_
) where
import XMonad ( Window )
import XMonad.Core ( X(), Message, SomeMessage(..), LayoutClass(..), windowset, catchX, WorkspaceId, Layout, whenJust )
import XMonad.StackSet ( Workspace, current, workspace, layout, tag )
import XMonad.Operations ( updateLayout, windowBracket, modifyWindowSet )
import Data.Maybe ( isJust )
import Control.Monad ( void )
import Control.Monad.State ( gets )
import Control.Applicative ( (<$>), liftA2 )
-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Actions.MessageFeedback
--
-- You can then use this module's functions wherever an action is expected.
-- You can then use this module's functions wherever an action is expected. All
-- feedback variants are supported:
--
-- * message to any workspace with no refresh
-- * message to current workspace with no refresh
-- * message to current workspace with refresh
--
-- Except "message to any workspace with refresh" which makes little sense.
--
-- Note that most functions in this module have a return type of @X Bool@
-- whereas configuration options will expect a @X ()@ action.
-- For example, the key binding
-- whereas configuration options will expect a @X ()@ action. For example, the
-- key binding:
--
-- > -- Shrink the master area of a tiled layout, or move the focused window
-- > -- to the left in a WindowArranger-based layout
-- > ((modKey, xK_Left), tryMessage Shrink (MoveLeft 50))
-- > ((modKey, xK_Left), tryMessageWithNoRefreshToCurrentB Shrink (MoveLeft 50))
--
-- is mis-typed. For this reason, this module provides alternatives (ending with
-- an underscore, e.g. tryMessage_) that discard their result and return an @X ()@.
-- For example, to correct the previous example:
-- is mis-typed. For this reason, this module provides alternatives (not ending
-- with an uppercase \"B\", e.g. 'XMonad.Operations.sendMessage' rather than
-- 'sendMessageB') that discard their boolean result and return an @X ()@. For
-- example, to correct the previous example:
--
-- > ((modKey, xK_Left), tryMessage_ Shrink (MoveLeft 50))
-- > ((modKey, xK_Left), tryMessageWithNoRefreshToCurrent Shrink (MoveLeft 50))
--
-- This module also provides 'SomeMessage' variants of each 'Message' function
-- for when the messages are of differing types (but still instances of
-- 'Message'). First box each message using 'SomeMessage' or the convenience
-- alias 'sm'. Then, for example, to send each message:
--
-- > sendSomeMessages [sm messageOfTypeA, sm messageOfTypeB]
--
-- This is /not/ equivalent to the following example, which will not refresh
-- the workspace unless the last message is handled:
--
-- > sendMessageWithNoRefreshToCurrent messageOfTypeA >> sendMessage messageOfTypeB
-- | Behaves like 'XMonad.Operations.sendMessage', but returns True of the
-- message was handled by the layout, False otherwise.
send :: Message a => a -> X Bool
send = sendSM . sm
-- | Variant of 'XMonad.Operations.sendMessage'. Accepts 'SomeMessage'; to use
-- 'Message' see 'sendMessageB'. Returns @True@ if the message was handled,
-- @False@ otherwise. Instead of using 'sendSomeMessageWithNoRefreshToCurrentB'
-- for efficiency this is pretty much an exact copy of the
-- 'XMonad.Operations.sendMessage' code - foregoes the O(n) 'updateLayout'.
sendSomeMessageB :: SomeMessage -> X Bool
sendSomeMessageB m = windowBracket id $ do
w <- workspace . current <$> gets windowset
ml <- handleMessage (layout w) m `catchX` return Nothing
whenJust ml $ \l ->
modifyWindowSet $ \ws -> ws { current = (current ws)
{ workspace = (workspace $ current ws)
{ layout = l }}}
return $ isJust ml
-- | Sends the first message, and if it was not handled, sends the second.
-- Returns True if either message was handled, False otherwise.
tryMessage :: (Message a, Message b) => a -> b -> X Bool
tryMessage m1 m2 = do b <- send m1
if b then return True else send m2
-- | Variant of 'sendSomeMessageB' that discards the result.
sendSomeMessage :: SomeMessage -> X ()
sendSomeMessage = void . sendSomeMessageB
tryMessage_ :: (Message a, Message b) => a -> b -> X ()
tryMessage_ m1 m2 = tryMessage m1 m2 >> return ()
-- | Variant of 'XMonad.Operations.sendMessageWithNoRefresh'. Accepts
-- 'SomeMessage'; to use 'Message' see 'sendMessageWithNoRefreshB'. Returns
-- @True@ if the message was handled, @False@ otherwise.
sendSomeMessageWithNoRefreshB :: SomeMessage -> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendSomeMessageWithNoRefreshB m w
= handleMessage (layout w) m `catchX` return Nothing
>>= liftA2 (>>) (updateLayout $ tag w) (return . isJust)
-- | Tries sending every message of the list in order until one of them
-- is handled. Returns True if one of the messages was handled, False otherwise.
tryInOrder :: [SomeMessage] -> X Bool
tryInOrder [] = return False
tryInOrder (m:ms) = do b <- sendSM m
if b then return True else tryInOrder ms
-- | Variant of 'sendSomeMessageWithNoRefreshB' that discards the result.
sendSomeMessageWithNoRefresh :: SomeMessage -> Workspace WorkspaceId (Layout Window) Window -> X ()
sendSomeMessageWithNoRefresh m = void . sendSomeMessageWithNoRefreshB m
tryInOrder_ :: [SomeMessage] -> X ()
tryInOrder_ ms = tryInOrder ms >> return ()
-- | Variant of 'XMonad.Operations.sendMessageWithNoRefresh' that sends the
-- message to the current layout. Accepts 'SomeMessage'; to use 'Message' see
-- 'sendMessageWithNoRefreshToCurrentB'. Returns @True@ if the message was
-- handled, @False@ otherwise. This function is somewhat of a cross between
-- 'XMonad.Operations.sendMessage' (sends to the current layout) and
-- 'XMonad.Operations.sendMessageWithNoRefresh' (does not refresh).
sendSomeMessageWithNoRefreshToCurrentB :: SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB m
= (gets $ workspace . current . windowset)
>>= sendSomeMessageWithNoRefreshB m
-- | Variant of 'sendSomeMessageWithNoRefreshToCurrentB' that discards the
-- result.
sendSomeMessageWithNoRefreshToCurrent :: SomeMessage -> X ()
sendSomeMessageWithNoRefreshToCurrent = void . sendSomeMessageWithNoRefreshToCurrentB
-- | Convenience shorthand for 'XMonad.Core.SomeMessage'.
-- | Variant of 'sendSomeMessageB' which like 'XMonad.Operations.sendMessage'
-- accepts 'Message' rather than 'SomeMessage'. Returns @True@ if the message
-- was handled, @False@ otherwise.
sendMessageB :: Message a => a -> X Bool
sendMessageB = sendSomeMessageB . SomeMessage
-- | Variant of 'sendSomeMessageWithNoRefreshB' which like
-- 'XMonad.Operations.sendMessageWithNoRefresh' accepts 'Message' rather than
-- 'SomeMessage'. Returns @True@ if the message was handled, @False@ otherwise.
sendMessageWithNoRefreshB :: Message a => a -> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendMessageWithNoRefreshB = sendSomeMessageWithNoRefreshB . SomeMessage
-- | Variant of 'sendSomeMessageWithNoRefreshToCurrentB' which accepts
-- 'Message' rather than 'SomeMessage'. Returns @True@ if the message was
-- handled, @False@ otherwise.
sendMessageWithNoRefreshToCurrentB :: Message a => a -> X Bool
sendMessageWithNoRefreshToCurrentB = sendSomeMessageWithNoRefreshToCurrentB . SomeMessage
-- | Variant of 'sendMessageWithNoRefreshToCurrentB' that discards the result.
sendMessageWithNoRefreshToCurrent :: Message a => a -> X ()
sendMessageWithNoRefreshToCurrent = void . sendMessageWithNoRefreshToCurrentB
-- | Send each 'SomeMessage' to the current layout without refresh (using
-- 'sendSomeMessageWithNoRefreshToCurrentB') and collect the results. If any
-- message was handled, refresh. If you want to sequence a series of messages
-- that would have otherwise used 'XMonad.Operations.sendMessage' while
-- minimizing refreshes, use this.
sendSomeMessagesB :: [SomeMessage] -> X [Bool]
sendSomeMessagesB
= windowBracket or
. mapM sendSomeMessageWithNoRefreshToCurrentB
-- | Variant of 'sendSomeMessagesB' that discards the results.
sendSomeMessages :: [SomeMessage] -> X ()
sendSomeMessages = void . sendSomeMessagesB
-- | Variant of 'sendSomeMessagesB' which accepts 'Message' rather than
-- 'SomeMessage'. Use this if all the messages are of the same type.
sendMessagesB :: Message a => [a] -> X [Bool]
sendMessagesB = sendSomeMessagesB . map SomeMessage
-- | Variant of 'sendMessagesB' that discards the results.
sendMessages :: Message a => [a] -> X ()
sendMessages = void . sendMessagesB
-- | Apply the dispatch function in order to each message of the list until one
-- is handled. Returns @True@ if so, @False@ otherwise.
tryInOrderB :: (SomeMessage -> X Bool) -> [SomeMessage] -> X Bool
tryInOrderB _ [] = return False
tryInOrderB f (m:ms) = do b <- f m
if b then return True else tryInOrderB f ms
-- | Variant of 'tryInOrderB' that sends messages to the current layout without
-- refresh using 'sendSomeMessageWithNoRefreshToCurrentB'.
tryInOrderWithNoRefreshToCurrentB :: [SomeMessage] -> X Bool
tryInOrderWithNoRefreshToCurrentB = tryInOrderB sendSomeMessageWithNoRefreshToCurrentB
-- | Variant of 'tryInOrderWithNoRefreshToCurrent' that discards the results.
tryInOrderWithNoRefreshToCurrent :: [SomeMessage] -> X ()
tryInOrderWithNoRefreshToCurrent = void . tryInOrderWithNoRefreshToCurrentB
-- | Apply the dispatch function to the first message, and if it was not
-- handled, apply it to the second. Returns @True@ if either message was
-- handled, @False@ otherwise.
tryMessageB :: (Message a, Message b) => (SomeMessage -> X Bool) -> a -> b -> X Bool
tryMessageB f m1 m2 = tryInOrderB f [sm m1,sm m2]
-- | Variant of 'tryMessageB' that sends messages to the current layout without
-- refresh using 'sendMessageWithNoRefreshToCurrentB'.
tryMessageWithNoRefreshToCurrentB :: (Message a, Message b) => a -> b -> X Bool
tryMessageWithNoRefreshToCurrentB = tryMessageB sendSomeMessageWithNoRefreshToCurrentB
-- | Variant of 'tryMessage' that discards the results.
tryMessageWithNoRefreshToCurrent :: (Message a, Message b) => a -> b -> X ()
tryMessageWithNoRefreshToCurrent m = void . tryMessageWithNoRefreshToCurrentB m
-- | Convenience shorthand for 'SomeMessage'.
sm :: Message a => a -> SomeMessage
sm = SomeMessage
--------------------------------------------------------------------------------
-- Backwards Compatibility:
--------------------------------------------------------------------------------
{-# DEPRECATED send "Use sendMessageB instead." #-}
{-# DEPRECATED sendSM "Use sendSomeMessageB instead." #-}
{-# DEPRECATED sendSM_ "Use sendSomeMessage instead." #-}
{-# DEPRECATED tryInOrder "Use tryInOrderWithNoRefreshToCurrentB instead." #-}
{-# DEPRECATED tryInOrder_ "Use tryInOrderWithNoRefreshToCurrent instead." #-}
{-# DEPRECATED tryMessage "Use tryMessageWithNoRefreshToCurrentB instead." #-}
{-# DEPRECATED tryMessage_ "Use tryMessageWithNoRefreshToCurrent instead." #-}
-- $backwardsCompatibility
-- The following functions exist solely for compatibility with pre-0.14
-- releases.
-- | See 'sendMessageWithNoRefreshToCurrentB'.
send :: Message a => a -> X Bool
send = sendMessageWithNoRefreshToCurrentB
-- | See 'sendSomeMessageWithNoRefreshToCurrentB'.
sendSM :: SomeMessage -> X Bool
sendSM m = do w <- workspace . current <$> gets windowset
ml' <- handleMessage (layout w) m `catchX` return Nothing
updateLayout (tag w) ml'
return $ isJust ml'
sendSM = sendSomeMessageWithNoRefreshToCurrentB
-- | See 'sendSomeMessageWithNoRefreshToCurrent'.
sendSM_ :: SomeMessage -> X ()
sendSM_ m = sendSM m >> return ()
sendSM_ = sendSomeMessageWithNoRefreshToCurrent
-- | See 'tryInOrderWithNoRefreshToCurrentB'.
tryInOrder :: [SomeMessage] -> X Bool
tryInOrder = tryInOrderWithNoRefreshToCurrentB
-- | See 'tryInOrderWithNoRefreshToCurrent'.
tryInOrder_ :: [SomeMessage] -> X ()
tryInOrder_ = tryInOrderWithNoRefreshToCurrent
-- | See 'tryMessageWithNoRefreshToCurrentB'.
tryMessage :: (Message a, Message b) => a -> b -> X Bool
tryMessage = tryMessageWithNoRefreshToCurrentB
-- | See 'tryMessageWithNoRefreshToCurrent'.
tryMessage_ :: (Message a, Message b) => a -> b -> X ()
tryMessage_ = tryMessageWithNoRefreshToCurrent

14
XMonad/Actions/Minimize.hs
View File

@ -29,6 +29,8 @@ module XMonad.Actions.Minimize
, maximizeWindowAndFocus
, withLastMinimized
, withLastMinimized'
, withFirstMinimized
, withFirstMinimized'
, withMinimized
) where
@ -85,7 +87,7 @@ modified f = XS.modified $
in Minimized { rectMap = newRectMap
, minimizedStack = (newWindows L.\\ oldStack)
++
(newWindows `L.intersect` oldStack)
(oldStack `L.intersect` newWindows)
}
@ -115,6 +117,16 @@ maximizeWindow = maximizeWindowAndChangeWSet $ const id
maximizeWindowAndFocus :: Window -> X ()
maximizeWindowAndFocus = maximizeWindowAndChangeWSet W.focusWindow
-- | Perform an action with first minimized window on current workspace
-- or do nothing if there is no minimized windows on current workspace
withFirstMinimized :: (Window -> X ()) -> X ()
withFirstMinimized action = withFirstMinimized' (flip whenJust action)
-- | Like withFirstMinimized but the provided action is always invoked with a
-- 'Maybe Window', that will be nothing if there is no first minimized window.
withFirstMinimized' :: (Maybe Window -> X ()) -> X ()
withFirstMinimized' action = withMinimized (action . listToMaybe . reverse)
-- | Perform an action with last minimized window on current workspace
-- or do nothing if there is no minimized windows on current workspace
withLastMinimized :: (Window -> X ()) -> X ()

123
XMonad/Actions/Navigation2D.hs
View File

@ -43,6 +43,9 @@ module XMonad.Actions.Navigation2D ( -- * Usage
, Navigation2D
, lineNavigation
, centerNavigation
, sideNavigation
, sideNavigationWithBias
, hybridOf
, hybridNavigation
, fullScreenRect
, singleWindowRect
@ -59,6 +62,7 @@ import Control.Applicative
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.Ord (comparing)
import XMonad hiding (Screen)
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS
@ -70,16 +74,17 @@ import XMonad.Util.Types
-- Navigation2D provides directional navigation (go left, right, up, down) for
-- windows and screens. It treats floating and tiled windows as two separate
-- layers and provides mechanisms to navigate within each layer and to switch
-- between layers. Navigation2D provides two different navigation strategies
-- (see <#Technical_Discussion> for details): /Line navigation/ feels rather
-- natural but may make it impossible to navigate to a given window from the
-- current window, particularly in the floating layer. /Center navigation/
-- feels less natural in certain situations but ensures that all windows can be
-- reached without the need to involve the mouse. A third option is to use
-- /Hybrid navigation/, which automatically chooses between the two whenever
-- navigation is attempted. Navigation2D allows different navigation strategies
-- to be used in the two layers and allows customization of the navigation strategy
-- for the tiled layer based on the layout currently in effect.
-- between layers. Navigation2D provides three different navigation strategies
-- (see <#Technical_Discussion> for details): /Line navigation/ and
-- /Side navigation/ feel rather natural but may make it impossible to navigate
-- to a given window from the current window, particularly in the floating
-- layer. /Center navigation/ feels less natural in certain situations but
-- ensures that all windows can be reached without the need to involve the
-- mouse. Another option is to use a /Hybrid/ of the three strategies,
-- automatically choosing whichever first provides a suitable target window.
-- Navigation2D allows different navigation strategies to be used in the two
-- layers and allows customization of the navigation strategy for the tiled
-- layer based on the layout currently in effect.
--
-- You can use this module with (a subset of) the following in your @~\/.xmonad\/xmonad.hs@:
--
@ -318,12 +323,46 @@ lineNavigation = N 1 doLineNavigation
centerNavigation :: Navigation2D
centerNavigation = N 2 doCenterNavigation
-- | Hybrid navigation. This attempts Line navigation, then falls back on Center
-- navigation if it does not find any suitable target windows. This is useful since
-- Line navigation tends to fail on gaps, but provides more intuitive motions
-- when it succeeds—provided there are no floating windows.
-- | Side navigation. Consider navigating to the right this time. The strategy
-- is to take the line segment forming the right boundary of the current window,
-- and push it to the right until it intersects with at least one other window.
-- Of those windows, one with a point that is the closest to the centre of the
-- line (+1) is selected. This is probably the most intuitive strategy for the
-- tiled layer when using XMonad.Layout.Spacing.
sideNavigation :: Navigation2D
sideNavigation = N 1 (doSideNavigationWithBias 1)
-- | Side navigation with bias. Consider a case where the screen is divided
-- up into three vertical panes; the side panes occupied by one window each and
-- the central pane split across the middle by two windows. By the criteria
-- of side navigation, the two central windows are equally good choices when
-- navigating inwards from one of the side panes. Hence in order to be
-- equitable, symmetric and pleasant to use, different windows are chosen when
-- navigating from different sides. In particular, the lower is chosen when
-- going left and the higher when going right, causing L, L, R, R, L, L, etc to
-- cycle through the four windows clockwise. This is implemented by using a bias
-- of 1. /Bias/ is how many pixels off centre the vertical split can be before
-- this behaviour is lost and the same window chosen every time. A negative bias
-- swaps the preferred window for each direction. A bias of zero disables the
-- behaviour.
sideNavigationWithBias :: Int -> Navigation2D
sideNavigationWithBias b = N 1 (doSideNavigationWithBias b)
-- | Hybrid of two modes of navigation, preferring the motions of the first.
-- Use this if you want to fall back on a second strategy whenever the first
-- does not find a candidate window. E.g.
-- @hybridOf lineNavigation centerNavigation@ is a good strategy for the
-- floating layer, and @hybridOf sideNavigation centerNavigation@ will enable
-- you to take advantage of some of the latter strategy's more interesting
-- motions in the tiled layer.
hybridOf :: Navigation2D -> Navigation2D -> Navigation2D
hybridOf (N g1 s1) (N g2 s2) = N (max g1 g2) $ applyToBoth s1 s2
where
applyToBoth f g a b c = f a b c <|> g a b c
{-# DEPRECATED hybridNavigation "Use hybridOf with lineNavigation and centerNavigation as arguments." #-}
hybridNavigation :: Navigation2D
hybridNavigation = N 2 doHybridNavigation
hybridNavigation = hybridOf lineNavigation centerNavigation
-- | Stores the configuration of directional navigation. The 'Default' instance
-- uses line navigation for the tiled layer and for navigation between screens,
@ -767,12 +806,54 @@ doCenterNavigation dir (cur, rect) winrects
-- or it has the same distance but comes later
-- in the window stack
-- | Implements Hybrid navigation. This attempts Line navigation first,
-- then falls back on Center navigation if it finds no suitable target window.
doHybridNavigation :: Eq a => Direction2D -> Rect a -> [Rect a] -> Maybe a
doHybridNavigation = applyToBoth (<|>) doLineNavigation doCenterNavigation
where
applyToBoth f g h a b c = f (g a b c) (h a b c)
-- x -y w h format is a pain. Let's use side coordinates. We assume x1 <= x2 and
-- y1 <= y2, and make the assumption valid by initialising SideRects with the
-- property and carefully preserving it over any individual transformation.
data SideRect = SideRect { x1 :: Int, x2 :: Int, y1 :: Int, y2 :: Int }
deriving Show
-- Conversion from Rectangle format to SideRect.
toSR :: Rectangle -> SideRect
toSR (Rectangle x y w h) = SideRect (fi x) (fi x + fi w) (-fi y - fi h) (-fi y)
-- Implements side navigation with bias.
doSideNavigationWithBias ::
Eq a => Int -> Direction2D -> Rect a -> [Rect a] -> Maybe a
doSideNavigationWithBias bias dir (cur, rect)
= fmap fst . listToMaybe
. L.sortBy (comparing dist) . foldr acClosest []
. filter (`toRightOf` (cur, transform rect))
. map (fmap transform)
where
-- Getting the center of the current window so we can make it the new origin.
cOf r = ((x1 r + x2 r) `div` 2, (y1 r + y2 r) `div` 2)
(x0, y0) = cOf . toSR $ rect
-- Translate the given SideRect by (-x0, -y0).
translate r = SideRect (x1 r - x0) (x2 r - x0) (y1 r - y0) (y2 r - y0)
-- Rotate the given SideRect 90 degrees counter-clockwise about the origin.
rHalfPiCC r = SideRect (-y2 r) (-y1 r) (x1 r) (x2 r)
-- Apply the above function until d becomes synonymous with R (wolog).
rotateToR d = let (_, _:l) = break (d ==) [U, L, D, R]
in foldr (const $ (.) rHalfPiCC) id l
transform = rotateToR dir . translate . toSR
-- (_, r) `toRightOf` (_, c) iff r has points to the right of c that aren't
-- below or above c, i.e. iff:
-- [x1 r, x2 r] x [y1 r, y2 r] intersects (x2 c, infinity) x (y1 c, y2 c)
toRightOf (_, r) (_, c) = (x2 r > x2 c) && (y2 r > y1 c) && (y1 r < y2 c)
-- Greedily accumulate the windows tied for the leftmost left side.
acClosest (w, r) l@((_, r'):_) | x1 r == x1 r' = (w, r) : l
| x1 r > x1 r' = l
acClosest (w, r) _ = (w, r) : []
-- Given a (_, SideRect), calculate how far it is from the y=bias line.
dist (_, r) | (y1 r <= bias) && (bias <= y2 r) = 0
| otherwise = min (abs $ y1 r - bias) (abs $ y2 r - bias)
-- | Swaps the current window with the window given as argument
swap :: Window -> WindowSet -> WindowSet

117
XMonad/Actions/PhysicalScreens.hs
View File

@ -21,6 +21,12 @@ module XMonad.Actions.PhysicalScreens (
, sendToScreen
, onNextNeighbour
, onPrevNeighbour
, horizontalScreenOrderer
, verticalScreenOrderer
, ScreenComparator(ScreenComparator)
, getScreenIdAndRectangle
, screenComparatorById
, screenComparatorByRectangle
) where
import XMonad
@ -36,17 +42,20 @@ physical location relative to each other (as reported by Xinerama),
rather than their @ScreenID@ s, which are arbitrarily determined by
your X server and graphics hardware.
Screens are ordered by the upper-left-most corner, from top-to-bottom
You can specify how to order the screen by giving a ScreenComparator.
To create a screen comparator you can use screenComparatorByRectangle or screenComparatorByScreenId.
The default ScreenComparator orders screens by the upper-left-most corner, from top-to-bottom
and then left-to-right.
Example usage in your @~\/.xmonad\/xmonad.hs@ file:
> import XMonad.Actions.PhysicalScreens
> import Data.Default
> , ((modMask, xK_a), onPrevNeighbour W.view)
> , ((modMask, xK_o), onNextNeighbour W.view)
> , ((modMask .|. shiftMask, xK_a), onPrevNeighbour W.shift)
> , ((modMask .|. shiftMask, xK_o), onNextNeighbour W.shift)
> , ((modMask, xK_a), onPrevNeighbour def W.view)
> , ((modMask, xK_o), onNextNeighbour def W.view)
> , ((modMask .|. shiftMask, xK_a), onPrevNeighbour def W.shift)
> , ((modMask .|. shiftMask, xK_o), onNextNeighbour def W.shift)
> --
> -- mod-{w,e,r}, Switch to physical/Xinerama screens 1, 2, or 3
@ -54,7 +63,7 @@ Example usage in your @~\/.xmonad\/xmonad.hs@ file:
> --
> [((modm .|. mask, key), f sc)
> | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..]
> , (f, mask) <- [(viewScreen, 0), (sendToScreen, shiftMask)]]
> , (f, mask) <- [(viewScreen def, 0), (sendToScreen def, shiftMask)]]
For detailed instructions on editing your key bindings, see
"XMonad.Doc.Extending#Editing_key_bindings".
@ -63,52 +72,78 @@ For detailed instructions on editing your key bindings, see
-- | The type of the index of a screen by location
newtype PhysicalScreen = P Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real)
getScreenIdAndRectangle :: (W.Screen i l a ScreenId ScreenDetail) -> (ScreenId, Rectangle)
getScreenIdAndRectangle screen = (W.screen screen, rect) where
rect = screenRect $ W.screenDetail screen
-- | Translate a physical screen index to a "ScreenId"
getScreen :: PhysicalScreen -> X (Maybe ScreenId)
getScreen (P i) = do w <- gets windowset
let screens = W.current w : W.visible w
if i<0 || i >= length screens
then return Nothing
else let ss = sortBy (cmpScreen `on` (screenRect . W.screenDetail)) screens
in return $ Just $ W.screen $ ss !! i
getScreen:: ScreenComparator -> PhysicalScreen -> X (Maybe ScreenId)
getScreen (ScreenComparator cmpScreen) (P i) = do w <- gets windowset
let screens = W.current w : W.visible w
if i<0 || i >= length screens
then return Nothing
else let ss = sortBy (cmpScreen `on` getScreenIdAndRectangle) screens
in return $ Just $ W.screen $ ss !! i
-- | Switch to a given physical screen
viewScreen :: PhysicalScreen -> X ()
viewScreen p = do i <- getScreen p
whenJust i $ \s -> do
w <- screenWorkspace s
whenJust w $ windows . W.view
viewScreen :: ScreenComparator -> PhysicalScreen -> X ()
viewScreen sc p = do i <- getScreen sc p
whenJust i $ \s -> do
w <- screenWorkspace s
whenJust w $ windows . W.view
-- | Send the active window to a given physical screen
sendToScreen :: PhysicalScreen -> X ()
sendToScreen p = do i <- getScreen p
whenJust i $ \s -> do
w <- screenWorkspace s
whenJust w $ windows . W.shift
sendToScreen :: ScreenComparator -> PhysicalScreen -> X ()
sendToScreen sc p = do i <- getScreen sc p
whenJust i $ \s -> do
w <- screenWorkspace s
whenJust w $ windows . W.shift
-- | Compare two screens by their top-left corners, ordering
-- | top-to-bottom and then left-to-right.
cmpScreen :: Rectangle -> Rectangle -> Ordering
cmpScreen (Rectangle x1 y1 _ _) (Rectangle x2 y2 _ _) = compare (y1,x1) (y2,x2)
-- | A ScreenComparator allow to compare two screen based on their coordonate and Xinerama Id
newtype ScreenComparator = ScreenComparator ((ScreenId, Rectangle) -> (ScreenId, Rectangle) -> Ordering)
-- | The default ScreenComparator orders screens by the upper-left-most corner, from top-to-bottom
instance Default ScreenComparator where
def= verticalScreenOrderer
-- | Compare screen only by their coordonate
screenComparatorByRectangle :: (Rectangle -> Rectangle -> Ordering) -> ScreenComparator
screenComparatorByRectangle rectComparator = ScreenComparator comparator where
comparator (_, rec1) (_, rec2) = rectComparator rec1 rec2
-- | Compare screen only by their Xinerama id
screenComparatorById :: (ScreenId -> ScreenId -> Ordering) -> ScreenComparator
screenComparatorById idComparator = ScreenComparator comparator where
comparator (id1, _) (id2, _) = idComparator id1 id2
-- | orders screens by the upper-left-most corner, from top-to-bottom
verticalScreenOrderer :: ScreenComparator
verticalScreenOrderer = screenComparatorByRectangle comparator where
comparator (Rectangle x1 y1 _ _) (Rectangle x2 y2 _ _) = compare (y1, x1) (y2, x2)
-- | orders screens by the upper-left-most corner, from left-to-right
horizontalScreenOrderer :: ScreenComparator
horizontalScreenOrderer = screenComparatorByRectangle comparator where
comparator (Rectangle x1 y1 _ _) (Rectangle x2 y2 _ _) = compare (x1, y1) (x2, y2)
-- | Get ScreenId for neighbours of the current screen based on position offset.
getNeighbour :: Int -> X ScreenId
getNeighbour d = do w <- gets windowset
let ss = map W.screen $ sortBy (cmpScreen `on` (screenRect . W.screenDetail)) $ W.current w : W.visible w
curPos = maybe 0 id $ findIndex (== W.screen (W.current w)) ss
pos = (curPos + d) `mod` length ss
return $ ss !! pos
getNeighbour :: ScreenComparator -> Int -> X ScreenId
getNeighbour (ScreenComparator cmpScreen) d =
do w <- gets windowset
let ss = map W.screen $ sortBy (cmpScreen `on` getScreenIdAndRectangle) $ W.current w : W.visible w
curPos = maybe 0 id $ findIndex (== W.screen (W.current w)) ss
pos = (curPos + d) `mod` length ss
return $ ss !! pos
neighbourWindows :: Int -> (WorkspaceId -> WindowSet -> WindowSet) -> X ()
neighbourWindows d f = do s <- getNeighbour d
w <- screenWorkspace s
whenJust w $ windows . f
neighbourWindows :: ScreenComparator -> Int -> (WorkspaceId -> WindowSet -> WindowSet) -> X ()
neighbourWindows sc d f = do s <- getNeighbour sc d
w <- screenWorkspace s
whenJust w $ windows . f
-- | Apply operation on a WindowSet with the WorkspaceId of the next screen in the physical order as parameter.
onNextNeighbour :: (WorkspaceId -> WindowSet -> WindowSet) -> X ()
onNextNeighbour = neighbourWindows 1
onNextNeighbour :: ScreenComparator -> (WorkspaceId -> WindowSet -> WindowSet) -> X ()
onNextNeighbour sc = neighbourWindows sc 1
-- | Apply operation on a WindowSet with the WorkspaceId of the previous screen in the physical order as parameter.
onPrevNeighbour :: (WorkspaceId -> WindowSet -> WindowSet) -> X ()
onPrevNeighbour = neighbourWindows (-1)
onPrevNeighbour :: ScreenComparator -> (WorkspaceId -> WindowSet -> WindowSet) -> X ()
onPrevNeighbour sc = neighbourWindows sc (-1)

407
XMonad/Actions/SwapPromote.hs Normal file
View File

@ -0,0 +1,407 @@
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Actions.SwapPromote
-- Copyright : (c) 2018 Yclept Nemo
-- License : BSD-style (see LICENSE)
--
-- Maintainer :
-- Stability : unstable
-- Portability : unportable
--
-- Module for tracking master window history per workspace, and associated
-- functions for manipulating the stack using such history.
--
-----------------------------------------------------------------------------
module XMonad.Actions.SwapPromote
( -- * Usage
-- $usage
MasterHistory (..)
-- * State Accessors
, getMasterHistoryMap
, getMasterHistoryFromTag
, getMasterHistoryCurrent
, getMasterHistoryFromWindow
, modifyMasterHistoryFromTag
, modifyMasterHistoryCurrent
-- * Log Hook
, masterHistoryHook
-- * Log Hook Building Blocks
, masterHistoryHook'
, updateMasterHistory
-- * Actions
, swapPromote
, swapPromote'
, swapIn
, swapIn'
, swapHybrid
, swapHybrid'
-- * Action Building Blocks
, swapApply
, swapPromoteStack
, swapInStack
, swapHybridStack
-- * List Utilities
, cycleN
, split
, split'
, merge
, merge'
-- * Stack Utilities
, stackSplit
, stackMerge
) where
import XMonad
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS
import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
import Data.Maybe
import Control.Arrow
import Control.Applicative ((<$>),(<*>))
import Control.Monad
-- $usage
-- Given your configuration file, import this module:
--
-- > import XMonad.Actions.SwapPromote
--
-- First add 'masterHistoryHook' to your 'logHook' to track master windows per
-- workspace:
--
-- > myLogHook = otherHook >> masterHistoryHook
--
-- Then replace xmonad's default promote keybinding with 'swapPromote'':
--
-- > , ((mod1Mask, xK_Return), swapPromote' False)
--
-- Depending on your xmonad configuration or window actions the master history
-- may be empty. If this is the case you can still chain another promotion
-- function:
--
-- > import XMonad.Actions.DwmPromote
-- > , ((mod1Mask, xK_Return), whenX (swapPromote False) dwmpromote)
--
-- To be clear, this is only called when the lack of master history hindered
-- the swap and not other conditions, such as having a only a single window.
--
-- While 'swapPromote' preserves window focus, 'swapIn' preserves the focus
-- position - effectively "swapping" new windows into focus without moving the
-- zipper. A mix of both, 'swapHybrid' promotes focused non-master windows
-- while swapping windows into the focused master. This works well on layouts
-- with large masters. Both come with chainable variants, see 'swapIn'' and
-- 'swapHybrid''.
--
-- So far floating windows have been treated no differently than tiled windows
-- even though their positions are independent of the stack. Often, yanking
-- floating windows in and out of the workspace will obliterate the stack
-- history - particularly frustrating with 'XMonad.Util.Scratchpad' since it is
-- toggled so frequenty and always replaces the master window. That's why the
-- swap functions accept a boolean argument; when @True@ non-focused floating
-- windows will be ignored.
--
-- All together:
--
-- > , ((mod1Mask, xK_Return), whenX (swapHybrid True) dwmpromote)
-- | Mapping from workspace tag to master history list. The current master is
-- the head of the list, the previous master the second element, and so on.
-- Without history, the list is empty.
newtype MasterHistory = MasterHistory
{ getMasterHistory :: M.Map WorkspaceId [Window]
} deriving (Read,Show,Typeable)
instance ExtensionClass MasterHistory where
initialValue = MasterHistory M.empty
-- | Return the master history map from the state.
getMasterHistoryMap :: X (M.Map WorkspaceId [Window])
getMasterHistoryMap = XS.gets getMasterHistory
-- | Return the master history list of a given tag. The master history list may
-- be empty. An invalid tag will also result in an empty list.
getMasterHistoryFromTag :: WorkspaceId -> X [Window]
getMasterHistoryFromTag t = M.findWithDefault [] t <$> getMasterHistoryMap
-- | Return the master history list of the current workspace.
getMasterHistoryCurrent :: X [Window]
getMasterHistoryCurrent = gets (W.currentTag . windowset)
>>= getMasterHistoryFromTag
-- | Return the master history list of the workspace containing the given
-- window. Return an empty list if the window is not in the stackset.
getMasterHistoryFromWindow :: Window -> X [Window]
getMasterHistoryFromWindow w = gets (W.findTag w . windowset)
>>= maybe (return []) getMasterHistoryFromTag
-- | Modify the master history list of a given workspace, or the empty list of
-- no such workspace is mapped. The result is then re-inserted into the master
-- history map.
modifyMasterHistoryFromTag :: WorkspaceId -> ([Window] -> [Window]) -> X ()
modifyMasterHistoryFromTag t f = XS.modify $ \(MasterHistory m) ->
let l = M.findWithDefault [] t m
in MasterHistory $ M.insert t (f l) m
-- | Modify the master history list of the current workspace. While the current
-- workspace is guaranteed to exist; its master history may not. For more
-- information see 'modifyMasterHistoryFromTag'.
modifyMasterHistoryCurrent :: ([Window] -> [Window]) -> X ()
modifyMasterHistoryCurrent f = gets (W.currentTag . windowset)
>>= flip modifyMasterHistoryFromTag f
-- | A 'logHook' to update the master history mapping. Non-existent workspaces
-- are removed, and the master history list for the current workspaces is
-- updated. See 'masterHistoryHook''.
masterHistoryHook :: X ()
masterHistoryHook = masterHistoryHook' True updateMasterHistory
-- | Backend for 'masterHistoryHook'.
masterHistoryHook' :: Bool
-- ^ If @True@, remove non-existent workspaces.
-> ([Window] -> [Window] -> [Window])
-- ^ Function used to update the master history list of
-- the current workspace. First argument is the master
-- history, second is the integrated stack. See
-- 'updateMasterHistory' for more details.
-> X ()
masterHistoryHook' removeWorkspaces historyModifier = do
wset <- gets windowset
let W.Workspace wid _ mst = W.workspace . W.current $ wset
tags = map W.tag $ W.workspaces wset
st = W.integrate' mst
XS.modify $ \(MasterHistory mm) ->
let mm' = if removeWorkspaces
then restrictKeys mm $ S.fromList tags
else mm
ms = M.findWithDefault [] wid mm'
ms' = historyModifier ms st
in MasterHistory $ M.insert wid ms' mm'
-- | Less efficient version of 'M.restrictKeys'. Given broader eventual
-- adoption, replace this with 'M.restrictKeys'.
restrictKeys :: Ord k => M.Map k a -> S.Set k -> M.Map k a
restrictKeys m s = M.filterWithKey (\k _ -> k `S.member` s) m
-- | Given the current master history list and an integrated stack, return the
-- new master history list. The current master is either moved (if it exists
-- within the history) or added to the head of the list, and all missing (i.e.
-- closed) windows are removed.
updateMasterHistory :: [Window] -- ^ The master history list.
-> [Window] -- ^ The integrated stack.
-> [Window]
updateMasterHistory _ [] = []
updateMasterHistory ms ws@(w:_) = (w : delete w ms) `intersect` ws
-- | Wrap 'swapPromoteStack'; see also 'swapApply'.
swapPromote :: Bool -> X Bool
swapPromote = flip swapApply swapPromoteStack
-- | Like 'swapPromote'' but discard the result.
swapPromote' :: Bool -> X ()
swapPromote' = void . swapPromote
-- | Wrap 'swapInStack'; see also 'swapApply'.
swapIn :: Bool -> X Bool
swapIn = flip swapApply swapInStack
-- | Like 'swapIn'' but discard the result.
swapIn' :: Bool -> X ()
swapIn' = void . swapIn
-- | Wrap 'swapHybridStack'; see also 'swapApply'.
swapHybrid :: Bool -> X Bool
swapHybrid = flip swapApply swapHybridStack
-- | Like 'swapHybrid'' but discard the result.
swapHybrid' :: Bool -> X ()
swapHybrid' = void . swapHybrid
-- | Apply the given master history stack modifier to the current stack. If
-- given @True@, all non-focused floating windows will be ignored. Return
-- @True@ if insufficient history; if so use 'whenX' to sequence a backup
-- promotion function.
swapApply :: Bool
-> (Maybe Window -> W.Stack Window -> (Bool,W.Stack Window))
-> X Bool
swapApply ignoreFloats swapFunction = do
fl <- gets $ W.floating . windowset
st <- gets $ W.stack . W.workspace . W.current . windowset
ch <- getMasterHistoryCurrent
let swapApply' s1 =
let fl' = if ignoreFloats then M.keysSet fl else S.empty
ff = (||) <$> (`S.notMember` fl') <*> (== W.focus s1)
fh = filter ff ch
pm = listToMaybe . drop 1 $ fh
(r,s2) = stackSplit s1 fl' :: ([(Int,Window)],W.Stack Window)
(b,s3) = swapFunction pm s2
s4 = stackMerge s3 r
mh = let w = head . W.integrate $ s3
in const $ w : delete w ch
in (b,Just s4,mh)
(x,y,z) = maybe (False,Nothing,id) swapApply' st
-- Any floating master windows will be added to the history when 'windows'
-- calls the log hook.
modifyMasterHistoryCurrent z
windows $ W.modify Nothing . const $ y
return x
-- | If the focused window is the master window and there is no previous
-- master, do nothing. Otherwise swap the master with the previous master. If
-- the focused window is not the master window, swap it with the master window.
-- In either case focus follows the original window, i.e. the focused window
-- does not change, only its position.
--
-- The first argument is the previous master (which may not exist), the second
-- a window stack. Return @True@ if the master history hindered the swap; the
-- history is either empty or out-of-sync. Though the latter shouldn't happen
-- this function never changes the stack under such circumstances.
swapPromoteStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window)
swapPromoteStack _ st@(W.Stack _x [] []) = (False,st)
swapPromoteStack Nothing st@(W.Stack _x [] _r) = (True,st)
swapPromoteStack (Just pm) (W.Stack x [] r) =
let (r',l') = (reverse *** cycleN 1) $ span (/= pm) $ reverse r
st' = W.Stack x l' r'
b = null l'
in (b,st')
swapPromoteStack _ (W.Stack x l r) =
let r' = (++ r) . cycleN 1 . reverse $ l
st' = W.Stack x [] r'
in (False,st')
-- | Perform the same swap as 'swapPromoteStack'. However the new window
-- receives the focus; it appears to "swap into" the position of the original
-- window. Under this model focus follows stack position and the zipper does
-- not move.
--
-- See 'swapPromoteStack' for more details regarding the parameters.
swapInStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window)
swapInStack _ st@(W.Stack _x [] []) = (False,st)
swapInStack Nothing st@(W.Stack _x [] _r) = (True,st)
swapInStack (Just pm) (W.Stack x [] r) =
let (x',r') = case span (/= pm) r of
(__,[]) -> (x,r)
(sl,sr) -> (pm,sl ++ x : drop 1 sr)
st' = W.Stack x' [] r'
b = x' == x
in (b,st')
swapInStack _ (W.Stack x l r) =
let l' = init l ++ [x]
x' = last l
st' = W.Stack x' l' r
in (False,st')
-- | If the focused window is the master window, use 'swapInStack'. Otherwise use
-- 'swapPromoteStack'.
--
-- See 'swapPromoteStack' for more details regarding the parameters.
swapHybridStack :: Maybe Window -> W.Stack Window -> (Bool,W.Stack Window)
swapHybridStack m st@(W.Stack _ [] _) = swapInStack m st
swapHybridStack m st = swapPromoteStack m st
-- | Cycle a list by the given count. If positive, cycle to the left. If
-- negative, cycle to the right:
--
-- >>> cycleN 2 [1,2,3,4,5]
-- [3,4,5,1,2]
-- >>> cycleN (-2) [1,2,3,4,5]
-- [4,5,1,2,3]
cycleN :: Int -> [a] -> [a]
cycleN n ls =
let l = length ls
in take l $ drop (n `mod` l) $ cycle ls
-- | Wrap 'split'' with an initial index of @0@, discarding the list's length.
split :: (Num a, Enum a) => (b -> Bool) -> [b] -> ([(a,b)],[b])
split p l =
let (_,ys,ns) = split' p 0 l
in (ys,ns)
-- | Given a predicate, an initial index and a list, return a tuple containing:
--
-- * List length.
-- * Indexed list of elements which satisfy the predicate. An indexed element
-- is a tuple containing the element index (offset by the initial index) and
-- the element.
-- * List of elements which do not satisfy the predicate.
--
-- The initial index and length of the list simplify chaining calls to this
-- function, such as for zippers of lists.
split' :: (Num a, Enum a) => (b -> Bool) -> a -> [b] -> (a,[(a,b)],[b])
split' p i l =
let accumulate e (c,ys,ns) = if p (snd e)
then (c+1,e:ys,ns)
else (c+1,ys,e:ns)
(c',ys',ns') = foldr accumulate (0,[],[]) $ zip [i..] l
in (c',ys',snd . unzip $ ns')
-- | Wrap 'merge'' with an initial virtual index of @0@. Return only the
-- unindexed list with elements from the leftover indexed list appended.
merge :: (Ord a, Num a) => [(a,b)] -> [b] -> [b]
merge il ul =
let (_,il',ul') = merge' 0 il ul
in ul' ++ map snd il'
-- | Inverse of 'split'. Merge an indexed list with an unindexed list (see
-- 'split''). Given a virtual index, an indexed list and an unindexed list,
-- return a tuple containing:
--
-- * Virtual index /after/ the unindexed list
-- * Remainder of the indexed list
-- * Merged unindexed list
--
-- If the indexed list is empty, this functions consumes the entire unindexed
-- list. If the unindexed list is empty, this function consumes only adjacent
-- indexed elements. For example, @[(10,"ten"),(12,"twelve")]@ implies missing
-- unindexed elements and so once @(10,"ten")@ is consumed this function
-- concludes.
--
-- The indexed list is assumed to have been created by 'split'' and not checked
-- for correctness. Indices are assumed to be ascending, i.e.
-- > [(1,"one"),(2,"two"),(4,"four")]
--
-- The initial and final virtual indices simplify chaining calls to the this
-- function, as as for zippers of lists. Positive values shift the unindexed
-- list towards the tail, as if preceded by that many elements.
merge' :: (Ord a, Num a) => a -> [(a,b)] -> [b] -> (a,[(a,b)],[b])
merge' i il@((j,a):ps) ul@(b:bs) = if j <= i
then let (x,y,z) = merge' (i+1) ps ul
in (x,y,a:z)
else let (x,y,z) = merge' (i+1) il bs
in (x,y,b:z)
merge' i [] (b:bs) =
let (x,y,z) = merge' (i+1) [] bs
in (x,y,b:z)
merge' i il@((j,a):ps) [] = if j <= i
then let (x,y,z) = merge' (i+1) ps []
in (x,y,a:z)
else (i,il,[])
merge' i [] [] =
(i,[],[])
-- | Remove all elements of the set from the stack. Skip the currently focused
-- member. Return an indexed list of excluded elements and the modified stack.
-- Use 'stackMerge' to re-insert the elements using this list.
stackSplit :: (Num a, Enum a, Ord b) => W.Stack b -> S.Set b -> ([(a,b)],W.Stack b)
stackSplit (W.Stack x l r) s =
let (c,fl,tl) = split' (`S.member` s) 0 (reverse l)
(_,fr,tr) = split' (`S.member` s) (c+1) r
in (fl++fr,W.Stack x (reverse tl) tr)
-- | Inverse of 'stackSplit'. Given a list of elements and their original
-- indices, re-insert the elements into these same positions within the stack.
-- Skip the currently focused member. Works best if the stack's length hasn't
-- changed, though if shorter any leftover elements will be tacked on.
stackMerge :: (Ord a, Num a) => W.Stack b -> [(a,b)] -> W.Stack b
stackMerge (W.Stack x l r) il =
let (i,il1,l') = merge' 0 il (reverse l)
(_,il2,r') = merge' (i+1) il1 r
in W.Stack x (reverse l') (r' ++ map snd il2)

12
XMonad/Config/Azerty.hs
View File

@ -17,7 +17,7 @@
module XMonad.Config.Azerty (
-- * Usage
-- $usage
azertyConfig, azertyKeys
azertyConfig, azertyKeys, belgianConfig, belgianKeys
) where
import XMonad
@ -40,11 +40,17 @@ import qualified Data.Map as M
azertyConfig = def { keys = azertyKeys <+> keys def }
azertyKeys conf@(XConfig {modMask = modm}) = M.fromList $
belgianConfig = def { keys = belgianKeys <+> keys def }
azertyKeys = azertyKeysTop [0x26,0xe9,0x22,0x27,0x28,0x2d,0xe8,0x5f,0xe7,0xe0]
belgianKeys = azertyKeysTop [0x26,0xe9,0x22,0x27,0x28,0xa7,0xe8,0x21,0xe7,0xe0]
azertyKeysTop topRow conf@(XConfig {modMask = modm}) = M.fromList $
[((modm, xK_semicolon), sendMessage (IncMasterN (-1)))]
++
[((m .|. modm, k), windows $ f i)
| (i, k) <- zip (workspaces conf) [0x26,0xe9,0x22,0x27,0x28,0x2d,0xe8,0x5f,0xe7,0xe0],
| (i, k) <- zip (workspaces conf) topRow,
(f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]]
++
-- mod-{z,e,r} %! Switch to physical/Xinerama screens 1, 2, or 3

2
XMonad/Config/Gnome.hs
View File

@ -47,7 +47,7 @@ gnomeConfig = desktopConfig
gnomeKeys (XConfig {modMask = modm}) = M.fromList $
[ ((modm, xK_p), gnomeRun)
, ((modm .|. shiftMask, xK_q), spawn "gnome-session-save --kill") ]
, ((modm .|. shiftMask, xK_q), spawn "gnome-session-quit --logout") ]
-- | Launch the "Run Application" dialog. gnome-panel must be running for this
-- to work.

79
XMonad/Config/Saegesser.hs Executable file
View File

@ -0,0 +1,79 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
---------------------------------------------------------------------
-- |
-- A mostly striped down configuration that demonstrates spawnOnOnce
--
---------------------------------------------------------------------
import System.IO
import XMonad
import XMonad.Hooks.DynamicLog
import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers
import XMonad.Hooks.UrgencyHook
import XMonad.Hooks.FadeInactive
import XMonad.Layout.NoBorders
import XMonad.Layout.ResizableTile
import XMonad.Layout.Mosaic
import XMonad.Util.Run
import XMonad.Util.Cursor
import XMonad.Util.NamedScratchpad
import XMonad.Util.Scratchpad
import XMonad.Util.SpawnOnce
import XMonad.Actions.CopyWindow
import XMonad.Actions.SpawnOn
import qualified XMonad.StackSet as W
main = do
myStatusBarPipe <- spawnPipe "xmobar"
xmonad $ docks $ withUrgencyHook NoUrgencyHook $ def
{ terminal = "xterm"
, workspaces = myWorkspaces
, layoutHook = myLayoutHook
, manageHook = myManageHook <+> manageSpawn
, startupHook = myStartupHook
, logHook = myLogHook myStatusBarPipe
, focusFollowsMouse = False
}
myManageHook = composeOne
[ isDialog -?> doFloat
, className =? "trayer" -?> doIgnore
, className =? "Skype" -?> doShift "chat"
, appName =? "libreoffice" -?> doShift "office"
, return True -?> doF W.swapDown
]
myWorkspaces = [ "web", "emacs", "chat", "vm", "office", "media", "xterms", "8", "9", "0"]
myStartupHook = do
setDefaultCursor xC_left_ptr
spawnOnOnce "emacs" "emacs"
spawnNOnOnce 4 "xterms" "xterm"
myLayoutHook = smartBorders $ avoidStruts $ standardLayouts
where standardLayouts = tiled ||| mosaic 2 [3,2] ||| Mirror tiled ||| Full
tiled = ResizableTall nmaster delta ratio []
nmaster = 1
delta = 0.03
ratio = 0.6
myLogHook p = do
copies <- wsContainingCopies
let check ws | ws == "NSP" = "" -- Hide the scratchpad workspace
| ws `elem` copies = xmobarColor "red" "black" $ ws -- Workspaces with copied windows are red on black
| otherwise = ws
dynamicLogWithPP $ xmobarPP { ppHidden = check
, ppOutput = hPutStrLn p
, ppUrgent = xmobarColor "white" "red"
, ppTitle = xmobarColor "green" "" . shorten 180
}
fadeInactiveLogHook 0.6

79
XMonad/Hooks/DebugEvents.hs
View File

@ -34,6 +34,7 @@ import Control.Exception.Extensible as E
import Control.Monad.State
import Control.Monad.Reader
import Data.Char (isDigit)
import Data.Maybe (fromJust)
import Data.List (genericIndex
,genericLength
,unfoldr
@ -696,30 +697,31 @@ dumpList'' m ((l,p,t):ps) sep = do
dumpString :: Decoder Bool
dumpString = do
fmt <- asks pType
[cOMPOUND_TEXT,uTF8_STRING] <- inX $ mapM getAtom ["COMPOUND_TEXT","UTF8_STRING"]
case () of
() | fmt == cOMPOUND_TEXT -> guardSize 16 (...)
| fmt == sTRING -> guardSize 8 $ do
vs <- gets value
modify (\r -> r {value = []})
let ss = flip unfoldr (map twiddle vs) $
\s -> if null s
then Nothing
else let (w,s'') = break (== '\NUL') s
s' = if null s''
then s''
else tail s''
in Just (w,s')
case ss of
[s] -> append $ show s
ss' -> let go (s:ss'') c = append c >>
append (show s) >>
go ss'' ","
go [] _ = append "]"
in append "[" >> go ss' ""
| fmt == uTF8_STRING -> dumpUTF -- duplicate type test instead of code :)
| otherwise -> (inX $ atomName fmt) >>=
failure . ("unrecognized string type " ++)
x <- inX $ mapM getAtom ["COMPOUND_TEXT","UTF8_STRING"]
case x of
[cOMPOUND_TEXT,uTF8_STRING] -> case () of
() | fmt == cOMPOUND_TEXT -> guardSize 16 (...)
| fmt == sTRING -> guardSize 8 $ do
vs <- gets value
modify (\r -> r {value = []})
let ss = flip unfoldr (map twiddle vs) $
\s -> if null s
then Nothing
else let (w,s'') = break (== '\NUL') s
s' = if null s''
then s''
else tail s''
in Just (w,s')
case ss of
[s] -> append $ show s
ss' -> let go (s:ss'') c = append c >>
append (show s) >>
go ss'' ","
go [] _ = append "]"
in append "[" >> go ss' ""
| fmt == uTF8_STRING -> dumpUTF -- duplicate type test instead of code :)
| otherwise -> (inX $ atomName fmt) >>=
failure . ("unrecognized string type " ++)
-- show who owns a selection
dumpSelection :: Decoder Bool
@ -917,7 +919,7 @@ dumpExcept xs item = do
let w = (length (value sp) - length vs) * 8
-- now we get to reparse again so we get our copy of it
put sp
Just v <- getInt' w
v <- fmap fromJust (getInt' w)
-- and after all that, we can process the exception list
dumpExcept' xs that v
@ -1176,20 +1178,23 @@ getInt w f = getInt' w >>= maybe (return False) (append . f)
-- @@@@@@@@@ evil beyond evil. there *has* to be a better way
inhale :: Int -> Decoder Integer
inhale 8 = do
[b] <- eat 1
return $ fromIntegral b
x <- eat 1
case x of
[b] -> return $ fromIntegral b
inhale 16 = do
[b0,b1] <- eat 2
io $ allocaArray 2 $ \p -> do
pokeArray p [b0,b1]
[v] <- peekArray 1 (castPtr p :: Ptr Word16)
return $ fromIntegral v
x <- eat 2
case x of
[b0,b1] -> io $ allocaArray 2 $ \p -> do
pokeArray p [b0,b1]
[v] <- peekArray 1 (castPtr p :: Ptr Word16)
return $ fromIntegral v
inhale 32 = do
[b0,b1,b2,b3] <- eat 4
io $ allocaArray 4 $ \p -> do
pokeArray p [b0,b1,b2,b3]
[v] <- peekArray 1 (castPtr p :: Ptr Word32)
return $ fromIntegral v
x <- eat 4
case x of
[b0,b1,b2,b3] -> io $ allocaArray 4 $ \p -> do
pokeArray p [b0,b1,b2,b3]
[v] <- peekArray 1 (castPtr p :: Ptr Word32)
return $ fromIntegral v
inhale b = error $ "inhale " ++ show b
eat :: Int -> Decoder Raw

72
XMonad/Hooks/DynamicLog.hs
View File

@ -24,6 +24,7 @@ module XMonad.Hooks.DynamicLog (
-- * Drop-in loggers
dzen,
dzenWithFlags,
xmobar,
statusBar,
dynamicLog,
@ -42,8 +43,8 @@ module XMonad.Hooks.DynamicLog (
-- * Formatting utilities
wrap, pad, trim, shorten,
xmobarColor, xmobarStrip,
xmobarStripTags,
xmobarColor, xmobarAction, xmobarRaw,
xmobarStrip, xmobarStripTags,
dzenColor, dzenEscape, dzenStrip,
-- * Internal formatting functions
@ -61,7 +62,7 @@ import Codec.Binary.UTF8.String (encodeString)
import Control.Monad (liftM2, msum)
import Data.Char ( isSpace, ord )
import Data.List (intersperse, stripPrefix, isPrefixOf, sortBy)
import Data.Maybe ( isJust, catMaybes, mapMaybe )
import Data.Maybe ( isJust, catMaybes, mapMaybe, fromMaybe )
import Data.Ord ( comparing )
import qualified Data.Map as M
import qualified XMonad.StackSet as S
@ -150,6 +151,32 @@ import XMonad.Hooks.ManageDocks
------------------------------------------------------------------------
-- | Run xmonad with a dzen status bar with specified dzen
-- command line arguments.
--
-- > main = xmonad =<< dzenWithFlags flags myConfig
-- >
-- > myConfig = def { ... }
-- >
-- > flags = "-e onstart lower -w 800 -h 24 -ta l -fg #a8a3f7 -bg #3f3c6d"
--
-- This function can be used to customize the arguments passed to dzen2.
-- e.g changing the default width and height of dzen2.
--
-- If you wish to customize the status bar format at all, you'll have to
-- use the 'statusBar' function instead.
--
-- The binding uses the XMonad.Hooks.ManageDocks module to automatically
-- handle screen placement for dzen, and enables 'mod-b' for toggling
-- the menu bar.
--
-- You should use this function only when the default 'dzen' function does not
-- serve your purpose.
--
dzenWithFlags :: LayoutClass l Window
=> String -> XConfig l -> IO (XConfig (ModifiedLayout AvoidStruts l))
dzenWithFlags flags conf = statusBar ("dzen2 " ++ flags) dzenPP toggleStrutsKey conf
-- | Run xmonad with a dzen status bar set to some nice defaults.
--
-- > main = xmonad =<< dzen myConfig
@ -159,16 +186,14 @@ import XMonad.Hooks.ManageDocks
-- The intent is that the above config file should provide a nice
-- status bar with minimal effort.
--
-- If you wish to customize the status bar format at all, you'll have to
-- use the 'statusBar' function instead.
--
-- The binding uses the XMonad.Hooks.ManageDocks module to automatically
-- handle screen placement for dzen, and enables 'mod-b' for toggling
-- the menu bar.
-- the menu bar. Please refer to 'dzenWithFlags' function for further
-- documentation.
--
dzen :: LayoutClass l Window
=> XConfig l -> IO (XConfig (ModifiedLayout AvoidStruts l))
dzen conf = statusBar ("dzen2 " ++ flags) dzenPP toggleStrutsKey conf
dzen conf = dzenWithFlags flags conf
where
fg = "'#a8a3f7'" -- n.b quoting
bg = "'#3f3c6d'"
@ -295,7 +320,8 @@ pprWindowSet sort' urgents pp s = sepBy (ppWsSep pp) . map fmt . sort' $
fmt w = printer pp (S.tag w)
where printer | any (\x -> maybe False (== S.tag w) (S.findTag x s)) urgents = ppUrgent
| S.tag w == this = ppCurrent
| S.tag w `elem` visibles = ppVisible
| S.tag w `elem` visibles && isJust (S.stack w) = ppVisible
| S.tag w `elem` visibles = liftM2 fromMaybe ppVisible ppVisibleNoWindows
| isJust (S.stack w) = ppHidden
| otherwise = ppHiddenNoWindows
@ -392,6 +418,31 @@ xmobarColor :: String -- ^ foreground color: a color name, or #rrggbb format
xmobarColor fg bg = wrap t "</fc>"
where t = concat ["<fc=", fg, if null bg then "" else "," ++ bg, ">"]
-- | Encapsulate text with an action. The text will be displayed, and the
-- action executed when the displayed text is clicked. Illegal input is not
-- filtered, allowing xmobar to display any parse errors. Uses xmobar's new
-- syntax wherein the command is surrounded by backticks.
xmobarAction :: String
-- ^ Command. Use of backticks (`) will cause a parse error.
-> String
-- ^ Buttons 1-5, such as "145". Other characters will cause a
-- parse error.
-> String
-- ^ Displayed/wrapped text.
-> String
xmobarAction command button = wrap l r
where
l = "<action=`" ++ command ++ "` button=" ++ button ++ ">"
r = "</action>"
-- | Encapsulate arbitrary text for display only, i.e. untrusted content if
-- wrapped (perhaps from window titles) will be displayed only, with all tags
-- ignored. Introduced in xmobar 0.21; see their documentation. Be careful not
-- to shorten the result.
xmobarRaw :: String -> String
xmobarRaw "" = ""
xmobarRaw s = concat ["<raw=", show $ length s, ":", s, "/>"]
-- ??? add an xmobarEscape function?
-- | Strip xmobar markup, specifically the <fc>, <icon> and <action> tags and
@ -435,6 +486,8 @@ data PP = PP { ppCurrent :: WorkspaceId -> String
-- contain windows
, ppHiddenNoWindows :: WorkspaceId -> String
-- ^ how to print tags of empty hidden workspaces
, ppVisibleNoWindows :: Maybe (WorkspaceId -> String)
-- ^ how to print tags of empty visible workspaces
, ppUrgent :: WorkspaceId -> String
-- ^ format to be applied to tags of urgent workspaces.
, ppSep :: String
@ -487,6 +540,7 @@ instance Default PP where
, ppVisible = wrap "<" ">"
, ppHidden = id
, ppHiddenNoWindows = const ""
, ppVisibleNoWindows= Nothing
, ppUrgent = id
, ppSep = " : "
, ppWsSep = " "

111
XMonad/Hooks/EwmhDesktops.hs
View File

@ -25,15 +25,19 @@ module XMonad.Hooks.EwmhDesktops (
) where
import Codec.Binary.UTF8.String (encode)
import Control.Applicative((<$>))
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map.Strict as M
import System.IO.Unsafe
import XMonad
import Control.Monad
import qualified XMonad.StackSet as W
import XMonad.Hooks.SetWMName
import qualified XMonad.Util.ExtensibleState as E
import XMonad.Util.XUtils (fi)
import XMonad.Util.WorkspaceCompare
import XMonad.Util.WindowProperties (getProp32)
@ -69,6 +73,58 @@ ewmhDesktopsStartup = setSupported
-- of the current state of workspaces and windows.
ewmhDesktopsLogHook :: X ()
ewmhDesktopsLogHook = ewmhDesktopsLogHookCustom id
-- |
-- Cached desktop names (e.g. @_NET_NUMBER_OF_DESKTOPS@ and
-- @_NET_DESKTOP_NAMES@).
newtype DesktopNames = DesktopNames [String]
deriving (Eq)
instance ExtensionClass DesktopNames where
initialValue = DesktopNames []
-- |
-- Cached client list (e.g. @_NET_CLIENT_LIST@).
newtype ClientList = ClientList [Window]
deriving (Eq)
instance ExtensionClass ClientList where
initialValue = ClientList []
-- |
-- Cached current desktop (e.g. @_NET_CURRENT_DESKTOP@).
newtype CurrentDesktop = CurrentDesktop Int
deriving (Eq)
instance ExtensionClass CurrentDesktop where
initialValue = CurrentDesktop 0
-- |
-- Cached window-desktop assignments (e.g. @_NET_CLIENT_LIST_STACKING@).
newtype WindowDesktops = WindowDesktops (M.Map Window Int)
deriving (Eq)
instance ExtensionClass WindowDesktops where
initialValue = WindowDesktops M.empty
-- |
-- The value of @_NET_ACTIVE_WINDOW@, cached to avoid unnecessary property
-- updates.
newtype ActiveWindow = ActiveWindow Window
deriving (Eq)
instance ExtensionClass ActiveWindow where
initialValue = ActiveWindow none
-- | Compare the given value against the value in the extensible state. Run the
-- action if it has changed.
whenChanged :: (Eq a, ExtensionClass a) => a -> X () -> X ()
whenChanged v action = do
v0 <- E.get
unless (v == v0) $ do
action
E.put v
-- |
-- Generalized version of ewmhDesktopsLogHook that allows an arbitrary
-- user-specified function to transform the workspace list (post-sorting)
@ -77,38 +133,32 @@ ewmhDesktopsLogHookCustom f = withWindowSet $ \s -> do
sort' <- getSortByIndex
let ws = f $ sort' $ W.workspaces s
-- Number of Workspaces
setNumberOfDesktops (length ws)
-- Set number of workspaces and names thereof
let desktopNames = map W.tag ws
whenChanged (DesktopNames desktopNames) $ do
setNumberOfDesktops (length desktopNames)
setDesktopNames desktopNames
-- Names thereof
setDesktopNames (map W.tag ws)
-- Set client list; all windows, with focused windows last
let clientList = nub . concatMap (maybe [] (\(W.Stack x l r) -> reverse l ++ r ++ [x]) . W.stack) $ ws
whenChanged (ClientList clientList) $ setClientList clientList
-- all windows, with focused windows last
let wins = nub . concatMap (maybe [] (\(W.Stack x l r)-> reverse l ++ r ++ [x]) . W.stack) $ ws
setClientList wins
-- Remap the current workspace to handle any renames that f might be doing.
let maybeCurrent' = W.tag <$> listToMaybe (f [W.workspace $ W.current s])
current = join (flip elemIndex (map W.tag ws) <$> maybeCurrent')
whenChanged (CurrentDesktop $ fromMaybe 0 current) $ do
mapM_ setCurrentDesktop current
-- Current desktop
case (elemIndex (W.currentTag s) $ map W.tag ws) of
Nothing -> return ()
Just curr -> do
setCurrentDesktop curr
-- Set window-desktop mapping
let windowDesktops =
let f wsId workspace = M.fromList [ (winId, wsId) | winId <- W.integrate' $ W.stack workspace ]
in M.unions $ zipWith f [0..] ws
whenChanged (WindowDesktops windowDesktops) $ do
mapM_ (uncurry setWindowDesktop) (M.toList windowDesktops)
-- Per window Desktop
-- To make gnome-panel accept our xinerama stuff, we display
-- all visible windows on the current desktop.
forM_ (W.current s : W.visible s) $ \x ->
forM_ (W.integrate' (W.stack (W.workspace x))) $ \win -> do
setWindowDesktop win curr
forM_ (W.hidden s) $ \w ->
case elemIndex (W.tag w) (map W.tag ws) of
Nothing -> return ()
Just wn -> forM_ (W.integrate' (W.stack w)) $ \win -> do
setWindowDesktop win wn
setActiveWindow
return ()
-- Set active window
let activeWindow' = fromMaybe none (W.peek s)
whenChanged (ActiveWindow activeWindow') $ setActiveWindow activeWindow'
-- |
-- Intercepts messages from pagers and similar applications and reacts on them.
@ -255,9 +305,8 @@ setSupported = withDisplay $ \dpy -> do
setWMName "xmonad"
setActiveWindow :: X ()
setActiveWindow = withWindowSet $ \s -> withDisplay $ \dpy -> do
let w = fromMaybe none (W.peek s)
setActiveWindow :: Window -> X ()
setActiveWindow w = withDisplay $ \dpy -> do
r <- asks theRoot
a <- getAtom "_NET_ACTIVE_WINDOW"
c <- getAtom "WINDOW"

6
XMonad/Hooks/FadeWindows.hs
View File

@ -61,7 +61,8 @@ import Control.Monad.Reader (ask
,asks)
import Control.Monad.State (gets)
import qualified Data.Map as M
import Data.Monoid
import Data.Monoid hiding ((<>))
import Data.Semigroup
import Graphics.X11.Xlib.Extras (Event(..))
@ -134,6 +135,9 @@ instance Monoid Opacity where
r `mappend` OEmpty = r
_ `mappend` r = r
instance Semigroup Opacity where
(<>) = mappend
-- | A FadeHook is similar to a ManageHook, but records window opacity.
type FadeHook = Query Opacity

6
XMonad/Hooks/WallpaperSetter.hs
View File

@ -41,7 +41,8 @@ import Data.Ord (comparing)
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.Monoid
import Data.Monoid hiding ((<>))
import Data.Semigroup
-- $usage
-- This module requires imagemagick and feh to be installed, as these are utilized
@ -86,6 +87,9 @@ instance Monoid WallpaperList where
mappend (WallpaperList w1) (WallpaperList w2) =
WallpaperList $ M.toList $ (M.fromList w2) `M.union` (M.fromList w1)
instance Semigroup WallpaperList where
(<>) = mappend
-- | Complete wallpaper configuration passed to the hook
data WallpaperConf = WallpaperConf {
wallpaperBaseDir :: FilePath -- ^ Where the wallpapers reside (if empty, will look in \~\/.wallpapers/)

139
XMonad/Layout/BinaryColumn.hs Normal file
View File

@ -0,0 +1,139 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.BinaryColumn
-- Copyright : (c) 2009 Ilya Portnov, (c) 2018 Campbell Barton
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Campbell Barton <ideasman42@gmail.com>
-- Stability : unstable
-- Portability : unportable
--
-- Provides Column layout that places all windows in one column.
-- Each window is half the height of the previous,
-- except for the last pair of windows.
--
-- Note: Originally based on 'XMonad.Layout.Column' with changes:
--
-- * Adding/removing windows doesn't resize all other windows.
-- (last window pair exception).
-- * Minimum window height option.
--
-----------------------------------------------------------------------------
module XMonad.Layout.BinaryColumn (
-- * Usage
-- $usage
BinaryColumn (..)
) where
import XMonad
import qualified XMonad.StackSet
import qualified Data.List
-- $usage
-- This module defines layout named BinaryColumn.
-- It places all windows in one column.
-- Windows heights are calculated to prevent window resizing whenever
-- a window is added or removed.
-- This is done by keeping the last two windows in the stack the same height.
--
-- You can use this module by adding following in your @xmonad.hs@:
--
-- > import XMonad.Layout.BinaryColumn
--
-- Then add layouts to your layoutHook:
--
-- > myLayoutHook = BinaryColumn 1.0 32 ||| ...
--
-- The first value causes the master window to take exactly half of the screen,
-- the second ensures that windows are no less than 32 pixels tall.
--
-- Shrink/Expand can be used to adjust the first value by increments of 0.1.
--
-- * 2.0 uses all space for the master window
-- (minus the space for windows which get their fixed height).
-- * 0.0 gives an evenly spaced grid.
-- Negative values reverse the sizes so the last
-- window in the stack becomes larger.
--
data BinaryColumn a = BinaryColumn Float Int
deriving (Read, Show)
instance XMonad.LayoutClass BinaryColumn a where
pureLayout = columnLayout
pureMessage = columnMessage
columnMessage :: BinaryColumn a -> SomeMessage -> Maybe (BinaryColumn a)
columnMessage (BinaryColumn q min_size) m = fmap resize (fromMessage m)
where
resize Shrink = BinaryColumn (max (-2.0) (q - 0.1)) min_size
resize Expand = BinaryColumn (min 2.0 (q + 0.1)) min_size
columnLayout :: BinaryColumn a
-> XMonad.Rectangle
-> XMonad.StackSet.Stack a
-> [(a, XMonad.Rectangle)]
columnLayout (BinaryColumn scale min_size) rect stack = zip ws rects
where
ws = XMonad.StackSet.integrate stack
n = length ws
scale_abs = abs scale
heights_noflip =
let
-- Regular case: check for min size.
f n size div False = let
n_fl = (fromIntegral n)
n_prev_fl = (fromIntegral (n + 1))
div_test = min (div) (n_prev_fl)
value_test = (toInteger (round ((fromIntegral size) / div_test)))
value_max = size - (toInteger (min_size * n))
(value, divide_next, no_room) =
if value_test < value_max then
(value_test, div, False)
else
(value_max, n_fl, True)
size_next = size - value
n_next = n - 1
in value
: f n_next size_next divide_next no_room
-- Fallback case: when windows have reached min size
-- simply create an even grid with the remaining space.
f n size div True = let
n_fl = (fromIntegral n)
value_even = ((fromIntegral size) / div)
value = (toInteger (round value_even))
n_next = n - 1
size_next = size - value
divide_next = n_fl
in value
: f n_next size_next n_fl True
-- Last item: included twice.
f 0 size div no_room_prev =
[size];
in f
n_init size_init divide_init False
where
n_init = n - 1
size_init = (toInteger (rect_height rect))
divide_init =
if scale_abs == 0.0 then
(fromIntegral n)
else
(1.0 / (0.5 * scale_abs))
heights =
if (scale < 0.0) then
Data.List.reverse (take n heights_noflip)
else
heights_noflip
ys = [fromIntegral $ sum $ take k heights | k <- [0..n - 1]]
rects = map (mkRect rect) $ zip heights ys
mkRect :: XMonad.Rectangle
-> (Integer,XMonad.Position)
-> XMonad.Rectangle
mkRect (XMonad.Rectangle xs ys ws _) (h, y) =
XMonad.Rectangle xs (ys + fromIntegral y) ws (fromInteger h)

38
XMonad/Layout/Fullscreen.hs
View File

@ -30,17 +30,19 @@ module XMonad.Layout.Fullscreen
,FullscreenFloat, FullscreenFocus, FullscreenFull
) where
import XMonad
import XMonad.Layout.LayoutModifier
import XMonad.Util.WindowProperties
import XMonad.Hooks.ManageHelpers (isFullscreen)
import qualified XMonad.StackSet as W
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map as M
import Control.Monad
import Control.Arrow (second)
import XMonad
import XMonad.Layout.LayoutModifier
import XMonad.Hooks.ManageHelpers (isFullscreen)
import XMonad.Util.WindowProperties
import qualified XMonad.Util.Rectangle as R
import qualified XMonad.StackSet as W
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map as M
import Control.Monad
import Control.Arrow (second)
-- $usage
-- Provides a ManageHook and an EventHook that sends layout messages
@ -107,9 +109,12 @@ instance LayoutModifier FullscreenFull Window where
_ -> Nothing
pureModifier (FullscreenFull frect fulls) rect _ list =
(map (flip (,) rect') visfulls ++ rest, Nothing)
where visfulls = intersect fulls $ map fst list
rest = filter (flip notElem visfulls . fst) list
(visfulls' ++ rest', Nothing)
where (visfulls,rest) = partition (flip elem fulls . fst) list
visfulls' = map (second $ const rect') visfulls
rest' = if null visfulls'
then rest
else filter (not . R.supersetOf rect' . snd) rest
rect' = scaleRationalRect rect frect
instance LayoutModifier FullscreenFocus Window where
@ -122,7 +127,7 @@ instance LayoutModifier FullscreenFocus Window where
pureModifier (FullscreenFocus frect fulls) rect (Just (W.Stack {W.focus = f})) list
| f `elem` fulls = ((f, rect') : rest, Nothing)
| otherwise = (list, Nothing)
where rest = filter ((/= f) . fst) list
where rest = filter (not . orP (== f) (R.supersetOf rect')) list
rect' = scaleRationalRect rect frect
pureModifier _ _ Nothing list = (list, Nothing)
@ -240,3 +245,6 @@ fullscreenManageHook' isFull = isFull --> do
sendMessageWithNoRefresh FullscreenChanged cw
idHook
-- | Applies a pair of predicates to a pair of operands, combining them with ||.
orP :: (a -> Bool) -> (b -> Bool) -> (a, b) -> Bool
orP f g (x, y) = f x || g y

72
XMonad/Layout/Gaps.hs
View File

@ -14,7 +14,9 @@
-- be used for tiling, along with support for toggling gaps on and
-- off.
--
-- Note that "XMonad.Hooks.ManageDocks" is the preferred solution for
-- Note 1: For gaps\/space around /windows/ see "XMonad.Layout.Spacing".
--
-- Note 2: "XMonad.Hooks.ManageDocks" is the preferred solution for
-- leaving space for your dock-type applications (status bars,
-- toolbars, docks, etc.), since it automatically sets up appropriate
-- gaps, allows them to be toggled, etc. However, this module may
@ -29,8 +31,8 @@ module XMonad.Layout.Gaps (
-- * Usage
-- $usage
Direction2D(..), Gaps,
GapSpec, gaps, gaps', GapMessage(..)
GapSpec, gaps, gaps', GapMessage(..),
weakModifyGaps, modifyGap, setGaps, setGap
) where
import XMonad.Core
@ -55,10 +57,23 @@ import Data.List (delete)
-- You can additionally add some keybindings to toggle or modify the gaps,
-- for example:
--
-- > , ((modm .|. controlMask, xK_g), sendMessage $ ToggleGaps) -- toggle all gaps
-- > , ((modm .|. controlMask, xK_t), sendMessage $ ToggleGap U) -- toggle the top gap
-- > , ((modm .|. controlMask, xK_w), sendMessage $ IncGap 5 R) -- increment the right-hand gap
-- > , ((modm .|. controlMask, xK_q), sendMessage $ DecGap 5 R) -- decrement the right-hand gap
-- > , ((modm .|. controlMask, xK_g), sendMessage $ ToggleGaps) -- toggle all gaps
-- > , ((modm .|. controlMask, xK_t), sendMessage $ ToggleGap U) -- toggle the top gap
-- > , ((modm .|. controlMask, xK_w), sendMessage $ IncGap 5 R) -- increment the right-hand gap
-- > , ((modm .|. controlMask, xK_q), sendMessage $ DecGap 5 R) -- decrement the right-hand gap
-- > , ((modm .|. controlMask, xK_r), sendMessage $ ModifyGaps rotateGaps) -- rotate gaps 90 degrees clockwise
-- > , ((modm .|. controlMask, xK_h), sendMessage $ weakModifyGaps halveHor) -- halve the left and right-hand gaps
-- > , ((modm .|. controlMask, xK_d), sendMessage $ modifyGap (*2) L) -- double the left-hand gap
-- > , ((modm .|. controlMask, xK_s), sendMessage $ setGaps [(U,18), (R,23)]) -- reset the GapSpec
-- > , ((modm .|. controlMask, xK_b), sendMessage $ setGap 30 D) -- set the bottom gap to 30
-- > ]
-- > where rotateGaps gs = zip (map (rotate . fst) gs) (map snd gs)
-- > rotate U = R
-- > rotate R = D
-- > rotate D = L
-- > rotate L = U
-- > halveHor d i | d `elem` [L, R] = i `div` 2
-- > | otherwise = i
--
-- If you want complete control over all gaps, you could include
-- something like this in your keybindings, assuming in this case you
@ -93,6 +108,7 @@ data GapMessage = ToggleGaps -- ^ Toggle all gaps.
| ToggleGap !Direction2D -- ^ Toggle a single gap.
| IncGap !Int !Direction2D -- ^ Increase a gap by a certain number of pixels.
| DecGap !Int !Direction2D -- ^ Decrease a gap.
| ModifyGaps (GapSpec -> GapSpec) -- ^ Modify arbitrarily.
deriving (Typeable)
instance Message GapMessage
@ -106,11 +122,46 @@ instance LayoutModifier Gaps a where
| Just (ToggleGap d) <- fromMessage m
= Just $ Gaps conf (toggleGap conf cur d)
| Just (IncGap i d) <- fromMessage m
= Just $ Gaps (incGap conf d i) cur
= Just $ Gaps (limit . continuation (+ i ) d $ conf) cur
| Just (DecGap i d) <- fromMessage m
= Just $ Gaps (incGap conf d (-i)) cur
= Just $ Gaps (limit . continuation (+(-i)) d $ conf) cur
| Just (ModifyGaps f) <- fromMessage m
= Just $ Gaps (limit . f $ conf) cur
| otherwise = Nothing
-- | Modifies gaps weakly, for convenience.
weakModifyGaps :: (Direction2D -> Int -> Int) -> GapMessage
weakModifyGaps = ModifyGaps . weakToStrong
-- | Arbitrarily modify a single gap with the given function.
modifyGap :: (Int -> Int) -> Direction2D -> GapMessage
modifyGap f d = ModifyGaps $ continuation f d
-- | Set the GapSpec.
setGaps :: GapSpec -> GapMessage
setGaps = ModifyGaps . const
-- | Set a gap to the given value.
setGap :: Int -> Direction2D -> GapMessage
setGap = modifyGap . const
-- | Imposes limits upon a GapSpec, ensuring gaps are at least 0. Not exposed.
limit :: GapSpec -> GapSpec
limit = weakToStrong $ \_ -> max 0
-- | Takes a weak gaps-modifying function f and returns a GapSpec modifying
-- function. Not exposed.
weakToStrong :: (Direction2D -> Int -> Int) -> GapSpec -> GapSpec
weakToStrong f gs = zip (map fst gs) (map (uncurry f) gs)
-- | Given f as a definition for the behaviour of a gaps modifying function in
-- one direction d, produces a continuation of the function to the other
-- directions using the identity. Not exposed.
continuation :: (Int -> Int) -> Direction2D -> GapSpec -> GapSpec
continuation f d1 = weakToStrong h
where h d2 | d2 == d1 = f
| otherwise = id
applyGaps :: Gaps a -> Rectangle -> Rectangle
applyGaps gs r = foldr applyGap r (activeGaps gs)
where
@ -131,9 +182,6 @@ toggleGap conf cur d | d `elem` cur = delete d cur
| d `elem` (map fst conf) = d:cur
| otherwise = cur
incGap :: GapSpec -> Direction2D -> Int -> GapSpec
incGap gs d i = map (\(dir,j) -> if dir == d then (dir,max (j+i) 0) else (dir,j)) gs
-- | Add togglable manual gaps to a layout.
gaps :: GapSpec -- ^ The gaps to allow, paired with their initial sizes.
-> l a -- ^ The layout to modify.

2
XMonad/Layout/Grid.hs
View File

@ -56,7 +56,7 @@ arrange :: Double -> Rectangle -> [a] -> [(a, Rectangle)]
arrange aspectRatio (Rectangle rx ry rw rh) st = zip st rectangles
where
nwins = length st
ncols = max 1 . round . sqrt $ fromIntegral nwins * fromIntegral rw / (fromIntegral rh * aspectRatio)
ncols = max 1 . min nwins . round . sqrt $ fromIntegral nwins * fromIntegral rw / (fromIntegral rh * aspectRatio)
mincs = max 1 $ nwins `div` ncols
extrs = nwins - ncols * mincs
chop :: Int -> Dimension -> [(Position, Dimension)]

92
XMonad/Layout/Groups.hs
View File

@ -1,6 +1,6 @@
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}
{-# LANGUAGE StandaloneDeriving, FlexibleContexts, DeriveDataTypeable
, UndecidableInstances, FlexibleInstances, MultiParamTypeClasses
, UndecidableInstances, FlexibleInstances, LambdaCase, MultiParamTypeClasses
, PatternGuards, Rank2Types, TypeSynonymInstances #-}
-----------------------------------------------------------------------------
@ -25,6 +25,7 @@ module XMonad.Layout.Groups ( -- * Usage
-- * Messages
, GroupsMessage(..)
, ModifySpec
, ModifySpecX
-- ** Useful 'ModifySpec's
, swapUp
, swapDown
@ -60,8 +61,8 @@ import XMonad.Util.Stack
import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes, fromJust)
import Data.List ((\\))
import Control.Arrow ((>>>))
import Control.Applicative ((<$>))
import Control.Monad (forM)
import Control.Applicative ((<$>),(<|>),(<$))
import Control.Monad (forM,void)
-- $usage
-- This module provides a layout combinator that allows you
@ -99,7 +100,6 @@ group :: l Window -> l2 (Group l Window) -> Groups l l2 Window
group l l2 = Groups l l2 startingGroups (U 1 0)
where startingGroups = fromJust $ singletonZ $ G (ID (U 0 0) l) emptyZ
-- * Stuff with unique keys
data Uniq = U Integer Integer
@ -187,6 +187,7 @@ data GroupsMessage = ToEnclosing SomeMessage -- ^ Send a message to the enclosin
-- to the layout.
| Modify ModifySpec -- ^ Modify the ordering\/grouping\/focusing
-- of windows according to a 'ModifySpec'
| ModifyX ModifySpecX -- ^ Same as 'Modify', but within the 'X' monad
deriving Typeable
instance Show GroupsMessage where
@ -206,6 +207,13 @@ modifyGroups f g = let (seed', id:_) = gen (seed g)
in g { groups = fromMaybe defaultGroups . f . Just $ groups g
, seed = seed' }
modifyGroupsX :: (Zipper (Group l a) -> X (Zipper (Group l a)))
-> Groups l l2 a -> X (Groups l l2 a)
modifyGroupsX f g = do
let (seed', id:_) = gen (seed g)
defaultGroups = fromJust $ singletonZ $ G (ID id $ baseLayout g) emptyZ
g' <- f . Just $ groups g
return g { groups = fromMaybe defaultGroups g', seed = seed' }
-- ** Readaptation
@ -303,9 +311,12 @@ instance (LayoutClass l Window, LayoutClass l2 (Group l Window))
Just (ToGroup i sm') -> do mg's <- handleOnIndex i sm' z
return $ maybeMakeNew l Nothing mg's
Just (Modify spec) -> case applySpec spec l of
Just l' -> refocus l' >> return (Just l')
Nothing -> return $ Just l
Just Refocus -> refocus l >> return (Just l)
Just l' -> refocus l'
Nothing -> return Nothing
Just (ModifyX spec) -> do ml' <- applySpecX spec l
whenJust ml' (void . refocus)
return (ml' <|> Just l)
Just Refocus -> refocus l
Just _ -> return Nothing
Nothing -> handleMessage l $ SomeMessage (ToFocused sm)
where handleOnFocused sm z = mapZM step $ Just z
@ -332,10 +343,10 @@ maybeMakeNew :: Groups l l2 a -> Maybe (l2 (Group l a)) -> [Maybe (WithID l a)]
maybeMakeNew _ Nothing ml's | all isNothing ml's = Nothing
maybeMakeNew g mpart' ml's = justMakeNew g mpart' ml's
refocus :: Groups l l2 Window -> X ()
refocus g = case getFocusZ $ gZipper $ W.focus $ groups g
of Just w -> focus w
Nothing -> return ()
refocus :: Groups l l2 Window -> X (Maybe (Groups l l2 Window))
refocus g =
let mw = (getFocusZ . gZipper . W.focus . groups) g
in g <$ mw <$ whenJust mw (modifyWindowSet . W.focusWindow)
-- ** ModifySpec type
@ -361,29 +372,50 @@ type ModifySpec = forall l. WithID l Window
-> Zipper (Group l Window)
-> Zipper (Group l Window)
-- ** ModifierSpecX type
-- | This is the same as 'ModifySpec', but it allows the function to use
-- actions inside the 'X' monad. This is useful, for example, if the function
-- has to make decisions based on the results of a 'runQuery'.
type ModifySpecX = forall l. WithID l Window
-> Zipper (Group l Window)
-> X (Zipper (Group l Window))
-- | Apply a ModifySpec.
applySpec :: ModifySpec -> Groups l l2 Window -> Maybe (Groups l l2 Window)
applySpec f g = let (seed', id:ids) = gen $ seed g
g' = flip modifyGroups g $ f (ID id $ baseLayout g)
>>> toTags
>>> foldr reID ((ids, []), [])
>>> snd
>>> fromTags
in case groups g == groups g' of
True -> Nothing
False -> Just g' { seed = seed' }
where reID eg ((id:ids, seen), egs)
= let myID = getID $ gLayout $ fromE eg
in case elem myID seen of
False -> ((id:ids, myID:seen), eg:egs)
True -> ((ids, seen), mapE_ (setID id) eg:egs)
where setID id (G (ID _ _) z) = G (ID id $ baseLayout g) z
reID _ (([], _), _) = undefined -- The list of ids is infinite
applySpec f g =
let (seed', id:ids) = gen $ seed g
g' = flip modifyGroups g $ f (ID id $ baseLayout g)
>>> toTags
>>> foldr (reID g) ((ids, []), [])
>>> snd
>>> fromTags
in case groups g == groups g' of
True -> Nothing
False -> Just g' { seed = seed' }
applySpecX :: ModifySpecX -> Groups l l2 Window -> X (Maybe (Groups l l2 Window))
applySpecX f g = do
let (seed', id:ids) = gen $ seed g
g' <- flip modifyGroupsX g $ f (ID id $ baseLayout g)
>>> fmap toTags
>>> fmap (foldr (reID g) ((ids, []), []))
>>> fmap snd
>>> fmap fromTags
return $ case groups g == groups g' of
True -> Nothing
False -> Just g' { seed = seed' }
reID :: Groups l l2 Window
-> Either (Group l Window) (Group l Window)
-> (([Uniq], [Uniq]), [Either (Group l Window) (Group l Window)])
-> (([Uniq], [Uniq]), [Either (Group l Window) (Group l Window)])
reID _ _ (([], _), _) = undefined -- The list of ids is infinite
reID g eg ((id:ids, seen), egs) = case elem myID seen of
False -> ((id:ids, myID:seen), eg:egs)
True -> ((ids, seen), mapE_ (setID id) eg:egs)
where myID = getID $ gLayout $ fromE eg
setID id (G (ID _ _) z) = G (ID id $ baseLayout g) z
-- ** Misc. ModifySpecs

4
XMonad/Layout/Groups/Helpers.hs
View File

@ -45,7 +45,7 @@ import qualified XMonad.StackSet as W
import qualified XMonad.Layout.Groups as G
import XMonad.Actions.MessageFeedback
import XMonad.Actions.MessageFeedback (sendMessageB)
import Control.Monad (unless)
import qualified Data.Map as M
@ -92,7 +92,7 @@ alt :: G.ModifySpec -> (WindowSet -> WindowSet) -> X ()
alt f g = alt2 (G.Modify f) $ windows g
alt2 :: G.GroupsMessage -> X () -> X ()
alt2 m x = do b <- send m
alt2 m x = do b <- sendMessageB m
unless b x
-- | Swap the focused window with the previous one

6
XMonad/Layout/LayoutHints.hs
View File

@ -44,6 +44,7 @@ import Data.Monoid(All(..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Maybe(fromJust)
-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
@ -147,10 +148,15 @@ instance LayoutModifier LayoutHintsToCenter Window where
modifyLayout _ ws@(W.Workspace _ _ (Just st)) r = do
(arrs,ol) <- runLayout ws r
flip (,) ol
. changeOrder (W.focus st : (filter (/= W.focus st) $ map fst arrs))
. head . reverse . sortBy (compare `on` (fitting . map snd))
. map (applyHints st r) . applyOrder r
<$> mapM (\x -> fmap ((,) x) $ mkAdjust (fst x)) arrs
changeOrder :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]
changeOrder w wr = zip w' $ map (fromJust . flip lookup wr) w'
where w' = filter (`elem` map fst wr) w
-- apply hints to first, grow adjacent windows
applyHints :: W.Stack Window -> Rectangle -> [((Window, Rectangle),(D -> D))] -> [(Window, Rectangle)]
applyHints _ _ [] = []

6
XMonad/Layout/Mosaic.hs
View File

@ -38,7 +38,8 @@ import Control.Monad(mplus)
import Data.Foldable(Foldable,foldMap, sum)
import Data.Function(on)
import Data.List(sortBy)
import Data.Monoid(Monoid,mempty, mappend)
import Data.Monoid(Monoid,mempty, mappend, (<>))
import Data.Semigroup
-- $usage
@ -202,6 +203,9 @@ instance Monoid (Tree a) where
mappend x Empty = x
mappend x y = Branch x y
instance Semigroup (Tree a) where
(<>) = mappend
makeTree :: (Num a1, Ord a1) => (a -> a1) -> [a] -> Tree a
makeTree _ [] = Empty
makeTree _ [x] = Leaf x

10
XMonad/Layout/MultiColumns.hs
View File

@ -77,10 +77,9 @@ data MultiCol a = MultiCol
} deriving (Show,Read,Eq)
instance LayoutClass MultiCol a where
doLayout l r s = return (zip w rlist, resl)
doLayout l r s = return (combine s rlist, resl)
where rlist = doL (multiColNWin l') (multiColSize l') r wlen
w = W.integrate s
wlen = length w
wlen = length $ W.integrate s
-- Make sure the list of columns is big enough and update active column
nw = multiColNWin l ++ repeat (multiColDefWin l)
l' = l { multiColNWin = take (max (length $ multiColNWin l) $ getCol (wlen-1) nw + 1) nw
@ -90,6 +89,7 @@ instance LayoutClass MultiCol a where
resl = if l'==l
then Nothing
else Just l'
combine (W.Stack foc left right) rs = zip (foc : reverse left ++ right) $ raiseFocused (length left) rs
handleMessage l m =
return $ msum [fmap resize (fromMessage m)
,fmap incmastern (fromMessage m)]
@ -104,6 +104,10 @@ instance LayoutClass MultiCol a where
a = multiColActive l
description _ = "MultiCol"
raiseFocused :: Int -> [a] -> [a]
raiseFocused n xs = actual ++ before ++ after
where (before,rest) = splitAt n xs
(actual,after) = splitAt 1 rest
-- | Get which column a window is in, starting at 0.
getCol :: Int -> [Int] -> Int

92
XMonad/Layout/MultiDishes.hs Normal file
View File

@ -0,0 +1,92 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.MultiDishes
-- Copyright : (c) Jeremy Apthorp, Nathan Fairhurst
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Nathan Fairhurst <nathan.p3pictures@gmail.com>
-- Stability : unstable
-- Portability : portable
--
-- MultiDishes is a layout that stacks groups of extra windows underneath
-- the master windows.
--
-----------------------------------------------------------------------------
module XMonad.Layout.MultiDishes (
-- * Usage
-- $usage
MultiDishes (..)
) where
import XMonad
import XMonad.StackSet (integrate)
import Control.Monad (ap)
-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Layout.MultiDishes
--
-- Then edit your @layoutHook@ by adding the MultiDishes layout:
--
-- > myLayout = MultiDishes 2 3 (1/6) ||| Full ||| etc..
-- > main = xmonad def { layoutHook = myLayout }
--
-- This is based on the Layout Dishes, but accepts another parameter for
-- the maximum number of dishes allowed within a stack.
--
-- > MultiDishes x 1 y
-- is equivalent to
-- > Dishes x y
--
-- The stack with the fewest dishes is always on top, so 4 windows
-- with the layout `MultiDishes 1 2 (1/5)` would look like this:
--
-- > _________
-- > | |
-- > | M |
-- > |_______|
-- > |_______|
-- > |___|___|
--
-- For more detailed instructions on editing the layoutHook see:
--
-- "XMonad.Doc.Extending#Editing_the_layout_hook"
data MultiDishes a = MultiDishes Int Int Rational deriving (Show, Read)
instance LayoutClass MultiDishes a where
pureLayout (MultiDishes nmaster dishesPerStack h) r =
ap zip (multiDishes h r nmaster dishesPerStack . length) . integrate
pureMessage (MultiDishes nmaster dishesPerStack h) m = fmap incmastern (fromMessage m)
where incmastern (IncMasterN d) = MultiDishes (max 0 (nmaster+d)) dishesPerStack h
multiDishes :: Rational -> Rectangle -> Int -> Int -> Int -> [Rectangle]
multiDishes h s nmaster dishesPerStack n = if n <= nmaster
then splitHorizontally n s
else ws
where
(filledDishStackCount, remainder) =
(n - nmaster) `quotRem` (max 1 dishesPerStack)
(firstDepth, dishStackCount) =
if remainder == 0 then
(dishesPerStack, filledDishStackCount)
else
(remainder, filledDishStackCount + 1)
(masterRect, dishesRect) =
splitVerticallyBy (1 - (fromIntegral dishStackCount) * h) s
dishStackRects =
splitVertically dishStackCount dishesRect
allDishRects = case dishStackRects of
(firstStack:bottomDishStacks) ->
splitHorizontally firstDepth firstStack ++ (bottomDishStacks >>= splitHorizontally dishesPerStack)
[] -> []
ws =
splitHorizontally nmaster masterRect ++ allDishRects

3
XMonad/Layout/MultiToggle.hs
View File

@ -90,7 +90,8 @@ import Data.Maybe
-- > instance Transformer MIRROR Window where
-- > transform _ x k = k (Mirror x) (\(Mirror x') -> x')
--
-- Note, you need to put @{-\# LANGUAGE DeriveDataTypeable \#-}@ at the
-- Note, you need to put @{-\# LANGUAGE DeriveDataTypeable,
-- TypeSynonymInstances, MultiParamTypeClasses \#-}@ at the
-- beginning of your file.
-- | A class to identify custom transformers (and look up transforming

47
XMonad/Layout/MultiToggle/TabBarDecoration.hs Normal file
View File

@ -0,0 +1,47 @@
{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.MultiToggle.TabBarDecoration
-- Copyright : (c) 2018 Lucian Poston
-- License : BSD-style (see LICENSE)
--
-- Maintainer : <lucianposton@pm.me>
-- Stability : unstable
-- Portability : unportable
--
-- Provides a simple transformer for use with "XMonad.Layout.MultiToggle" to
-- dynamically toggle "XMonad.Layout.TabBarDecoration".
-----------------------------------------------------------------------------
module XMonad.Layout.MultiToggle.TabBarDecoration (
SimpleTabBar(..)
) where
import XMonad.Layout.MultiToggle
import XMonad
import XMonad.Layout.LayoutModifier
import XMonad.Layout.TabBarDecoration
-- $usage
-- To use this module with "XMonad.Layout.MultiToggle", add the @SIMPLETABBAR@
-- to your layout For example, from a basic layout like
--
-- > layout = tiled ||| Full
--
-- Add @SIMPLETABBAR@ by changing it this to
--
-- > layout = mkToggle (single SIMPLETABBAR) (tiled ||| Full)
--
-- You can now dynamically toggle the 'XMonad.Layout.TabBarDecoration'
-- transformation by adding a key binding such as @mod-x@ as follows.
--
-- > ...
-- > , ((modm, xK_x ), sendMessage $ Toggle SIMPLETABBAR)
-- > ...
-- | Transformer for "XMonad.Layout.TabBarDecoration".
data SimpleTabBar = SIMPLETABBAR deriving (Read, Show, Eq, Typeable)
instance Transformer SimpleTabBar Window where
transform _ x k = k (simpleTabBar x) (\(ModifiedLayout _ (ModifiedLayout _ x')) -> x')

264
XMonad/Layout/NoBorders.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances, PatternGuards, DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.NoBorders
-- Copyright : (c) David Roundy <droundy@darcs.net>
-- Copyright : (c) -- David Roundy <droundy@darcs.net>
-- 2018 Yclept Nemo
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com>
@ -18,25 +19,32 @@
--
-----------------------------------------------------------------------------
module XMonad.Layout.NoBorders (
-- * Usage
-- $usage
noBorders,
smartBorders,
withBorder,
lessBorders,
SetsAmbiguous(..),
Ambiguity(..),
With(..),
SmartBorder, WithBorder, ConfigurableBorder,
module XMonad.Layout.NoBorders ( -- * Usage
-- $usage
noBorders
, smartBorders
, withBorder
, lessBorders
, hasBorder
, SetsAmbiguous(..)
, Ambiguity(..)
, With(..)
, BorderMessage (..), borderEventHook
, SmartBorder, WithBorder, ConfigurableBorder
) where
import XMonad
import XMonad.Layout.LayoutModifier
import qualified XMonad.StackSet as W
import Data.List
import qualified Data.Map as M
import Data.Function (on)
import XMonad
import XMonad.Layout.LayoutModifier
import qualified XMonad.StackSet as W
import qualified XMonad.Util.Rectangle as R
import Data.List
import Data.Monoid
import qualified Data.Map as M
import Data.Function (on)
import Control.Applicative ((<$>),(<*>),pure)
import Control.Monad (guard)
-- $usage
-- You can use this module with the following in your ~\/.xmonad\/xmonad.hs file:
@ -100,34 +108,94 @@ smartBorders = lessBorders Never
-- instances
lessBorders :: (SetsAmbiguous p, Read p, Show p, LayoutClass l a) =>
p -> l a -> ModifiedLayout (ConfigurableBorder p) l a
lessBorders amb = ModifiedLayout (ConfigurableBorder amb [])
lessBorders amb = ModifiedLayout (ConfigurableBorder amb [] [] [])
data ConfigurableBorder p w = ConfigurableBorder p [w] deriving (Read, Show)
-- | 'ManageHook' for sending 'HasBorder' messages:
--
-- > title =? "foo" --> hasBorder True
--
-- There is no equivalent for 'ResetBorder'.
hasBorder :: Bool -> ManageHook
hasBorder b = ask >>= \w -> liftX (broadcastMessage $ HasBorder b w) >> idHook
data BorderMessage
= HasBorder Bool Window
-- ^ If @True@, never remove the border from the specified window. If
-- @False@, always remove the border from the specified window.
| ResetBorder Window
-- ^ Reset the effects of any 'HasBorder' messages on the specified
-- window.
deriving (Typeable)
instance Message BorderMessage
data ConfigurableBorder p w = ConfigurableBorder
{ _generateHidden :: p
-- ^ Generates a list of windows without borders. Uses 'SetsAmbiguous'
-- to filter the current layout.
, alwaysHidden :: [w]
-- ^ Windows that never have borders. This list is added to the result
-- of 'generateHidden'.
, neverHidden :: [w]
-- ^ Windows that always have borders - i.e. ignored by this module.
-- This list is subtraced from 'alwaysHidden' and so has higher
-- precendence.
, currentHidden :: [w]
-- ^ The current set of windows without borders, i.e. the state.
} deriving (Read, Show)
-- | Only necessary with 'BorderMessage' - remove non-existent windows from the
-- 'alwaysHidden' or 'neverHidden' lists.
borderEventHook :: Event -> X All
borderEventHook (DestroyWindowEvent { ev_window = w }) = do
broadcastMessage $ ResetBorder w
return $ All True
borderEventHook _ = return $ All True
instance (Read p, Show p, SetsAmbiguous p) => LayoutModifier (ConfigurableBorder p) Window where
unhook (ConfigurableBorder _p s) = asks (borderWidth . config) >>= setBorders s
unhook (ConfigurableBorder _ _ _ ch) = asks (borderWidth . config) >>= setBorders ch
redoLayout (ConfigurableBorder p s) _ mst wrs = do
ws <- withWindowSet (\wset -> return (hiddens p wset mst wrs))
asks (borderWidth . config) >>= setBorders (s \\ ws)
setBorders ws 0
return (wrs, Just $ ConfigurableBorder p ws)
redoLayout cb@(ConfigurableBorder gh ah nh ch) lr mst wrs = do
let gh' wset = let lh = (hiddens gh wset lr mst wrs)
in return $ (ah `union` lh) \\ nh
ch' <- withWindowSet gh'
asks (borderWidth . config) >>= setBorders (ch \\ ch')
setBorders ch' 0
return (wrs, Just $ cb { currentHidden = ch' })
pureMess cb@(ConfigurableBorder gh ah nh ch) m
| Just (HasBorder b w) <- fromMessage m =
let consNewIf l True = if w `elem` l then Nothing else Just (w:l)
consNewIf l False = Just l
in (ConfigurableBorder gh) <$> consNewIf ah (not b)
<*> consNewIf nh b
<*> pure ch
| Just (ResetBorder w) <- fromMessage m =
let delete' e l = if e `elem` l then (True,delete e l) else (False,l)
(da,ah') = delete' w ah
(dn,nh') = delete' w nh
in if da || dn
then Just cb { alwaysHidden = ah', neverHidden = nh' }
else Nothing
| otherwise = Nothing
-- | SetsAmbiguous allows custom actions to generate lists of windows that
-- should not have borders drawn through 'ConfigurableBorder'
--
-- To add your own (though perhaps those options would better belong as an
-- aditional constructor to 'Ambiguity'), you can add the function as such:
-- additional constructor to 'Ambiguity'), you can add the following function.
-- Note that @lr@, the parameter representing the 'Rectangle' of the parent
-- layout, was added to 'hiddens' in 0.14. Update your instance accordingly.
--
-- > data MyAmbiguity = MyAmbiguity deriving (Read, Show)
--
-- > instance SetsAmbiguous MyAmbiguity where
-- > hiddens _ wset mst wrs = otherHiddens Screen \\ otherHiddens OnlyFloat
-- > where otherHiddens p = hiddens p wset mst wrs
-- > hiddens _ wset lr mst wrs = otherHiddens Screen \\ otherHiddens OnlyScreenFloat
-- > where otherHiddens p = hiddens p wset lr mst wrs
--
-- The above example is redundant, because you can have the same result with:
--
-- > layoutHook = lessBorders (Combine Difference Screen OnlyFloat) (Tall 1 0.5 0.03 ||| ... )
-- > layoutHook = lessBorders (Combine Difference Screen OnlyScreenFloat) (Tall 1 0.5 0.03 ||| ... )
--
-- To get the same result as 'smartBorders':
--
@ -136,32 +204,87 @@ instance (Read p, Show p, SetsAmbiguous p) => LayoutModifier (ConfigurableBorder
-- This indirect method is required to keep the 'Read' and 'Show' for
-- ConfigurableBorder so that xmonad can serialize state.
class SetsAmbiguous p where
hiddens :: p -> WindowSet -> Maybe (W.Stack Window) -> [(Window, Rectangle)] -> [Window]
hiddens :: p -> WindowSet -> Rectangle -> Maybe (W.Stack Window) -> [(Window, Rectangle)] -> [Window]
-- Quick overview since the documentation lacks clarity:
-- * Overall stacking order =
-- tiled stacking order ++ floating stacking order
-- Where tiled windows are (obviously) stacked below floating windows.
-- * Tiled stacking order =
-- [(window, Rectangle] order
-- Given by 'XMonad.Core.LayoutClass' where earlier entries are stacked
-- higher.
-- * Floating stacking order =
-- focus order
-- Given by the workspace stack where a higher focus corresponds to a higher
-- stacking position.
--
-- Integrating a stack returns a list in order of [highest...lowest].
--
-- 'XMonad.Core.LayoutClass' is given a stack with all floating windows removed
-- and returns a list (in stack order) of only the visible tiled windows, while
-- the workspace stack contains all windows (visible/hidden, floating/tiled) in
-- focus order. The StackSet 'floating' field maps all floating windows across
-- all workspaces to relative rectangles - without the associated screen.
--
-- 'XMonad.Operations.windows' gets the windowset from the state, mutates it,
-- then updates the state before calling 'runLayout' with the new windowset -
-- excluding any floating windows. Aside from the filtering, the stack received
-- by the layout should be identical to the one received from 'withWindowSet'.
instance SetsAmbiguous Ambiguity where
hiddens amb wset mst wrs
hiddens amb wset lr mst wrs
| Combine Union a b <- amb = on union next a b
| Combine Difference a b <- amb = on (\\) next a b
| Combine Intersection a b <- amb = on intersect next a b
| otherwise = tiled ms ++ floating
where next p = hiddens p wset mst wrs
nonzerorect (Rectangle _ _ 0 0) = False
nonzerorect _ = True
where next p = hiddens p wset lr mst wrs
screens = [ scr | scr <- W.screens wset
, case amb of
Never -> True
_ -> not $ null $ integrate scr
, not . R.empty . screenRect
$ W.screenDetail scr
]
-- This originally considered all floating windows across all
-- workspaces. It seems more efficient to have each layout manage
-- its own floating windows - and equally valid though untested
-- against a multihead setup. In some cases the previous code would
-- redundantly add then remove borders from already-borderless
-- windows.
floating = do
let wz :: Integer -> (Window,Rectangle)
-> (Integer,Window,Rectangle)
wz i (w,wr) = (i,w,wr)
-- For the following: in stacking order lowest -> highest.
ts = reverse . zipWith wz [-1,-2..] $ wrs
fs = zipWith wz [0..] $ do
w <- reverse . W.index $ wset
Just wr <- [M.lookup w (W.floating wset)]
return (w,scaleRationalRect sr wr)
sr = screenRect . W.screenDetail . W.current $ wset
(i1,w1,wr1) <- fs
guard $ case amb of
OnlyLayoutFloatBelow ->
let vu = do
gr <- sr `R.difference` lr
(i2,_w2,wr2) <- ts ++ fs
guard $ i2 < i1
[wr2 `R.intersects` gr]
in lr == wr1 && (not . or) vu
OnlyLayoutFloat ->
lr == wr1
_ ->
wr1 `R.supersetOf` sr
return w1
screens =
[ scr | scr <- W.screens wset,
case amb of
Never -> True
_ -> not $ null $ integrate scr,
nonzerorect . screenRect $ W.screenDetail scr]
floating = [ w |
(w, W.RationalRect px py wx wy) <- M.toList . W.floating $ wset,
px <= 0, py <= 0,
wx + px >= 1, wy + py >= 1]
ms = filter (`elem` W.integrate' mst) $ map fst wrs
tiled [w]
| Screen <- amb = [w]
| OnlyFloat <- amb = []
| OnlyScreenFloat <- amb = []
| OnlyLayoutFloat <- amb = []
| OnlyLayoutFloatBelow <- amb = []
| OtherIndicated <- amb
, let nonF = map integrate $ W.current wset : W.visible wset
, length (concat nonF) > length wrs
@ -174,23 +297,34 @@ instance SetsAmbiguous Ambiguity where
-- subsequent constructors add additional cases where borders are not drawn
-- than their predecessors. These behaviors make most sense with with multiple
-- screens: for single screens, 'Never' or 'smartBorders' makes more sense.
data Ambiguity = Combine With Ambiguity Ambiguity
-- ^ This constructor is used to combine the
-- borderless windows provided by the
-- SetsAmbiguous instances from two other
-- 'Ambiguity' data types.
| OnlyFloat -- ^ Only remove borders on floating windows that
-- cover the whole screen
| Never -- ^ Never remove borders when ambiguous:
-- this is the same as smartBorders
| EmptyScreen -- ^ Focus in an empty screens does not count as
-- ambiguous.
| OtherIndicated
-- ^ No borders on full when all other screens
-- have borders.
| Screen -- ^ Borders are never drawn on singleton screens.
-- With this one you really need another way such
-- as a statusbar to detect focus.
data Ambiguity
= Combine With Ambiguity Ambiguity
-- ^ This constructor is used to combine the borderless windows
-- provided by the SetsAmbiguous instances from two other 'Ambiguity'
-- data types.
| OnlyScreenFloat
-- ^ Only remove borders on floating windows that cover the whole
-- screen.
| OnlyLayoutFloatBelow
-- ^ Like 'OnlyLayoutFloat', but only removes borders if no window
-- stacked below remains visible. Considers all floating windows on the
-- current screen and all visible tiled windows of the child layout. If
-- any such window (that is stacked below) shows in any gap between the
-- parent layout rectangle and the physical screen, the border will
-- remain drawn.
| OnlyLayoutFloat
-- ^ Only remove borders on floating windows that exactly cover the
-- parent layout rectangle.
| Never
-- ^ Never remove borders when ambiguous: this is the same as
-- smartBorders.
| EmptyScreen
-- ^ Focus in an empty screen does not count as ambiguous.
| OtherIndicated
-- ^ No borders on full when all other screens have borders.
| Screen
-- ^ Borders are never drawn on singleton screens. With this one you
-- really need another way such as a statusbar to detect focus.
deriving (Read, Show)
-- | Used to indicate to the 'SetsAmbiguous' instance for 'Ambiguity' how two

453
XMonad/Layout/Spacing.hs
View File

@ -1,137 +1,388 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.Spacing
-- Copyright : (c) Brent Yorgey
-- Copyright : (C) -- Brent Yorgey
-- 2018 Yclept Nemo
-- License : BSD-style (see LICENSE)
--
-- Maintainer : <byorgey@gmail.com>
-- Stability : unstable
-- Portability : portable
-- Portability : unportable
--
-- Add a configurable amount of space around windows.
--
-- Note: For space\/gaps along edges of the /screen/ see "XMonad.Layout.Gaps".
-----------------------------------------------------------------------------
module XMonad.Layout.Spacing (
-- * Usage
-- $usage
module XMonad.Layout.Spacing
( -- * Usage
-- $usage
Border (..)
, Spacing (..)
, SpacingModifier (..)
, spacingRaw
, setSmartSpacing
, setScreenSpacing, setScreenSpacingEnabled
, setWindowSpacing, setWindowSpacingEnabled
, toggleSmartSpacing
, toggleScreenSpacingEnabled
, toggleWindowSpacingEnabled
, setScreenWindowSpacing
, incWindowSpacing, incScreenSpacing
, decWindowSpacing, decScreenSpacing
, incScreenWindowSpacing, decScreenWindowSpacing
, borderMap, borderIncrementBy
-- * Backwards Compatibility
-- $backwardsCompatibility
, SpacingWithEdge
, SmartSpacing, SmartSpacingWithEdge
, ModifySpacing (..)
, spacing, spacingWithEdge
, smartSpacing, smartSpacingWithEdge
, setSpacing, incSpacing
) where
spacing, Spacing,
spacingWithEdge, SpacingWithEdge,
smartSpacing, SmartSpacing,
smartSpacingWithEdge, SmartSpacingWithEdge,
ModifySpacing(..), setSpacing, incSpacing
) where
import XMonad
import XMonad.StackSet as W
import qualified XMonad.Util.Rectangle as R
import XMonad.Layout.LayoutModifier
import XMonad.Actions.MessageFeedback
import Graphics.X11 (Rectangle(..))
import Control.Arrow (second)
import XMonad.Operations (sendMessage)
import XMonad.Core (X,runLayout,Message,fromMessage,Typeable)
import XMonad.StackSet (up, down, Workspace(..))
import XMonad.Util.Font (fi)
import XMonad.Layout.LayoutModifier
-- $usage
-- You can use this module by importing it into your @~\/.xmonad\/xmonad.hs@ file:
-- You can use this module by importing it into your @~\/.xmonad\/xmonad.hs@
-- file:
--
-- > import XMonad.Layout.Spacing
--
-- and modifying your layoutHook as follows (for example):
--
-- > layoutHook = spacing 2 $ Tall 1 (3/100) (1/2)
-- > -- put a 2px space around every window
--
-- > layoutHook = spacingRaw True (Border 0 10 10 10) True (Border 10 10 10 10) True $
-- > layoutHook def
-- | Surround all windows by a certain number of pixels of blank space.
spacing :: Int -> l a -> ModifiedLayout Spacing l a
spacing p = ModifiedLayout (Spacing p)
-- | Represent the borders of a rectangle.
data Border = Border
{ top :: Integer
, bottom :: Integer
, right :: Integer
, left :: Integer
} deriving (Show,Read)
data Spacing a = Spacing Int deriving (Show, Read)
-- | A 'LayoutModifier' providing customizable screen and window borders.
-- Borders are clamped to @[0,Infinity]@ before being applied.
data Spacing a = Spacing
{ smartBorder :: Bool
-- ^ When @True@ borders are not applied if
-- there fewer than two windows.
, screenBorder :: Border
-- ^ The screen border.
, screenBorderEnabled :: Bool
-- ^ Is the screen border enabled?
, windowBorder :: Border
-- ^ The window borders.
, windowBorderEnabled :: Bool
-- ^ Is the window border enabled?
} deriving (Show,Read)
-- | Message to dynamically modify (e.g. increase/decrease/set) the size of the window spacing
instance Eq a => LayoutModifier Spacing a where
-- This is a bit of a chicken-and-egg problem - the visible window list has
-- yet to be generated. Several workarounds to incorporate the screen
-- border:
-- 1. Call 'runLayout' twice, with/without the screen border. Since layouts
-- run arbitrary X actions, this breaks an important underlying
-- assumption. Also, doesn't really solve the chicken-egg problem.
-- 2. Create the screen border after and if the child layout returns more
-- than one window. Unfortunately this breaks the window ratios
-- presented by the child layout, another important assumption.
-- 3. Create the screen border before, and remove it after and if the child
-- layout returns fewer than two visible windows. This is somewhat hacky
-- but probably the best option. Could significantly modify the child
-- layout if it would have returned more than one window given the space
-- of the screen border, but this is the underlying chicken-egg problem,
-- and some concession must be made:
-- * no border -> multiple windows
-- * border -> single window
-- Also slightly breaks layouts that expect to present absolutely-sized
-- windows; a single window will be scaled up by the border size.
-- Overall these are trivial assumptions.
--
-- Note #1: the original code counted the windows of the 'Workspace' stack,
-- and so generated incorrect results even for the builtin 'Full' layout.
-- Even though most likely true, it isn't guaranteed that a layout will
-- never return windows not in the stack, specifically that an empty stack
-- will lead to 0 visible windows and a stack with a single window will
-- lead to 0-1 visible windows (see 'XMonad.Layout.Decoration'). So as much
-- as I would like to pass a rectangle without screen borders to the child
-- layout when appropriate (per the original approach), I can't. Since the
-- screen border is always present whether displayed or not, child layouts
-- can't depend on an accurate layout rectangle.
--
-- Note #2: If there are fewer than two stack windows displayed, the stack
-- window (if present) is scaled up while the non-stack windows are moved a
-- border-dependent amount based on their quadrant. So a non-stack window
-- in the top-left quadrant will be moved using only the border's top and
-- left components. Originally I was going to use an edge-attachment
-- algorithm, but this is much simpler and covers most cases. Edge
-- attachment would have scaled non-stack windows, but most non-stack
-- windows are created by XMonad and therefore cannot be scaled. I suggest
-- this layout be disabled for any incompatible child layouts.
modifyLayout (Spacing _b _sb False _wb _wbe) wsp lr =
runLayout wsp lr
modifyLayout (Spacing b sb _sbe _wb _wbe) wsp lr = do
let sb1 = borderClampGTZero sb
lr' = withBorder' sb1 2 lr
sb2 = toBorder lr' lr
(wrs,ml) <- runLayout wsp lr'
let ff (w,wr) (i,ps) = if w `elem` (W.integrate' . W.stack $ wsp)
then let wr' = withBorder' sb2 2 wr
in (i+1,(w,wr'):ps)
else let wr' = moveByQuadrant lr wr sb2
in (i,(w,wr'):ps)
(c,wrs') = foldr ff (0::Integer,[]) wrs
return $ if c <= 1 && b
then (wrs',ml)
else (wrs,ml)
where
moveByQuadrant :: Rectangle -> Rectangle -> Border -> Rectangle
moveByQuadrant rr mr@(Rectangle {rect_x = x, rect_y = y}) (Border bt bb br bl) =
let (rcx,rcy) = R.center rr
(mcx,mcy) = R.center mr
dx = orderSelect (compare mcx rcx) (bl,0,negate br)
dy = orderSelect (compare mcy rcy) (bt,0,negate bb)
in mr { rect_x = x + fromIntegral dx, rect_y = y + fromIntegral dy }
-- This is run after 'modifyLayout' but receives the original stack, not
-- one possibly modified by the child layout. Does not remove borders from
-- windows not in the stack, i.e. decorations generated by
-- 'XMonad.Layout.Decorations'.
pureModifier (Spacing _b _sb _sbe _wb False) _lr _mst wrs =
(wrs, Nothing)
pureModifier (Spacing b _sb _sbe wb _wbe) _lr mst wrs =
let wb' = borderClampGTZero wb
ff p@(w,wr) (i,ps) = if w `elem` W.integrate' mst
then let wr' = withBorder' wb' 2 wr
in (i+1,(w,wr'):ps)
else (i,p:ps)
(c,wrs') = foldr ff (0::Integer,[]) wrs
in if c <= 1 && b
then (wrs, Nothing)
else (wrs', Nothing)
pureMess s@(Spacing b sb sbe wb wbe) m
| Just (ModifySmartBorder f) <- fromMessage m
= Just $ s { smartBorder = f b }
| Just (ModifyScreenBorder f) <- fromMessage m
= Just $ s { screenBorder = f sb }
| Just (ModifyScreenBorderEnabled f) <- fromMessage m
= Just $ s { screenBorderEnabled = f sbe }
| Just (ModifyWindowBorder f) <- fromMessage m
= Just $ s { windowBorder = f wb }
| Just (ModifyWindowBorderEnabled f) <- fromMessage m
= Just $ s { windowBorderEnabled = f wbe }
| Just (ModifySpacing f) <- fromMessage m
= Just $ let f' = borderMap (fromIntegral . f . fromIntegral)
in s { screenBorder = f' sb, windowBorder = f' wb }
| otherwise
= Nothing
modifierDescription Spacing {} =
"Spacing"
-- | Generate the 'ModifiedLayout', exposing all initial state of 'Spacing'.
spacingRaw :: Bool -- ^ The 'smartBorder'.
-> Border -- ^ The 'screenBorder'.
-> Bool -- ^ The 'screenBorderEnabled'.
-> Border -- ^ The 'windowBorder'.
-> Bool -- ^ The 'windowBorderEnabled'.
-> l a -> ModifiedLayout Spacing l a
spacingRaw b sb sbe wb wbe = ModifiedLayout (Spacing b sb sbe wb wbe)
-- | Messages to alter the state of 'Spacing' using the endomorphic function
-- arguments.
data SpacingModifier
= ModifySmartBorder (Bool -> Bool)
| ModifyScreenBorder (Border -> Border)
| ModifyScreenBorderEnabled (Bool -> Bool)
| ModifyWindowBorder (Border -> Border)
| ModifyWindowBorderEnabled (Bool -> Bool)
deriving (Typeable)
instance Message SpacingModifier
-- | Set 'smartBorder' to the given 'Bool'.
setSmartSpacing :: Bool -> X ()
setSmartSpacing = sendMessage . ModifySmartBorder . const
-- | Set 'screenBorder' to the given 'Border'.
setScreenSpacing :: Border -> X ()
setScreenSpacing = sendMessage . ModifyScreenBorder . const
-- | Set 'screenBorderEnabled' to the given 'Bool'.
setScreenSpacingEnabled :: Bool -> X ()
setScreenSpacingEnabled = sendMessage . ModifyScreenBorderEnabled . const
-- | Set 'windowBorder' to the given 'Border'.
setWindowSpacing :: Border -> X ()
setWindowSpacing = sendMessage . ModifyWindowBorder . const
-- | Set 'windowBorderEnabled' to the given 'Bool'.
setWindowSpacingEnabled :: Bool -> X ()
setWindowSpacingEnabled = sendMessage . ModifyWindowBorderEnabled . const
-- | Toggle 'smartBorder'.
toggleSmartSpacing :: X ()
toggleSmartSpacing = sendMessage $ ModifySmartBorder not
-- | Toggle 'screenBorderEnabled'.
toggleScreenSpacingEnabled :: X ()
toggleScreenSpacingEnabled = sendMessage $ ModifyScreenBorderEnabled not
-- | Toggle 'windowBorderEnabled'.
toggleWindowSpacingEnabled :: X ()
toggleWindowSpacingEnabled = sendMessage $ ModifyWindowBorderEnabled not
-- | Set all borders to a uniform size; see 'setWindowSpacing' and
-- 'setScreenSpacing'.
setScreenWindowSpacing :: Integer -> X ()
setScreenWindowSpacing = sendMessages . flip map [ModifyWindowBorder,ModifyScreenBorder]
. flip id . const . uniformBorder
-- | Increment the borders of 'windowBorder' using 'borderIncrementBy', which
-- preserves border ratios during clamping.
incWindowSpacing :: Integer -> X ()
incWindowSpacing = sendMessage . ModifyWindowBorder . borderIncrementBy
-- | Increment the borders of 'screenBorder' using 'borderIncrementBy'.
incScreenSpacing :: Integer -> X ()
incScreenSpacing = sendMessage . ModifyScreenBorder . borderIncrementBy
-- | Inverse of 'incWindowSpacing', equivalent to applying 'negate'.
decWindowSpacing :: Integer -> X ()
decWindowSpacing = incWindowSpacing . negate
-- | Inverse of 'incScreenSpacing'.
decScreenSpacing :: Integer -> X ()
decScreenSpacing = incScreenSpacing . negate
-- | Increment both screen and window borders; see 'incWindowSpacing' and
-- 'incScreenSpacing'.
incScreenWindowSpacing :: Integer -> X ()
incScreenWindowSpacing = sendMessages . flip map [ModifyWindowBorder,ModifyScreenBorder]
. flip id . borderIncrementBy
-- | Inverse of 'incScreenWindowSpacing'.
decScreenWindowSpacing :: Integer -> X ()
decScreenWindowSpacing = incScreenWindowSpacing . negate
-- | Construct a uniform 'Border'. That is, having equal individual borders.
uniformBorder :: Integer -> Border
uniformBorder i = Border i i i i
-- | Map a function over a 'Border'. That is, over the four individual borders.
borderMap :: (Integer -> Integer) -> Border -> Border
borderMap f (Border t b r l) = Border (f t) (f b) (f r) (f l)
-- | Clamp borders to within @[0,Infinity]@.
borderClampGTZero :: Border -> Border
borderClampGTZero = borderMap (max 0)
-- | Change the border spacing by the provided amount, adjusted so that at
-- least one border field is @>=0@.
borderIncrementBy :: Integer -> Border -> Border
borderIncrementBy i (Border t b r l) =
let bl = [t,b,r,l]
o = maximum bl
o' = max i $ negate o
[t',b',r',l'] = map (+o') bl
in Border t' b' r' l'
-- | Interface to 'XMonad.Util.Rectangle.withBorder'.
withBorder' :: Border -> Integer -> Rectangle -> Rectangle
withBorder' (Border t b r l) = R.withBorder t b r l
-- | Return the border necessary to derive the second rectangle from the first.
-- Since 'R.withBorder' may scale the borders to stay within rectangle bounds,
-- it is not an invertible operation, i.e. applying a negated border may not
-- return the original rectangle. Use this instead.
toBorder :: Rectangle -> Rectangle -> Border
toBorder r1 r2 =
let R.PointRectangle r1_x1 r1_y1 r1_x2 r1_y2 = R.pixelsToCoordinates r1
R.PointRectangle r2_x1 r2_y1 r2_x2 r2_y2 = R.pixelsToCoordinates r2
l = r2_x1 - r1_x1
r = r1_x2 - r2_x2
t = r2_y1 - r1_y1
b = r1_y2 - r2_y2
in Border t b r l
-- | Given an ordering and a three-tuple, return the first tuple entry if 'LT',
-- second if 'EQ' and third if 'GT'.
orderSelect :: Ordering -> (a,a,a) -> a
orderSelect o (lt,eq,gt) = case o of
LT -> lt
EQ -> eq
GT -> gt
-----------------------------------------------------------------------------
-- Backwards Compatibility:
-----------------------------------------------------------------------------
{-# DEPRECATED SpacingWithEdge, SmartSpacing, SmartSpacingWithEdge "Use Spacing instead." #-}
{-# DEPRECATED ModifySpacing "Use SpacingModifier instead, perhaps with sendMessages." #-}
{-# DEPRECATED spacing, spacingWithEdge, smartSpacing, smartSpacingWithEdge "Use spacingRaw instead." #-}
{-# DEPRECATED setSpacing "Use setScreenWindowSpacing instead." #-}
{-# DEPRECATED incSpacing "Use incScreenWindowSpacing instead." #-}
-- $backwardsCompatibility
-- The following functions and types exist solely for compatibility with
-- pre-0.14 releases.
-- | A type synonym for the 'Spacing' 'LayoutModifier'.
type SpacingWithEdge = Spacing
-- | A type synonym for the 'Spacing' 'LayoutModifier'.
type SmartSpacing = Spacing
-- | A type synonym for the 'Spacing' 'LayoutModifier'.
type SmartSpacingWithEdge = Spacing
-- | Message to dynamically modify (e.g. increase\/decrease\/set) the size of
-- the screen spacing and window spacing. See 'SpacingModifier'.
data ModifySpacing = ModifySpacing (Int -> Int) deriving (Typeable)
instance Message ModifySpacing
-- | Set spacing to given amount
setSpacing :: Int -> X ()
setSpacing n = sendMessage $ ModifySpacing $ const n
-- | Increase spacing by given amount
incSpacing :: Int -> X ()
incSpacing n = sendMessage $ ModifySpacing $ (+n)
instance LayoutModifier Spacing a where
pureModifier (Spacing p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
pureMess (Spacing px) m
| Just (ModifySpacing f) <- fromMessage m = Just $ Spacing $ max 0 $ f px
| otherwise = Nothing
modifierDescription (Spacing p) = "Spacing " ++ show p
-- | Surround all windows by a certain number of pixels of blank space. See
-- 'spacingRaw'.
spacing :: Int -> l a -> ModifiedLayout Spacing l a
spacing i = spacingRaw False (uniformBorder 0) False (uniformBorder i') True
where i' = fromIntegral i
-- | Surround all windows by a certain number of pixels of blank space, and
-- additionally adds the same amount of spacing around the edge of the screen.
spacingWithEdge :: Int -> l a -> ModifiedLayout SpacingWithEdge l a
spacingWithEdge p = ModifiedLayout (SpacingWithEdge p)
data SpacingWithEdge a = SpacingWithEdge Int deriving (Show, Read)
instance LayoutModifier SpacingWithEdge a where
pureModifier (SpacingWithEdge p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
pureMess (SpacingWithEdge px) m
| Just (ModifySpacing f) <- fromMessage m = Just $ SpacingWithEdge $ max 0 $ f px
| otherwise = Nothing
modifyLayout (SpacingWithEdge p) w r = runLayout w (shrinkRect p r)
modifierDescription (SpacingWithEdge p) = "SpacingWithEdge " ++ show p
shrinkRect :: Int -> Rectangle -> Rectangle
shrinkRect p (Rectangle x y w h) = Rectangle (x+fi p) (y+fi p) (fi $ max 1 $ fi w-2*p) (fi $ max 1 $ fi h-2*p)
-- See 'spacingRaw'.
spacingWithEdge :: Int -> l a -> ModifiedLayout Spacing l a
spacingWithEdge i = spacingRaw False (uniformBorder i') True (uniformBorder i') True
where i' = fromIntegral i
-- | Surrounds all windows with blank space, except when the window is the only
-- visible window on the current workspace.
smartSpacing :: Int -> l a -> ModifiedLayout SmartSpacing l a
smartSpacing p = ModifiedLayout (SmartSpacing p)
-- visible window on the current workspace. See 'spacingRaw'.
smartSpacing :: Int -> l a -> ModifiedLayout Spacing l a
smartSpacing i = spacingRaw True (uniformBorder 0) False (uniformBorder i') True
where i' = fromIntegral i
data SmartSpacing a = SmartSpacing Int deriving (Show, Read)
-- | Surrounds all windows with blank space, and adds the same amount of
-- spacing around the edge of the screen, except when the window is the only
-- visible window on the current workspace. See 'spacingRaw'.
smartSpacingWithEdge :: Int -> l a -> ModifiedLayout Spacing l a
smartSpacingWithEdge i = spacingRaw True (uniformBorder i') True (uniformBorder i') True
where i' = fromIntegral i
instance LayoutModifier SmartSpacing a where
-- | See 'setScreenWindowSpacing'.
setSpacing :: Int -> X ()
setSpacing = setScreenWindowSpacing . fromIntegral
pureModifier _ _ _ [x] = ([x], Nothing)
pureModifier (SmartSpacing p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
pureMess (SmartSpacing px) m
| Just (ModifySpacing f) <- fromMessage m = Just $ SmartSpacing $ max 0 $ f px
| otherwise = Nothing
modifierDescription (SmartSpacing p) = "SmartSpacing " ++ show p
-- | Surrounds all windows with blank space, and adds the same amount of spacing
-- around the edge of the screen, except when the window is the only visible
-- window on the current workspace.
smartSpacingWithEdge :: Int -> l a -> ModifiedLayout SmartSpacingWithEdge l a
smartSpacingWithEdge p = ModifiedLayout (SmartSpacingWithEdge p)
data SmartSpacingWithEdge a = SmartSpacingWithEdge Int deriving (Show, Read)
instance LayoutModifier SmartSpacingWithEdge a where
pureModifier _ _ _ [x] = ([x], Nothing)
pureModifier (SmartSpacingWithEdge p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)
modifyLayout (SmartSpacingWithEdge p) w r
| maybe False (\s -> null (up s) && null (down s)) (stack w) = runLayout w r
| otherwise = runLayout w (shrinkRect p r)
pureMess (SmartSpacingWithEdge px) m
| Just (ModifySpacing f) <- fromMessage m = Just $ SmartSpacingWithEdge $ max 0 $ f px
| otherwise = Nothing
modifierDescription (SmartSpacingWithEdge p) = "SmartSpacingWithEdge " ++ show p
-- | See 'incScreenWindowSpacing'.
incSpacing :: Int -> X ()
incSpacing = incScreenWindowSpacing . fromIntegral

94
XMonad/Layout/StateFull.hs Normal file
View File

@ -0,0 +1,94 @@
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
--------------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.StateFull
-- Description : The StateFull Layout & FocusTracking Layout Transformer
-- Copyright : (c) 2018 L. S. Leary
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : L. S. Leary
-- Stability : unstable
-- Portability : unportable
--
-- Provides StateFull: a stateful form of Full that does not misbehave when
-- floats are focused, and the FocusTracking layout transformer by means of
-- which StateFull is implemented. FocusTracking simply holds onto the last
-- true focus it was given and continues to use it as the focus for the
-- transformed layout until it sees another. It can be used to improve the
-- behaviour of a child layout that has not been given the focused window.
--------------------------------------------------------------------------------
module XMonad.Layout.StateFull (
-- * Usage
-- $Usage
pattern StateFull,
StateFull,
FocusTracking(..),
focusTracking
) where
import XMonad hiding ((<&&>))
import qualified XMonad.StackSet as W
import XMonad.Util.Stack (findZ)
import Data.Maybe (fromMaybe)
import Control.Applicative ((<|>),(<$>))
import Control.Monad (join)
-- $Usage
--
-- To use it, first you need to:
--
-- > import XMonad.Layout.StateFull
--
-- Then to toggle your tiled layout with @StateFull@, you can do:
--
-- > main = xmonad def { layoutHook = someTiledLayout ||| StateFull }
--
-- Or, some child layout that depends on focus information can be made to fall
-- back on the last focus it had:
--
-- > main = xmonad def
-- > { layoutHook = someParentLayoutWith aChild (focusTracking anotherChild) }
-- | The @FocusTracking@ data type for which the @LayoutClass@ instance is
-- provided.
data FocusTracking l a = FocusTracking (Maybe a) (l a)
deriving (Show, Read)
-- | Transform a layout into one that remembers and uses its last focus.
focusTracking :: l a -> FocusTracking l a
focusTracking = FocusTracking Nothing
-- | A type synonym to match the @StateFull@ pattern synonym.
type StateFull = FocusTracking Full
-- | A pattern synonym for the primary use case of the @FocusTracking@
-- transformer; using @Full@.
pattern StateFull = FocusTracking Nothing Full
instance LayoutClass l Window => LayoutClass (FocusTracking l) Window where
description (FocusTracking _ child)
| (chDesc == "Full") = "StateFull"
| (' ' `elem` chDesc) = "FocusTracking (" ++ chDesc ++ ")"
| otherwise = "FocusTracking " ++ chDesc
where chDesc = description child
runLayout (W.Workspace i (FocusTracking mOldFoc childL) mSt) sr = do
mRealFoc <- gets (W.peek . windowset)
let mGivenFoc = W.focus <$> mSt
passedMSt = if mRealFoc == mGivenFoc then mSt
else join (mOldFoc >>= \oF -> findZ (==oF) mSt) <|> mSt
(wrs, mChildL') <- runLayout (W.Workspace i childL passedMSt) sr
let newFT = if mRealFoc /= mGivenFoc then FocusTracking mOldFoc <$> mChildL'
else Just $ FocusTracking mGivenFoc (fromMaybe childL mChildL')
return (wrs, newFT)
handleMessage (FocusTracking mf childLayout) m =
(fmap . fmap) (FocusTracking mf) (handleMessage childLayout m)

98
XMonad/Layout/TwoPanePersistent.hs Normal file
View File

@ -0,0 +1,98 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.TwoPanePersistent
-- Copyright : (c) Chayanon Wichitrnithed
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : Chayanon Wichitrnithed <namowi@gatech.edu>
-- Stability : unstable
-- Portability : unportable
--
-- This layout is the same as "XMonad.Layout.TwoPane" except that it keeps track of the slave window
-- that is alongside the master pane. In other words, it prevents the slave pane
-- from changing after the focus goes back to the master pane.
-----------------------------------------------------------------------------
module XMonad.Layout.TwoPanePersistent
(
-- * Usage
-- $usage
TwoPanePersistent(..)
) where
import XMonad.StackSet (focus, up, down, Stack, Stack(..))
import XMonad hiding (focus)
-- $usage
-- Import the module in @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Layout.TwoPanePersistent
--
-- Then add the layout to the @layoutHook@:
--
-- > myLayout = TwoPanePersistent Nothing (3/100) (1/2) ||| Full ||| etc..
-- > main = xmonad def { layoutHook = myLayout }
data TwoPanePersistent a = TwoPanePersistent
{ slaveWin :: (Maybe a) -- ^ slave window; if 'Nothing' or not in the current workspace,
-- the window below the master will go into the slave pane
, dFrac :: Rational -- ^ shrink/expand size
, mFrac :: Rational -- ^ initial master size
} deriving (Show, Read)
instance (Show a, Eq a) => LayoutClass TwoPanePersistent a where
doLayout l r s =
case reverse (up s) of
-- master is focused
[] -> return $ focusedMaster l s r
-- slave is focused
(master:_) -> return $ focusedSlave l s r master
pureMessage (TwoPanePersistent w delta split) x =
case fromMessage x of
Just Shrink -> Just (TwoPanePersistent w delta (split - delta))
Just Expand -> Just (TwoPanePersistent w delta (split + delta))
_ -> Nothing
description _ = "TwoPanePersistent"
----------------------------------------------------------------------------------------
focusedMaster :: (Eq a) => TwoPanePersistent a -> Stack a -> Rectangle
-> ( [(a, Rectangle)], Maybe (TwoPanePersistent a) )
focusedMaster (TwoPanePersistent w delta split) s r =
let (left, right) = splitHorizontallyBy split r in
case down s of
-- there exist windows below the master
(next:_) -> let nextSlave = ( [(focus s, left), (next, right)]
, Just $ TwoPanePersistent (Just next) delta split )
in case w of
-- if retains state, preserve the layout
Just win -> if win `elem` (down s) && (focus s /= win)
then ( [(focus s, left), (win, right)]
, Just $ TwoPanePersistent w delta split )
else nextSlave
-- if no previous state, default to the next slave window
Nothing -> nextSlave
-- the master is the only window
[] -> ( [(focus s, r)]
, Just $ TwoPanePersistent Nothing delta split )
focusedSlave :: TwoPanePersistent a -> Stack a -> Rectangle -> a
-> ( [(a, Rectangle)], Maybe (TwoPanePersistent a) )
focusedSlave (TwoPanePersistent _ delta split) s r m =
( [(m, left), (focus s, right)]
, Just $ TwoPanePersistent (Just $ focus s) delta split )
where (left, right) = splitHorizontallyBy split r

1102
XMonad/Prompt.hs
View File

File diff suppressed because it is too large Load Diff

26
XMonad/Prompt/AppendFile.hs
View File

@ -23,6 +23,7 @@ module XMonad.Prompt.AppendFile (
-- $usage
appendFilePrompt,
appendFilePrompt',
AppendFile,
) where
@ -55,6 +56,17 @@ import Control.Exception.Extensible (bracket)
--
-- (Put the spawn on the line after the prompt to append the time instead.)
--
-- 'appendFilePrompt'' can be used to transform the string input in the prompt
-- before saving into the file. Previous example with date can be rewritten as:
--
-- > , ((modm .|. controlMask, xK_n), do
-- > date <- io $ liftM (formatTime defaultTimeLocale "[%Y-%m-%d %H:%M] ") getZonedTime
-- > appendFilePrompt' def (date ++) $ "/home/me/NOTES"
-- > )
--
-- A benefit is that if the prompt is cancelled the date is not output to
-- the file too.
--
-- For detailed instructions on editing your key bindings, see
-- "XMonad.Doc.Extending#Editing_key_bindings".
@ -66,11 +78,17 @@ instance XPrompt AppendFile where
-- | Given an XPrompt configuration and a file path, prompt the user
-- for a line of text, and append it to the given file.
appendFilePrompt :: XPConfig -> FilePath -> X ()
appendFilePrompt c fn = mkXPrompt (AppendFile fn)
appendFilePrompt c fn = appendFilePrompt' c id fn
-- | Given an XPrompt configuration, string transformation function
-- and a file path, prompt the user for a line of text, transform it
-- and append the result to the given file.
appendFilePrompt' :: XPConfig -> (String -> String) -> FilePath -> X ()
appendFilePrompt' c trans fn = mkXPrompt (AppendFile fn)
c
(const (return []))
(doAppend fn)
(doAppend trans fn)
-- | Append a string to a file.
doAppend :: FilePath -> String -> X ()
doAppend fn = io . bracket (openFile fn AppendMode) hClose . flip hPutStrLn
doAppend :: (String -> String) -> FilePath -> String -> X ()
doAppend trans fn = io . bracket (openFile fn AppendMode) hClose . flip hPutStrLn . trans

104
XMonad/Prompt/FuzzyMatch.hs Normal file
View File

@ -0,0 +1,104 @@
--------------------------------------------------------------------------------
-- |
-- Module : XMonad.Prompt.FuzzyMatch
-- Copyright : (C) 2015 Norbert Zeh
-- License : GPL
--
-- Maintainer : Norbert Zeh <norbert.zeh@gmail.com>
-- Stability : unstable
-- Portability : unportable
--
-- A module for fuzzy completion matching in prompts akin to emacs ido mode.
--
--------------------------------------------------------------------------------
module XMonad.Prompt.FuzzyMatch ( -- * Usage
-- $usage
fuzzyMatch
, fuzzySort
) where
import Data.Char
import Data.Function
import Data.List
-- $usage
--
-- This module offers two aspects of fuzzy matching of completions offered by
-- XMonad.Prompt.
--
-- 'fuzzyMatch' can be used as the searchPredicate in the XPConfig. The effect
-- is that any completion that contains the currently typed characters as a
-- subsequence is a valid completion; matching is case insensitive. This means
-- that the sequence of typed characters can be obtained from the completion by
-- deleting an appropriate subset of its characters. Example: "spr" matches
-- "FastSPR" but also "SuccinctParallelTrees" because it's a subsequence of the
-- latter: "S.......P.r..........".
--
-- While this type of inclusiveness is helpful most of the time, it sometimes
-- also produces surprising matches. 'fuzzySort' helps sorting matches by
-- relevance, using a simple heuristic for measuring relevance. The matches are
-- sorted primarily by the length of the substring that contains the query
-- characters and secondarily the starting position of the match. So, if the
-- search string is "spr" and the matches are "FastSPR", "FasterSPR", and
-- "SuccinctParallelTrees", then the order is "FastSPR", "FasterSPR",
-- "SuccinctParallelTrees" because both "FastSPR" and "FasterSPR" contain "spr"
-- within a substring of length 3 ("SPR") while the shortest substring of
-- "SuccinctParallelTrees" that matches "spr" is "SuccinctPar", which has length
-- 11. "FastSPR" is ranked before "FasterSPR" because its match starts at
-- position 5 while the match in "FasterSPR" starts at position 7.
--
-- To use these functions in an XPrompt, for example, for windowPrompt:
--
-- > import XMonad.Prompt
-- > import XMonad.Prompt.Window ( windowPrompt )
-- > import XMonad.Prompt.FuzzyMatch
-- >
-- > myXPConfig = def { searchPredicate = fuzzyMatch
-- > , sorter = fuzzySort
-- > }
--
-- then add this to your keys definition:
--
-- > , ((modm .|. shiftMask, xK_g), windowPrompt myXPConfig Goto allWindows)
--
-- For detailed instructions on editing the key bindings, see
-- "Xmonad.Doc.Extending#Editing_key_bindings".
-- | Returns True if the first argument is a subsequence of the second argument,
-- that is, it can be obtained from the second sequence by deleting elements.
fuzzyMatch :: String -> String -> Bool
fuzzyMatch [] _ = True
fuzzyMatch _ [] = False
fuzzyMatch xxs@(x:xs) (y:ys) | toLower x == toLower y = fuzzyMatch xs ys
| otherwise = fuzzyMatch xxs ys
-- | Sort the given set of strings by how well they match. Match quality is
-- measured first by the length of the substring containing the match and second
-- by the positions of the matching characters in the string.
fuzzySort :: String -> [String] -> [String]
fuzzySort q = map snd . sortBy (compare `on` fst) . map (rankMatch q)
rankMatch :: String -> String -> ((Int, Int), String)
rankMatch q s = (minimum $ rankMatches q s, s)
rankMatches :: String -> String -> [(Int, Int)]
rankMatches [] _ = [(0, 0)]
rankMatches q s = map (\(l, r) -> (r - l, l)) $ findShortestMatches q s
findShortestMatches :: String -> String -> [(Int, Int)]
findShortestMatches q s = foldl' extendMatches spans oss
where (os:oss) = map (findOccurrences s) q
spans = [(o, o) | o <- os]
findOccurrences :: String -> Char -> [Int]
findOccurrences s c = map snd $ filter ((toLower c ==) . toLower . fst) $ zip s [0..]
extendMatches :: [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches spans xs = map last $ groupBy ((==) `on` snd) $ extendMatches' spans xs
extendMatches' :: [(Int, Int)] -> [Int] -> [(Int, Int)]
extendMatches' [] _ = []
extendMatches' _ [] = []
extendMatches' spans@((l, r):spans') xs@(x:xs') | r < x = (l, x) : extendMatches' spans' xs
| otherwise = extendMatches' spans xs'

89
XMonad/Prompt/Pass.hs
View File

@ -8,38 +8,48 @@
-- Stability : unstable
-- Portability : unportable
--
-- This module provides 3 <XMonad.Prompt> to ease passwords manipulation (generate, read, remove):
-- This module provides 5 <XMonad.Prompt>s to ease password
-- manipulation (generate, read, edit, remove):
--
-- - one to lookup passwords in the password-storage.
-- - two to lookup passwords in the password-store; one of which
-- copies to the clipboard, and the other uses @xdotool@ to type the
-- password directly.
--
-- - one to generate a password for a given password label that the user inputs.
-- - one to generate a password for a given password label that the
-- user inputs.
--
-- - one to delete a stored password for a given password label that the user inputs.
-- - one to edit a password for a given password label that the user
-- inputs.
--
-- All those prompts benefit from the completion system provided by the module <XMonad.Prompt>.
-- - one to delete a stored password for a given password label that
-- the user inputs.
--
-- The password store is setuped through an environment variable PASSWORD_STORE_DIR.
-- If this is set, use the content of the variable.
-- Otherwise, the password store is located on user's home @$HOME\/.password-store@.
-- All those prompts benefit from the completion system provided by
-- the module <XMonad.Prompt>.
--
-- The password store is setup through an environment variable
-- PASSWORD_STORE_DIR, or @$HOME\/.password-store@ if it is unset.
-- The editor is determined from the environment variable EDITOR.
--
-- Source:
--
-- - The password storage implementation is <http://git.zx2c4.com/password-store the password-store cli>.
-- - The <https://www.passwordstore.org/ password store>
-- implementation is <http://git.zx2c4.com/password-store here>.
--
-- - Inspired from <http://babushk.in/posts/combining-xmonad-and-pass.html>
-- - Inspired by <http://babushk.in/posts/combining-xmonad-and-pass.html>
--
-----------------------------------------------------------------------------
module XMonad.Prompt.Pass (
-- * Usages
-- $usages
-- * Usage
-- $usage
passPrompt
, passGeneratePrompt
, passRemovePrompt
, passEditPrompt
, passTypePrompt
) where
import Control.Monad (liftM)
import XMonad.Core
import XMonad.Prompt ( XPrompt
, showXPrompt
@ -54,32 +64,34 @@ import System.FilePath (takeExtension, dropExtension, combine)
import System.Posix.Env (getEnv)
import XMonad.Util.Run (runProcessWithInput)
-- $usages
-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Prompt.Pass
--
-- Then add a keybinding for 'passPrompt', 'passGeneratePrompt' or 'passRemovePrompt':
-- Then add a keybinding for 'passPrompt', 'passGeneratePrompt',
-- 'passRemovePrompt', 'passEditPrompt' or 'passTypePrompt':
--
-- > , ((modMask , xK_p) , passPrompt xpconfig)
-- > , ((modMask .|. controlMask, xK_p) , passGeneratePrompt xpconfig)
-- > , ((modMask .|. shiftMask, xK_p) , passEditPrompt xpconfig)
-- > , ((modMask .|. controlMask .|. shiftMask, xK_p), passRemovePrompt xpconfig)
--
-- For detailed instructions on:
--
-- - editing your key bindings, see "XMonad.Doc.Extending#Editing_key_bindings".
--
-- - how to setup the password storage, see <http://git.zx2c4.com/password-store/about/>
-- - how to setup the password store, see <http://git.zx2c4.com/password-store/about/>
--
type Predicate = String -> String -> Bool
getPassCompl :: [String] -> Predicate -> String -> IO [String]
getPassCompl compls p s = do return $ filter (p s) compls
getPassCompl compls p s = return $ filter (p s) compls
type PromptLabel = String
data Pass = Pass PromptLabel
newtype Pass = Pass PromptLabel
instance XPrompt Pass where
showXPrompt (Pass prompt) = prompt ++ ": "
@ -98,7 +110,7 @@ passwordStoreFolderDefault home = combine home ".password-store"
passwordStoreFolder :: IO String
passwordStoreFolder =
getEnv "PASSWORD_STORE_DIR" >>= computePasswordStoreDir
where computePasswordStoreDir Nothing = liftM passwordStoreFolderDefault getHomeDirectory
where computePasswordStoreDir Nothing = fmap passwordStoreFolderDefault getHomeDirectory
computePasswordStoreDir (Just storeDir) = return storeDir
-- | A pass prompt factory
@ -126,23 +138,52 @@ passGeneratePrompt = mkPassPrompt "Generate password" generatePassword
passRemovePrompt :: XPConfig -> X ()
passRemovePrompt = mkPassPrompt "Remove password" removePassword
-- | A prompt to type in a password for a given entry.
-- This doesn't touch the clipboard.
--
passTypePrompt :: XPConfig -> X ()
passTypePrompt = mkPassPrompt "Type password" typePassword
-- | A prompt to edit a given entry.
-- This doesn't touch the clipboard.
--
passEditPrompt :: XPConfig -> X ()
passEditPrompt = mkPassPrompt "Edit password" editPassword
-- | Select a password.
--
selectPassword :: String -> X ()
selectPassword passLabel = spawn $ "pass --clip " ++ passLabel
selectPassword passLabel = spawn $ "pass --clip \"" ++ escapeQuote passLabel ++ "\""
-- | Generate a 30 characters password for a given entry.
-- If the entry already exists, it is updated with a new password.
--
generatePassword :: String -> X ()
generatePassword passLabel = spawn $ "pass generate --force " ++ passLabel ++ " 30"
generatePassword passLabel = spawn $ "pass generate --force \"" ++ escapeQuote passLabel ++ "\" 30"
-- | Remove a password stored for a given entry.
--
removePassword :: String -> X ()
removePassword passLabel = spawn $ "pass rm --force " ++ passLabel
removePassword passLabel = spawn $ "pass rm --force \"" ++ escapeQuote passLabel ++ "\""
-- | Retrieve the list of passwords from the password storage 'passwordStoreDir
-- | Edit a password stored for a given entry.
--
editPassword :: String -> X ()
editPassword passLabel = spawn $ "pass edit \"" ++ escapeQuote passLabel ++ "\""
-- | Type a password stored for a given entry using xdotool.
--
typePassword :: String -> X ()
typePassword passLabel = spawn $ "pass \"" ++ escapeQuote passLabel
++ "\"|head -n1|tr -d '\n'|xdotool type --clearmodifiers --file -"
escapeQuote :: String -> String
escapeQuote = concatMap escape
where escape :: Char -> String
escape '"' = ['\\', '\"']
escape x = return x
-- | Retrieve the list of passwords from the password store 'passwordStoreDir
getPasswords :: FilePath -> IO [String]
getPasswords passwordStoreDir = do
files <- runProcessWithInput "find" [
@ -150,7 +191,7 @@ getPasswords passwordStoreDir = do
"-type", "f",
"-name", "*.gpg",
"-printf", "%P\n"] []
return $ map removeGpgExtension $ lines files
return . map removeGpgExtension $ lines files
removeGpgExtension :: String -> String
removeGpgExtension file | takeExtension file == ".gpg" = dropExtension file

106
XMonad/Prompt/Unicode.hs
View File

@ -1,6 +1,7 @@
{- |
Module : XMonad.Prompt.Unicode
Copyright : (c) 2016 Joachim Breitner
2017 Nick Hu
License : BSD-style (see LICENSE)
Maintainer : <mail@joachim-breitner.de>
@ -9,14 +10,18 @@ Stability : stable
A prompt for searching unicode characters by name and inserting them into
the clipboard.
Requires the file @\/usr\/share\/unicode\/UnicodeData.txt@ (shipped in the package
@unicode-data@ on Debian) and the @xsel@ tool.
The provided @unicodePrompt@ and @typeUnicodePrompt@ use @xsel@ and @xdotool@
respectively.
-}
{-# LANGUAGE DeriveDataTypeable #-}
module XMonad.Prompt.Unicode (
-- * Usage
-- $usage
unicodePrompt
unicodePrompt,
typeUnicodePrompt,
mkUnicodePrompt
) where
import qualified Data.ByteString.Char8 as BS
@ -33,9 +38,23 @@ import Data.List
import Text.Printf
import XMonad
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Util.Run
import XMonad.Prompt
data Unicode = Unicode
instance XPrompt Unicode where
showXPrompt Unicode = "Unicode: "
commandToComplete Unicode s = s
nextCompletion Unicode = getNextCompletion
newtype UnicodeData = UnicodeData { getUnicodeData :: [(Char, BS.ByteString)] }
deriving (Typeable, Read, Show)
instance ExtensionClass UnicodeData where
initialValue = UnicodeData []
extensionType = StateExtension
{- $usage
You can use this module by importing it, along with
@ -46,54 +65,61 @@ You can use this module by importing it, along with
and adding an appropriate keybinding, for example:
> , ((modm .|. controlMask, xK_u), unicodePrompt def)
> , ((modm .|. controlMask, xK_u), unicodePrompt "/path/to/unicode-data" def)
More flexibility is given by the @mkUnicodePrompt@ function, which takes a
command and a list of arguments to pass as its first two arguments. See
@unicodePrompt@ for details.
-}
unicodeDataFilename :: String
unicodeDataFilename = "/usr/share/unicode/UnicodeData.txt"
entries :: [(Char, BS.ByteString)]
entries = unsafePerformIO $ do
datE <- tryIOError $ BS.readFile unicodeDataFilename
case datE of
Left e -> do
hPutStrLn stderr $ "Could not read file \"" ++ unicodeDataFilename ++ "\""
hPutStrLn stderr $ show e
hPutStrLn stderr $ "Do you have unicode-data installed?"
return []
Right dat -> return $ sortBy (comparing (BS.length . snd)) $ parseUnicodeData dat
{-# NOINLINE entries #-}
populateEntries :: String -> X Bool
populateEntries unicodeDataFilename = do
entries <- fmap getUnicodeData (XS.get :: X UnicodeData)
if null entries
then do
datE <- liftIO . tryIOError $ BS.readFile unicodeDataFilename
case datE of
Left e -> liftIO $ do
hPutStrLn stderr $ "Could not read file \"" ++ unicodeDataFilename ++ "\""
hPrint stderr e
hPutStrLn stderr "Do you have unicode-data installed?"
return False
Right dat -> do
XS.put . UnicodeData . sortBy (comparing (BS.length . snd)) $ parseUnicodeData dat
return True
else return True
parseUnicodeData :: BS.ByteString -> [(Char, BS.ByteString)]
parseUnicodeData = mapMaybe parseLine . BS.lines
where
parseLine l = do
field1 : field2 : _ <- return $ BS.split ';' l
[(c,"")] <- return $ readHex (BS.unpack field1)
return (chr c, field2)
where parseLine l = do
field1 : field2 : _ <- return $ BS.split ';' l
[(c,"")] <- return . readHex $ BS.unpack field1
return (chr c, field2)
searchUnicode :: String -> [(Char, String)]
searchUnicode s = map (second BS.unpack) $ filter go entries
where w = map BS.pack $ filter (all isAscii) $ filter ((> 1) . length) $ words $ map toUpper s
searchUnicode :: [(Char, BS.ByteString)] -> String -> [(Char, String)]
searchUnicode entries s = map (second BS.unpack) $ filter go entries
where w = map BS.pack . filter (all isAscii) . filter ((> 1) . length) . words $ map toUpper s
go (c,d) = all (`BS.isInfixOf` d) w
-- | Prompt the user for a unicode character to be inserted into the paste buffer of the X server.
unicodePrompt :: XPConfig -> X ()
unicodePrompt config = mkXPrompt Unicode config unicodeCompl paste
mkUnicodePrompt :: String -> [String] -> String -> XPConfig -> X ()
mkUnicodePrompt prog args unicodeDataFilename config =
whenX (populateEntries unicodeDataFilename) $ do
entries <- fmap getUnicodeData (XS.get :: X UnicodeData)
mkXPrompt Unicode config (unicodeCompl entries) paste
where
unicodeCompl [] = return []
unicodeCompl s = do
return $ map (\(c,d) -> printf "%s %s" [c] d) $ take 20 $ searchUnicode s
unicodeCompl _ [] = return []
unicodeCompl entries s = do
let m = searchUnicode entries s
return . map (\(c,d) -> printf "%s %s" [c] d) $ take 20 m
paste [] = return ()
paste (c:_) = do
runProcessWithInput "xsel" ["-i"] [c]
return ()
runProcessWithInput prog args [c]
return ()
data Unicode = Unicode
instance XPrompt Unicode where
showXPrompt Unicode = "Unicode: "
commandToComplete Unicode s = s
nextCompletion Unicode = getNextCompletion
-- | Prompt the user for a Unicode character to be inserted into the paste buffer of the X server.
unicodePrompt :: String -> XPConfig -> X ()
unicodePrompt = mkUnicodePrompt "xsel" ["-i"]
-- | Prompt the user for a Unicode character to be typed by @xdotool@.
typeUnicodePrompt :: String -> XPConfig -> X ()
typeUnicodePrompt = mkUnicodePrompt "xdotool" ["type", "--clearmodifiers", "--file", "-"]

23
XMonad/Util/Dmenu.hs
View File

@ -24,6 +24,7 @@ import XMonad
import qualified XMonad.StackSet as W
import qualified Data.Map as M
import XMonad.Util.Run
import Control.Monad (liftM)
-- $usage
-- You can use this module with the following in your Config.hs file:
@ -41,28 +42,32 @@ import XMonad.Util.Run
-- <http://www.jcreigh.com/dmenu/dmenu-3.2-xinerama.patch>
dmenuXinerama :: [String] -> X String
dmenuXinerama opts = do
curscreen <- (fromIntegral . W.screen . W.current) `fmap` gets windowset :: X Int
runProcessWithInput "dmenu" ["-xs", show (curscreen+1)] (unlines opts)
curscreen <-
(fromIntegral . W.screen . W.current) `fmap` gets windowset :: X Int
_ <-
runProcessWithInput "dmenu" ["-xs", show (curscreen+1)] (unlines opts)
menuArgs "dmenu" ["-xs", show (curscreen+1)] opts
-- | Run dmenu to select an option from a list.
dmenu :: [String] -> X String
dmenu :: MonadIO m => [String] -> m String
dmenu opts = menu "dmenu" opts
-- | like 'dmenu' but also takes the command to run.
menu :: String -> [String] -> X String
menu :: MonadIO m => String -> [String] -> m String
menu menuCmd opts = menuArgs menuCmd [] opts
-- | Like 'menu' but also takes a list of command line arguments.
menuArgs :: String -> [String] -> [String] -> X String
menuArgs menuCmd args opts = fmap (filter (/='\n')) $ runProcessWithInput menuCmd args (unlines opts)
menuArgs :: MonadIO m => String -> [String] -> [String] -> m String
menuArgs menuCmd args opts = liftM (filter (/='\n')) $
runProcessWithInput menuCmd args (unlines opts)
-- | Like 'dmenuMap' but also takes the command to run.
menuMap :: String -> M.Map String a -> X (Maybe a)
menuMap :: MonadIO m => String -> M.Map String a -> m (Maybe a)
menuMap menuCmd selectionMap = menuMapArgs menuCmd [] selectionMap
-- | Like 'menuMap' but also takes a list of command line arguments.
menuMapArgs :: String -> [String] -> M.Map String a -> X (Maybe a)
menuMapArgs :: MonadIO m => String -> [String] -> M.Map String a ->
m (Maybe a)
menuMapArgs menuCmd args selectionMap = do
selection <- menuFunction (M.keys selectionMap)
return $ M.lookup selection selectionMap
@ -70,5 +75,5 @@ menuMapArgs menuCmd args selectionMap = do
menuFunction = menuArgs menuCmd args
-- | Run dmenu to select an entry from a map based on the key.
dmenuMap :: M.Map String a -> X (Maybe a)
dmenuMap :: MonadIO m => M.Map String a -> m (Maybe a)
dmenuMap selectionMap = menuMap "dmenu" selectionMap

53
XMonad/Util/Dzen.hs
View File

@ -25,6 +25,11 @@ module XMonad.Util.Dzen (
x,
y,
addArgs,
fgColor,
bgColor,
align,
slaveAlign,
lineCount,
-- * Legacy interface
dzen,
@ -41,6 +46,7 @@ import Control.Monad
import XMonad
import XMonad.StackSet
import XMonad.Util.Run (runProcessWithInputAndWait, seconds)
import XMonad.Util.Font (Align (..))
type DzenConfig = (Int, [String]) -> X (Int, [String])
@ -116,6 +122,45 @@ x n = addArgs ["-x", show n]
y :: Int -> DzenConfig
y n = addArgs ["-y", show n]
-- | Set the foreground color.
--
-- Please be advised that @fgColor@ and @bgColor@ also exist in "XMonad.Prompt".
-- If you use both modules, you might have to tell the compiler which one you mean:
--
-- > import XMonad.Prompt as P
-- > import XMonad.Util.Dzen as D
-- >
-- > dzenConfig (D.fgColor "#f0f0f0") "foobar"
fgColor :: String -> DzenConfig
fgColor c = addArgs ["-fg", c]
-- | Set the background color.
bgColor :: String -> DzenConfig
bgColor c = addArgs ["-bg", c]
-- | Set the alignment of the title (main) window content.
-- Note that @AlignRightOffset@ is treated as equal to @AlignRight@.
--
-- > import XMonad.Util.Font (Align(..))
-- >
-- > dzenConfig (align AlignLeft) "foobar"
align :: Align -> DzenConfig
align = align' "-ta"
-- | Set the alignment of the slave window content.
-- Using this option only makes sense if you also use the @lineCount@ parameter.
slaveAlign :: Align -> DzenConfig
slaveAlign = align' "-sa"
-- Set an alignment parameter
align' :: String -> Align -> DzenConfig
align' opt a = addArgs [opt, s] where
s = case a of
AlignCenter -> "c"
AlignLeft -> "l"
AlignRight -> "r"
AlignRightOffset _ -> "r"
-- | Specify the font. Check out xfontsel to get the format of the String
-- right; if your dzen supports xft, then you can supply that here, too.
font :: String -> DzenConfig
@ -160,6 +205,14 @@ detailFromScreenId sc ws = fmap screenRect maybeSD where
mapping = map (\s -> (screen s, screenDetail s)) (c:v)
maybeSD = lookup sc mapping
-- | Enable slave window and specify the number of lines.
--
-- Dzen can optionally draw a second window underneath the title window.
-- By default, this window is only displayed if the mouse enters the title window.
-- This option is only useful if the string you want to display contains more than one line.
lineCount :: Int -> DzenConfig
lineCount n = addArgs ["-l", show n]
-- | @dzen str timeout@ pipes @str@ to dzen2 for @timeout@ microseconds.
-- Example usage:
--

23
XMonad/Util/ExtensibleState.hs
View File

@ -27,6 +27,7 @@ module XMonad.Util.ExtensibleState (
import Data.Typeable (typeOf,cast)
import qualified Data.Map as M
import XMonad.Core
import XMonad.Util.PureX
import qualified Control.Monad.State as State
import Data.Maybe (fromMaybe)
@ -75,27 +76,29 @@ import Data.Maybe (fromMaybe)
--
-- | Modify the map of state extensions by applying the given function.
modifyStateExts :: (M.Map String (Either String StateExtension)
-> M.Map String (Either String StateExtension))
-> X ()
modifyStateExts
:: XLike m
=> (M.Map String (Either String StateExtension)
-> M.Map String (Either String StateExtension))
-> m ()
modifyStateExts f = State.modify $ \st -> st { extensibleState = f (extensibleState st) }
-- | Apply a function to a stored value of the matching type or the initial value if there
-- is none.
modify :: ExtensionClass a => (a -> a) -> X ()
modify :: (ExtensionClass a, XLike m) => (a -> a) -> m ()
modify f = put . f =<< get
-- | Add a value to the extensible state field. A previously stored value with the same
-- type will be overwritten. (More precisely: A value whose string representation of its type
-- is equal to the new one's)
put :: ExtensionClass a => a -> X ()
put :: (ExtensionClass a, XLike m) => a -> m ()
put v = modifyStateExts . M.insert (show . typeOf $ v) . Right . extensionType $ v
-- | Try to retrieve a value of the requested type, return an initial value if there is no such value.
get :: ExtensionClass a => X a
get :: (ExtensionClass a, XLike m) => m a
get = getState' undefined -- `trick' to avoid needing -XScopedTypeVariables
where toValue val = maybe initialValue id $ cast val
getState' :: ExtensionClass a => a -> X a
getState' :: (ExtensionClass a, XLike m) => a -> m a
getState' k = do
v <- State.gets $ M.lookup (show . typeOf $ k) . extensibleState
case v of
@ -110,14 +113,14 @@ get = getState' undefined -- `trick' to avoid needing -XScopedTypeVariables
[(x,"")] -> Just x
_ -> Nothing
gets :: ExtensionClass a => (a -> b) -> X b
gets :: (ExtensionClass a, XLike m) => (a -> b) -> m b
gets = flip fmap get
-- | Remove the value from the extensible state field that has the same type as the supplied argument
remove :: ExtensionClass a => a -> X ()
remove :: (ExtensionClass a, XLike m) => a -> m ()
remove wit = modifyStateExts $ M.delete (show . typeOf $ wit)
modified :: (ExtensionClass a, Eq a) => (a -> a) -> X Bool
modified :: (ExtensionClass a, Eq a, XLike m) => (a -> a) -> m Bool
modified f = do
v <- get
case f v of

276
XMonad/Util/PureX.hs Normal file
View File

@ -0,0 +1,276 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Util.PureX
-- Copyright : L. S. Leary 2018
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : L. S. Leary
-- Stability : unstable
-- Portability : not portable
--
-- Unlike the opaque @IO@ actions that @X@ actions can wrap, regular reads from
-- the 'XConf' and modifications to the 'XState' are fundamentally pure—contrary
-- to the current treatment of such actions in most xmonad code. Pure
-- modifications to the 'WindowSet' can be readily composed, but due to the need
-- for those modifications to be properly handled by 'windows', other pure
-- changes to the @XState@ cannot be interleaved with those changes to the
-- @WindowSet@ without superfluous refreshes, hence breaking composability.
--
-- This module aims to rectify that situation by drawing attention to it and
-- providing 'PureX': a pure type with the same monadic interface to state as
-- @X@. The 'XLike' typeclass enables writing actions generic over the two
-- monads; if pure, existing @X@ actions can be generalised with only a change
-- to the type signature. Various other utilities are provided, in particular
-- the 'defile' function which is needed by end-users.
--
-----------------------------------------------------------------------------
-- --< Imports & Exports >-- {{{
module XMonad.Util.PureX (
-- * Usage
-- $Usage
PureX, XLike(..), defile,
windowBracket', handlingRefresh,
runPureX, toXLike,
-- * Utility
-- ** Generalised when* functions
when', whenM', whenJust',
-- ** Infix operators
(<?), (&>),
-- ** @WindowSet@ operations
withWindowSet', withFocii,
modify'', modifyWindowSet',
getStack, putStack, peek,
view, greedyView, invisiView,
shift, curScreen, curWorkspace,
curTag, curScreenId,
) where
-- xmonad
import XMonad
import qualified XMonad.StackSet as W
-- mtl
import Control.Monad.State
import Control.Monad.Reader
-- base
import Data.Semigroup (Semigroup(..), Any(..))
import Control.Applicative (liftA2)
-- }}}
-- --< Usage >-- {{{
-- $Usage
--
-- The suggested pattern of usage for this module is to write composable, pure
-- actions as @XLike m => m Any@ or @PureX Any@ values, where the encapsulated
-- @Any@ value encodes whether or not a refresh is needed to properly institute
-- changes. These values can then be combined monoidally (i.e. with '<>' AKA
-- '<+>') or with operators such as '<*', '*>', '<?' and '&>' to build seamless
-- new actions. The end user can run and handle the effects of the pure actions
-- in the @X@ monad by applying the @defile@ function, which you may want to
-- re-export. Alternatively, if an action does not make stackset changes that
-- need to be handled by @windows@, it can be written with as an
-- @XLike m => m ()@ and used directly.
--
-- Unfortunately since layouts must handle messages in the @X@ monad, this
-- approach does not quite apply to actions involving them. However a relatively
-- direct translation to impure actions is possible: you can write composable,
-- refresh-tracking actions as @X Any@ values, making sure to eschew
-- refresh-inducing functions like @windows@ and @sendMessage@ in favour of
-- 'modifyWindowSet' and utilities provided by "XMonad.Actions.MessageFeedback".
-- The 'windowBracket_' function recently added to "XMonad.Operations" is the
-- impure analogue of @defile@. Note that @PureX Any@ actions can be composed
-- into impure ones after applying 'toX'; don't use @defile@ for this. E.g.
--
-- > windowBracket_ (composableImpureAction <> toX composablePureAction)
--
-- Although both @X@ and @PureX@ have Monoid instances over monoidal values,
-- @(XLike m, Monoid a)@ is not enough to infer @Monoid (m a)@ (due to the
-- open-world assumption). Hence a @Monoid (m Any)@ constraint may need to be
-- used when working with @XLike m => m Any@ where no context is forcing @m@ to
-- unify with @X@ or @PureX@. This can also be avoided by working with
-- @PureX Any@ values and generalising them with 'toXLike' where necessary.
--
-- @PureX@ also enables a more monadic style when writing windowset operations;
-- see the implementation of the utilities in this module for examples.
-- For an example of a whole module written in terms of this one, see
-- "XMonad.Hooks.RefocusLast".
--
-- }}}
-- --< Core >-- {{{
-- | The @PureX@ newtype over @ReaderT XConf (State XState) a@.
newtype PureX a = PureX (ReaderT XConf (State XState) a)
deriving (Functor, Applicative, Monad, MonadReader XConf, MonadState XState)
instance Semigroup a => Semigroup (PureX a) where
(<>) = liftA2 (<>)
instance Monoid a => Monoid (PureX a) where
mappend = liftA2 mappend
mempty = return mempty
-- | The @XLike@ typeclass over monads reading @XConf@ values and tracking
-- @XState@ state.
class (MonadReader XConf m, MonadState XState m) => XLike m where
toX :: m a -> X a
instance XLike X where
toX = id
instance XLike PureX where
toX = toXLike
-- | Consume a @PureX a@.
runPureX :: PureX a -> XConf -> XState -> (a, XState)
runPureX (PureX m) = runState . runReaderT m
-- | Despite appearing less general, @PureX a@ is actually isomorphic to
-- @XLike m => m a@.
toXLike :: XLike m => PureX a -> m a
toXLike pa = state =<< runPureX pa <$> ask
-- | A generalisation of 'windowBracket'. Handles refreshing for an action that
-- __performs no refresh of its own__ but can indicate that it needs one
-- through a return value that's tested against the supplied predicate. The
-- action can interleave changes to the @WindowSet@ with @IO@ or changes to
-- the @XState@.
windowBracket' :: XLike m => (a -> Bool) -> m a -> X a
windowBracket' p = windowBracket p . toX
-- | A version of @windowBracket'@ specialised to take a @PureX Any@ action and
-- handle windowset changes with a refresh when the @Any@ holds @True@.
-- Analogous to 'windowBracket_'. Don't bake this into your action; it's for
-- the end-user.
defile :: PureX Any -> X ()
defile = void . windowBracket' getAny
-- | A version of @windowBracket@ specialised to take an @X ()@ action and
-- perform a refresh handling any changes it makes.
handlingRefresh :: X () -> X ()
handlingRefresh = windowBracket (\_ -> True)
-- }}}
-- --< Utility >-- {{{
-- | A 'when' that accepts a monoidal return value.
when' :: (Monad m, Monoid a) => Bool -> m a -> m a
when' b ma = if b then ma else return mempty
-- | A @whenX@/@whenM@ that accepts a monoidal return value.
whenM' :: (Monad m, Monoid a) => m Bool -> m a -> m a
whenM' mb m = when' <$> mb >>= ($ m)
-- | A 'whenJust' that accepts a monoidal return value.
whenJust' :: (Monad m, Monoid b) => Maybe a -> (a -> m b) -> m b
whenJust' = flip $ maybe (return mempty)
-- | Akin to @<*@. Discarding the wrapped value in the second argument either
-- way, keep its effects iff the first argument returns @Any True@.
(<?) :: Monad m => m Any -> m a -> m Any
ifthis <? thenthis = do
Any b <- ifthis
when' b (Any b <$ thenthis)
infixl 4 <?
-- | Akin to a low precedence @<>@. Combines applicative effects left-to-right
-- and wrapped @Bool@s with @&&@ (instead of @||@).
(&>) :: Applicative f => f Any -> f Any -> f Any
(&>) = liftA2 $ \(Any b1) (Any b2) -> Any (b1 && b2)
infixl 1 &>
-- | A generalisation of 'withWindowSet'.
withWindowSet' :: XLike m => (WindowSet -> m a) -> m a
withWindowSet' = (=<< gets windowset)
-- | If there is a current tag and a focused window, perform an operation with
-- them, otherwise return mempty.
withFocii :: (XLike m, Monoid a) => (WorkspaceId -> Window -> m a) -> m a
withFocii f = join $ (whenJust' <$> peek) <*> (f <$> curTag)
-- | A generalisation of 'modifyWindowSet'.
modifyWindowSet' :: XLike m => (WindowSet -> WindowSet) -> m ()
modifyWindowSet' f = modify $ \xs -> xs { windowset = f (windowset xs) }
-- | A variant of @W.modify@ and @W.modify'@ handling the @Nothing@ and @Just@
-- cases uniformly.
modify''
:: (Maybe (W.Stack a) -> Maybe (W.Stack a))
-> (W.StackSet i l a s sd -> W.StackSet i l a s sd)
modify'' f = W.modify (f Nothing) (f . Just)
-- | Get the stack from the current workspace.
getStack :: XLike m => m (Maybe (W.Stack Window))
getStack = W.stack <$> curWorkspace
-- | Set the stack on the current workspace.
putStack :: XLike m => Maybe (W.Stack Window) -> m ()
putStack mst = modifyWindowSet' . modify'' $ \_ -> mst
-- | Get the focused window if there is one.
peek :: XLike m => m (Maybe Window)
peek = withWindowSet' (return . W.peek)
-- | Get the current screen.
curScreen
:: XLike m
=> m (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
curScreen = withWindowSet' (return . W.current)
-- | Get the current workspace.
curWorkspace :: XLike m => m WindowSpace
curWorkspace = W.workspace <$> curScreen
-- | Get the current tag.
curTag :: XLike m => m WorkspaceId
curTag = W.tag <$> curWorkspace
-- | Get the current @ScreenId@.
curScreenId :: XLike m => m ScreenId
curScreenId = W.screen <$> curScreen
-- | Internal. Refresh-tracking logic of view operations.
viewWith
:: XLike m => (WorkspaceId -> WindowSet -> WindowSet) -> WorkspaceId -> m Any
viewWith viewer tag = do
itag <- curTag
when' (tag /= itag) $ do
modifyWindowSet' (viewer tag)
Any . (tag ==) <$> curTag
-- | A version of @W.view@ that tracks the need to refresh.
view :: XLike m => WorkspaceId -> m Any
view = viewWith W.view
-- | A version of @W.greedyView@ that tracks the need to refresh.
greedyView :: XLike m => WorkspaceId -> m Any
greedyView = viewWith W.greedyView
-- | View a workspace if it's not visible. An alternative to @view@ and
-- @greedyView@ that—rather than changing the current screen or affecting
-- another—opts not to act.
invisiView :: XLike m => WorkspaceId -> m Any
invisiView = viewWith $ \tag ws ->
if tag `elem` (W.tag . W.workspace <$> W.current ws : W.visible ws)
then W.view tag ws
else ws
-- | A refresh-tracking version of @W.Shift@.
shift :: XLike m => WorkspaceId -> m Any
shift tag = withFocii $ \ctag fw ->
when' (tag /= ctag) $ do
modifyWindowSet' (W.shiftWin tag fw)
mfw' <- peek
return (Any $ Just fw /= mfw')
-- }}}

214
XMonad/Util/Rectangle.hs Normal file
View File

@ -0,0 +1,214 @@
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Util.Rectangle
-- Copyright : (c) 2018 Yclept Nemo
-- License : BSD-style (see LICENSE)
--
-- Maintainer :
-- Stability : unstable
-- Portability : unportable
--
-- A module for handling pixel rectangles: 'Rectangle'.
--
-----------------------------------------------------------------------------
module XMonad.Util.Rectangle
( -- * Usage
-- $usage
PointRectangle (..)
, pixelsToIndices, pixelsToCoordinates
, indicesToRectangle, coordinatesToRectangle
, empty
, intersects
, supersetOf
, difference
, withBorder
, center
, toRatio
) where
import XMonad
import qualified XMonad.StackSet as W
import Data.Ratio
-- $usage
-- > import XMonad.Util.Rectangle as R
-- > R.empty (Rectangle 0 0 1024 768)
-- | Rectangle as two points. What those points mean depends on the conversion
-- function.
data PointRectangle a = PointRectangle
{ point_x1::a -- ^ Point nearest to the origin.
, point_y1::a
, point_x2::a -- ^ Point furthest from the origin.
, point_y2::a
} deriving (Eq,Read,Show)
-- | There are three possible ways to convert rectangles to pixels:
--
-- * Consider integers as "gaps" between pixels; pixels range from @(N,N+1)@,
-- exclusively: @(0,1)@, @(1,2)@, and so on. This leads to interval ambiguity:
-- whether an integer endpoint contains a pixel depends on which direction the
-- interval approaches the pixel. Consider the adjacent pixels @(0,1)@ and
-- @(1,2)@ where @1@ can refer to either pixel @(0,1)@ or pixel @(1,2)@.
--
-- * Consider integers to demarcate the start of each pixel; pixels range from
-- @[N,N+1)@: @[0,1)@, @[1,2)@, and so on - or equivalently: @(N,N+1]@. This is
-- the most flexible coordinate system, and the convention used by the
-- 'Rectangle' type.
--
-- * Consider integers to demarcate the center of each pixel; pixels range from
-- @[N,N+1]@, as though each real-valued coordinate had been rounded (either
-- down or up) to the nearest integers. So each pixel, from zero, is listed as:
-- @[0,0]@, @[1,1]@, @[2,2]@, and so on. Rather than a coordinate system, this
-- considers pixels as row/colum indices. While easiest to reason with,
-- indices are unable to represent zero-dimension rectangles.
--
-- Consider pixels as indices. Do not use this on empty rectangles.
pixelsToIndices :: Rectangle -> (PointRectangle Integer)
pixelsToIndices (Rectangle px py dx dy) =
PointRectangle (fromIntegral px)
(fromIntegral py)
(fromIntegral px + fromIntegral dx - 1)
(fromIntegral py + fromIntegral dy - 1)
-- | Consider pixels as @[N,N+1)@ coordinates. Available for empty rectangles.
pixelsToCoordinates :: Rectangle -> (PointRectangle Integer)
pixelsToCoordinates (Rectangle px py dx dy) =
PointRectangle (fromIntegral px)
(fromIntegral py)
(fromIntegral px + fromIntegral dx)
(fromIntegral py + fromIntegral dy)
-- | Invert 'pixelsToIndices'.
indicesToRectangle :: (PointRectangle Integer) -> Rectangle
indicesToRectangle (PointRectangle x1 y1 x2 y2) =
Rectangle (fromIntegral x1)
(fromIntegral y1)
(fromIntegral $ x2 - x1 + 1)
(fromIntegral $ y2 - y1 + 1)
-- | Invert 'pixelsToCoordinates'.
coordinatesToRectangle :: (PointRectangle Integer) -> Rectangle
coordinatesToRectangle (PointRectangle x1 y1 x2 y2) =
Rectangle (fromIntegral x1)
(fromIntegral y1)
(fromIntegral $ x2 - x1)
(fromIntegral $ y2 - y1)
-- | True if either the 'rect_width' or 'rect_height' fields are zero, i.e. the
-- rectangle has no area.
empty :: Rectangle -> Bool
empty (Rectangle _ _ _ 0) = True
empty (Rectangle _ _ 0 _) = True
empty (Rectangle _ _ _ _) = False
-- | True if the intersection of the set of points comprising each rectangle is
-- not the empty set. Therefore any rectangle containing the initial points of
-- an empty rectangle will never intersect that rectangle - including the same
-- empty rectangle.
intersects :: Rectangle -> Rectangle -> Bool
intersects r1 r2 | empty r1 || empty r2 = False
| otherwise = r1_x1 < r2_x2
&& r1_x2 > r2_x1
&& r1_y1 < r2_y2
&& r1_y2 > r2_y1
where PointRectangle r1_x1 r1_y1 r1_x2 r1_y2 = pixelsToCoordinates r1
PointRectangle r2_x1 r2_y1 r2_x2 r2_y2 = pixelsToCoordinates r2
-- | True if the first rectangle contains at least all the points of the second
-- rectangle. Any rectangle containing the initial points of an empty rectangle
-- will be a superset of that rectangle - including the same empty rectangle.
supersetOf :: Rectangle -> Rectangle -> Bool
supersetOf r1 r2 = r1_x1 <= r2_x1
&& r1_y1 <= r2_y1
&& r1_x2 >= r2_x2
&& r1_y2 >= r2_y2
where PointRectangle r1_x1 r1_y1 r1_x2 r1_y2 = pixelsToCoordinates r1
PointRectangle r2_x1 r2_y1 r2_x2 r2_y2 = pixelsToCoordinates r2
-- | Return the smallest set of rectangles resulting from removing all the
-- points of the second rectangle from those of the first, i.e. @r1 - r2@, such
-- that @0 <= l <= 4@ where @l@ is the length of the resulting list.
difference :: Rectangle -> Rectangle -> [Rectangle]
difference r1 r2 | r1 `intersects` r2 = map coordinatesToRectangle $
concat [rt,rr,rb,rl]
| otherwise = [r1]
where PointRectangle r1_x1 r1_y1 r1_x2 r1_y2 = pixelsToCoordinates r1
PointRectangle r2_x1 r2_y1 r2_x2 r2_y2 = pixelsToCoordinates r2
-- top - assuming (0,0) is top-left
rt = if r2_y1 > r1_y1 && r2_y1 < r1_y2
then [PointRectangle (max r2_x1 r1_x1) r1_y1 r1_x2 r2_y1]
else []
-- right
rr = if r2_x2 > r1_x1 && r2_x2 < r1_x2
then [PointRectangle r2_x2 (max r2_y1 r1_y1) r1_x2 r1_y2]
else []
-- bottom
rb = if r2_y2 > r1_y1 && r2_y2 < r1_y2
then [PointRectangle r1_x1 r2_y2 (min r2_x2 r1_x2) r1_y2]
else []
-- left
rl = if r2_x1 > r1_x1 && r2_x1 < r1_x2
then [PointRectangle r1_x1 r1_y1 r2_x1 (min r2_y2 r1_y2)]
else []
-- | Fit a 'Rectangle' within the given borders of itself. Given insufficient
-- space, borders are minimized while preserving the ratio of opposite borders.
-- Origin is top-left, and yes, negative borders are allowed.
withBorder :: Integer -- ^ Top border.
-> Integer -- ^ Bottom border.
-> Integer -- ^ Right border.
-> Integer -- ^ Left border.
-> Integer -- ^ Smallest allowable rectangle dimensions, i.e.
-- width/height, with values @<0@ defaulting to @0@.
-> Rectangle -> Rectangle
withBorder t b r l i (Rectangle x y w h) =
let -- conversions
w' = fromIntegral w
h' = fromIntegral h
-- minimum window dimensions
i' = max i 0
iw = min i' w'
ih = min i' h'
-- maximum border dimensions
bh = w' - iw
bv = h' - ih
-- scaled border ratios
rh = if l + r <= 0
then 1
else min 1 $ bh % (l + r)
rv = if t + b <= 0
then 1
else min 1 $ bv % (t + b)
-- scaled border pixels
t' = truncate $ rv * fromIntegral t
b' = truncate $ rv * fromIntegral b
r' = truncate $ rh * fromIntegral r
l' = truncate $ rh * fromIntegral l
in Rectangle (x + l')
(y + t')
(w - r' - fromIntegral l')
(h - b' - fromIntegral t')
-- | Calculate the center - @(x,y)@ - as if the 'Rectangle' were bounded.
center :: Rectangle -> (Ratio Integer,Ratio Integer)
center (Rectangle x y w h) = (cx,cy)
where cx = fromIntegral x + (fromIntegral w) % 2
cy = fromIntegral y + (fromIntegral h) % 2
-- | Invert 'scaleRationalRect'. Since that operation is lossy a roundtrip
-- conversion may not result in the original value. The first 'Rectangle' is
-- scaled to the second:
--
-- >>> (Rectangle 2 2 6 6) `toRatio` (Rectangle 0 0 10 10)
-- RationalRect (1 % 5) (1 % 5) (3 % 5) (3 % 5)
toRatio :: Rectangle -> Rectangle -> W.RationalRect
toRatio (Rectangle x1 y1 w1 h1) (Rectangle x2 y2 w2 h2) =
let [x1n,y1n,x2n,y2n] = map fromIntegral [x1,y1,x2,y2]
[w1n,h1n,w2n,h2n] = map fromIntegral [w1,h1,w2,h2]
in W.RationalRect ((x1n-x2n)/w2n) ((y1n-y2n)/h2n) (w1n/w2n) (h1n/h2n)

64
XMonad/Util/SessionStart.hs Normal file
View File

@ -0,0 +1,64 @@
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Util.SessionStart
-- Copyright : (c) Markus Ongyerth 2017
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : markus@ongy.net
-- Stability : unstable
-- Portability : not portable
--
-- A module for detectiong session startup. Useful to start
-- status bars, compositors and session initialization.
-- This is a more general approach than spawnOnce and allows spawnOn etc.
-----------------------------------------------------------------------------
module XMonad.Util.SessionStart
( doOnce
, isSessionStart
, setSessionStarted
)
where
import Control.Monad (when)
import Control.Applicative ((<$>))
import XMonad
import qualified XMonad.Util.ExtensibleState as XS
-- ---------------------------------------------------------------------
-- $usage
--
-- Add 'setSessionStarted' at the end of the 'startupHook' to set the
-- flag.
--
-- To do something only when the session is started up, use
-- 'isSessionStart' to query or wrap it in 'doOnce' to only do it when
-- the flag isn't set.
-- ---------------------------------------------------------------------
data SessionStart = SessionStart { unSessionStart :: Bool }
deriving (Read, Show, Typeable)
instance ExtensionClass SessionStart where
initialValue = SessionStart True
extensionType = PersistentExtension
-- | Use this to only do a part of your hook on session start
doOnce :: X () -> X ()
doOnce act = do
startup <- isSessionStart
when startup act
-- | Query if the current startup is the session start
isSessionStart :: X Bool
isSessionStart = unSessionStart <$> XS.get
-- This should become a noop/be deprecated when merged into master, and
-- the flag should be set when the state file is loaded.
-- | This currently has to be added to the end of the startup hook to
-- set the flag.
setSessionStarted :: X ()
setSessionStarted = XS.put $ SessionStart False

37
XMonad/Util/SpawnOnce.hs
View File

@ -15,9 +15,10 @@
--
-----------------------------------------------------------------------------
module XMonad.Util.SpawnOnce (spawnOnce) where
module XMonad.Util.SpawnOnce (spawnOnce, spawnOnOnce, spawnNOnOnce, spawnAndDoOnce) where
import XMonad
import XMonad.Actions.SpawnOn
import Data.Set as Set
import qualified XMonad.Util.ExtensibleState as XS
import Control.Monad
@ -29,11 +30,31 @@ instance ExtensionClass SpawnOnce where
initialValue = SpawnOnce Set.empty
extensionType = PersistentExtension
-- | The first time 'spawnOnce' is executed on a particular command, that
-- command is executed. Subsequent invocations for a command do nothing.
spawnOnce :: String -> X ()
spawnOnce xs = do
b <- XS.gets (Set.member xs . unspawnOnce)
doOnce :: (String -> X ()) -> String -> X ()
doOnce f s = do
b <- XS.gets (Set.member s . unspawnOnce)
when (not b) $ do
spawn xs
XS.modify (SpawnOnce . Set.insert xs . unspawnOnce)
f s
XS.modify (SpawnOnce . Set.insert s . unspawnOnce)
-- | The first time 'spawnOnce' is executed on a particular command,
-- that command is executed. Subsequent invocations for a command do
-- nothing.
spawnOnce :: String -> X ()
spawnOnce cmd = doOnce spawn cmd
-- | Like spawnOnce but launches the application on the given workspace.
spawnOnOnce :: WorkspaceId -> String -> X ()
spawnOnOnce ws cmd = doOnce (spawnOn ws) cmd
-- | Lanch the given application n times on the specified
-- workspace. Subsequent attempts to spawn this application will be
-- ignored.
spawnNOnOnce :: Int -> WorkspaceId -> String -> X ()
spawnNOnOnce n ws cmd = doOnce (\c -> sequence_ $ replicate n $ spawnOn ws c) cmd
-- | Spawn the application once and apply the manage hook. Subsequent
-- attempts to spawn this application will be ignored.
spawnAndDoOnce :: ManageHook -> String -> X ()
spawnAndDoOnce mh cmd = doOnce (spawnAndDo mh) cmd

31
XMonad/Util/Stack.hs
View File

@ -38,6 +38,8 @@ module XMonad.Util.Stack ( -- * Usage
, focusUpZ
, focusDownZ
, focusMasterZ
, findS
, findZ
-- ** Extraction
, getFocusZ
, getIZ
@ -73,10 +75,13 @@ module XMonad.Util.Stack ( -- * Usage
, mapE_
, mapEM
, mapEM_
, reverseS
, reverseZ
) where
import qualified XMonad.StackSet as W
import Control.Monad (liftM)
import Control.Applicative ((<|>),(<$>),(<$))
import Control.Monad (guard,liftM)
import Data.List (sortBy)
@ -175,6 +180,22 @@ focusMasterZ (Just (W.Stack f up down)) | not $ null up
= Just $ W.Stack (last up) [] (reverse (init up) ++ [f] ++ down)
focusMasterZ (Just s) = Just s
-- | Refocus a @Stack a@ on an element satisfying the predicate, or fail to
-- @Nothing@.
findS :: Eq a => (a -> Bool) -> W.Stack a -> Maybe (W.Stack a)
findS p st = st <$ (guard . p . W.focus) st <|> findUp st <|> findDown st
where findDown = reverseZ . findUp . reverseS
findUp s | u:ups <- W.up s = (if p u then Just else findUp)
$ W.Stack u ups (W.focus s : W.down s)
| otherwise = Nothing
-- | Refocus a @Zipper a@ on an element satisfying the predicate, or fail to
-- @Nothing@. Never returns @Just Nothing@, so the second layer of @Maybe@ is
-- actually redundant.
findZ :: Eq a => (a -> Bool) -> Zipper a -> Maybe (Zipper a)
findZ _ Nothing = Nothing
findZ p (Just st) = Just <$> findS p st
-- ** Extraction
-- | Get the focused element
@ -338,3 +359,11 @@ fromE (Left a) = a
-- | Tag the element with 'Right' if the property is true, 'Left' otherwise
tagBy :: (a -> Bool) -> a -> Either a a
tagBy p a = if p a then Right a else Left a
-- | Reverse a @Stack a@; O(1).
reverseS :: W.Stack a -> W.Stack a
reverseS (W.Stack foc ups downs) = W.Stack foc downs ups
-- | Reverse a @Zipper a@; O(1).
reverseZ :: Zipper a -> Zipper a
reverseZ = (reverseS <$>)

18
XMonad/Util/Themes.hs
View File

@ -20,6 +20,7 @@ module XMonad.Util.Themes
, xmonadTheme
, smallClean
, robertTheme
, darkTheme
, deiflTheme
, oxymor00nTheme
, donaldTheme
@ -90,6 +91,7 @@ ppThemeInfo t = themeName t <> themeDescription t <> "by" <> themeAuthor t
listOfThemes :: [ThemeInfo]
listOfThemes = [ xmonadTheme
, smallClean
, darkTheme
, deiflTheme
, oxymor00nTheme
, robertTheme
@ -163,6 +165,22 @@ robertTheme =
}
}
-- | Dark Theme, by Lucian Poston.
darkTheme :: ThemeInfo
darkTheme =
newTheme { themeName = "darkTheme"
, themeAuthor = "Lucian Poston"
, themeDescription = "Dark Theme"
, theme = def { inactiveBorderColor = "#202030"
, activeBorderColor = "#a0a0d0"
, inactiveColor = "#000000"
, activeColor = "#000000"
, inactiveTextColor = "#607070"
, activeTextColor = "#a0d0d0"
, decoHeight = 15
}
}
-- | deifl\'s Theme, by deifl.
deiflTheme :: ThemeInfo
deiflTheme =

32
XMonad/Util/WorkspaceCompare.hs
View File

@ -25,10 +25,10 @@ module XMonad.Util.WorkspaceCompare ( WorkspaceCompare, WorkspaceSort
import XMonad
import qualified XMonad.StackSet as S
import Data.List
import Data.Monoid
import Data.Ord
import Data.Maybe
import Data.Function
import Data.Monoid (mconcat)
import XMonad.Actions.PhysicalScreens (ScreenComparator(ScreenComparator), getScreenIdAndRectangle, screenComparatorById)
import Data.Function (on)
type WorkspaceCompare = WorkspaceId -> WorkspaceId -> Ordering
type WorkspaceSort = [WindowSpace] -> [WindowSpace]
@ -64,28 +64,22 @@ getWsCompareByTag = return compare
-- and screen id. It produces the same ordering as
-- 'XMonad.Hooks.DynamicLog.pprWindowSetXinerama'.
getXineramaWsCompare :: X WorkspaceCompare
getXineramaWsCompare = getXineramaWsCompare' False
getXineramaWsCompare = getXineramaPhysicalWsCompare $ screenComparatorById compare
-- | A comparison function like 'getXineramaWsCompare', but uses physical locations for screens.
getXineramaPhysicalWsCompare :: X WorkspaceCompare
getXineramaPhysicalWsCompare = getXineramaWsCompare' True
getXineramaWsCompare' :: Bool -> X WorkspaceCompare
getXineramaWsCompare' phy = do
getXineramaPhysicalWsCompare :: ScreenComparator -> X WorkspaceCompare
getXineramaPhysicalWsCompare (ScreenComparator sc) = do
w <- gets windowset
return $ \ a b -> case (isOnScreen a w, isOnScreen b w) of
(True, True) -> cmpPosition phy w a b
(True, True) -> compareUsingScreen w a b
(False, False) -> compare a b
(True, False) -> LT
(False, True) -> GT
where
onScreen w = S.current w : S.visible w
isOnScreen a w = a `elem` map (S.tag . S.workspace) (onScreen w)
tagToSid s x = S.screen $ fromJust $ find ((== x) . S.tag . S.workspace) s
cmpPosition False w a b = comparing (tagToSid $ onScreen w) a b
cmpPosition True w a b = comparing (rect.(tagToSid $ onScreen w)) a b
where rect i = let (Rectangle x y _ _) = screens !! fromIntegral i in (y,x)
screens = map (screenRect . S.screenDetail) $ sortBy (comparing S.screen) $ S.current w : S.visible w
tagToScreen s x = fromJust $ find ((== x) . S.tag . S.workspace) s
compareUsingScreen w = sc `on` getScreenIdAndRectangle . tagToScreen (onScreen w)
-- | Create a workspace sorting function from a workspace comparison
-- function.
@ -109,8 +103,6 @@ getSortByTag = mkWsSort getWsCompareByTag
-- sorted by tag.
getSortByXineramaRule :: X WorkspaceSort
getSortByXineramaRule = mkWsSort getXineramaWsCompare
-- | Like 'getSortByXineramaRule', but uses physical locations for screens.
getSortByXineramaPhysicalRule :: X WorkspaceSort
getSortByXineramaPhysicalRule = mkWsSort getXineramaPhysicalWsCompare
-- | Like 'getSortByXineramaRule', but allow you to use physical locations for screens.
getSortByXineramaPhysicalRule :: ScreenComparator -> X WorkspaceSort
getSortByXineramaPhysicalRule sc = mkWsSort $ getXineramaPhysicalWsCompare sc

23
xmonad-contrib.cabal
View File

@ -1,5 +1,5 @@
name: xmonad-contrib
version: 0.13
version: 0.15
homepage: http://xmonad.org/
synopsis: Third party extensions for xmonad
description:
@ -36,7 +36,7 @@ cabal-version: >= 1.6
build-type: Simple
bug-reports: https://github.com/xmonad/xmonad-contrib/issues
tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.1
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.1, GHC==8.2.2, GHC==8.4.3, GHC==8.6.1
source-repository head
type: git
@ -54,7 +54,7 @@ flag testing
library
build-depends: base >= 4.5 && < 5,
bytestring >= 0.10 && < 0.11,
containers >= 0.5 && < 0.6,
containers >= 0.5 && < 0.7,
directory,
extensible-exceptions,
filepath,
@ -64,9 +64,10 @@ library
random,
mtl >= 1 && < 3,
unix,
X11>=1.6.1 && < 1.9,
xmonad>=0.13 && < 0.14,
utf8-string
X11>=1.6.1 && < 1.10,
xmonad >= 0.15 && < 0.16,
utf8-string,
semigroups
if flag(use_xft)
build-depends: X11-xft >= 0.2
@ -128,6 +129,7 @@ library
XMonad.Actions.SpawnOn
XMonad.Actions.Submap
XMonad.Actions.SwapWorkspaces
XMonad.Actions.SwapPromote
XMonad.Actions.TagWindows
XMonad.Actions.TopicSpace
XMonad.Actions.TreeSelect
@ -193,6 +195,7 @@ library
XMonad.Layout.Accordion
XMonad.Layout.AutoMaster
XMonad.Layout.AvoidFloats
XMonad.Layout.BinaryColumn
XMonad.Layout.BinarySpacePartition
XMonad.Layout.BorderResize
XMonad.Layout.BoringWindows
@ -207,6 +210,7 @@ library
XMonad.Layout.DecorationAddons
XMonad.Layout.DecorationMadness
XMonad.Layout.Dishes
XMonad.Layout.MultiDishes
XMonad.Layout.DragPane
XMonad.Layout.DraggingVisualizer
XMonad.Layout.Drawer
@ -248,6 +252,7 @@ library
XMonad.Layout.MultiColumns
XMonad.Layout.MultiToggle
XMonad.Layout.MultiToggle.Instances
XMonad.Layout.MultiToggle.TabBarDecoration
XMonad.Layout.Named
XMonad.Layout.NoBorders
XMonad.Layout.NoFrillsDecoration
@ -271,6 +276,7 @@ library
XMonad.Layout.Spiral
XMonad.Layout.Square
XMonad.Layout.StackTile
XMonad.Layout.StateFull
XMonad.Layout.Stoppable
XMonad.Layout.SubLayouts
XMonad.Layout.TabBarDecoration
@ -279,6 +285,7 @@ library
XMonad.Layout.ToggleLayouts
XMonad.Layout.TrackFloating
XMonad.Layout.TwoPane
XMonad.Layout.TwoPanePersistent
XMonad.Layout.WindowArranger
XMonad.Layout.WindowNavigation
XMonad.Layout.WindowSwitcherDecoration
@ -291,6 +298,7 @@ library
XMonad.Prompt.DirExec
XMonad.Prompt.Directory
XMonad.Prompt.Email
XMonad.Prompt.FuzzyMatch
XMonad.Prompt.Input
XMonad.Prompt.Layout
XMonad.Prompt.Man
@ -323,11 +331,14 @@ library
XMonad.Util.NoTaskbar
XMonad.Util.Paste
XMonad.Util.PositionStore
XMonad.Util.PureX
XMonad.Util.Rectangle
XMonad.Util.RemoteWindows
XMonad.Util.Replace
XMonad.Util.Run
XMonad.Util.Scratchpad
XMonad.Util.SpawnNamedPipe
XMonad.Util.SessionStart
XMonad.Util.SpawnOnce
XMonad.Util.Stack
XMonad.Util.StringProp