diff --git a/.travis.yml b/.travis.yml index be835ac5..fda79e6f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -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: diff --git a/CHANGES.md b/CHANGES.md index 4ff73493..b9df3753 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -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 \ and \ 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 diff --git a/README.md b/README.md index 2cfa4e03..e11e675d 100644 --- a/README.md +++ b/README.md @@ -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: (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 diff --git a/XMonad/Actions/Commands.hs b/XMonad/Actions/Commands.hs index 100aab74..241fa16b 100644 --- a/XMonad/Actions/Commands.hs +++ b/XMonad/Actions/Commands.hs @@ -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 diff --git a/XMonad/Actions/DynamicProjects.hs b/XMonad/Actions/DynamicProjects.hs index c0b082b0..d78d65e4 100644 --- a/XMonad/Actions/DynamicProjects.hs +++ b/XMonad/Actions/DynamicProjects.hs @@ -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 }) -------------------------------------------------------------------------------- diff --git a/XMonad/Actions/DynamicWorkspaceOrder.hs b/XMonad/Actions/DynamicWorkspaceOrder.hs index b7142d87..f1755cca 100644 --- a/XMonad/Actions/DynamicWorkspaceOrder.hs +++ b/XMonad/Actions/DynamicWorkspaceOrder.hs @@ -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 () \ No newline at end of file +withNthWorkspace = withNthWorkspace' id diff --git a/XMonad/Actions/GroupNavigation.hs b/XMonad/Actions/GroupNavigation.hs index 408a5cd7..63acc990 100644 --- a/XMonad/Actions/GroupNavigation.hs +++ b/XMonad/Actions/GroupNavigation.hs @@ -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 + diff --git a/XMonad/Actions/MessageFeedback.hs b/XMonad/Actions/MessageFeedback.hs index 1928d33f..1717f57c 100644 --- a/XMonad/Actions/MessageFeedback.hs +++ b/XMonad/Actions/MessageFeedback.hs @@ -1,7 +1,8 @@ ----------------------------------------------------------------------------- -- | -- Module : XMonad.Actions.MessageFeedback --- Copyright : (c) Quentin Moser +-- Copyright : (c) -- Quentin Moser +-- 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 () \ No newline at end of file +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 diff --git a/XMonad/Actions/Minimize.hs b/XMonad/Actions/Minimize.hs index 6331aaf2..5a1ea389 100644 --- a/XMonad/Actions/Minimize.hs +++ b/XMonad/Actions/Minimize.hs @@ -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 () diff --git a/XMonad/Actions/Navigation2D.hs b/XMonad/Actions/Navigation2D.hs index fa2646a7..b354507c 100644 --- a/XMonad/Actions/Navigation2D.hs +++ b/XMonad/Actions/Navigation2D.hs @@ -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 diff --git a/XMonad/Actions/PhysicalScreens.hs b/XMonad/Actions/PhysicalScreens.hs index fe895663..ce54d132 100644 --- a/XMonad/Actions/PhysicalScreens.hs +++ b/XMonad/Actions/PhysicalScreens.hs @@ -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) diff --git a/XMonad/Actions/SwapPromote.hs b/XMonad/Actions/SwapPromote.hs new file mode 100644 index 00000000..e8fc41aa --- /dev/null +++ b/XMonad/Actions/SwapPromote.hs @@ -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) diff --git a/XMonad/Config/Azerty.hs b/XMonad/Config/Azerty.hs index af15e332..1bbfe195 100644 --- a/XMonad/Config/Azerty.hs +++ b/XMonad/Config/Azerty.hs @@ -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 diff --git a/XMonad/Config/Gnome.hs b/XMonad/Config/Gnome.hs index aa506e1e..a255145a 100644 --- a/XMonad/Config/Gnome.hs +++ b/XMonad/Config/Gnome.hs @@ -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. diff --git a/XMonad/Config/Saegesser.hs b/XMonad/Config/Saegesser.hs new file mode 100755 index 00000000..d76622ee --- /dev/null +++ b/XMonad/Config/Saegesser.hs @@ -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 + diff --git a/XMonad/Hooks/DebugEvents.hs b/XMonad/Hooks/DebugEvents.hs index cec777c3..8292a2a4 100644 --- a/XMonad/Hooks/DebugEvents.hs +++ b/XMonad/Hooks/DebugEvents.hs @@ -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 diff --git a/XMonad/Hooks/DynamicLog.hs b/XMonad/Hooks/DynamicLog.hs index ba673d9e..ce0e4cf9 100644 --- a/XMonad/Hooks/DynamicLog.hs +++ b/XMonad/Hooks/DynamicLog.hs @@ -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 "" where t = concat [""] +-- | 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 = "" + r = "" + +-- | 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 [""] + -- ??? add an xmobarEscape function? -- | Strip xmobar markup, specifically the , and 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 = " " diff --git a/XMonad/Hooks/EwmhDesktops.hs b/XMonad/Hooks/EwmhDesktops.hs index 2508b7ed..97c2bd3f 100644 --- a/XMonad/Hooks/EwmhDesktops.hs +++ b/XMonad/Hooks/EwmhDesktops.hs @@ -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" diff --git a/XMonad/Hooks/FadeWindows.hs b/XMonad/Hooks/FadeWindows.hs index 4b8e62b6..01d06792 100644 --- a/XMonad/Hooks/FadeWindows.hs +++ b/XMonad/Hooks/FadeWindows.hs @@ -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 diff --git a/XMonad/Hooks/WallpaperSetter.hs b/XMonad/Hooks/WallpaperSetter.hs index 00a3b1c3..d4f5ccb2 100644 --- a/XMonad/Hooks/WallpaperSetter.hs +++ b/XMonad/Hooks/WallpaperSetter.hs @@ -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/) diff --git a/XMonad/Layout/BinaryColumn.hs b/XMonad/Layout/BinaryColumn.hs new file mode 100644 index 00000000..b0d85381 --- /dev/null +++ b/XMonad/Layout/BinaryColumn.hs @@ -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 +-- 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) diff --git a/XMonad/Layout/Fullscreen.hs b/XMonad/Layout/Fullscreen.hs index 779a1e99..4b8352af 100644 --- a/XMonad/Layout/Fullscreen.hs +++ b/XMonad/Layout/Fullscreen.hs @@ -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 diff --git a/XMonad/Layout/Gaps.hs b/XMonad/Layout/Gaps.hs index 86243b52..fc238747 100644 --- a/XMonad/Layout/Gaps.hs +++ b/XMonad/Layout/Gaps.hs @@ -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. diff --git a/XMonad/Layout/Grid.hs b/XMonad/Layout/Grid.hs index 845fa80e..769a6c63 100644 --- a/XMonad/Layout/Grid.hs +++ b/XMonad/Layout/Grid.hs @@ -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)] diff --git a/XMonad/Layout/Groups.hs b/XMonad/Layout/Groups.hs index 467971fa..d2aa9725 100644 --- a/XMonad/Layout/Groups.hs +++ b/XMonad/Layout/Groups.hs @@ -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 diff --git a/XMonad/Layout/Groups/Helpers.hs b/XMonad/Layout/Groups/Helpers.hs index baf42817..c77f1580 100644 --- a/XMonad/Layout/Groups/Helpers.hs +++ b/XMonad/Layout/Groups/Helpers.hs @@ -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 diff --git a/XMonad/Layout/LayoutHints.hs b/XMonad/Layout/LayoutHints.hs index 864cf6c4..a5258b13 100644 --- a/XMonad/Layout/LayoutHints.hs +++ b/XMonad/Layout/LayoutHints.hs @@ -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 _ _ [] = [] diff --git a/XMonad/Layout/Mosaic.hs b/XMonad/Layout/Mosaic.hs index 05655d4c..da44fc50 100644 --- a/XMonad/Layout/Mosaic.hs +++ b/XMonad/Layout/Mosaic.hs @@ -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 diff --git a/XMonad/Layout/MultiColumns.hs b/XMonad/Layout/MultiColumns.hs index bea4be35..3e9321d1 100644 --- a/XMonad/Layout/MultiColumns.hs +++ b/XMonad/Layout/MultiColumns.hs @@ -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 diff --git a/XMonad/Layout/MultiDishes.hs b/XMonad/Layout/MultiDishes.hs new file mode 100644 index 00000000..85348782 --- /dev/null +++ b/XMonad/Layout/MultiDishes.hs @@ -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 +-- 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 diff --git a/XMonad/Layout/MultiToggle.hs b/XMonad/Layout/MultiToggle.hs index 4bf1ba56..0d6081e4 100644 --- a/XMonad/Layout/MultiToggle.hs +++ b/XMonad/Layout/MultiToggle.hs @@ -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 diff --git a/XMonad/Layout/MultiToggle/TabBarDecoration.hs b/XMonad/Layout/MultiToggle/TabBarDecoration.hs new file mode 100644 index 00000000..867c5c30 --- /dev/null +++ b/XMonad/Layout/MultiToggle/TabBarDecoration.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.MultiToggle.TabBarDecoration +-- Copyright : (c) 2018 Lucian Poston +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : +-- 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') diff --git a/XMonad/Layout/NoBorders.hs b/XMonad/Layout/NoBorders.hs index 71b72fe2..0997ed69 100644 --- a/XMonad/Layout/NoBorders.hs +++ b/XMonad/Layout/NoBorders.hs @@ -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 +-- Copyright : (c) -- David Roundy +-- 2018 Yclept Nemo -- License : BSD3-style (see LICENSE) -- -- Maintainer : Spencer Janssen @@ -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 diff --git a/XMonad/Layout/Spacing.hs b/XMonad/Layout/Spacing.hs index f0b8f8d3..e4efdd10 100644 --- a/XMonad/Layout/Spacing.hs +++ b/XMonad/Layout/Spacing.hs @@ -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 : -- 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 diff --git a/XMonad/Layout/StateFull.hs b/XMonad/Layout/StateFull.hs new file mode 100644 index 00000000..ceacad1c --- /dev/null +++ b/XMonad/Layout/StateFull.hs @@ -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) diff --git a/XMonad/Layout/TwoPanePersistent.hs b/XMonad/Layout/TwoPanePersistent.hs new file mode 100644 index 00000000..0cadfc59 --- /dev/null +++ b/XMonad/Layout/TwoPanePersistent.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.TwoPanePersistent +-- Copyright : (c) Chayanon Wichitrnithed +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Chayanon Wichitrnithed +-- 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 diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs index 69eb6bf5..88fedfe9 100644 --- a/XMonad/Prompt.hs +++ b/XMonad/Prompt.hs @@ -4,7 +4,7 @@ -- | -- Module : XMonad.Prompt -- Copyright : (C) 2007 Andrea Rossato, 2015 Evgeny Kurnevsky --- 2015 Sibi Prabakaran +-- 2015 Sibi Prabakaran, 2018 Yclept Nemo -- License : BSD3 -- -- Maintainer : Spencer Janssen @@ -15,6 +15,17 @@ -- ----------------------------------------------------------------------------- +----------------------------------------------------------------------------- +-- Bugs: +-- if 'alwaysHighlight' is True, and +-- 1 type several characters +-- 2 tab-complete past several entries +-- 3 backspace back to the several characters +-- 4 tab-complete once (results in the entry past the one in [2]) +-- 5 tab-complete against this shorter list of completions +-- then the prompt will freeze (XMonad continues however). +----------------------------------------------------------------------------- + module XMonad.Prompt ( -- * Usage -- $usage @@ -27,18 +38,26 @@ module XMonad.Prompt , greenXPConfig , XPMode , XPType (..) + , XPColor (..) , XPPosition (..) , XPConfig (..) , XPrompt (..) , XP , defaultXPKeymap, defaultXPKeymap' , emacsLikeXPKeymap, emacsLikeXPKeymap' + , vimLikeXPKeymap, vimLikeXPKeymap' , quit + , promptSubmap, promptBuffer, toHeadChar, bufferOne , killBefore, killAfter, startOfLine, endOfLine - , pasteString, moveCursor - , setInput, getInput - , moveWord, moveWord', killWord, killWord', deleteString - , moveHistory, setSuccess, setDone + , insertString, pasteString, pasteString' + , clipCursor, moveCursor, moveCursorClip + , setInput, getInput, getOffset + , defaultColor, modifyColor, setColor + , resetColor, setBorderColor + , modifyPrompter, setPrompter, resetPrompter + , moveWord, moveWord', killWord, killWord' + , changeWord, deleteString + , moveHistory, setSuccess, setDone, setModeDone , Direction1D(..) , ComplFunction -- * X Utilities @@ -80,7 +99,7 @@ import XMonad.Util.XSelection (getSelection) import Codec.Binary.UTF8.String (decodeString,isUTF8Encoded) import Control.Applicative ((<$>)) -import Control.Arrow (first, (&&&), (***)) +import Control.Arrow (first, second, (&&&), (***)) import Control.Concurrent (threadDelay) import Control.Exception.Extensible as E hiding (handle) import Control.Monad.State @@ -92,6 +111,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Set (fromList, toList) import System.IO +import System.IO.Unsafe (unsafePerformIO) import System.Posix.Files -- $usage @@ -105,57 +125,75 @@ import System.Posix.Files type XP = StateT XPState IO data XPState = - XPS { dpy :: Display - , rootw :: !Window - , win :: !Window - , screen :: !Rectangle - , complWin :: Maybe Window - , complWinDim :: Maybe ComplWindowDim - , complIndex :: !(Int,Int) - , showComplWin :: Bool - , operationMode :: XPOperationMode - , highlightedCompl :: Maybe String - , gcon :: !GC - , fontS :: !XMonadFont - , commandHistory :: W.Stack String - , offset :: !Int - , config :: XPConfig - , successful :: Bool - , numlockMask :: KeyMask - , done :: Bool + XPS { dpy :: Display + , rootw :: !Window + , win :: !Window + , screen :: !Rectangle + , complWin :: Maybe Window + , complWinDim :: Maybe ComplWindowDim + , complIndex :: !(Int,Int) + -- | This IORef should always have the same value as + -- complWin. Its purpose is to enable removal of the + -- completion window if an exception occurs, since the most + -- recent value of complWin is not available when handling + -- exceptions. + , complWinRef :: IORef (Maybe Window) + , showComplWin :: Bool + , operationMode :: XPOperationMode + , highlightedCompl :: Maybe String + , gcon :: !GC + , fontS :: !XMonadFont + , commandHistory :: W.Stack String + , offset :: !Int + , config :: XPConfig + , successful :: Bool + , numlockMask :: KeyMask + , done :: Bool + , modeDone :: Bool + , color :: XPColor + , prompter :: String -> String + , eventBuffer :: [(KeySym, String, Event)] + , inputBuffer :: String + , currentCompletions :: Maybe [String] } data XPConfig = - XPC { font :: String -- ^ Font. For TrueType fonts, use something like - -- @"xft:Hack:pixelsize=1"@. Alternatively, use X Logical Font - -- Description, i.e. something like - -- @"-*-dejavu sans mono-medium-r-normal--*-80-*-*-*-*-iso10646-1"@. - , bgColor :: String -- ^ Background color - , fgColor :: String -- ^ Font color - , fgHLight :: String -- ^ Font color of a highlighted completion entry - , bgHLight :: String -- ^ Background color of a highlighted completion entry - , borderColor :: String -- ^ Border color - , promptBorderWidth :: !Dimension -- ^ Border width - , position :: XPPosition -- ^ Position: 'Top', 'Bottom', or 'CenteredAt' - , alwaysHighlight :: !Bool -- ^ Always highlight an item, overriden to True with multiple modes. This implies having *one* column of autocompletions only. - , height :: !Dimension -- ^ Window height - , maxComplRows :: Maybe Dimension - -- ^ Just x: maximum number of rows to show in completion window - , historySize :: !Int -- ^ The number of history entries to be saved - , historyFilter :: [String] -> [String] - -- ^ a filter to determine which - -- history entries to remember - , promptKeymap :: M.Map (KeyMask,KeySym) (XP ()) - -- ^ Mapping from key combinations to actions - , completionKey :: (KeyMask, KeySym) -- ^ Key that should trigger completion - , changeModeKey :: KeySym -- ^ Key to change mode (when the prompt has multiple modes) - , defaultText :: String -- ^ The text by default in the prompt line - , autoComplete :: Maybe Int -- ^ Just x: if only one completion remains, auto-select it, - -- and delay by x microseconds - , showCompletionOnTab :: Bool -- ^ Only show list of completions when Tab was pressed - , searchPredicate :: String -> String -> Bool - -- ^ Given the typed string and a possible - -- completion, is the completion valid? + XPC { font :: String -- ^ Font. For TrueType fonts, use something like + -- @"xft:Hack:pixelsize=1"@. Alternatively, use X Logical Font + -- Description, i.e. something like + -- @"-*-dejavu sans mono-medium-r-normal--*-80-*-*-*-*-iso10646-1"@. + , bgColor :: String -- ^ Background color + , fgColor :: String -- ^ Font color + , bgHLight :: String -- ^ Background color of a highlighted completion entry + , fgHLight :: String -- ^ Font color of a highlighted completion entry + , borderColor :: String -- ^ Border color + , promptBorderWidth :: !Dimension -- ^ Border width + , position :: XPPosition -- ^ Position: 'Top', 'Bottom', or 'CenteredAt' + , alwaysHighlight :: !Bool -- ^ Always highlight an item, overriden to True with multiple modes. This implies having *one* column of autocompletions only. + , height :: !Dimension -- ^ Window height + , maxComplRows :: Maybe Dimension + -- ^ Just x: maximum number of rows to show in completion window + , historySize :: !Int -- ^ The number of history entries to be saved + , historyFilter :: [String] -> [String] + -- ^ a filter to determine which + -- history entries to remember + , promptKeymap :: M.Map (KeyMask,KeySym) (XP ()) + -- ^ Mapping from key combinations to actions + , completionKey :: (KeyMask, KeySym) -- ^ Key that should trigger completion + , changeModeKey :: KeySym -- ^ Key to change mode (when the prompt has multiple modes) + , defaultText :: String -- ^ The text by default in the prompt line + , autoComplete :: Maybe Int -- ^ Just x: if only one completion remains, auto-select it, + -- and delay by x microseconds + , showCompletionOnTab :: Bool -- ^ Only show list of completions when Tab was pressed + , searchPredicate :: String -> String -> Bool + -- ^ Given the typed string and a possible + -- completion, is the completion valid? + , defaultPrompter :: String -> String + -- ^ Modifies the prompt given by 'showXPrompt' + , sorter :: String -> [String] -> [String] + -- ^ Used to sort the possible completions by how well they + -- match the search string (see X.P.FuzzyMatch for an + -- example). } data XPType = forall p . XPrompt p => XPT p @@ -244,59 +282,92 @@ data XPPosition = Top } deriving (Show,Read) +data XPColor = + XPColor { bgNormal :: String -- ^ Background color + , fgNormal :: String -- ^ Font color + , bgHighlight :: String -- ^ Background color of a highlighted completion entry + , fgHighlight :: String -- ^ Font color of a highlighted completion entry + , border :: String -- ^ Border color + } + amberXPConfig, defaultXPConfig, greenXPConfig :: XPConfig +instance Default XPColor where + def = + XPColor { bgNormal = "grey22" + , fgNormal = "grey80" + , bgHighlight = "grey" + , fgHighlight = "black" + , border = "white" + } + instance Default XPConfig where def = - XPC { font = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*" - , bgColor = "grey22" - , fgColor = "grey80" - , fgHLight = "black" - , bgHLight = "grey" - , borderColor = "white" - , promptBorderWidth = 1 - , promptKeymap = defaultXPKeymap - , completionKey = (0,xK_Tab) - , changeModeKey = xK_grave - , position = Bottom - , height = 18 - , maxComplRows = Nothing - , historySize = 256 - , historyFilter = id - , defaultText = [] - , autoComplete = Nothing - , showCompletionOnTab = False - , searchPredicate = isPrefixOf - , alwaysHighlight = False + XPC { font = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*" + , bgColor = bgNormal def + , fgColor = fgNormal def + , bgHLight = bgHighlight def + , fgHLight = fgHighlight def + , borderColor = border def + , promptBorderWidth = 1 + , promptKeymap = defaultXPKeymap + , completionKey = (0,xK_Tab) + , changeModeKey = xK_grave + , position = Bottom + , height = 18 + , maxComplRows = Nothing + , historySize = 256 + , historyFilter = id + , defaultText = [] + , autoComplete = Nothing + , showCompletionOnTab = False + , searchPredicate = isPrefixOf + , alwaysHighlight = False + , defaultPrompter = id + , sorter = const id } {-# DEPRECATED defaultXPConfig "Use def (from Data.Default, and re-exported from XMonad.Prompt) instead." #-} defaultXPConfig = def -greenXPConfig = def { fgColor = "green", bgColor = "black", promptBorderWidth = 0 } -amberXPConfig = def { fgColor = "#ca8f2d", bgColor = "black", fgHLight = "#eaaf4c" } +greenXPConfig = def { bgColor = "black" + , fgColor = "green" + , promptBorderWidth = 0 + } +amberXPConfig = def { bgColor = "black" + , fgColor = "#ca8f2d" + , fgHLight = "#eaaf4c" + } initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode -> GC -> XMonadFont -> [String] -> XPConfig -> KeyMask -> XPState initState d rw w s opMode gc fonts h c nm = - XPS { dpy = d - , rootw = rw - , win = w - , screen = s - , complWin = Nothing - , complWinDim = Nothing - , showComplWin = not (showCompletionOnTab c) - , operationMode = opMode - , highlightedCompl = Nothing - , gcon = gc - , fontS = fonts - , commandHistory = W.Stack { W.focus = defaultText c - , W.up = [] - , W.down = h } - , complIndex = (0,0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True - , offset = length (defaultText c) - , config = c - , successful = False - , done = False - , numlockMask = nm + XPS { dpy = d + , rootw = rw + , win = w + , screen = s + , complWin = Nothing + , complWinDim = Nothing + , complWinRef = unsafePerformIO (newIORef Nothing) + , showComplWin = not (showCompletionOnTab c) + , operationMode = opMode + , highlightedCompl = Nothing + , gcon = gc + , fontS = fonts + , commandHistory = W.Stack { W.focus = defaultText c + , W.up = [] + , W.down = h + } + , complIndex = (0,0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True + , offset = length (defaultText c) + , config = c + , successful = False + , done = False + , modeDone = False + , numlockMask = nm + , prompter = defaultPrompter c + , color = defaultColor c + , eventBuffer = [] + , inputBuffer = "" + , currentCompletions = Nothing } -- Returns the current XPType @@ -344,10 +415,62 @@ setInput :: String -> XP () setInput = modify . setCommand -- | Returns the current input string. Intented for use in custom keymaps --- where the 'get' or similar can't be used to retrieve it. +-- where 'get' or similar can't be used to retrieve it. getInput :: XP String getInput = gets command +-- | Returns the offset of the current input string. Intended for use in custom +-- keys where 'get' or similar can't be used to retrieve it. +getOffset :: XP Int +getOffset = gets offset + +-- | Accessor encapsulating disparate color fields of 'XPConfig' into an +-- 'XPColor' (the configuration provides default values). +defaultColor :: XPConfig -> XPColor +defaultColor c = XPColor { bgNormal = bgColor c + , fgNormal = fgColor c + , bgHighlight = bgHLight c + , fgHighlight = fgHLight c + , border = borderColor c + } + +-- | Modify the prompt colors. +modifyColor :: (XPColor -> XPColor) -> XP () +modifyColor c = modify $ \s -> s { color = c $ color s } + +-- | Set the prompt colors. +setColor :: XPColor -> XP () +setColor = modifyColor . const + +-- | Reset the prompt colors to those from 'XPConfig'. +resetColor :: XP () +resetColor = gets (defaultColor . config) >>= setColor + +-- | Set the prompt border color. +setBorderColor :: String -> XPColor -> XPColor +setBorderColor bc xpc = xpc { border = bc } + +-- | Modify the prompter, i.e. for chaining prompters. +modifyPrompter :: ((String -> String) -> (String -> String)) -> XP () +modifyPrompter p = modify $ \s -> s { prompter = p $ prompter s } + +-- | Set the prompter. +setPrompter :: (String -> String) -> XP () +setPrompter = modifyPrompter . const + +-- | Reset the prompter to the one from 'XPConfig'. +resetPrompter :: XP () +resetPrompter = gets (defaultPrompter . config) >>= setPrompter + +-- | Set the current completion list, or 'Nothing' to invalidate the current +-- completions. +setCurrentCompletions :: Maybe [String] -> XP () +setCurrentCompletions cs = modify $ \s -> s { currentCompletions = cs } + +-- | Get the current completion list. +getCurrentCompletions :: XP (Maybe [String]) +getCurrentCompletions = gets currentCompletions + -- | Same as 'mkXPrompt', except that the action function can have -- type @String -> X a@, for any @a@, and the final action returned -- by 'mkXPromptWithReturn' will have type @X (Maybe a)@. @Nothing@ @@ -356,40 +479,18 @@ getInput = gets command -- module. mkXPromptWithReturn :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X a) -> X (Maybe a) mkXPromptWithReturn t conf compl action = do - XConf { display = d, theRoot = rw } <- ask - s <- gets $ screenRect . W.screenDetail . W.current . windowset - hist <- io readHistory - w <- io $ createWin d rw conf s - io $ selectInput d w $ exposureMask .|. keyPressMask - gc <- io $ createGC d w - io $ setGraphicsExposures d gc False - fs <- initXMF (font conf) - numlock <- gets $ X.numberlockMask - let hs = fromMaybe [] $ M.lookup (showXPrompt t) hist - om = (XPSingleMode compl (XPT t)) --operation mode - st = initState d rw w s om gc fs hs conf numlock - st' <- io $ execStateT runXP st - - releaseXMF fs - io $ freeGC d gc - if successful st' then do - let - prune = take (historySize conf) - - io $ writeHistory $ M.insertWith - (\xs ys -> prune . historyFilter conf $ xs ++ ys) - (showXPrompt t) - (prune $ historyFilter conf [command st']) - hist - -- we need to apply historyFilter before as well, since - -- otherwise the filter would not be applied if - -- there is no history - --When alwaysHighlight is True, autocompletion is handled with indexes. - --When it is false, it is handled depending on the prompt buffer's value - let selectedCompletion = case alwaysHighlight (config st') of - False -> command st' - True -> fromMaybe (command st') $ highlightedCompl st' - Just <$> action selectedCompletion + st' <- mkXPromptImplementation (showXPrompt t) conf (XPSingleMode compl (XPT t)) + if successful st' + then do + let selectedCompletion = + case alwaysHighlight (config st') of + -- When alwaysHighlight is True, autocompletion is + -- handled with indexes. + False -> command st' + -- When it is false, it is handled depending on the + -- prompt buffer's value. + True -> fromMaybe (command st') $ highlightedCompl st' + Just <$> action selectedCompletion else return Nothing -- | Creates a prompt given: @@ -417,75 +518,58 @@ mkXPrompt t conf compl action = mkXPromptWithReturn t conf compl action >> retur -- that means that this prompt overrides the value `alwaysHighlight` for its configuration to True. mkXPromptWithModes :: [XPType] -> XPConfig -> X () mkXPromptWithModes modes conf = do + let defaultMode = head modes + modeStack = W.Stack { W.focus = defaultMode -- Current mode + , W.up = [] + , W.down = tail modes -- Other modes + } + om = XPMultipleModes modeStack + st' <- mkXPromptImplementation (showXPrompt defaultMode) conf { alwaysHighlight = True } om + if successful st' + then do + case operationMode st' of + XPMultipleModes ms -> let + action = modeAction $ W.focus ms + in action (command st') $ (fromMaybe "" $ highlightedCompl st') + _ -> error "The impossible occurred: This prompt runs with multiple modes but they could not be found." --we are creating a prompt with multiple modes, so its operationMode should have been constructed with XPMultipleMode + else return () + +-- Internal function used to implement 'mkXPromptWithReturn' and +-- 'mkXPromptWithModes'. +mkXPromptImplementation :: String -> XPConfig -> XPOperationMode -> X XPState +mkXPromptImplementation historyKey conf om = do XConf { display = d, theRoot = rw } <- ask - s <- gets $ screenRect . W.screenDetail . W.current . windowset + s <- gets $ screenRect . W.screenDetail . W.current . windowset + numlock <- gets X.numberlockMask hist <- io readHistory - w <- io $ createWin d rw conf s - io $ selectInput d w $ exposureMask .|. keyPressMask - gc <- io $ createGC d w - io $ setGraphicsExposures d gc False fs <- initXMF (font conf) - numlock <- gets $ X.numberlockMask - let - defaultMode = head modes - hs = fromMaybe [] $ M.lookup (showXPrompt defaultMode) hist - modeStack = W.Stack{ W.focus = defaultMode --current mode - , W.up = [] - , W.down = tail modes --other modes - } - st = initState d rw w s (XPMultipleModes modeStack) gc fs hs conf { alwaysHighlight = True} numlock - st' <- io $ execStateT runXP st - + st' <- io $ + bracket + (createWin d rw conf s) + (destroyWindow d) + (\w -> + bracket + (createGC d w) + (freeGC d) + (\gc -> do + selectInput d w $ exposureMask .|. keyPressMask + setGraphicsExposures d gc False + let hs = fromMaybe [] $ M.lookup historyKey hist + st = initState d rw w s om gc fs hs conf numlock + runXP st)) releaseXMF fs - io $ freeGC d gc - - if successful st' then do - let - prune = take (historySize conf) - - -- insert into history the buffers value - io $ writeHistory $ M.insertWith + when (successful st') $ do + let prune = take (historySize conf) + io $ writeHistory $ + M.insertWith (\xs ys -> prune . historyFilter conf $ xs ++ ys) - (showXPrompt defaultMode) + historyKey + -- We need to apply historyFilter before as well, since + -- otherwise the filter would not be applied if there is no + -- history (prune $ historyFilter conf [command st']) hist - - case operationMode st' of - XPMultipleModes ms -> let - action = modeAction $ W.focus ms - in action (command st') $ (fromMaybe "" $ highlightedCompl st') - _ -> error "The impossible occurred: This prompt runs with multiple modes but they could not be found." --we are creating a prompt with multiple modes, so its operationMode should have been constructed with XPMultipleMode - else - return () - - -runXP :: XP () -runXP = do - (d,w) <- gets (dpy &&& win) - status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime - when (status == grabSuccess) $ do - updateWindows - eventLoop handle - io $ ungrabKeyboard d currentTime - io $ destroyWindow d w - destroyComplWin - io $ sync d False - -type KeyStroke = (KeySym, String) - -eventLoop :: (KeyStroke -> Event -> XP ()) -> XP () -eventLoop action = do - d <- gets dpy - (keysym,string,event) <- io $ - allocaXEvent $ \e -> do - maskEvent d (exposureMask .|. keyPressMask) e - ev <- getEvent e - (ks,s) <- if ev_event_type ev == keyPress - then lookupString $ asKeyEvent e - else return (Nothing, "") - return (ks,s,ev) - action (fromMaybe xK_VoidSymbol keysym,string) event - gets done >>= flip unless (eventLoop handle) + return st' -- | Removes numlock and capslock from a keymask. -- Duplicate of cleanMask from core, but in the @@ -496,96 +580,280 @@ cleanMask msk = do let highMasks = 1 `shiftL` 12 - 1 return (complement (numlock .|. lockMask) .&. msk .&. highMasks) --- Main event handler -handle :: KeyStroke -> Event -> XP () -handle ks@(sym,_) e@(KeyEvent {ev_event_type = t, ev_state = m}) = do - complKey <- gets $ completionKey . config - chgModeKey <- gets $ changeModeKey . config - c <- getCompletions - mCleaned <- cleanMask m - when (length c > 1) $ modify (\s -> s { showComplWin = True }) - if complKey == (mCleaned,sym) - then completionHandle c ks e - else if (sym == chgModeKey) then - do - modify setNextMode - updateWindows - else when (t == keyPress) $ keyPressHandle mCleaned ks -handle _ (ExposeEvent {ev_window = w}) = do - st <- get - when (win st == w) updateWindows -handle _ _ = return () +-- | Inverse of 'Codec.Binary.UTF8.String.utf8Encode', that is, a convenience +-- function that checks to see if the input string is UTF8 encoded before +-- decoding. +utf8Decode :: String -> String +utf8Decode str + | isUTF8Encoded str = decodeString str + | otherwise = str --- completion event handler -completionHandle :: [String] -> KeyStroke -> Event -> XP () -completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = do - complKey <- gets $ completionKey . config - alwaysHlight <- gets $ alwaysHighlight . config - mCleaned <- cleanMask m - case () of - () | t == keyPress && (mCleaned,sym) == complKey -> do - st <- get +runXP :: XPState -> IO XPState +runXP st = do + let d = dpy st + w = win st + st' <- bracket + (grabKeyboard d w True grabModeAsync grabModeAsync currentTime) + (\_ -> ungrabKeyboard d currentTime) + (\status -> + (flip execStateT st $ do + when (status == grabSuccess) $ do + updateWindows + eventLoop handleMain evDefaultStop) + `finally` (mapM_ (destroyWindow d) =<< readIORef (complWinRef st)) + `finally` sync d False) + return st' - let updateWins l = redrawWindows l >> eventLoop (completionHandle l) - updateState l = case alwaysHlight of - False -> simpleComplete l st - True | Just (command st) /= highlightedCompl st -> alwaysHighlightCurrent st - | otherwise -> alwaysHighlightNext l st +type KeyStroke = (KeySym, String) - case c of - [] -> updateWindows >> eventLoop handle - [x] -> updateState [x] >> getCompletions >>= updateWins - l -> updateState l >> updateWins l - | t == keyRelease && (mCleaned,sym) == complKey -> eventLoop (completionHandle c) - | otherwise -> keyPressHandle mCleaned ks -- some other key, handle it normally - where - -- When alwaysHighlight is off, just complete based on what the - -- user has typed so far. - simpleComplete :: [String] -> XPState -> XP () - simpleComplete l st = do - let newCommand = nextCompletion (currentXPMode st) (command st) l - modify $ \s -> setCommand newCommand $ - s { offset = length newCommand - , highlightedCompl = Just newCommand - } +-- | Main event "loop". Gives priority to events from the state's event buffer. +eventLoop :: (KeyStroke -> Event -> XP ()) + -> XP Bool + -> XP () +eventLoop handle stopAction = do + b <- gets eventBuffer + (keysym,keystr,event) <- case b of + [] -> do + d <- gets dpy + io $ allocaXEvent $ \e -> do + maskEvent d (exposureMask .|. keyPressMask) e + ev <- getEvent e + (ks,s) <- if ev_event_type ev == keyPress + then lookupString $ asKeyEvent e + else return (Nothing, "") + return (fromMaybe xK_VoidSymbol ks,s,ev) + l -> do + modify $ \s -> s { eventBuffer = tail l } + return $ head l + handle (keysym,keystr) event + stopAction >>= flip unless (eventLoop handle stopAction) - -- If alwaysHighlight is on, and this is the first use of the - -- completion key, update the buffer so that it contains the - -- current completion item. - alwaysHighlightCurrent :: XPState -> XP () - alwaysHighlightCurrent st = do - let newCommand = fromMaybe (command st) $ highlightedItem st c - modify $ \s -> setCommand newCommand $ - setHighlightedCompl (Just newCommand) $ - s { offset = length newCommand - } +-- | Default event loop stop condition. +evDefaultStop :: XP Bool +evDefaultStop = (||) <$> (gets modeDone) <*> (gets done) - -- If alwaysHighlight is on, and the user wants the next - -- completion, move to the next completion item and update the - -- buffer to reflect that. - -- - --TODO: Scroll or paginate results - alwaysHighlightNext :: [String] -> XPState -> XP () - alwaysHighlightNext l st = do - let complIndex' = nextComplIndex st (length l) - highlightedCompl' = highlightedItem st { complIndex = complIndex'} c - newCommand = fromMaybe (command st) $ highlightedCompl' - modify $ \s -> setHighlightedCompl highlightedCompl' $ - setCommand newCommand $ - s { complIndex = complIndex' - , offset = length newCommand - } +-- | Common patterns shared by all event handlers. Expose events can be +-- triggered by switching virtual consoles. +handleOther :: KeyStroke -> Event -> XP () +handleOther _ (ExposeEvent {ev_window = w}) = do + st <- get + when (win st == w) updateWindows +handleOther _ _ = return () --- some other event: go back to main loop -completionHandle _ k e = handle k e +-- | Prompt event handler for the main loop. Dispatches to input, completion +-- and mode switching handlers. +handleMain :: KeyStroke -> Event -> XP () +handleMain stroke@(keysym,_) (KeyEvent {ev_event_type = t, ev_state = m}) = do + (compKey,modeKey) <- gets $ (completionKey &&& changeModeKey) . config + keymask <- cleanMask m + -- haven't subscribed to keyRelease, so just in case + when (t == keyPress) $ + if (keymask,keysym) == compKey + then getCurrentCompletions >>= handleCompletionMain + else do + setCurrentCompletions Nothing + if (keysym == modeKey) + then modify setNextMode >> updateWindows + else handleInputMain keymask stroke +handleMain stroke event = handleOther stroke event + +-- | Prompt input handler for the main loop. +handleInputMain :: KeyMask -> KeyStroke -> XP () +handleInputMain keymask (keysym,keystr) = do + keymap <- gets (promptKeymap . config) + case M.lookup (keymask,keysym) keymap of + -- 'null keystr' i.e. when only a modifier was pressed + Just action -> action >> updateWindows + Nothing -> unless (null keystr) $ + when (keymask .&. controlMask == 0) $ do + insertString $ utf8Decode keystr + updateWindows + updateHighlightedCompl + complete <- tryAutoComplete + when complete $ setSuccess True >> setDone True + +-- There are two options to store the completion list during the main loop: +-- * Use the State monad, with 'Nothing' as the initial state. +-- * Join the output of the event loop handler to the input of the (same) +-- subsequent handler, using 'Nothing' as the initial input. +-- Both approaches are, under the hood, equivalent. +-- +-- | Prompt completion handler for the main loop. Given 'Nothing', generate the +-- current completion list. With the current list, trigger a completion. +handleCompletionMain :: Maybe [String] -> XP () +handleCompletionMain Nothing = do + cs <- getCompletions + when (length cs > 1) $ + modify $ \s -> s { showComplWin = True } + setCurrentCompletions $ Just cs + handleCompletion cs +handleCompletionMain (Just cs) = handleCompletion cs + +handleCompletion :: [String] -> XP () +handleCompletion cs = do + alwaysHlight <- gets $ alwaysHighlight . config + st <- get + + let updateWins l = redrawWindows l + updateState l = case alwaysHlight of + False -> simpleComplete l st + True | Just (command st) /= highlightedCompl st -> alwaysHighlightCurrent st + | otherwise -> alwaysHighlightNext l st + + case cs of + [] -> updateWindows + [x] -> do updateState [x] + cs' <- getCompletions + updateWins cs' + setCurrentCompletions $ Just cs' + l -> updateState l >> updateWins l + where + -- When alwaysHighlight is off, just complete based on what the + -- user has typed so far. + simpleComplete :: [String] -> XPState -> XP () + simpleComplete l st = do + let newCommand = nextCompletion (currentXPMode st) (command st) l + modify $ \s -> setCommand newCommand $ + s { offset = length newCommand + , highlightedCompl = Just newCommand + } + + -- If alwaysHighlight is on, and this is the first use of the + -- completion key, update the buffer so that it contains the + -- current completion item. + alwaysHighlightCurrent :: XPState -> XP () + alwaysHighlightCurrent st = do + let newCommand = fromMaybe (command st) $ highlightedItem st cs + modify $ \s -> setCommand newCommand $ + setHighlightedCompl (Just newCommand) $ + s { offset = length newCommand + } + + -- If alwaysHighlight is on, and the user wants the next + -- completion, move to the next completion item and update the + -- buffer to reflect that. + -- + --TODO: Scroll or paginate results + alwaysHighlightNext :: [String] -> XPState -> XP () + alwaysHighlightNext l st = do + let complIndex' = nextComplIndex st (length l) + highlightedCompl' = highlightedItem st { complIndex = complIndex'} cs + newCommand = fromMaybe (command st) $ highlightedCompl' + modify $ \s -> setHighlightedCompl highlightedCompl' $ + setCommand newCommand $ + s { complIndex = complIndex' + , offset = length newCommand + } + +-- | Initiate a prompt sub-map event loop. Submaps are intended to provide +-- alternate keybindings. Accepts a default action and a mapping from key +-- combinations to actions. If no entry matches, the default action is run. +promptSubmap :: XP () + -> M.Map (KeyMask, KeySym) (XP ()) + -> XP () +promptSubmap defaultAction keymap = do + md <- gets modeDone + setModeDone False + updateWindows + eventLoop (handleSubmap defaultAction keymap) evDefaultStop + setModeDone md + +handleSubmap :: XP () + -> M.Map (KeyMask, KeySym) (XP ()) + -> KeyStroke + -> Event + -> XP () +handleSubmap defaultAction keymap stroke (KeyEvent {ev_event_type = t, ev_state = m}) = do + keymask <- cleanMask m + when (t == keyPress) $ handleInputSubmap defaultAction keymap keymask stroke +handleSubmap _ _ stroke event = handleOther stroke event + +handleInputSubmap :: XP () + -> M.Map (KeyMask, KeySym) (XP ()) + -> KeyMask + -> KeyStroke + -> XP () +handleInputSubmap defaultAction keymap keymask (keysym,keystr) = do + case M.lookup (keymask,keysym) keymap of + Just action -> action >> updateWindows + Nothing -> unless (null keystr) $ defaultAction >> updateWindows + +-- | Initiate a prompt input buffer event loop. Input is sent to a buffer and +-- bypasses the prompt. The provided function is given the existing buffer and +-- the input keystring. The first field of the result determines whether the +-- input loop continues (if @True@). The second field determines whether the +-- input is appended to the buffer, or dropped (if @False@). If the loop is to +-- stop without keeping input - that is, @(False,False)@ - the event is +-- prepended to the event buffer to be processed by the parent loop. This +-- allows loop to process both fixed and indeterminate inputs. +-- +-- Result given @(continue,keep)@: +-- +-- * cont and keep +-- +-- * grow input buffer +-- +-- * stop and keep +-- +-- * grow input buffer +-- * stop loop +-- +-- * stop and drop +-- +-- * buffer event +-- * stop loop +-- +-- * cont and drop +-- +-- * do nothing +promptBuffer :: (String -> String -> (Bool,Bool)) -> XP (String) +promptBuffer f = do + md <- gets modeDone + setModeDone False + eventLoop (handleBuffer f) evDefaultStop + buff <- gets inputBuffer + modify $ \s -> s { inputBuffer = "" } + setModeDone md + return buff + +handleBuffer :: (String -> String -> (Bool,Bool)) + -> KeyStroke + -> Event + -> XP () +handleBuffer f stroke event@(KeyEvent {ev_event_type = t, ev_state = m}) = do + keymask <- cleanMask m + when (t == keyPress) $ handleInputBuffer f keymask stroke event +handleBuffer _ stroke event = handleOther stroke event + +handleInputBuffer :: (String -> String -> (Bool,Bool)) + -> KeyMask + -> KeyStroke + -> Event + -> XP () +handleInputBuffer f keymask (keysym,keystr) event = do + unless (null keystr || keymask .&. controlMask /= 0) $ do + (evB,inB) <- gets (eventBuffer &&& inputBuffer) + let keystr' = utf8Decode keystr + let (cont,keep) = f inB keystr' + when (keep) $ + modify $ \s -> s { inputBuffer = inB ++ keystr' } + unless (cont) $ + setModeDone True + unless (cont || keep) $ + modify $ \s -> s { eventBuffer = (keysym,keystr,event) : evB } + +-- | Predicate instructing 'promptBuffer' to get (and keep) a single non-empty +-- 'KeyEvent'. +bufferOne :: String -> String -> (Bool,Bool) +bufferOne xs x = (null xs && null x,True) --Receives an state of the prompt, the size of the autocompletion list and returns the column,row --which should be highlighted next nextComplIndex :: XPState -> Int -> (Int,Int) nextComplIndex st nitems = case complWinDim st of Nothing -> (0,0) --no window dims (just destroyed or not created) - Just (_,_,_,_,_,yy) -> let - (ncols,nrows) = (nitems `div` length yy + if (nitems `mod` length yy > 0) then 1 else 0, length yy) + Just (_,_,_,_,xx,yy) -> let + (ncols,nrows) = (length xx, length yy) (currentcol,currentrow) = complIndex st in if (currentcol + 1 >= ncols) then --hlight is in the last column if (currentrow + 1 < nrows ) then --hlight is still not at the last row @@ -637,8 +905,9 @@ defaultXPKeymap' p = M.fromList $ , (xK_a, startOfLine) , (xK_e, endOfLine) , (xK_y, pasteString) - , (xK_Right, moveWord' p Next) - , (xK_Left, moveWord' p Prev) + -- Retain the pre-0.14 moveWord' behavior: + , (xK_Right, moveWord' p Next >> moveCursor Next) + , (xK_Left, moveCursor Prev >> moveWord' p Prev) , (xK_Delete, killWord' p Next) , (xK_BackSpace, killWord' p Prev) , (xK_w, killWord' p Prev) @@ -689,8 +958,9 @@ emacsLikeXPKeymap' p = M.fromList $ ] ++ map (first $ (,) mod1Mask) -- meta key + [ (xK_BackSpace, killWord' p Prev) - , (xK_f, moveWord' p Next) -- move a word forward - , (xK_b, moveWord' p Prev) -- move a word backward + -- Retain the pre-0.14 moveWord' behavior: + , (xK_f, moveWord' p Next >> moveCursor Next) -- move a word forward + , (xK_b, moveCursor Prev >> moveWord' p Prev) -- move a word backward , (xK_d, killWord' p Next) -- kill the next word , (xK_n, moveHistory W.focusUp') , (xK_p, moveHistory W.focusDown') @@ -710,34 +980,141 @@ emacsLikeXPKeymap' p = M.fromList $ , (xK_Escape, quit) ] -keyPressHandle :: KeyMask -> KeyStroke -> XP () -keyPressHandle m (ks,str) = do - km <- gets (promptKeymap . config) - case M.lookup (m,ks) km of - Just action -> action >> updateWindows - Nothing -> case str of - "" -> eventLoop handle - _ -> when (m .&. controlMask == 0) $ do - let str' = if isUTF8Encoded str - then decodeString str - else str - insertString str' - updateWindows - updateHighlightedCompl - completed <- tryAutoComplete - when completed $ setSuccess True >> setDone True +-- | Vim-ish key bindings. Click on the \"Source\" link to the right to see the +-- complete list. See also 'vimLikeXPKeymap''. +vimLikeXPKeymap :: M.Map (KeyMask,KeySym) (XP ()) +vimLikeXPKeymap = vimLikeXPKeymap' (setBorderColor "grey22") id id isSpace +-- | A variant of 'vimLikeXPKeymap' with customizable aspects: +vimLikeXPKeymap' :: (XPColor -> XPColor) + -- ^ Modifies the prompt color when entering normal mode. + -- The default is @setBorderColor "grey22"@ - same color as + -- the default background color. + -> (String -> String) + -- ^ Prompter to use in normal mode. The default of 'id' + -- balances 'defaultPrompter' but @("[n] " ++)@ is a good + -- alternate with 'defaultPrompter' as @("[i] " ++)@. + -> (String -> String) + -- ^ Filter applied to the X Selection before pasting. The + -- default is 'id' but @filter isPrint@ is a good + -- alternate. + -> (Char -> Bool) + -- ^ Predicate identifying non-word characters. The default + -- is 'isSpace'. See the documentation of other keymaps for + -- alternates. + -> M.Map (KeyMask,KeySym) (XP ()) +vimLikeXPKeymap' fromColor promptF pasteFilter notWord = M.fromList $ + map (first $ (,) 0) + [ (xK_Return, setSuccess True >> setDone True) + , (xK_KP_Enter, setSuccess True >> setDone True) + , (xK_BackSpace, deleteString Prev) + , (xK_Delete, deleteString Next) + , (xK_Left, moveCursor Prev) + , (xK_Right, moveCursor Next) + , (xK_Home, startOfLine) + , (xK_End, endOfLine) + , (xK_Down, moveHistory W.focusUp') + , (xK_Up, moveHistory W.focusDown') + , (xK_Escape, moveCursor Prev + >> modifyColor fromColor + >> setPrompter promptF + >> promptSubmap (return ()) normalVimXPKeymap + >> resetColor + >> resetPrompter + ) + ] where + normalVimXPKeymap = M.fromList $ + map (first $ (,) 0) + [ (xK_i, setModeDone True) + , (xK_a, moveCursor Next >> setModeDone True) + , (xK_s, deleteString Next >> setModeDone True) + , (xK_x, deleteString Next >> clipCursor) + , (xK_Delete, deleteString Next >> clipCursor) + , (xK_p, moveCursor Next + >> pasteString' pasteFilter + >> moveCursor Prev + ) + , (xK_0, startOfLine) + , (xK_Escape, quit) + , (xK_Down, moveHistory W.focusUp') + , (xK_j, moveHistory W.focusUp') + , (xK_Up, moveHistory W.focusDown') + , (xK_k, moveHistory W.focusDown') + , (xK_Right, moveCursorClip Next) + , (xK_l, moveCursorClip Next) + , (xK_h, moveCursorClip Prev) + , (xK_Left, moveCursorClip Prev) + , (xK_BackSpace, moveCursorClip Prev) + -- Implementation using the original 'moveWord'': + --, (xK_e, moveCursor Next >> moveWord' notWord Next >> moveCursor Prev) + --, (xK_b, moveWord' notWord Prev) + --, (xK_w, moveWord' (not . notWord) Next >> clipCursor) + , (xK_e, moveCursorClip Next >> moveWord' notWord Next) + , (xK_b, moveCursorClip Prev >> moveWord' notWord Prev) + , (xK_w, moveWord' (not . notWord) Next >> moveCursorClip Next) + , (xK_f, promptBuffer bufferOne >>= toHeadChar Next) + , (xK_d, promptSubmap (setModeDone True) deleteVimXPKeymap) + , (xK_c, promptSubmap (setModeDone True) changeVimXPKeymap + >> setModeDone True + ) + ] ++ + map (first $ (,) shiftMask) + [ (xK_dollar, endOfLine >> moveCursor Prev) + , (xK_D, killAfter >> moveCursor Prev) + , (xK_C, killAfter >> setModeDone True) + , (xK_P, pasteString' pasteFilter >> moveCursor Prev) + , (xK_A, endOfLine >> setModeDone True) + , (xK_I, startOfLine >> setModeDone True) + , (xK_F, promptBuffer bufferOne >>= toHeadChar Prev) + ] + deleteVimXPKeymap = M.fromList $ + map ((first $ (,) 0) . (second $ flip (>>) (setModeDone True))) + [ (xK_e, deleteString Next >> killWord' notWord Next >> clipCursor) + , (xK_w, killWord' (not . notWord) Next >> clipCursor) + , (xK_0, killBefore) + , (xK_b, killWord' notWord Prev) + , (xK_d, setInput "") + ] ++ + map ((first $ (,) shiftMask) . (second $ flip (>>) (setModeDone True))) + [ (xK_dollar, killAfter >> moveCursor Prev) + ] + changeVimXPKeymap = M.fromList $ + map ((first $ (,) 0) . (second $ flip (>>) (setModeDone True))) + [ (xK_e, deleteString Next >> killWord' notWord Next) + , (xK_0, killBefore) + , (xK_b, killWord' notWord Prev) + , (xK_c, setInput "") + , (xK_w, changeWord notWord) + ] ++ + map ((first $ (,) shiftMask) . (second $ flip (>>) (setModeDone True))) + [ (xK_dollar, killAfter) + ] + +-- Useful for exploring off-by-one issues. +--testOffset :: XP () +--testOffset = do +-- off <- getOffset +-- str <- getInput +-- setInput $ str ++ "|" ++ (show off) ++ ":" ++ (show $ length str) + +-- | Set @True@ to save the prompt's entry to history and run it via the +-- provided action. setSuccess :: Bool -> XP () setSuccess b = modify $ \s -> s { successful = b } +-- | Set @True@ to leave all event loops, no matter how nested. setDone :: Bool -> XP () setDone b = modify $ \s -> s { done = b } +-- | Set @True@ to leave the current event loop, i.e. submaps. +setModeDone :: Bool -> XP () +setModeDone b = modify $ \s -> s { modeDone = b } + -- KeyPress and State -- | Quit. quit :: XP () -quit = flushString >> setSuccess False >> setDone True +quit = flushString >> setSuccess False >> setDone True >> setModeDone True -- | Kill the portion of the command before the cursor killBefore :: XP () @@ -776,6 +1153,19 @@ killWord' p d = do Prev -> (delPrevWord f ++ ss, length $ delPrevWord f) -- laziness!! modify $ \s -> setCommand ncom $ s { offset = noff} +-- | From Vim's @:help cw@: +-- +-- * Special case: When the cursor is in a word, "cw" and "cW" do not include +-- the white space after a word, they only change up to the end of the word. +changeWord :: (Char -> Bool) -> XP () +changeWord p = f <$> getInput <*> getOffset <*> (pure p) >>= id + where + f :: String -> Int -> (Char -> Bool) -> XP () + f str off _ | length str <= off || + length str <= 0 = return () + f str off p'| p' $ str !! off = killWord' (not . p') Next + | otherwise = killWord' p' Next + -- | Put the cursor at the end of line endOfLine :: XP () endOfLine = @@ -807,9 +1197,15 @@ insertString str = | otherwise = f ++ str ++ ss where (f,ss) = splitAt oo oc --- | Insert the current X selection string at the cursor position. +-- | Insert the current X selection string at the cursor position. The X +-- selection is not modified. pasteString :: XP () -pasteString = join $ io $ liftM insertString getSelection +pasteString = pasteString' id + +-- | A variant of 'pasteString' which allows modifying the X selection before +-- pasting. +pasteString' :: (String -> String) -> XP () +pasteString' f = join $ io $ liftM (insertString . f) getSelection -- | Remove a character at the cursor position deleteString :: Direction1D -> XP () @@ -823,33 +1219,69 @@ deleteString d = | otherwise = oc where (f,ss) = splitAt oo oc --- | move the cursor one position +-- | Ensure the cursor remains over the command by shifting left if necessary. +clipCursor :: XP () +clipCursor = modify $ \s -> s { offset = o (offset s) (command s)} + where o oo c = min (max 0 $ length c - 1) oo + +-- | Move the cursor one position. moveCursor :: Direction1D -> XP () moveCursor d = modify $ \s -> s { offset = o (offset s) (command s)} where o oo c = if d == Prev then max 0 (oo - 1) else min (length c) (oo + 1) +-- | Move the cursor one position, but not beyond the command. +moveCursorClip :: Direction1D -> XP () +moveCursorClip = (>> clipCursor) . moveCursor +-- modify $ \s -> s { offset = o (offset s) (command s)} +-- where o oo c = if d == Prev then max 0 (oo - 1) else min (max 0 $ length c - 1) (oo + 1) + -- | Move the cursor one word, using 'isSpace' as the default -- predicate for non-word characters. See 'moveWord''. moveWord :: Direction1D -> XP () moveWord = moveWord' isSpace --- | Move the cursor one word, given a predicate to identify non-word --- characters. First move past any consecutive non-word characters; --- then move to just before the next non-word character. +-- | Given a direction, move the cursor to just before the next +-- (predicate,not-predicate) character transition. This means a (not-word,word) +-- transition should be followed by a 'moveCursorClip' action. Always considers +-- the character under the current cursor position. This means a +-- (word,not-word) transition should be preceded by a 'moveCursorClip' action. +-- Calculated as the length of consecutive non-predicate characters starting +-- from the cursor position, plus the length of subsequent consecutive +-- predicate characters, plus when moving backwards the distance of the cursor +-- beyond the input. Reduced by one to avoid jumping off either end of the +-- input, when present. +-- +-- Use these identities to retain the pre-0.14 behavior: +-- +-- @ +-- (oldMoveWord' p Prev) = (moveCursor Prev >> moveWord' p Prev) +-- @ +-- +-- @ +-- (oldMoveWord' p Next) = (moveWord' p Next >> moveCursor Next) +-- @ moveWord' :: (Char -> Bool) -> Direction1D -> XP () moveWord' p d = do c <- gets command o <- gets offset - let (f,ss) = splitAt o c - len = uncurry (+) + let (f,ss) = splitOn o c + splitOn n xs = (take (n+1) xs, drop n xs) + gap = case d of + Prev -> max 0 $ (o + 1) - (length c) + Next -> 0 + len = max 0 . flip (-) 1 . (gap +) + . uncurry (+) . (length *** (length . fst . break p)) . break (not . p) newoff = case d of - Prev -> o - len (reverse f) - Next -> o + len ss + Prev -> o - len (reverse f) + Next -> o + len ss modify $ \s -> s { offset = newoff } +-- | Set the prompt's input to an entry further up or further down the history +-- stack. Use 'Stack' functions from 'XMonad.StackSet', i.e. 'focusUp'' or +-- 'focusDown''. moveHistory :: (W.Stack String -> W.Stack String) -> XP () moveHistory f = do modify $ \s -> let ch = f $ commandHistory s @@ -859,6 +1291,21 @@ moveHistory f = do updateWindows updateHighlightedCompl +-- | Move the cursor in the given direction to the first instance of the first +-- character of the given string, assuming the string is not empty. The +-- starting cursor character is not considered, and the cursor is placed over +-- the matching character. +toHeadChar :: Direction1D -> String -> XP () +toHeadChar d s = unless (null s) $ do + cmd <- gets command + off <- gets offset + let c = head s + off' = (if d == Prev then negate . fst else snd) + . join (***) (fromMaybe 0 . fmap (+1) . elemIndex c) + . (reverse *** drop 1) + $ (splitAt off cmd) + modify $ \st -> st { offset = offset st + off' } + updateHighlightedCompl :: XP () updateHighlightedCompl = do st <- get @@ -904,18 +1351,18 @@ createWin d rw c s = do drawWin :: XP () drawWin = do st <- get - let (c,(d,(w,gc))) = (config &&& dpy &&& win &&& gcon) st + let (c,(cr,(d,(w,gc)))) = (config &&& color &&& dpy &&& win &&& gcon) st scr = defaultScreenOfDisplay d wh = case position c of CenteredAt _ wd -> floor $ wd * fi (widthOfScreen scr) _ -> widthOfScreen scr ht = height c bw = promptBorderWidth c - Just bgcolor <- io $ initColor d (bgColor c) - Just border <- io $ initColor d (borderColor c) + Just bgcolor <- io $ initColor d (bgNormal cr) + Just borderC <- io $ initColor d (border cr) p <- io $ createPixmap d w wh ht (defaultDepthOfScreen scr) - io $ fillDrawable d p gc border bgcolor (fi bw) wh ht + io $ fillDrawable d p gc borderC bgcolor (fi bw) wh ht printPrompt p io $ copyArea d p w gc 0 0 wh ht 0 0 io $ freePixmap d p @@ -923,8 +1370,9 @@ drawWin = do printPrompt :: Drawable -> XP () printPrompt drw = do st <- get - let (gc,(c,(d,fs))) = (gcon &&& config &&& dpy &&& fontS) st - (prt,(com,off)) = (show . currentXPMode &&& command &&& offset) st + let (pr,(cr,gc)) = (prompter &&& color &&& gcon) st + (c,(d,fs)) = (config &&& dpy &&& fontS) st + (prt,(com,off)) = (pr . show . currentXPMode &&& command &&& offset) st str = prt ++ com -- break the string in 3 parts: till the cursor, the cursor and the rest (f,p,ss) = if off >= length com @@ -940,11 +1388,11 @@ printPrompt drw = do let draw = printStringXMF d drw fs gc -- print the first part - draw (fgColor c) (bgColor c) x y f + draw (fgNormal cr) (bgNormal cr) x y f -- reverse the colors and print the "cursor" ;-) - draw (bgColor c) (fgColor c) (x + fromIntegral fsl) y p + draw (bgNormal cr) (fgNormal cr) (x + fromIntegral fsl) y p -- reverse the colors and print the rest of the string - draw (fgColor c) (bgColor c) (x + fromIntegral (fsl + psl)) y ss + draw (fgNormal cr) (bgNormal cr) (x + fromIntegral (fsl + psl)) y ss -- get the current completion function depending on the active mode getCompletionFunction :: XPState -> ComplFunction @@ -956,19 +1404,25 @@ getCompletionFunction st = case operationMode st of getCompletions :: XP [String] getCompletions = do s <- get - io $ getCompletionFunction s (commandToComplete (currentXPMode s) (command s)) - `E.catch` \(SomeException _) -> return [] + let q = commandToComplete (currentXPMode s) (command s) + compl = getCompletionFunction s + srt = sorter (config s) + io $ (srt q <$> compl q) `E.catch` \(SomeException _) -> return [] setComplWin :: Window -> ComplWindowDim -> XP () -setComplWin w wi = +setComplWin w wi = do + wr <- gets complWinRef + io $ writeIORef wr (Just w) modify (\s -> s { complWin = Just w, complWinDim = Just wi }) destroyComplWin :: XP () destroyComplWin = do d <- gets dpy cw <- gets complWin + wr <- gets complWinRef case cw of Just w -> do io $ destroyWindow d w + io $ writeIORef wr Nothing modify (\s -> s { complWin = Nothing, complWinDim = Nothing }) Nothing -> return () @@ -1027,21 +1481,22 @@ drawComplWin :: Window -> [String] -> XP () drawComplWin w compl = do st <- get let c = config st + cr = color st d = dpy st scr = defaultScreenOfDisplay d bw = promptBorderWidth c gc = gcon st - Just bgcolor <- io $ initColor d (bgColor c) - Just border <- io $ initColor d (borderColor c) + Just bgcolor <- io $ initColor d (bgNormal cr) + Just borderC <- io $ initColor d (border cr) (_,_,wh,ht,xx,yy) <- getComplWinDim compl p <- io $ createPixmap d w wh ht (defaultDepthOfScreen scr) - io $ fillDrawable d p gc border bgcolor (fi bw) wh ht + io $ fillDrawable d p gc borderC bgcolor (fi bw) wh ht let ac = splitInSubListsAt (length yy) (take (length xx * length yy) compl) - printComplList d p gc (fgColor c) (bgColor c) xx yy ac + printComplList d p gc (fgNormal cr) (bgNormal cr) xx yy ac --lift $ spawn $ "xmessage " ++ " ac: " ++ show ac ++ " xx: " ++ show xx ++ " length xx: " ++ show (length xx) ++ " yy: " ++ show (length yy) io $ copyArea d p w gc 0 0 wh ht 0 0 io $ freePixmap d p @@ -1083,12 +1538,13 @@ printComplList d drw gc fc bc xs ys sss = let (colIndex,rowIndex) = findComplIndex item sss in -- assign some colors - if ((complIndex st) == (colIndex,rowIndex)) then (fgHLight $ config st,bgHLight $ config st) + if ((complIndex st) == (colIndex,rowIndex)) + then (fgHighlight $ color st,bgHighlight $ color st) else (fc,bc) False -> -- compare item with buffer's value if completionToCommand (currentXPMode st) item == commandToComplete (currentXPMode st) (command st) - then (fgHLight $ config st,bgHLight $ config st) + then (fgHighlight $ color st,bgHighlight $ color st) else (fc,bc) printStringXMF d drw (fontS st) gc f b x y item) ys ss) xs sss @@ -1125,9 +1581,9 @@ writeHistory hist = do -- | Fills a 'Drawable' with a rectangle and a border fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel -> Dimension -> Dimension -> Dimension -> IO () -fillDrawable d drw gc border bgcolor bw wh ht = do +fillDrawable d drw gc borderC bgcolor bw wh ht = do -- we start with the border - setForeground d gc border + setForeground d gc borderC fillRectangle d drw gc 0 0 wh ht -- here foreground means the background of the text setForeground d gc bgcolor @@ -1215,7 +1671,7 @@ historyCompletion = historyCompletionP (const True) -- name satisfies the given predicate. historyCompletionP :: (String -> Bool) -> ComplFunction historyCompletionP p x = fmap (toComplList . M.filterWithKey (const . p)) readHistory - where toComplList = deleteConsecutive . filter (isInfixOf x) . M.fold (++) [] + where toComplList = deleteConsecutive . filter (isInfixOf x) . M.foldr (++) [] -- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off -- laziness and stability for efficiency. diff --git a/XMonad/Prompt/AppendFile.hs b/XMonad/Prompt/AppendFile.hs index 4a0ce3ff..7da49b8e 100644 --- a/XMonad/Prompt/AppendFile.hs +++ b/XMonad/Prompt/AppendFile.hs @@ -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 diff --git a/XMonad/Prompt/FuzzyMatch.hs b/XMonad/Prompt/FuzzyMatch.hs new file mode 100644 index 00000000..a5d37d4a --- /dev/null +++ b/XMonad/Prompt/FuzzyMatch.hs @@ -0,0 +1,104 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.FuzzyMatch +-- Copyright : (C) 2015 Norbert Zeh +-- License : GPL +-- +-- Maintainer : Norbert Zeh +-- 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' diff --git a/XMonad/Prompt/Pass.hs b/XMonad/Prompt/Pass.hs index 8b2a1663..565fdd60 100644 --- a/XMonad/Prompt/Pass.hs +++ b/XMonad/Prompt/Pass.hs @@ -8,38 +8,48 @@ -- Stability : unstable -- Portability : unportable -- --- This module provides 3 to ease passwords manipulation (generate, read, remove): +-- This module provides 5 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 . +-- - 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 . -- +-- 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 . +-- - The +-- implementation is . -- --- - Inspired from +-- - Inspired by -- ----------------------------------------------------------------------------- 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 +-- - how to setup the password store, see -- 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 diff --git a/XMonad/Prompt/Unicode.hs b/XMonad/Prompt/Unicode.hs index 39167ce2..a76f90b1 100644 --- a/XMonad/Prompt/Unicode.hs +++ b/XMonad/Prompt/Unicode.hs @@ -1,6 +1,7 @@ {- | Module : XMonad.Prompt.Unicode Copyright : (c) 2016 Joachim Breitner + 2017 Nick Hu License : BSD-style (see LICENSE) Maintainer : @@ -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", "-"] diff --git a/XMonad/Util/Dmenu.hs b/XMonad/Util/Dmenu.hs index 79e47740..c464b3c8 100644 --- a/XMonad/Util/Dmenu.hs +++ b/XMonad/Util/Dmenu.hs @@ -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 -- 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 diff --git a/XMonad/Util/Dzen.hs b/XMonad/Util/Dzen.hs index 910beca4..4702ed7f 100644 --- a/XMonad/Util/Dzen.hs +++ b/XMonad/Util/Dzen.hs @@ -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: -- diff --git a/XMonad/Util/ExtensibleState.hs b/XMonad/Util/ExtensibleState.hs index 7e12a12c..4132ce51 100644 --- a/XMonad/Util/ExtensibleState.hs +++ b/XMonad/Util/ExtensibleState.hs @@ -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 diff --git a/XMonad/Util/PureX.hs b/XMonad/Util/PureX.hs new file mode 100644 index 00000000..988ad5e5 --- /dev/null +++ b/XMonad/Util/PureX.hs @@ -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 '<*', '*>', '' 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@. +( m Any -> m a -> m Any +ifthis @. 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') + +-- }}} + diff --git a/XMonad/Util/Rectangle.hs b/XMonad/Util/Rectangle.hs new file mode 100644 index 00000000..405a7a68 --- /dev/null +++ b/XMonad/Util/Rectangle.hs @@ -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) diff --git a/XMonad/Util/SessionStart.hs b/XMonad/Util/SessionStart.hs new file mode 100644 index 00000000..807807ec --- /dev/null +++ b/XMonad/Util/SessionStart.hs @@ -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 diff --git a/XMonad/Util/SpawnOnce.hs b/XMonad/Util/SpawnOnce.hs index a281a621..df935097 100644 --- a/XMonad/Util/SpawnOnce.hs +++ b/XMonad/Util/SpawnOnce.hs @@ -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 diff --git a/XMonad/Util/Stack.hs b/XMonad/Util/Stack.hs index 9455d71e..953de723 100644 --- a/XMonad/Util/Stack.hs +++ b/XMonad/Util/Stack.hs @@ -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 <$>) diff --git a/XMonad/Util/Themes.hs b/XMonad/Util/Themes.hs index f753a501..fc4875fe 100644 --- a/XMonad/Util/Themes.hs +++ b/XMonad/Util/Themes.hs @@ -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 = diff --git a/XMonad/Util/WorkspaceCompare.hs b/XMonad/Util/WorkspaceCompare.hs index 88886f5f..f2a320d9 100644 --- a/XMonad/Util/WorkspaceCompare.hs +++ b/XMonad/Util/WorkspaceCompare.hs @@ -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 diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 73721d53..fd84fd41 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -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