packages feed

xmonad-contrib 0.11.4 → 0.18.2

raw patch · 356 files changed

Files

+ CHANGES.md view
@@ -0,0 +1,2356 @@+# Change Log / Release Notes++## 0.18.2 (March 7, 2026)++### Breaking Changes++  * Drop support for GHC 8.6++### New Modules++  * `XMonad.Util.StickyWindows`++    - Stick windows on screens so they follow you across desktops.++### Bug Fixes and Minor Changes++  * `XMonad.Actions.WindowBringer`++    - Make sure functions that internally use their `…Args` versions+      pass on the default `dmenu` arguments.++      These are also now exported as `defaultDMenuArgs` for users using+      the `…Args` versions but want to augment instead of replacing the+      default `dmenu` arguments.++      For users, the visible change will be that `bringMenu` and `copyMenu`+      now behave identically to `gotoMenu`, as expected, instead of being+      case sensitive. Users who might have been relying on the incorrect+      behavior should replace `*Menu` with `*MenuArgs []`.++  * `XMonad.Util.XSelection`++    - Added `getClipboard` to query the X clipboard.+      Also added `getSecondarySelection`.++  * `XMonad.Util.EZConfig`++    - Added `XF86WLAN` and `Menu` to the list of supported special keys.++  * `XMonad.Actions.DynamicProjects`++    - No longer autodelete projects when `switchProject` is called from+      an empty workspace. This also fixes a bug where static workspaces+      would be deleted when switching to a dynamic project.+    - Improved documentation on how to close a project.++  * `XMonad.Hooks.Rescreen`++    - Allow overriding the `rescreen` operation itself. Additionally, the+      `XMonad.Actions.PhysicalScreens` module now provides an alternative+      implementation of `rescreen` that avoids reshuffling the workspaces if+      the number of screens doesn't change and only their locations do (which+      is especially common if one uses `xrandr --setmonitor` to split an+      ultra-wide display in two).++    - Added an optional delay when waiting for events to settle. This may be+      used to avoid flicker and unnecessary workspace reshuffling if multiple+      `xrandr` commands are used to reconfigure the display layout.++  * `XMonad.Layout.NoBorders`++    - It's no longer necessary to use `borderEventHook` to garbage collect+      `alwaysHidden`/`neverHidden` lists. The layout listens to+      `DestroyWindowEvent` messages instead, which are broadcast to layouts+      since xmonad v0.17.0.++  * `XMonad.Hooks.EwmhDesktops`++    - Added a customization option for the action that gets executed when+      a client sends a **_NET_CURRENT_DESKTOP** request. It is now possible+      to change it using the `setEwmhSwitchDesktopHook`.+    - Added a customization option for mapping hidden workspaces to screens+      when setting the **_NET_DESKTOP_VIEWPORT**. This can be done using+      the `setEwmhHiddenWorkspaceToScreenMapping`.++    - Added support for **_NET_WM_STATE_{ABOVE,BELOW}** to place windows+      correctly.++  * `XMonad.Layout.IndependentScreens`++    - Added `focusWorkspace` for focusing workspaces on the screen that they+      belong to.+    - Added `doFocus'` hook as an alternative for `doFocus` when using+      IndependentScreens.+    - Added `screenOnMonitor` for getting the active screen for a monitor.++  * `XMonad.Util.NamedScratchPad`++    - Fix unintended window hiding in `nsSingleScratchpadPerWorkspace`.+      Only hide the previously active scratchpad.++  * `XMonad.Actions.Search`++    - Added `multiChar`, `combineChar`, and `prefixAwareChar` as+      slightly generalised versions of `prefixAware` and `(!>)` that+      allow specifying the character that separates a search engine's+      prefix with the query when combining engines.++    - Added the `ecosia` search engine.++  * `XMonad.Hooks.ManageDocks`++    - Added `onAllDocks` to run an action on all recognised docks.++## 0.18.1 (August 20, 2024)++### Breaking Changes++  * `XMonad.Hooks.StatusBars`++    - Move status bar functions from the `IO` to the `X` monad to+      allow them to look up information from `X`, like the screen+      width. Existing configurations may need to use `io` from+      `XMonad.Core` or `liftIO` from `Control.Monad.IO.Class` in+      order to lift any existing `IO StatusBarConfig` values into+      `X StatusBarConfig` values.++  * `XMonad.Prompt`++    - Added an additional `XPConfig` argument to `historyCompletion` and+      `historyCompletionP`. Calls along the lines of `historyCompletionP+      myFunc` should be changed to `historyCompletionP myConf myFunc`.+      If not `myConf` is lying around, `def` can be used instead.++  * `XMonad.Actions.GridSelect`++    - Added the `gs_cancelOnEmptyClick` field to `GSConfig`, which makes+      mouse clicks into "empty space" cancel the current grid-select.+      Users explicitly defining their own `GSConfig` record will have to+      add this to their definitions. Additionally, the field defaults to+      `True`—to retain the old behaviour, set it to `False`.++### New Modules++  * `XMonad.Actions.Profiles`++    - Group workspaces by similarity. Useful when one has lots+      of workspaces and uses only a couple per unit of work.++  * `XMonad.Hooks.FloatConfigureReq`++    - Customize handling of floating windows' move/resize/restack requests+      (ConfigureRequest). Useful as a workaround for some misbehaving client+      applications (Steam, rxvt-unicode, anything that tries to restore+      absolute position of floats).++  * `XMonad.Layout.Columns`++    - Organize windows in columns. This layout allows to move/resize windows in+      every directions.++  * `XMonad.Prompt.WindowBringer`++    - Added `copyMenu`, a convenient way to copy a window to the current workspace.++### Bug Fixes and Minor Changes++  * Fix build-with-cabal.sh when XDG_CONFIG_HOME is defined.++  * `XMonad.Util.EZConfig`++    - Fixed `checkKeymap` warning that all keybindings are duplicates.++  * `XMonad.Hooks.ManageHelpers`++    - Added `isNotification` predicate to check for windows with+      `_NET_WM_WINDOW_TYPE` property of `_NET_WM_WINDOW_TYPE_NOTIFICATION`.++  * `XMonad.Prompt.OrgMode`++    - Added `HH:MM-HH:MM` and `HH:MM+HH` syntax to specify time spans.++  * `XMonad.Prompt`++    - The history file is not extraneously read and written anymore if+      the `historySize` is set to 0.++  * `XMonad.Hooks.EwmhDesktops`++    - Requests for unmanaged windows no longer cause a refresh. This avoids+      flicker and also fixes disappearing menus in the Steam client and+      possibly a few other client applications.++      (See also `XMonad.Hooks.FloatConfigureReq` and/or `XMonad.Util.Hacks`+      for additional Steam client workarounds.)++  * `XMonad.Actions.Submap`++    - Added `visualSubmapSorted` to enable sorting of the keymap+      descriptions.++  * `XMonad.Hooks.ScreenCorners`++    - Added screen edge support with `SCTop`, `SCBottom`, `SCLeft` and+      `SCRight`. Now both corners and edges are supported.++  * `XMonad.Actions.WindowNavigation`++    - Improve navigation in presence of floating windows.+    - Handle window switching when in `Full` layout.++### Other changes++## 0.18.0 (February 3, 2024)++### Breaking Changes++  * Deprecated `XMonad.Layout.Cross` due to bitrot; refer to+    `XMonad.Layout.Circle` and `XMonad.Layout.ThreeColumns` for+    alternatives.++  * Deprecated the `XMonad.Layout.StateFull` module and+    `XMonad.Layout.TrackFloating.(t|T)rackFloating` in favour of+    `XMonad.Layout.FocusTracking`.++  * Dropped support for GHC 8.4.++  * `XMonad.Util.ExclusiveScratchpads`++    - Deprecated the module in favour of the (new) exclusive scratchpad+      functionality of `XMonad.Util.NamedScratchpad`.++  * `XMonad.Actions.CycleWorkspaceByScreen`++    - The type of `repeatableAction` has changed, and it's deprecated in+      favour of `X.A.Repeatable.repeatable`.++  * `XMonad.Hooks.DynamicProperty`++    - Deprecated the module in favour of the more aptly named+      `XMonad.Hooks.OnPropertyChange`.++  * `XMonad.Util.Scratchpad`:++    - Deprecated the module; use `XMonad.Util.NamedScratchpad` instead.++  * `XMonad.Actions.Navigation2D`++    - Removed deprecated function `hybridNavigation`.++  * `XMonad.Layout.Spacing`++    - Removed deprecated functions `SpacingWithEdge`, `SmartSpacing`,+      `SmartSpacingWithEdge`, `ModifySpacing`, `setSpacing`, and+      `incSpacing`.++  * `XMonad.Actions.MessageFeedback`++    - Removed deprecated functions `send`, `sendSM`, `sendSM_`,+      `tryInOrder`, `tryInOrder_`, `tryMessage`, and `tryMessage_`.++  * `XMonad.Prompt.Window`++    - Removed deprecated functions `windowPromptGoto`,+      `windowPromptBring`, and `windowPromptBringCopy`.++  * `XMonad.Hooks.ICCCMFocus`++    - Removed deprecated module.  This was merged into xmonad.++  * `XMonad.Layout.LayoutBuilderP`++    - Removed deprecated module; use `XMonad.Layout.LayoutBuilder`+      instead.++  * `XMonad.Hooks.RestoreMinimized`++    - Removed deprecated module; use `XMonad.Hooks.Minimize` instead.++  * `XMonad.Layout.Named`++    - Deprecated the entire module, use `XMonad.Layout.Renamed` (which newly+      provides `named` for convenience) instead.++  * `XMonad.Actions.SinkAll`++    - Deprecated the entire module, use `XMonad.Actions.WithAll`+      instead.++  * `XMonad.Layout.Circle`:++    - Deprecated the entire module, use the `circle` function from+      `XMonad.Layout.CircleEx` instead.++  * `XMonad.Hooks.EwmhDesktops`++    - `_NET_CLIENT_LIST_STACKING` puts windows in the current workspace at the+      top in bottom-to-top order, followed by visible workspaces, followed by+      invisible workspaces.  Within visible and invisible groups, workspaces are+      ordered lexicographically, as before.  Currently focused window will+      always be the topmost, meaning the last in the list.++  * `XMonad.Util.NamedScratchpad`++    - Added `nsSingleScratchpadPerWorkspace`—a logHook to allow only one+      active scratchpad per workspace.++  * `XMonad.Util.EZConfig`++    - The function `readKeySequence` now returns a non-empty list if it+      succeeded.++  * Deprecate `XMonad.Util.Ungrab`; it was moved to `XMonad.Operations`+    in core.++### New Modules++  * `XMonad.Layout.CenterMainFluid`+    - A three column layout with main column in the center and two stack+      column surrounding it. Master window will be on center column and+      spaces on the sides are reserved.++  * `XMonad.Layout.FocusTracking`.++    - Replaces `X.L.StateFull` and half of `X.L.TrackFloating`.++  * `XMonad.Actions.MostRecentlyUsed`++    - Tab through windows by recency of use. Based on the Alt+Tab behaviour+      common outside of xmonad.++  * `XMonad.Util.History`++    - Track history in *O(log n)* time. Provides `History`, a variation on a+      LIFO stack with a uniqueness property. In order to achieve the desired+      asymptotics, the data type is implemented as an ordered Map.++  * `XMonad.Actions.Repeatable`++    - Actions you'd like to repeat. Factors out the shared logic of+      `X.A.CycleRecentWS`, `X.A.CycleWorkspaceByScreen` and `X.A.CycleWindows`.++  * `XMonad.Hooks.OnPropertyChange`:++    - A new module replicating the functionality of+      `XMonad.Hooks.DynamicProperty`, but with more discoverable names.++  * `XMonad.Actions.ToggleFullFloat`:++    - Fullscreen (float) a window while remembering its original state.+      There's both an action to be bound to a key, and hooks that plug into+      `XMonad.Hooks.EwmhDesktops`.++  * `XMonad.Layout.CircleEx`:++    - A new window layout, similar to X.L.Circle, but with more+      possibilities for customisation.++  * `XMonad.Layout.DecorationEx`:++    - A new, more extensible, mechanism for window decorations, and some+      standard types of decorations, including usual bar on top of window,+      tabbed decorations and dwm-like decorations.++### Bug Fixes and Minor Changes++  * `XMonad.Layout.Magnifier`++    - Added `magnifyxy` to allow for different magnification in the+      horizontal and vertical directions. Added `magnifierxy`,+      `magnifierxy'`, `magnifierxyOff`, and `magnifierxyOff'` as+      particular combinators.++  * `XMonad.Util.Loggers`++    - Added `logClassname`, `logClassnames`, `logClassnames'`,+      `logClassnameOnScreen`, `logClassnamesOnScreen`, `logClassnamesOnScreen'`,+      and `ClassnamesFormat`. These are all equivalents of their `Title`+      counterparts, allowing logging the window classname instead.++  * `XMonad.Hooks.StatusBar.PP`++    - `dynamicLogString` now forces its result and produces an error string if+      it throws an exception. Use `dynamicLogString'` if for some reason you+      need the old behavior.++  * `XMonad.Util.EZConfig`++    - Added `remapKeysP`, which remaps keybindings from one binding to+      another.++    - Made `additionalKeys{,P}`, `removeKeys{,P}`, `remapKeysP`, and+      `{additional,remove}MouseBindings` `infixl 4` so they can more easily+      be concatenated with `(++)`.++  * `XMonad.Util.NamedScratchpad`++    - Added `addExclusives`, `resetFocusedNSP`, `setNoexclusive`,+      `resizeNoexclusive`, and `floatMoveNoexclusive` in order to augment+      named scratchpads with the exclusive scratchpad functionality of+      `XMonad.Util.ExclusiveScratchpads`.++  * `XMonad.Layout.BorderResize`++    - Added `borderResizeNear` as a variant of `borderResize` that can+      control how many pixels near a border resizing still works.++  * `XMonad.Util.Run`++    - It is now ensured that all arguments of `execute` and `eval` are+      quoted.  Likewise, `executeNoQuote` is added as a version of+      `execute` that does not do that.++    - Added `findFile` as a shorthand to call `find-file`.++    - Added `list` and `saveExcursion` to the list of Emacs commands.++    - Added `toList` to easily lift a `String` to an `X Input`.++    - Added `>&&>` and `>||>` to glue together different inputs.++  * `XMonad.Util.Parser`++    - Added the `gather`, `count`, `between`, `option`, `optionally`,+      `skipMany`, `skipMany1`, `chainr`, `chainr1`, `chainl`, `chainl1`,+      and `manyTill` functions, in order to achieve feature parity with+      `Text.ParserCombinators.ReadP`.++  * `XMonad.Actions.FloatKeys`++    - Added `directionMoveWindow` and `directionMoveWindow` as more+      alternatives to the existing functions.++  * `XMonad.Hooks.InsertPosition`++    - Added `setupInsertPosition` as a combinator alternative to+      `insertPosition`.++  * `XMonad.Actions.Navigation2D`++    - Added `sideNavigation` as a fallback to the default tiling strategy,+      in case `lineNavigation` can't find a window.  This benefits+      especially users who use `XMonad.Layout.Spacing`.++  * `XMonad.Prompt.OrgMode`++    - Added `orgPromptRefile` and `orgPromptRefileTo` for interactive+      and targeted refiling of the entered note into some existing tree+      of headings, respectively.++    - Allowed the time specification in `HHMM` format.++  * `XMonad.Actions.Search`++    - Added `aur`, `flora`, `ncatlab`, `protondb`, `rosettacode`, `sourcehut`,+      `steam`, `voidpgks_x86_64`, `voidpgks_x86_64_musl`, `arXiv`,+      `clojureDocs`, `cratesIo`, `rustStd`, `noogle`, `nixos`, `homeManager`,+      and `zbmath` search engines.++  * `XMonad.Layout.ResizableThreeColumns`++    - Fixed an issue where the bottom right window would not respond to+      `MirrorShrink` and `MirrorExpand` messages.++  * `XMonad.Hooks.EwmhDesktops`++    - Added `disableEwmhManageDesktopViewport` to avoid setting the+      `_NET_DESKTOP_VIEWPORT` property, as it can lead to issues with+      some status bars (see this+      [polybar issue](https://github.com/polybar/polybar/issues/2603)).++    - Added `setEwmhFullscreenHooks` to override the default fullfloat/sink+      behaviour of `_NET_WM_STATE_FULLSCREEN` requests. See also+      `XMonad.Actions.ToggleFullFloat` for a float-restoring implementation of+      fullscreening.++    - Added `ewmhDesktops(Maybe)ManageHook` that places windows in their+      preferred workspaces. This is useful when restoring a browser session+      after a restart.++  * `XMonad.Hooks.StatusBar`++    - Added `startAllStatusBars` to start the configured status bars.++  * `XMonad.Util.NamedActions`++    - Changed `addDescrKeys` and `addDescrKeys'` to not discard the+      keybindings in the current config.++  * `XMonad.Prompt`++    - The `emacsLikeXPKeymap` and `vimLikeXPKeymap` keymaps now treat+      `C-m` the same as `Return`.++    - Added `prevCompletionKey` to `XPConfig`, facilitating the ability+      to cycle through the completions backwards. This is bound to+      `S-<TAB>` by default.++    - The `vimLikeXPKeymap` now accepts the prompt upon pressing enter+      in normal mode.++  * `XMonad.Actions.Prefix`++    - Added `orIfPrefixed`, a combinator to decide upon an action based+      on whether any prefix argument was given.++  * `XMonad.Actions.WorkspaceNames`++    - Enabled prompt completion (from history) in `renameWorkspace`.++  * `XMonad.Prompt.Pass`++    - Added `passOTPTypePrompt` to type out one-time-passwords via+      `xdotool`.++  * `XMonad.Util.Stack`++    - Added `zipperFocusedAtFirstOf` to differentiate two lists into a+      zipper.++## 0.17.1 (September 3, 2022)++### Breaking Changes++  * `XMonad.Util.EZConfig`++    - The functions `parseKey`, `parseKeyCombo`, and `parseKeySequence`+      now return a `Parser` (from `XMonad.Util.Parser`) instead of a+      `ReadP`.++  * `XMonad.Config.{Arossato,Dmwit,Droundy,Monad,Prime,Saegesser,Sjanssen}`++    - Deprecated all of these modules.  The user-specific configuration+      modules may still be found [on the+      website](https://xmonad.org/configurations.html)++  * `XMonad.Util.NamedScratchpad`++    - Scratchpads are now only based on the argument given to+      `namedScratchpadManageHook`; all other scratchpad arguments are,+      while still present, ignored.  Users passing all of their+      scratchpads to functions like `namedScratchpadAction` (as is shown+      in the module's documentation) should _not_ notice any difference+      in behaviour.++  * `XMonad.Util.DynamicScratchpads`++    - Deprecated the module; use the new dynamic scratchpad+      functionality of `XMonad.Util.NamedScratchpad` instead.++  * `XMonad.Hooks.UrgencyHook`++    - Deprecated `urgencyConfig`; use `def` from the new `Default`+      instance of `UrgencyConfig` instead.++### New Modules++  * `XMonad.Actions.PerLayoutKeys`++    Customizes a keybinding on a per-layout basis. Based on PerWorkspaceKeys.++  * `XMonad.Layout.CenteredIfSingle`++    Layout modifier that, if only a single window is on screen, places that window+    in the middle of the screen.++  * `XMonad.Util.ActionQueue`++    Put XMonad actions in the queue to be executed every time the+    `logHook` (or, alternatively, a hook of your choice) runs.++  * `XMonad.Hooks.BorderPerWindow`++    While XMonad provides config to set all window borders at the same+    width, this extension lets user set border width for a specific window+    using a ManageHook.++  * `XMonad.Util.Parser`++    A wrapper around the 'ReadP' parser combinator, providing behaviour+    that's closer to the more popular parser combinator libraries.++  * `XMonad.Hooks.StatusBar.WorkspaceScreen`++    In multi-head setup, it might be useful to have screen information of the+    visible workspaces combined with the workspace name, for example in a status+    bar. This module provides utility functions to do just that.++  * `XMonad.Hooks.ShowWName`++    Flashes the name of the current workspace when switching to it.+    Like `XMonad.Layout.ShowWName`, but as a logHook.++  * `XMonad.Actions.RepeatAction`++    A module for adding a keybinding to repeat the last action, similar+    to Vim's `.` or Emacs's `dot-mode`.++  * `XMonad.Util.Grab`++    Utilities for making grabbing and ungrabbing keys more convenient.++  * `XMonad.Hooks.Modal`++    This module implements modal keybindings for xmonad.++  * `XMonad.Layout.SideBorderDecoration`++    This module allows for having a configurable border position around+    windows; i.e., it can move the border to either cardinal direction.++### Bug Fixes and Minor Changes++  * `XMonad.Prompt.Pass`++    - Added new versions of the `pass` functions that allow user-specified+      prompts.++  * `XMonad.Prompt.AppendFile`++    - Use `XMonad.Prelude.mkAbsolutePath` to force names to be relative to the+      home directory and support `~/` prefixes.++  * `XMonad.Prompt.OrgMode`++    - Fixed the date parsing issue such that entries with a format of+      `todo +d 12 02 2024` work.++    - Added the ability to specify alphabetic (`#A`, `#B`, and `#C`)+      [priorities](https://orgmode.org/manual/Priorities.html) at the end of+      the input note.++  * `XMonad.Prompt.Unicode`++    - Fixed the display of non-ASCII characters in the description of Unicode+      characters++  * `XMonad.Prompt`++    - Added `transposeChars` to interchange the characters around the+      point and bound it to `C-t` in the Emacs XPKeymaps.++    - Added xft-based font fallback support.  This may be used by+      appending other fonts to the given string:+      `xft:iosevka-11,FontAwesome-9`.  Note that this requires+      `xmonad-contrib` to be compiled with `X11-xft` version 0.3.4 or+      higher.++  * `XMonad.Hooks.WindowSwallowing`++    - Fixed windows getting lost when used in conjunction with+      `smartBorders` and a single window.++    - No longer needs `pstree` to detect child/parent relationships.++    - Fixed some false positives in child/parent relationship detection.++  * `XMonad.Actions.SpawnOn`++    - Fixed parsing of `/proc/*/stat` to correctly handle complex process names.++  * `XMonad.Util.EZConfig`++    - Added support for Modifier Keys `KeySym`s for Emacs-like `additionalKeysP`.++  * `XMonad.Hooks.ManageHelpers`++    - Flipped how `(^?)`, `(~?)`, and `($?)` work to more accurately+      reflect how one uses these operators.++    - Added `isMinimized`++  * `XMonad.Actions.WindowNavigation`++    -  Fixed navigation getting "stuck" in certain situations for+       widescreen resolutions.++  * `XMonad.Layout.BinarySpacePartition`++    - Hidden windows are now ignored by the layout so that hidden windows in+      the stack don't offset position calculations in the layout.++  * `XMonad.Layout.MagicFocus`++    - The focused window will always be at the master area in the stack being+      passed onto the modified layout, even when focus leaves the workspace+      using the modified layout.++  * `XMonad.Actions.TreeSelect`++    - Added xft-based font fallback support.  This may be used by+      appending other fonts to the given string:+      `xft:iosevka-11,FontAwesome-9`.  Note that this requires+      `xmonad-contrib` to be compiled with `X11-xft` version 0.3.4 or+      higher.++  * `XMonad.Actions.FloatKeys`++    - Changed type signature of `keysMoveWindow` from `D -> Window -> X ()`+      to `ChangeDim -> Window -> X ()` to allow negative numbers without compiler warnings.++  * `XMonad.Util.Hacks`++    - Added `trayerPaddingXmobarEventHook` (plus generic variants for other+      trays/panels) to communicate trayer resize events to XMobar so that+      padding space may be reserved on xmobar for the tray.  Requires `xmobar`+      version 0.40 or higher.++  * `XMonad.Layout.VoidBorders`++    - Added new layout modifier `normalBorders` which can be used for+      resetting borders back in layouts where you want borders after calling+      `voidBorders`.++  * `XMonad.Prelude`++    - Added `keymaskToString` and `keyToString` to show a key mask and a+      key in the style of `XMonad.Util.EZConfig`.++    - Added `WindowScreen`, which is a type synonym for the specialized `Screen`+      type, that results from the `WindowSet` definition in `XMonad.Core`.++    - Modified `mkAbsolutePath` to support a leading environment variable, so+      things like `$HOME/NOTES` work. If you want more general environment+      variable support, comment on [this+      PR](https://github.com/xmonad/xmonad-contrib/pull/744)++  * `XMonad.Util.XUtils`++    - Added `withSimpleWindow`, `showSimpleWindow`, `WindowConfig`, and+      `WindowRect` in order to simplify the handling of simple popup+      windows.++  * `XMonad.Actions.Submap`++    - Added `visualSubmap` to visualise the available keys and their+      actions when inside a submap.++  * `XMonad.Prompt`, `XMonad.Actions.TreeSelect`, `XMonad.Actions.GridSelect`++    - Key bindings now behave similarly to xmonad core:+      State of mouse buttons and XKB layout groups is ignored.+      Translation of key codes to symbols ignores modifiers, so `Shift-Tab` is+      now just `(shiftMap, xK_Tab)` instead of `(shiftMap, xK_ISO_Left_Tab)`.++  * `XMonad.Util.NamedScratchpad`++    - Added support for dynamic scratchpads in the form of+      `dynamicNSPAction` and `toggleDynamicNSP`.++  * `XMonad.Hooks.EwmhDesktops`++    - Added support for `_NET_DESKTOP_VIEWPORT`, which is required by+      some status bars.++  * `XMonad.Util.Run`++    - Added an EDSL—particularly geared towards programs like terminals+      or Emacs—to spawn processes from XMonad in a compositional way.++  * `XMonad.Hooks.UrgencyHook`++    - Added a `Default` instance for `UrgencyConfig` and `DzenUrgencyHook`.++### Other changes++  * Migrated the sample build scripts from the deprecated `xmonad-testing` repo to+    `scripts/build`. This will be followed by a documentation update in the `xmonad`+    repo.++## 0.17.0 (October 27, 2021)++### Breaking Changes++  * All modules that export bitmap fonts as their default++    - If xmonad is compiled with XFT support (the default), use an XFT+      font instead.  The previous default expected an X11 misc font+      (PCF), which is not supported in pango 1.44 anymore and thus some+      distributions have stopped shipping these.++      This fixes the silent `user error (createFontSet)`; this would+      break the respective modules.++  * `XMonad.Prompt`++    - Now `mkComplFunFromList` and `mkComplFunFromList'` take an+      additional `XPConfig` argument, so that they can take into+      account the given `searchPredicate`.++    - A `complCaseSensitivity` field has been added to `XPConfig`, indicating+      whether case-sensitivity is desired when performing completion.++    - `historyCompletion` and `historyCompletionP` now both have an `X`+      constraint (was: `IO`), due to changes in how the xmonad core handles XDG+      directories.++    - The prompt window now sets a `WM_CLASS` property.  This allows+      other applications, like compositors, to properly match on it.++  * `XMonad.Hooks.EwmhDesktops`++    - It is no longer recommended to use `fullscreenEventHook` directly.+      Instead, use `ewmhFullscreen` which additionally advertises fullscreen+      support in `_NET_SUPPORTED` and fixes fullscreening of applications that+      explicitly check it, e.g. mupdf-gl, sxiv, …++      `XMonad.Layout.Fullscreen.fullscreenSupport` now advertises it as well,+      and no configuration changes are required in this case.++    - Deprecated `ewmhDesktopsLogHookCustom` and `ewmhDesktopsEventHookCustom`;+      these are now replaced by a composable `XMonad.Util.ExtensibleConf`-based+      interface. Users are advised to just use the `ewmh` XConfig combinator+      and customize behaviour using the provided `addEwmhWorkspaceSort`,+      `addEwmhWorkspaceRename` functions, or better still, use integrations+      provided by modules such as `XMonad.Actions.WorkspaceNames`.++      This interface now additionally allows customization of what happens+      when clients request window activation. This can be used to ignore+      activation of annoying applications, to mark windows as urgent instead+      of focusing them, and more. There's also a new `XMonad.Hooks.Focus`+      module extending the ManageHook EDSL with useful combinators.++    - Ordering of windows that are set to `_NET_CLIENT_LIST` and `_NET_CLIENT_LIST_STACKING`+      was changed to be closer to the spec. From now these two lists will have+      differently sorted windows.++    - `_NET_WM_STATE_DEMANDS_ATTENTION` was added to the list of supported+      hints (as per `_NET_SUPPORTED`). This hint has long been understood by+      `UrgencyHook`. This enables certain applications (e.g. kitty terminal+      emulator) that check whether the hint is supported to use it.++  * All modules still exporting a `defaultFoo` constructor++    - All of these were now removed. You can use the re-exported `def` from+      `Data.Default` instead.++  * `XMonad.Hooks.Script`++    - `execScriptHook` now has an `X` constraint (was: `MonadIO`), due to changes+      in how the xmonad core handles XDG directories.++  * `XMonad.Actions.WorkspaceNames`++    - The type of `getWorkspaceNames` was changed to fit into the new `ppRename`+      field of `PP`.++  * `XMonad.Hooks.StatusBar`, `XMonad.Hooks.StatusBar.PP` (previously+    `XMonad.Hooks.DynamicLog`) and `XMonad.Util.Run`++    - `spawnPipe` no longer uses binary mode handles but defaults to the+      current locale encoding instead.++      `dynamicLogString`, the output of which usually goes directly into such+      a handle, no longer encodes its output in UTF-8, but returns a normal+      `String` of Unicode codepoints instead.++      When these two are used together, everything should continue to work as+      it always has, but in isolation behaviour might change.++      (To get the old `spawnPipe` behaviour, `spawnPipeWithNoEncoding` can now+      be used, and `spawnPipeWithUtf8Encoding` was added as well to force+      UTF-8 regardless of locale. These shouldn't normally be necessary, though.)++    - `xmonadPropLog` and `xmonadPropLog'` now encode the String in UTF-8.+      Again, no change when used together with `dynamicLogString`, but other+      uses of these in user configs might need to be adapted.++  * `XMonad.Actions.TopicSpace`++    - Deprecated the `maxTopicHistory` field, as well as the+      `getLastFocusedTopics` and `setLastFocusedTopic` functions.  It is+      now recommended to directly use `XMonad.Hooks.WorkspaceHistory`+      instead.++    - Added `TopicItem`, as well as the helper functions `topicNames`,+      `tiActions`, `tiDirs`, `noAction`, and `inHome` for a more+      convenient specification of topics.++  * `XMonad.Actions.CycleRecentWS`++    - Changed the signature of `recentWS` to return a `[WorkspaceId]`+      instead of a `[WindowSet]`, while `cycleWindowSets` and+      `toggleWindowSets` now take a function `WindowSet ->+      [WorkspaceId]` instead of one to `[WindowSet]` as their first+      argument.  This fixes the interplay between this module and any+      layout that stores state.++  * `XMonad.Layout.LayoutCombinators`++    - Moved the alternative `(|||)` function and `JumpToLayout` to the+      xmonad core.  They are re-exported by the module, but do not add any+      new functionality.  `NewSelect` now exists as a deprecated type+      alias to `Choose`.++    - Removed the `Wrap` and `NextLayoutNoWrap` data constructors.++  - `XMonad.Actions.CycleWS`++    - Deprecated `EmptyWS`, `HiddenWS`, `NonEmptyWS`, `HiddenNonEmptyWS`,+      `HiddenEmptyWS`, `AnyWS` and `WSTagGroup`.++  - `XMonad.Actions.GridSelect`++    - `colorRangeFromClassName` now uses different hash function,+      so colors of inactive window tiles will be different (but still inside+      the provided color range).++  * `XMonad.Actions.Search`++    - Removed outdated `isohunt` search engine.++    - Updated URLs for `codesearch`, `openstreetmap`, and `thesaurus`+      search engines.++    - Added `github` search engine.++### New Modules++  * `XMonad.Layout.FixedAspectRatio`++    Layout modifier for user provided per-window aspect ratios.++  * `XMonad.Hooks.TaffybarPagerHints`++    Add a module that exports information about XMonads internal state that is+    not available through EWMH that is used by the taffybar status bar.++  * `XMonad.Hooks.StatusBar.PP`++    Originally contained inside `XMonad.Hooks.DynamicLog`, this module provides the+    pretty-printing abstraction and utilities, used primarly with `logHook`.++    Below are changes from `XMonad.Hooks.DynamicLog`, that now are included in+    this module:++    - Added `shortenLeft` function, like existing `shorten` but shortens by+      truncating from left instead of right. Useful for showing directories.++    - Added `shorten'` and `shortenLeft'` functions with customizable overflow+      markers.++    - Added `filterOutWsPP` for filtering out certain workspaces from being+      displayed.++    - Added `xmobarBorder` for creating borders around strings and+      `xmobarFont` for selecting an alternative font.++    - Added `ppRename` to `PP`, which makes it possible for extensions like+      `workspaceNamesPP`, `marshallPP` and/or `clickablePP` (which need to+      access the original `WorkspaceId`) to compose intuitively.++    - Added `ppPrinters`, `WSPP` and `fallbackPrinters` as a generalization of+      the `ppCurrent`, `ppVisible`… sextet, which makes it possible for+      extensions like `copiesPP` (which acts as if there was a+      `ppHiddenWithCopies`) to compose intuitively.++  * `XMonad.Hooks.StatusBar`++    This module provides a new interface that replaces `XMonad.Hooks.DynamicLog`,+    by providing composoble status bars. Supports property-based as well+    as pipe-based status bars.++  * `XMonad.Util.Hacks`++    A collection of hacks and fixes that should be easily acessible to users:++    - `windowedFullscreenFix` fixes fullscreen behaviour of chromium based+      applications when using windowed fullscreen.++    - `javaHack` helps when dealing with Java applications that might not work+      well with xmonad.++    - `trayerAboveXmobarEventHook` reliably stacks trayer on top of xmobar and+      below other windows++  * `XMonad.Util.ActionCycle`++    A module providing a simple way to implement "cycling" `X` actions,+    useful for things like alternating toggle-style keybindings.++  * `XMonad.Actions.RotateSome`++    Functions for rotating some elements around the stack while keeping others+    anchored in place. Useful in combination with layouts that dictate window+    visibility based on stack position, such as `XMonad.Layout.LimitWindows`.++    Export `surfaceNext` and `surfacePrev` actions, which treat the focused window+    and any hidden windows as a ring that can be rotated through the focused position.++    Export `rotateSome`, a pure function that rotates some elements around a stack+    while keeping others anchored in place.++  * `XMonad.Actions.Sift`++    Provide `siftUp` and `siftDown` actions, which behave like `swapUp` and `swapDown`+    but handle the wrapping case by exchanging the windows at either end of the stack+    instead of rotating the stack.++  * `XMonad.Hooks.DynamicIcons`++    Dynamically augment workspace names logged to a status bar via DynamicLog+    based on the contents (windows) of the workspace.++  * `XMonad.Hooks.WindowSwallowing`++    HandleEventHooks that implement window swallowing or sublayouting:+    Hide parent windows like terminals when opening other programs (like image viewers) from within them,+    restoring them once the child application closes.++  * `XMonad.Actions.TiledWindowDragging`++    An action that allows you to change the position of windows by dragging them around.++  * `XMonad.Layout.ResizableThreeColumns`++    A layout based on `XMonad.Layout.ThreeColumns` but with each slave window's+    height resizable.++  * `XMonad.Layout.TallMastersCombo`++    A layout combinator that support Shrink, Expand, and IncMasterN just as+    the `Tall` layout, and also support operations of two master windows:+    a main master, which is the original master window;+    a sub master, the first window of the second pane.+    This combinator can be nested, and has a good support for using+    `XMonad.Layout.Tabbed` as a sublayout.++  * `XMonad.Actions.PerWindowKeys`++    Create actions that run on a `Query Bool`, usually associated with+    conditions on a window, basis. Useful for creating bindings that are+    excluded or exclusive for some windows.++  * `XMonad.Util.DynamicScratchpads`++    Declare any window as a scratchpad on the fly. Once declared, the+    scratchpad behaves like `XMonad.Util.NamedScratchpad`.++  * `XMonad.Prompt.Zsh`++    A version of `XMonad.Prompt.Shell` that lets you use completions supplied by+    zsh.++  * `XMonad.Util.ClickableWorkspaces`++    Provides `clickablePP`, which when applied to the `PP` pretty-printer used by+    `XMonad.Hooks.StatusBar.PP`, will make the workspace tags clickable in XMobar+    (for switching focus).++  * `XMonad.Layout.VoidBorders`++    Provides a modifier that semi-permanently (requires manual intervention)+    disables borders for windows from the layout it modifies.++  * `XMonad.Hooks.Focus`++    Extends ManageHook EDSL to work on focused windows and current workspace.++  * `XMonad.Config.LXQt`++    This module provides a config suitable for use with the LXQt desktop+    environment.++  * `XMonad.Prompt.OrgMode`++    A prompt for interacting with [org-mode](https://orgmode.org/).  It+    can be used to quickly save TODOs, NOTEs, and the like with the+    additional capability to schedule/deadline a task, or use the+    primary selection as the contents of the note.++  * `XMonad.Util.ExtensibleConf`++    Extensible and composable configuration for contrib modules. Allows+    contrib modules to store custom configuration values inside `XConfig`.+    This lets them create custom hooks, ensure they hook into xmonad core only+    once, and possibly more.++  * `XMonad.Hooks.Rescreen`++    Custom hooks for screen (xrandr) configuration changes. These can be used+    to restart/reposition status bars or systrays automatically after xrandr,+    as well as to actually invoke xrandr or autorandr when an output is+    (dis)connected.++  * `XMonad.Actions.EasyMotion`++    A new module that allows selection of visible screens using a key chord.+    Inspired by [vim-easymotion](https://github.com/easymotion/vim-easymotion). See the animation+    in the vim-easymotion repo to get some idea of the functionality of this+    EasyMotion module.++### Bug Fixes and Minor Changes++  * Add support for GHC 9.0.1.++  * `XMonad.Actions.WithAll`++    - Added `killOthers`, which kills all unfocused windows on the+      current workspace.++  * `XMonad.Prompt.XMonad`++    - Added `xmonadPromptCT`, which allows you to create an XMonad+      prompt with a custom title.++  * `XMonad.Actions.DynamicWorkspaceGroups`++    - Add support for `XMonad.Actions.TopicSpace` through `viewTopicGroup` and+      `promptTopicGroupView`.++  * `XMonad.Actions.TreeSelect`++    - Fix swapped green/blue in foreground when using Xft.++    - The spawned tree-select window now sets a `WM_CLASS` property.+      This allows other applications, like compositors, to properly+      match on it.++  * `XMonad.Layout.Fullscreen`++    - Add fullscreenSupportBorder which uses smartBorders to remove+      window borders when the window is fullscreen.++  * `XMonad.Config.Mate`++    - Split out the logout dialog and add a shutdown dialog. The default behavior+      remains the same but there are now `mateLogout` and `mateShutdown` actions+      available.++    - Add mod-d keybinding to open the Mate main menu.++  * `XMonad.Actions.DynamicProjects`++    - The `changeProjectDirPrompt` function respects the `complCaseSensitivity` field+      of `XPConfig` when performing directory completion.++    - `modifyProject` is now exported.++  * `XMonad.Layout.WorkspaceDir`++    - The `changeDir` function respects the `complCaseSensitivity` field of `XPConfig`+      when performing directory completion.++    - `Chdir` message is exported, so it's now possible to change the+      directory programmaticaly, not just via a user prompt.++  * `XMonad.Prompt.Directory`++    - Added `directoryMultipleModes'`, like `directoryMultipleModes` with an additional+     `ComplCaseSensitivity` argument.++    - Directory completions are now sorted.++    - The `Dir` constructor now takes an additional `ComplCaseSensitivity`+      argument to indicate whether directory completion is case sensitive.++  * `XMonad.Prompt.FuzzyMatch`++    - `fuzzySort` will now accept cases where the input is not a subsequence of+      every completion.++  * `XMonad.Prompt.Shell`++    - Added `getShellCompl'`, like `getShellCompl` with an additional `ComplCaseSensitivity`+      argument.++    - Added `compgenDirectories` and `compgenFiles` to get the directory/filename completion+      matches returned by the compgen shell builtin.++    - Added `safeDirPrompt`, which is like `safePrompt`, but optimized+      for the use-case of a program that needs a file as an argument.++  * `XMonad.Prompt.Unicode`++    - Reworked internally to call `spawnPipe` (asynchronous) instead of+      `runProcessWithInput` (synchronous), which fixes `typeUnicodePrompt`.++    - Now respects `searchPredicate` and `sorter` from user-supplied `XPConfig`.++  * `XMonad.Hooks.DynamicLog`++    - Added `xmobarProp`, for property-based alternative to `xmobar`.++    - Add the -dock argument to the dzen spawn arguments++    - The API for this module is frozen: this is now a compatibility wrapper.++    - References for this module are updated to point to `X.H.StatusBar` or+      `X.H.StatusBar.PP`++  * `XMonad.Layout.BoringWindows`++    - Added boring-aware `swapUp`, `swapDown`, `siftUp`, and `siftDown` functions.++    - Added `markBoringEverywhere` function, to mark the currently+      focused window boring on all layouts, when using `XMonad.Actions.CopyWindow`.++  * `XMonad.Util.NamedScratchpad`++     - Added two new exported functions to the module:+         - `customRunNamedScratchpadAction`+             (provides the option to customize the `X ()` action the scratchpad is launched by)+         - `spawnHereNamedScratchpadAction`+             (uses `XMonad.Actions.SpawnOn.spawnHere` to initially start the scratchpad on the workspace it was launched on)++     - Deprecated `namedScratchpadFilterOutWorkspace` and+       `namedScratchpadFilterOutWorkspacePP`.  Use+       `XMonad.Util.WorkspaceCompare.filterOutWs` respectively+       `XMonad.Hooks.DynamicLog.filterOutWsPP` instead.++     - Exported the `scratchpadWorkspaceTag`.++     - Added a new logHook `nsHideOnFocusLoss` for hiding scratchpads+       when they lose focus.++  * `XMonad.Prompt.Window`++    - Added `allApplications` function which maps application executable+      names to its underlying window.++    - Added a `WithWindow` constructor to `WindowPrompt` to allow executing+      actions of type `Window -> X ()` on the chosen window.++  * `XMonad.Prompt.WindowBringer`++    - Added `windowAppMap` function which maps application executable+      names to its underlying window.++    - A new field `windowFilter` was added to the config, which allows the user+      to provide a function which will decide whether each window should be+      included in the window bringer menu.++  * `XMonad.Actions.Search`++    - The `hoogle` function now uses the new URL `hoogle.haskell.org`.++    - Added `promptSearchBrowser'` function to only suggest previous searches of+      the selected search engine (instead of all search engines).++  * `XMonad.Layout.MouseResizableTile`++    - When we calculate dragger widths, we first try to get the border width of+      the focused window, before failing over to using the initial `borderWidth`.++  * `XMonad.Actions.CycleRecentWS`++    - Added `cycleRecentNonEmptyWS` function which behaves like `cycleRecentWS`+      but is constrainded to non-empty workspaces.++    - Added `toggleRecentWS` and `toggleRecentNonEmptyWS` functions which toggle+      between the current and most recent workspace, and continue to toggle back+      and forth on repeated presses, rather than cycling through other workspaces.++    - Added `recentWS` function which allows the recency list to be filtered with+      a user-provided predicate.++  * `XMonad.Layout.Hidden`++    - Export `HiddenWindows` type constructor.++    - Export `popHiddenWindow` function restoring a specific window.++  * `XMonad.Hooks.ManageDocks`++    - Export `AvoidStruts` constructor++    - Restored compatibility with pre-0.13 configs by making the startup hook+      unnecessary for correct functioning (strut cache is initialized on-demand).++      This is a temporary measure, however. The individual hooks are now+      deprecated in favor of the `docks` combinator, `xmonad --recompile` now+      reports deprecation warnings, and the hooks will be removed soon.++    - Fixed ignoring of strut updates from override-redirect windows, which is+      default for xmobar.++      Previously, if one wanted xmobar to reposition itself after xrandr+      changes and have xmonad handle that repositioning, one would need to+      configure xmobar with `overrideRedirect = False`, which would disable+      lowering on start and thus cause other problems. This is no longer+      necessary.++  * `XMonad.Hooks.ManageHelpers`++    - Export `doSink`++    - Added `doLower` and `doRaise`++    - Added `shiftToSame` and `clientLeader` which allow a hook to be created+      that shifts a window to the workspace of other windows of the application+      (using either the `WM_CLIENT_LEADER` or `_NET_WM_PID` property).++    - Added `windowTag`++    - Added `(^?)`, `(~?)` and `($?)` operators as infix versions of `isPrefixOf`, `isInfixOf`+      and `isSuffixOf` working with `ManageHook`s.++  * `XMonad.Util.EZConfig`++    - Added support for XF86Bluetooth.++  * `XMonad.Util.Loggers`++    - Make `battery` and `loadAvg` distro-independent.++    - Added `logTitleOnScreen`, `logCurrentOnScreen` and `logLayoutOnScreen`+      as screen-specific variants of `logTitle`, `logCurrent` and `logLayout`.++    - Added `logWhenActive` to have loggers active only when a certain+      screen is active.++    - Added `logConst` to log a constant `String`, and `logDefault` (infix: `.|`)+      to combine loggers.++    - Added `logTitles` to log all window titles (focused and unfocused+      ones) on the focused workspace, as well as `logTitlesOnScreen` as+      a screen-specific variant thereof.++    - Added `logTitles'` and `logTitleOnScreen'`.  These act like+      `logTitles` and `logTitlesOnScreen` but use a record as an input+      to enable logging for more window types.  For example, currently+      urgent windows are additionally supported.++  * `XMonad.Layout.Minimize`++    - Export `Minimize` type constructor.++  * `XMonad.Actions.WorkspaceNames`++    - Added `workspaceNamesEwmh` which makes workspace names visible to+      external pagers.++  * `XMonad.Util.PureX`++    - Added `focusWindow` and `focusNth` which don't refresh (and thus+      possibly flicker) when they happen to be a no-op.++    - Added `shiftWin` as a refresh tracking version of `W.shiftWin`.++  * Several `LayoutClass` instances now have an additional `Typeable`+    constraint which may break some advanced configs. The upside is that we+    can now add `Typeable` to `LayoutClass` in `XMonad.Core` and make it+    possible to introspect the current layout and its modifiers.++  * `XMonad.Actions.TopicSpace`++    - `switchTopic` now correctly updates the last used topics.++    - `setLastFocusedTopic` will now check whether we have exceeded the+      `maxTopicHistory` and prune the topic history as necessary, as well as+      cons the given topic onto the list __before__ filtering it.++    - Added `switchNthLastFocusedExclude`, which works like+      `switchNthLastFocused` but is able to exclude certain topics.++    - Added `switchTopicWith`, which works like `switchTopic`, but one is able+      to give `setLastFocusedTopic` a custom filtering function as well.++    - Instead of a hand-rolled history, use the one from+      `XMonad.Hooks.WorkspaceHistory`.++    - Added the screen-aware functions `getLastFocusedTopicsByScreen` and+      `switchNthLastFocusedByScreen`.++  * `XMonad.Hooks.WorkspaceHistory`++    - Added `workspaceHistoryModify` to modify the workspace history with a pure+      function.++    - Added `workspaceHistoryHookExclude` for excluding certain+      workspaces to ever enter the history.++  * `XMonad.Util.DebugWindow`++    - Fixed a bottom in `debugWindow` when used on windows with UTF8 encoded titles.++  * `XMonad.Config.Xfce`++    - Set `terminal` to `xfce4-terminal`.++  * `XMonad.Hooks.WorkspaceCompare`++    - Added `filterOutWs` for workspace filtering.++  * `XMonad.Prompt`++    - Accommodate completion of multiple words even when `alwaysHighlight` is+      enabled.++    - Made the history respect words that were "completed" by `alwaysHighlight`+      upon confirmation of the selection by the user.++    - Fixed a crash when focusing a new window while the prompt was up+      by allowing pointer events to pass through the custom prompt event+      loop.++    - The prompt now cycles through its suggestions if one hits the ends+      of the suggestion list and presses `TAB` again.++    - Added `maxComplColumns` field to `XPConfig`, to limit the number of+      columns in the completion window.++    - Redefine `ComplCaseSensitivity` to a proper sum type as opposed to+      a `newtype` wrapper around `Bool`.++  * `XMonad.Actions.TreeSelect`++    - Fixed a crash when focusing a new window while the tree select+      window was up by allowing pointer events to pass through the+      custom tree select event loop.++  * `XMonad.Layout.NoBorders`++    - Fixed handling of floating window borders in multihead setups that was+      broken since 0.14.++    - Added `OnlyFloat` constructor to `Ambiguity` to unconditionally+      remove all borders on floating windows.++  * `XMonad.Hooks.UrgencyHook`++    - It's now possible to clear urgency of selected windows only using the+      newly exported `clearUrgents'` function. Also, this and `clearUrgents`+      now clear the `_NET_WM_STATE_DEMANDS_ATTENTION` bit as well.++    - Added a variant of `filterUrgencyHook` that takes a generic `Query Bool`+      to select which windows should never be marked urgent.++    - Added `askUrgent` and a `doAskUrgent` manage hook helper for marking+      windows as urgent from inside of xmonad. This can be used as a less+      intrusive action for windows requesting focus.++  * `XMonad.Hooks.ServerMode`++    - To make it easier to use, the `xmonadctl` client is now included in+      `scripts/`.++  * `XMonad.Layout.TrackFloating`++    - Fixed a bug that prevented changing focus on inactive workspaces.++  * `XMonad.Layout.Magnifier`++    - Added `magnifierczOff` and `magnifierczOff'` for custom-size+      magnifiers that start out with magnifying disabled.++    - Added `magnify` as a more general combinator, including the+      ability to postpone magnifying until there are a certain number of+      windows on the workspace.++  * `XMonad.Layout.Renamed`++    - Added `KeepWordsLeft` and `KeepWordsRight` for keeping certain number of+      words in left or right direction in layout description.++  * `XMonad.Hooks.WallpaperSetter`++    - Added `defWPNamesPng`, which works like `defWPNames` but maps+      `ws-name` to `ws-name.png` instead of `ws-name.jpg`.++    - Added `defWPNamesJpg` as an alias to `defWPNames` and deprecated+      the latter.++  * `XMonad.Layout.SubLayouts`++    - Floating windows are no longer moved to the end of the window stack.++  * `XMonad.Layout.BinarySpacePartition`++    - Add the ability to increase/decrease the window size by a custom+      rational number. E.g: `sendMessage $ ExpandTowardsBy L 0.02`++  * `XMonad.Layout.Decoration`++    - The decoration window now sets a `WM_CLASS` property.  This allows+      other applications, like compositors, to properly match on it.++  * `XMonad.Layout.IndependentScreens`++    - Fixed a bug where `marshallPP` always sorted workspace names+      lexically.  This changes the default behaviour of `marshallPP`—the+      given `ppSort` now operates in the _physical_ workspace names.+      The documentation of `marshallSort` contains an example of how to+      get the old behaviour, where `ppSort` operates in virtual names,+      back.++    - Added `workspacesOn` for filtering workspaces on the current screen.++    - Added `withScreen` to specify names for a given single screen.++    - Added new aliases `PhysicalWindowSpace` and `VirtualWindowSpace`+      for a `WindowSpace` for easier to read function signatures.++    - Added a few useful utility functions related to simplify using the+      module; namely `workspaceOnScreen`, `focusWindow'`, `focusScreen`,+      `nthWorkspace`, and `withWspOnScreen`.++    - Fixed wrong type-signature of `onCurrentScreen`.++  * `XMonad.Actions.CopyWindow`++    - Added `copiesPP` to make a `PP` aware of copies of the focused+      window.++  - `XMonad.Actions.CycleWS`++    - Added `:&:`, `:|:` and `Not` data constructors to `WSType` to logically+      combine predicates.++    - Added `hiddenWS`, `emptyWS` and `anyWS` to replace deprecated+      constructors.++    - Added `ingoringWSs` as a `WSType` predicate to skip workspaces having a+      tag in a given list.++  - `XMonad.Actions.DynamicWorkspaceOrder`++    - Added `swapWithCurrent` and `swapOrder` to the list of exported names.++  - `XMonad.Actions.Submap`, `XMonad.Util.Ungrab`:++    - Fixed issue with keyboard/pointer staying grabbed when a blocking action+      like `runProcessWithInput` was invoked.++  - `XMonad.Actions.UpdateFocus`++    - Added `focusUnderPointer`, that updates the focus based on pointer+      position, an inverse of `X.A.UpdatePointer`, which moves the mouse+      pointer to match the focused window). Together these can be used to+      ensure focus stays in sync with mouse.++  - `XMonad.Layout.MultiToggle`++    - Added `isToggleActive` for querying the toggle state of transformers.+      Useful to show the state in a status bar.++  * `XMonad.Layout.Spacing`++    - Removed deprecations for `spacing`, `spacingWithEdge`,+      `smartSpacing`, and `smartSpacingWithEdge`.++  * `XMonad.Actions.DynamicWorkspaces`++    - Fixed a system freeze when using `X.A.CopyWindow.copy` in+      combination with `removeWorkspace`.++    - `withWorkspace` now honors the users `searchPredicate`, for+      example `fuzzyMatch` from `Prompt.FuzzyMatch`.++## 0.16++### Breaking Changes++  * `XMonad.Layout.Decoration`+    - Added `Theme` record fields for controlling decoration border width for active/inactive/urgent windows.+  * `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.+  * `XMonad.Util.Invisble`+    - Requires `MonadFail` for `Read` instance++### 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.++  * `XMonad.Actions.Prefix`++    A module that allows the user to use an Emacs-style prefix+    argument (raw or numeric).++### Bug Fixes and Minor Changes++  * `XMonad.Layout.Tabbed`++    tabbedLeft and tabbedRight will set their tabs' height and width according to decoHeight/decoWidth++  * `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.Prompt.Pass`++    Added 'passOTPPrompt' to support getting OTP type password. This require+    pass-otp (https://github.com/tadfisher/pass-otp) has been setup in the running+    machine.++    Added 'passGenerateAndCopyPrompt', which both generates a new password and+    copies it to the clipboard.  These two actions are commonly desirable to+    take together, e.g. when establishing a new account.++    Made password prompts traverse symlinks when gathering password names for+    autocomplete.++  * `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.+++  * `XMonad.Hooks.WallpaperSetter`++    Preserve the aspect ratio of wallpapers that xmonad sets. When previous+    versions would distort images to fit the screen size, it will now find a+    best fit by cropping instead.++  * `XMonad.Util.Themes`++    Add adwaitaTheme and adwaitaDarkTheme to match their respective+    GTK themes.++  * 'XMonad.Layout.BinarySpacePartition'++    Add a new `SplitShiftDirectional` message that allows moving windows by+    splitting its neighbours.++  * `XMonad.Prompt.FuzzyMatch`++    Make fuzzy sort show shorter strings first.++## 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.++  * `XMonad.Layout.Minimize`++     Though the interface it offers is quite similar, this module has been+     almost completely rewritten. The new `XMonad.Actions.Minimize` contains+     several functions that allow interaction with minimization window state.+     If you are using this module, you must upgrade your configuration to import+     `X.A.Minimize` and use `maximizeWindow` and `withLastMinimized` instead of+     sending messages to `Minimized` layout. `XMonad.Hooks.RestoreMinimized` has+     been completely deprecated, and its functions have no effect.++  * `XMonad.Prompt.Unicode`++    - `unicodePrompt :: String -> XPConfig -> X ()` now additionally takes a+      filepath to the `UnicodeData.txt` file containing unicode data.++  * `XMonad.Actions.PhysicalScreens`++    `getScreen`, `viewScreen`, `sendToScreen`, `onNextNeighbour`, `onPrevNeighbour` now need a extra parameter+    of type `ScreenComparator`. This allow the user to specify how he want his screen to be ordered default+    value are:++     - `def`(same as verticalScreenOrderer) will keep previous behavior+     - `verticalScreenOrderer`+     - `horizontalScreenOrderer`++    One can build his custom ScreenOrderer using:+     - `screenComparatorById` (allow to order by Xinerama id)+     - `screenComparatorByRectangle` (allow to order by screen coordonate)+     - `ScreenComparator` (allow to mix ordering by screen coordonate and xinerama id)++  * `XMonad.Util.WorkspaceCompare`++    `getXineramaPhysicalWsCompare` now need a extra argument of type `ScreenComparator` defined in+    `XMonad.Actions.PhysicalScreens` (see changelog of this module for more information)++  * `XMonad.Hooks.EwmhDesktops`++    - Simplify ewmhDesktopsLogHookCustom, and remove the gnome-panel specific+      remapping of all visible windows to the active workspace (#216).+    - Handle workspace renames that might be occuring in the custom function+      that is provided to ewmhDesktopsLogHookCustom.++  * `XMonad.Hooks.DynamicLog`++    - Support xmobar's \<action> and \<raw> tags; see `xmobarAction` and+      `xmobarRaw`.++  * `XMonad.Layout.NoBorders`++    The layout now maintains a list of windows that never have borders, and a+    list of windows that always have borders. Use `BorderMessage` to manage+    these lists and the accompanying event hook (`borderEventHook`) to remove+    destroyed windows from them. Also provides the `hasBorder` manage hook.++    Two new conditions have been added to `Ambiguity`: `OnlyLayoutFloat` and+    `OnlyLayoutFloatBelow`; `OnlyFloat` was renamed to `OnlyScreenFloat`.  See+    the documentation for more information.++    The type signature of `hiddens` was changed to accept a new `Rectangle`+    parameter representing the bounds of the parent layout, placed after the+    `WindowSet` parameter. Anyone defining a new instance of `SetsAmbiguous`+    will need to update their configuration. For example, replace "`hiddens amb+    wset mst wrs =`" either with "`hiddens amb wset _ mst wrs =`" or to make+    use of the new parameter with "`hiddens amb wset lr mst wrs =`".++  * `XMonad.Actions.MessageFeedback`++    - Follow the naming conventions of `XMonad.Operations`. Functions returning+      `X ()` are named regularly (previously these ended in underscore) while+      those returning `X Bool` are suffixed with an uppercase 'B'.+    - Provide all `X Bool` and `SomeMessage` variations for `sendMessage` and+      `sendMessageWithNoRefresh`, not just `sendMessageWithNoRefreshToCurrent`+      (renamed from `send`).+    - The new `tryInOrderB` and `tryMessageB` functions accept a parameter of+      type `SomeMessage -> X Bool`, which means you are no longer constrained+      to the behavior of the `sendMessageWithNoRefreshToCurrent` dispatcher.+    - The `send*Messages*` family of funtions allows for sequencing arbitrary+      sets of messages with minimal refresh. It makes little sense for these+      functions to support custom message dispatchers.+    - Remain backwards compatible. Maintain deprecated aliases of all renamed+      functions:+      - `send`          -> `sendMessageWithNoRefreshToCurrentB`+      - `sendSM`        -> `sendSomeMessageWithNoRefreshToCurrentB`+      - `sendSM_`       -> `sendSomeMessageWithNoRefreshToCurrent`+      - `tryInOrder`    -> `tryInOrderWithNoRefreshToCurrentB`+      - `tryInOrder_`   -> `tryInOrderWithNoRefreshToCurrent`+      - `tryMessage`    -> `tryMessageWithNoRefreshToCurrentB`+      - `tryMessage_`   -> `tryMessageWithNoRefreshToCurrent`++### New Modules++  * `XMonad.Layout.MultiToggle.TabBarDecoration`++    Provides a simple transformer for use with `XMonad.Layout.MultiToggle` to+    dynamically toggle `XMonad.Layout.TabBarDecoration`.++  * `XMonad.Hooks.RefocusLast`++    Provides hooks and actions that keep track of recently focused windows on a+    per workspace basis and automatically refocus the last window on loss of the+    current (if appropriate as determined by user specified criteria).++  * `XMonad.Layout.StateFull`++    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.++  * `XMonad.Actions.SwapPromote`++    Module for tracking master window history per workspace, and associated+    functions for manipulating the stack using such history.++  * `XMonad.Actions.CycleWorkspaceByScreen`++    A new module that allows cycling through previously viewed workspaces in the+    order they were viewed most recently on the screen where cycling is taking+    place.++    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.++  * `XMonad.Actions.SpawnOn`++    - Bind windows spawns by child processes of the original window to the same+      workspace as the original window.++  * `XMonad.Util.WindowProperties`++    - Added the ability to test if a window has a tag from+      `XMonad.Actions.TagWindows`++  * `XMonad.Layout.Magnifier`++    - Handle `IncMasterN` messages.++  * `XMonad.Util.EZConfig`++    - Can now parse Latin1 keys, to better accommodate users with+      non-US keyboards.++  * `XMonad.Actions.Submap`++    Establish pointer grab to avoid freezing X, when button press occurs after+    submap key press.  And terminate submap at button press in the same way,+    as we do for wrong key press.++  * `XMonad.Hooks.SetWMName`++    Add function `getWMName`.++  * `XMonad.Hooks.ManageHelpers`++    - Make type of ManageHook combinators more general.+    - New manage hook `doSink` for sinking windows (as upposed to the `doFloat` manage hook)++  * `XMonad.Prompt`++    Export `insertString`.++  * `XMonad.Prompt.Window`++    - New function: `windowMultiPrompt` for using `mkXPromptWithModes`+      with window prompts.++  * `XMonad.Hooks.WorkspaceHistory`++    - Now supports per screen history.++  * `XMonad.Layout.ComboP`++    - New `PartitionWins` message to re-partition all windows into the+      configured sub-layouts.  Useful when window properties have+      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++  * The type of `completionKey` (of `XPConfig` record) has been+    changed from `KeySym` to `(KeyMask, KeySym)`. The default value+    for this is still bound to the `Tab` key.++  * New constructor `CenteredAt Rational Rational` added for+    `XMonad.Prompt.XPPosition`.++  * `XMonad.Prompt` now stores its history file in the XMonad cache+    directory in a file named `prompt-history`.++  * `XMonad.Hooks.ManageDocks` now requires an additional startup hook to be+    added to configuration in addition to the other 3 hooks, otherwise docks+    started before xmonad are covered by windows. It's recommended to use the+    newly introduced `docks` function to add all necessary hooks to xmonad+    config.++### New Modules++  * `XMonad.Layout.SortedLayout`++    A new LayoutModifier that sorts a given layout by a list of+    properties. The order of properties in the list determines+    the order of windows in the final layout. Any unmatched windows+    go to the end of the order.++  * `XMonad.Prompt.Unicode`++    A prompt to search a unicode character by its name, and put it into the+    clipboard.++  * `XMonad.Util.Ungrab`++    Release xmonad's keyboard and pointer grabs immediately, so+    screen grabbers and lock utilities, etc. will work. Replaces+    the short sleep hackaround.++  * `XMonad.Util.Loggers.NamedScratchpad`++    A collection of Loggers (see `XMonad.Util.Loggers`) for NamedScratchpads+    (see `XMonad.Util.NamedScratchpad`).++  * `XMonad.Util.NoTaskbar`++    Utility function and `ManageHook` to mark a window to be ignored by+    EWMH taskbars and pagers. Useful for `NamedScratchpad` windows, since+    you will usually be taken to the `NSP` workspace by them.++### Bug Fixes and Minor Changes++  * `XMonad.Hooks.ManageDocks`++    - Fix a very annoying bug where taskbars/docs would be+      covered by windows.++    - Also fix a bug that caused certain Gtk and Qt application to+      have issues displaying menus and popups.++  * `XMonad.Layout.LayoutBuilder`++    Merge all functionality from `XMonad.Layout.LayoutBuilderP` into+    `XMonad.Layout.LayoutBuilder`.++  * `XMonad.Actions.WindowGo`++    - Fix `raiseNextMaybe` cycling between 2 workspaces only.++  * `XMonad.Actions.UpdatePointer`++    - Fix bug when cursor gets stuck in one of the corners.++  * `XMonad.Actions.DynamicProjects`++    - Switching away from a dynamic project that contains no windows+      automatically deletes that project's workspace.++      The project itself was already being deleted, this just deletes+      the workspace created for it as well.++    - Added function to change the working directory (`changeProjectDirPrompt`)++    - All of the prompts are now multiple mode prompts.  Try using the+      `changeModeKey` in a prompt and see what happens!++## 0.12 (December 14, 2015)++### Breaking Changes++  * `XMonad.Actions.UpdatePointer.updatePointer` arguments were+    changed. This allows including aspects of both of the+    `TowardsCentre` and `Relative` methods. To keep the same behavior,+    replace the entry in the left column with the entry on the right:++    | < 0.12                              |   >= 0.12                        |+    |-------------------------------------|----------------------------------|+    | `updatePointer Nearest`             | `updatePointer (0.5, 0.5) (1,1)` |+    | `updatePointer (Relative x y)`      | `updatePointer (x,y) (0,0)`      |+    | `updatePointer (TowardsCentre x y)` | `updatePointer (0.5,0.5) (x,y)`  |++### New Modules++  * `XMonad.Actions.AfterDrag`++    Perform an action after the current mouse drag is completed.++  * `XMonad.Actions.DynamicProjects`++    Imbues workspaces with additional features so they can be treated+    as individual project areas.++  * `XMonad.Actions.LinkWorkspaces`++    Provides bindings to add and delete links between workspaces. It+    is aimed at providing useful links between workspaces in a+    multihead setup. Linked workspaces are viewed at the same time.++  * `XMonad.Config.Bepo`++    This module fixes some of the keybindings for the francophone+    among you who use a BEPO keyboard layout. Based on+    `XMonad.Config.Azerty`++  * `XMonad.Config.Dmwit`++    Daniel Wagner's configuration.++  * `XMonad.Config.Mate`++    This module provides a config suitable for use with the MATE+    desktop environment.++  * `XMonad.Config.Prime`++    A draft of a brand new config syntax for xmonad.++  * `XMonad.Hooks.DynamicProperty`++    Module to apply a `ManageHook` to an already-mapped window when a+    property changes. This would commonly be used to match browser+    windows by title, since the final title will only be set after (a)+    the window is mapped, (b) its document has been loaded, (c) all+    load-time scripts have run.++  * `XMonad.Hooks.ManageDebug`++    A `manageHook` and associated `logHook` for debugging `ManageHook`s.+    Simplest usage: wrap your xmonad config in the `debugManageHook`+    combinator.  Or use `debugManageHookOn` for a triggerable version,+    specifying the triggering key sequence in `XMonad.Util.EZConfig`+    syntax. Or use the individual hooks in whatever way you see fit.++  * `XMonad.Hooks.WallpaperSetter`++    Log hook which changes the wallpapers depending on visible+    workspaces.++  * `XMonad.Hooks.WorkspaceHistory`++    Keeps track of workspace viewing order.++  * `XMonad.Layout.AvoidFloats`++    Find a maximum empty rectangle around floating windows and use+    that area to display non-floating windows.++  * `XMonad.Layout.BinarySpacePartition`++    Layout where new windows will split the focused window in half,+    based off of BSPWM.++  * `XMonad.Layout.Dwindle`++    Three layouts: The first, `Spiral`, is a reimplementation of+    `XMonad.Layout.Spiral.spiral` with, at least to me, more intuitive+    semantics.  The second, `Dwindle`, is inspired by a similar layout+    in awesome and produces the same sequence of decreasing window+    sizes as Spiral but pushes the smallest windows into a screen+    corner rather than the centre.  The third, `Squeeze` arranges all+    windows in one row or in one column, with geometrically decreasing+    sizes.++  * `XMonad.Layout.Hidden`++    Similar to `XMonad.Layout.Minimize` but completely removes windows+    from the window set so `XMonad.Layout.BoringWindows` isn't+    necessary.  Perfect companion to `XMonad.Layout.BinarySpacePartition`+    since it can be used to move windows to another part of the BSP tree.++  * `XMonad.Layout.IfMax`++    Provides `IfMax` layout, which will run one layout if there are+    maximum `N` windows on workspace, and another layout, when number+    of windows is greater than `N`.++  * `XMonad.Layout.PerScreen`++    Configure layouts based on the width of your screen; use your+    favorite multi-column layout for wide screens and a full-screen+    layout for small ones.++  * `XMonad.Layout.Stoppable`++    This module implements a special kind of layout modifier, which when+    applied to a layout, causes xmonad to stop all non-visible processes.+    In a way, this is a sledge-hammer for applications that drain power.+    For example, given a web browser on a stoppable workspace, once the+    workspace is hidden the web browser will be stopped.++  * `XMonad.Prompt.ConfirmPrompt`++    A module for setting up simple confirmation prompts for+    keybindings.++  * `XMonad.Prompt.Pass`++    This module provides 3 `XMonad.Prompt`s to ease passwords manipulation+    (generate, read, remove) via [pass](http://www.passwordstore.org/).++  * `XMonad.Util.RemoteWindows`++    This module implements a proper way of finding out whether the+    window is remote or local.++  * `XMonad.Util.SpawnNamedPipe`++    A module for spawning a pipe whose `Handle` lives in the xmonad state.++  * `XMonad.Util.WindowState`++    Functions for saving per-window data.++### Miscellaneous Changes++  * Fix issue #9: `XMonad.Prompt.Shell` `searchPredicate` is ignored,+    defaults to `isPrefixOf`++  * Fix moveHistory when alwaysHighlight is enabled++  * `XMonad.Actions.DynamicWorkspaceGroups` now exports `addRawWSGroup`++  * Side tabs were added to the tabbed layout++  * `XMonad/Layout/IndependentScreens` now exports `marshallSort`++  * `XMonad/Hooks/UrgencyHook` now exports `clearUrgency`++  * Exceptions are now caught when finding commands on `PATH` in `Prompt.Shell`++  * Switched to `Data.Default` wherever possible++  * `XMonad.Layout.IndependentScreens` now exports `whenCurrentOn`++  * `XMonad.Util.NamedActions` now exports `addDescrKeys'`++  * EWMH `DEMANDS_ATTENTION` support added to `UrgencyHook`++  * New `useTransientFor` modifier in `XMonad.Layout.TrackFloating`++  * Added the ability to remove arbitrary workspaces++## 0.9 (October 26, 2009)++### Updates that Require Changes in `xmonad.hs`++  * `XMonad.Hooks.EwmhDesktops` no longer uses `layoutHook`, the+    `ewmhDesktopsLayout` modifier has been removed from+    xmonad-contrib. It uses `logHook`, `handleEventHook`, and+    `startupHook` instead and provides a convenient function `ewmh` to+    add EWMH support to a `defaultConfig`.++  * Most `DynamicLog` users can continue with configs unchanged, but+    users of the quickbar functions `xmobar` or `dzen` will need to+    change `xmonad.hs`: their types have changed to allow easier+    composition with other `XConfig` modifiers. The `dynamicLogDzen`+    and `dynamicLogXmobar` functions have been removed.++  * `WindowGo` or `safeSpawn` users may need to change command lines+    due to `safeSpawn` changes.++  * People explicitly referencing the "SP" scratchpad workspace should+    change it to "NSP" which is also used by the new+    `Util.NamedScratchpad` module.++  * (Optional) People who explicitly use `swapMaster` in key or mouse+    bindings should change it to `shiftMaster`. It's the current+    default used where `swapMaster` had been used previously. It works+    better than `swapMaster` when using floating and tiled windows+    together on the same workspace.++## See Also++<https://wiki.haskell.org/Xmonad/Notable_changes_since_0.8>
LICENSE view
@@ -1,27 +1,26 @@-Copyright (c) The Xmonad Community+Copyright (c) The Xmonad Community. All rights reserved. -All rights reserved.+Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met: -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.-3. Neither the name of the author nor the names of his contributors-   may be used to endorse or promote products derived from this software-   without specific prior written permission.+1. Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer. -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+2. Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+may be used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− README 
@@ -1,82 +0,0 @@-  xmonad-contrib : third party extensions to the xmonad window manager--                           http://xmonad.org--    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, the documents included with the xmonad source-    distribution, and online haddock documentation:--    http://www.xmonad.org/xmonad-docs----------------------------------------------------------------------------Changelogs--    For a list of changes since the 0.8.x releases, see:--http://www.haskell.org/haskellwiki/Xmonad/Notable_changes_since_0.8----------------------------------------------------------------------------Updates to XMonadContrib-0.9 that may Require Changes to ~/.xmonad/xmonad.hs--    Please see the Changelogs and xmonad-contrib haddock documentation-    links for further details regarding the following changes.--    * XMonad.Hooks.EwmhDesktops no longer uses layoutHook, the-    ewmhDesktopsLayout modifier has been removed from xmonad-contrib. It-    uses logHook, handleEventHook, and startupHook instead and provides-    a convenient function 'ewmh' to add EWMH support to a defaultConfig.--    * Most DynamicLog users can continue with configs unchanged, but users-    of the quickbar functions 'xmobar' or 'dzen' will need to change-    xmonad.hs: their types have changed to allow easier composition with-    other XConfig modifiers. The 'dynamicLogDzen' and 'dynamicLogXmobar'-    functions have been removed.--    * WindowGo or safeSpawn users may need to change command lines due to-    safeSpawn changes.--    * People explicitly referencing the "SP" scratchpad workspace should-    change it to "NSP" which is also used by the new Util.NamedScratchpad.--    * (Optional) People who explicitly use swapMaster in key or mouse-    bindings should change it to shiftMaster. It's the current default-    used where swapMaster had been used previously. It works better than-    swapMaster when using floating and tiled windows together on the-    same workspace.----------------------------------------------------------------------------Getting or updating XMonadContrib--    latest release: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmonad-contrib--    darcs version:  darcs get http://code.haskell.org/XMonadContrib--    (To use darcs xmonad-contrib you must also use the darcs version-    of xmonad.)----------------------------------------------------------------------------Contributing--    Haskell code contributed to this repo should live under the-    appropriate subdivision of the 'XMonad.' namespace (currently-    includes Actions, Config, Hooks, Layout, Prompt, and Util). For-    example, to use the Grid layout, one would import:--        XMonad.Layout.Grid--    For further details, see the documentation for the-    XMonad.Doc.Developing module and http://xmonad.org website.----------------------------------------------------------------------------Code submitted to the contrib repo is licensed under the same license as-xmonad itself, with copyright held by the authors.--------------------------------------------------------------------------
+ README.md view
@@ -0,0 +1,82 @@+<p align="center">+  <a href="https://xmonad.org/"><img alt="XMonad logo" src="https://xmonad.org/images/logo-wrapped.svg" height=150></a>+</p>+<p align="center">+  <a href="https://hackage.haskell.org/package/xmonad-contrib"><img alt="Hackage" src="https://img.shields.io/hackage/v/xmonad-contrib?logo=haskell"></a>+  <a href="https://github.com/xmonad/xmonad-contrib/blob/readme/LICENSE"><img alt="License" src="https://img.shields.io/github/license/xmonad/xmonad-contrib"></a>+  <a href="https://haskell.org/"><img alt="Made in Haskell" src="https://img.shields.io/badge/Made%20in-Haskell-%235e5086?logo=haskell"></a>+  <br>+  <a href="https://github.com/xmonad/xmonad-contrib/actions/workflows/stack.yml"><img alt="Stack" src="https://img.shields.io/github/actions/workflow/status/xmonad/xmonad-contrib/stack.yml?label=Stack&logo=githubactions&logoColor=white"></a>+  <a href="https://github.com/xmonad/xmonad-contrib/actions/workflows/haskell-ci.yml"><img alt="Cabal" src="https://img.shields.io/github/actions/workflow/status/xmonad/xmonad-contrib/haskell-ci.yml?label=Cabal&logo=githubactions&logoColor=white"></a>+  <a href="https://github.com/xmonad/xmonad-contrib/actions/workflows/nix.yml"><img alt="Nix" src="https://img.shields.io/github/actions/workflow/status/xmonad/xmonad-contrib/nix.yml?label=Nix&logo=githubactions&logoColor=white"></a>+  <br>+  <a href="https://github.com/sponsors/xmonad"><img alt="GitHub Sponsors" src="https://img.shields.io/github/sponsors/xmonad?label=GitHub%20Sponsors&logo=githubsponsors"></a>+  <a href="https://opencollective.com/xmonad"><img alt="Open Collective" src="https://img.shields.io/opencollective/all/xmonad?label=Open%20Collective&logo=opencollective"></a>+  <br>+  <a href="https://web.libera.chat/#xmonad"><img alt="Chat on #xmonad@irc.libera.chat" src="https://img.shields.io/badge/%23%20chat-on%20libera-brightgreen"></a>+  <a href="https://matrix.to/#/#xmonad:matrix.org"><img alt="Chat on #xmonad:matrix.org" src="https://img.shields.io/matrix/xmonad:matrix.org?logo=matrix"></a>+</p>++# xmonad-contrib++**Community-maintained extensions for the [XMonad][web:xmonad] window manager.**++[xmonad core][gh:xmonad] is minimal, stable, yet extensible.+[xmonad-contrib][gh:xmonad-contrib] is home to hundreds of additional tiling+algorithms and extension modules. The two combined make for a powerful X11+window-manager with endless customization possibilities. They are, quite+literally, libraries for creating your own window manager.++## Installation++For installation and configuration instructions, please see:++ * [downloading and installing xmonad][web:download]+ * [installing latest xmonad snapshot from git][web:install]+ * [configuring xmonad][web:tutorial]++If you run into any trouble, consult our [documentation][web:documentation] or+ask the [community][web:community] for help.++## Contributing++We welcome all forms of contributions:++ * [bug reports and feature ideas][gh:xmonad-contrib:issues]+   (also to [xmonad][gh:xmonad:issues])+ * [bug fixes, new features, new extensions][gh:xmonad-contrib:pulls]+   (also to [xmonad][gh:xmonad:pulls])+ * documentation fixes and improvements: [xmonad][gh:xmonad],+   [xmonad-contrib][gh:xmonad-contrib], [xmonad-web][gh:xmonad-web]+ * helping others in the [community][web:community]+ * financial support: [GitHub Sponsors][gh:xmonad:sponsors],+   [Open Collective][opencollective:xmonad]++Please do read the [CONTRIBUTING][gh:xmonad:contributing] document for more+information about bug reporting and code contributions. For a brief overview+of the architecture and code conventions, see the [documentation for the+`XMonad.Doc.Developing` module][doc:developing]. If in doubt, [talk to+us][web:community].++## License++Code submitted to the xmonad-contrib repo is licensed under the same license+as xmonad core itself, with copyright held by the authors.++[doc:developing]: https://xmonad.github.io/xmonad-docs/xmonad-contrib/XMonad-Doc-Developing.html+[gh:xmonad-contrib:issues]: https://github.com/xmonad/xmonad-contrib/issues+[gh:xmonad-contrib:pulls]: https://github.com/xmonad/xmonad-contrib/pulls+[gh:xmonad-contrib]: https://github.com/xmonad/xmonad-contrib+[gh:xmonad-web]: https://github.com/xmonad/xmonad-web+[gh:xmonad:contributing]: https://github.com/xmonad/xmonad/blob/master/CONTRIBUTING.md+[gh:xmonad:issues]: https://github.com/xmonad/xmonad/issues+[gh:xmonad:pulls]: https://github.com/xmonad/xmonad/pulls+[gh:xmonad:sponsors]: https://github.com/sponsors/xmonad+[gh:xmonad]: https://github.com/xmonad/xmonad+[opencollective:xmonad]: https://opencollective.com/xmonad+[web:community]: https://xmonad.org/community.html+[web:documentation]: https://xmonad.org/documentation.html+[web:download]: https://xmonad.org/download.html+[web:install]: https://xmonad.org/INSTALL.html+[web:tutorial]: https://xmonad.org/TUTORIAL.html+[web:xmonad]: https://xmonad.org/
+ XMonad/Actions/AfterDrag.hs view
@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.AfterDrag+-- Description :  Allows you to add actions dependent on the current mouse drag.+-- Copyright   :  (c) 2014 Anders Engstrom <ankaan@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Anders Engstrom <ankaan@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Perform an action after the current mouse drag is completed.+-----------------------------------------------------------------------------++module XMonad.Actions.AfterDrag (+                -- * Usage+                -- $usage+                afterDrag,+                ifClick,+                ifClick') where++import XMonad++import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime)++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- >    import XMonad.Actions.AfterDrag+--+-- Then add appropriate mouse bindings, for example:+--+-- >        , ((modm, button3), (\w -> focus w >> mouseResizeWindow w >> ifClick (windows $ W.float w $ W.RationalRect 0 0 1 1)))+--+-- This will allow you to resize windows as usual, but if you instead of+-- draging click the mouse button the window will be automatically resized to+-- fill the whole screen.+--+-- For detailed instructions on editing your mouse bindings, see+-- "XMonad.Doc.Extending#Editing_mouse_bindings".+--+-- More practical examples are available in "XMonad.Actions.FloatSnap".++-- | Schedule a task to take place after the current dragging is completed.+afterDrag+    :: X () -- ^ The task to schedule.+    -> X ()+afterDrag task = do drag <- gets dragging+                    case drag of+                        Nothing -> return () -- Not dragging+                        Just (motion, cleanup) -> modify $ \s -> s { dragging = Just(motion, cleanup >> task) }++-- | Take an action if the current dragging can be considered a click,+--   supposing the drag just started before this function is called.+--   A drag is considered a click if it is completed within 300 ms.+ifClick+  :: X ()   -- ^ The action to take if the dragging turned out to be a click.+  -> X ()+ifClick action = ifClick' 300 action (return ())++-- | Take an action if the current dragging is completed within a certain time (in milliseconds.)+ifClick'+  :: Int    -- ^ Maximum time of dragging for it to be considered a click (in milliseconds.)+  -> X ()   -- ^ The action to take if the dragging turned out to be a click.+  -> X ()   -- ^ The action to take if the dragging turned out to not be a click.+  -> X ()+ifClick' ms click drag = do+  start <- io getCurrentTime+  afterDrag $ do+    stop <- io getCurrentTime+    if diffUTCTime stop start <= (fromIntegral ms / 10^(3 :: Integer) :: NominalDiffTime)+      then click+      else drag
XMonad/Actions/BluetileCommands.hs view
@@ -1,6 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.BluetileCommands+-- Description :  Interface with the [Bluetile](https://hackage.haskell.org/package/bluetile) tiling window manager. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -24,26 +25,25 @@  import XMonad import qualified XMonad.StackSet as W-import XMonad.Layout.LayoutCombinators import System.Exit  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Hooks.ServerMode -- >    import XMonad.Actions.BluetileCommands -- -- Then edit your @handleEventHook@: ----- > main = xmonad defaultConfig { handleEventHook = serverModeEventHook' bluetileCommands }+-- > main = xmonad def { handleEventHook = serverModeEventHook' bluetileCommands } -- -- See the documentation of "XMonad.Hooks.ServerMode" for details on -- how to actually invoke the commands from external programs.  workspaceCommands :: Int -> X [(String, X ())] workspaceCommands sid = asks (workspaces . config) >>= \spaces -> return-                            [(("greedyView" ++ show i),+                            [( "greedyView" ++ show i,                                 activateScreen sid >> windows (W.greedyView i))                                 | i <- spaces ] @@ -66,7 +66,7 @@                          ]  quitCommands :: [(String, X ())]-quitCommands = [ ("quit bluetile", io (exitWith ExitSuccess))+quitCommands = [ ("quit bluetile", io exitSuccess)                , ("quit bluetile and start metacity", restart "metacity" False)                ]
XMonad/Actions/Commands.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.Commands+-- Description :  Run internal xmonad commands using a dmenu menu. -- Copyright   :  (c) David Glasser 2007 -- License     :  BSD3 --@@ -19,6 +20,7 @@                              -- $usage                              commandMap,                              runCommand,+                             runCommandConfig,                              runCommand',                              workspaceCommands,                              screenCommands,@@ -31,11 +33,11 @@  import qualified Data.Map as M import System.Exit-import Data.Maybe+import XMonad.Prelude  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.Commands --@@ -55,23 +57,23 @@ -- bindings!) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Create a 'Data.Map.Map' from @String@s to xmonad actions from a --   list of pairs. commandMap :: [(String, X ())] -> M.Map String (X ())-commandMap c = M.fromList c+commandMap = M.fromList  -- | Generate a list of commands to switch to\/send windows to workspaces. workspaceCommands :: X [(String, X ())] workspaceCommands = asks (workspaces . config) >>= \spaces -> return-                            [((m ++ show i), windows $ f i)+                            [( m ++ show i, windows $ f i)                                 | i <- spaces                                 , (f, m) <- [(view, "view"), (shift, "shift")] ]  -- | Generate a list of commands dealing with multiple screens. screenCommands :: [(String, X ())]-screenCommands = [((m ++ show sc), screenWorkspace (fromIntegral sc) >>= flip whenJust (windows . f))+screenCommands = [( m ++ show sc, screenWorkspace (fromIntegral sc) >>= flip whenJust (windows . f))                       | sc <- [0, 1]::[Int] -- TODO: adapt to screen changes                       , (f, m) <- [(view, "screen"), (shift, "screen-to-")]                  ]@@ -99,15 +101,22 @@         , ("swap-down"           , windows swapDown                                 )         , ("swap-master"         , windows swapMaster                               )         , ("sink"                , withFocused $ windows . sink                     )-        , ("quit-wm"             , io $ exitWith ExitSuccess                        )+        , ("quit-wm"             , io exitSuccess                                   )         ]  -- | 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
XMonad/Actions/ConstrainedResize.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.ConstrainedResize+-- Description :  Constrain the aspect ratio of a floating window. -- Copyright   :  (c) Dougal Stanton -- License     :  BSD3-style (see LICENSE) --@@ -25,7 +26,7 @@  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import qualified XMonad.Actions.ConstrainedResize as Sqr --@@ -43,9 +44,8 @@  -- | Resize (floating) window with optional aspect ratio constraints. mouseResizeWindow :: Window -> Bool -> X ()-mouseResizeWindow w c = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w+mouseResizeWindow w c = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     sh <- io $ getWMNormalHints d w     io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa))     mouseDrag (\ex ey -> do@@ -53,5 +53,6 @@                      y = ey - fromIntegral (wa_y wa)                      sz = if c then (max x y, max x y) else (x,y)                  io $ resizeWindow d w `uncurry`-                    applySizeHintsContents sh sz)+                    applySizeHintsContents sh sz+                 float w)               (float w)
XMonad/Actions/CopyWindow.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.CopyWindow+-- Description :  Duplicate a window on multiple workspaces. -- Copyright   :  (c) David Roundy <droundy@darcs.net>, Ivan Veselov <veselov@gmail.com>, Lanny Ripple <lan3ny@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -18,22 +20,24 @@                                  -- * Usage                                  -- $usage                                  copy, copyToAll, copyWindow, runOrCopy-                                 , killAllOtherCopies, kill1+                                 , killAllOtherCopies, kill1, taggedWindows, copiesOfOn                                  -- * Highlight workspaces containing copies in logHook                                  -- $logHook-                                 , wsContainingCopies+                                 , wsContainingCopies, copiesPP                                 ) where  import XMonad+import XMonad.Prelude import Control.Arrow ((&&&)) import qualified Data.List as L  import XMonad.Actions.WindowGo+import XMonad.Hooks.StatusBar.PP (PP(..), WS(..), isHidden) import qualified XMonad.StackSet as W  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- > import XMonad.Actions.CopyWindow --@@ -73,22 +77,28 @@ -- >  , ((modm .|. shiftMask, xK_v ),  killAllOtherCopies) -- @@ Toggle window state back -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- $logHook--- To distinguish workspaces containing copies of the focused window use--- something like: ----- > sampleLogHook h = do--- >    copies <- wsContainingCopies--- >    let check ws | ws `elem` copies = pad . xmobarColor "red" "black" $ ws--- >                 | otherwise = pad ws--- >    dynamicLogWithPP myPP {ppHidden = check, ppOutput = hPutStrLn h}--- >--- > main = do--- >    h <- spawnPipe "xmobar"--- >    xmonad defaultConfig { logHook = sampleLogHook h }+-- To distinguish workspaces containing copies of the focused window, use 'copiesPP'.+-- 'copiesPP' takes a pretty printer and makes it aware of copies of the focused window.+-- It can be applied when creating a 'XMonad.Hooks.StatusBar.StatusBarConfig'.+--+-- A sample config looks like this:+--+-- > mySB = statusBarProp "xmobar" (copiesPP (pad . xmobarColor "red" "black") xmobarPP)+-- > main = xmonad $ withEasySB mySB defToggleStrutsKey def +-- | Take a pretty printer and make it aware of copies by using the provided function+-- to show hidden workspaces that contain copies of the focused window.+copiesPP :: (WorkspaceId -> String) -> PP -> X PP+copiesPP wtoS pp = do+    copies <- wsContainingCopies+    let check WS{..} = W.tag wsWS `elem` copies+    let printer = (asks (isHidden <&&> check) >>= guard) $> wtoS+    return pp{ ppPrinters = printer <|> ppPrinters pp }+ -- | Copy the focused window to a workspace. copy :: (Eq s, Eq i, Eq a) => i -> W.StackSet i l a s sd -> W.StackSet i l a s sd copy n s | Just w <- W.peek s = copyWindow w n s@@ -96,7 +106,7 @@  -- | Copy the focused window to all workspaces. copyToAll :: (Eq s, Eq i, Eq a) => W.StackSet i l a s sd -> W.StackSet i l a s sd-copyToAll s = foldr copy s $ map W.tag (W.workspaces s)+copyToAll s = foldr (copy . W.tag) s (W.workspaces s)  -- | Copy an arbitrary window to a workspace. copyWindow :: (Eq a, Eq i, Eq s) => a -> i -> W.StackSet i l a s sd -> W.StackSet i l a s sd@@ -104,10 +114,10 @@     where copy' s = if n `W.tagMember` s                     then W.view (W.currentTag s) $ insertUp' w $ W.view n s                     else s-          insertUp' a s = W.modify (Just $ W.Stack a [] [])+          insertUp' a = W.modify (Just $ W.Stack a [] [])                           (\(W.Stack t l r) -> if a `elem` t:l++r                                              then Just $ W.Stack t l r-                                             else Just $ W.Stack a (L.delete a l) (L.delete a (t:r))) s+                                             else Just $ W.Stack a (L.delete a l) (L.delete a (t:r)))   -- | runOrCopy will run the provided shell command unless it can@@ -142,9 +152,9 @@                                                    W.view (W.currentTag ss) .                                                    delFromAllButCurrent w     where-      delFromAllButCurrent w ss = foldr ($) ss $-                                  map (delWinFromWorkspace w . W.tag) $-                                  W.hidden ss ++ map W.workspace (W.visible ss)+      delFromAllButCurrent w ss = foldr (delWinFromWorkspace w . W.tag)+                                  ss+                                  (W.hidden ss ++ map W.workspace (W.visible ss))       delWinFromWorkspace w wid = viewing wid $ W.modify Nothing (W.filter (/= w))        viewing wis f ss = W.view (W.currentTag ss) $ f $ W.view wis ss
XMonad/Actions/CycleRecentWS.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.CycleRecentWS+-- Description :  Cycle through most recently used workspaces. -- Copyright   :  (c) Michal Janeczek <janeczek@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -19,21 +24,37 @@                                 -- * Usage                                 -- $usage                                 cycleRecentWS,-                                cycleWindowSets+                                cycleRecentNonEmptyWS,+                                cycleWindowSets,+                                toggleRecentWS,+                                toggleRecentNonEmptyWS,+                                toggleWindowSets,+                                recentWS,++#ifdef TESTING+                                unView,+#endif ) where +import XMonad.Actions.Repeatable (repeatableSt)+ import XMonad hiding (workspaces)-import XMonad.StackSet+import XMonad.Prelude (void, when)+import XMonad.StackSet hiding (filter, modify) +import Control.Arrow ((&&&))+import Data.Function (on)+import Control.Monad.State (lift)+ -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- > import XMonad.Actions.CycleRecentWS -- > -- >   , ((modm, xK_Tab), cycleRecentWS [xK_Alt_L] xK_Tab xK_grave) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Cycle through most recent workspaces with repeated presses of a key, while --   a modifier key is held down. The recency of workspaces previewed while browsing@@ -47,39 +68,91 @@               -> KeySym   -- ^ Key used to switch to previous (more recent) workspace.                           --   If it's the same as the nextWorkspace key, it is effectively ignored.               -> X ()-cycleRecentWS = cycleWindowSets options- where options w = map (view `flip` w) (recentTags w)-       recentTags w = map tag $ tail (workspaces w) ++ [head (workspaces w)]+cycleRecentWS = cycleWindowSets $ recentWS (const True)  -cycref :: [a] -> Int -> a-cycref l i = l !! (i `mod` length l)+-- | Like 'cycleRecentWS', but restricted to non-empty workspaces.+cycleRecentNonEmptyWS :: [KeySym] -- ^ A list of modifier keys used when invoking this action.+                                  --   As soon as one of them is released, the final switch is made.+                      -> KeySym   -- ^ Key used to switch to next (less recent) workspace.+                      -> KeySym   -- ^ Key used to switch to previous (more recent) workspace.+                                  --   If it's the same as the nextWorkspace key, it is effectively ignored.+                      -> X ()+cycleRecentNonEmptyWS = cycleWindowSets $ recentWS (not . null . stack) --- | Cycle through a finite list of WindowSets with repeated presses of a key, while++-- | Switch to the most recent workspace. The stack of most recently used workspaces+-- is updated, so repeated use toggles between a pair of workspaces.+toggleRecentWS :: X ()+toggleRecentWS = toggleWindowSets $ recentWS (const True)+++-- | Like 'toggleRecentWS', but restricted to non-empty workspaces.+toggleRecentNonEmptyWS :: X ()+toggleRecentNonEmptyWS = toggleWindowSets $ recentWS (not . null . stack)+++-- | Given a predicate @p@ and the current 'WindowSet' @w@, create a+-- list of workspaces to choose from. They are ordered by recency and+-- have to satisfy @p@.+recentWS :: (WindowSpace -> Bool) -- ^ A workspace predicate.+         -> WindowSet             -- ^ The current WindowSet+         -> [WorkspaceId]+recentWS p w = map tag+             $ filter p+             $ map workspace (visible w)+               ++ hidden w+               ++ [workspace (current w)]++-- | Cycle through a finite list of workspaces with repeated presses of a key, while --   a modifier key is held down. For best effects use the same modkey+key combination --   as the one used to invoke this action.-cycleWindowSets :: (WindowSet -> [WindowSet]) -- ^ A function used to create a list of WindowSets to choose from-                -> [KeySym]                   -- ^ A list of modifier keys used when invoking this action.-                                              --   As soon as one of them is released, the final WindowSet is chosen and the action exits.-                -> KeySym                     -- ^ Key used to preview next WindowSet from the list of generated options-                -> KeySym                     -- ^ Key used to preview previous WindowSet from the list of generated options.-                                              --   If it's the same as nextOption key, it is effectively ignored.+cycleWindowSets :: (WindowSet -> [WorkspaceId]) -- ^ A function used to create a list of workspaces to choose from+                -> [KeySym]                     -- ^ A list of modifier keys used when invoking this action.+                                                --   As soon as one of them is released, the final workspace is chosen and the action exits.+                -> KeySym                       -- ^ Key used to preview next workspace from the list of generated options+                -> KeySym                       -- ^ Key used to preview previous workspace from the list of generated options.+                                                --   If it's the same as nextOption key, it is effectively ignored.                 -> X () cycleWindowSets genOptions mods keyNext keyPrev = do+  (options, unView') <- gets $ (genOptions &&& unView) . windowset+  let+    preview = do+      i <- get+      lift $ windows (view (options !! (i `mod` n)) . unView')+      where n = length options+  void . repeatableSt (-1) mods keyNext $ \t s -> when (t == keyPress) $ if+    | s == keyNext -> modify succ >> preview+    | s == keyPrev -> modify pred >> preview+    | otherwise    -> pure ()++-- | Given an old and a new 'WindowSet', which is __exactly__ one+-- 'view' away from the old one, restore the workspace order of the+-- former inside of the latter.  This respects any new state that the+-- new 'WindowSet' may have accumulated.+unView :: forall i l a s sd. (Eq i, Eq s)+       => StackSet i l a s sd -> StackSet i l a s sd -> StackSet i l a s sd+unView w0 w1 = fixOrderH . fixOrderV . view' (currentTag w0) $ w1+ where+  view' = if screen (current w0) == screen (current w1) then greedyView else view+  fixOrderV w | v : vs <- visible w = w{ visible = insertAt (pfxV (visible w0) vs) v vs }+              | otherwise = w+  fixOrderH w | h : hs <- hidden w = w{ hidden = insertAt (pfxH (hidden w0) hs) h hs }+              | otherwise = w+  pfxV = commonPrefix `on` fmap (tag . workspace)+  pfxH = commonPrefix `on` fmap tag++  insertAt :: Int -> x -> [x] -> [x]+  insertAt n x xs = let (l, r) = splitAt n xs in l ++ [x] ++ r++  commonPrefix :: Eq x => [x] -> [x] -> Int+  commonPrefix a b = length $ takeWhile id $ zipWith (==) a b++-- | Given some function that generates a list of workspaces from a+-- given 'WindowSet', switch to the first generated workspace.+toggleWindowSets :: (WindowSet -> [WorkspaceId]) -> X ()+toggleWindowSets genOptions = do   options <- gets $ genOptions . windowset-  XConf {theRoot = root, display = d} <- ask-  let event = allocaXEvent $ \p -> do-                maskEvent d (keyPressMask .|. keyReleaseMask) p-                KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p-                s <- keycodeToKeysym d c 0-                return (t, s)-  let setOption n = do windows $ const $ options `cycref` n-                       (t, s) <- io event-                       case () of-                         () | t == keyPress   && s == keyNext  -> setOption (n+1)-                            | t == keyPress   && s == keyPrev  -> setOption (n-1)-                            | t == keyRelease && s `elem` mods -> return ()-                            | otherwise                        -> setOption n-  io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime-  setOption 0-  io $ ungrabKeyboard d currentTime+  case options of+    []  -> return ()+    o:_ -> windows (view o)
XMonad/Actions/CycleSelectedLayouts.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.CycleSelectedLayouts+-- Description :  Cycle through the given subset of layouts. -- Copyright   :  (c) Roman Cheplyaka -- License     :  BSD3-style (see LICENSE) --@@ -18,34 +19,29 @@     cycleThroughLayouts) where  import XMonad-import Data.List (findIndex)-import Data.Maybe (fromMaybe)-import XMonad.Layout.LayoutCombinators (JumpToLayout(..))+import XMonad.Prelude (elemIndex, fromMaybe) import qualified XMonad.StackSet as S  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: ----- > import XMonad hiding ((|||))--- > import XMonad.Layout.LayoutCombinators ((|||))+-- > import XMonad -- > import XMonad.Actions.CycleSelectedLayouts -- -- >   , ((modm,  xK_t ),   cycleThroughLayouts ["Tall", "Mirror Tall"])------ Make sure you are using NewSelect from XMonad.Layout.LayoutCombinators,--- rather than the Select defined in xmonad core.  cycleToNext :: (Eq a) => [a] -> a -> Maybe a cycleToNext lst a = do     -- not beautiful but simple and readable-    ind <- findIndex (a==) lst+    ind <- elemIndex a lst     return $ lst !! if ind == length lst - 1 then 0 else ind+1  -- | If the current layout is in the list, cycle to the next layout. Otherwise, --   apply the first layout from list. cycleThroughLayouts :: [String] -> X ()-cycleThroughLayouts lst = do+cycleThroughLayouts []         = pure ()+cycleThroughLayouts lst@(x: _) = do     winset <- gets windowset     let ld = description . S.layout . S.workspace . S.current $ winset-    let newld = fromMaybe (head lst) (cycleToNext lst ld)+    let newld = fromMaybe x (cycleToNext lst ld)     sendMessage $ JumpToLayout newld
XMonad/Actions/CycleWS.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.CycleWS+-- Description :  Cycle through workspaces. -- Copyright   :  (c) Joachim Breitner <mail@joachim-breitner.de>, --                    Nelson Elhage <nelhage@mit.edu> (`toggleWS' function) -- License     :  BSD3-style (see LICENSE)@@ -18,13 +19,13 @@ -- -- Note that this module now subsumes the functionality of the former -- @XMonad.Actions.RotView@.  Former users of @rotView@ can simply replace--- @rotView True@ with @moveTo Next NonEmptyWS@, and so on.+-- @rotView True@ with @moveTo Next (Not emptyWS)@, and so on. -- -- If you want to exactly replicate the action of @rotView@ (cycling -- through workspace in order lexicographically by tag, instead of in -- the order specified in the config), it can be implemented as: ----- > rotView b  = do t <- findWorkspace getSortByTag (bToDir b) NonEmptyWS 1+-- > rotView b  = do t <- findWorkspace getSortByTag (bToDir b) (Not emptyWS) 1 -- >                 windows . greedyView $ t -- >   where bToDir True  = Next -- >         bToDir False = Prev@@ -63,6 +64,11 @@                                , Direction1D(..)                               , WSType(..)+                              , emptyWS+                              , hiddenWS+                              , anyWS+                              , wsTagGroup+                              , ignoringWSs                                , shiftTo                               , moveTo@@ -78,17 +84,15 @@                               ) where -import Control.Monad ( unless )-import Data.List ( findIndex )-import Data.Maybe ( isNothing, isJust )-+import XMonad.Prelude (find, findIndex, isJust, isNothing, liftM2) import XMonad hiding (workspaces)+import qualified XMonad.Hooks.WorkspaceHistory as WH import XMonad.StackSet hiding (filter) import XMonad.Util.Types import XMonad.Util.WorkspaceCompare  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- > import XMonad.Actions.CycleWS -- >@@ -112,13 +116,17 @@ -- You can also get fancier with 'moveTo', 'shiftTo', and 'findWorkspace'. -- For example: ----- >   , ((modm     , xK_f), moveTo Next EmptyWS)  -- find a free workspace+-- >   , ((modm     , xK_f), moveTo Next emptyWS)  -- find a free workspace -- >   , ((modm .|. controlMask, xK_Right),        -- a crazy keybinding!--- >         do t <- findWorkspace getSortByXineramaRule Next NonEmptyWS 2+-- >         do t <- findWorkspace getSortByXineramaRule Next (Not emptyWS) 2 -- >            windows . view $ t                                         ) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.+--+-- When using the toggle functions, in order to ensure that the workspace+-- to which you switch is the previously viewed workspace, use the+-- 'logHook' in "XMonad.Hooks.WorkspaceHistory".  {- $moving @@ -158,9 +166,7 @@ -- > -- Ignore the scratchpad workspace while toggling: -- > ("M-b", toggleWS' ["NSP"]) toggleWS' :: [WorkspaceId] -> X ()-toggleWS' skips = do-    hs' <- cleanHiddens skips-    unless (null hs') (windows . view . tag $ head hs')+toggleWS' skips = lastViewedHiddenExcept skips >>= flip whenJust (windows . view)  -- | 'XMonad.StackSet.greedyView' a workspace, or if already there, view -- the previously displayed workspace ala weechat. Change @greedyView@ to@@ -184,10 +190,9 @@ toggleOrDoSkip :: [WorkspaceId] -> (WorkspaceId -> WindowSet -> WindowSet)                                   -> WorkspaceId -> X () toggleOrDoSkip skips f toWS = do-    hs' <- cleanHiddens skips     cur <- gets (currentTag . windowset)     if toWS == cur-        then unless (null hs') (windows . f . tag $ head hs')+        then lastViewedHiddenExcept skips >>= flip whenJust (windows . f)         else windows (f toWS)  -- | List difference ('\\') for workspaces and tags. Removes workspaces@@ -195,8 +200,15 @@ skipTags :: (Eq i) => [Workspace i l a] -> [i] -> [Workspace i l a] skipTags wss ids = filter ((`notElem` ids) . tag) wss -cleanHiddens :: [WorkspaceId] -> X [WindowSpace]-cleanHiddens skips =  gets $ (flip skipTags) skips . hidden . windowset+-- | Ignoring the skips, find the best candidate for the last viewed hidden+-- workspace.+lastViewedHiddenExcept :: [WorkspaceId] -> X (Maybe WorkspaceId)+lastViewedHiddenExcept skips = do+    hs <- gets $ map tag . flip skipTags skips . hidden . windowset+    choose hs . find (`elem` hs) <$> WH.workspaceHistory+    where choose []    _           = Nothing+          choose (h:_) Nothing     = Just h+          choose _     vh@(Just _) = vh  switchWorkspace :: Int -> X () switchWorkspace d = wsBy d >>= windows . greedyView@@ -204,8 +216,8 @@ shiftBy :: Int -> X () shiftBy d = wsBy d >>= windows . shift -wsBy :: Int -> X (WorkspaceId)-wsBy = findWorkspace getSortByIndex Next AnyWS+wsBy :: Int -> X WorkspaceId+wsBy = findWorkspace getSortByIndex Next anyWS  {- $taketwo @@ -214,7 +226,7 @@  For example, ->   moveTo Next EmptyWS+>   moveTo Next emptyWS  will move to the first available workspace with no windows, and @@ -225,11 +237,19 @@  -} +{-# DEPRECATED EmptyWS             "Use emptyWS instead." #-}+{-# DEPRECATED HiddenWS            "Use hiddenWS instead." #-}+{-# DEPRECATED NonEmptyWS          "Use Not emptyWS instead." #-}+{-# DEPRECATED HiddenNonEmptyWS    "Use hiddenWS :&: Not emptyWS instead." #-}+{-# DEPRECATED HiddenEmptyWS       "Use hiddenWS :&: emptyWS instead." #-}+{-# DEPRECATED AnyWS               "Use anyWS instead." #-}+{-# DEPRECATED WSTagGroup          "Use wsTagGroup instead." #-} -- | What type of workspaces should be included in the cycle? data WSType = EmptyWS     -- ^ cycle through empty workspaces             | NonEmptyWS  -- ^ cycle through non-empty workspaces             | HiddenWS    -- ^ cycle through non-visible workspaces             | HiddenNonEmptyWS  -- ^ cycle through non-empty non-visible workspaces+            | HiddenEmptyWS  -- ^ cycle through empty non-visible workspaces             | AnyWS       -- ^ cycle through all workspaces             | WSTagGroup Char                           -- ^ cycle through workspaces in the same group, the@@ -238,6 +258,11 @@             | WSIs (X (WindowSpace -> Bool))                           -- ^ cycle through workspaces satisfying                           --   an arbitrary predicate+            | WSType :&: WSType -- ^ cycle through workspaces satisfying both+                                --   predicates.+            | WSType :|: WSType -- ^ cycle through workspaces satisfying one of+                                --   the predicates.+            | Not WSType -- ^ cycle through workspaces not satisfying the predicate  -- | Convert a WSType value to a predicate on workspaces. wsTypeToPred :: WSType -> X (WindowSpace -> Bool)@@ -248,12 +273,51 @@ wsTypeToPred HiddenNonEmptyWS  = do ne <- wsTypeToPred NonEmptyWS                                     hi <- wsTypeToPred HiddenWS                                     return (\w -> hi w && ne w)+wsTypeToPred HiddenEmptyWS  = do ne <- wsTypeToPred EmptyWS+                                 hi <- wsTypeToPred HiddenWS+                                 return (\w -> hi w && ne w) wsTypeToPred AnyWS      = return (const True)-wsTypeToPred (WSTagGroup sep) = do cur <- (groupName.workspace.current) `fmap` gets windowset+wsTypeToPred (WSTagGroup sep) = do cur <- groupName.workspace.current <$> gets windowset                                    return $ (cur ==).groupName                                    where groupName = takeWhile (/=sep).tag-wsTypeToPred (WSIs p)   = p+wsTypeToPred (WSIs p ) = p+wsTypeToPred (p :&: q) = liftM2 (&&) <$> wsTypeToPred p <*> wsTypeToPred q+wsTypeToPred (p :|: q) = liftM2 (||) <$> wsTypeToPred p <*> wsTypeToPred q+wsTypeToPred (Not p  ) = fmap not <$> wsTypeToPred p +-- | Cycle through empty workspaces+emptyWS :: WSType+emptyWS = WSIs . return $ isNothing . stack++-- | Cycle through non-visible workspaces+hiddenWS :: WSType+hiddenWS = WSIs $ do+  hs <- gets (map tag . hidden . windowset)+  return $ (`elem` hs) . tag++-- | Cycle through all workspaces+anyWS :: WSType+anyWS = WSIs . return $ const True++-- | Cycle through workspaces that are not in the given list. This could, for+--   example, be used for skipping the workspace reserved for+--   "XMonad.Util.NamedScratchpad":+--+-- >  moveTo Next $ hiddenWS :&: Not emptyWS :&: ignoringWSs [scratchpadWorkspaceTag]+--+ignoringWSs :: [WorkspaceId] -> WSType+ignoringWSs ts = WSIs . return $ (`notElem` ts) . tag++-- | Cycle through workspaces in the same group, the+--   group name is all characters up to the first+--   separator character or the end of the tag+wsTagGroup :: Char -> WSType+wsTagGroup sep = WSIs $ do+  cur <- groupName . workspace . current <$> gets windowset+  return $ (cur ==) . groupName+  where groupName = takeWhile (/= sep) . tag++ -- | View the next workspace in the given direction that satisfies --   the given condition. moveTo :: Direction1D -> WSType -> X ()@@ -286,7 +350,7 @@ findWorkspace s dir t n = findWorkspaceGen s (wsTypeToPred t) (maybeNegate dir n)   where     maybeNegate Next d = d-    maybeNegate Prev d = (-d)+    maybeNegate Prev d = -d  findWorkspaceGen :: X WorkspaceSort -> X (WindowSpace -> Bool) -> Int -> X WorkspaceId findWorkspaceGen _ _ 0 = gets (currentTag . windowset)@@ -296,7 +360,7 @@     ws     <- gets windowset     let cur     = workspace (current ws)         sorted  = sort (workspaces ws)-        pivoted = let (a,b) = span ((/= (tag cur)) . tag) sorted in b ++ a+        pivoted = let (a,b) = span ((/= tag cur) . tag) sorted in b ++ a         ws'     = filter wsPred pivoted         mCurIx  = findWsIndex cur ws'         d'      = if d > 0 then d - 1 else d@@ -308,7 +372,7 @@     return $ tag next  findWsIndex :: WindowSpace -> [WindowSpace] -> Maybe Int-findWsIndex ws wss = findIndex ((== tag ws) . tag) wss+findWsIndex ws = findIndex ((== tag ws) . tag)  -- | View next screen nextScreen :: X ()@@ -336,7 +400,7 @@ >         , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]]  -}-screenBy :: Int -> X (ScreenId)+screenBy :: Int -> X ScreenId screenBy d = do ws <- gets windowset                 --let ss = sortBy screen (screens ws)                 let now = screen (current ws)
XMonad/Actions/CycleWindows.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE ViewPatterns, MultiWayIf #-}+ -------------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.CycleWindows+-- Description  : Cycle windows while maintaining focus in place. -- Copyright    : (c) Wirt Wolff <wirtwolff@gmail.com> -- License      : BSD3-style (see LICENSE) --@@ -47,18 +50,21 @@         -- $pointer          -- * Generic list rotations-        -- $generic         rotUp, rotDown ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W+import qualified Data.List.NonEmpty as NE import XMonad.Actions.RotSlaves+import XMonad.Actions.Repeatable (repeatableSt)  import Control.Arrow (second)+import Control.Monad.Trans (lift)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- > import XMonad.Actions.CycleWindows -- >    -- config@@ -74,7 +80,7 @@ -- -- Also, if you use focus follows mouse, you will want to read the section -- on updating the mouse pointer below.  For detailed instructions on--- editing your key bindings, see "XMonad.Doc.Extending#Editing_key_bindings".+-- editing your key bindings, see <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. {- $pointer With FocusFollowsMouse == True, the focus is updated after binding actions, possibly focusing a window you didn't intend to focus. Most@@ -116,7 +122,7 @@                                --   If it's the same as the first key, it is effectively ignored.                     -> X () cycleRecentWindows = cycleStacks' stacks where-    stacks s = map (shiftToFocus' `flip` s) (wins s)+    stacks s = map (`shiftToFocus'` s) (wins s)     wins (W.Stack t l r) = t : r ++ reverse l  @@ -134,27 +140,19 @@                                     -> KeySym    -- ^ Key used to select a \"previous\" stack.                                     -> X () cycleStacks' filteredPerms mods keyNext keyPrev = do-    XConf {theRoot = root, display = d} <- ask-    stacks <- gets $ maybe [] filteredPerms . W.stack . W.workspace . W.current . windowset--    let evt = allocaXEvent $-                  \p -> do maskEvent d (keyPressMask .|. keyReleaseMask) p-                           KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p-                           s <- keycodeToKeysym d c 0-                           return (t, s)-        choose n (t, s)-              | t == keyPress   && s == keyNext  = io evt >>= choose (n+1)-              | t == keyPress   && s == keyPrev  = io evt >>= choose (n-1)-              | t == keyPress   && s `elem` [xK_0..xK_9] = io evt >>= choose (numKeyToN s)-              | t == keyRelease && s `elem` mods = return ()-              | otherwise                        = doStack n >> io evt >>= choose n-        doStack n = windows . W.modify' . const $ stacks `cycref` n--    io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime-    io evt >>= choose 1-    io $ ungrabKeyboard d currentTime-  where cycref l i = l !! (i `mod` length l) -- modify' ensures l is never [], but must also be finite-        numKeyToN = subtract 48 . read . show+  stacks <- gets $ maybe [] filteredPerms+                 . W.stack . W.workspace . W.current . windowset+  let+    preview = do+      i <- get+      lift . windows . W.modify' . const $ stacks !! (i `mod` n)+      where n = length stacks+  void $ repeatableSt 0 mods keyNext $ \t s -> if+    | t == keyPress && s == keyNext          -> modify succ+    | t == keyPress && s == keyPrev          -> modify pred+    | t == keyPress && s `elem` [xK_0..xK_9] -> put (numKeyToN s)+    | otherwise                              -> preview+  where numKeyToN = subtract 48 . read . show  -- | Given a stack element and a stack, shift or insert the element (window) --   at the currently focused position.@@ -178,7 +176,7 @@ rotOpposite' (W.Stack t l r) = W.Stack t' l' r'   where rrvl = r ++ reverse l         part = (length rrvl + 1) `div` 2-        (l',t':r') =  second reverse . splitAt (length l) $+        (l', notEmpty -> t' :| r') = second reverse . splitAt (length l) $                                 reverse (take part rrvl ++ t : drop part rrvl)  @@ -204,8 +202,8 @@ rotFocused' :: ([a] -> [a]) -> W.Stack a -> W.Stack a rotFocused' _ s@(W.Stack _ [] []) = s rotFocused' f   (W.Stack t [] (r:rs)) = W.Stack t' [] (r:rs') -- Master has focus-    where (t':rs') = f (t:rs)-rotFocused' f s@(W.Stack _ _ _) = rotSlaves' f s              -- otherwise+    where (notEmpty -> t' :| rs') = f (t:rs)+rotFocused' f s@W.Stack{} = rotSlaves' f s                    -- otherwise   -- $unfocused@@ -219,17 +217,8 @@  -- | The unfocused rotation on a stack. rotUnfocused' :: ([a] -> [a]) -> W.Stack a -> W.Stack a-rotUnfocused' _ s@(W.Stack _ [] []) = s-rotUnfocused' f s@(W.Stack _ [] _ ) = rotSlaves' f s                 -- Master has focus-rotUnfocused' f   (W.Stack t ls rs) = W.Stack t (reverse revls') rs' -- otherwise-    where  (master:revls)  = reverse ls+rotUnfocused' _ s@(W.Stack _ []        []) = s+rotUnfocused' f s@(W.Stack _ []        _ ) = rotSlaves' f s                 -- Master has focus+rotUnfocused' f   (W.Stack t ls@(l:ll) rs) = W.Stack t (reverse revls') rs' -- otherwise+    where  (master :| revls) = NE.reverse (l :| ll)            (revls',rs') = splitAt (length ls) (f $ master:revls ++ rs)---- $generic--- Generic list rotations such that @rotUp [1..4]@ is equivalent to--- @[2,3,4,1]@ and @rotDown [1..4]@ to @[4,1,2,3]@. They both are--- @id@ for null or singleton lists.-rotUp :: [a] -> [a]-rotUp   l = drop 1 l ++ take 1 l-rotDown :: [a] -> [a]-rotDown = reverse . rotUp . reverse
+ XMonad/Actions/CycleWorkspaceByScreen.hs view
@@ -0,0 +1,111 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.CycleWorkspaceByScreen+-- Description :  Cycle workspaces in a screen-aware fashion.+-- Copyright   :  (c) 2017 Ivan Malison+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  IvanMalison@gmail.com+-- Stability   :  unstable+-- Portability :  unportable+--+-- Cycle through previously viewed workspaces in the order they were viewed most+-- recently on the screen where cycling is taking place.+--+-----------------------------------------------------------------------------++module XMonad.Actions.CycleWorkspaceByScreen (+    -- * Usage+    -- $usage+    cycleWorkspaceOnScreen+  , cycleWorkspaceOnCurrentScreen+  , handleKeyEvent+  , repeatableAction+  ) where++import           Data.IORef++import           XMonad+import           XMonad.Prelude+import           XMonad.Hooks.WorkspaceHistory+import           XMonad.Actions.Repeatable (repeatable)+import qualified XMonad.StackSet as W++-- $usage+--+-- To use this module, first import it as well as+-- "XMonad.Hooks.WorkspaceHistory":+--+-- > import XMonad.Hooks.WorkspaceHistory (workspaceHistoryHook)+-- > import XMonad.Actions.CycleWorkspaceByScreen+--+-- Then add 'workspaceHistoryHook' to your @logHook@ like this:+--+-- > main :: IO ()+-- > main = xmonad $ def+-- >    { ...+-- >    , logHook = workspaceHistoryHook >> ...+-- >    }+--+-- Finally, define a new keybinding for cycling (seen) workspaces per+-- screen:+--+-- > , ((mod4Mask, xK_slash), cycleWorkspaceOnCurrentScreen [xK_Super_L] xK_slash xK_p)++{-# DEPRECATED repeatableAction "Use XMonad.Actions.Repeatable.repeatable" #-}+repeatableAction :: [KeySym] -> KeySym -> (EventType -> KeySym -> X ()) -> X ()+repeatableAction = repeatable++handleKeyEvent :: EventType+               -> KeySym+               -> X ()+               -> EventType+               -> KeySym+               -> Maybe (X ())+handleKeyEvent eventType key action = helper+  where+  helper et k+    | et == eventType && k == key = Just action+    | otherwise = Nothing+++runFirst :: [EventType -> KeySym -> Maybe (X ())] -> EventType -> KeySym -> X ()+runFirst matchers eventType key =+  fromMaybe (return ()) $ join $ find isJust $ map (\fn -> fn eventType key) matchers++-- | Like 'XMonad.Actions.CycleRecentWS.cycleRecentWS', but only cycle+-- through the most recent workspaces on the given screen.+cycleWorkspaceOnScreen+  :: ScreenId -- ^ The screen to cycle on.+  -> [KeySym] -- ^ A list of modifier keys used when invoking this+              --   action; as soon as one of them is released, the final+              --   switch is made.+  -> KeySym   -- ^ Key used to switch to next workspace.+  -> KeySym   -- ^ Key used to switch to previous workspace.+  -> X ()+cycleWorkspaceOnScreen screenId mods nextKey prevKey = workspaceHistoryTransaction $ do+  startingHistory <- workspaceHistoryByScreen+  currentWSIndex <- io $ newIORef 1+  let cycleWorkspaces = fromMaybe [] $ lookup screenId startingHistory+      getAndIncrementWS increment = do+        current <- readIORef currentWSIndex+        modifyIORef+          currentWSIndex+          ((`mod` length cycleWorkspaces) . (+ increment))+        return $ cycleWorkspaces !! current+      focusIncrement i = io (getAndIncrementWS i) >>= (windows . W.greedyView)++  repeatable mods nextKey $+    runFirst+      [ handleKeyEvent keyPress nextKey $ focusIncrement 1+      , handleKeyEvent keyPress prevKey $ focusIncrement (-1)+      ]+  return ()++-- | Like 'cycleWorkspaceOnScreen', but supply the currently focused+-- screen as the @screenId@.+cycleWorkspaceOnCurrentScreen+  :: [KeySym] -> KeySym -> KeySym -> X ()+cycleWorkspaceOnCurrentScreen mods n p =+  withWindowSet $ \ws ->+    cycleWorkspaceOnScreen (W.screen $ W.current ws) mods n p
XMonad/Actions/DeManage.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.DeManage+-- Description :  Cease management of a window without unmapping it. -- Copyright   :  (c) Spencer Janssen <spencerjanssen@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -38,7 +39,7 @@ import XMonad  -- $usage--- To use demanage, add this import to your @~\/.xmonad\/xmonad.hs@:+-- To use demanage, add this import to your @xmonad.hs@: -- -- >     import XMonad.Actions.DeManage --@@ -47,7 +48,7 @@ -- > , ((modm,               xK_d     ), withFocused demanage) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Stop managing the currently focused window. demanage :: Window -> X ()
XMonad/Actions/DwmPromote.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.DwmPromote+-- Description :  DWM-like swap function for xmonad. -- Copyright   :  (c) Miikka Koskinen 2007 -- License     :  BSD3-style (see LICENSE) --@@ -24,10 +25,13 @@  import XMonad import XMonad.StackSet+import XMonad.Prelude +import qualified Data.List.NonEmpty as NE+ -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.DwmPromote --@@ -36,7 +40,7 @@ -- >   , ((modm,               xK_Return), dwmpromote) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Swap the focused window with the master window. If focus is in --   the master, swap it with the next window in the stack. Focus@@ -44,6 +48,6 @@ dwmpromote :: X () dwmpromote = windows $ modify' $              \c -> case c of-                   Stack _ [] []     -> c-                   Stack t [] (x:rs) -> Stack x [] (t:rs)-                   Stack t ls rs     -> Stack t [] (ys ++ x : rs) where (x:ys) = reverse ls+                   Stack _ []     []     -> c+                   Stack t []     (r:rs) -> Stack r [] (t:rs)+                   Stack t (l:ls) rs     -> Stack t [] (ys ++ y : rs) where (y :| ys) = NE.reverse (l :| ls)
+ XMonad/Actions/DynamicProjects.hs view
@@ -0,0 +1,350 @@+--------------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.DynamicProjects+-- Description :  Treat workspaces as individual project areas.+-- Copyright   :  (c) Peter J. Jones+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Peter Jones <pjones@devalot.com>+-- Stability   :  unstable+-- Portability :  not portable+--+-- Imbues workspaces with additional features so they can be treated+-- as individual project areas.+--------------------------------------------------------------------------------+module XMonad.Actions.DynamicProjects+       ( -- * Overview+         -- $overview++         -- * Usage+         -- $usage++         -- * Types+         Project (..)+       , ProjectName++         -- * Hooks+       , dynamicProjects++         -- * Bindings+       , switchProjectPrompt+       , shiftToProjectPrompt+       , renameProjectPrompt+       , changeProjectDirPrompt++         -- * Helper Functions+       , switchProject+       , shiftToProject+       , lookupProject+       , currentProject+       , activateProject+       , modifyProject+       ) where++--------------------------------------------------------------------------------+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import System.Directory (setCurrentDirectory, getHomeDirectory, makeAbsolute)+import XMonad.Prelude+import XMonad+import XMonad.Actions.DynamicWorkspaces+import XMonad.Prompt+import XMonad.Prompt.Directory+import qualified XMonad.StackSet as W+import qualified XMonad.Util.ExtensibleState as XS++--------------------------------------------------------------------------------+-- $overview+-- Inspired by @TopicSpace@, @DynamicWorkspaces@, and @WorkspaceDir@,+-- @DynamicProjects@ treats workspaces as projects while maintaining+-- compatibility with all existing workspace-related functionality in+-- XMonad.+--+-- Instead of using generic workspace names such as @3@ or @work@,+-- @DynamicProjects@ allows you to dedicate workspaces to specific+-- projects and then switch between projects easily.+--+-- A project is made up of a name, working directory, and a start-up+-- hook.  When you switch to a workspace, @DynamicProjects@ changes+-- the working directory to the one configured for the matching+-- project.  If the workspace doesn't have any windows, the project's+-- start-up hook is executed.  This allows you to launch applications+-- or further configure the workspace/project. To close a project,+-- you can use the functions provided by "XMonad.Actions.DynamicWorkspaces",+-- such as @removeWorkspace@ or @removeWorkspaceByTag@.+--+-- When using the @switchProjectPrompt@ function, workspaces are+-- created as needed.  This means you can create new project spaces+-- (and therefore workspaces) on the fly.  (These dynamic projects are+-- not preserved across restarts.)+--+-- Additionally, frequently used projects can be configured statically+-- in your XMonad configuration.  Doing so allows you to configure the+-- per-project start-up hook.++--------------------------------------------------------------------------------+-- $usage+-- To use @DynamicProjects@ you need to add it to your XMonad+-- configuration and then configure some optional key bindings.+--+-- > import XMonad.Actions.DynamicProjects+--+-- Start by defining some projects:+--+-- > projects :: [Project]+-- > projects =+-- >   [ Project { projectName      = "scratch"+-- >             , projectDirectory = "~/"+-- >             , projectStartHook = Nothing+-- >             }+-- >+-- >   , Project { projectName      = "browser"+-- >             , projectDirectory = "~/download"+-- >             , projectStartHook = Just $ do spawn "conkeror"+-- >                                            spawn "chromium"+-- >             }+-- >   ]+--+-- Then inject @DynamicProjects@ into your XMonad configuration:+--+-- > main = xmonad $ dynamicProjects projects def+--+-- And finally, configure some optional key bindings:+--+-- >  , ((modm, xK_space), switchProjectPrompt def)+-- >  , ((modm, xK_slash), shiftToProjectPrompt def)+--+-- For detailed instructions on editing your key bindings, see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.++--------------------------------------------------------------------------------+type ProjectName  = String+type ProjectTable = Map ProjectName Project++--------------------------------------------------------------------------------+-- | Details about a workspace that represents a project.+data Project = Project+  { projectName      :: !ProjectName    -- ^ Workspace name.+  , projectDirectory :: !FilePath       -- ^ Working directory.+  , projectStartHook :: !(Maybe (X ())) -- ^ Optional start-up hook.+  }++--------------------------------------------------------------------------------+-- | Internal project state.+data ProjectState = ProjectState+  { projects        :: !ProjectTable+  , previousProject :: !(Maybe WorkspaceId)+  }++--------------------------------------------------------------------------------+instance ExtensionClass ProjectState where+  initialValue = ProjectState Map.empty Nothing++--------------------------------------------------------------------------------+-- Internal types for working with XPrompt.+data ProjectPrompt = ProjectPrompt XPConfig ProjectMode [ProjectName]+data ProjectMode = SwitchMode | ShiftMode | RenameMode | DirMode++instance XPrompt ProjectPrompt where+  showXPrompt (ProjectPrompt _ submode _) =+    case submode of+      SwitchMode -> "Switch or Create Project: "+      ShiftMode  -> "Send Window to Project: "+      RenameMode -> "New Project Name: "+      DirMode    -> "Change Project Directory: "++  completionFunction (ProjectPrompt _ RenameMode _) = return . (:[])+  completionFunction (ProjectPrompt c DirMode _) =+    let xpt = directoryMultipleModes' (complCaseSensitivity c) "" (const $ return ())+    in completionFunction xpt+  completionFunction (ProjectPrompt c _ ns) = mkComplFunFromList' c ns++  modeAction (ProjectPrompt _ SwitchMode _) buf auto = do+    let name = if null auto then buf else auto+    ps <- XS.gets projects++    case Map.lookup name ps of+      Just p              -> switchProject p+      Nothing | null name -> return ()+              | otherwise -> switchProject (defProject name)++  modeAction (ProjectPrompt _ ShiftMode _) buf auto = do+    let name = if null auto then buf else auto+    ps <- XS.gets projects+    shiftToProject . fromMaybe (defProject name) $ Map.lookup name ps++  modeAction (ProjectPrompt _ RenameMode _) name _ =+    when (not (null name) && not (all isSpace name)) $ do+      renameWorkspaceByName name+      modifyProject (\p -> p { projectName = name })++  modeAction (ProjectPrompt _ DirMode _) buf auto = do+    let dir' = if null auto then buf else auto+    dir <- io $ makeAbsolute dir'+    modifyProject (\p -> p { projectDirectory = dir })++--------------------------------------------------------------------------------+-- | Add dynamic projects support to the given config.+dynamicProjects :: [Project] -> XConfig a -> XConfig a+dynamicProjects ps c =+  c { startupHook     = dynamicProjectsStartupHook ps <> startupHook c+    , logHook         = dynamicProjectsLogHook        <> logHook c+    }++--------------------------------------------------------------------------------+-- | Log hook for tracking workspace changes.+dynamicProjectsLogHook :: X ()+dynamicProjectsLogHook = do+  name   <- gets (W.tag . W.workspace . W.current . windowset)+  xstate <- XS.get++  unless (Just name == previousProject xstate) $ do+    XS.put (xstate {previousProject = Just name})+    activateProject . fromMaybe (defProject name) $+      Map.lookup name (projects xstate)++--------------------------------------------------------------------------------+-- | Start-up hook for recording configured projects.+dynamicProjectsStartupHook :: [Project] -> X ()+dynamicProjectsStartupHook ps = XS.modify go+  where+    go :: ProjectState -> ProjectState+    go s = s {projects = update $ projects s}++    update :: ProjectTable -> ProjectTable+    update = Map.union (Map.fromList $ map entry ps)++    entry :: Project -> (ProjectName, Project)+    entry p = (projectName p, addDefaultHook p)++    -- Force the hook to be a @Just@ so that it doesn't automatically+    -- get deleted when switching away from a workspace with no+    -- windows.+    addDefaultHook :: Project -> Project+    addDefaultHook p = p { projectStartHook = projectStartHook p <|>+                                              Just (return ())+                         }++--------------------------------------------------------------------------------+-- | Find a project based on its name.+lookupProject :: ProjectName -> X (Maybe Project)+lookupProject name = Map.lookup name <$> XS.gets projects++--------------------------------------------------------------------------------+-- | Fetch the current project (the one being used for the currently+-- active workspace). If the workspace doesn't have a project, a+-- default project is returned, using the workspace name as the+-- project name.+currentProject :: X Project+currentProject = do+  name <- gets (W.tag . W.workspace . W.current . windowset)+  proj <- lookupProject name+  return $ fromMaybe (defProject name) proj++--------------------------------------------------------------------------------+-- | Modify the current project using a pure function.+modifyProject :: (Project -> Project) -> X ()+modifyProject f = do+  p  <- currentProject+  ps <- XS.gets projects++  -- If a project is renamed to match another project, the old project+  -- will be removed and replaced with this one.+  let new = f p+      ps' = Map.insert (projectName new) new $ Map.delete (projectName p) ps++  XS.modify $ \s -> s {projects = ps'}+  activateProject new++--------------------------------------------------------------------------------+-- | Switch to the given project.+switchProject :: Project -> X ()+switchProject p = appendWorkspace (projectName p)++--------------------------------------------------------------------------------+-- | Prompt for a project name and then switch to it.  Automatically+-- creates a project if a new name is returned from the prompt.+switchProjectPrompt :: XPConfig -> X ()+switchProjectPrompt = projectPrompt [ SwitchMode+                                    , ShiftMode+                                    , RenameMode+                                    , DirMode+                                    ]++--------------------------------------------------------------------------------+-- | Shift the currently focused window to the given project.+shiftToProject :: Project -> X ()+shiftToProject p = do+  addHiddenWorkspace (projectName p)+  windows (W.shift $ projectName p)++--------------------------------------------------------------------------------+-- | Prompts for a project name and then shifts the currently focused+-- window to that project.+shiftToProjectPrompt :: XPConfig -> X ()+shiftToProjectPrompt = projectPrompt [ ShiftMode+                                     , RenameMode+                                     , SwitchMode+                                     , DirMode+                                     ]++--------------------------------------------------------------------------------+-- | Rename the current project.+renameProjectPrompt :: XPConfig -> X ()+renameProjectPrompt = projectPrompt [ RenameMode+                                    , DirMode+                                    , SwitchMode+                                    , ShiftMode+                                    ]++--------------------------------------------------------------------------------+-- | Change the working directory used for the current project.+--+-- NOTE: This will only affect new processed started in this project.+-- Existing processes will maintain the previous working directory.+changeProjectDirPrompt :: XPConfig -> X ()+changeProjectDirPrompt = projectPrompt [ DirMode+                                       , SwitchMode+                                       , ShiftMode+                                       , RenameMode+                                       ]++--------------------------------------------------------------------------------+-- | Prompt for a project name.+projectPrompt :: [ProjectMode] -> XPConfig -> X ()+projectPrompt submodes c = do+  ws <- map W.tag <$> gets (W.workspaces . windowset)+  ps <- XS.gets projects++  let names = sort (Map.keys ps `union` ws)+      modes = map (\m -> XPT $ ProjectPrompt c m names) submodes++  mkXPromptWithModes modes c++--------------------------------------------------------------------------------+-- | Activate a project by updating the working directory and+-- possibly running its start-up hook.  This function is automatically+-- invoked when the workspace changes.+activateProject :: Project -> X ()+activateProject p = do+    ws   <- gets (W.integrate' . W.stack . W.workspace . W.current . windowset)+    home <- io getHomeDirectory++    -- Change to the project's directory.+    catchIO (setCurrentDirectory $ expandHome home $ projectDirectory p)++    -- Possibly run the project's startup hook.+    when (null ws) $ fromMaybe (return ()) (projectStartHook p)++  where++    -- Replace an initial @~@ character with the home directory.+    expandHome :: FilePath -> FilePath -> FilePath+    expandHome home dir = case stripPrefix "~" dir of+      Nothing -> dir+      Just xs -> home ++ xs++--------------------------------------------------------------------------------+-- | Default project.+defProject :: ProjectName -> Project+defProject name = Project name "~/" Nothing
XMonad/Actions/DynamicWorkspaceGroups.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-}- ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.DynamicWorkspaceGroups+-- Description :  Dynamically manage workspace groups in multi-head setups. -- Copyright   :  (c) Brent Yorgey 2009 -- License     :  BSD-style (see LICENSE) --@@ -23,6 +22,7 @@        WSGroupId +    , addRawWSGroup     , addWSGroup     , addCurrentWSGroup     , forgetWSGroup@@ -33,20 +33,25 @@     , promptWSGroupForget      , WSGPrompt+     -- * TopicSpace Integration+     -- $topics+    , viewTopicGroup+    , promptTopicGroupView     ) where -import Data.List (find) import Control.Arrow ((&&&)) import qualified Data.Map as M  import XMonad+import XMonad.Prelude (find, for_) import qualified XMonad.StackSet as W  import XMonad.Prompt import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Actions.TopicSpace  -- $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.hs@ file: -- -- > import XMonad.Actions.DynamicWorkspaceGroups --@@ -62,30 +67,35 @@  type WSGroupId = String -data WSGroupStorage = WSG { unWSG :: M.Map WSGroupId WSGroup }-  deriving (Typeable, Read, Show)+newtype WSGroupStorage = WSG { unWSG :: M.Map WSGroupId WSGroup }+  deriving (Read, Show)  withWSG :: (M.Map WSGroupId WSGroup -> M.Map WSGroupId WSGroup) -> WSGroupStorage -> WSGroupStorage withWSG f = WSG . f . unWSG  instance ExtensionClass WSGroupStorage where-  initialValue = WSG $ M.empty+  initialValue = WSG M.empty   extensionType = PersistentExtension +-- | Add a new workspace group of the given name, mapping to an+--   explicitly specified association between screen IDs and workspace+--   names.  This function could be useful for, say, creating some+--   standard workspace groups in your startup hook.+addRawWSGroup :: WSGroupId -> [(ScreenId, WorkspaceId)] -> X ()+addRawWSGroup name = XS.modify . withWSG . M.insert name+ -- | Add a new workspace group with the given name. addWSGroup :: WSGroupId -> [WorkspaceId] -> X () addWSGroup name wids = withWindowSet $ \w -> do   let wss  = map ((W.tag . W.workspace) &&& W.screen) $ W.screens w       wmap = mapM (strength . (flip lookup wss &&& id)) wids-  case wmap of-    Just ps -> XS.modify . withWSG . M.insert name $ ps-    Nothing -> return ()+  for_ wmap (addRawWSGroup name)  where strength (ma, b) = ma >>= \a -> return (a,b)  -- | Give a name to the current workspace group. addCurrentWSGroup :: WSGroupId -> X () addCurrentWSGroup name = withWindowSet $ \w ->-  addWSGroup name $ map (W.tag . W.workspace) (W.current w : W.visible w)+  addWSGroup name $ map (W.tag . W.workspace) (reverse $ W.current w : W.visible w)  -- | Delete the named workspace group from the list of workspace --   groups.  Note that this has no effect on the workspaces involved;@@ -95,20 +105,23 @@  -- | View the workspace group with the given name. viewWSGroup :: WSGroupId -> X ()-viewWSGroup name = do+viewWSGroup = viewGroup (windows . W.greedyView)++-- | Internal function for viewing a group.+viewGroup :: (WorkspaceId -> X ()) -> WSGroupId -> X ()+viewGroup fview name = do   WSG m <- XS.get-  case M.lookup name m of-    Just grp -> mapM_ (uncurry viewWS) grp-    Nothing -> return ()+  for_ (M.lookup name m) $+    mapM_ (uncurry (viewWS fview)) --- | View the given workspace on the given screen.-viewWS :: ScreenId -> WorkspaceId -> X ()-viewWS sid wid = do+-- | View the given workspace on the given screen, using the provided function.+viewWS :: (WorkspaceId -> X ())  -> ScreenId -> WorkspaceId -> X ()+viewWS fview sid wid = do   mw <- findScreenWS sid   case mw of     Just w -> do       windows $ W.view w-      windows $ W.greedyView wid+      fview wid     Nothing -> return ()  -- | Find the workspace which is currently on the given screen.@@ -116,16 +129,20 @@ findScreenWS sid = withWindowSet $   return . fmap (W.tag . W.workspace) . find ((==sid) . W.screen) . W.screens -data WSGPrompt = WSGPrompt String+newtype WSGPrompt = WSGPrompt String  instance XPrompt WSGPrompt where   showXPrompt (WSGPrompt s) = s  -- | Prompt for a workspace group to view. promptWSGroupView :: XPConfig -> String -> X ()-promptWSGroupView xp s = do+promptWSGroupView = promptGroupView viewWSGroup++-- | Internal function for making a prompt to view a workspace group+promptGroupView :: (WSGroupId -> X ()) -> XPConfig -> String -> X ()+promptGroupView fview xp s = do   gs <- fmap (M.keys . unWSG) XS.get-  mkXPrompt (WSGPrompt s) xp (mkComplFunFromList' gs) viewWSGroup+  mkXPrompt (WSGPrompt s) xp (mkComplFunFromList' xp gs) fview  -- | Prompt for a name for the current workspace group. promptWSGroupAdd :: XPConfig -> String -> X ()@@ -136,4 +153,25 @@ promptWSGroupForget :: XPConfig -> String -> X () promptWSGroupForget xp s = do   gs <- fmap (M.keys . unWSG) XS.get-  mkXPrompt (WSGPrompt s) xp (mkComplFunFromList' gs) forgetWSGroup+  mkXPrompt (WSGPrompt s) xp (mkComplFunFromList' xp gs) forgetWSGroup++-- $topics+-- You can use this module with "XMonad.Actions.TopicSpace" — just replace+-- 'promptWSGroupView' with 'promptTopicGroupView':+--+-- >    , ("M-y n", promptWSGroupAdd myXPConfig "Name this group: ")+-- >    , ("M-y g", promptTopicGroupView myTopicConfig myXPConfig "Go to group: ")+-- >    , ("M-y d", promptWSGroupForget myXPConfig "Forget group: ")+--+-- It's also a good idea to replace 'spawn' with+-- 'XMonad.Actions.SpawnOn.spawnOn' or 'XMonad.Actions.SpawnOn.spawnHere' in+-- your topic actions, so everything is spawned where it should be.++-- | Prompt for a workspace group to view, treating the workspaces as topics.+promptTopicGroupView :: TopicConfig -> XPConfig -> String -> X ()+promptTopicGroupView = promptGroupView . viewTopicGroup++-- | View the workspace group with the given name, treating the workspaces as+-- topics.+viewTopicGroup :: TopicConfig -> WSGroupId -> X ()+viewTopicGroup = viewGroup . switchTopic
XMonad/Actions/DynamicWorkspaceOrder.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-}- ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.DynamicWorkspaceOrder+-- Description :  Remember a dynamically updateable ordering on workspaces. -- Copyright   :  (c) Brent Yorgey 2009 -- License     :  BSD-style (see LICENSE) --@@ -12,7 +11,7 @@ -- -- Remember a dynamically updateable ordering on workspaces, together -- with tools for using this ordering with "XMonad.Actions.CycleWS"--- and "XMonad.Hooks.DynamicLog".+-- and "XMonad.Hooks.StatusBar.PP". -- ----------------------------------------------------------------------------- @@ -23,11 +22,16 @@       getWsCompareByOrder     , getSortByOrder     , swapWith+    , swapWithCurrent+    , swapOrder+    , updateName+    , removeName      , moveTo     , moveToGreedy     , shiftTo +    , withNthWorkspace'     , withNthWorkspace      ) where@@ -41,11 +45,11 @@  import qualified Data.Map as M import qualified Data.Set as S-import Data.Maybe (fromJust, fromMaybe)+import XMonad.Prelude (fromJust, fromMaybe) import Data.Ord (comparing)  -- $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.hs@ file: -- -- > import qualified XMonad.Actions.DynamicWorkspaceOrder as DO --@@ -64,10 +68,10 @@ -- order of workspaces must be updated to use the auxiliary ordering. -- -- To change the order in which workspaces are displayed by--- "XMonad.Hooks.DynamicLog", use 'getSortByOrder' in your--- 'XMonad.Hooks.DynamicLog.ppSort' field, for example:+-- "XMonad.Hooks.StatusBar.PP", use 'getSortByOrder' in your+-- 'XMonad.Hooks.StatusBar.PP.ppSort' field, for example: ----- >   ... dynamicLogWithPP $ byorgeyPP {+-- >   myPP = ... byorgeyPP { -- >     ... -- >     , ppSort = DO.getSortByOrder -- >     ...@@ -86,8 +90,8 @@ -- tweak as desired.  -- | Extensible state storage for the workspace order.-data WSOrderStorage = WSO { unWSO :: Maybe (M.Map WorkspaceId Int) }-  deriving (Typeable, Read, Show)+newtype WSOrderStorage = WSO { unWSO :: Maybe (M.Map WorkspaceId Int) }+  deriving (Read, Show)  instance ExtensionClass WSOrderStorage where   initialValue = WSO Nothing@@ -148,10 +152,26 @@ swapOrder w1 w2 = do   io $ print (w1,w2)   WSO (Just m) <- XS.get-  let [i1,i2] = map (fromJust . flip M.lookup m) [w1,w2]+  let i1 = fromJust (w1 `M.lookup` m)+  let i2 = fromJust (w2 `M.lookup` m)   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 +186,19 @@ shiftTo :: Direction1D -> WSType -> X () shiftTo dir t = doTo dir t getSortByOrder (windows . W.shift) --- | 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+-- | 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 (map W.tag . sort . W.workspaces . windowset)+  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 = withNthWorkspace' id
XMonad/Actions/DynamicWorkspaces.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.DynamicWorkspaces+-- Description :  Provides bindings to add and delete workspaces. -- Copyright   :  (c) David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -16,28 +17,34 @@                                          -- * Usage                                          -- $usage                                          addWorkspace, addWorkspacePrompt,+                                         appendWorkspace, appendWorkspacePrompt,+                                         addWorkspaceAt,                                          removeWorkspace,+                                         removeWorkspaceByTag,                                          removeEmptyWorkspace,+                                         removeEmptyWorkspaceByTag,                                          removeEmptyWorkspaceAfter,                                          removeEmptyWorkspaceAfterExcept,-                                         addHiddenWorkspace,+                                         addHiddenWorkspace, addHiddenWorkspaceAt,                                          withWorkspace,                                          selectWorkspace, renameWorkspace,                                          renameWorkspaceByName,-                                         toNthWorkspace, withNthWorkspace+                                         toNthWorkspace, withNthWorkspace,+                                         setWorkspaceIndex, withWorkspaceIndex,+                                         WorkspaceIndex                                        ) where +import XMonad.Prelude (find, isNothing, nub, when) import XMonad hiding (workspaces) import XMonad.StackSet hiding (filter, modify, delete) import XMonad.Prompt.Workspace ( Wor(Wor), workspacePrompt )-import XMonad.Prompt ( XPConfig, mkXPrompt )+import XMonad.Prompt ( XPConfig, mkComplFunFromList', mkXPrompt ) import XMonad.Util.WorkspaceCompare ( getSortByIndex )-import Data.List (find)-import Data.Maybe (isNothing)-import Control.Monad (when)+import qualified Data.Map.Strict as Map+import qualified XMonad.Util.ExtensibleState as XS  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- > import XMonad.Actions.DynamicWorkspaces -- > import XMonad.Actions.CopyWindow(copy)@@ -45,42 +52,82 @@ -- Then add keybindings like the following: -- -- >   , ((modm .|. shiftMask, xK_BackSpace), removeWorkspace)--- >   , ((modm .|. shiftMask, xK_v      ), selectWorkspace defaultXPConfig)--- >   , ((modm, xK_m                    ), withWorkspace defaultXPConfig (windows . W.shift))--- >   , ((modm .|. shiftMask, xK_m      ), withWorkspace defaultXPConfig (windows . copy))--- >   , ((modm .|. shiftMask, xK_r      ), renameWorkspace defaultXPConfig)+-- >   , ((modm .|. shiftMask, xK_v      ), selectWorkspace def)+-- >   , ((modm, xK_m                    ), withWorkspace def (windows . W.shift))+-- >   , ((modm .|. shiftMask, xK_m      ), withWorkspace def (windows . copy))+-- >   , ((modm .|. shiftMask, xK_r      ), renameWorkspace def) ----- > -- mod-[1..9]       %! Switch to workspace N--- > -- mod-shift-[1..9] %! Move client to workspace N+-- > -- mod-[1..9]       %! Switch to workspace N in the list of workspaces+-- > -- mod-shift-[1..9] %! Move client to workspace N in the list of workspaces -- >    ++ -- >    zip (zip (repeat (modm)) [xK_1..xK_9]) (map (withNthWorkspace W.greedyView) [0..]) -- >    ++ -- >    zip (zip (repeat (modm .|. shiftMask)) [xK_1..xK_9]) (map (withNthWorkspace W.shift) [0..]) --+-- Alternatively, you can associate indexes (which don't depend of the+-- workspace list order) to workspaces by using following keybindings:+--+-- > -- mod-[1..9]         %! Switch to workspace of index N+-- > -- mod-control-[1..9] %! Set index N to the current workspace+-- >    +++-- >    zip (zip (repeat (modm)) [xK_1..xK_9]) (map (withWorkspaceIndex W.greedyView) [1..])+-- >    +++-- >    zip (zip (repeat (modm .|. controlMask)) [xK_1..xK_9]) (map (setWorkspaceIndex) [1..])+-- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings". See also the documentation for--- "XMonad.Actions.CopyWindow", 'windows', 'shift', and 'defaultXPConfig'.+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. See also the documentation for+-- "XMonad.Actions.CopyWindow", 'windows', 'shift', and 'XPConfig'. +type WorkspaceTag = String+-- | The workspace index is mapped to a workspace tag by the user and+-- can be updated.+type WorkspaceIndex  = Int -mkCompl :: [String] -> String -> IO [String]-mkCompl l s = return $ filter (\x -> take (length s) x == s) l+-- | Internal dynamic project state that stores a mapping between+--   workspace indexes and workspace tags.+newtype DynamicWorkspaceState = DynamicWorkspaceState {workspaceIndexMap :: Map.Map WorkspaceIndex WorkspaceTag}+  deriving (Read, Show) +instance ExtensionClass DynamicWorkspaceState where+  initialValue = DynamicWorkspaceState Map.empty+  extensionType = PersistentExtension++-- | Set the index of the current workspace.+setWorkspaceIndex :: WorkspaceIndex -> X ()+setWorkspaceIndex widx = do+  wtag  <- gets (currentTag . windowset)+  wmap <- XS.gets workspaceIndexMap+  XS.modify $ \s -> s {workspaceIndexMap = Map.insert widx wtag wmap}++withWorkspaceIndex :: (String -> WindowSet -> WindowSet) -> WorkspaceIndex -> X ()+withWorkspaceIndex job widx = do+  wtag <- ilookup widx+  maybe (return ()) (windows . job) wtag+    where+      ilookup :: WorkspaceIndex -> X (Maybe WorkspaceTag)+      ilookup idx = Map.lookup idx <$> XS.gets workspaceIndexMap+ withWorkspace :: XPConfig -> (String -> X ()) -> X () withWorkspace c job = do ws <- gets (workspaces . windowset)                          sort <- getSortByIndex                          let ts = map tag $ sort ws                              job' t | t `elem` ts = job t                                     | otherwise = addHiddenWorkspace t >> job t-                         mkXPrompt (Wor "") c (mkCompl ts) job'+                         mkXPrompt (Wor "") c (mkComplFunFromList' c ts) job'  renameWorkspace :: XPConfig -> X () renameWorkspace conf = workspacePrompt conf renameWorkspaceByName  renameWorkspaceByName :: String -> X ()-renameWorkspaceByName w = windows $ \s -> let sett wk = wk { tag = w }-                                              setscr scr = scr { workspace = sett $ workspace scr }-                                              sets q = q { current = setscr $ current q }-                                          in sets $ removeWorkspace' w s+renameWorkspaceByName w = do old  <- gets (currentTag . windowset)+                             windows $ \s -> let sett wk = wk { tag = w }+                                                 setscr scr = scr { workspace = sett $ workspace scr }+                                                 sets q = q { current = setscr $ current q }+                                             in sets $ removeWorkspace' w s+                             updateIndexMap old w+  where updateIndexMap oldIM newIM = do+          wmap <- XS.gets workspaceIndexMap+          XS.modify $ \s -> s {workspaceIndexMap = Map.map (\t -> if t == oldIM then newIM else t) wmap}  toNthWorkspace :: (String -> X ()) -> Int -> X () toNthWorkspace job wnum = do sort <- getSortByIndex@@ -107,21 +154,42 @@ --   workspace with the given name already exists; then switch to the --   newly created workspace. addWorkspace :: String -> X ()-addWorkspace newtag = addHiddenWorkspace newtag >> windows (greedyView newtag)+addWorkspace = addWorkspaceAt (:) +-- | Same as addWorkspace, but adds the workspace to the end of the list of workspaces+appendWorkspace :: String -> X()+appendWorkspace = addWorkspaceAt (flip (++) . return)++-- | Adds a new workspace with the given name to the current list of workspaces.+--   This function allows the user to pass a function that inserts an element+--   into a list at an arbitrary spot.+addWorkspaceAt :: (WindowSpace -> [WindowSpace] -> [WindowSpace]) -> String -> X ()+addWorkspaceAt add newtag = addHiddenWorkspaceAt add newtag >> windows (greedyView newtag)+ -- | Prompt for the name of a new workspace, add it if it does not --   already exist, and switch to it. addWorkspacePrompt :: XPConfig -> X () addWorkspacePrompt conf = mkXPrompt (Wor "New workspace name: ") conf (const (return [])) addWorkspace +-- | Prompt for the name of a new workspace, appending it to the end of the list of workspaces+--   if it does not already exist, and switch to it.+appendWorkspacePrompt :: XPConfig -> X ()+appendWorkspacePrompt conf = mkXPrompt (Wor "New workspace name: ") conf (const (return [])) appendWorkspace+ -- | Add a new hidden workspace with the given name, or do nothing if---   a workspace with the given name already exists.-addHiddenWorkspace :: String -> X ()-addHiddenWorkspace newtag =+--   a workspace with the given name already exists. Takes a function to insert+--   the workspace at an arbitrary spot in the list.+addHiddenWorkspaceAt :: (WindowSpace -> [WindowSpace] -> [WindowSpace]) -> String -> X ()+addHiddenWorkspaceAt add newtag =   whenX (gets (not . tagMember newtag . windowset)) $ do     l <- asks (layoutHook . config)-    windows (addHiddenWorkspace' newtag l)+    windows (addHiddenWorkspace' add newtag l) +-- | Add a new hidden workspace with the given name, or do nothing if+--   a workspace with the given name already exists.+addHiddenWorkspace :: String -> X ()+addHiddenWorkspace = addHiddenWorkspaceAt (:)+ -- | Remove the current workspace if it contains no windows. removeEmptyWorkspace :: X () removeEmptyWorkspace = gets (currentTag . windowset) >>= removeEmptyWorkspaceByTag@@ -130,12 +198,11 @@ removeWorkspace :: X () removeWorkspace = gets (currentTag . windowset) >>= removeWorkspaceByTag --- | Remove workspace with specific tag if it contains no windows. Only works---   on the current or the last workspace.+-- | Remove workspace with specific tag if it contains no windows. removeEmptyWorkspaceByTag :: String -> X () removeEmptyWorkspaceByTag t = whenX (isEmpty t) $ removeWorkspaceByTag t --- | Remove workspace with specific tag. Only works on the current or the last workspace.+-- | Remove workspace with specific tag. removeWorkspaceByTag :: String -> X () removeWorkspaceByTag torem = do     s <- gets windowset@@ -166,16 +233,21 @@                let mws = find (\ws -> tag ws == t) wsl                return $ maybe True (isNothing . stack) mws -addHiddenWorkspace' :: i -> l -> StackSet i l a sid sd -> StackSet i l a sid sd-addHiddenWorkspace' newtag l s@(StackSet { hidden = ws }) = s { hidden = Workspace newtag l Nothing:ws }+addHiddenWorkspace' :: (Workspace i l a -> [Workspace i l a] -> [Workspace i l a]) -> i -> l -> StackSet i l a sid sd -> StackSet i l a sid sd+addHiddenWorkspace' add newtag l s@StackSet{ hidden = ws } = s { hidden = add (Workspace newtag l Nothing) ws } -removeWorkspace' :: (Eq i) => i -> StackSet i l a sid sd -> StackSet i l a sid sd-removeWorkspace' torem s@(StackSet { current = scr@(Screen { workspace = wc })-                                   , hidden = (w:ws) })-    | tag w == torem = s { current = scr { workspace = wc { stack = meld (stack w) (stack wc) } }-                         , hidden = ws }+-- | Remove the hidden workspace with the given tag from the StackSet, if+--   it exists. All the windows in that workspace are moved to the current+--   workspace.+removeWorkspace' :: (Eq i, Eq a) => i -> StackSet i l a sid sd -> StackSet i l a sid sd+removeWorkspace' torem s@StackSet{ current = scr@Screen { workspace = wc }+                                 , hidden  = hs }+    = let (xs, ys) = break ((== torem) . tag) hs+      in removeWorkspace'' xs ys    where meld Nothing Nothing = Nothing          meld x Nothing = x          meld Nothing x = x-         meld (Just x) (Just y) = differentiate (integrate x ++ integrate y)-removeWorkspace' _ s = s+         meld (Just x) (Just y) = differentiate . nub $ integrate x ++ integrate y+         removeWorkspace'' xs (y:ys) = s { current = scr { workspace = wc { stack = meld (stack y) (stack wc) } }+                                         , hidden = xs ++ ys }+         removeWorkspace'' _  _      = s
+ XMonad/Actions/EasyMotion.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.EasyMotion+-- Description :  Focus a visible window using a key chord.+-- Copyright   :  (c) Matt Kingston <mattkingston@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  mattkingston@gmail.com+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides functionality to use key chords to focus a visible window. Overlays a unique key chord+-- (a string) above each visible window and allows the user to select a window by typing that+-- chord.+-- Inspired by <https://github.com/easymotion/vim-easymotion vim-easymotion>.+-- Thanks to <https://github.com/larkery Tom Hinton> for some feature inspiration and window+-- sorting code.+--+-----------------------------------------------------------------------------++module XMonad.Actions.EasyMotion ( -- * Usage+                                   -- $usage+                                   selectWindow++                                   -- * Configuration+                                 , EasyMotionConfig(..)+                                 , ChordKeys(..)+                                 , def++                                   -- * Creating overlays+                                 , fullSize+                                 , fixedSize+                                 , textSize+                                 , proportional+                                 , bar+                                 ) where++import           XMonad+import           XMonad.Prelude+import qualified XMonad.StackSet          as W+import           XMonad.Util.Font         (releaseXMF, initXMF, Align(AlignCenter), XMonadFont(..), textExtentsXMF)+import           XMonad.Util.XUtils       (createNewWindow, paintAndWrite, deleteWindow, showWindow)++import           Control.Arrow            ((&&&))+import qualified Data.Map.Strict as M     (Map, elems, map, mapWithKey)++-- $usage+--+-- You can use this module's basic functionality with the following in your+-- @xmonad.hs@:+--+-- >    import XMonad.Actions.EasyMotion (selectWindow)+--+-- To customise+--+-- >    import XMonad.Actions.EasyMotion (selectWindow, EasyMotionConfig(..))+--+-- Then add a keybinding and an action to the 'selectWindow' function.+-- In this case @M-f@ to focus the selected window:+--+-- >    , ((modm, xK_f), selectWindow def >>= (`whenJust` windows . W.focusWindow))+--+-- Similarly, to kill a window with @M-f@:+--+-- >    , ((modm, xK_f), selectWindow def >>= (`whenJust` killWindow))+--+-- See 'EasyMotionConfig' for all configuration options. A short summary follows.+--+-- Default chord keys are @s,d,f,j,k,l@. To customise these and display options assign+-- different values to 'def' (the default configuration):+--+-- >    , ((modm, xK_f), (selectWindow def{sKeys = AnyKeys [xK_f, xK_d]}) >>= (`whenJust` windows . W.focusWindow))+--+-- You must supply at least two different keys in the 'sKeys' list. Keys provided earlier in the list+-- will be used preferentially—therefore, keys you would like to use more frequently should be+-- earlier in the list.+--+-- To map different sets of keys to different screens. The following configuration maps keys @fdsa@+-- to screen 0 and @hjkl@ to screen 1. Keys provided earlier in the list will be used preferentially.+-- Providing the same key for multiple screens is possible but will break down in some scenarios.+--+-- >    import qualified Data.Map.Strict as StrictMap (fromList)+-- >    emConf :: EasyMotionConfig+-- >    emConf = def { sKeys = PerScreenKeys $ StrictMap.fromList [(0, [xK_f, xK_d, xK_s, xK_a]), (1, [xK_h, xK_j, xK_k, xK_l])] }+-- >    -- key bindings+-- >    , ((modm, xK_f), selectWindow emConf >>= (`whenJust` windows . W.focusWindow))+--+-- To customise the font:+--+-- >    , ((modm, xK_f), (selectWindow def{emFont = "xft: Sans-40"}) >>= (`whenJust` windows . W.focusWindow))+--+-- The 'emFont' field provided is supplied directly to the 'initXMF' function. The default is+-- @"xft:Sans-100"@. Some example options:+--+-- >    "xft: Sans-40"+-- >    "xft: Arial-100"+-- >    "xft: Cambria-80"+--+-- Customise the overlay by supplying a function to 'overlayF'. The signature is+-- @'Position' -> 'Rectangle' -> 'Rectangle'@. The parameters are the height in pixels of+-- the selection chord and the rectangle of the window to be overlaid. Some are provided:+--+-- >    import XMonad.Actions.EasyMotion (selectWindow, EasyMotionConfig(..), proportional, bar, fullSize)+-- >    , ((modm, xK_f), (selectWindow def{ overlayF = proportional 0.3  }) >>= (`whenJust` windows . W.focusWindow))+-- >    , ((modm, xK_f), (selectWindow def{ overlayF = bar 0.5           }) >>= (`whenJust` windows . W.focusWindow))+-- >    , ((modm, xK_f), (selectWindow def{ overlayF = fullSize          }) >>= (`whenJust` windows . W.focusWindow))+-- >    , ((modm, xK_f), (selectWindow def{ overlayF = fixedSize 300 350 }) >>= (`whenJust` windows . W.focusWindow))++-- TODO:+--  - An overlay function that creates an overlay a proportion of the width XOR height of the+--    window it's over, and with a fixed w/h proportion? E.g. overlay-height = 0.3 *+--    target-window-height; overlay-width = 0.5 * overlay-height.+--  - An overlay function that creates an overlay of a fixed w,h, aligned mid,mid, or parametrised+--    alignment?+--  - Parametrise chord generation?+--  - W.shift example; bring window from other screen to current screen? Only useful if we don't+--    show chords on current workspace.+--  - Use stringToKeysym, keysymToKeycode, keycodeToKeysym, keysymToString to take a string from+--    the user?+--  - Think a bit more about improving functionality with floating windows.+--    - currently, floating window z-order is not respected+--    - could ignore floating windows+--    - may be able to calculate the visible section of a floating window, and display the chord in+--      that space+--  - Provide an option to prepend the screen key to the easymotion keys (i.e. w,e,r)?+--  - overlay alpha+--  - Delay after selection so the user can see what they've chosen? Min-delay: 0 seconds. If+--    there's a delay, perhaps keep the other windows covered briefly to naturally draw the user's+--    attention to the window they've selected? Or briefly highlight the border of the selected+--    window?+--  - Option to cover windows that will not be selected by the current chord, such that it's+--    slightly more obvious where to maintain focus.+--  - Something unpleasant happens when the user provides only two keys (let's say f, d) for+--    chords. When they have five windows open, the following chords are generated: ddd, ddf, dfd,+--    dff, fdd. When 'f' is pressed, all chords disappear unexpectedly because we know there are no+--    other valid options. The user expects to press 'fdd'. This is an optimisation in software but+--    pretty bad for usability, as the user continues firing keys into their+--    now-unexpectedly-active window. And is of course only one concrete example of a more general+--    problem.+--    Short-term solution:+--      - Keep displaying the chord until the user has fully entered it+--    Fix:+--      - Show the shortest possible chords++-- | Associates a user window, an overlay window created by this module and a rectangle+--   circumscribing these windows+data OverlayWindow =+  OverlayWindow { win     :: !Window           -- ^ The window managed by xmonad+                , attrs   :: !WindowAttributes -- ^ Window attributes for @win@+                , overlay :: !Window           -- ^ Our window used to display the overlay+                , rect    :: !Rectangle        -- ^ The rectangle of @overlay@+                }++-- | An overlay window and the chord used to select it+data Overlay =+  Overlay { overlayWin :: !OverlayWindow    -- ^ The window managed by xmonad+          , chord      :: ![KeySym]         -- ^ The chord we'll display in the overlay+          }+++-- | Maps keys to windows. 'AnyKeys' maps keys to windows regardless which screen they're on.+--   'PerScreenKeys' maps keys to screens to windows. See @Usage@ for more examples.+data ChordKeys = AnyKeys       ![KeySym]+               | PerScreenKeys !(M.Map ScreenId [KeySym])++-- | Configuration options for EasyMotion.+--+--   All colors are hex strings, e.g. "#000000"+--+--   If the number of windows for which chords are required exceeds 'maxChordLen', chords+--   will simply not be generated for these windows. In this way, single-key selection may be+--   preferred over the ability to select any window.+--+--   'cancelKey', @xK_BackSpace@ and any duplicates will be removed from 'sKeys' if included.+--   See @Usage@ for examples of 'sKeys'.+data EasyMotionConfig =+  EMConf { txtCol      :: !String                               -- ^ Color of the text displayed+         , bgCol       :: !String                               -- ^ Color of the window overlaid+         , overlayF    :: !(Position -> Rectangle -> Rectangle) -- ^ Function to generate overlay rectangle+         , borderCol   :: !String                               -- ^ Color of the overlay window borders+         , sKeys       :: !ChordKeys                            -- ^ Keys to use for window selection+         , cancelKey   :: !KeySym                               -- ^ Key to use to cancel selection+         , emFont      :: !String                               -- ^ Font for selection characters (passed to 'initXMF')+         , borderPx    :: !Int                                  -- ^ Width of border in pixels+         , maxChordLen :: !Int                                  -- ^ Maximum chord length. Use 0 for no maximum.+         }++instance Default EasyMotionConfig where+  def =+    EMConf { txtCol      = "#ffffff"+           , bgCol       = "#000000"+           , overlayF    = proportional (0.3::Double)+           , borderCol   = "#ffffff"+           , sKeys       = AnyKeys [xK_s, xK_d, xK_f, xK_j, xK_k, xK_l]+           , cancelKey   = xK_q+           , borderPx    = 1+           , maxChordLen = 0+#ifdef XFT+           , emFont      = "xft:Sans-100"+#else+           , emFont      = "-misc-fixed-*-*-*-*-200-*-*-*-*-*-*-*"+#endif+           }++-- | Create overlay windows of the same size as the window they select+fullSize :: Position -> Rectangle -> Rectangle+fullSize _ = id++-- | Create overlay windows a proportion of the size of the window they select+proportional :: RealFrac f => f -> Position -> Rectangle -> Rectangle+proportional f th r = Rectangle { rect_width  = newW+                                , rect_height = newH+                                , rect_x      = rect_x r + fi (rect_width r - newW) `div` 2+                                , rect_y      = rect_y r + fi (rect_height r - newH) `div` 2 }+ where+  newH = max (fi th) (round $ f * fi (rect_height r))+  newW = newH++-- | Create fixed-size overlay windows+fixedSize :: (Integral a, Integral b) => a -> b -> Position -> Rectangle -> Rectangle+fixedSize w h th r = Rectangle { rect_width  = rw+                               , rect_height = rh+                               , rect_x      = rect_x r + fi (rect_width r - rw) `div` 2+                               , rect_y      = rect_y r + fi (rect_height r - rh) `div` 2 }+ where+  rw = max (fi w) (fi th)+  rh = max (fi h) (fi th)++-- | Create overlay windows the minimum size to contain their key chord+textSize :: Position -> Rectangle -> Rectangle+textSize th r = Rectangle { rect_width  = fi th+                          , rect_height = fi th+                          , rect_x      = rect_x r + (fi (rect_width r) - fi th) `div` 2+                          , rect_y      = rect_y r + (fi (rect_height r) - fi th) `div` 2 }++-- | Create overlay windows the full width of the window they select, the minimum height to contain+--   their chord, and a proportion of the distance from the top of the window they select+bar :: RealFrac f => f -> Position -> Rectangle -> Rectangle+bar f th r = Rectangle { rect_width  = rect_width r+                       , rect_height = fi th+                       , rect_x      = rect_x r+                       , rect_y      = rect_y r + round (f' * (fi (rect_height r) - fi th)) }+ where+   -- clamp f in [0,1] as other values will appear to lock up xmonad as the overlay will be+   -- displayed off-screen+   f' = min 0.0 $ max f 1.0++-- | Handles overlay display and window selection. Called after config has been sanitised.+handleSelectWindow :: EasyMotionConfig -> X (Maybe Window)+handleSelectWindow EMConf { sKeys = AnyKeys [] } = return Nothing+handleSelectWindow c = do+  f <- initXMF $ emFont c+  th <- (\(asc, dsc) -> asc + dsc + 2) <$> textExtentsXMF f (concatMap keysymToString (allKeys . sKeys $ c))+  XConf { theRoot = rw, display = dpy } <- ask+  XState { mapped = mappedWins, windowset = ws } <- get+  -- build overlays depending on key configuration+  overlays :: [Overlay] <- case sKeys c of+    AnyKeys ks -> buildOverlays ks <$> sortedOverlayWindows+     where+      visibleWindows :: [Window]+      visibleWindows = toList mappedWins+      sortedOverlayWindows :: X [OverlayWindow]+      sortedOverlayWindows = sortOverlayWindows <$> buildOverlayWindows th visibleWindows+    PerScreenKeys m ->+      fmap concat+        $ sequence+        $ M.elems+        $ M.mapWithKey (\sid ks -> buildOverlays ks <$> sortedOverlayWindows sid) m+     where+      screenById :: ScreenId -> Maybe WindowScreen+      screenById sid = find ((== sid) . W.screen) (W.screens ws)+      visibleWindowsOnScreen :: ScreenId -> [Window]+      visibleWindowsOnScreen sid = filter (`elem` toList mappedWins) $ W.integrate' $ screenById sid >>= W.stack . W.workspace+      sortedOverlayWindows :: ScreenId -> X [OverlayWindow]+      sortedOverlayWindows sid = sortOverlayWindows <$> buildOverlayWindows th (visibleWindowsOnScreen sid)+  status <- io $ grabKeyboard dpy rw True grabModeAsync grabModeAsync currentTime+  if status == grabSuccess+    then do+      resultWin <- handleKeyboard dpy (displayOverlay f) (cancelKey c) overlays []+      io $ ungrabKeyboard dpy currentTime+      mapM_ (deleteWindow . overlay . overlayWin) overlays+      io $ sync dpy False+      releaseXMF f+      case resultWin of+        -- focus the selected window+        Selected o -> return . Just . win . overlayWin $ o+        -- return focus correctly+        _ -> whenJust (W.peek ws) (windows . W.focusWindow) $> Nothing+    else releaseXMF f $> Nothing+ where+  allKeys :: ChordKeys -> [KeySym]+  allKeys (AnyKeys ks) = ks+  allKeys (PerScreenKeys m) = concat $ M.elems m++  buildOverlays :: [KeySym] -> [OverlayWindow] -> [Overlay]+  buildOverlays = appendChords (maxChordLen c)++  buildOverlayWindows :: Position -> [Window] -> X [OverlayWindow]+  buildOverlayWindows th = fmap (fromMaybe [] . sequenceA)+                         . traverse (buildOverlayWin th)++  sortOverlayWindows :: [OverlayWindow] -> [OverlayWindow]+  sortOverlayWindows = sortOn ((wa_x &&& wa_y) . attrs)++  makeRect :: WindowAttributes -> Rectangle+  makeRect wa = Rectangle (fi (wa_x wa)) (fi (wa_y wa)) (fi (wa_width wa)) (fi (wa_height wa))++  buildOverlayWin :: Position -> Window -> X (Maybe OverlayWindow)+  buildOverlayWin th w = safeGetWindowAttributes w >>= \case+    Nothing     -> pure Nothing+    Just wAttrs -> do+      let r = overlayF c th $ makeRect wAttrs+      o <- createNewWindow r Nothing "" True+      return . Just $ OverlayWindow { rect=r, overlay=o, win=w, attrs=wAttrs }++  -- | Display an overlay with the provided formatting+  displayOverlay :: XMonadFont -> Overlay -> X ()+  displayOverlay f Overlay { overlayWin = OverlayWindow { rect = r, overlay = o }, chord = ch } = do+    showWindow o+    paintAndWrite o f (fi (rect_width r)) (fi (rect_height r)) (fi (borderPx c)) (bgCol c) (borderCol c) (txtCol c) (bgCol c) [AlignCenter] [concatMap keysymToString ch]++-- | Display overlay windows and chords for window selection+selectWindow :: EasyMotionConfig -> X (Maybe Window)+selectWindow conf =+  handleSelectWindow conf { sKeys = sanitiseKeys (sKeys conf) }+ where+  -- make sure the key lists don't contain: backspace, our cancel key, or duplicates+  sanitise :: [KeySym] -> [KeySym]+  sanitise = nub . filter (`notElem` [xK_BackSpace, cancelKey conf])+  sanitiseKeys :: ChordKeys -> ChordKeys+  sanitiseKeys cKeys =+    case cKeys of+      AnyKeys ks -> AnyKeys . sanitise $ ks+      PerScreenKeys m -> PerScreenKeys $ M.map sanitise m++-- | Take a list of overlays lacking chords, return a list of overlays with key chords+appendChords :: Int -> [KeySym] -> [OverlayWindow] -> [Overlay]+appendChords _ [] _ = []+appendChords maxUserSelectedLen ks overlayWins =+  zipWith Overlay overlayWins chords+ where+  chords = replicateM chordLen ks+  -- the minimum necessary chord length to assign a unique chord to each visible window+  minCoverLen = -((-(length overlayWins)) `div` length ks)+  -- if the user has specified a max chord length we use this even if it will not cover all+  -- windows, as they may prefer to focus windows with fewer keys over the ability to focus any+  -- window+  chordLen = if maxUserSelectedLen <= 0 then minCoverLen else min minCoverLen maxUserSelectedLen++-- | A three-state result for handling user-initiated selection cancellation, successful selection,+--   or backspace.+data HandleResult = Exit | Selected Overlay | Backspace++-- | Handle key press events for window selection.+handleKeyboard :: Display -> (Overlay -> X()) -> KeySym -> [Overlay] -> [Overlay] -> X HandleResult+handleKeyboard _ _ _ [] _ = return Exit+handleKeyboard dpy drawFn cancel selected deselected = do+  redraw+  ev <- io $ allocaXEvent $ \e -> do+    maskEvent dpy (keyPressMask .|. keyReleaseMask .|. buttonPressMask) e+    getEvent e+  if | ev_event_type ev == keyPress -> do+         s <- io $ keycodeToKeysym dpy (ev_keycode ev) 0+         if | s == cancel -> return Exit+            | s == xK_BackSpace -> return Backspace+            | isNextOverlayKey s -> handleNextOverlayKey s+            | otherwise -> handleKeyboard dpy drawFn cancel selected deselected+     | ev_event_type ev == buttonPress -> do+         -- See XMonad.Prompt Note [Allow ButtonEvents]+         io $ allowEvents dpy replayPointer currentTime+         handleKeyboard dpy drawFn cancel selected deselected+     | otherwise -> handleKeyboard dpy drawFn cancel selected deselected+ where+  redraw = mapM (mapM_ drawFn) [selected, deselected]+  retryBackspace x =+    case x of+      Backspace -> redraw >> handleKeyboard dpy drawFn cancel selected deselected+      _ -> return x+  isNextOverlayKey keySym = isJust (find ((== Just keySym) . listToMaybe .chord) selected)+  handleNextOverlayKey keySym =+    case fg of+      [x] -> return $ Selected x+      _   -> handleKeyboard dpy drawFn cancel (trim fg) (clear bg) >>= retryBackspace+   where+    (fg, bg) = partition ((== Just keySym) . listToMaybe . chord) selected+    trim = map (\o -> o { chord = drop 1 $ chord o })+    clear = map (\o -> o { chord = [] })
XMonad/Actions/FindEmptyWorkspace.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.FindEmptyWorkspace+-- Description :  Find an empty workspace. -- Copyright   :  (c) Miikka Koskinen 2007 -- License     :  BSD3-style (see LICENSE) --@@ -18,15 +19,13 @@     viewEmptyWorkspace, tagToEmptyWorkspace, sendToEmptyWorkspace   ) where -import Data.List-import Data.Maybe ( isNothing )-+import XMonad.Prelude import XMonad import XMonad.StackSet  -- $usage ----- To use, import this module into your @~\/.xmonad\/xmonad.hs@:+-- To use, import this module into your @xmonad.hs@: -- -- >   import XMonad.Actions.FindEmptyWorkspace --@@ -39,7 +38,7 @@ -- will tag the current window to an empty workspace and view it. -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Find the first hidden empty workspace in a StackSet. Returns -- Nothing if all workspaces are in use. Function searches currently
XMonad/Actions/FlexibleManipulate.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.FlexibleManipulate+-- Description :  Move and resize floating windows without warping the mouse. -- Copyright   :  (c) Michael Sloan -- License     :  BSD3-style (see LICENSE) --@@ -23,11 +24,12 @@ ) where  import XMonad+import XMonad.Prelude ((<&>), fi) import qualified Prelude as P-import Prelude (($), (.), fst, snd, uncurry, const, id, Ord(..), Monad(..), fromIntegral, Double, Integer, map, round, otherwise)+import Prelude (Double, Integer, Ord (..), const, fromIntegral, fst, id, otherwise, round, snd, uncurry, ($))  -- $usage--- First, add this import to your @~\/.xmonad\/xmonad.hs@:+-- First, add this import to your @xmonad.hs@: -- -- > import qualified XMonad.Actions.FlexibleManipulate as Flex --@@ -78,43 +80,36 @@ -- | Given an interpolation function, implement an appropriate window --   manipulation action. mouseWindow :: (Double -> Double) -> Window -> X ()-mouseWindow f w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    [wpos, wsize] <- io $ getWindowAttributes d w >>= return . winAttrs+mouseWindow f w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do+    let wpos  = (fi (wa_x wa), fi (wa_y wa))+        wsize = (fi (wa_width wa), fi (wa_height wa))     sh <- io $ getWMNormalHints d w-    pointer <- io $ queryPointer d w >>= return . pointerPos+    pointer <- io $ queryPointer d w <&> pointerPos      let uv = (pointer - wpos) / wsize         fc = mapP f uv         mul = mapP (\x -> 2 P.- 2 P.* P.abs(x P.- 0.5)) fc --Fudge factors: interpolation between 1 when on edge, 2 in middle         atl = ((1, 1) - fc) * mul         abr = fc * mul-    mouseDrag (\ex ey -> io $ do+    mouseDrag (\ex ey -> do         let offset = (fromIntegral ex, fromIntegral ey) - pointer             npos = wpos + offset * atl             nbr = (wpos + wsize) + offset * abr             ntl = minP (nbr - (32, 32)) npos    --minimum size             nwidth = applySizeHintsContents sh $ mapP (round :: Double -> Integer) (nbr - ntl)-        moveResizeWindow d w (round $ fst ntl) (round $ snd ntl) `uncurry` nwidth-        return ())+        io $ moveResizeWindow d w (round $ fst ntl) (round $ snd ntl) `uncurry` nwidth+        float w)         (float w)      float w    where     pointerPos (_,_,_,px,py,_,_,_) = (fromIntegral px,fromIntegral py) :: Pnt-    winAttrs :: WindowAttributes -> [Pnt]-    winAttrs x = pairUp $ map (fromIntegral . ($ x)) [wa_x, wa_y, wa_width, wa_height] - -- I'd rather I didn't have to do this, but I hate writing component 2d math type Pnt = (Double, Double) -pairUp :: [a] -> [(a,a)]-pairUp [] = []-pairUp [_] = []-pairUp (x:y:xs) = (x, y) : (pairUp xs)- mapP :: (a -> b) -> (a, a) -> (b, b) mapP f (x, y) = (f x, f y) zipP :: (a -> b -> c) -> (a,a) -> (b,b) -> (c,c)@@ -132,4 +127,3 @@ (*) = zipP (P.*) (/) :: (P.Fractional a) => (a,a) -> (a,a) -> (a,a) (/) = zipP (P./)-
XMonad/Actions/FlexibleResize.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.FlexibleResize+-- Description :  Resize floating windows from any corner. -- Copyright   :  (c) Lukas Mai -- License     :  BSD3-style (see LICENSE) --@@ -20,11 +21,11 @@ ) where  import XMonad-import XMonad.Util.XUtils (fi)+import XMonad.Prelude (fi) import Foreign.C.Types  -- $usage--- To use, first import this module into your @~\/.xmonad\/xmonad.hs@ file:+-- To use, first import this module into your @xmonad.hs@ file: -- -- > import qualified XMonad.Actions.FlexibleResize as Flex --@@ -49,29 +50,32 @@   :: Rational -- ^ The size of the area where only one edge is resized.   -> Window   -- ^ The window to resize.   -> X ()-mouseResizeEdgeWindow edge w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w+mouseResizeEdgeWindow edge w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     sh <- io $ getWMNormalHints d w     (_, _, _, _, _, ix, iy, _) <- io $ queryPointer d w     let-        [pos_x, pos_y, width, height] = map (fi . ($ wa)) [wa_x, wa_y, wa_width, wa_height]+        pos_x  = fi $ wa_x wa+        pos_y  = fi $ wa_y wa+        width  = fi $ wa_width wa+        height = fi $ wa_height wa         west  = findPos ix width         north = findPos iy height         (cx, fx, gx) = mkSel west  width  pos_x         (cy, fy, gy) = mkSel north height pos_y     io $ warpPointer d none w 0 0 0 0 cx cy     mouseDrag (\ex ey -> do let (nw,nh) = applySizeHintsContents sh (gx ex, gy ey)-                            io $ moveResizeWindow d w (fx nw) (fy nh) nw nh)+                            io $ moveResizeWindow d w (fx nw) (fy nh) nw nh+                            float w)               (float w)     where     findPos :: CInt -> Position -> Maybe Bool-    findPos m s = if p < 0.5 - edge/2-                  then Just True-                  else if p < 0.5 + edge/2-                       then Nothing-                       else Just False-                  where p = fi m / fi s+    findPos m s+      | p < 0.5 - edge/2 = Just True+      | p < 0.5 + edge/2 = Nothing+      | otherwise = Just False+      where+          p = fi m / fi s     mkSel :: Maybe Bool -> Position -> Position -> (Position, Dimension -> Position, Position -> Dimension)     mkSel b k p = case b of                       Just True ->  (0, (fi k + fi p -).fi, (fi k + fi p -).fi)
XMonad/Actions/FloatKeys.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.FloatKeys+-- Description  :  Move and resize floating windows. -- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de> -- License      : BSD --@@ -18,13 +19,18 @@                 keysMoveWindowTo,                 keysResizeWindow,                 keysAbsResizeWindow,-                P, G,+                directionMoveWindow,+                directionResizeWindow,+                Direction2D(..),+                P, G, ChangeDim                 ) where  import XMonad+import XMonad.Prelude (fi)+import XMonad.Util.Types  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.FloatKeys --@@ -36,17 +42,44 @@ -- >  , ((modm .|. shiftMask, xK_s     ), withFocused (keysAbsResizeWindow (10,10) (1024,752))) -- >  , ((modm,               xK_a     ), withFocused (keysMoveWindowTo (512,384) (1%2,1%2))) --+-- Using "XMonad.Util.EZConfig" syntax, we can easily build keybindings+-- where @M-\<arrow-keys\>@ moves the currently focused window and+-- @M-S-\<arrow-keys\>@ resizes it using 'directionMoveWindow' and+-- 'directionResizeWindow':+--+-- > [ ("M-" <> m <> k, withFocused $ f i)+-- > | (i, k) <- zip [U, D, R, L] ["<Up>", "<Down>", "<Right>", "<Left>"]+-- > , (f, m) <- [(directionMoveWindow 10, ""), (directionResizeWindow 10, "S-")]+-- > ]+-- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. +-- | @directionMoveWindow delta dir win@ moves the window @win@ by+--   @delta@ pixels in direction @dir@.+directionMoveWindow :: Int -> Direction2D -> Window -> X ()+directionMoveWindow delta dir win = case dir of+  U -> keysMoveWindow (0, -delta) win+  D -> keysMoveWindow (0, delta)  win+  R -> keysMoveWindow (delta, 0)  win+  L -> keysMoveWindow (-delta, 0) win++-- | @directionResizeWindow delta dir win@ resizes the window @win@ by+--   @delta@ pixels in direction @dir@.+directionResizeWindow :: Int -> Direction2D -> Window -> X ()+directionResizeWindow delta dir win = case dir of+  U -> keysResizeWindow (0, -delta) (0, 0) win+  D -> keysResizeWindow (0, delta)  (0, 0) win+  R -> keysResizeWindow (delta, 0)  (0, 0) win+  L -> keysResizeWindow (-delta, 0) (0, 0) win+ -- | @keysMoveWindow (dx, dy)@ moves the window by @dx@ pixels to the --   right and @dy@ pixels down.-keysMoveWindow :: D -> Window -> X ()-keysMoveWindow (dx,dy) w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w-    io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + dx))-                        (fromIntegral (fromIntegral (wa_y wa) + dy))+keysMoveWindow :: ChangeDim -> Window -> X ()+keysMoveWindow (dx,dy) w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do+    io $ moveWindow d w (fi (fi (wa_x wa) + dx))+                        (fi (fi (wa_y wa) + dy))     float w  -- | @keysMoveWindowTo (x, y) (gx, gy)@ moves the window relative@@ -60,15 +93,15 @@ -- > keysMoveWindowTo (512,384) (1%2, 1%2) -- center the window on screen -- > keysMoveWindowTo (1024,0) (1, 0)      -- put window in the top right corner keysMoveWindowTo :: P -> G -> Window -> X ()-keysMoveWindowTo (x,y) (gx, gy) w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w-    io $ moveWindow d w (x - round (gx * fromIntegral (wa_width wa)))-                        (y - round (gy * fromIntegral (wa_height wa)))+keysMoveWindowTo (x,y) (gx, gy) w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do+    io $ moveWindow d w (x - round (gx * fi (wa_width wa)))+                        (y - round (gy * fi (wa_height wa)))     float w  type G = (Rational, Rational) type P = (Position, Position)+type ChangeDim = (Int, Int)  -- | @keysResizeWindow (dx, dy) (gx, gy)@ changes the width by @dx@ --   and the height by @dy@, leaving the window-relative point @(gx,@@ -80,7 +113,7 @@ -- > keysResizeWindow (10, 0) (0, 1%2)    -- does the same, unless sizeHints are applied -- > keysResizeWindow (10, 10) (1%2, 1%2) -- add 5 pixels on each side -- > keysResizeWindow (-10, -10) (0, 1)   -- shrink the window in direction of the bottom-left corner-keysResizeWindow :: D -> G -> Window -> X ()+keysResizeWindow :: ChangeDim -> G -> Window -> X () keysResizeWindow = keysMoveResize keysResizeWindow'  -- | @keysAbsResizeWindow (dx, dy) (ax, ay)@ changes the width by @dx@@@ -90,34 +123,34 @@ --   For example: -- -- > keysAbsResizeWindow (10, 10) (0, 0)   -- enlarge the window; if it is not in the top-left corner it will also be moved down and to the right.-keysAbsResizeWindow :: D -> D -> Window -> X ()+keysAbsResizeWindow :: ChangeDim -> D -> Window -> X () keysAbsResizeWindow = keysMoveResize keysAbsResizeWindow' -keysAbsResizeWindow' :: SizeHints -> P -> D -> D -> D -> (P,D)+keysAbsResizeWindow' :: SizeHints -> P -> D -> ChangeDim -> D -> (P,D) keysAbsResizeWindow' sh (x,y) (w,h) (dx,dy) (ax, ay) = ((round nx, round ny), (nw, nh))     where-        (nw, nh) = applySizeHintsContents sh (w + dx, h + dy)+        -- The width and height of a window are positive and thus+        -- converting to 'Dimension' should be safe.+        (nw, nh) = applySizeHintsContents sh (fi w + dx, fi h + dy)         nx :: Rational-        nx = fromIntegral (ax * w + nw * (fromIntegral x - ax)) / fromIntegral w+        nx = fi (ax * w + nw * (fi x - ax)) / fi w         ny :: Rational-        ny = fromIntegral (ay * h + nh * (fromIntegral y - ay)) / fromIntegral h+        ny = fi (ay * h + nh * (fi y - ay)) / fi h -keysResizeWindow' :: SizeHints -> P -> D -> D -> G -> (P,D)+keysResizeWindow' :: SizeHints -> P -> D -> ChangeDim -> G -> (P,D) keysResizeWindow' sh (x,y) (w,h) (dx,dy) (gx, gy) = ((nx, ny), (nw, nh))     where-        (nw, nh) = applySizeHintsContents sh (w + dx, h + dy)-        nx = round $ fromIntegral x + gx * fromIntegral w - gx * fromIntegral nw-        ny = round $ fromIntegral y + gy * fromIntegral h - gy * fromIntegral nh+        (nw, nh) = applySizeHintsContents sh (fi w + dx, fi h + dy)+        nx = round $ fi x + gx * fi w - gx * fi nw+        ny = round $ fi y + gy * fi h - gy * fi nh  keysMoveResize :: (SizeHints -> P -> D -> a -> b -> (P,D)) -> a -> b -> Window -> X ()-keysMoveResize f move resize w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w+keysMoveResize f move resize w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     sh <- io $ getWMNormalHints d w-    let wa_dim = (fromIntegral $ wa_width wa, fromIntegral $ wa_height wa)-        wa_pos = (fromIntegral $ wa_x wa, fromIntegral $ wa_y wa)+    let wa_dim = (fi $ wa_width wa, fi $ wa_height wa)+        wa_pos = (fi $ wa_x wa, fi $ wa_y wa)         (wn_pos, wn_dim) = f sh wa_pos wa_dim move resize     io $ resizeWindow d w `uncurry` wn_dim     io $ moveWindow d w `uncurry` wn_pos     float w-
XMonad/Actions/FloatSnap.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.FloatSnap+-- Description :  Snap to other windows or the edge of the screen while moving or resizing. -- Copyright   :  (c) 2009 Anders Engstrom <ankaan@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -21,21 +22,22 @@                 snapShrink,                 snapMagicMove,                 snapMagicResize,-                snapMagicMouseResize) where+                snapMagicMouseResize,+                afterDrag,+                ifClick,+                ifClick') where  import XMonad-import Control.Applicative((<$>))-import Data.List (sort)-import Data.Maybe (listToMaybe,fromJust,isNothing)+import XMonad.Prelude (fromJust, isNothing, listToMaybe, sort, when) import qualified XMonad.StackSet as W+import qualified Data.Set as S  import XMonad.Hooks.ManageDocks (calcGap) import XMonad.Util.Types (Direction2D(..))--import qualified Data.Set as S+import XMonad.Actions.AfterDrag  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.FloatSnap --@@ -51,20 +53,27 @@ -- >        , ((modm .|. shiftMask, xK_Down),  withFocused $ snapGrow D Nothing) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. ----- And possibly add an appropriate mouse binding, for example:+-- And possibly add appropriate mouse bindings, for example: ----- >        , ((modm,               button1), (\w -> focus w >> mouseMoveWindow w >> snapMagicMove (Just 50) (Just 50) w))--- >        , ((modm .|. shiftMask, button1), (\w -> focus w >> mouseMoveWindow w >> snapMagicResize [L,R,U,D] (Just 50) (Just 50) w))--- >        , ((modm,               button3), (\w -> focus w >> mouseResizeWindow w >> snapMagicResize [R,D] (Just 50) (Just 50) w))+-- >        , ((modm,               button1), (\w -> focus w >> mouseMoveWindow w >> ifClick (snapMagicMove (Just 50) (Just 50) w)))+-- >        , ((modm .|. shiftMask, button1), (\w -> focus w >> mouseMoveWindow w >> ifClick (snapMagicResize [L,R,U,D] (Just 50) (Just 50) w)))+-- >        , ((modm,               button3), (\w -> focus w >> mouseResizeWindow w >> ifClick (snapMagicResize [R,D] (Just 50) (Just 50) w))) -- -- For detailed instructions on editing your mouse bindings, see -- "XMonad.Doc.Extending#Editing_mouse_bindings". -- -- Using these mouse bindings, it will not snap while moving, but allow you to click the window once after it has been moved or resized to snap it into place.--- Note that the order in which the commands are applied in the mouse bindings are important.+-- Note that the order in which the commands are applied in the mouse bindings are important. Snapping can also be used together with other window resizing+-- functions, such as those from "XMonad.Actions.FlexibleResize" --+-- An alternative set of mouse bindings that will always snap after the drag is:+--+-- >        , ((modm,               button1), (\w -> focus w >> mouseMoveWindow w >> afterDrag (snapMagicMove (Just 50) (Just 50) w)))+-- >        , ((modm .|. shiftMask, button1), (\w -> focus w >> mouseMoveWindow w >> afterDrag (snapMagicResize [L,R,U,D] (Just 50) (Just 50) w)))+-- >        , ((modm,               button3), (\w -> focus w >> mouseResizeWindow w >> afterDrag (snapMagicResize [R,D] (Just 50) (Just 50) w)))+-- -- Interesting values for the distance to look for window in the orthogonal axis are Nothing (to snap against every window), Just 0 (to only snap -- against windows that we should collide with geometrically while moving) and Just 1 (to also snap against windows we brush against). --@@ -83,17 +92,17 @@     -> Maybe Int -- ^ The maximum distance to snap. Use Nothing to not impose any boundary.     -> Window    -- ^ The window to move and resize.     -> X ()-snapMagicMouseResize middle collidedist snapdist w = whenX (isClient w) $ withDisplay $ \d -> do-    wa <- io $ getWindowAttributes d w+snapMagicMouseResize middle collidedist snapdist w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     (_, _, _, px, py, _, _, _) <- io $ queryPointer d w-    let x = (fromIntegral px - wx wa)/(ww wa)-        y = (fromIntegral py - wy wa)/(wh wa)-        ml = if x <= (0.5 - middle/2) then [L] else []-        mr = if x >  (0.5 + middle/2) then [R] else []-        mu = if y <= (0.5 - middle/2) then [U] else []-        md = if y >  (0.5 + middle/2) then [D] else []+    let x = (fromIntegral px - wx wa)/ww wa+        y = (fromIntegral py - wy wa)/wh wa+        ml = [L | x <= (0.5 - middle/2)]+        mr = [R | x >  (0.5 + middle/2)]+        mu = [U | y <= (0.5 - middle/2)]+        md = [D | y >  (0.5 + middle/2)]         mdir = ml++mr++mu++md-        dir = if mdir == []+        dir = if null mdir               then [L,R,U,D]               else mdir     snapMagicResize dir collidedist snapdist w@@ -110,19 +119,17 @@     -> Maybe Int   -- ^ The maximum distance to snap. Use Nothing to not impose any boundary.     -> Window      -- ^ The window to move and resize.     -> X ()-snapMagicResize dir collidedist snapdist w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w-+snapMagicResize dir collidedist snapdist w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     (xbegin,xend) <- handleAxis True d wa     (ybegin,yend) <- handleAxis False d wa -    let xbegin' = if L `elem` dir then xbegin else (wx wa)-        xend'   = if R `elem` dir then xend   else (wx wa + ww wa)-        ybegin' = if U `elem` dir then ybegin else (wy wa)-        yend'   = if D `elem` dir then yend   else (wy wa + wh wa)+    let xbegin' = if L `elem` dir then xbegin else wx wa+        xend'   = if R `elem` dir then xend   else wx wa + ww wa+        ybegin' = if U `elem` dir then ybegin else wy wa+        yend'   = if D `elem` dir then yend   else wy wa + wh wa -    io $ moveWindow d w (fromIntegral $ xbegin') (fromIntegral $ ybegin')+    io $ moveWindow d w (fromIntegral xbegin') (fromIntegral ybegin')     io $ resizeWindow d w (fromIntegral $ xend' - xbegin') (fromIntegral $ yend' - ybegin')     float w     where@@ -142,13 +149,13 @@                             (Nothing,Nothing) -> wpos wa                 end = if fs                       then wpos wa + wdim wa-                      else case (if mfl==(Just begin) then Nothing else mfl,mfr) of+                      else case (if mfl==Just begin then Nothing else mfl,mfr) of                           (Just fl,Just fr) -> if wpos wa + wdim wa - fl < fr - wpos wa - wdim wa then fl else fr                           (Just fl,Nothing) -> fl                           (Nothing,Just fr) -> fr                           (Nothing,Nothing) -> wpos wa + wdim wa-                begin' = if isNothing snapdist || abs (begin - wpos wa) <= fromJust snapdist then begin else (wpos wa)-                end' = if isNothing snapdist || abs (end - wpos wa - wdim wa) <= fromJust snapdist then end else (wpos wa + wdim wa)+                begin' = if isNothing snapdist || abs (begin - wpos wa) <= fromJust snapdist then begin else wpos wa+                end' = if isNothing snapdist || abs (end - wpos wa - wdim wa) <= fromJust snapdist then end else wpos wa + wdim wa             return (begin',end')             where                 (wpos, wdim, _, _) = constructors horiz@@ -160,10 +167,8 @@     -> Maybe Int -- ^ The maximum distance to snap. Use Nothing to not impose any boundary.     -> Window    -- ^ The window to move.     -> X ()-snapMagicMove collidedist snapdist w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w-+snapMagicMove collidedist snapdist w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     nx <- handleAxis True d wa     ny <- handleAxis False d wa @@ -184,8 +189,8 @@                                     (Just fl,Nothing) -> fl                                     (Nothing,Just fr) -> fr                                     (Nothing,Nothing) -> wpos wa-                              newpos = if abs (b - wpos wa) <= abs (f - wpos wa - wdim wa) then b else (f - wdim wa)-                          in if isNothing snapdist || abs (newpos - wpos wa) <= fromJust snapdist then newpos else (wpos wa)+                              newpos = if abs (b - wpos wa) <= abs (f - wpos wa - wdim wa) then b else f - wdim wa+                          in if isNothing snapdist || abs (newpos - wpos wa) <= fromJust snapdist then newpos else wpos wa             where                 (wpos, wdim, _, _) = constructors horiz @@ -201,9 +206,8 @@ snapMove D = doSnapMove False False  doSnapMove :: Bool -> Bool -> Maybe Int -> Window -> X ()-doSnapMove horiz rev collidedist w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w+doSnapMove horiz rev collidedist w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     ((bl,br,_),(fl,fr,_)) <- getSnap horiz collidedist d w      let (mb,mf) = if rev then (bl,fl)@@ -241,9 +245,8 @@ snapShrink = snapResize False  snapResize :: Bool -> Direction2D -> Maybe Int -> Window -> X ()-snapResize grow dir collidedist w = whenX (isClient w) $ withDisplay $ \d -> do-    io $ raiseWindow d w-    wa <- io $ getWindowAttributes d w+snapResize grow dir collidedist w = whenX (isClient w) $ withDisplay $ \d ->+  withWindowAttributes d w $ \wa -> do     mr <- case dir of               L -> do ((mg,ms,_),(_,_,_)) <- getSnap True collidedist d w                       return $ case (if grow then mg else ms) of@@ -264,9 +267,8 @@      case mr of         Nothing -> return ()-        Just (nx,ny,nw,nh) -> if nw>0 && nh>0 then do io $ moveWindow d w (fromIntegral nx) (fromIntegral ny)-                                                      io $ resizeWindow d w (fromIntegral nw) (fromIntegral nh)-                                              else return ()+        Just (nx,ny,nw,nh) -> when (nw>0 && nh>0) $ do io $ moveWindow d w (fromIntegral nx) (fromIntegral ny)+                                                       io $ resizeWindow d w (fromIntegral nw) (fromIntegral nh)     float w     where         wx = fromIntegral.wa_x@@ -281,8 +283,8 @@     screen <- W.current <$> gets windowset     let sr = screenRect $ W.screenDetail screen         wl = W.integrate' . W.stack $ W.workspace screen-    gr <- fmap ($sr) $ calcGap $ S.fromList [minBound .. maxBound]-    wla <- filter (collides wa) `fmap` (io $ mapM (getWindowAttributes d) $ filter (/=w) wl)+    gr <- ($ sr) <$> calcGap (S.fromList [minBound .. maxBound])+    wla <- filter (collides wa) <$> io (mapM (getWindowAttributes d) $ filter (/=w) wl)      return ( neighbours (back wa sr gr wla) (wpos wa)            , neighbours (front wa sr gr wla) (wpos wa + wdim wa)@@ -296,8 +298,8 @@          back wa sr gr wla = dropWhile (< rpos sr) $                             takeWhile (< rpos sr + rdim sr) $-                            sort $ (rpos sr):(rpos gr):(rpos gr + rdim gr):-                                   foldr (\a as -> (wpos a):(wpos a + wdim a + wborder a + wborder wa):as) [] wla+                            sort $ rpos sr:rpos gr:(rpos gr + rdim gr):+                                   foldr (\a as -> wpos a:(wpos a + wdim a + wborder a + wborder wa):as) [] wla          front wa sr gr wla = dropWhile (<= rpos sr) $                              takeWhile (<= rpos sr + rdim sr) $@@ -311,8 +313,8 @@          collides wa oa = case collidedist of                              Nothing -> True-                             Just dist -> (  refwpos oa - wborder oa < refwpos wa + refwdim wa + wborder wa + dist-                                          && refwpos wa - wborder wa - dist < refwpos oa + refwdim oa + wborder oa )+                             Just dist -> refwpos oa - wborder oa < refwpos wa + refwdim wa + wborder wa + dist+                                       && refwpos wa - wborder wa - dist < refwpos oa + refwdim oa + wborder oa   constructors :: Bool -> (WindowAttributes -> Int, WindowAttributes -> Int, Rectangle -> Int, Rectangle -> Int)
XMonad/Actions/FocusNth.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE ViewPatterns #-}+ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.FocusNth+-- Description  : Focus the nth window of the current workspace. -- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de> -- License      : BSD --@@ -14,13 +17,15 @@ module XMonad.Actions.FocusNth (                  -- * Usage                  -- $usage-                 focusNth,focusNth') where+                 focusNth,focusNth',+                 swapNth,swapNth') where -import XMonad.StackSet import XMonad+import XMonad.Prelude+import XMonad.StackSet  -- $usage--- Add the import to your @~\/.xmonad\/xmonad.hs@:+-- Add the import to your @xmonad.hs@: -- -- > import XMonad.Actions.FocusNth --@@ -31,20 +36,22 @@ -- >     | (i, k) <- zip [0 .. 8] [xK_1 ..]] -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Give focus to the nth window of the current workspace. focusNth :: Int -> X () focusNth = windows . modify' . focusNth'  focusNth' :: Int -> Stack a -> Stack a-focusNth' n s@(Stack _ ls rs) | (n < 0) || (n > length(ls) + length(rs)) = s-                              | otherwise = listToStack n (integrate s)--listToStack :: Int -> [a] -> Stack a-listToStack n l = Stack t ls rs- where-    (t:rs)    = drop n l-    ls        = reverse (take n l)+focusNth' n s | n >= 0, (ls, t:rs) <- splitAt n (integrate s) = Stack t (reverse ls) rs+              | otherwise = s +-- | Swap current window with nth. Focus stays in the same position+swapNth :: Int -> X ()+swapNth = windows . modify' . swapNth' +swapNth' :: Int -> Stack a -> Stack a+swapNth' n s@(Stack c l r)+  | (n < 0) || (n > length l + length r) || (n == length l) = s+  | n < length l = let (nl, notEmpty -> nc :| nr) = splitAt (length l - n - 1) l in Stack nc (nl ++ c : nr) r+  | otherwise    = let (nl, notEmpty -> nc :| nr) = splitAt (n - length l - 1) r in Stack nc l (nl ++ c : nr)
XMonad/Actions/GridSelect.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.GridSelect+-- Description :  Display items in a 2D grid and select from it with the keyboard or the mouse. -- Copyright   :  Clemens Fruhwirth <clemens@endorphin.org> -- License     :  BSD-style (see LICENSE) --@@ -27,7 +28,7 @@      -- * Configuration     GSConfig(..),-    defaultGSConfig,+    def,     TwoDPosition,     buildDefaultGSConfig, @@ -38,6 +39,7 @@     bringSelected,     goToSelected,     gridselectWorkspace,+    gridselectWorkspace',     spawnSelected,     runSelectedAction, @@ -46,6 +48,7 @@     fromClassName,     stringColorizer,     colorRangeFromClassName,+    stringToRatio,      -- * Navigation Mode assembly     TwoD,@@ -65,22 +68,26 @@     cancel,     transformSearchString, +    -- * Rearrangers+    -- $rearrangers+    Rearranger,+    noRearranger,+    searchStringRearrangerGenerator,+     -- * Screenshots     -- $screenshots      -- * Types     TwoDState,     ) where-import Data.Maybe+import Control.Arrow ((***)) import Data.Bits-import Data.Char import Data.Ord (comparing)-import Control.Applicative import Control.Monad.State-import Control.Arrow import Data.List as L import qualified Data.Map as M import XMonad hiding (liftX)+import XMonad.Prelude import XMonad.Util.Font import XMonad.Prompt (mkUnmanagedWindow) import XMonad.StackSet as W@@ -88,24 +95,25 @@ import XMonad.Util.NamedWindows import XMonad.Actions.WindowBringer (bringWindow) import Text.Printf-import System.Random (mkStdGen, genRange, next)+import System.Random (mkStdGen, randomR) import Data.Word (Word8)+import qualified Data.List.NonEmpty as NE  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.GridSelect -- -- Then add a keybinding, e.g. ----- >    , ((modm, xK_g), goToSelected defaultGSConfig)+-- >    , ((modm, xK_g), goToSelected def) -- -- This module also supports displaying arbitrary information in a grid and letting -- the user select from it. E.g. to spawn an application from a given list, you -- can use the following: ----- >   , ((modm, xK_s), spawnSelected defaultGSConfig ["xterm","gmplayer","gvim"])+-- >   , ((modm, xK_s), spawnSelected def ["xterm","gmplayer","gvim"])  -- $commonGSConfig --@@ -115,9 +123,9 @@ -- > {-# LANGUAGE NoMonomorphismRestriction #-} -- > import XMonad -- > ...--- > gsconfig1 = defaultGSConfig { gs_cellheight = 30, gs_cellwidth = 100 }+-- > gsconfig1 = def { gs_cellheight = 30, gs_cellwidth = 100 } ----- An example where 'buildDefaultGSConfig' is used instead of 'defaultGSConfig'+-- An example where 'buildDefaultGSConfig' is used instead of 'def' -- in order to specify a custom colorizer is @gsconfig2@ (found in -- "XMonad.Actions.GridSelect#Colorizers"): --@@ -135,8 +143,8 @@ -- -- Then you can bind to: ----- >     ,((modm, xK_g), goToSelected  $ gsconfig2 myWinColorizer)--- >     ,((modm, xK_p), spawnSelected $ spawnSelected defaultColorizer)+-- >     ,((modm, xK_g), goToSelected $ gsconfig2 myWinColorizer)+-- >     ,((modm, xK_p), spawnSelected (gsconfig2 defaultColorizer) ["xterm","gvim"])  -- $keybindings --@@ -167,7 +175,7 @@ -- -- You can then define @gsconfig3@ which may be used in exactly the same manner as @gsconfig1@: ----- > gsconfig3 = defaultGSConfig+-- > gsconfig3 = def -- >    { gs_cellheight = 30 -- >    , gs_cellwidth = 100 -- >    , gs_navigate = myNavigation@@ -183,6 +191,11 @@ -- -- <<http://haskell.org/wikiupload/3/35/Xmonad-gridselect-window-aavogt.png>> +-- | The 'Default' instance gives a basic configuration for 'gridselect', with+-- the colorizer chosen based on the type.+--+-- If you want to replace the 'gs_colorizer' field, use 'buildDefaultGSConfig'+-- instead of 'def' to avoid ambiguous type variables. data GSConfig a = GSConfig {       gs_cellheight :: Integer,       gs_cellwidth :: Integer,@@ -190,8 +203,13 @@       gs_colorizer :: a -> Bool -> X (String, String),       gs_font :: String,       gs_navigate :: TwoD a (Maybe a),+      -- ^ Customize key bindings for a GridSelect+      gs_rearranger :: Rearranger a,       gs_originFractX :: Double,-      gs_originFractY :: Double+      gs_originFractY :: Double,+      gs_bordercolor :: String,+      gs_cancelOnEmptyClick :: Bool+      -- ^ When True, click on empty space will cancel GridSelect }  -- | That is 'fromClassName' if you are selecting a 'Window', or@@ -207,17 +225,13 @@ instance HasColorizer String where     defaultColorizer = stringColorizer -instance HasColorizer a where+instance {-# OVERLAPPABLE #-} HasColorizer a where     defaultColorizer _ isFg =         let getColor = if isFg then focusedBorderColor else normalBorderColor-        in asks $ flip (,) "black" . getColor . config+        in asks $ (, "black") . getColor . config --- | A basic configuration for 'gridselect', with the colorizer chosen based on the type.------ If you want to replace the 'gs_colorizer' field, use 'buildDefaultGSConfig'--- instead, to avoid ambiguous type variables.-defaultGSConfig :: HasColorizer a => GSConfig a-defaultGSConfig = buildDefaultGSConfig defaultColorizer+instance HasColorizer a => Default (GSConfig a) where+    def = buildDefaultGSConfig defaultColorizer  type TwoDPosition = (Integer, Integer) @@ -232,19 +246,24 @@                              , td_paneY :: Integer                              , td_drawingWin :: Window                              , td_searchString :: String+                             , td_elementmap :: TwoDElementMap a                              } -td_elementmap :: TwoDState a -> [(TwoDPosition,(String,a))]-td_elementmap s = zipWith (,) positions sortedElements+generateElementmap :: TwoDState a -> X (TwoDElementMap a)+generateElementmap s = do+    rearrangedElements <- rearranger searchString sortedElements+    return $ zip positions rearrangedElements   where     TwoDState {td_availSlots = positions,+               td_gsconfig = gsconfig,                td_searchString = searchString} = s+    GSConfig {gs_rearranger = rearranger} = gsconfig     -- Filter out any elements that don't contain the searchString (case insensitive)     filteredElements = L.filter ((searchString `isInfixOfI`) . fst) (td_elements s)     -- Sorts the elementmap     sortedElements = orderElementmap searchString filteredElements     -- Case Insensitive version of isInfixOf-    needle `isInfixOfI` haystack = (upper needle) `isInfixOf` (upper haystack)+    needle `isInfixOfI` haystack = upper needle `isInfixOf` upper haystack     upper = map toUpper  @@ -270,11 +289,7 @@   newtype TwoD a b = TwoD { unTwoD :: StateT (TwoDState a) X b }-    deriving (Monad,Functor,MonadState (TwoDState a))--instance Applicative (TwoD a) where-    (<*>) = ap-    pure = return+    deriving (Functor, Applicative, Monad, MonadState (TwoDState a))  liftX ::  X a1 -> TwoD a a1 liftX = TwoD . lift@@ -288,30 +303,30 @@   -- tr = top right   --  r = ur ++ 90 degree clock-wise rotation of ur   let tr = [ (x,n-x) | x <- [0..n-1] ]-      r  = tr ++ (map (\(x,y) -> (y,-x)) tr)-  in r ++ (map (negate *** negate) r)+      r  = tr ++ map (\(x,y) -> (y,-x)) tr+  in r ++ map (negate *** negate) r -diamond :: (Enum a, Num a, Eq a) => [(a, a)]-diamond = concatMap diamondLayer [0..]+diamond :: (Enum a, Num a, Eq a) => Stream (a, a)+diamond = fromList $ concatMap diamondLayer [0..]  diamondRestrict :: Integer -> Integer -> Integer -> Integer -> [(Integer, Integer)] diamondRestrict x y originX originY =   L.filter (\(x',y') -> abs x' <= x && abs y' <= y) .   map (\(x', y') -> (x' + fromInteger originX, y' + fromInteger originY)) .-  take 1000 $ diamond+  takeS 1000 $ diamond  findInElementMap :: (Eq a) => a -> [(a, b)] -> Maybe (a, b) findInElementMap pos = find ((== pos) . fst) -drawWinBox :: Window -> XMonadFont -> (String, String) -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X ()-drawWinBox win font (fg,bg) ch cw text x y cp =+drawWinBox :: Window -> XMonadFont -> (String, String) -> String -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X ()+drawWinBox win font (fg,bg) bc ch cw text x y cp =   withDisplay $ \dpy -> do   gc <- liftIO $ createGC dpy win   bordergc <- liftIO $ createGC dpy win   liftIO $ do     Just fgcolor <- initColor dpy fg     Just bgcolor <- initColor dpy bg-    Just bordercolor <- initColor dpy borderColor+    Just bordercolor <- initColor dpy bc     setForeground dpy gc fgcolor     setBackground dpy gc bgcolor     setForeground dpy bordergc bordercolor@@ -319,9 +334,12 @@     drawRectangle dpy win bordergc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)   stext <- shrinkWhile (shrinkIt shrinkText)            (\n -> do size <- liftIO $ textWidthXMF dpy font n-                     return $ size > (fromInteger (cw-(2*cp))))+                     return $ size > fromInteger (cw-(2*cp)))            text-  printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+(div ch 2))) stext+  -- calculate the offset to vertically centre the text based on the ascender and descender+  (asc,desc) <- liftIO $ textExtentsXMF font stext+  let offset = ((ch - fromIntegral (asc + desc)) `div` 2) + fromIntegral asc+  printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+offset)) stext   liftIO $ freeGC dpy gc   liftIO $ freeGC dpy bordergc @@ -331,11 +349,11 @@       s <- get       updateElements (td_elementmap s) -grayoutAllElements :: TwoD a ()-grayoutAllElements =+grayoutElements :: Int -> TwoD a ()+grayoutElements skip =     do       s <- get-      updateElementsWithColorizer grayOnly (td_elementmap s)+      updateElementsWithColorizer grayOnly $ drop skip (td_elementmap s)     where grayOnly _ _ = return ("#808080", "#808080")  updateElements :: TwoDElementMap a -> TwoD a ()@@ -359,6 +377,7 @@             colors <- colorizer element (pos == curpos)             drawWinBox win font                        colors+                       (gs_bordercolor gsconfig)                        cellheight                        cellwidth                        text@@ -368,18 +387,25 @@     mapM_ updateElement elementmap  stdHandle :: Event -> TwoD a (Maybe a) -> TwoD a (Maybe a)-stdHandle (ButtonEvent { ev_event_type = t, ev_x = x, ev_y = y }) contEventloop+stdHandle ButtonEvent{ ev_event_type = t, ev_x = x, ev_y = y } contEventloop     | t == buttonRelease = do-        s @  TwoDState { td_paneX = px, td_paneY = py,-                         td_gsconfig = (GSConfig ch cw _ _ _ _ _ _) } <- get+        s@TwoDState{ td_paneX = px+                   , td_paneY = py+                   , td_gsconfig = GSConfig{ gs_cellheight = ch+                                           , gs_cellwidth = cw+                                           , gs_cancelOnEmptyClick = cancelOnEmptyClick+                                           }+                   } <- get         let gridX = (fi x - (px - cw) `div` 2) `div` cw             gridY = (fi y - (py - ch) `div` 2) `div` ch         case lookup (gridX,gridY) (td_elementmap s) of              Just (_,el) -> return (Just el)-             Nothing -> contEventloop+             Nothing     -> if cancelOnEmptyClick+                            then return Nothing+                            else contEventloop     | otherwise = contEventloop -stdHandle (ExposeEvent { }) contEventloop = updateAllElements >> contEventloop+stdHandle ExposeEvent{} contEventloop = updateAllElements >> contEventloop  stdHandle _ contEventloop = contEventloop @@ -392,10 +418,11 @@                              ev <- getEvent e                              if ev_event_type ev == keyPress                                then do-                                  (ks,s) <- lookupString $ asKeyEvent e+                                  (_, s) <- lookupString $ asKeyEvent e+                                  ks <- keycodeToKeysym d (ev_keycode ev) 0                                   return $ do-                                      mask <- liftX $ cleanMask (ev_state ev)-                                      keyhandler (fromMaybe xK_VoidSymbol ks, s, mask)+                                      mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)+                                      keyhandler (ks, s, mask)                                else                                   return $ stdHandle ev me @@ -411,7 +438,7 @@ select :: TwoD a (Maybe a) select = do   s <- get-  return $ fmap (snd . snd) $ findInElementMap (td_curpos s) (td_elementmap s)+  return $ snd . snd <$> findInElementMap (td_curpos s) (td_elementmap s)  -- | Closes gridselect returning no element. cancel :: TwoD a (Maybe a)@@ -426,7 +453,7 @@       oldPos = td_curpos s   when (isJust newSelectedEl && newPos /= oldPos) $ do     put s { td_curpos = newPos }-    updateElements (catMaybes [(findInElementMap oldPos elmap), newSelectedEl])+    updateElements (catMaybes [findInElementMap oldPos elmap, newSelectedEl])  -- | Moves the cursor by the offsets specified move :: (Integer, Integer) -> TwoD a ()@@ -467,11 +494,17 @@           let oldSearchString = td_searchString s               newSearchString = f oldSearchString           when (newSearchString /= oldSearchString) $ do-            -- FIXME: grayoutAllElements + updateAllElements paint some fields twice causing flickering-            --        we would need a much smarter update strategy to fix that-            when (length newSearchString > length oldSearchString) grayoutAllElements             -- FIXME curpos might end up outside new bounds-            put s { td_searchString = newSearchString }+            let s' = s { td_searchString = newSearchString }+            m <- liftX $ generateElementmap s'+            let s'' = s' { td_elementmap = m }+                oldLen = length $ td_elementmap s+                newLen = length $ td_elementmap s''+            -- All the elements in the previous element map should be+            -- grayed out, except for those which will be covered by+            -- elements in the new element map.+            when (newLen < oldLen) $ grayoutElements newLen+            put s''             updateAllElements  -- | By default gridselect used the defaultNavigation action, which@@ -520,7 +553,7 @@           ,((0,xK_Up)         , move (0,-1) >> navNSearch)           ,((0,xK_Tab)        , moveNext >> navNSearch)           ,((shiftMask,xK_Tab), movePrev >> navNSearch)-          ,((0,xK_BackSpace), transformSearchString (\s -> if (s == "") then "" else init s) >> navNSearch)+          ,((0,xK_BackSpace), transformSearchString (\s -> if s == "" then "" else init s) >> navNSearch)           ]         -- The navigation handler ignores unknown key symbols, therefore we const         navNSearchDefaultHandler (_,s,_) = do@@ -534,7 +567,7 @@   let searchKeyMap = M.fromList [            ((0,xK_Escape)   , transformSearchString (const "") >> returnNavigation)           ,((0,xK_Return)   , returnNavigation)-          ,((0,xK_BackSpace), transformSearchString (\s -> if (s == "") then "" else init s) >> me)+          ,((0,xK_BackSpace), transformSearchString (\s -> if s == "" then "" else init s) >> me)           ]       searchDefaultHandler (_,s,_) = do           transformSearchString (++ s)@@ -546,8 +579,8 @@ -- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a) hsv2rgb (h,s,v) =-    let hi = (div h 60) `mod` 6 :: Integer-        f = (((fromInteger h)/60) - (fromInteger hi)) :: Fractional a => a+    let hi = div h 60 `mod` 6 :: Integer+        f = ((fromInteger h/60) - fromInteger hi) :: Fractional a => a         q = v * (1-f)         p = v * (1-s)         t = v * (1-(1-f)*s)@@ -564,19 +597,19 @@ stringColorizer :: String -> Bool -> X (String, String) stringColorizer s active =     let seed x = toInteger (sum $ map ((*x).fromEnum) s) :: Integer-        (r,g,b) = hsv2rgb ((seed 83) `mod` 360,-                           (fromInteger ((seed 191) `mod` 1000))/2500+0.4,-                           (fromInteger ((seed 121) `mod` 1000))/2500+0.4)+        (r,g,b) = hsv2rgb (seed 83 `mod` 360,+                           fromInteger (seed 191 `mod` 1000)/2500+0.4,+                           fromInteger (seed 121 `mod` 1000)/2500+0.4)     in if active          then return ("#faff69", "black")-         else return ("#" ++ concat (map (twodigitHex.(round :: Double -> Word8).(*256)) [r, g, b] ), "white")+         else return ("#" ++ concatMap (twodigitHex.(round :: Double -> Word8).(*256)) [r, g, b], "white")  -- | Colorize a window depending on it's className. fromClassName :: Window -> Bool -> X (String, String) fromClassName w active = runQuery className w >>= flip defaultColorizer active  twodigitHex :: Word8 -> String-twodigitHex a = printf "%02x" a+twodigitHex = printf "%02x"  -- | A colorizer that picks a color inside a range, -- and depending on the window's class.@@ -605,15 +638,12 @@  -- | Generates a Double from a string, trying to -- achieve a random distribution.--- We create a random seed from the sum of all characters+-- We create a random seed from the hash of all characters -- in the string, and use it to generate a ratio between 0 and 1 stringToRatio :: String -> Double stringToRatio "" = 0-stringToRatio s = let gen = mkStdGen $ sum $ map fromEnum s-                      range = (\(a, b) -> b - a) $ genRange gen-                      randomInt = foldr1 combine $ replicate 20 next-                      combine f1 f2 g = let (_, g') = f1 g in f2 g'-                  in fi (fst $ randomInt gen) / fi range+stringToRatio s = let gen = mkStdGen $ foldl' (\t c -> t * 31 + fromEnum c) 0 s+                  in fst $ randomR (0, 1) gen  -- | Brings up a 2D grid of elements in the center of the screen, and one can -- select an element with cursors keys. The selected element is returned.@@ -622,38 +652,42 @@ gridselect gsconfig elements =  withDisplay $ \dpy -> do     rootw <- asks theRoot-    s <- gets $ screenRect . W.screenDetail . W.current . windowset+    scr <- gets $ screenRect . W.screenDetail . W.current . windowset     win <- liftIO $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw-                    (rect_x s) (rect_y s) (rect_width s) (rect_height s)+                    (rect_x scr) (rect_y scr) (rect_width scr) (rect_height scr)     liftIO $ mapWindow dpy win     liftIO $ selectInput dpy win (exposureMask .|. keyPressMask .|. buttonReleaseMask)     status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime-    io $ grabButton dpy button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none+    void $ io $ grabPointer dpy win True buttonReleaseMask grabModeAsync grabModeAsync none none currentTime     font <- initXMF (gs_font gsconfig)-    let screenWidth = toInteger $ rect_width s;-        screenHeight = toInteger $ rect_height s;-    selectedElement <- if (status == grabSuccess) then do+    let screenWidth = toInteger $ rect_width scr+        screenHeight = toInteger $ rect_height scr+    selectedElement <- if status == grabSuccess then do                             let restriction ss cs = (fromInteger ss/fromInteger (cs gsconfig)-1)/2 :: Double                                 restrictX = floor $ restriction screenWidth gs_cellwidth                                 restrictY = floor $ restriction screenHeight gs_cellheight-                                originPosX = floor $ ((gs_originFractX gsconfig) - (1/2)) * 2 * fromIntegral restrictX-                                originPosY = floor $ ((gs_originFractY gsconfig) - (1/2)) * 2 * fromIntegral restrictY+                                originPosX = floor $ (gs_originFractX gsconfig - (1/2)) * 2 * fromIntegral restrictX+                                originPosY = floor $ (gs_originFractY gsconfig - (1/2)) * 2 * fromIntegral restrictY                                 coords = diamondRestrict restrictX restrictY originPosX originPosY--                            evalTwoD (updateAllElements >> (gs_navigate gsconfig)) TwoDState { td_curpos = (head coords),-                                                                                  td_availSlots = coords,-                                                                                  td_elements = elements,-                                                                                  td_gsconfig = gsconfig,-                                                                                  td_font = font,-                                                                                  td_paneX = screenWidth,-                                                                                  td_paneY = screenHeight,-                                                                                  td_drawingWin = win,-                                                                                  td_searchString = "" }+                                s = TwoDState { td_curpos = NE.head (notEmpty coords),+                                                td_availSlots = coords,+                                                td_elements = elements,+                                                td_gsconfig = gsconfig,+                                                td_font = font,+                                                td_paneX = screenWidth,+                                                td_paneY = screenHeight,+                                                td_drawingWin = win,+                                                td_searchString = "",+                                                td_elementmap = [] }+                            m <- generateElementmap s+                            evalTwoD (updateAllElements >> gs_navigate gsconfig)+                                     (s { td_elementmap = m })                       else                           return Nothing     liftIO $ do       unmapWindow dpy win       destroyWindow dpy win+      ungrabPointer dpy currentTime       sync dpy False     releaseXMF font     return selectedElement@@ -668,27 +702,21 @@ withSelectedWindow :: (Window -> X ()) -> GSConfig Window -> X () withSelectedWindow callback conf = do     mbWindow <- gridselectWindow conf-    case mbWindow of-        Just w -> callback w-        Nothing -> return ()+    for_ mbWindow callback  windowMap :: X [(String,Window)] windowMap = do     ws <- gets windowset-    wins <- mapM keyValuePair (W.allWindows ws)-    return wins- where keyValuePair w = flip (,) w `fmap` decorateName' w+    mapM keyValuePair (W.allWindows ws)+ where keyValuePair w = (, w) <$> decorateName' w  decorateName' :: Window -> X String decorateName' w = do-  fmap show $ getName w+  show <$> getName w  -- | Builds a default gs config from a colorizer function. buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a-buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation (1/2) (1/2)--borderColor :: String-borderColor = "white"+buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultNavigation noRearranger (1/2) (1/2) "white" True  -- | Brings selected window to the current workspace. bringSelected :: GSConfig Window -> X ()@@ -721,6 +749,44 @@ -- > gridselectWorkspace (\ws -> W.greedyView ws . W.shift ws) gridselectWorkspace :: GSConfig WorkspaceId ->                           (WorkspaceId -> WindowSet -> WindowSet) -> X ()-gridselectWorkspace conf viewFunc = withWindowSet $ \ws -> do+gridselectWorkspace conf viewFunc = gridselectWorkspace' conf (windows . viewFunc)++-- | Select a workspace and run an arbitrary action on it.+gridselectWorkspace' :: GSConfig WorkspaceId -> (WorkspaceId -> X ()) -> X ()+gridselectWorkspace' conf func = withWindowSet $ \ws -> do     let wss = map W.tag $ W.hidden ws ++ map W.workspace (W.current ws : W.visible ws)-    gridselect conf (zip wss wss) >>= flip whenJust (windows . viewFunc)+    gridselect conf (zip wss wss) >>= flip whenJust func++-- $rearrangers+--+-- Rearrangers allow for arbitrary post-filter rearranging of the grid+-- elements.+--+-- For example, to be able to switch to a new dynamic workspace by typing+-- in its name, you can use the following keybinding action:+--+-- > import XMonad.Actions.DynamicWorkspaces (addWorkspace)+-- >+-- > gridselectWorkspace' def+-- >                          { gs_navigate   = navNSearch+-- >                          , gs_rearranger = searchStringRearrangerGenerator id+-- >                          }+-- >                      addWorkspace++-- | A function taking the search string and a list of elements, and+-- returning a potentially rearranged list of elements.+type Rearranger a = String -> [(String, a)] -> X [(String, a)]++-- | A rearranger that leaves the elements unmodified.+noRearranger :: Rearranger a+noRearranger _ = return++-- | A generator for rearrangers that append a single element based on the+-- search string, if doing so would not be redundant (empty string or value+-- already present).+searchStringRearrangerGenerator :: (String -> a) -> Rearranger a+searchStringRearrangerGenerator f =+    let r "" xs                       = return xs+        r s  xs | s `elem` map fst xs = return xs+                | otherwise           = return $ xs ++ [(s, f s)]+    in r
XMonad/Actions/GroupNavigation.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}-+{-# language DeriveGeneric, DeriveAnyClass #-} ---------------------------------------------------------------------- -- | -- Module      : XMonad.Actions.GroupNavigation+-- Description : Cycle through groups of windows across workspaces. -- Copyright   : (c) nzeh@cs.dal.ca -- License     : BSD3-style (see LICENSE) --@@ -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,24 +27,33 @@                                       , nextMatchOrDo                                       , nextMatchWithThis                                       , historyHook++                                        -- * Utilities+                                        -- $utilities+                                      , isOnAnyVisibleWS                                       ) where -import Control.Monad.Reader-import Data.Foldable as Fold-import Data.Map as Map-import Data.Sequence as Seq-import Data.Set as Set+import Control.Monad.Reader (ask, asks)+import Control.Monad.State (gets)+import Control.DeepSeq+import Data.Map ((!))+import qualified Data.Map as Map+import Data.Sequence (Seq, ViewL (EmptyL, (:<)), viewl, (<|), (><), (|>))+import qualified Data.Sequence as Seq+import qualified Data.Set as Set import Graphics.X11.Types-import Prelude hiding (concatMap, drop, elem, filter, null, reverse)+import GHC.Generics+import Prelude hiding (drop, elem, filter, null, reverse) import XMonad.Core import XMonad.ManageHook import XMonad.Operations (windows, withFocused)+import XMonad.Prelude (elem, foldl', (>=>)) import qualified XMonad.StackSet as SS import qualified XMonad.Util.ExtensibleState as XS  {- $usage -Import the module into your @~\/.xmonad\/xmonad.hs@:+Import the module into your @xmonad.hs@:  > import XMonad.Actions.GroupNavigation @@ -73,7 +82,7 @@ matching a certain Boolean query.  To do this, you need to add 'historyHook' to your logHook: -> main = xmonad $ defaultConfig { logHook = historyHook }+> main = xmonad $ def { logHook = historyHook }  Then the following keybindings, for example, allow you to return to the most recent xterm or emacs window or to simply to the most recent@@ -120,14 +129,14 @@                              >=> maybe act (windows . SS.focusWindow)  -- Returns the list of windows ordered by workspace as specified in--- ~/.xmonad/xmonad.hs+-- @xmonad.hs@. orderedWindowList :: Direction -> X (Seq Window)-orderedWindowList History = liftM (\(HistoryDB w ws) -> maybe ws (ws |>) w) XS.get+orderedWindowList History = fmap (\(HistoryDB w ws) -> maybe ws (ws |>) w) XS.get orderedWindowList dir     = withWindowSet $ \ss -> do   wsids <- asks (Seq.fromList . workspaces . config)   let wspcs = orderedWorkspaceList ss wsids       wins  = dirfun dir-              $ Fold.foldl' (><) Seq.empty+              $ foldl' (><) Seq.empty               $ fmap (Seq.fromList . SS.integrate' . SS.stack) wspcs       cur   = SS.peek ss   return $ maybe wins (rotfun wins) cur@@ -136,13 +145,13 @@     dirfun _        = id     rotfun wins x   = rotate $ rotateTo (== x) wins --- Returns the ordered workspace list as specified in ~/.xmonad/xmonad.hs+-- Returns the ordered workspace list as specified in @xmonad.hs@. orderedWorkspaceList :: WindowSet -> Seq String -> Seq WindowSpace 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+      wspcsMap   = foldl' (\m ws -> Map.insert (SS.tag ws) ws m) Map.empty wspcs+      wspcs'     = fmap (wspcsMap !) wsids       isCurWS ws = SS.tag ws == SS.tag (SS.workspace $ SS.current ss)  --- History navigation, requires a layout modifier -------------------@@ -150,7 +159,7 @@ -- The state extension that holds the history information data HistoryDB = HistoryDB (Maybe Window) -- currently focused window                            (Seq Window)   -- previously focused windows-               deriving (Read, Show, Typeable)+               deriving (Read, Show, Generic, NFData)  instance ExtensionClass HistoryDB where @@ -160,33 +169,18 @@ -- | Action that needs to be executed as a logHook to maintain the -- focus history of all windows as the WindowSet changes. historyHook :: X ()-historyHook = XS.get >>= updateHistory >>= XS.put+historyHook = (XS.put $!) . force =<< updateHistory =<< XS.get  -- Updates the history in response to a WindowSet change updateHistory :: HistoryDB -> X HistoryDB-updateHistory (HistoryDB oldcur oldhist) = withWindowSet $ \ss -> do+updateHistory (HistoryDB oldcur oldhist) = withWindowSet $ \ss ->   let newcur   = SS.peek ss       wins     = Set.fromList $ SS.allWindows ss-      newhist  = flt (flip Set.member wins) (ins oldcur oldhist)-  return $ HistoryDB newcur (del newcur newhist)+      newhist  = Seq.filter (`Set.member` wins) (ins oldcur oldhist)+  in pure $ HistoryDB newcur (del newcur newhist)   where     ins x xs = maybe xs (<| xs) x-    del x xs = maybe xs (\x' -> flt (/= x') xs) x----- Two replacements for Seq.filter and Seq.breakl available only in---- containers-0.3.0.0, which only ships with ghc 6.12.  Once we---- decide to no longer support ghc < 6.12, these should be replaced---- with Seq.filter and Seq.breakl.--flt :: (a -> Bool) -> Seq a -> Seq a-flt p = Fold.foldl (\xs x -> if p x then xs |> x else xs) Seq.empty--brkl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-brkl p xs = flip Seq.splitAt xs-            $ snd-            $ Fold.foldr (\x (i, j) -> if p x then (i-1, i-1) else (i-1, j)) (l, l) xs-  where-    l = Seq.length xs+    del x xs = maybe xs (\x' -> Seq.filter (/= x') xs) x  --- Some sequence helpers -------------------------------------------- @@ -200,7 +194,7 @@ -- Rotates the sequence until an element matching the given condition -- is at the beginning of the sequence. rotateTo :: (a -> Bool) -> Seq a -> Seq a-rotateTo cond xs = let (lxs, rxs) = brkl cond xs in rxs >< lxs+rotateTo cond xs = let (lxs, rxs) = Seq.breakl cond xs in rxs >< lxs  --- A monadic find --------------------------------------------------- @@ -216,3 +210,21 @@       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 = concatMap (maybe [] SS.integrate . SS.stack . SS.workspace) (SS.current ws:SS.visible ws)+      visibleWs = w `elem` allVisible+      unfocused = Just w /= SS.peek ws+  return $ visibleWs && unfocused
XMonad/Actions/KeyRemap.hs view
@@ -1,7 +1,7 @@- {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.KeyRemap+-- Description :  Remap Keybinding on the fly. -- Copyright   :  (c) Christian Dietrich -- License     :  BSD-style (as xmonad) --@@ -27,14 +27,13 @@   ) where  import XMonad+import XMonad.Prelude import XMonad.Util.Paste-import Data.List  import qualified XMonad.Util.ExtensibleState as XS-import Control.Monad  -data KeymapTable = KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))] deriving (Typeable, Show)+newtype KeymapTable = KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))] deriving (Show)  instance ExtensionClass KeymapTable where    initialValue = KeymapTable []@@ -125,8 +124,8 @@ buildKeyRemapBindings :: [KeymapTable] -> [((KeyMask, KeySym), X ())] buildKeyRemapBindings keyremaps =   [((mask, sym), doKeyRemap mask sym) | (mask, sym) <- bindings]-  where mappings = concat (map (\(KeymapTable table) -> table) keyremaps)-        bindings = nub (map (\binding -> fst binding) mappings)+  where mappings = concatMap (\(KeymapTable table) -> table) keyremaps+        bindings = nub (map fst mappings)   -- Here come the Keymappings@@ -138,7 +137,7 @@ dvorakProgrammerKeyRemap :: KeymapTable dvorakProgrammerKeyRemap =   KeymapTable [((charToMask maskFrom, from), (charToMask maskTo, to)) |-               (maskFrom, from, maskTo, to) <- (zip4 layoutUsShift layoutUsKey layoutDvorakShift layoutDvorakKey)]+               (maskFrom, from, maskTo, to) <- zip4 layoutUsShift layoutUsKey layoutDvorakShift layoutDvorakKey]   where      layoutUs    = map (fromIntegral . fromEnum) "`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./~!@#$%^&*()_+QWERTYUIOP{}|ASDFGHJKL:\"ZXCVBNM<>?"  :: [KeySym]@@ -149,8 +148,6 @@      layoutDvorakShift = map getShift layoutDvorak     layoutDvorakKey   = map getKey layoutDvorak-    getKey  char = let Just index = elemIndex char layoutUs-                    in layoutUsKey !! index-    getShift char = let Just index = elemIndex char layoutUs-                    in layoutUsShift !! index+    getKey   char = fromJust $ (layoutUsKey   !?) =<< elemIndex char layoutUs+    getShift char = fromJust $ (layoutUsShift !?) =<< elemIndex char layoutUs     charToMask char = if [char] == "0" then 0 else shiftMask
XMonad/Actions/Launcher.hs view
@@ -1,5 +1,6 @@ {- | Module      :  XMonad.Actions.Launcher+Description :  A set of prompts for XMonad. Copyright   :  (C) 2012 Carlos López-Camey License     :  None; public domain @@ -18,10 +19,9 @@   , launcherPrompt ) where -import           Data.List       (find, findIndex, isPrefixOf, tails) import qualified Data.Map        as M-import           Data.Maybe      (isJust) import           XMonad          hiding (config)+import           XMonad.Prelude import           XMonad.Prompt import           XMonad.Util.Run @@ -34,10 +34,10 @@      To test it, modify your local .xmonad: -    > import XMonad.Prompt(defaultXPConfig)+    > import XMonad.Prompt(def)     > import XMonad.Actions.Launcher -    > ((modm .|. controlMask, xK_l), launcherPrompt defaultXPConfig $ defaultLauncherModes launcherConfig)+    > ((modm .|. controlMask, xK_l), launcherPrompt def $ defaultLauncherModes launcherConfig)      A LauncherConfig contains settings for the default modes, modify them accordingly. @@ -45,7 +45,7 @@  Restart xmonad. Press Ctrl + Your_Modkey + L and the first prompt should pop up. - If you used 'defaultXPConfig', you can change mode with 'xK_grave'. If you are using your own 'XPConfig', define the value for 'changeModeKey'.+ If you used the default 'XPConfig', you can change mode with 'xK_grave'. If you are using your own 'XPConfig', define the value for 'changeModeKey'.  -}  data HoogleMode = HMode FilePath String --path to hoogle and browser@@ -62,15 +62,15 @@ instance XPrompt CalculatorMode where   showXPrompt CalcMode = "calc %s> "   commandToComplete CalcMode = id --send the whole string to `calc`-  completionFunction CalcMode = \s -> if (length s == 0) then return [] else do-    fmap lines $ runProcessWithInput "calc" [s] ""+  completionFunction CalcMode s = if null s then return [] else+    lines <$> runProcessWithInput "calc" [s] ""   modeAction CalcMode _ _ = return () -- do nothing; this might copy the result to the clipboard  -- | Uses the program `hoogle` to search for functions instance XPrompt HoogleMode where   showXPrompt _ = "hoogle %s> "   commandToComplete _ = id-  completionFunction (HMode pathToHoogleBin' _) = \s -> completionFunctionWith pathToHoogleBin' ["--count","8",s]+  completionFunction (HMode pathToHoogleBin' _) s = completionFunctionWith pathToHoogleBin' ["--count","8",s]   -- This action calls hoogle again to find the URL corresponding to the autocompleted item   modeAction (HMode pathToHoogleBin'' browser') query result = do     completionsWithLink <- liftIO $ completionFunctionWith pathToHoogleBin'' ["--count","5","--link",query]@@ -88,7 +88,7 @@  -- | Creates an autocompletion function for a programm given the program's name and a list of args to send to the command. completionFunctionWith :: String -> [String] -> IO [String]-completionFunctionWith cmd args = do fmap lines $ runProcessWithInput cmd args ""+completionFunctionWith cmd args = lines <$> runProcessWithInput cmd args ""  -- | Creates a prompt with the given modes launcherPrompt :: XPConfig -> [XPMode] -> X()
+ XMonad/Actions/LinkWorkspaces.hs view
@@ -0,0 +1,169 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.LinkWorkspaces+-- Description : Bindings to add and delete links between workspaces.+-- Copyright   :  (c) Jan-David Quesel <quesel@gmail.org>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  none+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides bindings to add and delete links between workspaces. It is aimed+-- at providing useful links between workspaces in a multihead setup. Linked+-- workspaces are view at the same time.+--+-----------------------------------------------------------------------------++module XMonad.Actions.LinkWorkspaces (+                                         -- * Usage+                                         -- $usage+                                        switchWS,+                                        removeAllMatchings,+                                        unMatch,+                                        toggleLinkWorkspaces,+                                        defaultMessageConf,+                                        MessageConfig(..)+                                       ) where++import XMonad+import XMonad.Prelude (for_)+import qualified XMonad.StackSet as W+import XMonad.Layout.IndependentScreens(countScreens)+import qualified XMonad.Util.ExtensibleState as XS (get, put)+import XMonad.Actions.OnScreen(Focus(FocusCurrent), onScreen')+import qualified Data.Map as M+    ( insert, delete, Map, lookup, empty, filter )++-- $usage+-- You can use this module with the following in your @xmonad.hs@ file:+--+-- > import XMonad.Actions.LinkWorkspaces+--+-- and add a function to print messages like+--+-- > message_command (S screen) = " dzen2 -p 1 -w 300 -xs " ++ show (screen + 1)+-- > message_color_func c1 c2 msg = dzenColor c1 c2 msg+-- > message screen c1 c2 msg = spawn $ "echo '" ++ (message_color_func c1 c2 msg) ++ "' | " ++ message_command screen+--+-- alternatively you can use the noMessages function as the argument+--+-- Then add keybindings like the following:+--+-- > ,((modm, xK_p), toggleLinkWorkspaces message)+-- > ,((modm .|. shiftMask, xK_p), removeAllMatchings message)+--+-- >   [ ((modm .|. m, k), a i)+-- >       | (a, m) <- [(switchWS (\y -> windows $ view y) message, 0),(switchWS (\x -> windows $ shift x . view x) message, shiftMask)]+-- >       , (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9]]+--+-- For detailed instructions on editing your key bindings, see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.++data MessageConfig = MessageConfig {  messageFunction :: ScreenId -> [Char] -> [Char] -> [Char] -> X()+                    , foreground :: [Char]+                    , alertedForeground :: [Char]+                    , background :: [Char]+                   }++defaultMessageConf :: MessageConfig+defaultMessageConf = MessageConfig { messageFunction = noMessageFn+                     , background = "#000000"+                     , alertedForeground = "#ff7701"+                     , foreground = "#00ff00" }++noMessageFn :: ScreenId -> [Char] -> [Char] -> [Char] -> X()+noMessageFn _ _ _ _ = return () :: X ()++-- | Stuff for linking workspaces+newtype WorkspaceMap = WorkspaceMap (M.Map WorkspaceId WorkspaceId) deriving (Read, Show)+instance ExtensionClass WorkspaceMap+    where initialValue = WorkspaceMap M.empty+          extensionType = PersistentExtension++switchWS :: (WorkspaceId -> X ()) -> MessageConfig -> WorkspaceId -> X ()+switchWS f m ws = switchWS' f m ws Nothing++-- | Switch to the given workspace in a non greedy way, stop if we reached the first screen+-- | we already did switching on+switchWS' :: (WorkspaceId -> X ()) -> MessageConfig  -> WorkspaceId -> Maybe ScreenId -> X ()+switchWS' switchFn message workspace stopAtScreen = do+  ws <- gets windowset+  nScreens <- countScreens+  let now = W.screen (W.current ws)+  let next = (now + 1) `mod` nScreens+  switchFn workspace+  case stopAtScreen of+    Nothing -> sTM now next (Just now)+    Just sId -> if sId == next then return () else sTM now next (Just sId)+  where sTM = switchToMatching (switchWS' switchFn message) message workspace++-- | Switch to the workspace that matches the current one, executing switches for that workspace as well.+-- | The function switchWorkspaceNonGreedy' will take of stopping if we reached the first workspace again.+switchToMatching :: (WorkspaceId -> Maybe ScreenId -> X ()) -> MessageConfig -> WorkspaceId -> ScreenId+    -> ScreenId -> Maybe ScreenId -> X ()+switchToMatching f message t now next stopAtScreen = do+    WorkspaceMap matchings <- XS.get :: X WorkspaceMap+    case M.lookup t matchings of+        Nothing -> return () :: X()+        Just newWorkspace -> do+            onScreen' (f newWorkspace stopAtScreen) FocusCurrent next+            messageFunction message now (foreground message) (background message) ("Switching to: " ++ (t ++ " and " ++ newWorkspace))++-- | Insert a mapping between t1 and t2 or remove it was already present+toggleMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> X ()+toggleMatching message t1 t2 = do+    WorkspaceMap matchings <- XS.get :: X WorkspaceMap+    case M.lookup t1 matchings of+        Nothing -> setMatching message t1 t2 matchings+        Just t -> if t == t2 then removeMatching' message t1 t2 matchings else setMatching message t1 t2 matchings+    return ()++-- | Insert a mapping between t1 and t2 and display a message+setMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> M.Map WorkspaceId WorkspaceId -> X ()+setMatching message t1 t2 matchings = do+   ws <- gets windowset+   let now = W.screen (W.current ws)+   XS.put $ WorkspaceMap $ M.insert t1 t2 matchings+   messageFunction message now (foreground message) (background message) ("Linked: " ++ (t1 ++ " " ++ t2))++-- currently this function is called manually this means that if workspaces+-- were deleted, some links stay in the RAM even though they are not used+-- anymore... because of the small amount of memory used for those there is no+-- special cleanup so far+removeMatching' :: MessageConfig -> WorkspaceId -> WorkspaceId -> M.Map WorkspaceId WorkspaceId -> X ()+removeMatching' message t1 t2 matchings = do+   ws <- gets windowset+   let now = W.screen (W.current ws)+   XS.put $ WorkspaceMap $ M.delete t1 matchings+   messageFunction message now (alertedForeground message) (background message) ("Unlinked: " ++ t1 ++ " " ++ t2)++-- | Remove all maps between workspaces+removeAllMatchings :: MessageConfig -> X ()+removeAllMatchings message = do+   ws <- gets windowset+   let now = W.screen (W.current ws)+   XS.put $ WorkspaceMap M.empty+   messageFunction message now (alertedForeground message) (background message) "All links removed!"++-- | remove all matching regarding a given workspace+unMatch :: WorkspaceId -> X ()+unMatch workspace = do+    WorkspaceMap matchings <- XS.get :: X WorkspaceMap+    XS.put $ WorkspaceMap $ M.delete workspace (M.filter (/= workspace) matchings)++-- | Toggle the currently displayed workspaces as matching. Starting from the one with focus+-- | a linked list of workspaces is created that will later be iterated by switchToMatching.+toggleLinkWorkspaces :: MessageConfig -> X ()+toggleLinkWorkspaces message = withWindowSet $ \ws -> toggleLinkWorkspaces' (W.screen (W.current ws)) message++toggleLinkWorkspaces' :: ScreenId -> MessageConfig -> X ()+toggleLinkWorkspaces' first message = do+    ws <- gets windowset+    nScreens <- countScreens+    let now = W.screen (W.current ws)+    let next = (now + 1) `mod` nScreens+    if next == first then return () else do -- this is also the case if there is only one screen+        for_ (W.lookupWorkspace next ws)+             (toggleMatching message (W.currentTag ws))+        onScreen' (toggleLinkWorkspaces' first message) FocusCurrent next
XMonad/Actions/MessageFeedback.hs view
@@ -1,7 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.MessageFeedback--- Copyright    : (c) Quentin Moser <moserq@gmail.com>+-- Description :  An alternative @sendMessage@.+-- Copyright    : (c) --   Quentin Moser <moserq@gmail.com>+--                    2018 Yclept Nemo -- License      : BSD3 -- -- Maintainer   : orphaned@@ -13,87 +15,212 @@ -- 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+    ) where++import XMonad               ( Window )+import XMonad.Core          ( X(), Message, SomeMessage(..), LayoutClass(..), windowset, catchX, WorkspaceId, Layout, whenJust )+import XMonad.Operations    ( updateLayout, windowBracket, modifyWindowSet )+import XMonad.Prelude+import XMonad.StackSet      ( Workspace, current, workspace, layout, tag )++import Control.Monad.State  ( gets )+ -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @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  <- gets ((workspace . current) . 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'.-sm :: Message a => a -> SomeMessage-sm = 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 -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'+-- | 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 -sendSM_ :: SomeMessage -> X ()-sendSM_ m = sendSM m >> return ()+-- | 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
+ XMonad/Actions/Minimize.hs view
@@ -0,0 +1,147 @@+----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.Minimize+-- Description :  Actions for minimizing and maximizing windows.+-- Copyright   :  (c) Bogdan Sinitsyn (2016)+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Bogdan Sinitsyn <bogdan.sinitsyn@gmail.com>+-- Stability   :  unstable+-- Portability :  not portable+--+-- Adds actions for minimizing and maximizing windows+--+-- This module should be used with "XMonad.Layout.Minimize". Add 'minimize' to your+-- layout modifiers as described in "XMonad.Layout.Minimize" and use actions from+-- this module+--+-- Possible keybindings:+--+-- >        , ((modm,               xK_m     ), withFocused minimizeWindow)+-- >        , ((modm .|. shiftMask, xK_m     ), withLastMinimized maximizeWindowAndFocus)+--+-----------------------------------------------------------------------------++module XMonad.Actions.Minimize+  ( -- * Usage+    -- $usage+    minimizeWindow+  , maximizeWindow+  , maximizeWindowAndFocus+  , withLastMinimized+  , withLastMinimized'+  , withFirstMinimized+  , withFirstMinimized'+  , withMinimized+  ) where++import XMonad+import XMonad.Prelude (fromMaybe, join, listToMaybe)+import qualified XMonad.StackSet as W++import qualified XMonad.Layout.BoringWindows as BW+import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Util.Minimize+import XMonad.Util.WindowProperties (getProp32)++import Foreign.C.Types (CLong)+import qualified Data.List as L+import qualified Data.Map as M++-- $usage+-- Import this module with "XMonad.Layout.Minimize" and "XMonad.Layout.BoringWindows":+--+-- > import XMonad.Actions.Minimize+-- > import XMonad.Layout.Minimize+-- > import qualified XMonad.Layout.BoringWindows as BW+--+-- Then apply 'minimize' and 'boringWindows' to your layout hook and use some+-- actions from this module:+--+-- > main = xmonad def { layoutHook = minimize . BW.boringWindows $ whatever }+--+-- Example keybindings:+--+-- >        , ((modm,               xK_m     ), withFocused minimizeWindow      )+-- >        , ((modm .|. shiftMask, xK_m     ), withLastMinimized maximizeWindow)++setMinimizedState :: Window -> Int -> (CLong -> [CLong] -> [CLong]) -> X ()+setMinimizedState win st f = do+    setWMState win st+    withDisplay $ \dpy -> do+        wm_state <- getAtom "_NET_WM_STATE"+        hidden <- fromIntegral <$> getAtom "_NET_WM_STATE_HIDDEN"+        wstate <- fromMaybe [] <$> getProp32 wm_state win+        io $ changeProperty32 dpy win wm_state aTOM propModeReplace (f hidden wstate)++setMinimized :: Window -> X ()+setMinimized win = setMinimizedState win iconicState (:)++setNotMinimized :: Window -> X ()+setNotMinimized win = setMinimizedState win normalState L.delete++-- It does not just set minimizedStack to newWindows because it should save+-- order in which elements were added (newer first)+modified :: (RectMap -> RectMap) -> X Bool+modified f = XS.modified $+    \Minimized { rectMap = oldRectMap, minimizedStack = oldStack } ->+      let newRectMap = f oldRectMap+          newWindows = M.keys newRectMap+       in Minimized { rectMap = newRectMap+                    , minimizedStack = (newWindows L.\\ oldStack)+                                       +++                                       (oldStack `L.intersect` newWindows)+                    }+++-- | Minimize a window+minimizeWindow :: Window -> X ()+minimizeWindow w = withWindowSet $ \ws ->+  whenX (modified $ M.insert w (M.lookup w $ W.floating ws)) $ do+    setMinimized w+    windows $ W.sink w+    BW.focusDown+++-- | Maximize window and apply a function to maximized window and 'WindowSet'+maximizeWindowAndChangeWSet :: (Window -> WindowSet -> WindowSet) -> Window -> X ()+maximizeWindowAndChangeWSet f w = do+  mrect <- XS.gets (join . M.lookup w . rectMap)+  whenX (modified $ M.delete w) $ do+    setNotMinimized w+    broadcastMessage BW.UpdateBoring+    windows $ f w . maybe id (W.float w) mrect++-- | Just maximize a window without focusing+maximizeWindow :: Window -> X ()+maximizeWindow = maximizeWindowAndChangeWSet $ const id++-- | Maximize a window and then focus it+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' (`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 ()+withLastMinimized action = withLastMinimized' (`whenJust` action)++-- | Like withLastMinimized but the provided action is always invoked with a+--   'Maybe Window', that will be nothing if there is no last minimized window.+withLastMinimized' :: (Maybe Window -> X ()) -> X ()+withLastMinimized' action = withMinimized (action . listToMaybe)++withMinimized :: ([Window] -> X a) -> X a+withMinimized action = do+  minimized <- XS.gets minimizedStack+  currentStack <- withWindowSet $ return . W.index+  action $ minimized `L.intersect` currentStack
+ XMonad/Actions/MostRecentlyUsed.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.MostRecentlyUsed+-- Description :  Tab through windows by recency of use.+-- Copyright   :  (c) 2022 L. S. Leary+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  @LSLeary (on github)+-- Stability   :  unstable+-- Portability :  unportable+--+-- Based on the Alt+Tab behaviour common outside of xmonad.+--+-----------------------------------------------------------------------------++-- --< Imports & Exports >-- {{{++module XMonad.Actions.MostRecentlyUsed (++  -- * Usage+  -- $usage++  -- * Interface+  configureMRU,+  mostRecentlyUsed,+  withMostRecentlyUsed,+  Location(..),++  ) where++-- base+import Data.List.NonEmpty (nonEmpty)+import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)+import Control.Monad.IO.Class (MonadIO)++-- mtl+import Control.Monad.Trans (lift)+import Control.Monad.State (get, put, gets)++-- containers+import qualified Data.Map.Strict as M++-- xmonad+import XMonad+  ( Window, KeySym, keyPress, io+  , Event (DestroyWindowEvent, UnmapEvent, ev_send_event, ev_window)+  )+import XMonad.Core+  ( X, XConfig(..), windowset, WorkspaceId, ScreenId+  , ExtensionClass(..), StateExtension(..)+  , waitingUnmap+  )+import XMonad.Operations (screenWorkspace)+import qualified XMonad.StackSet as W++-- xmonad-contrib+import qualified XMonad.Util.ExtensibleConf  as XC+import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Util.PureX+  (handlingRefresh, curScreenId, curTag, greedyView, view, peek, focusWindow)+import XMonad.Util.History (History, origin, event, erase, ledger)+import XMonad.Actions.Repeatable (repeatableSt)+import XMonad.Prelude++-- }}}++-- --< Core Data Types: WindowHistory & Location >-- {{{++data WindowHistory = WinHist+  { busy :: !Bool+  , hist :: !(History Window Location)+  } deriving (Show, Read)++instance ExtensionClass WindowHistory where+  initialValue = WinHist+    { busy = False+    , hist = origin+    }+  extensionType = PersistentExtension++data Location = Location+  { workspace :: !WorkspaceId+  , screen    :: !ScreenId+  } deriving (Show, Read, Eq, Ord)++-- }}}++-- --< Interface >-- {{{++-- $usage+--+-- 'configureMRU' must be applied to your config in order for 'mostRecentlyUsed'+-- to work.+--+-- > main :: IO ()+-- > main = xmonad . configureMRU . ... $ def+-- >   { ...+-- >   }+--+-- Once that's done, it can be used normally in keybinds:+--+-- > , ((mod1Mask, xK_Tab), mostRecentlyUsed [xK_Alt_L, xK_Alt_R] xK_Tab)+--+-- N.B.: This example assumes that 'mod1Mask' corresponds to alt, which is not+-- always the case, depending on how your system is configured.++-- | Configure xmonad to support 'mostRecentlyUsed'.+configureMRU :: XConfig l -> XConfig l+configureMRU = XC.once f (MRU ()) where+  f cnf = cnf+    { logHook         = logHook         cnf <> logWinHist+    , handleEventHook = handleEventHook cnf <> winHistEH+    }+newtype MRU = MRU () deriving Semigroup++-- | An action to browse through the history of focused windows, taking+--   another step back with each tap of the key.+mostRecentlyUsed+  :: [KeySym] -- ^ The 'KeySym's corresponding to the modifier to which the+              --   action is bound.+  -> KeySym   -- ^ The 'KeySym' corresponding to the key to which the action+              --   is bound.+  -> X ()+mostRecentlyUsed mods key = do+  (toUndo, undo) <- undoer+  let undoably curThing withThing thing = curThing >>= \cur ->+        when (cur /= thing) $ withThing thing >> toUndo (withThing cur)+  withMostRecentlyUsed mods key $ \win Location{workspace,screen} ->+    handlingRefresh $ do+      undo+      undoably curScreenId viewScreen screen+      undoably curTag      greedyView workspace+      mi <- gets (W.findTag win . windowset)+      for_ mi $ \i -> do+        undoably curTag greedyView i+        mfw <- peek+        for_ mfw $ \fw -> do+          undoably (pure fw) focusWindow win+  where+    undoer :: (MonadIO m, Monoid a) => m (m a -> m (), m a)+    undoer = do+      ref <- io . newIORef $ pure mempty+      let toUndo = io . modifyIORef ref . liftA2 (<>)+          undo   = join (io $ readIORef ref)+                <* io (writeIORef ref $ pure mempty)+      pure (toUndo, undo)+    viewScreen :: ScreenId -> X Any+    viewScreen scr = screenWorkspace scr >>= foldMap view++-- | A version of 'mostRecentlyUsed' that allows you to customise exactly what+--   is done with each window you tab through (the default being to visit its+--   previous 'Location' and give it focus).+withMostRecentlyUsed+  :: [KeySym]                     -- ^ The 'KeySym's corresponding to the+                                  --   modifier to which the action is bound.+  -> KeySym                       -- ^ The 'KeySym' corresponding to the key to+                                  --   which the action is bound.+  -> (Window -> Location -> X ()) -- ^ The function applied to each window.+  -> X ()+withMostRecentlyUsed mods tab preview = do+  wh@WinHist{busy,hist} <- XS.get+  unless busy $ do+    XS.put wh{ busy = True }++    for_ (nonEmpty $ ledger hist) $ \ne -> do+      mfw <- gets (W.peek . windowset)+      let iSt = case cycleS ne of+            (w, _) :~ s | mfw == Just w -> s+            s                           -> s+      repeatableSt iSt mods tab $ \t s ->+        when (t == keyPress && s == tab) (pop >>= lift . uncurry preview)++    XS.modify $ \ws@WinHist{} -> ws{ busy = False }+    logWinHist+  where+    pop = do+      h :~ t <- get+      put t $> h++-- }}}++-- --< Raw Config >-- {{{++logWinHist :: X ()+logWinHist = do+  wh@WinHist{busy,hist} <- XS.get+  unless busy $ do+    cs <- gets (W.current . windowset)+    let cws = W.workspace cs+    for_ (W.stack cws) $ \st -> do+      let location = Location{ workspace = W.tag cws, screen = W.screen cs }+      XS.put wh{ hist = event (W.focus st) location hist }++winHistEH :: Event -> X All+winHistEH ev = All True <$ case ev of+  UnmapEvent{ ev_send_event = synth, ev_window = w } -> do+    e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap)+    when (synth || e == 0) (collect w)+  DestroyWindowEvent{                ev_window = w } -> collect w+  _                                                  -> pure ()+  where collect w = XS.modify $ \wh@WinHist{hist} -> wh{ hist = erase w hist }++-- }}}
XMonad/Actions/MouseGestures.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.MouseGestures+-- Description :  Support for simple mouse gestures. -- Copyright   :  (c) Lukas Mai -- License     :  BSD3-style (see LICENSE) --@@ -21,18 +22,17 @@     mkCollect ) where +import XMonad.Prelude import XMonad import XMonad.Util.Types (Direction2D(..))  import Data.IORef import qualified Data.Map as M import Data.Map (Map)-import Data.Maybe-import Control.Monad  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Actions.MouseGestures -- > import qualified XMonad.StackSet as W@@ -79,17 +79,11 @@ gauge hook op st nx ny = do     let np = (nx, ny)     stx <- io $ readIORef st-    let-        (~(Just od), pivot) = case stx of-            Nothing -> (Nothing, op)-            Just (d, zp) -> (Just d, zp)-        cont = do-            guard $ significant np pivot-            return $ do-                let d' = dir pivot np-                when (isNothing stx || od /= d') $ hook d'-                io $ writeIORef st (Just (d', np))-    fromMaybe (return ()) cont+    let pivot = maybe op snd stx+    when (significant np pivot) $ do+        let d' = dir pivot np+        when ((fst <$> stx) /= Just d') $ hook d'+        io $ writeIORef st (Just (d', np))     where     significant a b = delta a b >= 10 @@ -111,7 +105,7 @@ mouseGesture :: Map [Direction2D] (Window -> X ()) -> Window -> X () mouseGesture tbl win = do     (mov, end) <- mkCollect-    mouseGestureH (\d -> mov d >> return ()) $ end >>= \gest ->+    mouseGestureH (void . mov) $ end >>= \gest ->         case M.lookup gest tbl of             Nothing -> return ()             Just f -> f win
XMonad/Actions/MouseResize.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.MouseResize+-- Description :  A layout modifier to resize windows with the mouse. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -36,27 +37,27 @@ -- "XMonad.Layout.SimpleFloat" or "XMonad.Layout.DecorationMadness". -- -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Actions.MouseResize -- > import XMonad.Layout.WindowArranger -- -- Then edit your @layoutHook@ by modifying a given layout: ----- > myLayout = mouseResize $ windowArrange $ layoutHook defaultConfig+-- > myLayout = mouseResize $ windowArrange $ layoutHook def -- -- and then: ----- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  mouseResize :: l a -> ModifiedLayout MouseResize l a mouseResize = ModifiedLayout (MR []) -data MouseResize a = MR [((a,Rectangle),Maybe a)]+newtype MouseResize a = MR [((a,Rectangle),Maybe a)] instance Show (MouseResize a) where show        _ = "" instance Read (MouseResize a) where readsPrec _ s = [(MR [], s)] @@ -68,7 +69,7 @@         where           wrs'         = wrs_to_state [] . filter (isInStack s . fst) $ wrs           initState    = mapM createInputWindow wrs'-          processState = mapM (deleteInputWin . snd) st >> mapM createInputWindow wrs'+          processState = mapM_ (deleteInputWin . snd) st >> mapM createInputWindow wrs'            inputRectangle (Rectangle x y wh ht) = Rectangle (x + fi wh - 5) (y + fi ht - 5) 10 10 @@ -105,7 +106,7 @@ handleResize _ _ = return ()  createInputWindow :: ((Window,Rectangle), Maybe Rectangle) -> X ((Window,Rectangle),Maybe Window)-createInputWindow ((w,r),mr) = do+createInputWindow ((w,r),mr) =   case mr of     Just tr  -> withDisplay $ \d -> do                   tw <- mkInputWindow d tr
XMonad/Actions/Navigation2D.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, PatternGuards, RankNTypes, TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses, PatternGuards, RankNTypes, TypeSynonymInstances #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Navigation2D+-- Description :  Directional navigation of windows and screens. -- Copyright   :  (c) 2011  Norbert Zeh <nzeh@cs.dal.ca> -- License     :  BSD3-style (see LICENSE) --@@ -32,12 +33,19 @@                                      -- * Exported functions and types                                      -- #Exports# -                                     withNavigation2DConfig+                                     navigation2D+                                   , navigation2DP+                                   , additionalNav2DKeys+                                   , additionalNav2DKeysP+                                   , withNavigation2DConfig                                    , Navigation2DConfig(..)-                                   , defaultNavigation2DConfig+                                   , def                                    , Navigation2D                                    , lineNavigation                                    , centerNavigation+                                   , sideNavigation+                                   , sideNavigationWithBias+                                   , hybridOf                                    , fullScreenRect                                    , singleWindowRect                                    , switchLayer@@ -49,38 +57,86 @@                                    , Direction2D(..)                                    ) where -import Control.Applicative import qualified Data.List as L import qualified Data.Map as M-import Data.Maybe+import Control.Arrow (second)+import XMonad.Prelude import XMonad hiding (Screen) import qualified XMonad.StackSet as W import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Util.EZConfig (additionalKeys, additionalKeysP) import XMonad.Util.Types+import qualified Data.List.NonEmpty as NE  -- $usage -- #Usage# -- 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.  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@:+-- You can use this module with (a subset of) the following in your @xmonad.hs@: -- -- > import XMonad.Actions.Navigation2D ----- Then edit your keybindings:+-- Then add the configuration of the module to your main function: --+-- > main = xmonad $ navigation2D def+-- >                              (xK_Up, xK_Left, xK_Down, xK_Right)+-- >                              [(mod4Mask,               windowGo  ),+-- >                               (mod4Mask .|. shiftMask, windowSwap)]+-- >                              False+-- >               $ def+--+-- /NOTE/: the @def@ argument to 'navigation2D' contains the strategy+-- that decides which windows actually get selected.  While the default+-- behaviour tries to keep them into account, if you use modules that+-- influence tiling in some way, like "XMonad.Layout.Spacing" or+-- "XMonad.Layout.Gaps", you should think about using a different+-- strategy, if you find the default behaviour to be unnatural.  Check+-- out the [finer points](#g:Finer_Points) below for more information.+--+-- Alternatively to 'navigation2D', you can use 'navigation2DP':+--+-- > main = xmonad $ navigation2DP def+-- >                               ("<Up>", "<Left>", "<Down>", "<Right>")+-- >                               [("M-",   windowGo  ),+-- >                                ("M-S-", windowSwap)]+-- >                               False+-- >               $ def+--+-- That's it. If instead you'd like more control, you can combine+-- 'withNavigation2DConfig' and 'additionalNav2DKeys' or 'additionalNav2DKeysP':+--+-- > main = xmonad $ withNavigation2DConfig def+-- >               $ additionalNav2DKeys (xK_Up, xK_Left, xK_Down, xK_Right)+-- >                                     [(mod4Mask,               windowGo  ),+-- >                                      (mod4Mask .|. shiftMask, windowSwap)]+-- >                                     False+-- >               $ additionalNav2DKeys (xK_u, xK_l, xK_d, xK_r)+-- >                                     [(mod4Mask,               screenGo  ),+-- >                                      (mod4Mask .|. shiftMask, screenSwap)]+-- >                                     False+-- >               $ def+--+-- Or you can add the configuration of the module to your main function:+--+-- > main = xmonad $ withNavigation2DConfig def $ def+--+-- And specify your keybindings normally:+-- -- >    -- Switch between layers--- >    , ((modm,                 xK_space), switchLayers)+-- >    , ((modm,                 xK_space), switchLayer) -- > -- >    -- Directional navigation of windows -- >    , ((modm,                 xK_Right), windowGo R False)@@ -112,14 +168,9 @@ -- >    , ((modm .|. mod1Mask,    xK_u    ), windowToScreen U False) -- >    , ((modm .|. mod1Mask,    xK_d    ), windowToScreen D False) ----- and add the configuration of the module to your main function:------ > main = xmonad $ withNavigation2DConfig defaultNavigation2DConfig--- >               $ defaultConfig--- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- $finer_points -- #Finer_Points#@@ -136,9 +187,19 @@ -- values in the above example to 'True'.  You could also decide you want -- wrapping only for a subset of the operations and no wrapping for others. ----- By default, all layouts use the 'defaultTiledNavigation' strategy specified--- in the 'Navigation2DConfig' (by default, line navigation is used).  To--- override this behaviour for some layouts, add a pair (\"layout name\",+-- By default, all layouts use the 'defaultTiledNavigation' strategy+-- specified in the 'Navigation2DConfig' (by default, line navigation is+-- used).  Many more navigation strategies are available; some may feel+-- more natural, depending on the layout and user:+--+--   * 'lineNavigation'+--   * 'centerNavigation'+--   * 'sideNavigation'+--   * 'sideNavigationWithBias'+--+-- There is also the ability to combine two strategies with 'hybridOf'.+--+-- To override the default behaviour for some layouts, add a pair (\"layout name\", -- navigation strategy) to the 'layoutNavigation' list in the -- 'Navigation2DConfig', where \"layout name\" is the string reported by the -- layout's description method (normally what is shown as the layout name in@@ -147,10 +208,10 @@ -- example, for the Full layout, is to switch to center navigation for the Full -- layout: ----- > myNavigation2DConfig = defaultNavigation2DConfig { layoutNavigation = [("Full", centerNavigation)] }+-- > myNavigation2DConfig = def { layoutNavigation = [("Full", centerNavigation)] } -- > -- > main = xmonad $ withNavigation2DConfig myNavigation2DConfig--- >               $ defaultConfig+-- >               $ def -- -- The navigation between windows is based on their screen rectangles, which are -- available /and meaningful/ only for mapped windows.  Thus, as already said,@@ -164,12 +225,12 @@ -- on top of each other so that only the frontmost one is visible.  This can be -- done as follows: ----- > myNavigation2DConfig = defaultNavigation2DConfig { layoutNavigation   = [("Full", centerNavigation)]--- >                                                  , unmappedWindowRect = [("Full", singleWindowRect)]--- >                                                  }+-- > myNavigation2DConfig = def { layoutNavigation   = [("Full", centerNavigation)]+-- >                            , unmappedWindowRect = [("Full", singleWindowRect)]+-- >                            } -- > -- > main = xmonad $ withNavigation2DConfig myNavigation2DConfig--- >               $ defaultConfig+-- >               $ def -- -- With this setup, Left/Up navigation behaves like standard -- 'XMonad.StackSet.focusUp' and Right/Down navigation behaves like@@ -279,7 +340,47 @@ centerNavigation :: Navigation2D centerNavigation = N 2 doCenterNavigation --- | Stores the configuration of directional navigation+-- | 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++-- | Stores the configuration of directional navigation. The 'Default' instance+-- uses line navigation for the tiled layer and for navigation between screens,+-- and center navigation for the float layer.  No custom navigation strategies+-- or rectangles for unmapped windows are defined for individual layouts. data Navigation2DConfig = Navigation2DConfig   { defaultTiledNavigation :: Navigation2D             -- ^ default navigation strategy for the tiled layer   , floatNavigation        :: Navigation2D             -- ^ navigation strategy for the float layer@@ -298,14 +399,64 @@                                                        -- function calculates a rectangle for a given unmapped                                                        -- window from the screen it is on and its window ID.                                                        -- See <#Finer_Points> for how to use this.-  } deriving Typeable+  }  -- | Shorthand for the tedious screen type-type Screen = W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail+type Screen = WindowScreen +-- | Convenience function for enabling Navigation2D with typical keybindings.+-- Takes a Navigation2DConfig, an (up, left, down, right) tuple, a mapping from+-- modifier key to action, and a bool to indicate if wrapping should occur, and+-- returns a function from XConfig to XConfig.+-- Example:+--+-- >  navigation2D def (xK_w, xK_a, xK_s, xK_d) [(mod4Mask, windowGo), (mod4Mask .|. shiftMask, windowSwap)] False myConfig+navigation2D :: Navigation2DConfig -> (KeySym, KeySym, KeySym, KeySym) -> [(ButtonMask, Direction2D -> Bool -> X ())] ->+                Bool -> XConfig l -> XConfig l+navigation2D navConfig (u, l, d, r) modifiers wrap xconfig =+  additionalNav2DKeys (u, l, d, r) modifiers wrap $+  withNavigation2DConfig navConfig xconfig++-- | Convenience function for enabling Navigation2D with typical keybindings,+-- using the syntax defined in 'XMonad.Util.EZConfig.mkKeymap'. Takes a+-- Navigation2DConfig, an (up, left, down, right) tuple, a mapping from key+-- prefix to action, and a bool to indicate if wrapping should occur, and+-- returns a function from XConfig to XConfig. Example:+--+-- >  navigation2DP def ("w", "a", "s", "d") [("M-", windowGo), ("M-S-", windowSwap)] False myConfig+navigation2DP :: Navigation2DConfig -> (String, String, String, String) -> [(String, Direction2D -> Bool -> X ())] ->+                 Bool -> XConfig l -> XConfig l+navigation2DP navConfig (u, l, d, r) modifiers wrap xconfig =+  additionalNav2DKeysP (u, l, d, r) modifiers wrap $+  withNavigation2DConfig navConfig xconfig++-- | Convenience function for adding keybindings. Takes an (up, left, down,+-- right) tuple, a mapping from key prefix to action, and a bool to indicate if+-- wrapping should occur, and returns a function from XConfig to XConfig.+-- Example:+--+-- >  additionalNav2DKeys (xK_w, xK_a, xK_s, xK_d) [(mod4Mask, windowGo), (mod4Mask .|. shiftMask, windowSwap)] False myConfig+additionalNav2DKeys :: (KeySym, KeySym, KeySym, KeySym) -> [(ButtonMask, Direction2D -> Bool -> X ())] ->+                       Bool -> XConfig l -> XConfig l+additionalNav2DKeys (u, l, d, r) modifiers wrap =+  flip additionalKeys [((modif, k), func dir wrap) | (modif, func) <- modifiers, (k, dir) <- dirKeys]+  where dirKeys = [(u, U), (l, L), (d, D), (r, R)]++-- | Convenience function for adding keybindings, using the syntax defined in+-- 'XMonad.Util.EZConfig.mkKeymap'. Takes an (up, left, down, right) tuple, a+-- mapping from key prefix to action, and a bool to indicate if wrapping should+-- occur, and returns a function from XConfig to XConfig. Example:+--+-- >  additionalNav2DKeysP ("w", "a", "s", "d") [("M-", windowGo), ("M-S-", windowSwap)] False myConfig+additionalNav2DKeysP :: (String, String, String, String) -> [(String, Direction2D -> Bool -> X ())] ->+                        Bool -> XConfig l -> XConfig l+additionalNav2DKeysP (u, l, d, r) modifiers wrap =+  flip additionalKeysP [(modif ++ k, func dir wrap) | (modif, func) <- modifiers, (k, dir) <- dirKeys]+  where dirKeys = [(u, U), (l, L), (d, D), (r, R)]+ -- So we can store the configuration in extensible state instance ExtensionClass Navigation2DConfig where-  initialValue = defaultNavigation2DConfig+  initialValue = def  -- | Modifies the xmonad configuration to store the Navigation2D configuration withNavigation2DConfig :: Navigation2DConfig -> XConfig a -> XConfig a@@ -313,12 +464,8 @@                                                           >> XS.put conf2d                                             } --- | Default navigation configuration.  It uses line navigation for the tiled--- layer and for navigation between screens, and center navigation for the float--- layer.  No custom navigation strategies or rectangles for unmapped windows are--- defined for individual layouts.-defaultNavigation2DConfig :: Navigation2DConfig-defaultNavigation2DConfig = Navigation2DConfig { defaultTiledNavigation = lineNavigation+instance Default Navigation2DConfig where+    def                   = Navigation2DConfig { defaultTiledNavigation = hybridOf lineNavigation sideNavigation                                                , floatNavigation        = centerNavigation                                                , screenNavigation       = lineNavigation                                                , layoutNavigation       = []@@ -344,7 +491,7 @@ -- navigation should wrap around (e.g., from the left edge of the leftmost -- screen to the right edge of the rightmost screen). windowGo :: Direction2D -> Bool -> X ()-windowGo dir wrap = actOnLayer thisLayer+windowGo dir = actOnLayer thisLayer                                ( \ conf cur wins -> windows                                  $ doTiledNavigation conf dir W.focusWindow cur wins                                )@@ -354,7 +501,6 @@                                ( \ conf cur wspcs -> windows                                  $ doScreenNavigation conf dir W.view cur wspcs                                )-                               wrap  -- | Swaps the current window with the next window in the given direction and in -- the same layer as the current window.  (In the floating layer, all that@@ -363,7 +509,7 @@ -- window's screen but retains its position and size relative to the screen.) -- The second argument indicates wrapping (see 'windowGo'). windowSwap :: Direction2D -> Bool -> X ()-windowSwap dir wrap = actOnLayer thisLayer+windowSwap dir = actOnLayer thisLayer                                  ( \ conf cur wins -> windows                                    $ doTiledNavigation conf dir swap cur wins                                  )@@ -371,32 +517,28 @@                                    $ doFloatNavigation conf dir swap cur wins                                  )                                  ( \ _ _ _ -> return () )-                                 wrap  -- | Moves the current window to the next screen in the given direction.  The -- second argument indicates wrapping (see 'windowGo'). windowToScreen :: Direction2D -> Bool -> X ()-windowToScreen dir wrap = actOnScreens ( \ conf cur wspcs -> windows+windowToScreen dir = actOnScreens ( \ conf cur wspcs -> windows                                          $ doScreenNavigation conf dir W.shift cur wspcs                                        )-                                       wrap  -- | Moves the focus to the next screen in the given direction.  The second -- argument indicates wrapping (see 'windowGo'). screenGo :: Direction2D -> Bool -> X ()-screenGo dir wrap = actOnScreens ( \ conf cur wspcs -> windows+screenGo dir = actOnScreens ( \ conf cur wspcs -> windows                                    $ doScreenNavigation conf dir W.view cur wspcs                                  )-                                 wrap  -- | Swaps the workspace on the current screen with the workspace on the screen -- in the given direction.  The second argument indicates wrapping (see -- 'windowGo'). screenSwap :: Direction2D -> Bool -> X ()-screenSwap dir wrap = actOnScreens ( \ conf cur wspcs -> windows+screenSwap dir = actOnScreens ( \ conf cur wspcs -> windows                                      $ doScreenNavigation conf dir W.greedyView cur wspcs                                    )-                                   wrap  -- | Maps each window to a fullscreen rect.  This may not be the same rectangle the -- window maps to under the Full layout or a similar layout if the layout@@ -488,11 +630,8 @@  -- | Determines whether a given window is mapped isMapped :: Window -> X Bool-isMapped win  =  withDisplay-              $  \dpy -> io-              $  (waIsUnmapped /=)-              .  wa_map_state-             <$> getWindowAttributes dpy win+isMapped = fmap (maybe False ((waIsUnmapped /=) .  wa_map_state))+         . safeGetWindowAttributes  ---------------------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------------------@@ -516,7 +655,7 @@   where     ctr     = centerOf rect     winctrs = filter ((cur /=) . fst)-            $ map (\(w, r) -> (w, centerOf r)) winrects+            $ map (second centerOf) winrects     closer wc1@(_, c1) wc2@(_, c2) | lDist ctr c1 > lDist ctr c2 = wc2                                    | otherwise                   = wc1 @@ -536,8 +675,7 @@     nav     = maximum             $ map ( fromMaybe (defaultTiledNavigation conf)                   . flip L.lookup (layoutNavigation conf)-                  )-            $ layouts+                  ) layouts  -- | Implements navigation for the float layer doFloatNavigation :: Navigation2DConfig@@ -582,7 +720,7 @@      -- The list of windows that are candidates to receive focus.     winrects'     = filter dirFilter-                  $ filter ((cur /=) . fst)+                  . filter ((cur /=) . fst)                   $ winrects      -- Decides whether a given window matches the criteria to be a candidate to@@ -623,9 +761,8 @@     -- center rotated so the right cone becomes the relevant cone.     -- The windows are ordered in the order they should be preferred     -- when they are otherwise tied.-    winctrs = map (\(w, r) -> (w, dirTransform . centerOf $ r))-            $ stackTransform-            $ winrects+    winctrs = map (second (dirTransform . centerOf))+            $ stackTransform winrects      -- Give preference to windows later in the stack for going left or up and to     -- windows earlier in the stack for going right or down.  (The stack order@@ -647,8 +784,7 @@      -- All the points that coincide with the current center and succeed it     -- in the (appropriately ordered) window stack.-    onCtr' = L.tail $ L.dropWhile ((cur /=) . fst) onCtr-             -- tail should be safe here because cur should be in onCtr+    onCtr' = L.drop 1 $ L.dropWhile ((cur /=) . fst) onCtr      -- All the points that do not coincide with the current center and which     -- lie in the (rotated) right cone.@@ -668,6 +804,54 @@                                              -- or it has the same distance but comes later                                              -- in the window stack +-- 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.sortOn 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 = fromJust . lookup d . zip [R, D, L, U] . iterate rHalfPiCC++    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 swap win winset = W.focusWindow cur@@ -683,7 +867,7 @@     visws    = map W.workspace scrs      -- The focused windows of the visible workspaces-    focused  = mapMaybe (\ws -> W.focus <$> W.stack ws) visws+    focused  = mapMaybe (fmap W.focus . W.stack) visws      -- The window lists of the visible workspaces     wins     = map (W.integrate' . W.stack) visws@@ -700,22 +884,18 @@     -- Reconstruct the workspaces' window stacks to reflect the swap.     newvisws  = zipWith (\ws wns -> ws { W.stack = W.differentiate wns }) visws newwins     newscrs   = zipWith (\scr ws -> scr { W.workspace = ws }) scrs newvisws-    newwinset = winset { W.current = head newscrs-                       , W.visible = tail newscrs+    newwinset = winset { W.current = NE.head (notEmpty newscrs) -- Always at least one screen.+                       , W.visible = drop 1 newscrs                        }  -- | Calculates the center of a rectangle centerOf :: Rectangle -> (Position, Position) centerOf r = (rect_x r + fi (rect_width r) `div` 2, rect_y r + fi (rect_height r) `div` 2) --- | Shorthand for integer conversions-fi :: (Integral a, Num b) => a -> b-fi = fromIntegral- -- | Functions to choose the subset of windows to operate on thisLayer, otherLayer :: a -> a -> a-thisLayer  = curry fst-otherLayer = curry snd+thisLayer  = const+otherLayer _ x = x  -- | Returns the list of visible workspaces and their screen rects visibleWorkspaces :: WindowSet -> Bool -> [WSRect]@@ -752,8 +932,8 @@   where     min_x = fi $ minimum $ map rect_x rects     min_y = fi $ minimum $ map rect_y rects-    max_x = fi $ maximum $ map (\r -> rect_x r + (fi $ rect_width  r)) rects-    max_y = fi $ maximum $ map (\r -> rect_y r + (fi $ rect_height r)) rects+    max_x = fi $ maximum $ map (\r -> rect_x r + fi (rect_width  r)) rects+    max_y = fi $ maximum $ map (\r -> rect_y r + fi (rect_height r)) rects     rects = map snd $ visibleWorkspaces winset False  @@ -763,16 +943,16 @@ sortedScreens winset = L.sortBy cmp                      $ W.screens winset   where-    cmp s1 s2 | x1 < x2   = LT-              | x1 > x2   = GT-              | y1 < x2   = LT-              | y1 > y2   = GT+    cmp s1 s2 | x < x'   = LT+              | x > x'   = GT+              | y < x'   = LT+              | y > y'   = GT               | otherwise = EQ       where-        (x1, y1) = centerOf (screenRect . W.screenDetail $ s1)-        (x2, y2) = centerOf (screenRect . W.screenDetail $ s2)+        (x , y ) = centerOf (screenRect . W.screenDetail $ s1)+        (x', y') = centerOf (screenRect . W.screenDetail $ s2)   -- | Calculates the L1-distance between two points. lDist :: (Position, Position) -> (Position, Position) -> Int-lDist (x1, y1) (x2, y2) = abs (fi $ x1 - x2) + abs (fi $ y1 - y2)+lDist (x, y) (x', y') = abs (fi $ x - x') + abs (fi $ y - y')
XMonad/Actions/NoBorders.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.NoBorders+-- Description :  Helper functions for dealing with window borders. -- Copyright   :  (c) Lukas Mai -- License     :  BSD3-style (see LICENSE) --@@ -26,8 +27,7 @@ toggleBorder :: Window -> X () toggleBorder w = do     bw <- asks (borderWidth . config)-    withDisplay $ \d -> io $ do-        cw <- wa_border_width `fmap` getWindowAttributes d w-        if cw == 0+    withDisplay $ \d -> withWindowAttributes d w $ \wa -> io $+        if wa_border_width wa == 0             then setWindowBorderWidth d w bw             else setWindowBorderWidth d w 0
XMonad/Actions/OnScreen.hs view
@@ -1,157 +1,187 @@------------------------------------------------------------------------------ -- | -- Module      :  XMonad.Actions.OnScreen--- Copyright   :  (c) 2009 Nils Schweinsberg+-- Description :  Control workspaces on different screens (in xinerama mode).+-- Copyright   :  (c) 2009-2025 Nils Schweinsberg -- License     :  BSD3-style (see LICENSE) ----- Maintainer  :  Nils Schweinsberg <mail@n-sch.de>+-- Maintainer  :  Nils Schweinsberg <mail@nils.cc> -- Stability   :  unstable -- Portability :  unportable -- -- Control workspaces on different screens (in xinerama mode).-----------------------------------------------------------------------------------module XMonad.Actions.OnScreen (-    -- * Usage+module XMonad.Actions.OnScreen+  ( -- * Usage     -- $usage-      onScreen-    , onScreen'-    , Focus(..)-    , viewOnScreen-    , greedyViewOnScreen-    , onlyOnScreen-    , toggleOnScreen-    , toggleGreedyOnScreen-    ) where+    onScreen,+    onScreen',+    Focus (..),+    viewOnScreen,+    greedyViewOnScreen,+    onlyOnScreen,+    toggleOnScreen,+    toggleGreedyOnScreen,+  )+where  import XMonad+import XMonad.Prelude (empty, fromMaybe, guard) import XMonad.StackSet hiding (new) -import Control.Monad (guard)--- import Control.Monad.State.Class (gets)-import Data.Maybe (fromMaybe)-- -- | Focus data definitions-data Focus = FocusNew                       -- ^ always focus the new screen-           | FocusCurrent                   -- ^ always keep the focus on the current screen-           | FocusTag WorkspaceId           -- ^ always focus tag i on the new stack-           | FocusTagVisible WorkspaceId    -- ^ focus tag i only if workspace with tag i is visible on the old stack-+data Focus+  = -- | always focus the new screen+    FocusNew+  | -- | always keep the focus on the current screen+    FocusCurrent+  | -- | always focus tag i on the new stack+    FocusTag WorkspaceId+  | -- | focus tag i only if workspace with tag i is visible on the old stack+    FocusTagVisible WorkspaceId  -- | Run any function that modifies the stack on a given screen. This function -- will also need to know which Screen to focus after the function has been -- run.-onScreen :: (WindowSet -> WindowSet) -- ^ function to run-         -> Focus                    -- ^ what to do with the focus-         -> ScreenId                 -- ^ screen id-         -> WindowSet                -- ^ current stack-         -> WindowSet+onScreen ::+  -- | function to run+  (WindowSet -> WindowSet) ->+  -- | what to do with the focus+  Focus ->+  -- | screen id+  ScreenId ->+  -- | current stack+  WindowSet ->+  WindowSet onScreen f foc sc st = fromMaybe st $ do-    ws <- lookupWorkspace sc st--    let fStack      = f $ view ws st+  ws <- lookupWorkspace sc st -    return $ setFocus foc st fStack+  let fStack = f $ view ws st +  return $ setFocus foc st fStack  -- set focus for new stack-setFocus :: Focus-         -> WindowSet -- ^ old stack-         -> WindowSet -- ^ new stack-         -> WindowSet-setFocus FocusNew _ new             = new-setFocus FocusCurrent old new        =-    case lookupWorkspace (screen $ current old) new of-         Nothing -> new-         Just i -> view i new-setFocus (FocusTag i) _ new         = view i new+setFocus ::+  Focus ->+  -- | old stack+  WindowSet ->+  -- | new stack+  WindowSet ->+  WindowSet+setFocus FocusNew _ new = new+setFocus FocusCurrent old new =+  case lookupWorkspace (screen $ current old) new of+    Nothing -> new+    Just i -> view i new+setFocus (FocusTag i) _ new = view i new setFocus (FocusTagVisible i) old new =-    if i `elem` map (tag . workspace) (visible old)-       then setFocus (FocusTag i) old new-       else setFocus FocusCurrent old new+  if i `elem` map (tag . workspace) (visible old)+    then setFocus (FocusTag i) old new+    else setFocus FocusCurrent old new  -- | A variation of @onScreen@ which will take any @X ()@ function and run it -- on the given screen. -- Warning: This function will change focus even if the function it's supposed -- to run doesn't succeed.-onScreen' :: X ()       -- ^ X function to run-          -> Focus      -- ^ focus-          -> ScreenId   -- ^ screen id-          -> X ()+onScreen' ::+  -- | X function to run+  X () ->+  -- | focus+  Focus ->+  -- | screen id+  ScreenId ->+  X () onScreen' x foc sc = do-    st <- gets windowset-    case lookupWorkspace sc st of-         Nothing -> return ()-         Just ws -> do-             windows $ view ws-             x-             windows $ setFocus foc st-+  st <- gets windowset+  case lookupWorkspace sc st of+    Nothing -> return ()+    Just ws -> do+      windows $ view ws+      x+      windows $ setFocus foc st  -- | Switch to workspace @i@ on screen @sc@. If @i@ is visible use @view@ to -- switch focus to the workspace @i@.-viewOnScreen :: ScreenId    -- ^ screen id-             -> WorkspaceId -- ^ index of the workspace-             -> WindowSet   -- ^ current stack-             -> WindowSet+viewOnScreen ::+  -- | screen id+  ScreenId ->+  -- | index of the workspace+  WorkspaceId ->+  -- | current stack+  WindowSet ->+  WindowSet viewOnScreen sid i =-    onScreen (view i) (FocusTag i) sid+  onScreen (view i) (FocusTag i) sid  -- | Switch to workspace @i@ on screen @sc@. If @i@ is visible use @greedyView@ -- to switch the current workspace with workspace @i@.-greedyViewOnScreen :: ScreenId    -- ^ screen id-                   -> WorkspaceId -- ^ index of the workspace-                   -> WindowSet   -- ^ current stack-                   -> WindowSet+greedyViewOnScreen ::+  -- | screen id+  ScreenId ->+  -- | index of the workspace+  WorkspaceId ->+  -- | current stack+  WindowSet ->+  WindowSet greedyViewOnScreen sid i =-    onScreen (greedyView i) (FocusTagVisible i) sid+  onScreen (greedyView i) (FocusTagVisible i) sid  -- | Switch to workspace @i@ on screen @sc@. If @i@ is visible do nothing.-onlyOnScreen :: ScreenId    -- ^ screen id-             -> WorkspaceId -- ^ index of the workspace-             -> WindowSet   -- ^ current stack-             -> WindowSet+onlyOnScreen ::+  -- | screen id+  ScreenId ->+  -- | index of the workspace+  WorkspaceId ->+  -- | current stack+  WindowSet ->+  WindowSet onlyOnScreen sid i =-    onScreen (view i) FocusCurrent sid+  onScreen (view i) FocusCurrent sid  -- | @toggleOrView@ as in "XMonad.Actions.CycleWS" for @onScreen@ with view-toggleOnScreen :: ScreenId    -- ^ screen id-               -> WorkspaceId -- ^ index of the workspace-               -> WindowSet   -- ^ current stack-               -> WindowSet+toggleOnScreen ::+  -- | screen id+  ScreenId ->+  -- | index of the workspace+  WorkspaceId ->+  -- | current stack+  WindowSet ->+  WindowSet toggleOnScreen sid i =-    onScreen (toggleOrView' view i) FocusCurrent sid+  onScreen (toggleOrView' view i) FocusCurrent sid  -- | @toggleOrView@ from "XMonad.Actions.CycleWS" for @onScreen@ with greedyView-toggleGreedyOnScreen :: ScreenId    -- ^ screen id-                     -> WorkspaceId -- ^ index of the workspace-                     -> WindowSet   -- ^ current stack-                     -> WindowSet+toggleGreedyOnScreen ::+  -- | screen id+  ScreenId ->+  -- | index of the workspace+  WorkspaceId ->+  -- | current stack+  WindowSet ->+  WindowSet toggleGreedyOnScreen sid i =-    onScreen (toggleOrView' greedyView i) FocusCurrent sid-+  onScreen (toggleOrView' greedyView i) FocusCurrent sid  -- a \"pure\" version of X.A.CycleWS.toggleOrDoSkip-toggleOrView' :: (WorkspaceId -> WindowSet -> WindowSet)   -- ^ function to run-              -> WorkspaceId                               -- ^ tag to look for-              -> WindowSet                                 -- ^ current stackset-              -> WindowSet+toggleOrView' ::+  -- | function to run+  (WorkspaceId -> WindowSet -> WindowSet) ->+  -- | tag to look for+  WorkspaceId ->+  -- | current stackset+  WindowSet ->+  WindowSet toggleOrView' f i st = fromMaybe (f i st) $ do-    let st' = hidden st-    -- make sure we actually have to do something-    guard $ i == (tag . workspace $ current st)-    guard $ not (null st')-    -- finally, toggle!-    return $ f (tag . head $ st') st-+  let st' = hidden st+  -- make sure we actually have to do something+  guard $ i == (tag . workspace $ current st)+  case st' of+    [] -> empty+    (h : _) -> return $ f (tag h) st -- finally, toggle!  -- $usage -- -- This module provides an easy way to control, what you see on other screens in -- xinerama mode without having to focus them. Put this into your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Actions.OnScreen --@@ -185,4 +215,4 @@ -- where 0 is the first screen and \"1\" the workspace with the tag \"1\". -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.
+ XMonad/Actions/PerLayoutKeys.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.PerLayoutKeys+-- Description :  Define key-bindings on per-layout basis.+-- Copyright   :  (c) brandon s allbery kf8nh 2022, Roman Cheplyaka, 2008+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  brandon s allbery kf8ng <allbery.b@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Define key-bindings on per-layout basis.+--+-----------------------------------------------------------------------------++module XMonad.Actions.PerLayoutKeys (+                                 -- * Usage+                                 -- $usage+                                 chooseActionByLayout,+                                 bindByLayout+                                ) where++import XMonad+import XMonad.StackSet as S++-- $usage+--+-- You can use this module with the following in your @xmonad.hs@:+--+-- >  import XMonad.Actions.PerLayoutKeys+--+-- >   ,((0, xK_F2), bindByLayout [("Tall", spawn "rxvt"), ("Mirror Tall", spawn "xeyes"), ("", spawn "xmessage hello")])+--+-- For detailed instructions on editing your key bindings, see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.++-- | Uses supplied function to decide which action to run depending on current layout name.+chooseActionByLayout :: (String->X()) -> X()+chooseActionByLayout f = withWindowSet (f . description . S.layout. S.workspace . S.current)++-- | If current layout is listed, run appropriate action (only the first match counts!)+-- If it isn't listed, then run default action (marked with empty string, \"\"), or do nothing if default isn't supplied.+bindByLayout :: [(String, X())] -> X()+bindByLayout bindings = chooseActionByLayout chooser where+    chooser l = case lookup l bindings of+        Just action -> action+        Nothing -> case lookup "" bindings of+            Just action -> action+            Nothing -> return ()
+ XMonad/Actions/PerWindowKeys.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.PerWindowKeys+-- Description :  Define key-bindings on a per-window basis.+-- Copyright   :  (c) Wilson Sales, 2019+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Wilson Sales <spoonm@spoonm.org>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Define key-bindings on a per-window basis.+--+-----------------------------------------------------------------------------++module XMonad.Actions.PerWindowKeys (+                                    -- * Usage+                                    -- $usage+                                    bindAll,+                                    bindFirst+                                   ) where++import XMonad++-- $usage+--+-- You can use this module with the following in your @xmonad.hs@:+--+-- >  import XMonad.Actions.PerWindowKeys+--+-- >   ,((0, xK_F2), bindFirst [(className =? "firefox", spawn "dmenu"), (isFloat, withFocused $ windows . W.sink)])+--+-- >   ,((0, xK_F3), bindAll [(isDialog, kill), (pure True, doSomething)])+--+-- If you want an action that will always run, but also want to do something for+-- other queries, you can use @'bindAll' [(query1, action1), ..., (pure True,+-- alwaysDoThisAction)]@.+--+-- Similarly, if you want a default action to be run if all the others failed,+-- you can use @'bindFirst' [(query1, action1), ..., (pure True,+-- doThisIfTheOthersFail)]@.+--+-- For detailed instructions on editing your key bindings, see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.++-- | Run an action if a Query holds true. Doesn't stop at the first one that+-- does, however, and could potentially run all actions.+bindAll :: [(Query Bool, X ())] -> X ()+bindAll = mapM_ choose where+  choose (mh,action) = withFocused $ \w -> whenX (runQuery mh w) action++-- | Run the action paired with the first Query that holds true.+bindFirst :: [(Query Bool, X ())] -> X ()+bindFirst = withFocused . chooseOne++chooseOne :: [(Query Bool, X ())] -> Window -> X ()+chooseOne [] _ = return ()+chooseOne ((mh,a):bs) w = do+  c <- runQuery mh w+  if c then a+       else chooseOne bs w
XMonad/Actions/PerWorkspaceKeys.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.PerWorkspaceKeys+-- Description :  Define key-bindings on per-workspace basis. -- Copyright   :  (c) Roman Cheplyaka, 2008 -- License     :  BSD3-style (see LICENSE) --@@ -24,14 +25,14 @@  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >  import XMonad.Actions.PerWorkspaceKeys -- -- >   ,((0, xK_F2), bindOn [("1", spawn "rxvt"), ("2", spawn "xeyes"), ("", spawn "xmessage hello")]) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Uses supplied function to decide which action to run depending on current workspace name. chooseAction :: (String->X()) -> X()@@ -46,4 +47,3 @@         Nothing -> case lookup "" bindings of             Just action -> action             Nothing -> return ()-
XMonad/Actions/PhysicalScreens.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ParallelListComp #-} ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.PhysicalScreens+-- Description  : Manipulate screens ordered by physical location instead of ID. -- Copyright    : (c) Nelson Elhage <nelhage@mit.edu> -- License      : BSD --@@ -21,14 +24,21 @@                                       , sendToScreen                                       , onNextNeighbour                                       , onPrevNeighbour+                                      , horizontalScreenOrderer+                                      , verticalScreenOrderer+                                      , ScreenComparator(ScreenComparator)+                                      , getScreenIdAndRectangle+                                      , screenComparatorById+                                      , screenComparatorByRectangle+                                      , rescreen                                       ) where -import XMonad+import Data.List.NonEmpty (nonEmpty)+import XMonad hiding (rescreen)+import XMonad.Prelude (elemIndex, fromMaybe, on, sortBy, NonEmpty((:|)))+import qualified Data.List.NonEmpty as NE import qualified XMonad.StackSet as W -import Data.List (sortBy,findIndex)-import Data.Function (on)- {- $usage  This module allows you name Xinerama screens from XMonad using their@@ -36,17 +46,20 @@ 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:+Example usage in your @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,61 +67,137 @@ > -- > [((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".+<https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -}  -- | The type of the index of a screen by location newtype PhysicalScreen = P Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) --- | 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+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:: 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 = fromMaybe 0 $ elemIndex (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)++-- | An alternative to 'XMonad.Operations.rescreen' that avoids reshuffling+-- the workspaces if the number of screens doesn't change and only their+-- locations do. Useful for users of @xrandr --setmonitor@.+--+-- See 'XMonad.Hooks.Rescreen.setRescreenWorkspacesHook', which lets you+-- replace the builtin rescreen handler.+rescreen :: ScreenComparator -> X ()+rescreen (ScreenComparator cmpScreen) = withDisplay (fmap nonEmpty . getCleanedScreenInfo) >>= \case+    Nothing -> trace "getCleanedScreenInfo returned []"+    Just xinescs -> windows $ rescreen' xinescs+  where+    rescreen' :: NonEmpty Rectangle -> WindowSet -> WindowSet+    rescreen' xinescs ws+      | NE.length xinescs == length (W.visible ws) + 1 = rescreenSameLength xinescs ws+      | otherwise = rescreenCore xinescs ws++    -- the 'XMonad.Operations.rescreen' implementation from core as a fallback+    rescreenCore :: NonEmpty Rectangle -> WindowSet -> WindowSet+    rescreenCore (xinesc :| xinescs) ws@W.StackSet{ W.current = v, W.visible = vs, W.hidden = hs } =+        let (xs, ys) = splitAt (length xinescs) (map W.workspace vs ++ hs)+            a = W.Screen (W.workspace v) 0 (SD xinesc)+            as = zipWith3 W.Screen xs [1..] $ map SD xinescs+        in  ws{ W.current = a+              , W.visible = as+              , W.hidden  = ys }++    -- sort both existing screens and the screens we just got from xinerama+    -- using cmpScreen, and then replace the rectangles in the WindowSet,+    -- keeping the order of current/visible workspaces intact+    rescreenSameLength :: NonEmpty Rectangle -> WindowSet -> WindowSet+    rescreenSameLength xinescs ws =+        ws{ W.current = (W.current ws){ W.screenDetail = SD newCurrentRect }+          , W.visible = [ w{ W.screenDetail = SD r } | w <- W.visible ws | r <- newVisibleRects ]+          }+      where+        undoSort =+            NE.map fst $+            NE.sortBy (cmpScreen `on` (getScreenIdAndRectangle . snd)) $+            NE.zip ((0 :: Int) :| [1..]) $ -- add indices to undo the sort later+            W.current ws :| W.visible ws+        newCurrentRect :| newVisibleRects =+            NE.map snd $ NE.sortWith fst $ NE.zip undoSort $ -- sort back into current:visible order+            NE.map snd $ NE.sortBy cmpScreen $ NE.zip (0 :| [1..]) xinescs++    -- TODO:+    -- If number of screens before and after isn't the same, we might still+    -- try to match locations and avoid changing the workspace for those that+    -- didn't move, while making sure that the current workspace is still+    -- visible somewhere.
XMonad/Actions/Plane.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.Plane+-- Description :  Navigate through workspaces in a bidimensional manner. -- Copyright   :  (c) Marco Túlio Gontijo e Silva <marcot@riseup.net>, --                    Leonardo Serra <leoserra@minaslivre.org> -- License     :  BSD3-style (see LICENSE)@@ -38,28 +39,27 @@     )     where -import Control.Monad-import Data.List-import Data.Map hiding (split)-import Data.Maybe+import Data.Map (Map, fromList) +import XMonad.Prelude hiding (fromList) import XMonad import XMonad.StackSet hiding (workspaces) import XMonad.Util.Run  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- > import XMonad.Actions.Plane+-- > import Data.Map (union) -- >--- > main = xmonad defaultConfig {keys = myKeys}+-- > main = xmonad def {keys = myKeys} -- >--- > myKeys conf = union (keys defaultConfig conf) $ myNewKeys conf+-- > myKeys conf = union (keys def conf) $ myNewKeys conf -- >--- > myNewkeys (XConfig {modMask = modm}) = planeKeys modm (Lines 3) Finite+-- > myNewKeys (XConfig {modMask = modm}) = planeKeys modm (Lines 3) Finite -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Direction to go in the plane. data Direction =  ToLeft | ToUp | ToRight | ToDown deriving Enum
+ XMonad/Actions/Prefix.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.Prefix+-- Description :  Use an Emacs-style prefix argument for commands.+-- Copyright   :  (c) Matus Goljer <matus.goljer@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Matus Goljer <matus.goljer@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- A module that allows the user to use a prefix argument (raw or numeric).+--+-----------------------------------------------------------------------------++module XMonad.Actions.Prefix+       (+      -- * Usage+      -- $usage++      -- * Installation+      -- $installation++         PrefixArgument(..)+       , usePrefixArgument+       , useDefaultPrefixArgument+       , withPrefixArgument+       , isPrefixRaw+       , isPrefixNumeric+       , orIfPrefixed+       , ppFormatPrefix+       ) where++import qualified Data.Map as M++import XMonad.Prelude+import XMonad+import XMonad.Util.ExtensibleState as XS+import XMonad.Util.Paste (sendKey)+import XMonad.Actions.Submap (submapDefaultWithKey)+import XMonad.Util.EZConfig (readKeySequence)+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty ((<|))++{- $usage++This module implements Emacs-style prefix argument.  The argument+comes in two flavours, 'Raw' and 'Numeric'.++To initiate the "prefix mode" you hit the prefix keybinding (default+C-u).  This sets the Raw argument value to 1.  Repeatedly hitting this+key increments the raw value by 1.  The Raw argument is usually used+as a toggle, changing the behaviour of the function called in some way.++An example might be calling "mpc add" to add new song to the playlist,+but with C-u we also clean up the playlist beforehand.++When in the "Raw mode", you can hit numeric keys 0..9 (with no+modifier) to enter a "Numeric argument".  Numeric argument represents+a natural number.  Hitting numeric keys in sequence produces the+decimal number that would result from typing them.  That is, the+sequence C-u 4 2 sets the Numeric argument value to the number 42.++If you have a function which understands the prefix argument, for example:++>    addMaybeClean :: PrefixArgument -> X ()+>    addMaybeClean (Raw _) = spawn "mpc clear" >> spawn "mpc add <file>"+>    addMaybeClean _ = spawn "mpc add <file>"++you can turn it into an X action with the function 'withPrefixArgument'.++Binding it in your config++>    ((modm, xK_a), withPrefixArgument addMaybeClean)++Hitting MOD-a will add the @\<file\>@ to the playlist while C-u MOD-a will+clear the playlist and then add the file.++You can of course use an anonymous action, like so:++>    ((modm, xK_a), withPrefixArgument $ \prefix -> do+>        case prefix of ...+>    )++If the prefix key is followed by a binding which is unknown to XMonad,+the prefix along with that binding is sent to the active window.++There is one caveat: when you use an application which has a nested+C-u binding, for example C-c C-u in Emacs org-mode, you have to hit+C-g (or any other non-recognized key really) to get out of the "xmonad+grab" and let the C-c C-u be sent to the application.++-}++{- $installation++The simplest way to enable this is to use 'useDefaultPrefixArgument'++>    xmonad $ useDefaultPrefixArgument $ def { .. }++The default prefix argument is C-u.  If you want to customize the+prefix argument, 'usePrefixArgument' can be used:++>    xmonad $ usePrefixArgument "M-u" $ def { .. }++where the key is entered in Emacs style (or "XMonad.Util.EZConfig"+style) notation.  The letter `M` stands for your chosen modifier.  The+function defaults to C-u if the argument could not be parsed.+-}++data PrefixArgument = Raw Int | Numeric Int | None+                      deriving (Read, Show)+instance ExtensionClass PrefixArgument where+  initialValue = None+  extensionType = PersistentExtension++-- | Run 'job' in the 'X' monad and then execute 'cleanup'.  In case+-- of exception, 'cleanup' is executed anyway.+--+-- Return the return value of 'job'.+finallyX :: X a -> X a -> X a+finallyX job cleanup = catchX (job >>= \r -> cleanup >> return r) cleanup++-- | Set up Prefix.  Defaults to C-u when given an invalid key.+--+-- See usage section.+usePrefixArgument :: LayoutClass l Window+                  => String+                  -> XConfig l+                  -> XConfig l+usePrefixArgument prefix conf =+  conf{ keys = M.insert binding (handlePrefixArg (binding :| [])) . keys conf }+ where+  binding = case readKeySequence conf prefix of+    Just (key :| []) -> key+    _                -> (controlMask, xK_u)++-- | Set Prefix up with default prefix key (C-u).+useDefaultPrefixArgument :: LayoutClass l Window+                         => XConfig l+                         -> XConfig l+useDefaultPrefixArgument = usePrefixArgument "C-u"++handlePrefixArg :: NonEmpty (KeyMask, KeySym) -> X ()+handlePrefixArg events = do+  ks <- asks keyActions+  logger <- asks (logHook . config)+  flip finallyX (XS.put None >> logger) $ do+    prefix <- XS.get+    case prefix of+      Raw a -> XS.put $ Raw (a + 1)+      None -> XS.put $ Raw 1+      _ -> return ()+    logger+    submapDefaultWithKey defaultKey ks+  where defaultKey key@(m, k) =+          if k `elem` (xK_0 : [xK_1 .. xK_9]) && m == noModMask+          then do+            prefix <- XS.get+            let x = fromJust (Prelude.lookup k keyToNum)+            case prefix of+              Raw _ -> XS.put $ Numeric x+              Numeric a -> XS.put $ Numeric $ a * 10 + x+              None -> return () -- should never happen+            handlePrefixArg (key <| events)+          else do+            prefix <- XS.get+            mapM_ (uncurry sendKey) $ case prefix of+              Raw a -> replicate a (NE.head events) ++ [key]+              _ -> reverse (key : toList events)+        keyToNum = (xK_0, 0) : zip [xK_1 .. xK_9] [1..9]++-- | Turn a prefix-aware X action into an X-action.+--+-- First, fetch the current prefix, then pass it as argument to the+-- original function.  You should use this to "run" your commands.+withPrefixArgument :: (PrefixArgument -> X a) -> X a+withPrefixArgument = (>>=) XS.get++-- | Test if 'PrefixArgument' is 'Raw' or not.+isPrefixRaw :: PrefixArgument -> Bool+isPrefixRaw (Raw _) = True+isPrefixRaw _ = False++-- | Test if 'PrefixArgument' is 'Numeric' or not.+isPrefixNumeric :: PrefixArgument -> Bool+isPrefixNumeric (Numeric _) = True+isPrefixNumeric _ = False++-- | Execute the first action, unless any prefix argument is given,+-- in which case the second action is chosen instead.+--+-- > action1 `orIfPrefixed` action2+orIfPrefixed :: X a -> X a -> X a+orIfPrefixed xa xb = withPrefixArgument $ bool xa xb . isPrefixRaw++-- | Format the prefix using the Emacs convetion for use in a+-- statusbar, like xmobar.+--+-- To add this formatted prefix to printer output, you can set it up+-- like so+--+-- > myPrinter :: PP+-- > myPrinter = def { ppExtras = [ppFormatPrefix] }+--+-- And then add to your status bar using "XMonad.Hooks.StatusBar":+--+-- > mySB = statusBarProp "xmobar" myPrinter+-- > main = xmonad $ withEasySB mySB defToggleStrutsKey def+--+-- Or, directly in your 'logHook' configuration+--+-- > logHook = dynamicLogWithPP myPrinter+ppFormatPrefix :: X (Maybe String)+ppFormatPrefix = do+  prefix <- XS.get+  return $ case prefix of+    Raw n -> Just $ foldr1 (\a b -> a ++ " " ++ b) $ replicate n "C-u"+    Numeric n -> Just $ "C-u " ++ show n+    None -> Nothing
+ XMonad/Actions/Profiles.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DerivingVia   #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.Profiles+-- Description :  Group your workspaces by similarity.+-- Copyright   :  (c) Mislav Zanic+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Mislav Zanic <mislavzanic3@gmail.com>+-- Stability   :  experimental+-- Portability :  unportable+--+--------------------------------------------------------------------------------++module XMonad.Actions.Profiles+  ( -- * Overview+    -- $overview++    -- * Usage+    -- $usage++    -- * Types+    ProfileId+  , Profile(..)+  , ProfileConfig(..)++  -- * Hooks+  , addProfiles+  , addProfilesWithHistory++  -- * Switching profiles+  , switchToProfile++  -- * Workspace navigation and keybindings+  , wsFilter+  , bindOn++  -- * Loggers and pretty printers+  , excludeWSPP+  , profileLogger++  -- * Prompts+  , switchProfilePrompt+  , addWSToProfilePrompt+  , removeWSFromProfilePrompt+  , switchProfileWSPrompt+  , shiftProfileWSPrompt++  -- * Utilities+  , currentProfile+  , profileIds+  , previousProfile+  , profileHistory+  , allProfileWindows+  , profileWorkspaces+  )where++--------------------------------------------------------------------------------+import Data.Map.Strict (Map)+import Data.List+import qualified Data.Map.Strict as Map++import Control.DeepSeq++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W++import XMonad.Actions.CycleWS++import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Util.Loggers (Logger)+import XMonad.Prompt.Window (XWindowMap)+import XMonad.Actions.WindowBringer (WindowBringerConfig(..))+import XMonad.Actions.OnScreen (greedyViewOnScreen)+import XMonad.Hooks.Rescreen (addAfterRescreenHook)+import XMonad.Hooks.DynamicLog (PP(ppRename))+import XMonad.Prompt ++--------------------------------------------------------------------------------+-- $overview+-- This module allows you to group your workspaces into 'Profile's based on certain similarities.+-- The idea is to expand upon the philosophy set by "XMonad.Actions.TopicSpace"+-- which states that you can look at a topic/workspace as a+-- single unit of work instead of multiple related units of work.+-- This comes in handy if you have lots of workspaces with windows open and need only to+-- work with a few of them at a time. With 'Profile's, you can focus on those few workspaces that+-- require your attention by not displaying, or allowing you to switch to the rest of the workspaces.+-- The best example is having a profile for development and a profile for leisure activities.++--------------------------------------------------------------------------------+-- $usage+-- To use @Profiles@ you need to add it to your XMonad configuration+-- and configure your profiles.+--  +-- First you'll need to handle the imports.+--  +-- > import XMonad.Actions.Profiles +-- > import XMonad.Util.EZConfig -- for keybindings+-- > import qualified XMonad.StackSet as W+-- > import qualified XMonad.Actions.DynamicWorkspaceOrder as DO -- for workspace navigation+--+-- Next you'll need to define your profiles.+--+-- > myStartingProfile :: ProfileId+-- > myStartingProfile = "Work"+-- >+-- > myProfiles :: [Profile]+-- > myProfiles =+-- >  [ Profile { profileId = "Home"+-- >            , profileWS = [ "www"+-- >                          , "rss"+-- >                          , "vid"+-- >                          , "vms"+-- >                          , "writing"+-- >                          , "notes"+-- >                          ]+-- >            }+-- >  , Profile { profileId = "Work"+-- >            , profileWS = [ "www"+-- >                          , "slack"+-- >                          , "dev"+-- >                          , "k8s"+-- >                          , "notes"+-- >                          ]+-- >            }+-- >  ]+-- +-- So, while using @Home@ 'Profile', you'll only be able to see, navigate to and +-- do actions with @["www", "rss", "vid", "vms", "writing", "notes"]@ workspaces.+--+-- You may also need to define some keybindings. Since @M-1@ .. @M-9@ are+-- sensible keybindings for switching workspaces, you'll need to use+-- 'bindOn' to have different keybindings per profile.+-- Here, we'll use "XMonad.Util.EZConfig" syntax:+-- +-- > myKeys :: [(String, X())]+-- > myKeys = +-- >   [ ("M-p",  switchProfilePrompt   xpConfig)+-- >   , ("M-g",  switchProfileWSPrompt xpConfig)+-- >   , ("M1-j", DO.moveTo Next wsFilter)+-- >   , ("M1-k", DO.moveTo Prev wsFilter)+-- >   ]+-- >   <>+-- >   [ ("M-" ++ m ++ k, bindOn $ map (\x -> (fst x, f $ snd x)) i)+-- >   | (i, k) <- map (\(x:xs) -> (map fst (x:xs), snd x)) $ sortGroupBy snd tupleList+-- >   , (f, m) <- [(mby $ windows . W.greedyView, ""), (mby $ windows . W.shift, "S-")]+-- >   ]+-- >   where+-- >     mby f wid = if wid == "" then return () else f wid+-- >     sortGroupBy f = groupBy (\ x y -> f x == f y) . sortBy (\x y -> compare (f x) (f y))+-- >     tupleList = concatMap (\p -> zip (map (\wid -> (profileId p, wid)) (profileWS p <> repeat "")) (map show [1..9 :: Int])) myProfiles+-- +-- After that, you'll need to hook @Profiles@ into your XMonad config:+-- +-- > main = xmonad $ addProfiles def { profiles        = myProfiles+-- >                                 , startingProfile = myStartingProfile+-- >                                 }+-- >               $ def `additionalKeysP` myKeys+-- ++--------------------------------------------------------------------------------+type ProfileId  = String+type ProfileMap = Map ProfileId Profile++--------------------------------------------------------------------------------+-- | Profile representation.+data Profile = Profile+  { profileId :: !ProfileId     -- ^ Profile name.+  , profileWS :: ![WorkspaceId] -- ^ A list of workspaces contained within a profile.+  }++--------------------------------------------------------------------------------+-- | Internal profile state.+data ProfileState = ProfileState+  { profilesMap :: !ProfileMap+  , current     :: !(Maybe Profile)+  , previous    :: !(Maybe ProfileId)+  }++--------------------------------------------------------------------------------+-- | User config for profiles.+data ProfileConfig = ProfileConfig+  { workspaceExcludes :: ![WorkspaceId] -- ^ A list of workspaces to exclude from the @profileHistoryHook@.+  , profiles          :: ![Profile]     -- ^ A list of user-defined profiles.+  , startingProfile   :: !ProfileId     -- ^ Profile shown on startup.+  }++--------------------------------------------------------------------------------+instance Default ProfileConfig where+  def            = ProfileConfig { workspaceExcludes = []+                                 , profiles          = []+                                 , startingProfile   = ""+                                 }++--------------------------------------------------------------------------------+instance ExtensionClass ProfileState where+  initialValue = ProfileState Map.empty Nothing Nothing++--------------------------------------------------------------------------------+-- Internal type for history tracking.+-- Main problem with @XMonad.Hooks.HistoryHook@ is that it isn't profile aware.+-- Because of that, when switching to a previous workspace, you might switch to+-- a workspace+newtype ProfileHistory = ProfileHistory+  { history :: Map ProfileId [(ScreenId, WorkspaceId)]+  }+  deriving (Read, Show)+  deriving NFData via Map ProfileId [(Int, WorkspaceId)]++--------------------------------------------------------------------------------+instance ExtensionClass ProfileHistory where+  extensionType = PersistentExtension+  initialValue = ProfileHistory Map.empty++--------------------------------------------------------------------------------+newtype ProfilePrompt = ProfilePrompt String++--------------------------------------------------------------------------------+instance XPrompt ProfilePrompt where+  showXPrompt (ProfilePrompt x) = x++--------------------------------------------------------------------------------+defaultProfile :: Profile+defaultProfile = defaultProfile++--------------------------------------------------------------------------------+-- | Returns current profile.+currentProfile :: X ProfileId+currentProfile = profileId . fromMaybe defaultProfile . current <$> XS.get++--------------------------------------------------------------------------------+-- | Returns previous profile.+previousProfile :: X (Maybe ProfileId)+previousProfile = XS.gets previous++--------------------------------------------------------------------------------+-- | Returns the history of viewed workspaces per profile.+profileHistory :: X (Map ProfileId [(ScreenId, WorkspaceId)])+profileHistory = XS.gets history++--------------------------------------------------------------------------------+profileMap :: X ProfileMap+profileMap = XS.gets profilesMap++--------------------------------------------------------------------------------+-- | Returns ids of all profiles.+profileIds :: X [ProfileId]+profileIds = Map.keys <$> XS.gets profilesMap++--------------------------------------------------------------------------------+currentProfileWorkspaces :: X [WorkspaceId]+currentProfileWorkspaces = XS.gets current <&> profileWS . fromMaybe defaultProfile++--------------------------------------------------------------------------------+-- | Hook profiles into XMonad. This function adds a startup hook that+-- sets up ProfileState. Also adds an afterRescreenHook for viewing correct+-- workspaces when adding new screens.+addProfiles :: ProfileConfig -> XConfig a -> XConfig a+addProfiles profConf conf = addAfterRescreenHook hook $ conf+  { startupHook = profileStartupHook' <> startupHook conf+  }+ where+   profileStartupHook' :: X()+   profileStartupHook' = profilesStartupHook (profiles profConf) (startingProfile profConf)+   hook = currentProfile >>= switchWSOnScreens++--------------------------------------------------------------------------------+-- | Hooks profiles into XMonad and enables Profile history logging.+addProfilesWithHistory :: ProfileConfig -> XConfig a -> XConfig a+addProfilesWithHistory profConf conf = conf'+  { logHook = profileHistoryHookExclude (workspaceExcludes profConf) <> logHook conf+  }+  where+   conf' = addProfiles profConf conf++--------------------------------------------------------------------------------+profileHistoryHookExclude :: [WorkspaceId] -> X()+profileHistoryHookExclude ews = do+  cur <- gets $ W.current . windowset+  vis <- gets $ W.visible . windowset+  pws <- currentProfileWorkspaces+  p <- currentProfile++  updateHist p $ workspaceScreenPairs $ filterWS pws $ cur:vis+  where+    workspaceScreenPairs wins = zip (W.screen <$> wins) (W.tag . W.workspace <$> wins)+    filterWS pws = filter ((\wid -> (wid `elem` pws) && (wid `notElem` ews)) . W.tag . W.workspace)++--------------------------------------------------------------------------------+updateHist :: ProfileId -> [(ScreenId, WorkspaceId)] -> X()+updateHist pid xs = profileWorkspaces pid >>= XS.modify' . update+  where+    update pws hs = force $ hs { history = doUpdate pws $ history hs }++    doUpdate pws hist = foldl (\acc (sid, wid) -> Map.alter (f pws sid wid) pid acc) hist xs++    f pws sid wid val = case val of+      Nothing -> pure [(sid, wid)]+      Just hs -> pure $ let new = (sid, wid) in new:filterWS pws new hs++    filterWS :: [WorkspaceId] -> (ScreenId, WorkspaceId) -> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]+    filterWS pws new = filter (\x -> snd x `elem` pws && x /= new)++--------------------------------------------------------------------------------+-- | Adds profiles to ProfileState and sets current profile using .++profilesStartupHook :: [Profile] -> ProfileId -> X ()+profilesStartupHook ps pid = XS.modify go >> switchWSOnScreens pid+  where+    go :: ProfileState -> ProfileState+    go s = s {profilesMap = update $ profilesMap s, current = setCurrentProfile $ Map.fromList $ map entry ps}++    update :: ProfileMap -> ProfileMap+    update = Map.union (Map.fromList $ map entry ps)++    entry :: Profile -> (ProfileId, Profile)+    entry p = (profileId p, p)++    setCurrentProfile :: ProfileMap -> Maybe Profile+    setCurrentProfile s = case Map.lookup pid s of+      Nothing -> Just $ Profile pid []+      Just pn -> Just pn++--------------------------------------------------------------------------------+setPrevious :: ProfileId -> X()+setPrevious name = XS.modify update+  where+    update ps = ps { previous = doUpdate ps }+    doUpdate ps = case Map.lookup name $ profilesMap ps of+      Nothing -> previous ps+      Just p -> Just $ profileId p++--------------------------------------------------------------------------------+setProfile :: ProfileId -> X ()+setProfile p = currentProfile >>= setPrevious >> setProfile' p++--------------------------------------------------------------------------------+setProfile' :: ProfileId -> X ()+setProfile' name = XS.modify update+  where+    update ps = ps { current = doUpdate ps }+    doUpdate ps = case Map.lookup name $ profilesMap ps of+      Nothing -> current ps+      Just p -> Just p++--------------------------------------------------------------------------------+-- | Switch to a profile.+switchToProfile :: ProfileId -> X()+switchToProfile pid = setProfile pid >> switchWSOnScreens pid++--------------------------------------------------------------------------------+-- | Returns the workspace ids associated with a profile id.+profileWorkspaces :: ProfileId -> X [WorkspaceId]+profileWorkspaces pid = profileMap >>= findPWs+  where+    findPWs pm = return . profileWS . fromMaybe defaultProfile $ Map.lookup pid pm++--------------------------------------------------------------------------------+-- | Prompt for adding a workspace id to a profile.+addWSToProfilePrompt :: XPConfig -> X()+addWSToProfilePrompt c = do+  ps <- profileIds+  mkXPrompt (ProfilePrompt "Add ws to profile:") c (mkComplFunFromList' c ps) f+  where+   f :: String -> X()+   f p = do+     vis <- gets $ fmap (W.tag . W.workspace) . W.visible . windowset+     cur <- gets $ W.tag . W.workspace . W.current . windowset+     hid <- gets $ fmap W.tag . W.hidden . windowset+     let+       arr = cur:(vis <> hid)+       in mkXPrompt (ProfilePrompt "Ws to add to profile:") c (mkComplFunFromList' c arr) (`addWSToProfile` p)++--------------------------------------------------------------------------------+-- | Prompt for switching profiles.+switchProfilePrompt :: XPConfig -> X()+switchProfilePrompt c = do+  ps <- profileIds+  mkXPrompt (ProfilePrompt "Profile: ") c (mkComplFunFromList' c ps) switchToProfile+     +--------------------------------------------------------------------------------+-- | Prompt for switching workspaces.+switchProfileWSPrompt :: XPConfig -> X ()+switchProfileWSPrompt c = mkPrompt =<< currentProfileWorkspaces+  where+    mkPrompt pws = mkXPrompt (ProfilePrompt "Switch to workspace:") c (mkComplFunFromList' c pws) mbygoto +    mbygoto wid = do+      pw <- profileWorkspaces =<< currentProfile+      unless (wid `notElem` pw) (windows . W.greedyView $ wid)++--------------------------------------------------------------------------------+-- | Prompt for shifting windows to a different workspace.+shiftProfileWSPrompt :: XPConfig -> X ()+shiftProfileWSPrompt c = mkPrompt =<< currentProfileWorkspaces+  where+    mkPrompt pws = mkXPrompt (ProfilePrompt "Send window to workspace:") c (mkComplFunFromList' c pws) mbyshift+    mbyshift wid = do+      pw <- profileWorkspaces =<< currentProfile+      unless (wid `notElem` pw) (windows . W.shift $ wid)++--------------------------------------------------------------------------------+addWSToProfile :: WorkspaceId -> ProfileId -> X()+addWSToProfile wid pid = XS.modify go+  where+   go :: ProfileState -> ProfileState+   go ps = ps {profilesMap = update $ profilesMap ps, current = update' $ fromMaybe defaultProfile $ current ps}++   update :: ProfileMap -> ProfileMap+   update mp = case Map.lookup pid mp of+     Nothing -> mp+     Just p  -> if wid `elem` profileWS p then mp else Map.adjust f pid mp++   f :: Profile -> Profile+   f p = Profile pid (wid : profileWS p)++   update' :: Profile -> Maybe Profile+   update' cp = if profileId cp == pid && wid `notElem` profileWS cp then Just (Profile pid $ wid:profileWS cp) else Just cp++--------------------------------------------------------------------------------+-- | Prompt for removing a workspace from a profile.+removeWSFromProfilePrompt :: XPConfig -> X()+removeWSFromProfilePrompt c = do+  ps <- profileIds+  mkXPrompt (ProfilePrompt "Remove ws from profile:") c (mkComplFunFromList' c ps) f+  where+   f :: String -> X()+   f p = do+     arr <- profileWorkspaces p+     mkXPrompt (ProfilePrompt "Ws to remove from profile:") c (mkComplFunFromList' c arr) $+       \ws -> do+         cp <- currentProfile+         ws `removeWSFromProfile` p +         when (cp == p) $ currentProfile >>= switchWSOnScreens++--------------------------------------------------------------------------------+removeWSFromProfile :: WorkspaceId -> ProfileId -> X()+removeWSFromProfile wid pid = XS.modify go+  where+   go :: ProfileState -> ProfileState+   go ps = ps {profilesMap = update $ profilesMap ps, current = update' $ fromMaybe defaultProfile $ current ps}++   update :: ProfileMap -> ProfileMap+   update mp = case Map.lookup pid mp of+     Nothing -> mp+     Just p  -> if wid `elem` profileWS p then Map.adjust f pid mp else mp++   f :: Profile -> Profile+   f p = Profile pid (delete wid $ profileWS p)++   update' :: Profile -> Maybe Profile+   update' cp = if profileId cp == pid && wid `elem` profileWS cp then Just (Profile pid $ delete wid $ profileWS cp) else Just cp++--------------------------------------------------------------------------------+-- | Pretty printer for a bar. Prints workspace ids of current profile.+excludeWSPP :: PP -> X PP+excludeWSPP pp = modifyPP <$> currentProfileWorkspaces+  where+    modifyPP pws = pp { ppRename = ppRename pp . printTag pws }+    printTag pws tag = if tag `elem` pws then tag else ""++--------------------------------------------------------------------------------+-- | For cycling through workspaces associated with the current.+wsFilter :: WSType+wsFilter = WSIs $ currentProfileWorkspaces >>= (\ws -> return $ (`elem` ws) . W.tag)++--------------------------------------------------------------------------------+-- Takes care of placing correct workspaces on their respective screens.+-- It does this by reducing the history of a Profile until it gets an array of length+-- equal to the number of screens with pairs that have unique workspace ids.+switchWSOnScreens :: ProfileId -> X()+switchWSOnScreens pid = do+  hist <- profileHistory+  vis <- gets $ W.visible . windowset+  cur <- gets $ W.current . windowset+  pws <- profileMap <&> (profileWS . fromMaybe (Profile pid []) . Map.lookup pid)+  case Map.lookup pid hist of+    Nothing -> switchScreens $ zip (W.screen <$> (cur:vis)) pws+    Just xs -> compareAndSwitch (f (W.screen <$> cur:vis) xs) (cur:vis) pws+  where+    f :: [ScreenId] -> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]+    f sids = reorderUniq . reorderUniq . reverse . filter ((`elem` sids) . fst)++    reorderUniq :: (Ord k, Ord v) => [(k,v)] -> [(v,k)]+    reorderUniq = map (\(x,y) -> (y,x)) . uniq++    uniq :: (Ord k, Ord v) => [(k,v)] -> [(k,v)]+    uniq = Map.toList . Map.fromList++    viewWS fview sid wid = windows $ fview sid wid++    switchScreens = mapM_ (uncurry $ viewWS greedyViewOnScreen)++    compareAndSwitch hist wins pws | length hist < length wins = switchScreens $ hist <> populateScreens hist wins pws+                                   | otherwise                 = switchScreens hist++    populateScreens hist wins pws = zip (filter (`notElem` map fst hist) $ W.screen <$> wins) (filter (`notElem` map snd hist) pws)++--------------------------------------------------------------------------------+chooseAction :: (String -> X ()) -> X ()+chooseAction f = XS.gets current <&> (profileId . fromMaybe defaultProfile) >>= f++--------------------------------------------------------------------------------+-- | Create keybindings per profile.+bindOn :: [(String, X ())] -> X ()+bindOn bindings = chooseAction chooser+  where+    chooser profile = case lookup profile bindings of+        Just action -> action+        Nothing -> case lookup "" bindings of+            Just action -> action+            Nothing -> return ()++--------------------------------------------------------------------------------+-- | Loggs currentProfile and all profiles with hidden workspaces+--   (workspaces that aren't shown on a screen but have windows).+profileLogger :: (String -> String) -> (String -> String) -> Logger+profileLogger formatFocused formatUnfocused = do+  hws <- gets $ W.hidden . windowset+  p <- currentProfile+  hm <- map fst+      . filter (\(p', xs) -> any ((`elem` htags hws) . snd) xs || p' == p)+      . Map.toList <$> profileHistory+  return $ Just $ foldl (\a b -> a ++ " " ++ b) "" $ format p <$> hm+  where+    format p a = if a == p then formatFocused a else formatUnfocused a+    htags wins = W.tag <$> filter (isJust . W.stack) wins++--------------------------------------------------------------------------------+-- | @XWindowMap@ of all windows contained in a profile.+allProfileWindows :: XWindowMap+allProfileWindows = allProfileWindows' def++--------------------------------------------------------------------------------+allProfileWindows' :: WindowBringerConfig -> XWindowMap+allProfileWindows' WindowBringerConfig{ windowTitler = titler, windowFilter = include } = do+  pws <- currentProfileWorkspaces+  windowSet <- gets windowset+  Map.fromList . concat <$> mapM keyValuePairs (filter ((`elem` pws) . W.tag) $ W.workspaces windowSet)+   where keyValuePairs ws = let wins = W.integrate' (W.stack ws)+                           in mapM (keyValuePair ws) =<< filterM include wins+         keyValuePair ws w = (, w) <$> titler ws w
XMonad/Actions/Promote.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.Promote+-- Description :  Alternate promote function for xmonad. -- Copyright   :  (c) Miikka Koskinen 2007 -- License     :  BSD3-style (see LICENSE) --@@ -27,7 +28,7 @@  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.Promote --@@ -36,7 +37,7 @@ -- >   , ((modm,               xK_Return), promote) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Move the focused window to the master pane. All other windows --   retain their order. If focus is in the master, swap it with the
XMonad/Actions/RandomBackground.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.RandomBackground+-- Description :  Start terminals with a random background color. -- Copyright   :  (c) 2009 Anze Slosar --                translation to Haskell by Adam Vogt -- License     :  BSD3-style (see LICENSE)@@ -24,7 +25,6 @@ import XMonad(X, XConf(config), XConfig(terminal), io, spawn,               MonadIO, asks) import System.Random-import Control.Monad(liftM) import Numeric(showHex)  -- $usage@@ -55,7 +55,7 @@  -- | @randomBg'@ produces a random hex number in the form @'#xxyyzz'@ randomBg' ::  (MonadIO m) => RandomColor -> m String-randomBg' (RGB l h) = io $ liftM (toHex . take 3 . randomRs (l,h)) newStdGen+randomBg' (RGB l h) = io $ fmap (toHex . take 3 . randomRs (l,h)) newStdGen randomBg' (HSV s v) = io $ do     g <- newStdGen     let x = (^(2::Int)) $ fst $ randomR (0,sqrt $ pi / 3) g
+ XMonad/Actions/RepeatAction.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.RepeatAction+-- Description :  Repeat the last performed action.+-- Copyright   :  (c) 2022 Martin Kozlovsky+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  <kozlovsky.m7@gmail.com>+-- Stability   :  unstable+-- Portability :  not portable+--+-- Ability to repeat the last action.+--+-----------------------------------------------------------------------------++module XMonad.Actions.RepeatAction (+  -- * Usage+  -- $usage+  rememberAction,+  rememberActions,+  repeatLast,+) where++import XMonad++import qualified XMonad.Util.ExtensibleState as XS++-- $usage+--+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Actions.RepeatAction+--+-- Then join a dedicated key to run the last action with the rest of your+-- key bindings using the 'rememberActions':+--+-- > rememberActions (modm, xK_period) [((modm, xK_c), kill), …]+--+-- It can be also used in the same way for "XMonad.Util.EZConfig":+--+-- > rememberActions "M-." [("M-c", kill), …]+--+-- For example, if you use 'XMonad.Util.EZConfig.additionalKeysP',+--+-- > main = xmonad $ … $ def+-- >   {+-- >     …+-- >   }+-- >  `additionalKeysP` myKeys+--+-- you would adjust the call to 'XMonad.Util.EZConfig.additionalKeysP'+-- like so:+--+-- > `additionalKeysP` (rememberActions "M-." myKeys)+--+-- For more detailed instructions on editing your key bindings, see+-- <https://xmonad.org/TUTORIAL.html the tutorial>.++newtype LastAction = LastAction { runLastAction :: X () }++instance ExtensionClass LastAction where+  initialValue = LastAction $ pure ()++-- | Transforms an action into an action that can be remembered and repeated.+rememberAction :: X () -> X ()+rememberAction x = userCode x >>= \case+  Nothing -> pure ()+  Just () -> XS.put (LastAction x)  -- Only remember action if nothing went wrong.++-- | Maps 'rememberAction' over a list of key bindings.+rememberActions' :: [(a, X ())] -> [(a, X ())]+rememberActions' = map (fmap rememberAction)++infixl 4 `rememberActions`+-- | Maps 'rememberAction' over a list of key bindings and adds a dedicated+-- key to repeat the last action.+rememberActions :: a -> [(a, X ())] -> [(a, X ())]+rememberActions key keyList = (key, repeatLast) : rememberActions' keyList++-- | Runs the last remembered action.+-- / Be careful not to include this action in the remembered actions! /+repeatLast :: X ()+repeatLast = XS.get >>= runLastAction
+ XMonad/Actions/Repeatable.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.Repeatable+-- Description :  Actions you'd like to repeat.+-- Copyright   :  (c) 2022 L. S. Leary+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  @LSLeary (on github)+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module factors out the shared logic of "XMonad.Actions.CycleRecentWS",+-- "XMonad.Actions.CycleWorkspaceByScreen", "XMonad.Actions.CycleWindows" and+-- "XMonad.Actions.MostRecentlyUsed".+--+-- See the source of these modules for usage examples.+--+-----------------------------------------------------------------------------++module XMonad.Actions.Repeatable+  ( repeatable+  , repeatableSt+  , repeatableM+  ) where++-- mtl+import Control.Monad.State (StateT(..))++-- X11+import Graphics.X11.Xlib.Extras++-- xmonad+import XMonad+++-- | An action that temporarily usurps and responds to key press/release events,+--   concluding when one of the modifier keys is released.+repeatable+  :: [KeySym]                      -- ^ The list of 'KeySym's under the+                                   --   modifiers used to invoke the action.+  -> KeySym                        -- ^ The keypress that invokes the action.+  -> (EventType -> KeySym -> X ()) -- ^ The keypress handler.+  -> X ()+repeatable = repeatableM id++-- | A more general variant of 'repeatable' with a stateful handler,+--   accumulating a monoidal return value throughout the events.+repeatableSt+  :: Monoid a+  => s                                     -- ^ Initial state.+  -> [KeySym]                              -- ^ The list of 'KeySym's under the+                                           --   modifiers used to invoke the+                                           --   action.+  -> KeySym                                -- ^ The keypress that invokes the+                                           --   action.+  -> (EventType -> KeySym -> StateT s X a) -- ^ The keypress handler.+  -> X (a, s)+repeatableSt iSt = repeatableM $ \m -> runStateT m iSt++-- | A more general variant of 'repeatable' with an arbitrary monadic handler,+--   accumulating a monoidal return value throughout the events.+repeatableM+  :: (MonadIO m, Monoid a)+  => (m a -> X b)                 -- ^ How to run the monad in 'X'.+  -> [KeySym]                     -- ^ The list of 'KeySym's under the+                                  --   modifiers used to invoke the action.+  -> KeySym                       -- ^ The keypress that invokes the action.+  -> (EventType -> KeySym -> m a) -- ^ The keypress handler.+  -> X b+repeatableM run mods key pressHandler = do+  XConf{ theRoot = root, display = d } <- ask+  run (repeatableRaw d root mods key pressHandler)++repeatableRaw+  :: (MonadIO m, Monoid a)+  => Display -> Window+  -> [KeySym] -> KeySym -> (EventType -> KeySym -> m a) -> m a+repeatableRaw d root mods key pressHandler = do+  io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime)+  handleEvent (keyPress, key) <* io (ungrabKeyboard d currentTime)+  where+    getNextEvent = io $ allocaXEvent $ \p -> do+      maskEvent d (keyPressMask .|. keyReleaseMask) p+      KeyEvent{ ev_event_type = t, ev_keycode = c } <- getEvent p+      s <- keycodeToKeysym d c 0+      return (t, s)+    handleEvent (t, s)+      | t == keyRelease && s `elem` mods = pure mempty+      | otherwise = (<>) <$> pressHandler t s <*> (getNextEvent >>= handleEvent)
XMonad/Actions/RotSlaves.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE ViewPatterns #-}+ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.RotSlaves+-- Description  : Rotate all windows except the master window and keep the focus in place. -- Copyright    : (c) Hans Philipp Annen <haphi@gmx.net>, Mischa Dieterle <der_m@freenet.de> -- License      : BSD3-style (see LICENSE) --@@ -14,11 +17,16 @@ module XMonad.Actions.RotSlaves (         -- $usage         rotSlaves', rotSlavesUp, rotSlavesDown,-        rotAll', rotAllUp, rotAllDown+        rotAll', rotAllUp, rotAllDown,++        -- * Generic list rotations+        -- $generic+        rotUp, rotDown         ) where -import XMonad.StackSet import XMonad+import XMonad.StackSet+import XMonad.Prelude  -- $usage --@@ -35,28 +43,37 @@ -- TwoPane layout (see "XMonad.Layout.TwoPane"). -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Rotate the windows in the current stack, excluding the first one --   (master). rotSlavesUp,rotSlavesDown :: X ()-rotSlavesUp   = windows $ modify' (rotSlaves' (\l -> (tail l)++[head l]))-rotSlavesDown = windows $ modify' (rotSlaves' (\l -> [last l]++(init l)))+rotSlavesUp   = windows $ modify' (rotSlaves' rotUp)+rotSlavesDown = windows $ modify' (rotSlaves' rotDown)  -- | The actual rotation, as a pure function on the window stack. rotSlaves' :: ([a] -> [a]) -> Stack a -> Stack a rotSlaves' _ s@(Stack _ [] []) = s rotSlaves' f   (Stack t [] rs) = Stack t [] (f rs)                -- Master has focus rotSlaves' f s@(Stack _ ls _ ) = Stack t' (reverse revls') rs'    -- otherwise-    where  (master:ws)     = integrate s-           (revls',t':rs') = splitAt (length ls) (master:(f ws))+    where  (notEmpty -> master :| ws)      = integrate s+           (revls', notEmpty -> t' :| rs') = splitAt (length ls) (master:f ws)  -- | Rotate all the windows in the current stack. rotAllUp,rotAllDown :: X ()-rotAllUp   = windows $ modify' (rotAll' (\l -> (tail l)++[head l]))-rotAllDown = windows $ modify' (rotAll' (\l -> [last l]++(init l)))+rotAllUp   = windows $ modify' (rotAll' rotUp)+rotAllDown = windows $ modify' (rotAll' rotDown)  -- | The actual rotation, as a pure function on the window stack. rotAll' :: ([a] -> [a]) -> Stack a -> Stack a rotAll' f s = Stack r (reverse revls) rs-    where (revls,r:rs) = splitAt (length (up s)) (f (integrate s))+    where (revls, notEmpty -> r :| rs) = splitAt (length (up s)) (f (integrate s))++-- $generic+-- Generic list rotations such that @rotUp [1..4]@ is equivalent to+-- @[2,3,4,1]@ and @rotDown [1..4]@ to @[4,1,2,3]@. They both are+-- @id@ for null or singleton lists.+rotUp :: [a] -> [a]+rotUp   l = drop 1 l ++ take 1 l+rotDown :: [a] -> [a]+rotDown = reverse . rotUp . reverse
+ XMonad/Actions/RotateSome.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.RotateSome+-- Description :  Rotate some elements around the stack.+-- Copyright   :  (c) 2020 Ivan Brennan <ivanbrennan@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Ivan Brennan <ivanbrennan@gmail.com>+-- Stability   :  stable+-- Portability :  unportable+--+-- Functions for rotating some elements around the stack while keeping others+-- anchored in place. Useful in combination with layouts that dictate window+-- visibility based on stack position, such as "XMonad.Layout.LimitWindows".+--+-----------------------------------------------------------------------------++module XMonad.Actions.RotateSome (+    -- * Usage+    -- $usage+    -- * Example+    -- $example+    surfaceNext,+    surfacePrev,+    rotateSome,+  ) where++import Control.Arrow ((***))+import XMonad.Prelude (NonEmpty(..), notEmpty, partition, sortOn, (\\))+import qualified Data.Map as M+import XMonad (Window, WindowSpace, Rectangle, X, runLayout, screenRect, windows, withWindowSet)+import XMonad.StackSet (Screen (Screen), Stack (Stack), current, floating, modify', stack)+import XMonad.Util.Stack (reverseS)++{- $usage+You can use this module with the following in your @xmonad.hs@:++> import XMonad.Actions.RotateSome++and add keybindings such as the following:++>   , ((modMask .|. controlMask, xK_n), surfaceNext)+>   , ((modMask .|. controlMask, xK_p), surfacePrev)++-}++{- $example+#Example#++Consider a workspace whose stack contains five windows A B C D E but whose+layout limits how many will actually be shown, showing only the first plus+two additional windows, starting with the third:++>  ┌─────┬─────┐+>  │     │  C  │+>  │  A  ├─────┤+>  │     │  D  │+>  └─────┴─────┘+>+>  A  B  C  D  E+>  _     ____++If C has focus and we'd like to replace it with one of the unshown windows,+'surfaceNext' will move the next unshown window, E, into the focused position:++>  ┌─────┬─────┐                ┌─────┬─────┐+>  │     │ *C* │                │     │ *E* │+>  │  A  ├─────┤ surfaceNext -> │  A  ├─────┤+>  │     │  D  │                │     │  D  │+>  └─────┴─────┘                └─────┴─────┘+>+>  A  B *C* D  E                A  C *E* D  B+>  _     ____                   _     ____++This repositioned windows B C E by treating them as a sequence that can be+rotated through the focused stack position. Windows A and D remain anchored+to their original (visible) positions.++A second call to 'surfaceNext' moves B into focus:++>  ┌─────┬─────┐                ┌─────┬─────┐+>  │     │ *E* │                │     │ *B* │+>  │  A  ├─────┤ surfaceNext -> │  A  ├─────┤+>  │     │  D  │                │     │  D  │+>  └─────┴─────┘                └─────┴─────┘+>+>  A  C *E* D  B                A  E *B* D  C+>  _     ____                   _     ____++A third call would complete the cycle, bringing C back into focus.++-}++-- |+-- Treating the focused window and any unshown windows as a ring that can be+-- rotated through the focused position, surface the next element in the ring.+surfaceNext :: X ()+surfaceNext = do+  ring <- surfaceRing+  windows . modify' $ rotateSome (`elem` ring)++-- | Like 'surfaceNext' in reverse.+surfacePrev :: X ()+surfacePrev = do+  ring <- surfaceRing+  windows . modify' $ reverseS . rotateSome (`elem` ring) . reverseS++-- |+-- Return a list containing the current focus plus any unshown windows. Note+-- that windows are shown if 'runLayout' provides them with a rectangle or if+-- they are floating.+surfaceRing :: X [Window]+surfaceRing = withWindowSet $ \wset -> do+  let Screen wsp _ sd = current wset++  case stack wsp >>= filter' (`M.notMember` floating wset) of+    Nothing -> pure []+    Just st -> go st <$> layoutWindows wsp {stack = Just st} (screenRect sd)+  where+    go :: Stack Window -> [Window] -> [Window]+    go (Stack t ls rs) shown = t : ((ls ++ rs) \\ shown)++    layoutWindows :: WindowSpace -> Rectangle -> X [Window]+    layoutWindows wsp rect = map fst . fst <$> runLayout wsp rect++-- | Like "XMonad.StackSet.filter" but won't move focus.+filter' :: (a -> Bool) -> Stack a -> Maybe (Stack a)+filter' p (Stack f ls rs)+  | p f       = Just $ Stack f (filter p ls) (filter p rs)+  | otherwise = Nothing++-- |+-- @'rotateSome' p stack@ treats the elements of @stack@ that satisfy predicate+-- @p@ as a ring that can be rotated, while all other elements remain anchored+-- in place.+rotateSome :: (a -> Bool) -> Stack a -> Stack a+rotateSome p (Stack t ls rs) =+  let+    -- Flatten the stack, index each element relative to the focused position,+    -- then partition into movable and anchored elements.+    (movables, anchors) =+      partition (p . snd) $+        zip+          [negate (length ls)..]+          (reverse ls ++ t : rs)++    -- Pair each movable element with the index of its next movable neighbor.+    -- Append anchored elements, along with their unchanged indices, and sort+    -- by index. Separate lefts (negative indices) from the rest, and grab the+    -- new focus from the head of the remaining elements.+    (ls', notEmpty -> t' :| rs') =+      (map snd *** map snd)+        . span ((< 0) . fst)+        . sortOn fst+        . (++) anchors+        $ zipWith (curry (fst *** snd)) movables (rotate movables)+  in+    Stack t' (reverse ls') rs'++rotate :: [a] -> [a]+rotate = uncurry (flip (++)) . splitAt 1
XMonad/Actions/Search.hs view
@@ -1,4 +1,6 @@-{- | Module      :  XMonad.Actions.Search+{- |+   Module      :  XMonad.Actions.Search+   Description :  Easily run Internet searches on web sites through xmonad.    Copyright   :  (C) 2007 Gwern Branwen    License     :  None; public domain @@ -18,6 +20,7 @@                                  searchEngineF,                                  promptSearch,                                  promptSearchBrowser,+                                 promptSearchBrowser',                                  selectSearch,                                  selectSearchBrowser,                                  isPrefixOf,@@ -27,30 +30,55 @@                                  (!>),                                  prefixAware,                                  namedEngine,+                                 multiChar,+                                 combineChar,+                                 prefixAwareChar, -                                 amazon,                                  alpha,+                                 amazon,+                                 arXiv,+                                 aur,+                                 clojureDocs,                                  codesearch,+                                 cratesIo,                                  deb,                                  debbts,                                  debpts,                                  dictionary,+                                 duckduckgo,+                                 ebay,+                                 ecosia,+                                 flora,+                                 github,                                  google,                                  hackage,+                                 homeManager,                                  hoogle,                                  images,                                  imdb,-                                 isohunt,                                  lucky,                                  maps,                                  mathworld,+                                 ncatlab,+                                 nixos,+                                 noogle,                                  openstreetmap,+                                 protondb,+                                 rosettacode,+                                 rustStd,                                  scholar,+                                 sourcehut,+                                 stackage,+                                 steam,                                  thesaurus,+                                 vocabulary,+                                 voidpgks_x86_64,+                                 voidpgks_x86_64_musl,                                  wayback,                                  wikipedia,                                  wiktionary,                                  youtube,+                                 zbmath,                                  multi,                                   -- * Use case: searching with a submap                                   -- $tip@@ -59,15 +87,16 @@                                  Browser, Site, Query, Name, Search                           ) where -import Codec.Binary.UTF8.String (encode)-import Data.Char (isAlphaNum, isAscii)-import Data.List (isPrefixOf)-import Text.Printf-import XMonad (X(), MonadIO, liftIO)-import XMonad.Prompt (XPrompt(showXPrompt, nextCompletion, commandToComplete), mkXPrompt, XPConfig(), historyCompletionP, getNextCompletion)-import XMonad.Prompt.Shell (getBrowser)-import XMonad.Util.Run (safeSpawn)-import XMonad.Util.XSelection (getSelection)+import           Codec.Binary.UTF8.String (encode)+import           Text.Printf+import           XMonad                   (X (), liftIO)+import           XMonad.Prompt            (XPConfig (), XPrompt (showXPrompt, nextCompletion, commandToComplete),+                                           getNextCompletion,+                                           historyCompletionP, mkXPrompt)+import           XMonad.Prelude           (NonEmpty ((:|)), isAlphaNum, isAscii, isPrefixOf)+import           XMonad.Prompt.Shell      (getBrowser)+import           XMonad.Util.Run          (safeSpawn)+import           XMonad.Util.XSelection   (getSelection)   {- $usage@@ -94,12 +123,20 @@     The currently available search engines are: +* 'alpha' -- Wolfram|Alpha query.+ * 'amazon' -- Amazon keyword search. -* 'alpha' -- Wolfram|Alpha query.+* 'arXiv' -- Open-access preprint archive. +* 'aur' -- Arch User Repository.++* 'clojureDocs' -- Documentation and examples repository for Clojure.+ * 'codesearch' -- Google Labs Code Search search. +* 'cratesIo' -- Rust crate registry.+ * 'deb'    -- Debian package search.  * 'debbts' -- Debian Bug Tracking System.@@ -108,36 +145,74 @@  * 'dictionary' -- dictionary.reference.com search. +* 'duckduckgo' -- DuckDuckGo search engine.++* 'ebay' -- Ebay keyword search.++* 'ecosia' -- Ecosia search engine.++* 'flora' -- Prettier Haskell package database.++* 'github' -- GitHub keyword search.+ * 'google' -- basic Google search.  * 'hackage' -- Hackage, the Haskell package database. +* 'homeManager' -- Search Nix's home-manager's options.+ * 'hoogle' -- Hoogle, the Haskell libraries API search engine.  * 'images' -- Google images.  * 'imdb'   -- the Internet Movie Database. -* 'isohunt' -- isoHunt search.- * 'lucky' -- Google "I'm feeling lucky" search.  * 'maps'   -- Google maps.  * 'mathworld' -- Wolfram MathWorld search. +* 'ncatlab' -- Higer Algebra, Homotopy and Category Theory Wiki.++* 'nixos' -- Search NixOS packages and options.++* 'noogle' -- 'hoogle'-like Nix API search engine.+ * 'openstreetmap' -- OpenStreetMap free wiki world map. +* 'protondb' -- Steam Proton Game Database.++* 'rosettacode' -- Programming chrestomathy wiki.++* 'rustStd' -- Rust standard library documentation.+ * 'scholar' -- Google scholar academic search. -* 'thesaurus' -- thesaurus.reference.com search.+* 'sourcehut' -- Sourcehut projects search. +* 'stackage' -- Stackage, An alternative Haskell libraries API search engine.++* 'steam' -- Steam games search.++* 'thesaurus' -- thesaurus.com search.++* 'vocabulary' -- Dictionary search.++* 'voidpgks_x86_64' -- Void Linux packages search for @x86_64@.++* 'voidpgks_x86_64_musl' -- Void Linux packages search for @x86_64-musl@.+ * 'wayback' -- the Wayback Machine.  * 'wikipedia' -- basic Wikipedia search. +* 'wiktionary' -- Wiktionary search.+ * 'youtube' -- Youtube video search. +* 'zbmath' -- Open alternative to MathSciNet.+ * 'multi' -- Search based on the prefix. \"amazon:Potter\" will use amazon, etc. With no prefix searches google.  Feel free to add more! -}@@ -157,7 +232,7 @@  > ... > -- Search commands-> , ((modm, xK_s), SM.submap $ searchEngineMap $ S.promptSearch P.defaultXPConfig)+> , ((modm, xK_s), SM.submap $ searchEngineMap $ S.promptSearch P.def) > , ((modm .|. shiftMask, xK_s), SM.submap $ searchEngineMap $ S.selectSearch) > > ...@@ -173,14 +248,14 @@ > ... > ] -- end of regular keybindings > -- Search commands-> ++ [("M-s " ++ k, S.promptSearch P.defaultXPConfig f) | (k,f) <- searchList ]+> ++ [("M-s " ++ k, S.promptSearch P.def f) | (k,f) <- searchList ] > ++ [("M-S-s " ++ k, S.selectSearch f) | (k,f) <- searchList ] > > ... > > searchList :: [(String, S.SearchEngine)] > searchList = [ ("g", S.google)->              , ("h", S.hoohle)+>              , ("h", S.hoogle) >              , ("w", S.wikipedia) >              ] @@ -199,7 +274,7 @@ Happy searching! -}  -- | A customized prompt indicating we are searching, and the name of the site.-data Search = Search Name+newtype Search = Search Name instance XPrompt Search where     showXPrompt (Search name)= "Search [" ++ name ++ "]: "     nextCompletion _ = getNextCompletion@@ -237,7 +312,7 @@    appends it to the base. You can easily define a new engine locally using    exported functions without needing to modify "XMonad.Actions.Search": -> myNewEngine = searchEngine "site" "http://site.com/search="+> myNewEngine = searchEngine "site" "https://site.com/search="     The important thing is that the site has a interface which accepts the escaped query    string as part of the URL. Alas, the exact URL to feed searchEngine varies@@ -246,21 +321,21 @@    Generally, examining the resultant URL of a search will allow you to reverse-engineer    it if you can't find the necessary URL already described in other projects such as Surfraw. -} searchEngine :: Name -> String -> SearchEngine-searchEngine name site = searchEngineF name (\s -> site ++ (escape s))+searchEngine name site = searchEngineF name (\s -> site ++ escape s)  {- | If your search engine is more complex than this (you may want to identify    the kind of input and make the search URL dependent on the input or put the query    inside of a URL instead of in the end) you can use the alternative 'searchEngineF' function.  > searchFunc :: String -> String-> searchFunc s | "wiki:"   `isPrefixOf` s = "http://en.wikipedia.org/wiki/" ++ (escape $ tail $ snd $ break (==':') s)->              | "http://" `isPrefixOf` s = s->              | otherwise               = (use google) s+> searchFunc s | "wiki:"    `isPrefixOf` s = "https://en.wikipedia.org/wiki/" ++ (escape $ drop 1 $ snd $ break (==':') s)+>              | "https://" `isPrefixOf` s = s+>              | otherwise                 = (use google) s > myNewEngine = searchEngineF "mymulti" searchFunc     @searchFunc@ here searches for a word in wikipedia if it has a prefix    of \"wiki:\" (you can use the 'escape' function to escape any forbidden characters), opens an address-   directly if it starts with \"http:\/\/\" and otherwise uses the provided google search engine.+   directly if it starts with \"https:\/\/\" and otherwise uses the provided google search engine.    You can use other engines inside of your own through the 'use' function as shown above to make    complex searches. @@ -270,35 +345,58 @@ searchEngineF = SearchEngine  -- The engines.-amazon, alpha, codesearch, deb, debbts, debpts, dictionary, google, hackage, hoogle,-  images, imdb, isohunt, lucky, maps, mathworld, openstreetmap, scholar, thesaurus, wayback, wikipedia, wiktionary,-  youtube :: SearchEngine-amazon        = searchEngine "amazon"        "http://www.amazon.com/exec/obidos/external-search?index=all&keyword="-alpha         = searchEngine "alpha"         "http://www.wolframalpha.com/input/?i="-codesearch    = searchEngine "codesearch"    "http://www.google.com/codesearch?q="-deb           = searchEngine "deb"           "http://packages.debian.org/"-debbts        = searchEngine "debbts"        "http://bugs.debian.org/"-debpts        = searchEngine "debpts"        "http://packages.qa.debian.org/"-dictionary    = searchEngine "dict"          "http://dictionary.reference.com/browse/"-google        = searchEngine "google"        "http://www.google.com/search?num=100&q="-hackage       = searchEngine "hackage"       "http://hackage.haskell.org/package/"-hoogle        = searchEngine "hoogle"        "http://www.haskell.org/hoogle/?q="-images        = searchEngine "images"        "http://images.google.fr/images?q="-imdb          = searchEngine "imdb"          "http://www.imdb.com/find?s=all&q="-isohunt       = searchEngine "isohunt"       "http://isohunt.com/torrents/?ihq="-lucky         = searchEngine "lucky"         "http://www.google.com/search?btnI&q="-maps          = searchEngine "maps"          "http://maps.google.com/maps?q="-mathworld     = searchEngine "mathworld"     "http://mathworld.wolfram.com/search/?query="-openstreetmap = searchEngine "openstreetmap" "http://gazetteer.openstreetmap.org/namefinder/?find="-scholar       = searchEngine "scholar"       "http://scholar.google.com/scholar?q="-thesaurus     = searchEngine "thesaurus"     "http://thesaurus.reference.com/search?q="-wikipedia     = searchEngine "wiki"          "http://en.wikipedia.org/wiki/Special:Search?go=Go&search="-wiktionary    = searchEngine "wikt"          "http://en.wiktionary.org/wiki/Special:Search?go=Go&search="-youtube       = searchEngine "youtube"       "http://www.youtube.com/results?search_type=search_videos&search_query="-wayback       = searchEngineF "wayback"      ("http://web.archive.org/web/*/"++)+alpha, amazon, arXiv, aur, clojureDocs, codesearch, cratesIo, deb, debbts, debpts, dictionary, duckduckgo, ebay, ecosia, flora,+  github, google, hackage, homeManager, hoogle, images, imdb, lucky, maps, mathworld, ncatlab, nixos, noogle, openstreetmap, protondb,+  rosettacode, rustStd, scholar, sourcehut, stackage, steam, thesaurus, vocabulary, voidpgks_x86_64, voidpgks_x86_64_musl, wayback,+  wikipedia, wiktionary, youtube, zbmath :: SearchEngine+alpha         = searchEngine "alpha"         "https://www.wolframalpha.com/input/?i="+amazon        = searchEngine "amazon"        "https://www.amazon.com/s/ref=nb_sb_noss_2?url=search-alias%3Daps&field-keywords="+arXiv         = searchEngineF "arXiv"        (\s -> "https://arxiv.org/search/?query=" <> s <> "&searchtype=all")+aur           = searchEngine "aur"           "https://aur.archlinux.org/packages?&K="+clojureDocs   = searchEngine "clojureDocs"   "https://clojuredocs.org/search?q="+codesearch    = searchEngine "codesearch"    "https://developers.google.com/s/results/code-search?q="+cratesIo      = searchEngine  "cratesIo"     "https://crates.io/search?q="+deb           = searchEngine "deb"           "https://packages.debian.org/"+debbts        = searchEngine "debbts"        "https://bugs.debian.org/"+debpts        = searchEngine "debpts"        "https://packages.qa.debian.org/"+dictionary    = searchEngine "dict"          "https://dictionary.reference.com/browse/"+duckduckgo    = searchEngine "duckduckgo"    "https://duckduckgo.com/?t=lm&q="+ebay          = searchEngine "ebay"          "https://www.ebay.com/sch/i.html?_nkw="+ecosia        = searchEngine "ecosia"        "https://www.ecosia.org/search?q="+flora         = searchEngine "flora"         "https://flora.pm/search?q="+github        = searchEngine "github"        "https://github.com/search?q="+google        = searchEngine "google"        "https://www.google.com/search?q="+hackage       = searchEngine "hackage"       "https://hackage.haskell.org/package/"+homeManager   = searchEngine "homeManager"   "https://mipmip.github.io/home-manager-option-search/?query="+hoogle        = searchEngine "hoogle"        "https://hoogle.haskell.org/?hoogle="+images        = searchEngine "images"        "https://images.google.fr/images?q="+imdb          = searchEngine "imdb"          "https://www.imdb.com/find?s=all&q="+lucky         = searchEngine "lucky"         "https://www.google.com/search?btnI&q="+maps          = searchEngine "maps"          "https://maps.google.com/maps?q="+mathworld     = searchEngine "mathworld"     "https://mathworld.wolfram.com/search/?query="+ncatlab       = searchEngine "ncatlab"       "https://ncatlab.org/nlab/search?query="+nixos         = searchEngine "nixos"         "https://search.nixos.org/packages?channel=unstable&from=0&size=200&sort=relevance&type=packages&query="+noogle        = searchEngineF "noogle"       (\s -> "https://noogle.dev/?search=" <> s <> "&page=1&to=any&from=any")+openstreetmap = searchEngine "openstreetmap" "https://www.openstreetmap.org/search?query="+protondb      = searchEngine "protondb"      "https://www.protondb.com/search?q="+rosettacode   = searchEngine "rosettacode"   "https://rosettacode.org/w/index.php?search="+rustStd       = searchEngine "rustStd"       "https://doc.rust-lang.org/std/index.html?search="+scholar       = searchEngine "scholar"       "https://scholar.google.com/scholar?q="+sourcehut     = searchEngine "sourcehut"     "https://sr.ht/projects?search="+stackage      = searchEngine "stackage"      "https://www.stackage.org/lts/hoogle?q="+steam         = searchEngine "steam"         "https://store.steampowered.com/search/?term="+thesaurus     = searchEngine "thesaurus"     "https://thesaurus.com/browse/"+vocabulary    = searchEngine "vocabulary"    "https://www.vocabulary.com/search?q="+voidpgks_x86_64      = searchEngine "voidpackages" "https://voidlinux.org/packages/?arch=x86_64&q="+voidpgks_x86_64_musl = searchEngine "voidpackages" "https://voidlinux.org/packages/?arch=x86_64-musl&q="+wayback       = searchEngineF "wayback"      ("https://web.archive.org/web/*/"++)+wikipedia     = searchEngine "wiki"          "https://en.wikipedia.org/wiki/Special:Search?go=Go&search="+wiktionary    = searchEngine "wikt"          "https://en.wiktionary.org/wiki/Special:Search?go=Go&search="+youtube       = searchEngine "youtube"       "https://www.youtube.com/results?search_type=search_videos&search_query="+zbmath        = searchEngine "zbmath"        "https://zbmath.org/?q="  multi :: SearchEngine-multi = namedEngine "multi" $ foldr1 (!>) [amazon, alpha, codesearch, deb, debbts, debpts, dictionary, google, hackage, hoogle, images, imdb, isohunt, lucky, maps, mathworld, openstreetmap, scholar, thesaurus, wayback, wikipedia, wiktionary, (prefixAware google)]+multi = namedEngine "multi" $ foldr1 (!>) [alpha, amazon, aur, codesearch, deb, debbts, debpts, dictionary, duckduckgo, ebay, ecosia, flora, github, hackage, hoogle, images, imdb, lucky, maps, mathworld, ncatlab, openstreetmap, protondb, rosettacode, scholar, sourcehut, stackage, steam, thesaurus, vocabulary, voidpgks_x86_64, voidpgks_x86_64_musl, wayback, wikipedia, wiktionary, youtube, prefixAware google]  {- | This function wraps up a search engine and creates a new one, which works    like the argument, but goes directly to a URL if one is given rather than@@ -306,15 +404,31 @@  > myIntelligentGoogleEngine = intelligent google -   Now if you search for http:\/\/xmonad.org it will directly open in your browser-}+   Now if you search for https:\/\/xmonad.org it will directly open in your browser-} intelligent :: SearchEngine -> SearchEngine-intelligent (SearchEngine name site) = searchEngineF name (\s -> if (fst $ break (==':') s) `elem` ["http", "https", "ftp"] then s else (site s))+intelligent (SearchEngine name site) = searchEngineF name (\s -> if takeWhile (/= ':') s `elem` ["http", "https", "ftp"] then s else site s) --- | > removeColonPrefix "foo://bar" ~> "//bar"--- > removeColonPrefix "foo//bar" ~> "foo//bar"-removeColonPrefix :: String -> String-removeColonPrefix s = if ':' `elem` s then drop 1 $ dropWhile (':' /=) s else s+-- >>> rmChar ':' "foo://bar"+-- "//bar"+-- >>> rmChar 'z' "foo://bar"+-- "foo://bar"+rmChar :: Char -> String -> String+rmChar c s = if c `elem` s then drop 1 (dropWhile (c /=) s) else s +-- | Connect the given list of search engines into one. Selecting a search+-- engine works by its prefix, separated by the given separation character.+-- This is a generalisation of '(!>)' and 'prefixAware' with a custom+-- character that separates the prefix from the query. The first search engine+-- is the fallback; for example,+--+-- > multiChar ':' (google :| [wikipedia, mathworld])+--+-- is equivalent to+--+-- > wikipedia !> mathworld !> (prefixAware google)+multiChar :: Char -> NonEmpty SearchEngine -> SearchEngine+multiChar c (se :| ses) = foldr (combineChar c) (prefixAwareChar c se) ses+ {- | Connects a few search engines into one. If the search engines\' names are    \"s1\", \"s2\" and \"s3\", then the resulting engine will use s1 if the query    is @s1:word@, s2 if you type @s2:word@ and s3 in all other cases.@@ -327,15 +441,30 @@   \"mathworld:integral\" will search mathworld, and everything else will fall back to   google. The use of intelligent will make sure that URLs are opened directly. -} (!>) :: SearchEngine -> SearchEngine -> SearchEngine-(SearchEngine name1 site1) !> (SearchEngine name2 site2) = searchEngineF (name1 ++ "/" ++ name2) (\s -> if (name1++":") `isPrefixOf` s then site1 (removeColonPrefix s) else site2 s)+(!>) = combineChar ':'+infixr 6 !> +-- | @combineChar c s s'@ combines the search engines @s@ and @s'@ into one,+-- where prefixes are separated by the character @c@. It works analogously to+-- '(!>)', only with a chosen separating character: @combineChar ':'@ is the+-- same as '(!>)'.+combineChar :: Char -> SearchEngine -> SearchEngine -> SearchEngine+combineChar c (SearchEngine name1 site1) (SearchEngine name2 site2) =+  searchEngineF (name1 ++ "/" ++ name2) (\s -> if (name1++[c]) `isPrefixOf` s then site1 (rmChar c s) else site2 s)+ {- | Makes a search engine prefix-aware. Especially useful together with '!>'.    It will automatically remove the prefix from a query so that you don\'t end      up searching for google:xmonad if google is your fallback engine and you      explicitly add the prefix. -} prefixAware :: SearchEngine -> SearchEngine-prefixAware (SearchEngine name site) = SearchEngine name (\s -> if (name++":") `isPrefixOf` s then site $ removeColonPrefix s else site s)+prefixAware = prefixAwareChar ':' +-- | Like 'prefixAware', but one gets to choose the character that separates+-- the prefix from the search query.+prefixAwareChar :: Char -> SearchEngine -> SearchEngine+prefixAwareChar c (SearchEngine name site) =+  SearchEngine name (\s -> if (name++[c]) `isPrefixOf` s then site (rmChar c s) else site s)+ {- | Changes search engine's name -} namedEngine :: Name -> SearchEngine -> SearchEngine namedEngine name (SearchEngine _ site) = searchEngineF name site@@ -344,8 +473,18 @@    Prompt's result, passes it to a given searchEngine and opens it in a given    browser. -} promptSearchBrowser :: XPConfig -> Browser -> SearchEngine -> X ()-promptSearchBrowser config browser (SearchEngine name site) =-    mkXPrompt (Search name) config (historyCompletionP ("Search [" `isPrefixOf`)) $ search browser site+promptSearchBrowser config browser (SearchEngine name site) = do+    hc <- historyCompletionP config ("Search [" `isPrefixOf`)+    mkXPrompt (Search name) config hc $ search browser site++{- | Like 'promptSearchBrowser', but only suggest previous searches for the+   given 'SearchEngine' in the prompt. -}+promptSearchBrowser' :: XPConfig -> Browser -> SearchEngine -> X ()+promptSearchBrowser' config browser (SearchEngine name site) = do+    hc <- historyCompletionP config (searchName `isPrefixOf`)+    mkXPrompt (Search name) config hc $ search browser site+  where+    searchName = showXPrompt (Search name)  {- | Like 'search', but in this case, the string is not specified but grabbed  from the user's response to a prompt. Example:
XMonad/Actions/ShowText.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.ShowText+-- Description :  Display text on the screen. -- Copyright   :  (c) Mario Pastorelli (2012) -- License     :  BSD-style (see xmonad/LICENSE) --@@ -16,17 +18,16 @@ module XMonad.Actions.ShowText     ( -- * Usage       -- $usage-      defaultSTConfig+      def     , handleTimerEvent     , flashText     , ShowTextConfig(..)     ) where -import Control.Monad (when) import Data.Map (Map,empty,insert,lookup)-import Data.Monoid (mempty, All) import Prelude hiding (lookup) import XMonad+import XMonad.Prelude (All, fi, listToMaybe) import XMonad.StackSet (current,screen) import XMonad.Util.Font (Align(AlignCenter)                        , initXMF@@ -36,28 +37,27 @@ import XMonad.Util.Timer (startTimer) import XMonad.Util.XUtils (createNewWindow                          , deleteWindow-                         , fi                          , showWindow                          , paintAndWrite) import qualified XMonad.Util.ExtensibleState as ES  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Actions.ShowText -- -- Then add the event hook handler: ----- > xmonad { handleEventHook = myHandleEventHooks <+> handleTimerEvent }+-- > xmonad { handleEventHook = myHandleEventHooks <> handleTimerEvent } -- -- You can then use flashText in your keybindings: ----- > ((modMask, xK_Right), flashText defaultSTConfig 1 "->" >> nextWS)+-- > ((modMask, xK_Right), flashText def 1 "->" >> nextWS) --  -- | ShowText contains the map with timers as keys and created windows as values newtype ShowText = ShowText (Map Atom Window)-    deriving (Read,Show,Typeable)+    deriving (Read,Show)  instance ExtensionClass ShowText where     initialValue = ShowText empty@@ -72,9 +72,13 @@         , st_fg   :: String -- ^ Foreground color     } -defaultSTConfig :: ShowTextConfig-defaultSTConfig =+instance Default ShowTextConfig where+  def =+#ifdef XFT+    STC { st_font = "xft:monospace-20"+#else     STC { st_font = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"+#endif         , st_bg   = "black"         , st_fg   = "white"     }@@ -84,8 +88,9 @@ handleTimerEvent (ClientMessageEvent _ _ _ dis _ mtyp d) = do     (ShowText m) <- ES.get :: X ShowText     a <- io $ internAtom dis "XMONAD_TIMER" False-    when (mtyp == a && length d >= 1)-         (whenJust (lookup (fromIntegral $ d !! 0) m) deleteWindow)+    if | mtyp == a, Just dh <- listToMaybe d ->+           whenJust (lookup (fromIntegral dh) m) deleteWindow+       | otherwise -> pure ()     mempty handleTimerEvent _ = mempty
+ XMonad/Actions/Sift.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.Sift+-- Description :  Functions for sifting windows up and down.+-- Copyright   :  (c) 2020 Ivan Brennan <ivanbrennan@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Ivan Brennan <ivanbrennan@gmail.com>+-- Stability   :  stable+-- Portability :  unportable+--+-- Functions for sifting windows up and down. Sifts behave identically to+-- swaps (i.e. 'swapUp' and 'swapDown' from "XMonad.StackSet"), except in+-- the wrapping case: rather than rotating the entire stack by one position+-- like a swap would, a sift causes the windows at either end of the stack+-- to trade positions.+--+-----------------------------------------------------------------------------++module XMonad.Actions.Sift (+    -- * Usage+    -- $usage+    siftUp,+    siftDown,+  ) where++import XMonad.StackSet (Stack (Stack), StackSet, modify')+import XMonad.Util.Stack (reverseS)++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Actions.Sift+--+-- and add keybindings such as the following:+--+-- >   , ((modMask .|. shiftMask, xK_j ), windows siftDown)+-- >   , ((modMask .|. shiftMask, xK_k ), windows siftUp  )+--++-- |+-- siftUp, siftDown. Exchange the focused window with its neighbour in+-- the stack ordering, wrapping if we reach the end. Unlike 'swapUp' and+-- 'swapDown', wrapping is handled by trading positions with the window+-- at the other end of the stack.+--+siftUp, siftDown :: StackSet i l a s sd -> StackSet i l a s sd+siftUp   = modify' siftUp'+siftDown = modify' (reverseS . siftUp' . reverseS)++siftUp' :: Stack a -> Stack a+siftUp' (Stack t (l:ls) rs) = Stack t ls (l:rs)+siftUp' (Stack t []     rs) =+  case reverse rs of+    (x:xs) -> Stack t (xs ++ [x]) []+    []     -> Stack t []          []
XMonad/Actions/SimpleDate.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.SimpleDate+-- Description :  An example external contrib module for XMonad. -- Copyright   :  (c) Don Stewart 2007 -- License     :  BSD3-style (see LICENSE) --@@ -23,7 +24,7 @@ import XMonad.Util.Run  -- $usage--- To use, import this module into @~\/.xmonad\/xmonad.hs@:+-- To use, import this module into @xmonad.hs@: -- -- >     import XMonad.Actions.SimpleDate --@@ -34,7 +35,7 @@ -- In this example, a popup date menu will now be bound to @mod-d@. -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  date :: X () date = unsafeSpawn "(date; sleep 10) | dzen2"
XMonad/Actions/SinkAll.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.SinkAll+-- Description  : (DEPRECATED) Push floating windows back into tiling. -- License      : BSD3-style (see LICENSE) -- Stability    : unstable -- Portability  : unportable@@ -12,7 +13,7 @@ -- 'sinkAll' function for backwards compatibility. ----------------------------------------------------------------------------- -module XMonad.Actions.SinkAll (+module XMonad.Actions.SinkAll {-# DEPRECATED "Use XMonad.Actions.WithAll instead" #-} (     -- * Usage     -- $usage @@ -22,7 +23,7 @@  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Actions.SinkAll --@@ -31,4 +32,4 @@ -- >   , ((modm .|. shiftMask, xK_t), sinkAll) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.
XMonad/Actions/SpawnOn.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.SpawnOn+-- Description  : Modify a window spawned by a command. -- Copyright    : (c) Spencer Janssen -- License      : BSD --@@ -20,6 +22,7 @@     -- $usage     Spawner,     manageSpawn,+    manageSpawnWithGC,     spawnHere,     spawnOn,     spawnAndDo,@@ -27,69 +30,77 @@     shellPromptOn ) where -import Data.List (isInfixOf) import System.Posix.Types (ProcessID)  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W  import XMonad.Hooks.ManageHelpers import XMonad.Prompt import XMonad.Prompt.Shell import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Util.Process (getPPIDChain)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.SpawnOn -- -- >    main = do--- >      xmonad defaultConfig {+-- >      xmonad def { -- >         ...--- >         manageHook = manageSpawn <+> manageHook defaultConfig+-- >         manageHook = manageSpawn <> manageHook def -- >         ... -- >      } -- -- To ensure that application appears on a workspace it was launched at, add keybindings like: -- -- >  , ((mod1Mask,xK_o), spawnHere "urxvt")--- >  , ((mod1Mask,xK_s), shellPromptHere defaultXPConfig)+-- >  , ((mod1Mask,xK_s), shellPromptHere def) -- -- The module can also be used to apply other manage hooks to the window of -- the spawned application(e.g. float or resize it). -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -newtype Spawner = Spawner {pidsRef :: [(ProcessID, ManageHook)]} deriving Typeable+newtype Spawner = Spawner {pidsRef :: [(ProcessID, ManageHook)]}  instance ExtensionClass Spawner where     initialValue = Spawner [] -maxPids :: Int-maxPids = 5  -- | Get the current Spawner or create one if it doesn't exist. modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X () modifySpawner f = XS.modify (Spawner . f . pidsRef) +modifySpawnerM :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]) -> X ()+modifySpawnerM f = XS.modifyM (fmap Spawner . f . pidsRef)+ -- | Provides a manage hook to react on process spawned with -- 'spawnOn', 'spawnHere' etc. manageSpawn :: ManageHook-manageSpawn = do-    Spawner pids <- liftX XS.get-    mp <- pid-    case flip lookup pids =<< mp of-        Nothing -> idHook-        Just mh  -> do-            whenJust mp $ \p ->-                liftX . modifySpawner $ filter ((/= p) . fst)-            mh+manageSpawn = manageSpawnWithGC (return . take 20) +manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])+        -- ^ function to stop accumulation of entries for windows that never set @_NET_WM_PID@+       -> ManageHook+manageSpawnWithGC garbageCollect = pid >>= \case+    Nothing -> mempty+    Just p -> do+        Spawner pids <- liftX XS.get+        ppid_chain <- io $ getPPIDChain p+        case mapMaybe (`lookup` pids) ppid_chain of+            [] -> mempty+            mh : _ -> liftX (gc p) >> mh+  where+    gc p = modifySpawnerM $ garbageCollect . filter ((/= p) . fst)+ mkPrompt :: (String -> X ()) -> XPConfig -> X () mkPrompt cb c = do-    cmds <- io $ getCommands-    mkXPrompt Shell c (getShellCompl cmds) cb+    cmds <- io getCommands+    mkXPrompt Shell c (getShellCompl cmds $ searchPredicate c) cb  -- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches -- application on current workspace.@@ -109,13 +120,13 @@ -- | Replacement for 'spawn' which launches -- application on given workspace. spawnOn :: WorkspaceId -> String -> X ()-spawnOn ws cmd = spawnAndDo (doShift ws) cmd+spawnOn ws = spawnAndDo (doShift ws)  -- | Spawn an application and apply the manage hook when it opens. spawnAndDo :: ManageHook -> String -> X () spawnAndDo mh cmd = do     p <- spawnPID $ mangle cmd-    modifySpawner $ (take maxPids . ((p,mh) :))+    modifySpawner ((p,mh) :)  where     -- TODO this is silly, search for a better solution     mangle xs | any (`elem` metaChars) xs || "exec" `isInfixOf` xs = xs
XMonad/Actions/Submap.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.Submap+-- Description :  Create a sub-mapping of key bindings. -- Copyright   :  (c) Jason Creighton <jcreigh@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -16,19 +17,23 @@                              -- * Usage                              -- $usage                              submap,-                             submapDefault+                             visualSubmap,+                             visualSubmapSorted,+                             submapDefault,+                             submapDefaultWithKey,++                             -- * Utilities+                             subName,                             ) where import Data.Bits-import XMonad hiding (keys) import qualified Data.Map as M-import Control.Monad.Fix (fix)+import XMonad hiding (keys)+import XMonad.Prelude (fix, fromMaybe, keyToString, cleanKeyMask)+import XMonad.Util.XUtils  {- $usage ----First, import this module into your @~\/.xmonad\/xmonad.hs@:+First, import this module into your @xmonad.hs@:  > import XMonad.Actions.Submap @@ -49,7 +54,7 @@ modifier.  For detailed instructions on editing your key bindings, see-"XMonad.Doc.Extending#Editing_key_bindings".+<https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -} @@ -58,25 +63,98 @@ --   corresponding action, or does nothing if the key is not found in --   the map. submap :: M.Map (KeyMask, KeySym) (X ()) -> X ()-submap keys = submapDefault (return ()) keys+submap = submapDefault (return ()) +-- | Like 'submap', but visualise the relevant options.+--+-- ==== __Example__+--+-- > import qualified Data.Map as Map+-- > import XMonad.Actions.Submap+-- >+-- > gotoLayout :: [(String, X ())]   -- for use with EZConfig+-- > gotoLayout =  -- assumes you have a layout named "Tall" and one named "Full".+-- >   [("M-l", visualSubmap def $ Map.fromList $ map (\(k, s, a) -> ((0, k), (s, a)))+-- >              [ (xK_t, "Tall", switchToLayout "Tall")     -- "M-l t" switches to "Tall"+-- >              , (xK_r, "Full", switchToLayout "Full")     -- "M-l r" switches to "full"+-- >              ])]+--+-- One could alternatively also write @gotoLayout@ as+--+-- > gotoLayout = [("M-l", visualSubmap def $ Map.fromList $+-- >                         [ ((0, xK_t), subName "Tall" $ switchToLayout "Tall")+-- >                         , ((0, xK_r), subName "Full" $ switchToLayout "Full")+-- >                         ])]+visualSubmap :: WindowConfig -- ^ The config for the spawned window.+             -> M.Map (KeyMask, KeySym) (String, X ())+                             -- ^ A map @keybinding -> (description, action)@.+             -> X ()+visualSubmap = visualSubmapSorted id++-- | Like 'visualSubmap', but is able to sort the descriptions.+-- For example,+--+-- > import Data.Ord (comparing, Down)+-- >+-- > visualSubmapSorted (sortBy (comparing Down)) def+--+-- would sort the @(key, description)@ pairs by their keys in descending+-- order.+visualSubmapSorted :: ([((KeyMask, KeySym), String)] -> [((KeyMask, KeySym), String)])+                             -- ^ A function to resort the descriptions+             -> WindowConfig -- ^ The config for the spawned window.+             -> M.Map (KeyMask, KeySym) (String, X ())+                             -- ^ A map @keybinding -> (description, action)@.+             -> X ()+visualSubmapSorted sorted wc keys =+    withSimpleWindow wc descriptions waitForKeyPress >>= \(m', s) ->+        maybe (pure ()) snd (M.lookup (m', s) keys)+  where+    descriptions :: [String]+    descriptions =+        map (\(key, desc) -> keyToString key <> ": " <> desc)+            . sorted+            $ zip (M.keys keys) (map fst (M.elems keys))++-- | Give a name to an action.+subName :: String -> X () -> (String, X ())+subName = (,)+ -- | Like 'submap', but executes a default action if the key did not match. submapDefault :: X () -> M.Map (KeyMask, KeySym) (X ()) -> X ()-submapDefault def keys = do-    XConf { theRoot = root, display = d } <- ask+submapDefault = submapDefaultWithKey . const -    io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime+-- | Like 'submapDefault', but sends the unmatched key to the default+-- action as argument.+submapDefaultWithKey :: ((KeyMask, KeySym) -> X ())+                     -> M.Map (KeyMask, KeySym) (X ())+                     -> X ()+submapDefaultWithKey defAction keys = waitForKeyPress >>=+    \(m', s) -> fromMaybe (defAction (m', s)) (M.lookup (m', s) keys) -    (m, s) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do-        maskEvent d keyPressMask p-        KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p-        keysym <- keycodeToKeysym d code 0-        if isModifierKey keysym-            then nextkey-            else return (m, keysym)-    -- Remove num lock mask and Xkb group state bits-    m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1)+-----------------------------------------------------------------------+-- Internal stuff -    io $ ungrabKeyboard d currentTime+waitForKeyPress :: X (KeyMask, KeySym)+waitForKeyPress = do+    XConf{ theRoot = root, display = dpy } <- ask -    maybe def id (M.lookup (m', s) keys)+    io $ do grabKeyboard dpy root False grabModeAsync grabModeAsync currentTime+            grabPointer dpy root False buttonPressMask grabModeAsync grabModeAsync+                        none none currentTime++    (m, s) <- io $ allocaXEvent $ \p -> fix $ \nextkey -> do+        maskEvent dpy (keyPressMask .|. buttonPressMask) p+        ev <- getEvent p+        case ev of+          KeyEvent { ev_keycode = code, ev_state = m } -> do+            keysym <- keycodeToKeysym dpy code 0+            if isModifierKey keysym+                then nextkey+                else return (m, keysym)+          _ -> return (0, 0)+    m' <- cleanKeyMask <*> pure m+    io $ do ungrabPointer dpy currentTime+            ungrabKeyboard dpy currentTime+            sync dpy False+    pure (m', s)
+ XMonad/Actions/SwapPromote.hs view
@@ -0,0 +1,404 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.SwapPromote+-- Description :  Track the master window history per workspace.+-- 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           XMonad.Prelude+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           Control.Arrow+import qualified Data.List.NonEmpty             as NE+++-- $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)++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 = NE.head . notEmpty . 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',map snd 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)
XMonad/Actions/SwapWorkspaces.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.SwapWorkspaces+-- Description :  Swap workspace tags without having to move individual windows. -- Copyright   :  (c) Devin Mullins <me@twifkak.com> -- License     :  BSD3-style (see LICENSE) --@@ -29,7 +30,7 @@   -- $usage--- Add this import to your @~\/.xmonad\/xmonad.hs@:+-- Add this import to your @xmonad.hs@: -- -- > import XMonad.Actions.SwapWorkspaces --@@ -43,7 +44,7 @@ -- will swap workspaces 1 and 5. -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Swaps the currently focused workspace with the given workspace tag, via --   @swapWorkspaces@.@@ -53,12 +54,13 @@ -- | Say @swapTo Next@ or @swapTo Prev@ to move your current workspace. -- This is an @X ()@ so can be hooked up to your keybindings directly. swapTo :: Direction1D -> X ()-swapTo dir = findWorkspace getSortByIndex dir AnyWS 1 >>= windows . swapWithCurrent+swapTo dir = findWorkspace getSortByIndex dir anyWS 1 >>= windows . swapWithCurrent  -- | Takes two workspace tags and an existing XMonad.StackSet and returns a new --   one with the two corresponding workspaces' tags swapped. swapWorkspaces :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd swapWorkspaces t1 t2 = mapWorkspace swap-    where swap w = if      tag w == t1 then w { tag = t2 }-                   else if tag w == t2 then w { tag = t1 }-                   else w+    where swap w+            | tag w == t1 = w { tag = t2 }+            | tag w == t2 = w { tag = t1 }+            | otherwise = w
XMonad/Actions/TagWindows.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.TagWindows+-- Description  : Functions for tagging windows and selecting them by tags. -- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de> -- License      : BSD --@@ -26,21 +27,19 @@                  TagPrompt,                  ) where -import Data.List (nub,sortBy)-import Control.Monad import Control.Exception as E -import XMonad.StackSet hiding (filter)--import XMonad.Prompt import XMonad hiding (workspaces)+import XMonad.Prelude+import XMonad.Prompt+import XMonad.StackSet hiding (filter)  econst :: Monad m => a -> IOException -> m a econst = const . return  -- $usage ----- To use window tags, import this module into your @~\/.xmonad\/xmonad.hs@:+-- To use window tags, import this module into your @xmonad.hs@: -- -- > import XMonad.Actions.TagWindows -- > import XMonad.Prompt    -- to use tagPrompt@@ -53,19 +52,19 @@ -- >   , ((modm,                 xK_d  ), withTaggedP "abc" (W.shiftWin "2")) -- >   , ((modm .|. shiftMask,   xK_d  ), withTaggedGlobalP "abc" shiftHere) -- >   , ((modm .|. controlMask, xK_d  ), focusUpTaggedGlobal "abc")--- >   , ((modm,                 xK_g  ), tagPrompt defaultXPConfig (\s -> withFocused (addTag s)))--- >   , ((modm .|. controlMask, xK_g  ), tagDelPrompt defaultXPConfig)--- >   , ((modm .|. shiftMask,   xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobal s float))--- >   , ((modWinMask,                xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedP s (W.shiftWin "2")))--- >   , ((modWinMask .|. shiftMask,  xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobalP s shiftHere))--- >   , ((modWinMask .|. controlMask, xK_g ), tagPrompt defaultXPConfig (\s -> focusUpTaggedGlobal s))+-- >   , ((modm,                 xK_g  ), tagPrompt def (\s -> withFocused (addTag s)))+-- >   , ((modm .|. controlMask, xK_g  ), tagDelPrompt def)+-- >   , ((modm .|. shiftMask,   xK_g  ), tagPrompt def (\s -> withTaggedGlobal s float))+-- >   , ((modWinMask,                xK_g  ), tagPrompt def (\s -> withTaggedP s (W.shiftWin "2")))+-- >   , ((modWinMask .|. shiftMask,  xK_g  ), tagPrompt def (\s -> withTaggedGlobalP s shiftHere))+-- >   , ((modWinMask .|. controlMask, xK_g ), tagPrompt def (\s -> focusUpTaggedGlobal s)) -- -- NOTE: Tags are saved as space separated strings and split with --       'unwords'. Thus if you add a tag \"a b\" the window will have --       the tags \"a\" and \"b\" but not \"a b\". -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | set multiple tags for a window at once (overriding any previous tags) setTags :: [String] -> Window -> X ()@@ -84,18 +83,17 @@     io $ E.catch (internAtom d "_XMONAD_TAGS" False >>=                 getTextProperty d w >>=                 wcTextPropertyToTextList d)-               (econst [[]])-    >>= return . words . unwords+               (econst [[]]) <&> (words . unwords)  -- | check a window for the given tag hasTag :: String -> Window -> X Bool-hasTag s w = (s `elem`) `fmap` getTags w+hasTag s w = (s `elem`) <$> getTags w  -- | add a tag to the existing ones addTag :: String -> Window -> X () addTag s w = do     tags <- getTags w-    if (s `notElem` tags) then setTags (s:tags) w else return ()+    when (s `notElem` tags) $ setTags (s:tags) w  -- | remove a tag from a window, if it exists delTag :: String -> Window -> X ()@@ -136,11 +134,6 @@ focusTagged' wl t = gets windowset >>= findM (hasTag t) . wl >>=     maybe (return ()) (windows . focusWindow) -findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)-findM _ []      = return Nothing-findM p (x:xs)  = do b <- p x-                     if b then return (Just x) else findM p xs- -- | apply a pure function to windows with a tag withTaggedP, withTaggedGlobalP :: String -> (Window -> WindowSet -> WindowSet) -> X () withTaggedP       t f = withTagged'       t (winMap f)@@ -158,7 +151,7 @@  withTaggedGlobal' :: String -> ([Window] -> X ()) -> X () withTaggedGlobal' t m = gets windowset >>=-    filterM (hasTag t) . concat . map (integrate' . stack) . workspaces >>= m+    filterM (hasTag t) . concatMap (integrate' . stack) . workspaces >>= m  withFocusedP :: (Window -> WindowSet -> WindowSet) -> X () withFocusedP f = withFocused $ windows . f@@ -167,7 +160,7 @@ shiftHere w s = shiftWin (currentTag s) w s  shiftToScreen :: (Ord a, Eq s, Eq i) => s -> a -> StackSet i l a s sd -> StackSet i l a s sd-shiftToScreen sid w s = case filter (\m -> sid /= screen m) ((current s):(visible s)) of+shiftToScreen sid w s = case filter (\m -> sid /= screen m) (current s:visible s) of                                 []      -> s                                 (t:_)   -> shiftWin (tag . workspace $ t) w s @@ -180,20 +173,19 @@ tagPrompt :: XPConfig -> (String -> X ()) -> X () tagPrompt c f = do   sc <- tagComplList-  mkXPrompt TagPrompt c (mkComplFunFromList' sc) f+  mkXPrompt TagPrompt c (mkComplFunFromList' c sc) f  tagComplList :: X [String]-tagComplList = gets (concat . map (integrate' . stack) . workspaces . windowset) >>=-    mapM getTags >>=-    return . nub . concat+tagComplList = gets (concatMap (integrate' . stack) . workspaces . windowset)+           >>= mapM getTags+           <&> nub . concat   tagDelPrompt :: XPConfig -> X () tagDelPrompt c = do   sc <- tagDelComplList-  if (sc /= [])-    then mkXPrompt TagPrompt c (mkComplFunFromList' sc) (\s -> withFocused (delTag s))-    else return ()+  when (sc /= []) $+    mkXPrompt TagPrompt c (mkComplFunFromList' c sc) (withFocused . delTag)  tagDelComplList :: X [String] tagDelComplList = gets windowset >>= maybe (return []) getTags . peek
+ XMonad/Actions/TiledWindowDragging.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.TiledWindowDragging+-- Description :  Change the position of windows by dragging them.+-- Copyright   :  (c) 2020 Leon Kowarschick+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Leon Kowarschick. <thereal.elkowar@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides an action that allows you to change the position of windows by dragging them around.+--+-----------------------------------------------------------------------------++module XMonad.Actions.TiledWindowDragging+  (+  -- * Usage+  -- $usage+    dragWindow+  )+where++import           XMonad+import           XMonad.Prelude+import qualified XMonad.StackSet               as W+import           XMonad.Layout.DraggingVisualizer++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Actions.TiledWindowDragging+-- > import XMonad.Layout.DraggingVisualizer+--+-- then edit your 'layoutHook' by adding the draggingVisualizer to your layout:+--+-- > myLayout = draggingVisualizer $ layoutHook def+--+-- Then add a mouse binding for 'dragWindow':+--+-- > , ((modMask .|. shiftMask, button1), dragWindow)+--+-- For detailed instructions on editing your mouse bindings, see+-- "XMonad.Doc.Extending#Editing_mouse_bindings".++++-- | Create a mouse binding for this to be able to drag your windows around.+-- You need "XMonad.Layout.DraggingVisualizer" for this to look good.+dragWindow :: Window -> X ()+dragWindow window = whenX (isClient window) $ withDisplay $ \dpy ->+  withWindowAttributes dpy window $ \wa -> do+    focus window+    (offsetX, offsetY)                    <- getPointerOffset window+    let (winX, winY, winWidth, winHeight)  = getWindowPlacement wa++    mouseDrag+        (\posX posY ->+          let rect = Rectangle (fi (fi winX + (posX - fi offsetX)))+                               (fi (fi winY + (posY - fi offsetY)))+                               (fi winWidth)+                               (fi winHeight)+          in  sendMessage $ DraggingWindow window rect+        )+        (sendMessage DraggingStopped >> performWindowSwitching window)+++-- | get the pointer offset relative to the given windows root coordinates+getPointerOffset :: Window -> X (Int, Int)+getPointerOffset win = do+    (_, _, _, oX, oY, _, _, _) <- withDisplay (\d -> io $ queryPointer d win)+    return (fi oX, fi oY)++-- | return a tuple of windowX, windowY, windowWidth, windowHeight+getWindowPlacement :: WindowAttributes -> (Int, Int, Int, Int)+getWindowPlacement wa = (fi $ wa_x wa, fi $ wa_y wa, fi $ wa_width wa, fi $ wa_height wa)++performWindowSwitching :: Window -> X ()+performWindowSwitching win = do+    root                          <- asks theRoot+    (_, _, selWin, _, _, _, _, _) <- withDisplay (\d -> io $ queryPointer d root)+    ws                            <- gets windowset+    let allWindows = W.index ws+    when ((win `elem` allWindows) && (selWin `elem` allWindows)) $ do+        let allWindowsSwitched = map (switchEntries win selWin) allWindows+        (ls, t : rs)          <- pure $ break (== win) allWindowsSwitched+        let newStack           = W.Stack t (reverse ls) rs+        windows $ W.modify' $ const newStack+   where+    switchEntries a b x | x == a    = b+                        | x == b    = a+                        | otherwise = x
+ XMonad/Actions/ToggleFullFloat.hs view
@@ -0,0 +1,122 @@+-- |+-- Module      :  XMonad.Actions.ToggleFullFloat+-- Description :  Fullscreen (float) a window while remembering its original state.+-- Copyright   :  (c) 2022 Tomáš Janoušek <tomi@nomi.cz>+-- License     :  BSD3+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>+--+module XMonad.Actions.ToggleFullFloat (+    -- * Usage+    -- $usage+    toggleFullFloatEwmhFullscreen,+    toggleFullFloat,+    fullFloat,+    unFullFloat,+    gcToggleFullFloat,+    ) where++import qualified Data.Map.Strict as M++import XMonad+import XMonad.Prelude+import XMonad.Hooks.EwmhDesktops (setEwmhFullscreenHooks)+import XMonad.Hooks.ManageHelpers+import qualified XMonad.StackSet as W+import qualified XMonad.Util.ExtensibleState as XS++-- ---------------------------------------------------------------------+-- $usage+--+-- The main use-case is to make 'ewmhFullscreen' (re)store the size and+-- position of floating windows instead of just unconditionally sinking them+-- into the floating layer. To enable this, you'll need this in your+-- @xmonad.hs@:+--+-- > import XMonad+-- > import XMonad.Actions.ToggleFullFloat+-- > import XMonad.Hooks.EwmhDesktops+-- >+-- > main = xmonad $ … . toggleFullFloatEwmhFullscreen . ewmhFullscreen . ewmh . … $ def{…}+--+-- Additionally, this "smart" fullscreening can be bound to a key and invoked+-- manually whenever one needs a larger window temporarily:+--+-- >   , ((modMask .|. shiftMask, xK_t), withFocused toggleFullFloat)++newtype ToggleFullFloat = ToggleFullFloat{ fromToggleFullFloat :: M.Map Window (Maybe W.RationalRect) }+    deriving (Show, Read)++instance ExtensionClass ToggleFullFloat where+    extensionType = PersistentExtension+    initialValue = ToggleFullFloat mempty++-- | Full-float a window, remembering its state (tiled/floating and+-- position/size).+fullFloat :: Window -> X ()+fullFloat = windows . appEndo <=< runQuery doFullFloatSave++-- | Restore window to its remembered state.+unFullFloat :: Window -> X ()+unFullFloat = windows . appEndo <=< runQuery doFullFloatRestore++-- | Full-float a window, if it's not already full-floating. Otherwise,+-- restore its original state.+toggleFullFloat :: Window -> X ()+toggleFullFloat w = ifM (isFullFloat w) (unFullFloat w) (fullFloat w)++isFullFloat :: Window -> X Bool+isFullFloat w = gets $ (Just fullRect ==) . M.lookup w . W.floating . windowset+  where+    fullRect = W.RationalRect 0 0 1 1++doFullFloatSave :: ManageHook+doFullFloatSave = do+    w <- ask+    liftX $ do+        f <- gets $ M.lookup w . W.floating . windowset+        -- @M.insertWith const@ = don't overwrite stored original state+        XS.modify' $ ToggleFullFloat . M.insertWith const w f . fromToggleFullFloat+    doFullFloat++doFullFloatRestore :: ManageHook+doFullFloatRestore = do+    w <- ask+    mf <- liftX $ do+        mf <- XS.gets $ M.lookup w . fromToggleFullFloat+        XS.modify' $ ToggleFullFloat . M.delete w . fromToggleFullFloat+        pure mf+    doF $ case mf of+        Just (Just f) -> W.float w f  -- was floating before+        Just Nothing -> W.sink w      -- was tiled before+        Nothing -> W.sink w           -- fallback when not found in ToggleFullFloat++-- | Install ToggleFullFloat garbage collection hooks.+--+-- Note: This is included in 'toggleFullFloatEwmhFullscreen', only needed if+-- using the 'toggleFullFloat' separately from the EWMH hook.+gcToggleFullFloat :: XConfig a -> XConfig a+gcToggleFullFloat c = c { startupHook     = startupHook c <> gcToggleFullFloatStartupHook+                        , handleEventHook = handleEventHook c <> gcToggleFullFloatEventHook }++-- | ToggleFullFloat garbage collection: drop windows when they're destroyed.+gcToggleFullFloatEventHook :: Event -> X All+gcToggleFullFloatEventHook DestroyWindowEvent{ev_window = w} = do+    XS.modify' $ ToggleFullFloat . M.delete w . fromToggleFullFloat+    mempty+gcToggleFullFloatEventHook _ = mempty++-- | ToggleFullFloat garbage collection: restrict to existing windows at+-- startup.+gcToggleFullFloatStartupHook :: X ()+gcToggleFullFloatStartupHook = withWindowSet $ \ws ->+    XS.modify' $ ToggleFullFloat . M.filterWithKey (\w _ -> w `W.member` ws) . fromToggleFullFloat++-- | Hook this module into 'XMonad.Hooks.EwmhDesktops.ewmhFullscreen'. This+-- makes windows restore their original state (size and position if floating)+-- instead of unconditionally sinking into the tiling layer.+--+-- ('gcToggleFullFloat' is included here.)+toggleFullFloatEwmhFullscreen :: XConfig a -> XConfig a+toggleFullFloatEwmhFullscreen =+    setEwmhFullscreenHooks doFullFloatSave doFullFloatRestore .+    gcToggleFullFloat
XMonad/Actions/TopicSpace.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.TopicSpace+-- Description :  Turns your workspaces into a more topic oriented system. -- Copyright   :  (c) Nicolas Pouillard -- License     :  BSD-style (see LICENSE) --@@ -19,20 +20,49 @@    -- * Usage   -- $usage-   Topic++  -- * Types for Building Topics+    Topic   , Dir   , TopicConfig(..)-  , defaultTopicConfig+  , TopicItem(..)++    -- * Managing 'TopicItem's+  , topicNames+  , tiActions+  , tiDirs+  , noAction+  , inHome++    -- * Switching and Shifting Topics+  , switchTopic+  , switchNthLastFocused+  , switchNthLastFocusedByScreen+  , switchNthLastFocusedExclude+  , shiftNthLastFocused++    -- * Topic Actions+  , topicActionWithPrompt+  , topicAction+  , currentTopicAction++    -- * Getting the Topic History   , getLastFocusedTopics+  , workspaceHistory+  , workspaceHistoryByScreen++    -- * Modifying the Topic History   , setLastFocusedTopic   , reverseLastFocusedTopics++    -- * History hooks+  , workspaceHistoryHook+  , workspaceHistoryHookExclude++    -- * Pretty Printing   , pprWindowSet-  , topicActionWithPrompt-  , topicAction-  , currentTopicAction-  , switchTopic-  , switchNthLastFocused-  , shiftNthLastFocused++    -- * Utility   , currentTopicDir   , checkTopicConfig   , (>*>)@@ -40,25 +70,26 @@ where  import XMonad--import Data.List-import Data.Maybe (fromMaybe, isNothing, listToMaybe, fromJust)-import Data.Ord-import qualified Data.Map as M-import Control.Monad (liftM2,when,unless,replicateM_)-import System.IO+import XMonad.Prelude -import qualified XMonad.StackSet as W+import qualified Data.Map.Strict           as M+import qualified XMonad.Hooks.StatusBar.PP as SBPP+import qualified XMonad.StackSet           as W -import XMonad.Prompt-import XMonad.Prompt.Workspace+import Data.Map (Map) -import XMonad.Hooks.UrgencyHook-import XMonad.Hooks.DynamicLog (PP(..))-import qualified XMonad.Hooks.DynamicLog as DL+import XMonad.Prompt (XPConfig)+import XMonad.Prompt.Workspace (workspacePrompt) -import XMonad.Util.Run (spawnPipe)-import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Hooks.StatusBar.PP (PP(ppHidden, ppVisible))+import XMonad.Hooks.UrgencyHook (readUrgents)+import XMonad.Hooks.WorkspaceHistory+    ( workspaceHistory+    , workspaceHistoryByScreen+    , workspaceHistoryHook+    , workspaceHistoryHookExclude+    , workspaceHistoryModify+    )  -- $overview -- This module allows to organize your workspaces on a precise topic basis.  So@@ -72,112 +103,133 @@ -- display your topics in an historical way using a custom `pprWindowSet' -- function. You can also easily switch to recent topics using this history -- of last focused topics.+--+-- A blog post highlighting some features of this module can be found+-- <https://tony-zorman.com/posts/topic-space/2022-09-11-topic-spaces.html here>.  -- $usage--- Here is an example of configuration using TopicSpace:+-- You can use this module with the following in your @xmonad.hs@: ----- > -- The list of all topics/workspaces of your xmonad configuration.--- > -- The order is important, new topics must be inserted--- > -- at the end of the list if you want hot-restarting--- > -- to work.--- > myTopics :: [Topic]--- > myTopics =--- >   [ "dashboard" -- the first one--- >   , "admin", "build", "cleaning", "conf", "darcs", "haskell", "irc"--- >   , "mail", "movie", "music", "talk", "text", "tools", "web", "xmonad"--- >   , "yi", "documents", "twitter", "pdf"--- >   ]+-- > import qualified Data.Map.Strict as M+-- > import qualified XMonad.StackSet as W -- >+-- > import XMonad.Actions.TopicSpace+-- > import XMonad.Util.EZConfig    -- for the keybindings+-- > import XMonad.Prompt.Workspace -- if you want to use the prompt+--+-- You will then have to+--+--   * Define a new 'TopicConfig' via 'TopicItem's+--+--   * Add the appropriate keybindings+--+--   * Replace the @workspaces@ field in your 'XConfig' with a list of+--     your topics names+--+--   * Optionally, if you want to use the history features, add+--     'workspaceHistoryHook' from "XMonad.Hooks.WorkspaceHistory"+--     (re-exported by this module) or an equivalent function to your+--     @logHook@.  See the documentation of+--     "XMonad.Hooks.WorkspaceHistory" for further details+--+-- Let us go through a full example together.+--+-- A 'TopicItem' consists of three things: the name of the topic, its+-- root directory, and the action associated to it—to be executed if the+-- topic is empty or the action is forced via a keybinding.+--+-- We start by specifying our chosen topics as a list of such+-- 'TopicItem's:+--+-- > topicItems :: [TopicItem]+-- > topicItems =+-- >   [ inHome   "1:WEB"              (spawn "firefox")+-- >   , noAction "2"      "."+-- >   , noAction "3:VID"  "videos"+-- >   , TI       "4:VPN"  "openvpn"   (spawn "urxvt -e randomVPN.sh")+-- >   , inHome   "5:IM"               (spawn "signal" *> spawn "telegram")+-- >   , inHome   "6:IRC"              (spawn "urxvt -e weechat")+-- >   , TI       "dts"    ".dotfiles" spawnShell+-- >   , TI       "xm-con" "hs/xm-con" (spawnShell *> spawnShellIn "hs/xm")+-- >   ]+--+-- Then we just need to put together our topic config:+-- -- > myTopicConfig :: TopicConfig--- > myTopicConfig = defaultTopicConfig--- >   { topicDirs = M.fromList $--- >       [ ("conf", "w/conf")--- >       , ("dashboard", "Desktop")--- >       , ("yi", "w/dev-haskell/yi")--- >       , ("darcs", "w/dev-haskell/darcs")--- >       , ("haskell", "w/dev-haskell")--- >       , ("xmonad", "w/dev-haskell/xmonad")--- >       , ("tools", "w/tools")--- >       , ("movie", "Movies")--- >       , ("talk", "w/talks")--- >       , ("music", "Music")--- >       , ("documents", "w/documents")--- >       , ("pdf", "w/documents")--- >       ]--- >   , defaultTopicAction = const $ spawnShell >*> 3--- >   , defaultTopic = "dashboard"--- >   , topicActions = M.fromList $--- >       [ ("conf",       spawnShell >> spawnShellIn "wd/ertai/private")--- >       , ("darcs",      spawnShell >*> 3)--- >       , ("yi",         spawnShell >*> 3)--- >       , ("haskell",    spawnShell >*> 2 >>--- >                        spawnShellIn "wd/dev-haskell/ghc")--- >       , ("xmonad",     spawnShellIn "wd/x11-wm/xmonad" >>--- >                        spawnShellIn "wd/x11-wm/xmonad/contrib" >>--- >                        spawnShellIn "wd/x11-wm/xmonad/utils" >>--- >                        spawnShellIn ".xmonad" >>--- >                        spawnShellIn ".xmonad")--- >       , ("mail",       mailAction)--- >       , ("irc",        ssh somewhere)--- >       , ("admin",      ssh somewhere >>--- >                        ssh nowhere)--- >       , ("dashboard",  spawnShell)--- >       , ("twitter",    spawnShell)--- >       , ("web",        spawn browserCmd)--- >       , ("movie",      spawnShell)--- >       , ("documents",  spawnShell >*> 2 >>--- >                        spawnShellIn "Documents" >*> 2)--- >       , ("pdf",        spawn pdfViewerCmd)--- >       ]+-- > myTopicConfig = def+-- >   { topicDirs          = tiDirs    topicItems+-- >   , topicActions       = tiActions topicItems+-- >   , defaultTopicAction = const (pure ()) -- by default, do nothing+-- >   , defaultTopic       = "1:WEB"         -- fallback -- >   }--- >--- > -- extend your keybindings--- > myKeys conf@XConfig{modMask=modm} =--- >   [ ((modm              , xK_n     ), spawnShell) -- %! Launch terminal--- >   , ((modm              , xK_a     ), currentTopicAction myTopicConfig)--- >   , ((modm              , xK_g     ), promptedGoto)--- >   , ((modm .|. shiftMask, xK_g     ), promptedShift)--- >   {- more  keys ... -}--- >   ]--- >   ++--- >   [ ((modm, k), switchNthLastFocused myTopicConfig i)--- >   | (i, k) <- zip [1..] workspaceKeys]--- >+--+-- Above, we have used the `spawnShell` and `spawnShellIn` helper+-- functions; here they are:+-- -- > spawnShell :: X () -- > spawnShell = currentTopicDir myTopicConfig >>= spawnShellIn -- > -- > spawnShellIn :: Dir -> X ()--- > spawnShellIn dir = spawn $ "urxvt '(cd ''" ++ dir ++ "'' && " ++ myShell ++ " )'"--- >+-- > spawnShellIn dir = spawn $ "alacritty --working-directory " ++ dir+--+-- Next, we define some other other useful helper functions.  It is+-- rather common to have a lot of topics—much more than available keys!+-- In a situation like that, it's very convenient to switch topics with+-- a prompt; the following use of 'workspacePrompt' does exactly that.+-- -- > goto :: Topic -> X () -- > goto = switchTopic myTopicConfig -- > -- > promptedGoto :: X ()--- > promptedGoto = workspacePrompt myXPConfig goto+-- > promptedGoto = workspacePrompt def goto -- > -- > promptedShift :: X ()--- > promptedShift = workspacePrompt myXPConfig $ windows . W.shift--- >--- > myConfig = do--- >     checkTopicConfig myTopics myTopicConfig--- >     myLogHook <- makeMyLogHook--- >     return $ defaultConfig--- >          { borderWidth = 1 -- Width of the window border in pixels.--- >          , workspaces = myTopics--- >          , layoutHook = myModifiers myLayout--- >          , manageHook = myManageHook--- >          , logHook = myLogHook--- >          , handleEventHook = myHandleEventHook--- >          , terminal = myTerminal -- The preferred terminal program.--- >          , normalBorderColor = "#3f3c6d"--- >          , focusedBorderColor = "#4f66ff"--- >          , XMonad.modMask = mod1Mask--- >          , keys = myKeys--- >          , mouseBindings = myMouseBindings--- >          }+-- > promptedShift = workspacePrompt def $ windows . W.shift -- >+-- > -- Toggle between the two most recently used topics, but keep+-- > -- screens separate.  This needs @workspaceHistoryHook@.+-- > toggleTopic :: X ()+-- > toggleTopic = switchNthLastFocusedByScreen myTopicConfig 1+--+-- Hopefully you've gotten a general feeling of how to define these kind of+-- small helper functions using what's provided in this module.+--+-- Adding the appropriate keybindings works as it normally would.  Here,+-- we'll use "XMonad.Util.EZConfig" syntax:+--+-- > myKeys :: [(String, X ())]+-- > myKeys =+-- >   [ ("M-n"        , spawnShell)+-- >   , ("M-a"        , currentTopicAction myTopicConfig)+-- >   , ("M-g"        , promptedGoto)+-- >   , ("M-S-g"      , promptedShift)+-- >   , ("M-S-<Space>", toggleTopic)+-- >   ]+-- >   +++-- >   -- The following does two things:+-- >   --   1. Switch topics (no modifier)+-- >   --   2. Move focused window to topic N (shift modifier)+-- >   [ ("M-" ++ m ++ k, f i)+-- >   | (i, k) <- zip (topicNames topicItems) (map show [1 .. 9 :: Int])+-- >   , (f, m) <- [(goto, ""), (windows . W.shift, "S-")]+-- >   ]+--+-- This makes @M-1@ to @M-9@ switch to the first nine topics that we+-- have specified in @topicItems@.+--+-- You can also switch to the nine last-used topics instead:+--+-- >   [ ("M-" ++ show i, switchNthLastFocused myTopicConfig i)+-- >   | i <- [1 .. 9]+-- >   ]+--+-- We can now put the whole configuration together with the following:+-- -- > main :: IO ()--- > main = xmonad =<< myConfig+-- > main = xmonad $ def+-- >   { workspaces = topicNames topicItems+-- >   }+-- >  `additionalKeysP` myKeys  -- | An alias for @flip replicateM_@ (>*>) :: Monad m => m a -> Int -> m ()@@ -187,81 +239,79 @@ -- | 'Topic' is just an alias for 'WorkspaceId' type Topic = WorkspaceId --- | 'Dir' is just an alias for 'FilePath' but should points to a directory.+-- | 'Dir' is just an alias for 'FilePath', but should point to a directory. type Dir = FilePath  -- | Here is the topic space configuration area.-data TopicConfig = TopicConfig { topicDirs          :: M.Map Topic Dir-                                 -- ^ This mapping associate a directory to each topic.-                               , topicActions       :: M.Map Topic (X ())-                                 -- ^ This mapping associate an action to trigger when+data TopicConfig = TopicConfig { topicDirs          :: Map Topic Dir+                                 -- ^ This mapping associates a directory to each topic.+                               , topicActions       :: Map Topic (X ())+                                 -- ^ This mapping associates an action to trigger when                                  -- switching to a given topic which workspace is empty.                                , defaultTopicAction :: Topic -> X ()                                  -- ^ This is the default topic action.                                , defaultTopic       :: Topic-                                 -- ^ This is the default topic.+                                 -- ^ This is the default (= fallback) topic.                                , maxTopicHistory    :: Int-                                 -- ^ This setups the maximum depth of topic history, usually-                                 -- 10 is a good default since we can bind all of them using-                                 -- numeric keypad.+                                 -- ^ This specifies the maximum depth of the topic history;+                                 -- usually 10 is a good default since we can bind all of+                                 -- them using numeric keypad.                                }--defaultTopicConfig :: TopicConfig-defaultTopicConfig = TopicConfig { topicDirs = M.empty-                                 , topicActions = M.empty-                                 , defaultTopicAction = const (ask >>= spawn . terminal . config)-                                 , defaultTopic = "1"-                                 , maxTopicHistory = 10-                                 }+{-# DEPRECATED maxTopicHistory "This field will be removed in the future; history is now handled by XMonad.Hooks.WorkspaceHistory" #-} -newtype PrevTopics = PrevTopics { getPrevTopics :: [String] } deriving (Read,Show,Typeable)-instance ExtensionClass PrevTopics where-    initialValue = PrevTopics []-    extensionType = PersistentExtension+instance Default TopicConfig where+  def            = TopicConfig { topicDirs = M.empty+                               , topicActions = M.empty+                               , defaultTopicAction = const (ask >>= spawn . terminal . config)+                               , defaultTopic = "1"+                               , maxTopicHistory = 10+                               } --- | Returns the list of last focused workspaces the empty list otherwise.-getLastFocusedTopics :: X [String]-getLastFocusedTopics = XS.gets getPrevTopics+-- | Return the (possibly empty) list of last focused topics.+getLastFocusedTopics :: X [Topic]+getLastFocusedTopics = workspaceHistory+{-# DEPRECATED getLastFocusedTopics "Use XMonad.Hooks.WorkspaceHistory.workspaceHistory (re-exported by this module) instead" #-} --- | Given a 'TopicConfig', the last focused topic, and a predicate that will--- select topics that one want to keep, this function will set the property--- of last focused topics.-setLastFocusedTopic :: Topic -> (Topic -> Bool) -> X ()-setLastFocusedTopic w predicate =-  XS.modify $ PrevTopics-    . seqList . nub . (w:) . filter predicate-    . getPrevTopics-  where seqList xs = length xs `seq` xs+-- | Given a 'TopicConfig', a topic, and a predicate to select topics that one+-- wants to keep, this function will cons the topic in front of the list of+-- last focused topics and filter it according to the predicate.  Note that we+-- prune the list in case that its length exceeds 'maxTopicHistory'.+setLastFocusedTopic :: TopicConfig -> Topic -> (Topic -> Bool) -> X ()+setLastFocusedTopic tc w predicate = do+  sid <- gets $ W.screen . W.current . windowset+  workspaceHistoryModify $+    take (maxTopicHistory tc) . nub . filter (predicate . snd) . ((sid, w) :)+{-# DEPRECATED setLastFocusedTopic "Use XMonad.Hooks.WorkspaceHistory instead" #-}  -- | Reverse the list of "last focused topics" reverseLastFocusedTopics :: X ()-reverseLastFocusedTopics =-  XS.modify $ PrevTopics . reverse . getPrevTopics+reverseLastFocusedTopics = workspaceHistoryModify reverse --- | This function is a variant of 'DL.pprWindowSet' which takes a topic configuration--- and a pretty-printing record 'PP'. It will show the list of topics sorted historically--- and highlighting topics with urgent windows.+-- | This function is a variant of 'SBPP.pprWindowSet' which takes a topic+-- configuration and a pretty-printing record 'PP'. It will show the list of+-- topics sorted historically and highlight topics with urgent windows. pprWindowSet :: TopicConfig -> PP -> X String pprWindowSet tg pp = do-    winset <- gets windowset-    urgents <- readUrgents-    let empty_workspaces = map W.tag $ filter (isNothing . W.stack) $ W.workspaces winset-        maxDepth = maxTopicHistory tg-    setLastFocusedTopic (W.tag . W.workspace . W.current $ winset)-                        (`notElem` empty_workspaces)-    lastWs <- getLastFocusedTopics-    let depth topic = fromJust $ elemIndex topic (lastWs ++ [topic])-        add_depth proj topic = proj pp . (((topic++":")++) . show) . depth $ topic-        pp' = pp { ppHidden = add_depth ppHidden, ppVisible = add_depth ppVisible }-        sortWindows = take maxDepth . sortBy (comparing $ depth . W.tag)-    return $ DL.pprWindowSet sortWindows urgents pp' winset+  winset <- gets windowset+  urgents <- readUrgents+  let empty_workspaces = map W.tag $ filter (isNothing . W.stack) $ W.workspaces winset+      maxDepth = maxTopicHistory tg+  setLastFocusedTopic tg+                      (W.tag . W.workspace . W.current $ winset)+                      (`notElem` empty_workspaces)+  lastWs <- workspaceHistory+  let depth topic = fromJust $ elemIndex topic (lastWs ++ [topic])+      add_depth proj topic = proj pp . (((topic++":")++) . show) . depth $ topic+      pp' = pp { ppHidden = add_depth ppHidden, ppVisible = add_depth ppVisible }+      sortWindows = take maxDepth . sortOn (depth . W.tag)+  return $ SBPP.pprWindowSet sortWindows urgents pp' winset --- | Given a prompt configuration and a topic configuration, triggers the action associated with+-- | Given a prompt configuration and a topic configuration, trigger the action associated with -- the topic given in prompt. topicActionWithPrompt :: XPConfig -> TopicConfig -> X ()-topicActionWithPrompt xp tg = workspacePrompt xp (liftM2 (>>) (switchTopic tg) (topicAction tg))+topicActionWithPrompt xp tg = workspacePrompt xp (liftA2 (>>) (switchTopic tg) (topicAction tg)) --- | Given a configuration and a topic, triggers the action associated with the given topic.+-- | Given a configuration and a topic, trigger the action associated with the given topic. topicAction :: TopicConfig -> Topic -> X () topicAction tg topic = fromMaybe (defaultTopicAction tg topic) $ M.lookup topic $ topicActions tg @@ -271,46 +321,94 @@  -- | Switch to the given topic. switchTopic :: TopicConfig -> Topic -> X ()-switchTopic tg topic = do+switchTopic tc topic = do+  -- Switch to topic and add it to the last seen topics   windows $ W.greedyView topic++  -- If applicable, execute the topic action   wins <- gets (W.integrate' . W.stack . W.workspace . W.current . windowset)-  when (null wins) $ topicAction tg topic+  when (null wins) $ topicAction tc topic --- | Switch to the Nth last focused topic or failback to the 'defaultTopic'.+-- | Switch to the Nth last focused topic or fall back to the 'defaultTopic'. switchNthLastFocused :: TopicConfig -> Int -> X ()-switchNthLastFocused tg depth = do-  lastWs <- getLastFocusedTopics-  switchTopic tg $ (lastWs ++ repeat (defaultTopic tg)) !! depth+switchNthLastFocused = switchNthLastFocusedExclude [] --- | Shift the focused window to the Nth last focused topic, or fallback to doing nothing.+-- | Like 'switchNthLastFocused', but also filter out certain topics.+switchNthLastFocusedExclude :: [Topic] -> TopicConfig -> Int -> X ()+switchNthLastFocusedExclude excludes tc depth = do+  lastWs <- filter (`notElem` excludes) <$> workspaceHistory+  switchTopic tc $ (lastWs ++ repeat (defaultTopic tc)) !! depth++-- | Like 'switchNthLastFocused', but only consider topics that used to+-- be on the current screen.+--+-- For example, the following function allows one to toggle between the+-- currently focused and the last used topic, while treating different+-- screens completely independently from one another.+--+-- > toggleTopicScreen = switchNthLastFocusedByScreen myTopicConfig 1+switchNthLastFocusedByScreen :: TopicConfig -> Int -> X ()+switchNthLastFocusedByScreen tc depth = do+  sid <- gets $ W.screen . W.current . windowset+  sws <- fromMaybe []+       . listToMaybe+       . map snd+       . filter ((== sid) . fst)+     <$> workspaceHistoryByScreen+  switchTopic tc $ (sws ++ repeat (defaultTopic tc)) !! depth++-- | Shift the focused window to the Nth last focused topic, or fall back to doing nothing. shiftNthLastFocused :: Int -> X () shiftNthLastFocused n = do-  ws <- fmap (listToMaybe . drop n) getLastFocusedTopics+  ws <- fmap (listToMaybe . drop n) workspaceHistory   whenJust ws $ windows . W.shift --- | Returns the directory associated with current topic returns the empty string otherwise.-currentTopicDir :: TopicConfig -> X String+-- | Return the directory associated with the current topic, or return the empty+-- string if the topic could not be found.+currentTopicDir :: TopicConfig -> X FilePath currentTopicDir tg = do   topic <- gets (W.tag . W.workspace . W.current . windowset)   return . fromMaybe "" . M.lookup topic $ topicDirs tg --- | Check the given topic configuration for duplicates topics or undefined topics.+-- | Check the given topic configuration for duplicate or undefined topics. checkTopicConfig :: [Topic] -> TopicConfig -> IO () checkTopicConfig tags tg = do-    -- tags <- gets $ map W.tag . workspaces . windowset+  -- tags <- gets $ map W.tag . workspaces . windowset -    let-      seenTopics = nub $ sort $ M.keys (topicDirs tg) ++ M.keys (topicActions tg)-      dups       = tags \\ nub tags-      diffTopic  = seenTopics \\ sort tags-      check lst msg = unless (null lst) $ xmessage $ msg ++ " (tags): " ++ show lst+  let+    seenTopics = nub $ sort $ M.keys (topicDirs tg) ++ M.keys (topicActions tg)+    dups       = tags \\ nub tags+    diffTopic  = seenTopics \\ sort tags+    check lst msg = unless (null lst) $ xmessage $ msg ++ " (tags): " ++ show lst -    check diffTopic "Seen but missing topics/workspaces"-    check dups      "Duplicate topics/workspaces"+  check diffTopic "Seen but missing topics/workspaces"+  check dups      "Duplicate topics/workspaces" --- | Display the given message using the @xmessage@ program.-xmessage :: String -> IO ()-xmessage s = do-  h <- spawnPipe "xmessage -file -"-  hPutStr h s-  hClose h+-- | Convenience type for specifying topics.+data TopicItem = TI+  { tiName   :: !Topic  -- ^ 'Topic' ≡ 'String'+  , tiDir    :: !Dir    -- ^ Directory associated with topic; 'Dir' ≡ 'String'+  , tiAction :: !(X ()) -- ^ Startup hook when topic is empty+  }++-- | Extract the names from a given list of 'TopicItem's.+topicNames :: [TopicItem] -> [Topic]+topicNames = map tiName++-- | From a list of 'TopicItem's, build a map that can be supplied as+-- the 'topicDirs'.+tiDirs :: [TopicItem] -> Map Topic Dir+tiDirs = M.fromList . map (\TI{ tiName, tiDir } -> (tiName, tiDir))++-- | From a list of 'TopicItem's, build a map that can be supplied as+-- the 'topicActions'.+tiActions :: [TopicItem] -> Map Topic (X ())+tiActions = M.fromList . map (\TI{ tiName, tiAction } -> (tiName, tiAction))++-- | Associate a directory with the topic, but don't spawn anything.+noAction :: Topic -> Dir -> TopicItem+noAction n d = TI n d (pure ())++-- | Topic with @tiDir = ~/@.+inHome :: Topic -> X () -> TopicItem+inHome n = TI n "."
+ XMonad/Actions/TreeSelect.hs view
@@ -0,0 +1,677 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.TreeSelect+-- Description :  Display workspaces or actions in a tree-like format.+-- Copyright   :  (c) Tom Smeets <tom.tsmeets@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Tom Smeets <tom.tsmeets@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+--+-- TreeSelect displays your workspaces or actions in a Tree-like format.+-- You can select the desired workspace/action with the cursor or hjkl keys.+--+-- This module is fully configurable and very useful if you like to have a+-- lot of workspaces.+--+-- Only the nodes up to the currently selected are displayed.+-- This will be configurable in the near future by changing 'ts_hidechildren' to @False@, this is not yet implemented.+--+-- <<https://wiki.haskell.org/wikiupload/thumb/0/0b/Treeselect-Workspace.png/800px-Treeselect-Workspace.png>>+--+-----------------------------------------------------------------------------+module XMonad.Actions.TreeSelect+    (+      -- * Usage+      -- $usage+      treeselectWorkspace+    , toWorkspaces+    , treeselectAction++      -- * Configuring+      -- $config+    , Pixel+      -- $pixel++    , TSConfig(..)+    , tsDefaultConfig+    , def++      -- * Navigation+      -- $navigation+    , defaultNavigation+    , select+    , cancel+    , moveParent+    , moveChild+    , moveNext+    , movePrev+    , moveHistBack+    , moveHistForward+    , moveTo++      -- * Advanced usage+      -- $advusage+    , TSNode(..)+    , treeselect+    , treeselectAt+    ) where++import Control.Monad.Reader+import Control.Monad.State+import Data.Tree+import Foreign (shiftL, shiftR, (.&.))+import System.IO+import XMonad hiding (liftX)+import XMonad.Prelude+import XMonad.StackSet as W+import XMonad.Util.Font+import XMonad.Util.NamedWindows+import XMonad.Util.TreeZipper+import XMonad.Hooks.WorkspaceHistory+import qualified Data.Map as M++#ifdef XFT+import qualified Data.List.NonEmpty as NE+import Graphics.X11.Xrender+import Graphics.X11.Xft+#endif++-- $usage+--+-- These imports are used in the following example+--+-- > import Data.Tree+-- > import XMonad.Actions.TreeSelect+-- > import XMonad.Hooks.WorkspaceHistory+-- > import qualified XMonad.StackSet as W+--+-- For selecting Workspaces, you need to define them in a tree structure using 'Data.Tree.Node' instead of just a standard list+--+-- Here is an example workspace-tree+--+-- > myWorkspaces :: Forest String+-- > myWorkspaces = [ Node "Browser" [] -- a workspace for your browser+-- >                , Node "Home"       -- for everyday activity's+-- >                    [ Node "1" []   --  with 4 extra sub-workspaces, for even more activity's+-- >                    , Node "2" []+-- >                    , Node "3" []+-- >                    , Node "4" []+-- >                    ]+-- >                , Node "Programming" -- for all your programming needs+-- >                    [ Node "Haskell" []+-- >                    , Node "Docs"    [] -- documentation+-- >                    ]+-- >                ]+--+-- Then add it to your 'XMonad.Core.workspaces' using the 'toWorkspaces' function.+--+-- Optionally, if you add 'workspaceHistoryHook' to your 'logHook' you can use the \'o\' and \'i\' keys to select from previously-visited workspaces+--+-- > xmonad $ def { ...+-- >              , workspaces = toWorkspaces myWorkspaces+-- >              , logHook = workspaceHistoryHook+-- >              }+--+-- After that you still need to bind buttons to 'treeselectWorkspace' to start selecting a workspaces and moving windows+--+-- you could bind @Mod-f@ to switch workspace+--+-- >  , ((modMask, xK_f), treeselectWorkspace myTreeConf myWorkspaces W.greedyView)+--+-- and bind @Mod-Shift-f@ to moving the focused windows to a workspace+--+-- >  , ((modMask .|. shiftMask, xK_f), treeselectWorkspace myTreeConf myWorkspaces W.shift)++-- $config+-- The selection menu is very configurable, you can change the font, all colors and the sizes of the boxes.+--+-- The default config defined as 'def'+--+-- > def = TSConfig { ts_hidechildren = True+-- >                , ts_background   = 0xc0c0c0c0+-- >                , ts_font         = "xft:Sans-16"+-- >                , ts_node         = (0xff000000, 0xff50d0db)+-- >                , ts_nodealt      = (0xff000000, 0xff10b8d6)+-- >                , ts_highlight    = (0xffffffff, 0xffff0000)+-- >                , ts_extra        = 0xff000000+-- >                , ts_node_width   = 200+-- >                , ts_node_height  = 30+-- >                , ts_originX      = 0+-- >                , ts_originY      = 0+-- >                , ts_indent       = 80+-- >                , ts_navigate     = defaultNavigation+-- >                }++-- $pixel+--+-- The 'Pixel' Color format is in the form of @0xaarrggbb@+--+-- Note that transparency is only supported if you have a window compositor running like <https://github.com/chjj/compton compton>+--+-- Some Examples:+--+-- @+-- white       = 0xffffffff+-- black       = 0xff000000+-- red         = 0xffff0000+-- green       = 0xff00ff00+-- blue        = 0xff0000ff+-- transparent = 0x00000000+-- @++-- $navigation+--+-- Keybindings for navigations can also be modified+--+-- This is the definition of 'defaultNavigation'+--+-- > defaultNavigation :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a))+-- > defaultNavigation = M.fromList+-- >     [ ((0, xK_Escape), cancel)+-- >     , ((0, xK_Return), select)+-- >     , ((0, xK_space),  select)+-- >     , ((0, xK_Up),     movePrev)+-- >     , ((0, xK_Down),   moveNext)+-- >     , ((0, xK_Left),   moveParent)+-- >     , ((0, xK_Right),  moveChild)+-- >     , ((0, xK_k),      movePrev)+-- >     , ((0, xK_j),      moveNext)+-- >     , ((0, xK_h),      moveParent)+-- >     , ((0, xK_l),      moveChild)+-- >     , ((0, xK_o),      moveHistBack)+-- >     , ((0, xK_i),      moveHistForward)+-- >     ]++-- $advusage+-- This module can also be used to select any other action++-- | Extensive configuration for displaying the tree.+--+-- This class also has a 'Default' instance+data TSConfig a = TSConfig { ts_hidechildren :: Bool -- ^ when enabled, only the parents (and their first children) of the current node will be shown (This feature is not yet implemented!)+                           , ts_background :: Pixel -- ^ background color filling the entire screen.++                           , ts_font :: String -- ^ XMF font for drawing the node name extra text++                           , ts_node      :: (Pixel, Pixel) -- ^ node foreground (text) and background color when not selected+                           , ts_nodealt   :: (Pixel, Pixel) -- ^ every other node will use this color instead of 'ts_node'+                           , ts_highlight :: (Pixel, Pixel) -- ^ node foreground (text) and background color when selected++                           , ts_extra :: Pixel -- ^ extra text color++                           , ts_node_width   :: Int -- ^ node width in pixels+                           , ts_node_height  :: Int -- ^ node height in pixels+                           , ts_originX :: Int -- ^ tree X position on the screen in pixels+                           , ts_originY :: Int -- ^ tree Y position on the screen in pixels++                           , ts_indent :: Int -- ^ indentation amount for each level in pixels++                           , ts_navigate :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a)) -- ^ key bindings for navigating the tree+                           }++instance Default (TSConfig a) where+    def = TSConfig { ts_hidechildren = True+                   , ts_background   = 0xc0c0c0c0+                   , ts_font         = "xft:Sans-16"+                   , ts_node         = (0xff000000, 0xff50d0db)+                   , ts_nodealt      = (0xff000000, 0xff10b8d6)+                   , ts_highlight    = (0xffffffff, 0xffff0000)+                   , ts_extra        = 0xff000000+                   , ts_node_width   = 200+                   , ts_node_height  = 30+                   , ts_originX      = 0+                   , ts_originY      = 0+                   , ts_indent       = 80+                   , ts_navigate     = defaultNavigation+                   }++-- | Default navigation+--+-- * navigation using either arrow key or vi style hjkl+-- * Return or Space to confirm+-- * Escape or Backspace to cancel to+defaultNavigation :: M.Map (KeyMask, KeySym) (TreeSelect a (Maybe a))+defaultNavigation = M.fromList+    [ ((0, xK_Escape), cancel)+    , ((0, xK_Return), select)+    , ((0, xK_space),  select)+    , ((0, xK_Up),     movePrev)+    , ((0, xK_Down),   moveNext)+    , ((0, xK_Left),   moveParent)+    , ((0, xK_Right),  moveChild)+    , ((0, xK_k),      movePrev)+    , ((0, xK_j),      moveNext)+    , ((0, xK_h),      moveParent)+    , ((0, xK_l),      moveChild)+    , ((0, xK_o),      moveHistBack)+    , ((0, xK_i),      moveHistForward)+    ]++-- | Default configuration.+--+-- Using nice alternating blue nodes+tsDefaultConfig :: TSConfig a+tsDefaultConfig = def+{-# DEPRECATED tsDefaultConfig "Use def (from Data.Default, and re-exported by XMonad.Actions.TreeSelect) instead." #-}++-- | Tree Node With a name and extra text+data TSNode a = TSNode { tsn_name  :: String+                       , tsn_extra :: String -- ^ extra text, displayed next to the node name+                       , tsn_value :: a      -- ^ value to return when this node is selected+                       }++-- | State used by TreeSelect.+--+-- Contains all needed information such as the window, font and a zipper over the tree.+data TSState a = TSState { tss_tree     :: TreeZipper (TSNode a)+                         , tss_window   :: Window+                         , tss_display  :: Display+                         , tss_size     :: (Int, Int) -- ^ size of 'tz_window'+                         , tss_xfont    :: XMonadFont+                         , tss_gc       :: GC+                         , tss_visual   :: Visual+                         , tss_colormap :: Colormap+                         , tss_history  :: ([[String]], [[String]]) -- ^ history zipper, navigated with 'moveHistBack' and 'moveHistForward'+                         }++-- | State monad transformer using 'TSState'+newtype TreeSelect a b = TreeSelect { runTreeSelect :: ReaderT (TSConfig a) (StateT (TSState a) X) b }+    deriving (Monad, Applicative, Functor, MonadState (TSState a),  MonadReader (TSConfig a), MonadIO)++-- | Lift the 'X' action into the 'XMonad.Actions.TreeSelect.TreeSelect' monad+liftX :: X a -> TreeSelect b a+liftX = TreeSelect . lift . lift++-- | Run Treeselect with a given config and tree.+-- This can be used for selectiong anything+--+-- * for switching workspaces and moving windows use 'treeselectWorkspace'+-- * for selecting actions use 'treeselectAction'+treeselect :: TSConfig a         -- ^ config file+           -> Forest (TSNode a)  -- ^ a list of 'Data.Tree.Tree's to select from.+           -> X (Maybe a)+treeselect c t = treeselectAt c (fromForest t) []++-- | Same as 'treeselect' but ad a specific starting position+treeselectAt :: TSConfig a         -- ^ config file+             -> TreeZipper (TSNode a)  -- ^ tree structure with a cursor position (starting node)+             -> [[String]] -- ^ list of paths that can be navigated with 'moveHistBack' and 'moveHistForward' (bound to the 'o' and 'i' keys)+             -> X (Maybe a)+treeselectAt conf@TSConfig{..} zipper hist = withDisplay $ \display -> do+    -- create a window on the currently focused screen+    rootw <- asks theRoot+    Rectangle{..} <- gets $ screenRect . W.screenDetail . W.current . windowset++    Just vinfo <- liftIO $ matchVisualInfo display (defaultScreen display) 32 4++    colormap <- liftIO $ createColormap display rootw (visualInfo_visual vinfo) allocNone++    win <- liftIO $ allocaSetWindowAttributes $ \attributes -> do+        set_override_redirect attributes True+        set_colormap attributes colormap+        set_background_pixel attributes ts_background+        set_border_pixel attributes 0+        w <- createWindow display rootw rect_x rect_y rect_width rect_height 0 (visualInfo_depth vinfo) inputOutput (visualInfo_visual vinfo) (cWColormap .|. cWBorderPixel .|. cWBackPixel) attributes+        setClassHint display w (ClassHint "xmonad-tree_select" "xmonad")+        pure w++    liftIO $ do+        -- TODO: move below?+        -- make the window visible+        mapWindow display win++        -- listen to key and mouse button events+        selectInput display win (exposureMask .|. keyPressMask .|. buttonReleaseMask)++        -- TODO: enable mouse select?+        -- and mouse button 1+        grabButton display button1 anyModifier win True buttonReleaseMask grabModeAsync grabModeAsync none none++    -- grab the keyboard+    status <- liftIO $ grabKeyboard display win True grabModeAsync grabModeAsync currentTime++    r <- if status == grabSuccess+        then do+            -- load the XMF font+            gc <- liftIO $ createGC display win+            xfont <- initXMF ts_font++            -- run the treeselect Monad+            ret <- evalStateT (runReaderT (runTreeSelect (redraw >> navigate)) conf)+                TSState{ tss_tree     = zipper+                       , tss_window   = win+                       , tss_display  = display+                       , tss_xfont    = xfont+                       , tss_size     = (fromIntegral rect_width, fromIntegral rect_height)+                       , tss_gc       = gc+                       , tss_visual   = visualInfo_visual vinfo+                       , tss_colormap = colormap+                       , tss_history = ([], hist)+                       }++            -- release the XMF font+            releaseXMF xfont+            liftIO $ freeGC display gc+            return ret++        else return Nothing++    -- destroy the window+    liftIO $ do+        unmapWindow display win+        destroyWindow display win+        freeColormap display colormap+        -- Flush the output buffer and wait for all the events to be processed+        -- TODO: is this needed?+        sync display False+    return r++-- | Select a workspace and execute a \"view\" function from "XMonad.StackSet" on it.+treeselectWorkspace :: TSConfig WorkspaceId+                    -> Forest String -- ^ your tree of workspace-names+                    -> (WorkspaceId -> WindowSet -> WindowSet) -- ^ the \"view\" function.+                                                               -- Instances can be 'W.greedyView' for switching to a workspace+                                                               -- and/or 'W.shift' for moving the focused window to a selected workspace.+                                                               --+                                                               -- These actions can also be combined by doing+                                                               --+                                                               -- > \i -> W.greedyView i . W.shift i+                    -> X ()+treeselectWorkspace c xs f = do+    -- get all defined workspaces+    -- They have to be set with 'toWorkspaces'!+    ws <- gets (W.workspaces . windowset)++    -- check the 'XConfig.workspaces'+    if all (`elem` map tag ws) (toWorkspaces xs)+      then do+        -- convert the 'Forest WorkspaceId' to 'Forest (TSNode WorkspaceId)'+        wsf <- forMForest (mkPaths xs) $ \(n, i) -> maybe (return (TSNode n "Does not exist!" "")) (mkNode n) (find (\w -> i == tag w) ws)++        -- get the current workspace path+        me <- gets (W.tag . W.workspace . W.current . windowset)+        hist <- workspaceHistory+        treeselectAt c (fromJust $ followPath tsn_name (splitPath me) $ fromForest wsf) (map splitPath hist) >>= maybe (return ()) (windows . f)++      else liftIO $ do+        -- error!+        let msg = unlines $ [ "Please add:"+                            , "    workspaces = toWorkspaces myWorkspaces"+                            , "to your XMonad config!"+                            , ""+                            , "XConfig.workspaces: "+                            ] ++ map tag ws+        hPutStrLn stderr msg+        xmessage msg+        return ()+  where+    mkNode n w = do+        -- find the focused window's name on this workspace+        name <- maybe (return "") (fmap show . getName . W.focus) $ stack w+        return $ TSNode n name (tag w)++-- | Convert the workspace-tree to a flat list of paths such that XMonad can use them+--+-- The Nodes will be separated by a dot (\'.\') character+toWorkspaces :: Forest String -> [WorkspaceId]+toWorkspaces = map snd . concatMap flatten . mkPaths++mkPaths :: Forest String -> Forest (String, WorkspaceId)+mkPaths = map (\(Node n ns) -> Node (n, n) (map (f n) ns))+  where+    f pth (Node x xs) = let pth' = pth ++ '.' : x+                         in Node (x, pth') (map (f pth') xs)++splitPath :: WorkspaceId -> [String]+splitPath i = case break (== '.') i of+    (x,   []) -> [x]+    (x, _:xs) -> x : splitPath xs++-- | Select from a Tree of 'X' actions+--+-- <<https://wiki.haskell.org/wikiupload/thumb/9/9b/Treeselect-Action.png/800px-Treeselect-Action.png>>+--+-- Each of these actions have to be specified inside a 'TSNode'+--+-- Example+--+-- > treeselectAction myTreeConf+-- >    [ Node (TSNode "Hello"    "displays hello"      (spawn "xmessage hello!")) []+-- >    , Node (TSNode "Shutdown" "Poweroff the system" (spawn "shutdown")) []+-- >    , Node (TSNode "Brightness" "Sets screen brightness using xbacklight" (return ()))+-- >        [ Node (TSNode "Bright" "FULL POWER!!"            (spawn "xbacklight -set 100")) []+-- >        , Node (TSNode "Normal" "Normal Brightness (50%)" (spawn "xbacklight -set 50"))  []+-- >        , Node (TSNode "Dim"    "Quite dark"              (spawn "xbacklight -set 10"))  []+-- >        ]+-- >    ]+treeselectAction :: TSConfig (X a) -> Forest (TSNode (X a)) -> X ()+treeselectAction c xs = treeselect c xs >>= \case+    Just a  -> void a+    Nothing -> return ()++forMForest :: (Functor m, Applicative m, Monad m) => [Tree a] -> (a -> m b) -> m [Tree b]+forMForest x g = mapM (mapMTree g) x++mapMTree :: (Functor m, Applicative m, Monad m) => (a -> m b) -> Tree a -> m (Tree b)+mapMTree f (Node x xs) = Node <$> f x <*>  mapM (mapMTree f) xs+++-- | Quit returning the currently selected node+select :: TreeSelect a (Maybe a)+select = gets (Just . (tsn_value . cursor . tss_tree))++-- | Quit without returning anything+cancel :: TreeSelect a (Maybe a)+cancel = return Nothing++-- TODO: redraw only what is necessary.+-- Examples: redrawAboveCursor, redrawBelowCursor and redrawCursor++-- | Move the cursor to its parent node+moveParent :: TreeSelect a (Maybe a)+moveParent = moveWith parent >> redraw >> navigate++-- | Move the cursor one level down, highlighting its first child-node+moveChild :: TreeSelect a (Maybe a)+moveChild = moveWith children >> redraw >> navigate++-- | Move the cursor to the next child-node+moveNext :: TreeSelect a (Maybe a)+moveNext = moveWith nextChild >> redraw >> navigate++-- | Move the cursor to the previous child-node+movePrev :: TreeSelect a (Maybe a)+movePrev = moveWith previousChild >> redraw >> navigate++-- | Move backwards in history+moveHistBack :: TreeSelect a (Maybe a)+moveHistBack = do+    s <- get+    case tss_history s of+        (xs, a:y:ys) -> do+            put s{tss_history = (a:xs, y:ys)}+            moveTo y+        _ -> navigate++-- | Move forward in history+moveHistForward :: TreeSelect a (Maybe a)+moveHistForward = do+    s <- get+    case tss_history s of+        (x:xs, ys) -> do+            put s{tss_history = (xs, x:ys)}+            moveTo x+        _ -> navigate++-- | Move to a specific node+moveTo :: [String] -- ^ path, always starting from the top+       -> TreeSelect a (Maybe a)+moveTo i = moveWith (followPath tsn_name i . rootNode) >> redraw >> navigate++-- | Apply a transformation on the internal 'XMonad.Util.TreeZipper.TreeZipper'.+moveWith :: (TreeZipper (TSNode a) -> Maybe (TreeZipper (TSNode a))) -> TreeSelect a ()+moveWith f = do+    s <- get+    case f (tss_tree s) of+        -- TODO: redraw cursor only?+        Just t -> put s{ tss_tree = t }+        Nothing -> return ()++-- | wait for keys and run navigation+navigate :: TreeSelect a (Maybe a)+navigate = gets tss_display >>= \d -> join . liftIO . allocaXEvent $ \e -> do+    maskEvent d (exposureMask .|. keyPressMask .|. buttonReleaseMask .|. buttonPressMask) e++    ev <- getEvent e++    if | ev_event_type ev == keyPress -> do+           ks <- keycodeToKeysym d (ev_keycode ev) 0+           return $ do+               mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)+               f <- asks ts_navigate+               fromMaybe navigate $ M.lookup (mask, ks) f+       | ev_event_type ev == buttonPress -> do+           -- See XMonad.Prompt Note [Allow ButtonEvents]+           allowEvents d replayPointer currentTime+           return navigate+       | otherwise -> return navigate++-- | Request a full redraw+redraw :: TreeSelect a ()+redraw = do+    win <- gets tss_window+    dpy <- gets tss_display++    -- clear window+    -- TODO: not always needed!+    liftIO $ clearWindow dpy win++    t <- gets tss_tree+    _ <- drawLayers 0 0 (reverse $ (tz_before t, cursor t, tz_after t) : tz_parents t)+    return ()++drawLayers :: Int -- ^ indentation level+           -> Int -- ^ height+           -> [(Forest (TSNode a), TSNode a, Forest (TSNode a))] -- ^ node layers (from top to bottom!)+           -> TreeSelect a Int+drawLayers _ yl [] = return yl+drawLayers xl yl ((bs, c, as):xs) = do+    TSConfig{..} <- ask++    let nodeColor y = if odd y then ts_node else ts_nodealt++    -- draw nodes above+    forM_ (zip [yl ..] (reverse bs)) $ \(y, Node n _) ->+        drawNode xl y n (nodeColor y)+        -- drawLayers (xl + 1) (y + 1) ns+        -- TODO: draw rest? if not ts_hidechildren+        -- drawLayers (xl + 1) (y + 1) ns++    -- draw the current / parent node+    -- if this is the last (currently focused) we use the 'ts_highlight' color+    let current_level = yl + length bs+    drawNode xl current_level c $+        if null xs then ts_highlight+                   else nodeColor current_level++    l2 <- drawLayers (xl + 1) (current_level + 1) xs++    -- draw nodes below+    forM_ (zip [l2 ..] as) $ \(y, Node n _) ->+        drawNode xl y n (nodeColor y)+        -- TODO: draw rest? if not ts_hidechildren+        -- drawLayers (xl + 1) (y + 1) ns+    return (l2 + length as)+++-- | Draw a node at a given indentation and height level+drawNode :: Int -- ^ indentation level (not in pixels)+         -> Int -- ^ height level (not in pixels)+         -> TSNode a -- ^ node to draw+         -> (Pixel, Pixel) -- ^ node foreground (font) and background color+         -> TreeSelect a ()+drawNode ix iy TSNode{..} col = do+    TSConfig{..} <- ask+    window       <- gets tss_window+    display      <- gets tss_display+    font         <- gets tss_xfont+    gc           <- gets tss_gc+    colormap <- gets tss_colormap+    visual   <- gets tss_visual+    liftIO $ drawWinBox window display visual colormap gc font col tsn_name ts_extra tsn_extra+        (ix * ts_indent + ts_originX) (iy * ts_node_height + ts_originY)+        ts_node_width ts_node_height++    -- TODO: draw extra text (transparent background? or ts_background)+    -- drawWinBox window fnt col2 nodeH (scW-x) (mes) (x+nodeW) y 8++-- | Draw a simple box with text+drawWinBox :: Window -> Display -> Visual -> Colormap -> GC -> XMonadFont -> (Pixel, Pixel) -> String -> Pixel -> String -> Int -> Int -> Int -> Int -> IO ()+drawWinBox win display visual colormap gc font (fg, bg) text fg2 text2 x y w h = do+    -- draw box+    setForeground display gc bg+    fillRectangle display win gc (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)++    -- dreaw text+    drawStringXMF display win visual colormap gc font fg+        (fromIntegral $ x + 8)+        (fromIntegral $ y + h - 8)+        text++    -- dreaw extra text+    drawStringXMF display win visual colormap gc font fg2+        (fromIntegral $ x + w + 8)+        (fromIntegral $ y + h - 8)+        text2++-- | Modified version of 'XMonad.Util.Font.printStringXMF' that uses 'Pixel' as color format+drawStringXMF :: Display -> Drawable -> Visual -> Colormap -> GC+              -> XMonadFont -- ^ XMF Font+              -> Pixel -- ^ font color+              -> Position   -- ^ x-position+              -> Position   -- ^ y-position+              -> String -- ^ string text+              -> IO ()+drawStringXMF display window visual colormap gc font col x y text = case font of+    Core fnt -> do+        setForeground display gc col+        setFont display gc $ fontFromFontStruct fnt+        drawImageString display window gc x y text+    Utf8 fnt -> do+        setForeground display gc col+        wcDrawImageString display window fnt gc x y text+#ifdef XFT+    Xft fnts -> do+        withXftDraw display window visual colormap $+            \ft_draw -> withXftColorValue display visual colormap (fromARGB col) $+#if MIN_VERSION_X11_xft(0, 3, 4)+            \ft_color -> xftDrawStringFallback ft_draw ft_color (NE.toList fnts) (fi x) (fi y) text+#else+            \ft_color -> xftDrawString ft_draw ft_color (NE.head fnts) x y text+#endif++-- | Convert 'Pixel' to 'XRenderColor'+--+-- Note that it uses short to represent its components+fromARGB :: Pixel -> XRenderColor+fromARGB x =+#if MIN_VERSION_X11_xft(0, 3, 3)+    XRenderColor r g b a+#else+    -- swapped green/blue as a workaround for the faulty Storable instance in X11-xft < 0.3.3+    XRenderColor r b g a+#endif+  where+    r = fromIntegral $ 0xff00 .&. shiftR x 8+    g = fromIntegral $ 0xff00 .&. x+    b = fromIntegral $ 0xff00 .&. shiftL x 8+    a = fromIntegral $ 0xff00 .&. shiftR x 16+#endif
+ XMonad/Actions/UpKeys.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}+{- |+   Module      : XMonad.Actions.UpKeys+   Description : Bind an action to the release of a key+   Copyright   : (c) Tony Zorman, 2024+   License     : BSD-3+   Maintainer  : Tony Zorman <soliditsallgood@mailbox.org>++A combinator for binding an action to the release of a key. This can be+useful for hold-type buttons, where the press of a key engages some+functionality, and its release… releases it again.+-}+module XMonad.Actions.UpKeys+  ( -- * Usage+    -- $usage+    useUpKeys,+    UpKeysConfig (..),+    ezUpKeys,+  )+where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import XMonad+import XMonad.Prelude+import XMonad.Util.EZConfig (mkKeymap)+import qualified XMonad.Util.ExtensibleConf as XC++{- $usage+You can use this module with the following in your @xmonad.hs@:++> import XMonad.Actions.UpKeys++Next, define the keys and actions you want to have happen on the release+of a key:++> myUpKeys = ezUpKeys $+>   [ ("M-z", myAction)+>   , ("M-a", myAction2)+>   ]++All that's left is to plug this definition into the 'useUpKeys'+combinator that this module provides:++> main :: IO ()+> main = xmonad+>      . useUpKeys (def{ grabKeys = True, upKeys = myUpKeys })+>      $ myConfig++Note the presence of @'grabKeys' = True@; this is for situations where+you don't have any of these keys bound to do something upon pressing+them; i.e., you use them solely for their release actions. If you want+something to happen in both cases, remove that part (@'grabKeys' =+False@ is the default) and bind the keys to actions as you normally+would.++==== __Examples__++As an extended example, consider the case where you want all of your+docks (e.g., status bar) to "pop up" when you press the super key, and+then vanish again once that keys is released.++Since docks are not generally part of XMonad's window-set—otherwise, we+would have to manage them—we first need a way to access and manipulate+all docks.++> onAllDocks :: (Display -> Window -> IO ()) -> X ()+> onAllDocks act = withDisplay \dpy -> do+>   rootw <- asks theRoot+>   (_, _, wins) <- io $ queryTree dpy rootw+>   traverse_ (io . act dpy) =<< filterM (runQuery checkDock) wins++This is also the place where one could filter for just status bar,+trayer, and so on.++Now we have to decide what kinds of keys we want to watch out for. Since+you most likely use left super as your modifier key, this is a little+bit more complicated than for other keys, as you will most likely see+the key both as a @KeyMask@, as well as a @KeySym@. One could think a+bit and probably come up with an elegant solution for this—or one could+grab all possible key combinations by brute-force!++> dockKeys :: X () -> [((KeyMask, KeySym), X ())]+> dockKeys act = map (actKey . foldr1 (.|.)) . combinations $ keyMasks+>  where+>   actKey :: KeyMask -> ((KeyMask, KeySym), X ())+>   actKey mask = ((mask, xK_Super_L), act)+>+>   keyMasks :: [KeyMask]+>   keyMasks = [ noModMask, shiftMask, lockMask, controlMask, mod1Mask, mod2Mask, mod3Mask, mod4Mask, mod5Mask ]+>+>   -- Return all combinations of a sequence of values.+>   combinations :: [a] -> [[a]]+>   combinations xs = concat [combs i xs | i <- [1 .. length xs]]+>    where+>     combs 0 _      = [[]]+>     combs _ []     = []+>     combs n (x:xs) = map (x:) (combs (n-1) xs) <> combs n xs++Given some action, like lowering or raising the window, we generate all+possible combinations of modifiers that may be pressed with the super+key. This is a good time to say that this is just for demonstrative+purposes, btw—please don't actually do this.++All that's left is to plug everything into the machinery of this module,+and we're done!++> import qualified Data.Map.Strict as Map+>+> main :: IO ()+> main = xmonad+>      . … -- other combinators+>      . useUpKeys (def { upKeys = Map.fromList $ dockKeys (onAllDocks lowerWindow) })+>      $ myConfig `additionalKeys` dockKeys (onAllDocks raiseWindow)+>+> myConfig = …+-}++data UpKeysConfig = UpKeysConfig+  { -- | Whether to grab all keys that are not already grabbed.+    grabKeys :: !Bool+    -- | The keys themselves.+  , upKeys :: !(Map (KeyMask, KeySym) (X ()))+  }++-- | The default 'UpKeysConfig'; keys are not grabbed, and no upkeys are+-- specified.+instance Default UpKeysConfig where+  def :: UpKeysConfig+  def = UpKeysConfig { grabKeys = False, upKeys = mempty }++instance Semigroup UpKeysConfig where+  (<>) :: UpKeysConfig -> UpKeysConfig -> UpKeysConfig+  UpKeysConfig g u <> UpKeysConfig g' u' = UpKeysConfig (g && g') (u <> u')++-- | Bind actions to keys upon their release.+useUpKeys :: UpKeysConfig -> (XConfig l -> XConfig l)+useUpKeys upKeysConf = flip XC.once upKeysConf \conf -> conf+  { handleEventHook = handleEventHook conf <> (\e -> handleKeyUp e $> All True)+  , startupHook     = startupHook     conf <> when (grabKeys upKeysConf) grabUpKeys+  }+ where+  grabUpKeys :: X ()+  grabUpKeys = do+    XConf{ display = dpy, theRoot = rootw } <- ask+    realKeys <- maybe mempty upKeys <$> XC.ask @X @UpKeysConfig+    let grab :: (KeyMask, KeyCode) -> X ()+        grab (km, kc) = io $ grabKey dpy kc km rootw True grabModeAsync grabModeAsync+    traverse_ grab =<< mkGrabs (Map.keys realKeys)++-- | Parse the given EZConfig-style keys into the internal keymap+-- representation.+--+-- This is just 'mkKeymap' with a better name.+ezUpKeys :: XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())+ezUpKeys = mkKeymap++-- | A handler for key-up events.+handleKeyUp :: Event -> X ()+handleKeyUp KeyEvent{ ev_event_type, ev_state, ev_keycode }+  | ev_event_type == keyRelease = withDisplay \dpy -> do+      s   <- io $ keycodeToKeysym dpy ev_keycode 0+      cln <- cleanMask ev_state+      ks  <- maybe mempty upKeys <$> XC.ask @X @UpKeysConfig+      userCodeDef () $ whenJust (ks Map.!? (cln, s)) id+handleKeyUp _ = pure ()
XMonad/Actions/UpdateFocus.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.UpdateFocus+-- Description :  Updates the focus on mouse move in unfocused windows. -- Copyright   :  (c) Daniel Schoepe -- License     :  BSD3-style (see LICENSE) --@@ -16,20 +17,20 @@     -- * Usage     -- $usage     focusOnMouseMove,-    adjustEventInput+    adjustEventInput,+    focusUnderPointer, ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W-import Control.Monad (when)-import Data.Monoid  -- $usage -- To make the focus update on mouse movement within an unfocused window, add the--- following to your @~\/.xmonad\/xmonad.hs@:+-- following to your @xmonad.hs@: -- -- > import XMonad.Actions.UpdateFocus--- > xmonad $ defaultConfig {+-- > xmonad $ def { -- >   .. -- >   startupHook = adjustEventInput -- >   handleEventHook = focusOnMouseMove@@ -40,7 +41,7 @@  -- | Changes the focus if the mouse is moved within an unfocused window. focusOnMouseMove :: Event -> X All-focusOnMouseMove (MotionEvent { ev_x = x, ev_y = y, ev_window = root }) = do+focusOnMouseMove MotionEvent{ ev_x = x, ev_y = y, ev_window = root } = do     -- check only every 15 px to avoid excessive calls to translateCoordinates     when (x `mod` 15 == 0 || y `mod` 15 == 0) $ do       dpy <- asks display@@ -58,3 +59,25 @@   io $ selectInput dpy rootw $  substructureRedirectMask .|. substructureNotifyMask                                 .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask                                 .|. buttonPressMask .|. pointerMotionMask++-- | Focus the window under the mouse pointer, unless we're currently changing+-- focus with the mouse or dragging. This is the inverse to+-- "XMonad.Actions.UpdatePointer": instead of moving the mouse pointer to+-- match the focus, we change the focus to match the mouse pointer.+--+-- This is meant to be used together with+-- 'XMonad.Actions.UpdatePointer.updatePointer' in individual key bindings.+-- Bindings that change focus should invoke+-- 'XMonad.Actions.UpdatePointer.updatePointer' at the end, bindings that+-- switch workspaces or change layouts should call 'focusUnderPointer' at the+-- end. Neither should go to 'logHook', as that would override the other.+--+-- This is more finicky to set up than 'focusOnMouseMove', but ensures that+-- focus is updated immediately, without having to touch the mouse.+focusUnderPointer :: X ()+focusUnderPointer = whenX (not <$> (asks mouseFocused <||> gets (isJust . dragging))) $ do+  dpy <- asks display+  root <- asks theRoot+  (_, _, w', _, _, _, _, _) <- io $ queryPointer dpy root+  w <- gets (W.peek . windowset)+  when (w' /= none && Just w' /= w) (focus w')
XMonad/Actions/UpdatePointer.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonadContrib.UpdatePointer--- Copyright   :  (c) Robert Marlow <robreim@bobturf.org>+-- Description :  Causes the pointer to follow whichever window focus changes to.+-- Copyright   :  (c) Robert Marlow <robreim@bobturf.org>, 2015 Evgeny Kurnevsky -- License     :  BSD3-style (see LICENSE) -- -- Maintainer  :  Robert Marlow <robreim@bobturf.org>@@ -19,87 +21,94 @@      -- * Usage      -- $usage      updatePointer-     , PointerPosition (..)     )     where  import XMonad-import XMonad.Util.XUtils (fi)-import Control.Monad+import XMonad.Prelude import XMonad.StackSet (member, peek, screenDetail, current)-import Data.Maybe +import Control.Arrow ((&&&), (***))+ -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Actions.UpdatePointer ----- Enable it by including it in your logHook definition. Eg:------ > logHook = updatePointer Nearest+-- Enable it by including it in your logHook definition, e.g.: ----- which will move the pointer to the nearest point of a newly focused window, or+-- > logHook = updatePointer (0.5, 0.5) (1, 1) ----- > logHook = updatePointer (Relative 0.5 0.5)+-- which will move the pointer to the nearest point of a newly focused+-- window. The first argument establishes a reference point within the+-- newly-focused window, while the second argument linearly interpolates+-- between said reference point and the edges of the newly-focused window to+-- obtain a bounding box for the pointer. ----- which will move the pointer to the center of a newly focused window.+-- > logHook = updatePointer (0.5, 0.5) (0, 0) -- exact centre of window+-- > logHook = updatePointer (0.25, 0.25) (0.25, 0.25) -- near the top-left+-- > logHook = updatePointer (0.5, 0.5) (1.1, 1.1) -- within 110% of the edge -- -- To use this with an existing logHook, use >> : -- -- > logHook = dynamicLog--- >           >> updatePointer (Relative 1 1)+-- >           >> updatePointer (1, 1) (0, 0) -- -- which moves the pointer to the bottom-right corner of the focused window. -data PointerPosition = Nearest | Relative Rational Rational | TowardsCentre Rational Rational-    deriving (Read,Show)- -- | Update the pointer's location to the currently focused -- window or empty screen unless it's already there, or unless the user was changing -- focus with the mouse-updatePointer :: PointerPosition -> X ()-updatePointer p = do+--+-- See also 'XMonad.Actions.UpdateFocus.focusUnderPointer' for an inverse+-- operation that updates the focus instead. The two can be combined in a+-- single config if neither goes into 'logHook' but are invoked explicitly in+-- individual key bindings.+updatePointer :: (Rational, Rational) -> (Rational, Rational) -> X ()+updatePointer refPos ratio = do   ws <- gets windowset   dpy <- asks display+  let defaultRect = screenRect $ screenDetail $ current ws   rect <- case peek ws of-        Nothing -> return $ (screenRect . screenDetail .current) ws-        Just w  -> windowAttributesToRectangle `fmap` io (getWindowAttributes dpy w)+        Nothing -> return defaultRect+        Just w  -> maybe defaultRect windowAttributesToRectangle+               <$> safeGetWindowAttributes w+   root <- asks theRoot   mouseIsMoving <- asks mouseFocused-  (_sameRoot,_,currentWindow,rootx,rooty,_,_,_) <- io $ queryPointer dpy root+  (_sameRoot,_,currentWindow,rootX,rootY,_,_,_) <- io $ queryPointer dpy root   drag <- gets dragging-  unless (pointWithin (fi rootx) (fi rooty) rect+  unless (pointWithin (fi rootX) (fi rootY) rect           || mouseIsMoving           || isJust drag-          || not (currentWindow `member` ws || currentWindow == none)) $-    case p of-    Nearest -> do-      let x = moveWithin (fi rootx) (rect_x rect) (fi (rect_x rect) + fi (rect_width  rect))-          y = moveWithin (fi rooty) (rect_y rect) (fi (rect_y rect) + fi (rect_height rect))-      io $ warpPointer dpy none root 0 0 0 0 x y-    TowardsCentre xfrc yfrc -> do-      let cx = fi (rect_width rect) / 2 + fi (rect_x rect)-          cy = fi (rect_height rect) / 2 + fi (rect_y rect)-          x,y,cx,cy :: Rational-          x = moveWithin (fi rootx) (fi $ rect_x rect) (fi (rect_x rect) + fi (rect_width  rect))-          y = moveWithin (fi rooty) (fi $ rect_y rect) (fi (rect_y rect) + fi (rect_height rect))-      io $ warpPointer dpy none root 0 0 0 0 (round $ x + xfrc*(cx-x)) (round $ y + yfrc*(cy-y))-    Relative h v ->-      io $ warpPointer dpy none root 0 0 0 0-           (rect_x rect + fraction h (rect_width rect))-           (rect_y rect + fraction v (rect_height rect))-        where fraction x y = floor (x * fromIntegral y)+          || not (currentWindow `member` ws || currentWindow == none)) $ let+    -- focused rectangle+    (rectX, rectY) = (rect_x &&& rect_y) rect+    (rectW, rectH) = (fi . rect_width &&& fi . rect_height) rect+    -- reference position, with (0,0) and (1,1) being top-left and bottom-right+    refX = lerp (fst refPos) rectX (rectX + rectW)+    refY = lerp (snd refPos) rectY (rectY + rectH)+    -- final pointer bounds, lerped *outwards* from reference position+    boundsX = join (***) (lerp (fst ratio) refX) (rectX, rectX + rectW)+    boundsY = join (***) (lerp (snd ratio) refY) (rectY, rectY + rectH)+    -- ideally we ought to move the pointer in a straight line towards the+    -- reference point until it is within the above bounds, but…+    in io $ warpPointer dpy none root 0 0 0 0+        (round . clip boundsX $ fi rootX)+        (round . clip boundsY $ fi rootY)  windowAttributesToRectangle :: WindowAttributes -> Rectangle windowAttributesToRectangle wa = Rectangle (fi (wa_x wa))                                            (fi (wa_y wa))                                            (fi (wa_width wa + 2 * wa_border_width wa))                                            (fi (wa_height wa + 2 * wa_border_width wa))-moveWithin :: Ord a => a -> a -> a -> a-moveWithin now lower upper =-    if now < lower-    then lower-    else if now > upper-         then upper-         else now++lerp :: (RealFrac r, Real a, Real b) => r -> a -> b -> r+lerp r a b = (1 - r) * realToFrac a + r * realToFrac b++clip :: Ord a => (a, a) -> a -> a+clip (lower, upper) x+  | x < lower = lower+  | x > upper = upper+  | otherwise = x
XMonad/Actions/Warp.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.Warp+-- Description :  Warp the pointer to a given window or screen. -- Copyright   :  (c) daniel@wagner-home.com -- License     :  BSD3-style (see LICENSE) --@@ -22,12 +23,12 @@                            warpToWindow                           ) where -import Data.List+import XMonad.Prelude import XMonad import XMonad.StackSet as W  {- $usage-You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+You can use this module with the following in your @xmonad.hs@:  > import XMonad.Actions.Warp @@ -44,7 +45,7 @@ -}  -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.   data Corner = UpperLeft | UpperRight | LowerLeft | LowerRight@@ -90,18 +91,16 @@ -- | Warp the pointer to a given position relative to the currently --   focused window.  Top left = (0,0), bottom right = (1,1). warpToWindow :: Rational -> Rational -> X ()-warpToWindow h v =-    withDisplay $ \d ->-        withFocused $ \w -> do-            wa <- io $ getWindowAttributes d w-            warp w (fraction h (wa_width wa)) (fraction v (wa_height wa))+warpToWindow h v = withDisplay $ \d -> withFocused $ \w ->+  withWindowAttributes d w $ \wa ->+    warp w (fraction h (wa_width wa)) (fraction v (wa_height wa))  -- | Warp the pointer to the given position (top left = (0,0), bottom --   right = (1,1)) on the given screen. warpToScreen :: ScreenId -> Rational -> Rational -> X () warpToScreen n h v = do     root <- asks theRoot-    (StackSet {current = x, visible = xs}) <- gets windowset+    StackSet{current = x, visible = xs} <- gets windowset     whenJust (fmap (screenRect . W.screenDetail) . find ((n==) . W.screen) $ x : xs)         $ \r ->             warp root (rect_x r + fraction h (rect_width  r))
XMonad/Actions/WindowBringer.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.WindowBringer+-- Description :  Dmenu operations to bring windows to you, and bring you to windows. -- Copyright   :  Devin Mullins <me@twifkak.com> -- License     :  BSD-style (see LICENSE) --@@ -17,24 +19,27 @@ module XMonad.Actions.WindowBringer (                     -- * Usage                     -- $usage-                    gotoMenu, gotoMenu', gotoMenuArgs, gotoMenuArgs',-                    bringMenu, bringMenu', bringMenuArgs, bringMenuArgs',-                    windowMap,-                    bringWindow+                    WindowBringerConfig(..),+                    gotoMenu, gotoMenuConfig, gotoMenu', gotoMenuArgs, gotoMenuArgs',+                    bringMenu, bringMenuConfig, bringMenu', bringMenuArgs, bringMenuArgs',+                    copyMenu, copyMenuConfig, copyMenu', copyMenuArgs, copyMenuArgs',+                    windowMap, windowAppMap, windowMap', bringWindow, actionMenu,+                    defaultDMenuArgs                    ) where -import Data.Char (toLower)+import Control.Monad import qualified Data.Map as M  import qualified XMonad.StackSet as W import XMonad import qualified XMonad as X import XMonad.Util.Dmenu (menuMapArgs)-import XMonad.Util.NamedWindows (getName)+import XMonad.Util.NamedWindows (getName, getNameWMClass)+import XMonad.Actions.CopyWindow (copyWindow)  -- $usage ----- Import the module into your @~\/.xmonad\/xmonad.hs@:+-- Import the module into your @xmonad.hs@: -- -- > import XMonad.Actions.WindowBringer --@@ -42,58 +47,117 @@ -- -- > , ((modm .|. shiftMask, xK_g     ), gotoMenu) -- > , ((modm .|. shiftMask, xK_b     ), bringMenu)+-- > , ((modm .|. shiftMask, xK_y     ), copyMenu) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. --- | Default menu command-defaultCmd :: String-defaultCmd = "dmenu"+-- | The default arguments passed to dmenu. You may want to use this with+--   the *MenuArgs functions.+defaultDMenuArgs :: [String]+defaultDMenuArgs = ["-i"] +data WindowBringerConfig = WindowBringerConfig+    { menuCommand :: String -- ^ The shell command that will handle window selection+    , menuArgs :: [String] -- ^ Arguments to be passed to menuCommand+    , windowTitler :: X.WindowSpace -> Window -> X String -- ^ A function that produces window titles given a workspace and a window+    , windowFilter :: Window -> X Bool -- ^ Filter function to decide which windows to consider+    }++instance Default WindowBringerConfig where+    def = WindowBringerConfig{ menuCommand = "dmenu"+                             , menuArgs = defaultDMenuArgs+                             , windowTitler = decorateName+                             , windowFilter = \_ -> return True+                             }+ -- | Pops open a dmenu with window titles. Choose one, and you will be --   taken to the corresponding workspace. gotoMenu :: X ()-gotoMenu = gotoMenuArgs []+gotoMenu = gotoMenuConfig def  -- | Pops open a dmenu with window titles. Choose one, and you will be+--   taken to the corresponding workspace. This version accepts a configuration+--   object.+gotoMenuConfig :: WindowBringerConfig -> X ()+gotoMenuConfig wbConfig = actionMenu wbConfig W.focusWindow++-- | Pops open a dmenu with window titles. Choose one, and you will be --   taken to the corresponding workspace. This version takes a list of --   arguments to pass to dmenu. gotoMenuArgs :: [String] -> X ()-gotoMenuArgs menuArgs = gotoMenuArgs' defaultCmd menuArgs+gotoMenuArgs args = gotoMenuConfig def { menuArgs = args }  -- | Pops open an application with window titles given over stdin. Choose one, --   and you will be taken to the corresponding workspace. gotoMenu' :: String -> X ()-gotoMenu' menuCmd = gotoMenuArgs' menuCmd []+gotoMenu' cmd = gotoMenuConfig def { menuArgs = [], menuCommand = cmd }  -- | Pops open an application with window titles given over stdin. Choose one, --   and you will be taken to the corresponding workspace. This version takes a --   list of arguments to pass to dmenu. gotoMenuArgs' :: String -> [String] -> X ()-gotoMenuArgs' menuCmd menuArgs = actionMenu menuCmd menuArgs W.focusWindow+gotoMenuArgs' cmd args = gotoMenuConfig def { menuCommand = cmd, menuArgs = args } +-- | Pops open a dmenu with window titles. Choose one, and it will be copied into your current workspace.+copyMenu :: X ()+copyMenu = copyMenuArgs defaultDMenuArgs+ -- | Pops open a dmenu with window titles. Choose one, and it will be+--   copied into your current workspace. This version+--   accepts a configuration object.+copyMenuConfig :: WindowBringerConfig -> X ()+copyMenuConfig wbConfig = actionMenu wbConfig copyBringWindow++-- | Pops open a dmenu with window titles. Choose one, and it will be+--   copied into your current workspace. This version+--   takes a list of arguments to pass to dmenu.+copyMenuArgs :: [String] -> X ()+copyMenuArgs args = copyMenuConfig def { menuArgs = args }++-- | Pops open an application with window titles given over stdin. Choose one,+--   and it will be copied into your current workspace.+copyMenu' :: String -> X ()+copyMenu' cmd = copyMenuConfig def { menuArgs = [], menuCommand = cmd }++-- | Pops open an application with window titles given over stdin. Choose one,+--   and it will be copied into your current+--   workspace. This version allows arguments to the chooser to be specified.+copyMenuArgs' :: String -> [String] -> X ()+copyMenuArgs' cmd args = copyMenuConfig def { menuArgs = args, menuCommand = cmd }++-- | Brings a copy of the specified window into the current workspace.+copyBringWindow :: Window -> X.WindowSet -> X.WindowSet+copyBringWindow w ws = copyWindow w (W.currentTag ws) ws++-- | Pops open a dmenu with window titles. Choose one, and it will be --   dragged, kicking and screaming, into your current workspace. bringMenu :: X ()-bringMenu = bringMenuArgs []+bringMenu = bringMenuArgs defaultDMenuArgs  -- | Pops open a dmenu with window titles. Choose one, and it will be --   dragged, kicking and screaming, into your current workspace. This version+--   accepts a configuration object.+bringMenuConfig :: WindowBringerConfig -> X ()+bringMenuConfig wbConfig = actionMenu wbConfig bringWindow++-- | Pops open a dmenu with window titles. Choose one, and it will be+--   dragged, kicking and screaming, into your current workspace. This version --   takes a list of arguments to pass to dmenu. bringMenuArgs :: [String] -> X ()-bringMenuArgs menuArgs = bringMenuArgs' defaultCmd menuArgs+bringMenuArgs args = bringMenuConfig def { menuArgs = args }  -- | Pops open an application with window titles given over stdin. Choose one, --   and it will be dragged, kicking and screaming, into your current --   workspace. bringMenu' :: String -> X ()-bringMenu' menuCmd = bringMenuArgs' menuCmd []+bringMenu' cmd = bringMenuConfig def { menuArgs = [], menuCommand = cmd }  -- | Pops open an application with window titles given over stdin. Choose one, --   and it will be dragged, kicking and screaming, into your current --   workspace. This version allows arguments to the chooser to be specified. bringMenuArgs' :: String -> [String] -> X ()-bringMenuArgs' menuCmd menuArgs = actionMenu menuCmd menuArgs bringWindow+bringMenuArgs' cmd args = bringMenuConfig def { menuArgs = args, menuCommand = cmd }  -- | Brings the specified window into the current workspace. bringWindow :: Window -> X.WindowSet -> X.WindowSet@@ -101,25 +165,43 @@  -- | Calls dmenuMap to grab the appropriate Window, and hands it off to action --   if found.-actionMenu :: String -> [String] -> (Window -> X.WindowSet -> X.WindowSet) -> X ()-actionMenu menuCmd menuArgs action = windowMap >>= menuMapFunction >>= flip X.whenJust (windows . action)+actionMenu :: WindowBringerConfig -> (Window -> X.WindowSet -> X.WindowSet) -> X ()+actionMenu c@WindowBringerConfig{ menuCommand = cmd, menuArgs = args } action =+  windowMap' c >>= menuMapFunction >>= flip X.whenJust (windows . action)     where       menuMapFunction :: M.Map String a -> X (Maybe a)-      menuMapFunction selectionMap = menuMapArgs menuCmd menuArgs selectionMap+      menuMapFunction = menuMapArgs cmd args + -- | A map from window names to Windows. windowMap :: X (M.Map String Window)-windowMap = do-  ws <- gets X.windowset-  M.fromList `fmap` concat `fmap` mapM keyValuePairs (W.workspaces ws)- where keyValuePairs ws = mapM (keyValuePair ws) $ W.integrate' (W.stack ws)-       keyValuePair ws w = flip (,) w `fmap` decorateName ws w+windowMap = windowMap' def +-- | A map from application executable names to Windows.+windowAppMap :: X (M.Map String Window)+windowAppMap = windowMap' def { windowTitler = decorateAppName }++-- | A map from window names to Windows, given a windowTitler function.+windowMap' :: WindowBringerConfig -> X (M.Map String Window)+windowMap' WindowBringerConfig{ windowTitler = titler, windowFilter = include } = do+  windowSet <- gets X.windowset+  M.fromList . concat <$> mapM keyValuePairs (W.workspaces windowSet)+ where keyValuePairs ws = let wins = W.integrate' (W.stack ws)+                           in mapM (keyValuePair ws) =<< filterM include wins+       keyValuePair ws w = (, w) <$> titler ws w+ -- | Returns the window name as will be listed in dmenu.---   Lowercased, for your convenience (since dmenu is case-sensitive). --   Tagged with the workspace ID, to guarantee uniqueness, and to let the user --   know where he's going. decorateName :: X.WindowSpace -> Window -> X String decorateName ws w = do-  name <- fmap (map toLower . show) $ getName w+  name <- show <$> getName w+  return $ name ++ " [" ++ W.tag ws ++ "]"++-- | Returns the window name as will be listed in dmenu.  This will+-- return the executable name of the window along with its workspace+-- ID.+decorateAppName :: X.WindowSpace -> Window -> X String+decorateAppName ws w = do+  name <- show <$> getNameWMClass w   return $ name ++ " [" ++ W.tag ws ++ "]"
XMonad/Actions/WindowGo.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE ViewPatterns #-}+ {- | Module      :  XMonad.Actions.WindowGo+Description :  Operations for raising (traveling to) windows. License     :  Public domain  Maintainer  :  <gwern0@gmail.com>@@ -21,6 +24,7 @@                  runOrRaiseNext,                  raiseMaybe,                  raiseNextMaybe,+                 raiseNextMaybeCustomFocus,                   raiseBrowser,                  raiseEditor,@@ -35,19 +39,20 @@                  module XMonad.ManageHook                 ) where -import Control.Monad-import Data.Char (toLower)-import Data.Monoid-import XMonad (Query(), X(), ManageHook, withWindowSet, runQuery, liftIO, ask)+import qualified Data.List as L (nub,sortBy)+import XMonad.Prelude+import XMonad (Query(), X(), ManageHook, WindowSet, withWindowSet, runQuery, liftIO, ask) import Graphics.X11 (Window) import XMonad.ManageHook import XMonad.Operations (windows) import XMonad.Prompt.Shell (getBrowser, getEditor)-import qualified XMonad.StackSet as W (allWindows, peek, swapMaster, focusWindow)+import qualified XMonad.StackSet as W (peek, swapMaster, focusWindow, workspaces, StackSet, Workspace, integrate', tag, stack) import XMonad.Util.Run (safeSpawnProg)+import qualified Data.List.NonEmpty as NE+ {- $usage -Import the module into your @~\/.xmonad\/xmonad.hs@:+Import the module into your @xmonad.hs@:  > import XMonad.Actions.WindowGo @@ -63,14 +68,23 @@ > (className =? "Firefox" <||> className =? "Firefox-bin")  For detailed instructions on editing your key bindings, see-"XMonad.Doc.Extending#Editing_key_bindings". -}+<https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.+-} +-- | Get the list of workspaces sorted by their tag+workspacesSorted :: Ord i => W.StackSet i l a s sd -> [W.Workspace i l a]+workspacesSorted s = L.sortBy (\u t -> W.tag u `compare` W.tag t) $ W.workspaces s++-- | Get a list of all windows in the 'StackSet' with an absolute ordering of workspaces+allWindowsSorted :: Ord i => Eq a => W.StackSet i l a s sd -> [a]+allWindowsSorted = L.nub . concatMap (W.integrate' . W.stack) . workspacesSorted+ -- | If windows that satisfy the query exist, apply the supplied -- function to them, otherwise run the action given as -- second parameter. ifWindows :: Query Bool -> ([Window] -> X ()) -> X () -> X () ifWindows qry f el = withWindowSet $ \wins -> do-  matches <- filterM (runQuery qry) $ W.allWindows wins+  matches <- filterM (runQuery qry) $ allWindowsSorted wins   case matches of     [] -> el     ws -> f ws@@ -78,7 +92,10 @@ -- | The same as ifWindows, but applies a ManageHook to the first match -- instead and discards the other matches ifWindow :: Query Bool -> ManageHook -> X () -> X ()-ifWindow qry mh = ifWindows qry (windows . appEndo <=< runQuery mh . head)+ifWindow qry mh = ifWindows qry (windows . appEndo <=< runQuery mh . NE.head . notEmpty)+-- ifWindows guarantees that the list given to the function is+-- non-empty. This should really use Data.List.NonEmpty, but, alas,+-- that would be a breaking change.  {- | 'action' is an executable to be run via 'safeSpawnProg' (of "XMonad.Util.Run") if the Window cannot be found.    Presumably this executable is the same one that you were looking for.@@ -137,16 +154,24 @@      'raiseNextMaybe' is an alternative version that allows cycling      through the matching windows. If the focused window matches the      query the next matching window is raised. If no matches are found-     the function f is executed.--}-+     the function f is executed. -} raiseNextMaybe :: X () -> Query Bool -> X ()-raiseNextMaybe f qry = flip (ifWindows qry) f $ \ws -> do+raiseNextMaybe = raiseNextMaybeCustomFocus W.focusWindow++{- | See 'raiseMaybe' and 'raiseNextMaybe'.+     In addition to all of the options offered by 'raiseNextMaybe'+     'raiseNextMaybeCustomFocus' allows the user to supply the function that+     should be used to shift the focus to any window that is found. -}+raiseNextMaybeCustomFocus :: (Window -> WindowSet -> WindowSet) -> X() -> Query Bool -> X()+raiseNextMaybeCustomFocus focusFn f qry = flip (ifWindows qry) f $ \ws -> do   foc <- withWindowSet $ return . W.peek   case foc of-    Just w | w `elem` ws -> let (_:y:_) = dropWhile (/=w) $ cycle ws -- cannot fail to match-                            in windows $ W.focusWindow y-    _ -> windows . W.focusWindow . head $ ws+    Just w | w `elem` ws ->+        let (notEmpty -> _ :| (notEmpty -> y :| _)) = dropWhile (/=w) $ cycle ws+            -- cannot fail to match+        in windows $ focusFn y+    _ -> windows . focusFn . NE.head . notEmpty $ ws+         -- ws is non-empty by ifWindows's definition.  -- | Given a function which gets us a String, we try to raise a window with that classname, --   or we then interpret that String as a executable name.@@ -167,7 +192,8 @@ raiseAndDo f qry after = ifWindow qry (afterRaise `mappend` raiseHook) f     where afterRaise = ask >>= (>> idHook) . liftX . after -{- | If a window matching the second argument is found, the window is focused and the third argument is called;+{- | If a window matching the second argument is found, the window is focused and+     the third argument is called;      otherwise, the first argument is called. -} runOrRaiseAndDo :: String -> Query Bool -> (Window -> X ()) -> X () runOrRaiseAndDo = raiseAndDo . safeSpawnProg@@ -182,7 +208,6 @@ {- |  If the window is found the window is focused and set to master       otherwise, action is run. -      > runOrRaiseMaster "firefox" (className =? "Firefox"))-  -}+      > runOrRaiseMaster "firefox" (className =? "Firefox")) -} runOrRaiseMaster :: String -> Query Bool -> X () runOrRaiseMaster run query = runOrRaiseAndDo run query (\_ -> windows W.swapMaster)
XMonad/Actions/WindowMenu.hs view
@@ -1,6 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.WindowMenu+-- Description :  Display window management actions in the center of the focused window. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -28,12 +29,12 @@ import qualified XMonad.StackSet as W import XMonad.Actions.GridSelect import XMonad.Layout.Maximize-import XMonad.Layout.Minimize-import XMonad.Util.XUtils (fi)+import XMonad.Actions.Minimize+import XMonad.Prelude (fi)  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- >    import XMonad.Actions.WindowMenu --@@ -50,9 +51,9 @@                 else (nBC, fBC)  windowMenu :: X ()-windowMenu = withFocused $ \w -> do+windowMenu = withFocused $ \w -> withDisplay $ \d -> withWindowAttributes d w $ \wa -> do     tags <- asks (workspaces . config)-    Rectangle x y wh ht <- getSize w+    let Rectangle x y wh ht = getSize wa     Rectangle sx sy swh sht <- gets $ screenRect . W.screenDetail . W.current . windowset     let originFractX = (fi x - fi sx + fi wh / 2) / fi swh         originFractY = (fi y - fi sy + fi ht / 2) / fi sht@@ -68,12 +69,10 @@                     | tag <- tags ]     runSelectedAction gsConfig actions -getSize :: Window -> X (Rectangle)-getSize w = do-  d  <- asks display-  wa <- io $ getWindowAttributes d w+getSize :: WindowAttributes -> Rectangle+getSize wa =   let x = fi $ wa_x wa       y = fi $ wa_y wa       wh = fi $ wa_width wa       ht = fi $ wa_height wa-  return (Rectangle x y wh ht)+   in Rectangle x y wh ht
XMonad/Actions/WindowNavigation.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE TupleSections #-} -- I didn't want this, it's hlint's "suggestion" and it's apparently non-negotiable ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.WindowNavigation+-- Description :  Experimental rewrite of "XMonad.Layout.WindowNavigation". -- Copyright   :  (c) 2007  David Roundy <droundy@darcs.net>, --                          Devin Mullins <me@twifkak.com>--- Maintainer  :  Devin Mullins <me@twifkak.com>+-- Maintainer  :  Devin Mullins <me@twifkak.com>,+--                Platon Pronko <platon7pronko@gmail.com> -- License     :  BSD3-style (see LICENSE) -- Stability   :  unstable -- Portability :  unportable@@ -36,21 +39,20 @@                                        withWindowNavigationKeys,                                        WNAction(..),                                        go, swap,+                                       goPure, swapPure,                                        Direction2D(..), WNState,                                        ) where -import XMonad+import XMonad hiding (state)+import XMonad.Prelude (catMaybes, fromMaybe, sortOn) import XMonad.Util.Types (Direction2D(..)) import qualified XMonad.StackSet as W -import Control.Applicative ((<$>)) import Control.Arrow (second) import Data.IORef-import Data.List (sortBy) import Data.Map (Map())+import Data.List (partition, find) import qualified Data.Map as M-import Data.Maybe (catMaybes, fromMaybe, listToMaybe)-import Data.Ord (comparing) import qualified Data.Set as S  -- $usage@@ -62,9 +64,14 @@ -- -- > main = do -- >     config <- withWindowNavigation (xK_w, xK_a, xK_s, xK_d)--- >             $ defaultConfig { ... }+-- >             $ def { ... } -- >     xmonad config --+-- Or, for the brave souls:+--+-- > main = xmonad =<< withWindowNavigation (xK_w, xK_a, xK_s, xK_d)+-- >             $ def { ... }+-- -- Here, we pass in the keys for navigation in counter-clockwise order from up. -- It creates keybindings for @modMask@ to move to window, and @modMask .|. shiftMask@ -- to swap windows.@@ -98,118 +105,316 @@  withWindowNavigationKeys :: [((KeyMask, KeySym), WNAction)] -> XConfig l -> IO (XConfig l) withWindowNavigationKeys wnKeys conf = do-    posRef <- newIORef M.empty-    return conf { keys = \cnf -> M.fromList (map (second (fromWNAction posRef)) wnKeys)+    stateRef <- newIORef M.empty+    return conf { keys = \cnf -> M.fromList (map (second (fromWNAction stateRef)) wnKeys)                                  `M.union` keys conf cnf,-                  logHook = logHook conf >> trackMovement posRef }-  where fromWNAction posRef (WNGo dir)   = go   posRef dir-        fromWNAction posRef (WNSwap dir) = swap posRef dir+                  logHook = logHook conf >> trackMovement stateRef }+  where fromWNAction stateRef (WNGo dir)   = go   stateRef dir+        fromWNAction stateRef (WNSwap dir) = swap stateRef dir  data WNAction = WNGo Direction2D | WNSwap Direction2D  type WNState = Map WorkspaceId Point --- go:--- 1. get current position, verifying it matches the current window--- 2. get target windowrect--- 3. focus window--- 4. set new position+-- | Focus window in the given direction. go :: IORef WNState -> Direction2D -> X ()-go = withTargetWindow W.focusWindow+go stateRef dir = runPureAction stateRef (goPure dir) +-- | Swap current window with the window in the given direction.+-- Note: doesn't work with floating windows (don't think it makes much sense to swap floating windows). swap :: IORef WNState -> Direction2D -> X ()-swap = withTargetWindow swapWithFocused+swap stateRef dir = runPureAction stateRef (swapPure dir)++type WindowRectFn x = (Window -> x (Maybe Rectangle))+-- | (state, oldWindowSet, mappedWindows, windowRect)+type WNInput x = (WNState, WindowSet, S.Set Window, WindowRectFn x)+type WNOutput = (WNState, WindowSet)++-- | Run the pure action inside X monad.+runPureAction :: IORef WNState -> (WNInput X -> X WNOutput) -> X ()+runPureAction stateRef action = do+  oldState <- io (readIORef stateRef)+  oldWindowSet <- gets windowset+  mappedWindows <- gets mapped+  (newState, newWindowSet) <- action (oldState, oldWindowSet, mappedWindows, windowRectX)+  windows (const newWindowSet)+  io $ writeIORef stateRef newState++-- | Version of `go` not dependent on X monad (needed for testing).+goPure :: Monad x => Direction2D -> WNInput x -> x WNOutput+goPure dir input@(oldState, oldWindowSet, mappedWindows, _) =+  if length (filter (`S.member` mappedWindows) $ W.integrate' $ W.stack $ W.workspace $ W.current oldWindowSet) == 1+  then+    -- Handle the special case of Full layout, when there's only one mapped window on a screen.+    return ( oldState+           , case dir of+               U -> W.focusUp oldWindowSet+               L -> W.focusDown oldWindowSet+               D -> W.focusDown oldWindowSet+               R -> W.focusUp oldWindowSet+           )+  else+    withTargetWindow W.focusWindow dir input++-- | Version of `swap` not dependent on X monad (needed for testing).+swapPure :: Monad x => Direction2D -> WNInput x -> x WNOutput+swapPure = withTargetWindow swapWithFocused   where swapWithFocused targetWin winSet =             case W.peek winSet of                 Just currentWin -> W.focusWindow currentWin $                                    mapWindows (swapWin currentWin targetWin) winSet                 Nothing -> winSet-        mapWindows f ss = W.mapWorkspace (mapWindows' f) ss-        mapWindows' f ws@(W.Workspace { W.stack = s }) = ws { W.stack = mapWindows'' f <$> s }+        mapWindows f = W.mapWorkspace (mapWindows' f)+        mapWindows' f ws@W.Workspace{ W.stack = s } = ws { W.stack = mapWindows'' f <$> s }         mapWindows'' f (W.Stack focused up down) = W.Stack (f focused) (map f up) (map f down)-        swapWin win1 win2 win = if win == win1 then win2 else if win == win2 then win1 else win+        swapWin win1 win2 win+          | win == win1 = win2+          | win == win2 = win1+          | otherwise = win -withTargetWindow :: (Window -> WindowSet -> WindowSet) -> IORef WNState -> Direction2D -> X ()-withTargetWindow adj posRef dir = fromCurrentPoint posRef $ \win pos -> do-    targets <- filter ((/= win) . fst) <$> navigableTargets pos dir-    whenJust (listToMaybe targets) $ \(targetWin, targetRect) -> do-      windows (adj targetWin)-      setPosition posRef pos targetRect+-- | Select a target window in the given direction and modify the WindowSet.+-- 1. Get current position, verifying it matches the current window (exit if no focused window).+-- 2. Get the target window.+-- 3. Execute an action on the target window and windowset.+-- 4. Set the new position.+withTargetWindow :: Monad x => (Window -> WindowSet -> WindowSet) -> Direction2D -> WNInput x -> x WNOutput+withTargetWindow adj dir input@(oldState, oldWindowSet, _, _) = do+  whenJust' (getCurrentWindow input) (oldState, oldWindowSet) $ \(win, winRect, pos) -> do+    targetMaybe <- find ((/= win) . fst) <$> navigableTargets input dir winRect pos+    whenJust' (pure targetMaybe) (oldState, oldWindowSet) $ \(targetWin, newPos) ->+      let newWindowSet = adj targetWin oldWindowSet+      in return (modifyState newWindowSet newPos oldState, newWindowSet) +-- | Update position on outside changes in windows. trackMovement :: IORef WNState -> X ()-trackMovement posRef = fromCurrentPoint posRef $ \win pos -> do-                           windowRect win >>= flip whenJust (setPosition posRef pos . snd)+trackMovement stateRef = do+  oldState <- io (readIORef stateRef)+  oldWindowSet <- gets windowset+  mappedWindows <- gets mapped+  whenJust' (getCurrentWindow (oldState, oldWindowSet, mappedWindows, windowRectX)) () $ \(_, _, pos) -> do+      io $ writeIORef stateRef $ modifyState oldWindowSet pos oldState -fromCurrentPoint :: IORef WNState -> (Window -> Point -> X ()) -> X ()-fromCurrentPoint posRef f = withFocused $ \win -> do-                                currentPosition posRef >>= f win+-- | Get focused window and current position.+getCurrentWindow :: Monad x => WNInput x -> x (Maybe (Window, Rectangle, Point))+getCurrentWindow input@(_, oldWindowSet, _, _) =+  whenJust' (pure $ W.peek oldWindowSet) Nothing $ \window -> do+    (pos, rect) <- currentPosition input+    return $ Just (window, rect, pos) --- Gets the current position from the IORef passed in, or if nothing (say, from--- a restart), derives the current position from the current window. Also,--- verifies that the position is congruent with the current window (say, if you--- used mod-j/k or mouse or something).-currentPosition :: IORef WNState -> X Point-currentPosition posRef = do-    root <- asks theRoot-    currentWindow <- gets (W.peek . windowset)-    currentRect <- maybe (Rectangle 0 0 0 0) snd <$> windowRect (fromMaybe root currentWindow)+-- | Gets the current position from the state passed in, or if nothing+-- (say, from a restart), derives the current position from the current window.+-- Also, verifies that the position is congruent with the current window+-- (say, if you moved focus using mouse or something).+-- Returns the window rectangle for convenience, since we'll need it later anyway.+currentPosition :: Monad x => WNInput x -> x (Point, Rectangle)+currentPosition (state, oldWindowSet, _, windowRect) = do+  currentRect <- fromMaybe (Rectangle 0 0 0 0) <$> maybe (pure Nothing) windowRect (W.peek oldWindowSet)+  let posMaybe = M.lookup (W.currentTag oldWindowSet) state+      middleOf (Rectangle x y w h) = Point (midPoint x w) (midPoint y h)+  return $ case posMaybe of+    Nothing -> (middleOf currentRect, currentRect)+    Just pos -> (centerPosition currentRect pos, currentRect) -    wsid <- gets (W.currentTag . windowset)-    mp <- M.lookup wsid <$> io (readIORef posRef)+-- | Inserts new position into the state.+modifyState :: WindowSet -> Point -> WNState -> WNState+modifyState oldWindowSet =+  M.insert (W.currentTag oldWindowSet) -    return $ maybe (middleOf currentRect) (`inside` currentRect) mp+-- | "Jumps" the current position into the middle of target rectangle.+-- (keeps the position as-is if it is already inside the target rectangle)+centerPosition :: Rectangle -> Point -> Point+centerPosition r@(Rectangle rx ry rw rh) pos@(Point x y) = do+  if pointWithin x y r+  then pos+  else Point (midPoint rx rw) (midPoint ry rh) -  where middleOf (Rectangle x y w h) = Point (midPoint x w) (midPoint y h)+midPoint :: Position -> Dimension -> Position+midPoint pos dim = pos + fromIntegral dim `div` 2 -setPosition :: IORef WNState -> Point -> Rectangle -> X ()-setPosition posRef oldPos newRect = do-    wsid <- gets (W.currentTag . windowset)-    io $ modifyIORef posRef $ M.insert wsid (oldPos `inside` newRect)+-- | Make a list of target windows we can navigate to,+-- sorted by desirability of navigation.+navigableTargets :: Monad x => WNInput x -> Direction2D -> Rectangle -> Point -> x [(Window, Point)]+navigableTargets input@(_, oldWindowSet, _, _) dir currentRect currentPos = do+  allScreensWindowsAndRectangles <- mapSnd (rectTransform dir) <$> windowRects input+  let+    screenWindows = S.fromList $ W.integrate' $ W.stack $ W.workspace $ W.current oldWindowSet+    (thisScreenWindowsAndRectangles, otherScreensWindowsAndRectangles) = partition (\(w, _) -> S.member w screenWindows) allScreensWindowsAndRectangles -inside :: Point -> Rectangle -> Point-Point x y `inside` Rectangle rx ry rw rh =-    Point (x `within` (rx, rw)) (y `within` (ry, rh))-  where pos `within` (lower, dim) = if pos >= lower && pos < lower + fromIntegral dim-                                    then pos-                                    else midPoint lower dim+    pos = pointTransform dir currentPos+    wr = rectTransform dir currentRect -midPoint :: Position -> Dimension -> Position-midPoint pos dim = pos + fromIntegral dim `div` 2+    rectInside r = (rect_p1 r >= rect_p1 wr && rect_p1 r < rect_p2 wr && rect_p2 r > rect_p1 wr && rect_p2 r <= rect_p2 wr) &&+                   ((rect_o1 r >= rect_o1 wr && rect_o1 r < rect_o2 wr && rect_o2 r > rect_o1 wr && rect_o2 r <= rect_o2 wr) ||+                    (rect_o1 r <= rect_o1 wr && rect_o2 r >= rect_o2 wr)) -- include windows that fully overlaps current on the orthogonal axis+    sortByP2 = sortOn (rect_p2 . snd)+    posBeforeEdge r = point_p pos < rect_p2 r -navigableTargets :: Point -> Direction2D -> X [(Window, Rectangle)]-navigableTargets point dir = navigable dir point <$> windowRects+    rectOverlapsEdge r = rect_p1 r <= rect_p2 wr && rect_p2 r > rect_p2 wr &&+                         rect_o1 r < rect_o2 wr && rect_o2 r > rect_o1 wr+    rectOverlapsOneEdge r = rectOverlapsEdge r && rect_p1 r > rect_p1 wr+    rectOverlapsBothEdges r = rectOverlapsEdge r &&+                              rect_o1 r > rect_o1 wr && rect_o2 r < rect_o2 wr && point_o pos >= rect_o1 r && point_o pos < rect_o2 r+    distanceToRectEdge r = max (max 0 (rect_o1 r - point_o pos)) (max 0 (point_o pos + 1 - rect_o2 r))+    distanceToRectCenter r =+      let distance = (rect_o1 r + rect_o2 r) `div` 2 - point_o pos+      in if distance <= 0+         then distance + 1+         else distance+    sortByPosDistance = sortOn ((\r -> (rect_p1 r, distanceToRectEdge r, distanceToRectCenter r)) . snd) --- Filters and sorts the windows in terms of what is closest from the Point in--- the Direction2D.-navigable :: Direction2D -> Point -> [(Window, Rectangle)] -> [(Window, Rectangle)]-navigable d pt = sortby d . filter (inr d pt . snd)+    rectOutside r = rect_p1 r < rect_p1 wr && rect_p2 r > rect_p2 wr &&+                    rect_o1 r < rect_o1 wr && rect_o2 r > rect_o2 wr+    sortByLength = sortOn (rect_psize . snd) --- Produces a list of normal-state windows, on any screen. Rectangles are--- adjusted based on screen position relative to the current screen, because I'm--- bad like that.-windowRects :: X [(Window, Rectangle)]-windowRects = fmap catMaybes . mapM windowRect . S.toList =<< gets mapped+    rectAfterEdge r = rect_p1 r > rect_p2 wr -windowRect :: Window -> X (Maybe (Window, Rectangle))-windowRect win = withDisplay $ \dpy -> do+    -- Modified from David Roundy and Devin Mullins original implementation of WindowNavigation:+    inr r = point_p pos < rect_p2 r && point_o pos >= rect_o1 r && point_o pos < rect_o2 r++    clamp v v1 v2 | v < v1 = v1+                  | v >= v2 = v2 - 1+                  | otherwise = v+    dragPos r = DirPoint (max (point_p pos) (rect_p1 r)) (clamp (point_o pos) (rect_o1 r) (rect_o2 r))++  return $ mapSnd (inversePointTransform dir) $ concat+    [+      -- First, navigate to windows that are fully inside current window+      -- and have higher coordinate bigger than current position.+      -- ┌──────────────────┐+      -- │   current        │  (all examples assume direction=R)+      -- │    ┌──────────┐  │+      -- │  ──┼─► inside │  │+      -- │    └──────────┘  │+      -- └──────────────────┘+      -- Also include windows fully overlapping current on the orthogonal axis:+      --             ┌──────────────┐+      --             │ overlapping  │+      -- ┌───────────┤              ├────┐+      -- │ current ──┼─►            │    │+      -- └───────────┤              ├────┘+      --             └──────────────┘+      mapSnd dragPos $ sortByP2 $ filterSnd posBeforeEdge $ filterSnd rectInside thisScreenWindowsAndRectangles++      -- Then navigate to windows that touch or overlap the edge of current window in the chosen direction.+      -- ┌──────────────┬─────────────┐   ┌───────────┐                   ┌─────────────┐+      -- │ current      │ adjacent    │   │ current   │                   │ current     │+      -- │            ──┼─►           │   │       ┌───┴───────────────┐   │         ┌───┴─────────────┐+      -- │              │             │   │     ──┼─► │   overlapping │   │       ──┼─►               │+      -- │              ├─────────────┘   │       └───┬───────────────┘   └─────────┤     overlapping │+      -- │              │                 │           │                             │                 │+      -- └──────────────┘                 └───────────┘                             └─────────────────┘+    , mapSnd dragPos $ sortByPosDistance $ filterSnd rectOverlapsOneEdge thisScreenWindowsAndRectangles++      -- Windows fully overlapping current window "in the middle" on the parallel axis are also included,+      -- if position is inside them:+      --     ┌───────────┐+      --     │  current  │+      -- ┌───┤-----------├────────────────┐+      -- │   │     *   ──┼─►  overlapping │+      -- └───┤-----------├────────────────┘+      --     └───────────┘+    , mapSnd (\_ -> DirPoint (rect_p2 wr) (point_o pos)) $ sortByPosDistance $ filterSnd rectOverlapsBothEdges thisScreenWindowsAndRectangles++      -- Then navigate to windows that fully encompass the current window.+      -- ┌─────────────────────┐+      -- │    outer            │+      -- │  ┌─────────────┐    │+      -- │  │  current  ──┼─►  │+      -- │  └─────────────┘    │+      -- └─────────────────────┘+    , mapSnd (\_ -> DirPoint (rect_p2 wr) (point_o pos)) $ sortByLength $ filterSnd rectOutside thisScreenWindowsAndRectangles++      -- Then navigate to windows that are fully after current window in the chosen direction.+      -- ┌──────────────┐+      -- │ current      │  ┌────────────────┐+      -- │              │  │                │+      -- │            ──┼──┼─► not adjacent │+      -- │              │  │                │+      -- │              │  └────────────────┘+      -- └──────────────┘+    , mapSnd dragPos $ sortByPosDistance $ filterSnd rectAfterEdge thisScreenWindowsAndRectangles++      -- Cast a ray from the current position, jump to the first window (on another screen) that intersects this ray.+    , mapSnd dragPos $ sortByPosDistance $ filterSnd inr otherScreensWindowsAndRectangles++      -- If everything else fails, then navigate to the window that is fully inside current window,+      -- but is before the current position.+      -- This can happen when we are at the last window on a screen, and attempt to navigate even further.+      -- In this case it seems okay to jump to the remaining inner windows, since we don't have any other choice anyway,+      -- and user is probably not so fully aware of the precise position anyway.+    , mapSnd (\r -> DirPoint (rect_p2 r - 1) (clamp (point_o pos) (rect_o1 r) (rect_o2 r))) $+      sortByP2 $ filterSnd (not . posBeforeEdge) $ filterSnd rectInside thisScreenWindowsAndRectangles+    ]++-- Structs for direction-independent space - equivalent to rotating points and rectangles such that+-- navigation direction points to the right.+-- Allows us to abstract over direction in the navigation functions.+data DirPoint = DirPoint+  { point_p :: Position -- coordinate parallel to the direction+  , point_o :: Position -- coordinate orthogonal to the direction+  }+data DirRectangle = DirRectangle+  { rect_p1 :: Position -- lower rectangle coordinate parallel to the direction+  , rect_p2 :: Position -- higher rectangle coordinate parallel to the direction+  , rect_o1 :: Position -- lower rectangle coordinate orthogonal to the direction+  , rect_o2 :: Position -- higher rectangle coordinate orthogonal to the direction+  }+{- HLINT ignore "Use camelCase" -}+rect_psize :: DirRectangle -> Dimension+rect_psize r = fromIntegral (rect_p2 r - rect_p1 r)++-- | Transform a point from screen space into direction-independent space.+pointTransform :: Direction2D -> Point -> DirPoint+pointTransform dir (Point x y) = case dir of+  U -> DirPoint (negate y - 1) x+  L -> DirPoint (negate x - 1) (negate y - 1)+  D -> DirPoint y (negate x - 1)+  R -> DirPoint x y++-- | Transform a point from direction-independent space back into screen space.+inversePointTransform :: Direction2D -> DirPoint -> Point+inversePointTransform dir p = case dir of+  U -> Point (point_o p) (negate $ point_p p + 1)+  L -> Point (negate $ point_p p + 1) (negate $ point_o p + 1)+  D -> Point (negate $ point_o p + 1) (point_p p)+  R -> Point (point_p p) (point_o p)++-- | Transform a rectangle from screen space into direction-independent space.+rectTransform :: Direction2D -> Rectangle -> DirRectangle+rectTransform dir (Rectangle x y w h) = case dir of+  U -> DirRectangle (negate $ y + fromIntegral h) (negate y) x (x + fromIntegral w)+  L -> DirRectangle (negate $ x + fromIntegral w) (negate x) (negate $ y + fromIntegral h) (negate y)+  D -> DirRectangle y (y + fromIntegral h) (negate $ x + fromIntegral w) (negate x)+  R -> DirRectangle x (x + fromIntegral w) y (y + fromIntegral h)++-- | Produces a list of normal-state windows on all screens, excluding currently focused window.+windowRects :: Monad x => WNInput x -> x [(Window, Rectangle)]+windowRects (_, oldWindowSet, mappedWindows, windowRect) =+  let+    allWindows = filter (\w -> w `notElem` W.peek oldWindowSet) $ S.toList mappedWindows+    windowRect2 w = fmap (w,) <$> windowRect w+  in catMaybes <$> mapM windowRect2 allWindows++windowRectX :: Window -> X (Maybe Rectangle)+windowRectX win = withDisplay $ \dpy -> do     (_, x, y, w, h, bw, _) <- io $ getGeometry dpy win-    return $ Just $ (win, Rectangle x y (w + 2 * bw) (h + 2 * bw))+    return $ Just $ Rectangle x y (w + 2 * bw) (h + 2 * bw)     `catchX` return Nothing --- Modified from droundy's implementation of WindowNavigation:+-- Maybe below functions can be replaced with some standard helper functions? -inr :: Direction2D -> Point -> Rectangle -> Bool-inr D (Point px py) (Rectangle rx ry w h) = px >= rx && px < rx + fromIntegral w &&-                                                        py < ry + fromIntegral h-inr U (Point px py) (Rectangle rx ry w _) = px >= rx && px < rx + fromIntegral w &&-                                            py >  ry-inr R (Point px py) (Rectangle rx ry _ h) = px <  rx &&-                                            py >= ry && py < ry + fromIntegral h-inr L (Point px py) (Rectangle rx ry w h) =             px > rx + fromIntegral w &&-                                            py >= ry && py < ry + fromIntegral h+-- | Execute a monadic action on the contents if Just, otherwise wrap default value and return it.+whenJust' :: Monad x => x (Maybe a) -> b -> (a -> x b) -> x b+whenJust' monadMaybeValue deflt f = do+  maybeValue <- monadMaybeValue+  case maybeValue of+    Nothing -> return deflt+    Just value -> f value -sortby :: Direction2D -> [(a,Rectangle)] -> [(a,Rectangle)]-sortby D = sortBy $ comparing (rect_y . snd)-sortby R = sortBy $ comparing (rect_x . snd)-sortby U = reverse . sortby D-sortby L = reverse . sortby R+-- | Filter a list of tuples on the second tuple member.+filterSnd :: (b -> Bool) -> [(a, b)] -> [(a, b)]+filterSnd f = filter (f . snd)++-- | Map a second tuple member in a list of tuples.+mapSnd :: (b -> b') -> [(a, b)] -> [(a, b')]+mapSnd f = map (second f)
XMonad/Actions/WithAll.hs view
@@ -1,28 +1,30 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.WithAll+-- Description  : Perform a given action on all or certain groups of windows. -- License      : BSD3-style (see LICENSE) -- Stability    : unstable -- Portability  : unportable ----- Provides functions for performing a given action on all windows of--- the current workspace.+-- Provides functions for performing a given action on all or certain+-- groups of windows on the current workspace. -----------------------------------------------------------------------------  module XMonad.Actions.WithAll (     -- * Usage     -- $usage     sinkAll, withAll,-    withAll', killAll) where+    withAll', killAll,+    killOthers) where -import Data.Foldable hiding (foldr)+import XMonad.Prelude hiding (foldr)  import XMonad import XMonad.StackSet  -- $usage ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Actions.WithAll --@@ -31,7 +33,7 @@ --     , ((modm .|. shiftMask, xK_t), sinkAll) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Un-float all floating windows on the current workspace. sinkAll :: X ()@@ -50,3 +52,7 @@ -- | Kill all the windows on the current workspace. killAll :: X() killAll = withAll killWindow++-- | Kill all the unfocused windows on the current workspace.+killOthers :: X ()+killOthers = withUnfocused killWindow
XMonad/Actions/Workscreen.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE ViewPatterns #-}+ ----------------------------------------------------------------------------- -- | -- Module     :  XMonad.Actions.Workscreen+-- Description:  Display a set of workspaces on several screens. -- Copyright  :  (c) 2012 kedals0 -- License    :  BSD3-style (see LICENSE) --@@ -20,7 +23,6 @@ -- This also permits to see all workspaces of a workscreen even if just -- one screen is present, and to move windows from workspace to workscreen. ------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-}  module XMonad.Actions.Workscreen (   -- * Usage@@ -31,15 +33,17 @@   ,shiftToWorkscreen   ,fromWorkspace   ,expandWorkspace+  ,WorkscreenId   ) where  import XMonad hiding (workspaces)+import XMonad.Prelude import qualified XMonad.StackSet as W import qualified XMonad.Util.ExtensibleState as XS import XMonad.Actions.OnScreen  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Actions.Workscreen -- > myWorkspaces = let myOldWorkspaces = ["adm","work","mail"]@@ -54,26 +58,26 @@ -- >      , (f, m) <- [(Workscreen.viewWorkscreen, 0), (Workscreen.shiftToWorkscreen, shiftMask)]] -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -data Workscreen = Workscreen{workscreenId::Int,workspaces::[WorkspaceId]} deriving (Show,Typeable)+data Workscreen = Workscreen{workscreenId::Int,workspaces::[WorkspaceId]} deriving (Show) type WorkscreenId=Int -data WorkscreenStorage = WorkscreenStorage WorkscreenId [Workscreen] deriving (Show,Typeable)+data WorkscreenStorage = WorkscreenStorage WorkscreenId [Workscreen] deriving (Show) instance ExtensionClass WorkscreenStorage where   initialValue = WorkscreenStorage 0 []  -- | Helper to group workspaces. Multiply workspace by screens number. expandWorkspace :: Int -> [WorkspaceId] -> [WorkspaceId]-expandWorkspace nscr ws = concat $ map expandId ws+expandWorkspace nscr = concatMap expandId   where expandId wsId = let t = wsId ++ "_"                         in map ((++) t . show ) [1..nscr]  -- | Create workscreen list from workspace list. Group workspaces to -- packets of screens number size. fromWorkspace :: Int -> [WorkspaceId] -> [Workscreen]-fromWorkspace n ws = map (\(a,b) -> Workscreen a b) $ zip [0..] (fromWorkspace' n ws)+fromWorkspace n ws = zipWith Workscreen [0..] (fromWorkspace' n ws) fromWorkspace' :: Int -> [WorkspaceId] -> [[WorkspaceId]] fromWorkspace' _ [] = [] fromWorkspace' n ws = take n ws : fromWorkspace' n (drop n ws)@@ -89,7 +93,7 @@                            let wscr = if wscrId == c                                           then Workscreen wscrId $ shiftWs (workspaces $ a !! wscrId)                                           else a !! wscrId-                               (x,_:ys) = splitAt wscrId a+                               (x, notEmpty -> _ :| ys) = splitAt wscrId a                                newWorkscreenStorage = WorkscreenStorage wscrId (x ++ [wscr] ++ ys)                            windows (viewWorkscreen' wscr)                            XS.put newWorkscreenStorage@@ -105,5 +109,6 @@ -- @WorkscreenId@. shiftToWorkscreen :: WorkscreenId -> X () shiftToWorkscreen wscrId = do (WorkscreenStorage _ a) <- XS.get-                              let ws = head . workspaces $ a !! wscrId-                              windows $ W.shift ws+                              case workspaces (a !! wscrId) of+                                []      -> pure ()+                                (w : _) -> windows $ W.shift w
XMonad/Actions/WorkspaceCursors.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Actions.WorkspaceCursors+-- Description  : Like "XMonad.Actions.Plane" for an arbitrary number of dimensions. -- Copyright    : (c) 2009 Adam Vogt <vogt.adam@gmail.com> -- License      : BSD --@@ -46,14 +47,10 @@ import XMonad.Actions.FocusNth(focusNth') import XMonad.Layout.LayoutModifier(ModifiedLayout(..),                                     LayoutModifier(handleMess, redoLayout))-import XMonad(Typeable, Message, WorkspaceId, X, XState(windowset),+import XMonad(Message, WorkspaceId, X, XState(windowset),               fromMessage, sendMessage, windows, gets)-import Control.Monad((<=<), guard, liftM, liftM2, when)-import Control.Applicative((<$>))-import Data.Foldable(Foldable(foldMap), toList)-import Data.Maybe(fromJust, listToMaybe)-import Data.Monoid(Monoid(mappend, mconcat))-import Data.Traversable(sequenceA)+import XMonad.Util.Stack (reverseS)+import XMonad.Prelude  -- $usage --@@ -61,16 +58,13 @@ -- -- > import XMonad -- > import XMonad.Actions.WorkspaceCursors--- > import XMonad.Hooks.DynamicLog -- > import XMonad.Util.EZConfig -- > import qualified XMonad.StackSet as W -- >--- > main = do--- >     x <- xmobar conf--- >     xmonad x+-- > main = xmonad conf -- >--- > conf = additionalKeysP defaultConfig--- >        { layoutHook = workspaceCursors myCursors $ layoutHook defaultConfig+-- > conf = additionalKeysP def+-- >        { layoutHook = workspaceCursors myCursors $ layoutHook def -- >        , workspaces = toList myCursors } $ -- >        [("M-"++shift++control++[k], f direction depth) -- >          | (f,shift) <- zip [modifyLayer,shiftModifyLayer] ["","S-"]@@ -92,7 +86,8 @@ --   workspaces. Or change it such that workspaces are created when you try to --   view it. ----- * Function for pretty printing for DynamicLog that groups workspaces by+-- * Function for pretty printing for "XMonad.Hooks.StatusBar.PP" that groups+--   workspaces by -- common prefixes -- -- * Examples of adding workspaces to the cursors, having them appear multiple@@ -100,10 +95,10 @@  -- | makeCursors requires a nonempty string, and each sublist must be nonempty makeCursors ::  [[String]] -> Cursors String-makeCursors [] = error "Workspace Cursors cannot be empty"-makeCursors a = concat . reverse <$> foldl addDim x xs-    where x = end $ map return $ head a-          xs = map (map return) $ tail a+makeCursors []       = error "Workspace Cursors cannot be empty"+makeCursors (a : as) = concat . reverse <$> foldl addDim x xs+    where x = end $ map return a+          xs = map (map return) as           -- this could probably be simplified, but this true:           -- toList . makeCursors == map (concat . reverse) . sequence . reverse . map (map (:[]))           -- the strange order is used because it makes the regular M-1..9@@ -118,7 +113,7 @@  data Cursors a     = Cons (W.Stack (Cursors a))-    | End a deriving (Eq,Show,Read,Typeable)+    | End a deriving (Eq,Show,Read)  instance Foldable Cursors where     foldMap f (End x) = f x@@ -144,7 +139,7 @@  -- This could be made more efficient, if the fact that the suffixes are grouped focusTo ::  (Eq t) => t -> Cursors t -> Maybe (Cursors t)-focusTo x = listToMaybe . filter ((x==) . getFocus) . changeFocus (const True)+focusTo x = find ((x==) . getFocus) . changeFocus (const True)  -- | non-wrapping version of 'W.focusUp'' noWrapUp ::  W.Stack t -> W.Stack t@@ -153,20 +148,19 @@  -- | non-wrapping version of 'W.focusDown'' noWrapDown ::  W.Stack t -> W.Stack t-noWrapDown = reverseStack . noWrapUp . reverseStack-    where reverseStack (W.Stack t ls rs) = W.Stack t rs ls+noWrapDown = reverseS . noWrapUp . reverseS  focusDepth ::  Cursors t -> Int focusDepth (Cons x) = 1 + focusDepth (W.focus x) focusDepth (End  _) = 0  descend :: Monad m =>(W.Stack (Cursors a) -> m (W.Stack (Cursors a)))-> Int-> Cursors a-> m (Cursors a)-descend f 1 (Cons x) = Cons `liftM` f x-descend f n (Cons x) | n > 1 = liftM Cons $ descend f (pred n) `onFocus` x+descend f 1 (Cons x) = Cons <$> f x+descend f n (Cons x) | n > 1 = fmap Cons $ descend f (pred n) `onFocus` x descend _ _ x = return x  onFocus :: (Monad m) => (a1 -> m a1) -> W.Stack a1 -> m (W.Stack a1)-onFocus f st = (\x -> st { W.focus = x}) `liftM` f (W.focus st)+onFocus f st = (\x -> st { W.focus = x}) <$> f (W.focus st)  -- | @modifyLayer@ is used to change the focus at a given depth modifyLayer :: (W.Stack (Cursors String) -> W.Stack (Cursors String)) -> Int -> X ()@@ -192,10 +186,10 @@ modifyLayer' f depth = modifyCursors (descend f depth)  modifyCursors ::  (Cursors String -> X (Cursors String)) -> X ()-modifyCursors = sendMessage . ChangeCursors . (liftM2 (>>) updateXMD return <=<)+modifyCursors = sendMessage . ChangeCursors . (liftA2 (>>) updateXMD return <=<) -data WorkspaceCursors a = WorkspaceCursors (Cursors String)-    deriving (Typeable,Read,Show)+newtype WorkspaceCursors a = WorkspaceCursors (Cursors String)+    deriving (Read,Show)  -- | The state is stored in the 'WorkspaceCursors' layout modifier. Put this as -- your outermost modifier, unless you want different cursors at different@@ -203,8 +197,7 @@ workspaceCursors :: Cursors String -> l a -> ModifiedLayout WorkspaceCursors l a workspaceCursors = ModifiedLayout . WorkspaceCursors -data ChangeCursors = ChangeCursors { unWrap :: Cursors String -> X (Cursors String) }-    deriving (Typeable)+newtype ChangeCursors = ChangeCursors { unWrap :: Cursors String -> X (Cursors String) }  instance Message ChangeCursors @@ -219,4 +212,4 @@         return (arrs,WorkspaceCursors <$> focusTo cws cs)      handleMess (WorkspaceCursors cs) m =-        sequenceA $ fmap WorkspaceCursors . ($ cs) . unWrap <$> fromMessage m+        traverse (fmap WorkspaceCursors . ($ cs) . unWrap) (fromMessage m)
XMonad/Actions/WorkspaceNames.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Actions.WorkspaceNames+-- Description :  Persistently rename workspace and swap them along with their names. -- Copyright   :  (c) Tomas Janousek <tomi@nomi.cz> -- License     :  BSD3-style (see LICENSE) --@@ -8,23 +9,23 @@ -- Stability   :  experimental -- Portability :  unportable ----- Provides bindings to rename workspaces, show these names in DynamicLog and+-- Provides bindings to rename workspaces, show these names in a status bar and -- swap workspaces along with their names. These names survive restart. -- Together with "XMonad.Layout.WorkspaceDir" this provides for a fully -- dynamic topic space workflow. -- ----------------------------------------------------------------------------- -{-# LANGUAGE DeriveDataTypeable #-}- module XMonad.Actions.WorkspaceNames (     -- * Usage     -- $usage      -- * Workspace naming     renameWorkspace,-    workspaceNamesPP,+    getWorkspaceNames',     getWorkspaceNames,+    getWorkspaceName,+    getCurrentWorkspaceName,     setWorkspaceName,     setCurrentWorkspaceName, @@ -32,36 +33,51 @@     swapTo,     swapTo',     swapWithCurrent,++    -- * Workspace prompt+    workspaceNamePrompt,++    -- * StatusBar, EwmhDesktops integration+    workspaceNamesPP,+    workspaceNamesEwmh,     ) where  import XMonad+import XMonad.Prelude (fromMaybe, isInfixOf, (<&>), (>=>)) import qualified XMonad.StackSet as W import qualified XMonad.Util.ExtensibleState as XS -import XMonad.Actions.CycleWS (findWorkspace, WSType(..), Direction1D(..))+import XMonad.Actions.CycleWS (findWorkspace, WSType(..), Direction1D(..), anyWS) import qualified XMonad.Actions.SwapWorkspaces as Swap-import XMonad.Hooks.DynamicLog (PP(..))-import XMonad.Prompt (mkXPrompt, XPConfig)+import XMonad.Hooks.StatusBar.PP (PP(..))+import XMonad.Hooks.EwmhDesktops (addEwmhWorkspaceRename)+import XMonad.Prompt (mkXPrompt, XPConfig, historyCompletionP) import XMonad.Prompt.Workspace (Wor(Wor)) import XMonad.Util.WorkspaceCompare (getSortByIndex)  import qualified Data.Map as M-import Data.Maybe (fromMaybe)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- > import XMonad.Actions.WorkspaceNames -- -- Then add keybindings like the following: ----- >   , ((modm .|. shiftMask, xK_r      ), renameWorkspace defaultXPConfig)+-- >   , ((modm .|. shiftMask, xK_r      ), renameWorkspace def) ----- and apply workspaceNamesPP to your DynamicLog pretty-printer:+-- and apply workspaceNamesPP to your pretty-printer: ----- > myLogHook =--- >     workspaceNamesPP xmobarPP >>= dynamicLogString >>= xmonadPropLog+-- > myPP = workspaceNamesPP xmobarPP --+-- Check "XMonad.Hooks.StatusBar" for more information on how to incorprate+-- this into your status bar.+--+-- To expose workspace names to pagers and other EWMH clients, integrate this+-- with "XMonad.Hooks.EwmhDesktops":+--+-- > main = xmonad $ … . workspaceNamesEwmh . ewmh . … $ def{…}+-- -- We also provide a modification of "XMonad.Actions.SwapWorkspaces"\'s -- functionality, which may be used this way: --@@ -72,27 +88,39 @@ -- >     | (i, k) <- zip workspaces [xK_1 ..]] -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.    -- | Workspace names container. newtype WorkspaceNames = WorkspaceNames (M.Map WorkspaceId String)-    deriving (Typeable, Read, Show)+    deriving (Read, Show)  instance ExtensionClass WorkspaceNames where     initialValue = WorkspaceNames M.empty     extensionType = PersistentExtension --- | Returns a function that maps workspace tag @\"t\"@ to @\"t:name\"@ for--- workspaces with a name, and to @\"t\"@ otherwise.-getWorkspaceNames :: X (WorkspaceId -> String)-getWorkspaceNames = do+-- | Returns a lookup function that maps workspace tags to workspace names.+getWorkspaceNames' :: X (WorkspaceId -> Maybe String)+getWorkspaceNames' = do     WorkspaceNames m <- XS.get-    return $ \wks -> case M.lookup wks m of-        Nothing -> wks-        Just s  -> wks ++ ":" ++ s+    return (`M.lookup` m) +-- | Returns a function for 'ppRename' that appends @sep@ and the workspace+-- name, if set.+getWorkspaceNames :: String -> X (String -> WindowSpace -> String)+getWorkspaceNames sep = ren <$> getWorkspaceNames'+  where+    ren name s w = s ++ maybe "" (sep ++) (name (W.tag w))++-- | Gets the name of a workspace, if set, otherwise returns nothing.+getWorkspaceName :: WorkspaceId -> X (Maybe String)+getWorkspaceName w = ($ w) <$> getWorkspaceNames'++-- | Gets the name of the current workspace. See 'getWorkspaceName'+getCurrentWorkspaceName :: X (Maybe String)+getCurrentWorkspaceName = getWorkspaceName =<< gets (W.currentTag . windowset)+ -- | Sets the name of a workspace. Empty string makes the workspace unnamed -- again. setWorkspaceName :: WorkspaceId -> String -> X ()@@ -110,26 +138,14 @@ -- | Prompt for a new name for the current workspace and set it. renameWorkspace :: XPConfig -> X () renameWorkspace conf = do-    mkXPrompt pr conf (const (return [])) setCurrentWorkspaceName-    where pr = Wor "Workspace name: "---- | Modify "XMonad.Hooks.DynamicLog"\'s pretty-printing format to show--- workspace names as well.-workspaceNamesPP :: PP -> X PP-workspaceNamesPP pp = do-    names <- getWorkspaceNames-    return $-        pp {-            ppCurrent         = ppCurrent         pp . names,-            ppVisible         = ppVisible         pp . names,-            ppHidden          = ppHidden          pp . names,-            ppHiddenNoWindows = ppHiddenNoWindows pp . names,-            ppUrgent          = ppUrgent          pp . names-        }+    completion <- historyCompletionP conf (prompt ==)+    mkXPrompt (Wor prompt) conf completion setCurrentWorkspaceName+  where+    prompt = "Workspace name: "  -- | See 'XMonad.Actions.SwapWorkspaces.swapTo'. This is the same with names. swapTo :: Direction1D -> X ()-swapTo dir = swapTo' dir AnyWS+swapTo dir = swapTo' dir anyWS  -- | Swap with the previous or next workspace of the given type. swapTo' :: Direction1D -> WSType -> X ()@@ -149,4 +165,27 @@     WorkspaceNames m <- XS.get     let getname w = fromMaybe "" $ M.lookup w m         set w name m' = if null name then M.delete w m' else M.insert w name m'-    XS.put $ WorkspaceNames $ set w1 (getname w2) $ set w2 (getname w1) $ m+    XS.put $ WorkspaceNames $ set w1 (getname w2) $ set w2 (getname w1) m++-- | Same behavior than 'XMonad.Prompt.Workspace.workspacePrompt' excepted it acts on the workspace name provided by this module.+workspaceNamePrompt :: XPConfig -> (WorkspaceId -> X ()) -> X ()+workspaceNamePrompt conf job = do+    myWorkspaces <- gets $ W.workspaces . windowset+    myWorkspacesName <- getWorkspaceNames ":" <&> \n -> [n (W.tag w) w | w <- myWorkspaces]+    let pairs = zip myWorkspacesName (map W.tag myWorkspaces)+    mkXPrompt (Wor "Select workspace: ") conf+              (contains myWorkspacesName)+              (job . toWsId pairs)+  where toWsId pairs name = fromMaybe "" (lookup name pairs)+        contains completions input =+          return $ filter (isInfixOf input) completions++-- | Modify 'XMonad.Hooks.StatusBar.PP.PP'\'s pretty-printing format to show+-- workspace names as well.+workspaceNamesPP :: PP -> X PP+workspaceNamesPP pp = getWorkspaceNames ":" <&> \ren -> pp{ ppRename = ppRename pp >=> ren }++-- | Tell "XMonad.Hooks.EwmhDesktops" to append workspace names to desktop+-- names.+workspaceNamesEwmh :: XConfig l -> XConfig l+workspaceNamesEwmh = addEwmhWorkspaceRename $ getWorkspaceNames ":"
XMonad/Config/Arossato.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Config.Arossato+-- Description :  Andrea Rossato's xmonad configuration. -- Copyright   :  (c) Andrea Rossato 2007 -- License     :  BSD3-style (see LICENSE) --@@ -15,6 +16,7 @@ ------------------------------------------------------------------------  module XMonad.Config.Arossato+    {-# DEPRECATED "This module contains a personal configuration, to be removed from xmonad-contrib.  If you use this module, please copy the relevant parts to your configuration or obtain a copy of it on https://xmonad.org/configurations.html and include it as a local module." #-}     ( -- * Usage       -- $usage       arossatoConfig@@ -22,7 +24,7 @@  import qualified Data.Map as M -import XMonad hiding ( (|||) )+import XMonad import qualified XMonad.StackSet as W  import XMonad.Actions.CycleWS@@ -30,13 +32,11 @@ import XMonad.Hooks.ManageDocks import XMonad.Hooks.ServerMode import XMonad.Layout.Accordion-import XMonad.Layout.LayoutCombinators import XMonad.Layout.Magnifier import XMonad.Layout.NoBorders import XMonad.Layout.SimpleFloat import XMonad.Layout.Tabbed import XMonad.Layout.WindowArranger-import XMonad.Prompt import XMonad.Prompt.Shell import XMonad.Prompt.Ssh import XMonad.Prompt.Theme@@ -47,7 +47,7 @@  -- $usage -- The simplest way to use this configuration module is to use an--- @~\/.xmonad\/xmonad.hs@ like this:+-- @xmonad.hs@ like this: -- -- > module Main (main) where -- >@@ -64,7 +64,7 @@ -- -- You can use this module also as a starting point for writing your -- own configuration module from scratch. Save it as your--- @~\/.xmonad\/xmonad.hs@ and:+-- @xmonad.hs@ and: -- -- 1. Change the module name from --@@ -86,7 +86,7 @@  arossatoConfig = do     xmobar <- spawnPipe "xmobar" -- REMOVE this line if you do not have xmobar installed!-    return $ defaultConfig+    return $ def          { workspaces         = ["home","var","dev","mail","web","doc"] ++                                 map show [7 .. 9 :: Int]          , logHook            = myDynLog xmobar -- REMOVE this line if you do not have xmobar installed!@@ -120,7 +120,7 @@       newManageHook = myManageHook        -- xmobar-      myDynLog    h = dynamicLogWithPP defaultPP+      myDynLog    h = dynamicLogWithPP def                       { ppCurrent = xmobarColor "yellow" "" . wrap "[" "]"                       , ppTitle   = xmobarColor "green"  "" . shorten 40                       , ppVisible = wrap "(" ")"@@ -128,7 +128,7 @@                       }        -- key bindings stuff-      defKeys    = keys defaultConfig+      defKeys    = keys def       delKeys x  = foldr M.delete           (defKeys x) (toRemove x)       newKeys x  = foldr (uncurry M.insert) (delKeys x) (toAdd    x)       -- remove some of the default key bindings@@ -144,12 +144,12 @@           [(shiftMask .|. modMask x, k) | k <- [xK_1 .. xK_9]]       -- These are my personal key bindings       toAdd x   =-          [ ((modMask x              , xK_F12   ), xmonadPrompt      defaultXPConfig     )-          , ((modMask x              , xK_F3    ), shellPrompt       defaultXPConfig     )-          , ((modMask x              , xK_F4    ), sshPrompt         defaultXPConfig     )-          , ((modMask x              , xK_F5    ), themePrompt       defaultXPConfig     )-          , ((modMask x              , xK_F6    ), windowPromptGoto  defaultXPConfig     )-          , ((modMask x              , xK_F7    ), windowPromptBring defaultXPConfig     )+          [ ((modMask x              , xK_F12   ), xmonadPrompt      def                 )+          , ((modMask x              , xK_F3    ), shellPrompt       def                 )+          , ((modMask x              , xK_F4    ), sshPrompt         def                 )+          , ((modMask x              , xK_F5    ), themePrompt       def                 )+          , ((modMask x              , xK_F6    ), windowPrompt def Goto  allWindows     )+          , ((modMask x              , xK_F7    ), windowPrompt def Bring allWindows     )           , ((modMask x              , xK_comma ), prevWS                                )           , ((modMask x              , xK_period), nextWS                                )           , ((modMask x              , xK_Right ), windows W.focusDown                   )
XMonad/Config/Azerty.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Config.Azerty+-- Description  : Fix some keybindings for users of French keyboard layouts. -- Copyright    : (c) Devin Mullins <me@twifkak.com> -- License      : BSD --@@ -17,7 +18,7 @@ module XMonad.Config.Azerty (     -- * Usage     -- $usage-    azertyConfig, azertyKeys+    azertyConfig, azertyKeys, belgianConfig, belgianKeys     ) where  import XMonad@@ -26,7 +27,7 @@ import qualified Data.Map as M  -- $usage--- To use this module, start with the following @~\/.xmonad\/xmonad.hs@:+-- To use this module, start with the following @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Config.Azerty@@ -36,13 +37,25 @@ -- If you prefer, an azertyKeys function is provided which you can use as so: -- -- > import qualified Data.Map as M--- > main = xmonad someConfig { keys = \c -> azertyKeys c `M.union` keys someConfig c }+-- > main = xmonad someConfig { keys = \c -> azertyKeys c <> keys someConfig c } -azertyConfig = defaultConfig { keys = azertyKeys <+> keys defaultConfig }+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+    -- mod-shift-{z,e,r} %! Move client to screen 1, 2, or 3+    [((m .|. modm, key), screenWorkspace sc >>= flip whenJust (windows . f))+        | (key, sc) <- zip [xK_z, xK_e, xK_r] [0..],+          (f, m) <- [(W.view, 0), (W.shift, shiftMask)]]
+ XMonad/Config/Bepo.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+-- |+-- Module       : XMonad.Config.Bepo+-- Description  : Fix keybindings for the BEPO keyboard layout.+-- Copyright    : (c) Yorick Laupa <yo.eight@gmail.com>+-- License      : BSD+--+-- Maintainer   : Yorick Laupa <yo.eight@gmail.com>+-- Stability    : stable+-- Portability  : unportable+--+-- This module fixes some of the keybindings for the francophone among you who+-- use a BEPO keyboard layout. Based on XMonad.Config.Azerty++module XMonad.Config.Bepo (+    -- * Usage+    -- $usage+    bepoConfig, bepoKeys+    ) where++import XMonad+import qualified XMonad.StackSet as W++import qualified Data.Map as M++-- $usage+-- To use this module, start with the following @xmonad.hs@:+--+-- > import XMonad+-- > import XMonad.Config.Bepo+-- >+-- > main = xmonad bepoConfig+--+-- If you prefer, an bepoKeys function is provided which you can use as so:+--+-- > import qualified Data.Map as M+-- > main = xmonad someConfig { keys = \c -> bepoKeys c `M.union` keys someConfig c }++bepoConfig = def { keys = bepoKeys <> keys def }++bepoKeys conf@XConfig { modMask = modm } = M.fromList $+    ((modm, xK_semicolon), sendMessage (IncMasterN (-1)))+    : [((m .|. modm, k), windows $ f i)+          | (i, k) <- zip (workspaces conf) [0x22,0xab,0xbb,0x28,0x29,0x40,0x2b,0x2d,0x2f,0x2a],+            (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]]
XMonad/Config/Bluetile.hs view
@@ -1,8 +1,9 @@-{-# OPTIONS -fno-warn-missing-signatures #-} {-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS -fno-warn-missing-signatures #-} ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Config.Bluetile+-- Description :  Default configuration of [Bluetile](http://projects.haskell.org/bluetile/). -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -25,25 +26,25 @@     bluetileConfig     ) where -import XMonad hiding ( (|||) )+import XMonad  import XMonad.Layout.BorderResize-import XMonad.Layout.BoringWindows+import XMonad.Layout.BoringWindows hiding (Replace) import XMonad.Layout.ButtonDecoration import XMonad.Layout.Decoration import XMonad.Layout.DecorationAddons import XMonad.Layout.DraggingVisualizer-import XMonad.Layout.LayoutCombinators import XMonad.Layout.Maximize import XMonad.Layout.Minimize import XMonad.Layout.MouseResizableTile-import XMonad.Layout.Named+import XMonad.Layout.Renamed import XMonad.Layout.NoBorders import XMonad.Layout.PositionStoreFloat import XMonad.Layout.WindowSwitcherDecoration  import XMonad.Actions.BluetileCommands import XMonad.Actions.CycleWS+import XMonad.Actions.Minimize import XMonad.Actions.WindowMenu  import XMonad.Hooks.CurrentWorkspaceOnTop@@ -61,11 +62,10 @@ import qualified Data.Map as M  import System.Exit-import Data.Monoid-import Control.Monad(when)+import XMonad.Prelude(when)  -- $usage--- To use this module, start with the following @~\/.xmonad\/xmonad.hs@:+-- To use this module, start with the following @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Config.Bluetile@@ -81,7 +81,7 @@ bluetileWorkspaces = ["1","2","3","4","5","6","7","8","9","0"]  bluetileKeys :: XConfig Layout -> M.Map (KeyMask, KeySym) (X ())-bluetileKeys conf@(XConfig {XMonad.modMask = modMask'}) = M.fromList $+bluetileKeys conf@XConfig{XMonad.modMask = modMask'} = M.fromList $     -- launching and killing programs     [ ((modMask'              , xK_Return), spawn $ XMonad.terminal conf) -- %! Launch terminal     , ((modMask',               xK_p     ), gnomeRun)    --  %! Launch Gnome "Run application" dialog@@ -112,14 +112,14 @@      -- floating layer support     , ((modMask',               xK_t     ), withFocused $ windows . W.sink) -- %! Push window back into tiling-    , ((modMask' .|. shiftMask, xK_t     ), withFocused $ float ) -- %! Float window+    , ((modMask' .|. shiftMask, xK_t     ), withFocused float ) -- %! Float window      -- increase or decrease number of windows in the master area     , ((modMask'              , xK_comma ), sendMessage (IncMasterN 1)) -- %! Increment the number of windows in the master area     , ((modMask'              , xK_period), sendMessage (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area      -- quit, or restart-    , ((modMask' .|. shiftMask, xK_q     ), io (exitWith ExitSuccess)) -- %! Quit+    , ((modMask' .|. shiftMask, xK_q     ), io exitSuccess) -- %! Quit     , ((modMask'              , xK_q     ), restart "xmonad" True) -- %! Restart      -- Metacity-like workspace switching@@ -143,7 +143,7 @@      -- Minimizing     , ((modMask',               xK_m     ), withFocused minimizeWindow)-    , ((modMask' .|. shiftMask, xK_m     ), sendMessage RestoreNextMinimizedWin)+    , ((modMask' .|. shiftMask, xK_m     ), withLastMinimized maximizeWindow)     ]     ++     -- mod-[1..9] ++ [0] %! Switch to workspace N@@ -159,19 +159,19 @@         , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]]  bluetileMouseBindings :: XConfig Layout -> M.Map (KeyMask, Button) (Window -> X ())-bluetileMouseBindings (XConfig {XMonad.modMask = modMask'}) = M.fromList $+bluetileMouseBindings XConfig{XMonad.modMask = modMask'} = M.fromList     -- mod-button1 %! Move a floated window by dragging-    [ ((modMask', button1), (\w -> isFloating w >>= \isF -> when (isF) $-                                focus w >> mouseMoveWindow w >> windows W.shiftMaster))+    [ ((modMask', button1), \w -> isFloating w >>= \isF -> when isF $+                                focus w >> mouseMoveWindow w >> windows W.shiftMaster)     -- mod-button2 %! Switch to next and first layout-    , ((modMask', button2), (\_ -> sendMessage NextLayout))-    , ((modMask' .|. shiftMask, button2), (\_ -> sendMessage $ JumpToLayout "Floating"))+    , ((modMask', button2), \_ -> sendMessage NextLayout)+    , ((modMask' .|. shiftMask, button2), \_ -> sendMessage $ JumpToLayout "Floating")     -- mod-button3 %! Resize a floated window by dragging-    , ((modMask', button3), (\w -> isFloating w >>= \isF -> when (isF) $-                                focus w >> mouseResizeWindow w >> windows W.shiftMaster))+    , ((modMask', button3), \w -> isFloating w >>= \isF -> when isF $+                                focus w >> mouseResizeWindow w >> windows W.shiftMaster)     ] -isFloating :: Window -> X (Bool)+isFloating :: Window -> X Bool isFloating w = do     ws <- gets windowset     return $ M.member w (W.floating ws)@@ -180,33 +180,30 @@ bluetileManageHook = composeAll                [ workspaceByPos, positionStoreManageHook (Just defaultThemeWithButtons)                 , className =? "MPlayer" --> doFloat-                , isFullscreen --> doFullFloat-                , manageDocks]+                , isFullscreen --> doFullFloat] -bluetileLayoutHook = avoidStruts $ minimize $ boringWindows $ (-                        named "Floating" floating |||-                        named "Tiled1" tiled1 |||-                        named "Tiled2" tiled2 |||-                        named "Fullscreen" fullscreen-                        )+bluetileLayoutHook = avoidStruts $ minimize $ boringWindows $+                        renamed [Replace "Floating"] floating |||+                        renamed [Replace "Tiled1"] tiled1 |||+                        renamed [Replace "Tiled2"] tiled2 |||+                        renamed [Replace "Fullscreen"] fullscreen         where-            floating = floatingDeco $ maximize $ borderResize $ positionStoreFloat-            tiled1 = tilingDeco $ maximize $ mouseResizableTileMirrored-            tiled2 = tilingDeco $ maximize $ mouseResizableTile+            floating = floatingDeco $ maximize $ borderResize positionStoreFloat+            tiled1 = tilingDeco $ maximize mouseResizableTileMirrored+            tiled2 = tilingDeco $ maximize mouseResizableTile             fullscreen = tilingDeco $ maximize $ smartBorders Full              tilingDeco l = windowSwitcherDecorationWithButtons shrinkText defaultThemeWithButtons (draggingVisualizer l)-            floatingDeco l = buttonDeco shrinkText defaultThemeWithButtons l+            floatingDeco = buttonDeco shrinkText defaultThemeWithButtons  bluetileConfig =-    defaultConfig+    docks . ewmhFullscreen . ewmh $+    def         { modMask = mod4Mask,   -- logo key           manageHook = bluetileManageHook,           layoutHook = bluetileLayoutHook,-          logHook = currentWorkspaceOnTop >> ewmhDesktopsLogHook,-          handleEventHook = ewmhDesktopsEventHook-                                `mappend` fullscreenEventHook-                                `mappend` minimizeEventHook+          logHook = currentWorkspaceOnTop,+          handleEventHook = minimizeEventHook                                 `mappend` serverModeEventHook' bluetileCommands                                 `mappend` positionStoreEventHook,           workspaces = bluetileWorkspaces,
XMonad/Config/Desktop.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Config.Desktop+-- Description  : Core settings for interfacing with desktop environments. -- Copyright    : (c) Spencer Janssen <spencerjanssen@gmail.com> -- License      : BSD --@@ -22,7 +23,8 @@     -- the DE via a subset of the Extended Window Manager Hints (EWMH)     -- specification. Extra xmonad settings unique to specific DE's are     -- added by overriding or modifying @desktopConfig@ fields in the-    -- same way that @defaultConfig@ is customized in @~\/.xmonad/xmonad.hs@.+    -- same way that the default configuration is customized in+    -- @xmonad.hs@.     --     -- For more information about EWMH see:     --@@ -56,6 +58,7 @@ import XMonad import XMonad.Hooks.ManageDocks import XMonad.Hooks.EwmhDesktops+import XMonad.Layout.LayoutModifier (ModifiedLayout) import XMonad.Util.Cursor  import qualified Data.Map as M@@ -69,7 +72,7 @@ -- <http://haskell.org/haskellwiki/Xmonad> -- -- To configure xmonad for use with a DE or with DE tools like panels--- and pagers, in place of @defaultConfig@ in your @~\/.xmonad/xmonad.hs@,+-- and pagers, in place of @def@ in your @xmonad.hs@, -- use @desktopConfig@ or one of the other desktop configs from the -- @XMonad.Config@ namespace. The following setup and customization examples -- work the same way for the other desktop configs as for @desktopConfig@.@@ -88,7 +91,7 @@  -- $customizing -- To customize a desktop config, modify its fields as is illustrated with--- @defaultConfig@ in "XMonad.Doc.Extending#Extending xmonad".+-- the default configuration @def@ in <https://xmonad.org/TUTORIAL.html the tutorial>.  -- $layouts -- See also "XMonad.Util.EZConfig" for more options for modifying key bindings.@@ -103,7 +106,7 @@ -- > main = -- >   xmonad $ desktopConfig { -- >     -- add manage hooks while still ignoring panels and using default manageHooks--- >       manageHook = myManageHook <+> manageHook desktopConfig+-- >       manageHook = myManageHook <> manageHook desktopConfig -- > -- >     -- add a fullscreen tabbed layout that does not avoid covering -- >     -- up desktop panels before the desktop layouts@@ -126,7 +129,7 @@ -- To add to the logHook while still sending workspace and window information -- to DE apps use something like: ----- >  , logHook = myLogHook <+> logHook desktopConfig+-- >  , logHook = myLogHook <> logHook desktopConfig -- -- Or for more elaborate logHooks you can use @do@: --@@ -140,7 +143,7 @@ -- To customize xmonad's event handling while still having it respond -- to EWMH events from pagers, task bars: ----- >  , handleEventHook = myEventHooks <+> handleEventHook desktopConfig+-- >  , handleEventHook = myEventHooks <> handleEventHook desktopConfig -- -- or 'mconcat' if you write a list event of event hooks --@@ -154,7 +157,7 @@  -- $startupHook -- To run the desktop startupHook, plus add further actions to be run each--- time xmonad starts or restarts, use '<+>' to combine actions as in the+-- time xmonad starts or restarts, use '<>' to combine actions as in the -- logHook example, or something like: -- -- >  , startupHook = do@@ -163,14 +166,16 @@ -- >        adjustEventInput -- -desktopConfig = ewmh defaultConfig-    { startupHook     = setDefaultCursor xC_left_ptr-    , layoutHook      = desktopLayoutModifiers $ layoutHook defaultConfig-    , manageHook      = manageHook defaultConfig <+> manageDocks-    , keys            = desktopKeys <+> keys defaultConfig }+desktopConfig :: XConfig (ModifiedLayout AvoidStruts+                             (Choose Tall (Choose (Mirror Tall) Full)))+desktopConfig = docks $ ewmh def+    { startupHook     = setDefaultCursor xC_left_ptr <> startupHook def+    , layoutHook      = desktopLayoutModifiers $ layoutHook def+    , keys            = desktopKeys <> keys def } -desktopKeys (XConfig {modMask = modm}) = M.fromList $+desktopKeys :: XConfig l -> M.Map (KeyMask, KeySym) (X ())+desktopKeys XConfig{modMask = modm} = M.fromList     [ ((modm, xK_b), sendMessage ToggleStruts) ] -desktopLayoutModifiers layout = avoidStruts layout-+desktopLayoutModifiers :: LayoutClass l a => l a -> ModifiedLayout AvoidStruts l a+desktopLayoutModifiers = avoidStruts
+ XMonad/Config/Dmwit.hs view
@@ -0,0 +1,324 @@+-- boilerplate {{{+{-# LANGUAGE ExistentialQuantification, NoMonomorphismRestriction, TypeSynonymInstances, ViewPatterns, LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Config.Dmwit+-- Description :  Daniel Wagner's xmonad configuration.+--+------------------------------------------------------------------------+module XMonad.Config.Dmwit {-# DEPRECATED "This module contains a personal configuration, to be removed from xmonad-contrib.  If you use this module, please copy the relevant parts to your configuration or obtain a copy of it on https://xmonad.org/configurations.html and include it as a local module." #-} where++-- system imports+import Control.Monad.Trans+import Data.Map (Map, fromList)+import Data.Ratio+import Data.Word+import GHC.Real+import System.Environment+import System.Exit+import System.IO+import System.Process++-- xmonad core+import XMonad+import XMonad.StackSet hiding (workspaces)++-- xmonad contrib+import XMonad.Actions.SpawnOn+import XMonad.Actions.Warp+import XMonad.Hooks.DynamicLog+import XMonad.Hooks.ManageDocks+import XMonad.Hooks.ManageHelpers+import XMonad.Layout.Grid+import XMonad.Layout.IndependentScreens hiding (withScreen)+import XMonad.Layout.Magnifier+import XMonad.Layout.NoBorders+import XMonad.Prelude hiding (fromList)+import XMonad.Util.Dzen hiding (x, y)+import XMonad.Util.SpawnOnce+-- }}}+-- volume {{{+outputOf :: String -> IO String+outputOf s = do+    uninstallSignalHandlers+    (hIn, hOut, hErr, p) <- runInteractiveCommand s+    mapM_ hClose [hIn, hErr]+    hGetContents hOut <* waitForProcess p <* installSignalHandlers++geomMean :: Floating a => [a] -> a+geomMean xs = product xs ** (recip . fromIntegral . length $ xs)++arithMean :: Floating a => [a] -> a+arithMean xs = sum xs / fromIntegral (length xs)++namedNumbers n s = do+    l <- lines s+    guard (sentinel `isPrefixOf` l)+    return (drop (length sentinel) l)+    where sentinel = n ++ " #"++-- Data.List.Split.splitOn ":", but without involving an extra dependency+splitColon xs = case break (==':') xs of+    (a, ':':b) -> a : splitColon b+    (a, _)     -> [a]++parse s = arithMean $ do+    l <- lines s+    guard ("\tVolume: " `isPrefixOf` l)+    part <- splitColon l+    (n,'%':_) <- reads part+    return n++modVolume :: String -> Integer -> IO Double+modVolume kind n = do+    is <- namedNumbers parseKind <$> outputOf listCommand+    forM_ is (outputOf . setCommand)+    parse <$> outputOf listCommand+    where+    sign | n > 0 = "+" | otherwise = "-"+    ctlKind      = map (\c -> if c == ' ' then '-' else c) kind+    parseKind    = unwords . map (\(notEmpty -> c :| cs) -> toUpper c : cs) . words $ kind+    setCommand i = "pactl set-" ++ ctlKind ++ "-volume " ++ i ++ " -- " ++ sign ++ show (abs n) ++ "%"+    listCommand  = "pactl list " ++ ctlKind ++ "s"+-- }}}+-- convenient actions {{{+centerMouse = warpToWindow (1/2) (1/2)+statusBarMouse = warpToScreen 0 (5/1600) (5/1200)+withScreen s f = screenWorkspace s >>= flip whenJust (windows . f)++makeLauncher yargs run exec close = concat+    ["exe=`yeganesh ", yargs, "` && ", run, " ", exec, "$exe", close]+launcher     = makeLauncher "" "eval" "\"exec " "\""+termLauncher = makeLauncher "-p withterm" "exec urxvt -e" "" ""+viewShift  i = view i . shift i+floatAll     = composeAll . map (\s -> className =? s --> doFloat)+sinkFocus    = peek >>= maybe id sink+showMod  k n = liftIO (modVolume k n) >>= volumeDzen . show . round+volumeDzen   = dzenConfig $ onCurr (center 170 66) >=> font "-*-helvetica-*-r-*-*-64-*-*-*-*-*-*-*,-*-terminus-*-*-*-*-64-*-*-*-*-*-*-*"+-- }}}+altMask = mod1Mask+bright  = "#80c0ff"+dark    = "#13294e"+-- manage hooks for mplayer {{{+fullscreen43on169 = expand $ RationalRect 0 (-1/6) 1 (4/3) where+    expand (RationalRect x y w h) = RationalRect (x - bwx) (y - bwy) (w + 2 * bwx) (h + 2 * bwy)+    bwx = 2 / 1920 -- borderwidth+    bwy = 2 / 1080++fullscreenMPlayer = className =? "MPlayer" --> do+    dpy   <- liftX $ asks display+    win   <- ask+    hints <- liftIO $ getWMNormalHints dpy win+    case fmap (approx . fst) (sh_aspect hints) of+        Just ( 4 :% 3)  -> viewFullOn 0 "5" win+        Just (16 :% 9)  -> viewFullOn 1 "5" win+        _               -> doFloat+    where+    approx (n, d)    = approxRational (fi n / fi d) (1/100)++operationOn f s n w = do+    let ws = marshall s n+    currws <- liftX $ screenWorkspace s+    doF $ view ws . maybe id view currws . shiftWin ws w . f w++viewFullOn = operationOn sink+centerWineOn = operationOn (`XMonad.StackSet.float` RationalRect (79/960) (-1/540) (401/480) (271/270))+-- }}}+-- debugging {{{+class Show a => PPrint a where+    pprint :: Int -> a -> String+    pprint _ = show++data PPrintable = forall a. PPrint a => P a+instance Show   PPrintable where show     (P x) = show x+instance PPrint PPrintable where pprint n (P x) = pprint n x++record :: String -> Int -> [(String, PPrintable)] -> String+record s n xs = preamble ++ intercalate newline fields ++ postlude where+    indentation = '\n' : replicate n '\t'+    preamble    = s ++ " {" ++ indentation+    postlude    = indentation ++ "}"+    newline     = ',' : indentation+    fields      = map (\(name, value) -> name ++ " = " ++ pprint (n+1) value) xs++instance PPrint a => PPrint (Maybe a) where+    pprint n (Just x) = "Just (" ++ pprint n x ++ ")"+    pprint _ x        = show x++instance PPrint a => PPrint [a] where+    pprint _ [] = "[]"+    pprint n xs = preamble ++ intercalate newline allLines ++ postlude where+        indentation = '\n' : replicate n '\t'+        preamble    = "[" ++ indentation+        allLines    = map (pprint (n+1)) xs+        newline     = ',' : indentation+        postlude    = indentation ++ "]"++instance PPrint Rectangle where+    pprint n x = record "Rectangle" n [+        ("rect_x", P (rect_x x)),+        ("rect_y", P (rect_y x)),+        ("rect_width", P (rect_width x)),+        ("rect_height", P (rect_height x))+        ]++instance PPrint a => PPrint (Stack a) where+    pprint n x = record "Stack" n [+        ("focus", P (XMonad.StackSet.focus x)),+        ("up", P (up x)),+        ("down", P (down x))+        ]++instance (PPrint i, PPrint l, PPrint a) => PPrint (Workspace i l a) where+    pprint n x = record "Workspace" n [+        ("tag", P (tag x)),+        ("layout", P (layout x)),+        ("stack", P (stack x))+        ]++instance PPrint ScreenDetail where+    pprint n x = record "SD" n [("screenRect", P (screenRect x))]++instance (PPrint i, PPrint l, PPrint a, PPrint sid, PPrint sd) => PPrint (XMonad.StackSet.Screen i l a sid sd) where+    pprint n x = record "Screen" n [+        ("workspace", P (workspace x)),+        ("screen", P (screen x)),+        ("screenDetail", P (screenDetail x))+        ]++instance (PPrint i, PPrint l, PPrint a, PPrint sid, PPrint sd) => PPrint (StackSet i l a sid sd) where+    pprint n x = record "StackSet" n [+        ("current", P (current x)),+        ("visible", P (visible x)),+        ("hidden", P (hidden x)),+        ("floating", P (floating x))+        ]++instance PPrint (Layout a)+instance PPrint Int+instance PPrint XMonad.Screen+instance PPrint Integer+instance PPrint Position+instance PPrint Dimension+instance PPrint Char+instance PPrint Word64+instance PPrint ScreenId+instance (Show a, Show b) => PPrint (Map a b)+-- }}}+-- main {{{+dmwitConfig nScreens = docks $ def {+    borderWidth             = 2,+    workspaces              = withScreens nScreens (map show [1..5]),+    terminal                = "urxvt",+    normalBorderColor       = dark,+    focusedBorderColor      = bright,+    modMask                 = mod4Mask,+    keys                    = keyBindings,+    layoutHook              = magnifierOff $ avoidStruts (GridRatio 0.9) ||| noBorders Full,+    manageHook              =     (title =? "CGoban: Main Window" --> doF sinkFocus)+                              <> (className =? "Wine" <&&> (appName =? "hl2.exe" <||> appName =? "portal2.exe") --> ask >>= viewFullOn {-centerWineOn-} 1 "5")+                              <> (className =? "VirtualBox" --> ask >>= viewFullOn 1 "5")+                              <> (isFullscreen --> doFullFloat) -- TF2 matches the "isFullscreen" criteria, so its manage hook should appear after (e.g., to the left of a <> compared to) this one+                              <> (appName =? "huludesktop" --> doRectFloat fullscreen43on169)+                              <> fullscreenMPlayer+                              <> floatAll ["Gimp", "Wine"]+                              <> manageSpawn,+    logHook                 = allPPs nScreens,+    startupHook             = refresh+                           >> mapM_ (spawnOnce . xmobarCommand) [0 .. nScreens-1]+    }++main = countScreens >>= xmonad . dmwitConfig+-- }}}+-- keybindings {{{+keyBindings conf = let m = modMask conf in fromList . anyMask $ [+    ((m                , xK_BackSpace  ), spawnHere "urxvt"),+    ((m                , xK_p          ), spawnHere launcher),+    ((m .|. shiftMask  , xK_p          ), spawnHere termLauncher),+    ((m .|. shiftMask  , xK_c          ), kill),+    ((m                , xK_q          ), restart "xmonad" True),+    ((m .|. shiftMask  , xK_q          ), io exitSuccess),+    ((m                , xK_grave      ), sendMessage NextLayout),+    ((m .|. shiftMask  , xK_grave      ), setLayout $ layoutHook conf),+    ((m                , xK_o          ), sendMessage Toggle),+    ((m                , xK_x          ), withFocused (windows . sink)),+    ((m                , xK_Home       ), windows focusUp),+    ((m .|. shiftMask  , xK_Home       ), windows swapUp),+    ((m                , xK_End        ), windows focusDown),+    ((m .|. shiftMask  , xK_End        ), windows swapDown),+    ((m                , xK_a          ), windows focusMaster),+    ((m .|. shiftMask  , xK_a          ), windows swapMaster),+    ((m                , xK_Control_L  ), withScreen 0 view),+    ((m .|. shiftMask  , xK_Control_L  ), withScreen 0 viewShift),+    ((m                , xK_Alt_L      ), withScreen 1 view),+    ((m .|. shiftMask  , xK_Alt_L      ), withScreen 1 viewShift),+    ((m                , xK_u          ), centerMouse),+    ((m .|. shiftMask  , xK_u          ), statusBarMouse),+    ((m                , xK_s          ), spawnHere "chromium --password-store=gnome"),+    ((m                , xK_n          ), spawnHere "gvim todo"),+    ((m                , xK_t          ), spawnHere "mpc toggle"),+    ((m                , xK_h          ), spawnHere "urxvt -e alsamixer"),+    ((m                , xK_d          ), spawnHere "wyvern"),+    ((m                , xK_l          ), spawnHere "urxvt -e sup"),+    ((m                , xK_r          ), spawnHere "urxvt -e ncmpcpp"),+    ((m                , xK_c          ), spawnHere "urxvt -e ghci"),+    ((m                , xK_g          ), spawnHere "slock" >> spawnHere "xscreensaver-command -lock"),+    ((m                , xK_f          ), spawnHere "gvim ~/.xmonad/xmonad.hs"),+    ((      noModMask  , xK_F8         ), showMod "sink input" (-4)),+    ((      noModMask  , xK_F9         ), showMod "sink input"   4 ),+    ((      shiftMask  , xK_F8         ), showMod "sink"       (-4)),+    ((      shiftMask  , xK_F9         ), showMod "sink"         4 ),+    ((      noModMask  , xK_Super_L    ), return ()) -- make VirtualBox ignore stray hits of the Windows key+    ] ++ [+    ((m .|. e          , key           ), windows (onCurrentScreen f ws))+    | (key, ws) <- zip [xK_1..xK_9] (workspaces' conf)+    , (e, f)    <- [(0, view), (shiftMask, viewShift)]+    ]++atSchool school home = do+    host <- liftIO (getEnv "HOST")+    return $ case host of+        "sorghum"   -> home+        "buckwheat" -> home+        _           -> school++anyMask xs = do+    ((mask, key), action) <- xs+    extraMask             <- [0, controlMask, altMask, controlMask .|. altMask]+    return ((mask .|. extraMask, key), action)+-- }}}+-- logHook {{{+pipeName n s = "/home/dmwit/.xmonad/pipe-" ++ n ++ "-" ++ show s++xmobarCommand (S s) = unwords ["xmobar",+    "-x", show s,+    "-t", template s,+    "-C", pipeReader+    ]+    where+    template 0 = "}%focus%{%workspaces%"+    template _ = "%date%}%focus%{%workspaces%"+    pipeReader = "'[\+        \Run PipeReader \"" ++ pipeName "focus"      s ++ "\" \"focus\",\+        \Run PipeReader \"" ++ pipeName "workspaces" s ++ "\" \"workspaces\"\+        \]'"++allPPs nScreens = sequence_ [dynamicLogWithPP (pp s) | s <- [0..nScreens-1], pp <- [ppFocus, ppWorkspaces]]+color c = xmobarColor c ""++ppFocus s@(S s_) = whenCurrentOn s def {+    ppOrder  = \case{ _:_:windowTitle:_ -> [windowTitle]; _ -> [] },+    ppOutput = appendFile (pipeName "focus" s_) . (++ "\n")+    }++ppWorkspaces s@(S s_) = marshallPP s def {+    ppCurrent           = color "white",+    ppVisible           = color "white",+    ppHiddenNoWindows   = color dark,+    ppUrgent            = color "red",+    ppSep               = "",+    ppOrder             = \case{ wss:_layout:_title:_ -> [wss]; _ -> [] },+    ppOutput            = appendFile (pipeName "workspaces" s_) . (++"\n")+    }+-- }}}
XMonad/Config/Droundy.hs view
@@ -1,25 +1,27 @@ {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |+-- Module      :  XMonad.Config.Droundy+-- Description :  David Roundy's xmonad config. -- Copyright   :  (c) Spencer Janssen 2007 -- License     :  BSD3-style (see LICENSE) -- --------------------------------------------------------------------------module XMonad.Config.Droundy ( config, mytab ) where+module XMonad.Config.Droundy {-# DEPRECATED "This module contains a personal configuration, to be removed from xmonad-contrib.  If you use this module, please copy the relevant parts to your configuration or obtain a copy of it on https://xmonad.org/configurations.html and include it as a local module." #-} ( config, mytab ) where -import XMonad hiding (keys, config, (|||))+import XMonad hiding (keys, config) import qualified XMonad (keys)  import qualified XMonad.StackSet as W import qualified Data.Map as M-import System.Exit ( exitWith, ExitCode(ExitSuccess) )+import System.Exit ( exitSuccess ) -import XMonad.Layout.Tabbed ( tabbed, defaultTheme,+import XMonad.Layout.Tabbed ( tabbed,                               shrinkText, Shrinker, shrinkIt, CustomShrink(CustomShrink) ) import XMonad.Layout.Combo ( combineTwo )-import XMonad.Layout.Named ( named )+import XMonad.Layout.Renamed ( Rename(Replace), renamed ) import XMonad.Layout.LayoutCombinators import XMonad.Layout.Square ( Square(Square) ) import XMonad.Layout.WindowNavigation ( Navigate(Move,Swap,Go), Direction2D(U,D,R,L),@@ -32,22 +34,22 @@ import XMonad.Layout.ShowWName ( showWName ) import XMonad.Layout.Magnifier ( maximizeVertical, MagnifyMsg(Toggle) ) -import XMonad.Prompt ( defaultXPConfig, font, height, XPConfig )+import XMonad.Prompt ( font, height, XPConfig ) import XMonad.Prompt.Layout ( layoutPrompt ) import XMonad.Prompt.Shell ( shellPrompt )  import XMonad.Actions.CopyWindow ( kill1, copy ) import XMonad.Actions.DynamicWorkspaces ( withNthWorkspace, withWorkspace,                                           selectWorkspace, renameWorkspace, removeWorkspace )-import XMonad.Actions.CycleWS ( moveTo, WSType( HiddenNonEmptyWS ),-                                Direction1D( Prev, Next) )+import XMonad.Actions.CycleWS ( moveTo, hiddenWS, emptyWS,+                                Direction1D( Prev, Next), WSType ((:&:), Not) ) -import XMonad.Hooks.ManageDocks ( avoidStruts, manageDocks )+import XMonad.Hooks.ManageDocks ( avoidStruts, docks ) import XMonad.Hooks.EwmhDesktops ( ewmh )  myXPConfig :: XPConfig-myXPConfig = defaultXPConfig {font="-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-*"-                             ,height=22}+myXPConfig = def {font="-*-lucida-medium-r-*-*-14-*-*-*-*-*-*-*"+                 ,height=22}   ------------------------------------------------------------------------@@ -77,11 +79,11 @@     , ((modMask x,               xK_t     ), withFocused $ windows . W.sink) -- %! Push window back into tiling      -- quit, or restart-    , ((modMask x .|. shiftMask, xK_Escape), io (exitWith ExitSuccess)) -- %! Quit xmonad+    , ((modMask x .|. shiftMask, xK_Escape), io exitSuccess) -- %! Quit xmonad     , ((modMask x              , xK_Escape), restart "xmonad" True) -- %! Restart xmonad -    , ((modMask x .|. shiftMask, xK_Right), moveTo Next HiddenNonEmptyWS)-    , ((modMask x .|. shiftMask, xK_Left), moveTo Prev HiddenNonEmptyWS)+    , ((modMask x .|. shiftMask, xK_Right), moveTo Next $ hiddenWS :&: Not emptyWS)+    , ((modMask x .|. shiftMask, xK_Left), moveTo Prev $ hiddenWS :&: Not emptyWS)     , ((modMask x, xK_Right), sendMessage $ Go R)     , ((modMask x, xK_Left), sendMessage $ Go L)     , ((modMask x, xK_Up), sendMessage $ Go U)@@ -113,23 +115,22 @@     ]      ++-    zip (zip (repeat $ modMask x) [xK_F1..xK_F12]) (map (withNthWorkspace W.greedyView) [0..])+    zip (map (modMask x,) [xK_F1..xK_F12]) (map (withNthWorkspace W.greedyView) [0..])     ++-    zip (zip (repeat (modMask x .|. shiftMask)) [xK_F1..xK_F12]) (map (withNthWorkspace copy) [0..])+    zip (map (modMask x .|. shiftMask,) [xK_F1..xK_F12]) (map (withNthWorkspace copy) [0..]) -config = ewmh defaultConfig+config = docks $ ewmh def          { borderWidth = 1 -- Width of the window border in pixels.          , XMonad.workspaces = ["mutt","iceweasel"]          , layoutHook = showWName $ workspaceDir "~" $                         boringWindows $ smartBorders $ windowNavigation $                         maximizeVertical $ toggleLayouts Full $ avoidStruts $-                        named "tabbed" mytab |||-                        named "xclock" (mytab ****//* combineTwo Square mytab mytab) |||-                        named "three" (mytab **//* mytab *//* combineTwo Square mytab mytab) |||-                        named "widescreen" ((mytab *||* mytab)+                        renamed [Replace "tabbed"] mytab |||+                        renamed [Replace "xclock"] (mytab ****//* combineTwo Square mytab mytab) |||+                        renamed [Replace "three"] (mytab **//* mytab *//* combineTwo Square mytab mytab) |||+                        renamed [Replace "widescreen"] ((mytab *||* mytab)                                                 ****//* combineTwo Square mytab mytab) --   |||                         --mosaic 0.25 0.5-         , manageHook = manageHook defaultConfig <+> manageDocks -- add panel-handling          , terminal = "xterm" -- The preferred terminal program.          , normalBorderColor = "#222222" -- Border color for unfocused windows.          , focusedBorderColor = "#00ff00" -- Border color for focused windows.@@ -137,7 +138,7 @@          , XMonad.keys = keys          } -mytab = tabbed CustomShrink defaultTheme+mytab = tabbed CustomShrink def  instance Shrinker CustomShrink where     shrinkIt shr s | Just s' <- dropFromHead " " s = shrinkIt shr s'
+ XMonad/Config/Example.hs view
@@ -0,0 +1,79 @@+--------------------------------------------------------------------------------+-- | Example.hs+--+-- Example configuration file for xmonad using the latest recommended+-- features (e.g., 'desktopConfig').+module Main (main) where++--------------------------------------------------------------------------------+import System.Exit+import XMonad+import XMonad.Config.Desktop+import XMonad.Hooks.DynamicLog+import XMonad.Hooks.ManageHelpers+import XMonad.Layout.BinarySpacePartition (emptyBSP)+import XMonad.Layout.NoBorders (noBorders)+import XMonad.Layout.ResizableTile (ResizableTall(..))+import XMonad.Layout.ToggleLayouts (ToggleLayout(..), toggleLayouts)+import XMonad.Prompt+import XMonad.Prompt.ConfirmPrompt+import XMonad.Prompt.Shell+import XMonad.Util.EZConfig++--------------------------------------------------------------------------------+main = do+  spawn "xmobar" -- Start a task bar such as xmobar.++  -- Start xmonad using the main desktop configuration with a few+  -- simple overrides:+  xmonad $ desktopConfig+    { modMask    = mod4Mask -- Use the "Win" key for the mod key+    , manageHook = myManageHook <> manageHook desktopConfig+    , layoutHook = desktopLayoutModifiers myLayouts+    , logHook    = (dynamicLogString def >>= xmonadPropLog)+                    <> logHook desktopConfig+    }++    `additionalKeysP` -- Add some extra key bindings:+      [ ("M-S-q",   confirmPrompt myXPConfig "exit" (io exitSuccess))+      , ("M-p",     shellPrompt myXPConfig)+      , ("M-<Esc>", sendMessage (Toggle "Full"))+      ]++--------------------------------------------------------------------------------+-- | Customize layouts.+--+-- This layout configuration uses two primary layouts, 'ResizableTall'+-- and 'BinarySpacePartition'.  You can also use the 'M-<Esc>' key+-- binding defined above to toggle between the current layout and a+-- full screen layout.+myLayouts = toggleLayouts (noBorders Full) others+  where+    others = ResizableTall 1 (1.5/100) (3/5) [] ||| emptyBSP++--------------------------------------------------------------------------------+-- | Customize the way 'XMonad.Prompt' looks and behaves.  It's a+-- great replacement for dzen.+myXPConfig = def+  { position          = Top+  , alwaysHighlight   = True+  , promptBorderWidth = 0+  , font              = "xft:monospace:size=9"+  }++--------------------------------------------------------------------------------+-- | Manipulate windows as they are created.  The list given to+-- @composeOne@ is processed from top to bottom.  The first matching+-- rule wins.+--+-- Use the `xprop' tool to get the info you need for these matches.+-- For className, use the second value that xprop gives you.+myManageHook = composeOne+  -- Handle floating windows:+  [ transience            -- move transient windows to their parent+  , isDialog              -?> doCenterFloat+  ] <> composeAll+  [ className =? "Pidgin" --> doFloat+  , className =? "XCalc"  --> doFloat+  , className =? "mpv"    --> doFloat+  ]
XMonad/Config/Gnome.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Config.Gnome+-- Description  : Config for integrating xmonad with GNOME. -- Copyright    : (c) Spencer Janssen <spencerjanssen@gmail.com> -- License      : BSD --@@ -18,7 +19,8 @@     -- $usage     gnomeConfig,     gnomeRun,-    gnomeRegister+    gnomeRegister,+    desktopLayoutModifiers     ) where  import XMonad@@ -30,7 +32,7 @@ import System.Environment (getEnvironment)  -- $usage--- To use this module, start with the following @~\/.xmonad\/xmonad.hs@:+-- To use this module, start with the following @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Config.Gnome@@ -41,12 +43,12 @@  gnomeConfig = desktopConfig     { terminal = "gnome-terminal"-    , keys     = gnomeKeys <+> keys desktopConfig+    , keys     = gnomeKeys <> keys desktopConfig     , startupHook = gnomeRegister >> startupHook desktopConfig } -gnomeKeys (XConfig {modMask = modm}) = M.fromList $+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.@@ -71,10 +73,10 @@ -- > gconftool-2 -s /desktop/gnome/session/required_components/windowmanager xmonad --type string gnomeRegister :: MonadIO m => m () gnomeRegister = io $ do-    x <- lookup "DESKTOP_AUTOSTART_ID" `fmap` getEnvironment+    x <- lookup "DESKTOP_AUTOSTART_ID" <$> getEnvironment     whenJust x $ \sessionId -> safeSpawn "dbus-send"             ["--session"-            ,"--print-reply=string"+            ,"--print-reply=literal"             ,"--dest=org.gnome.SessionManager"             ,"/org/gnome/SessionManager"             ,"org.gnome.SessionManager.RegisterClient"
XMonad/Config/Kde.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Config.Kde+-- Description  : Config for integrating xmonad with KDE. -- Copyright    : (c) Spencer Janssen <spencerjanssen@gmail.com> -- License      : BSD --@@ -17,7 +18,8 @@     -- * Usage     -- $usage     kdeConfig,-    kde4Config+    kde4Config,+    desktopLayoutModifiers     ) where  import XMonad@@ -26,7 +28,7 @@ import qualified Data.Map as M  -- $usage--- To use this module, start with the following @~\/.xmonad\/xmonad.hs@:+-- To use this module, start with the following @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Config.Kde@@ -40,18 +42,18 @@  kdeConfig = desktopConfig     { terminal = "konsole"-    , keys     = kdeKeys <+> keys desktopConfig }+    , keys     = kdeKeys <> keys desktopConfig }  kde4Config = desktopConfig     { terminal = "konsole"-    , keys     = kde4Keys <+> keys desktopConfig }+    , keys     = kde4Keys <> keys desktopConfig } -kdeKeys (XConfig {modMask = modm}) = M.fromList $+kdeKeys XConfig{modMask = modm} = M.fromList     [ ((modm,               xK_p), spawn "dcop kdesktop default popupExecuteCommand")     , ((modm .|. shiftMask, xK_q), spawn "dcop kdesktop default logout")     ] -kde4Keys (XConfig {modMask = modm}) = M.fromList $+kde4Keys XConfig{modMask = modm} = M.fromList     [ ((modm,               xK_p), spawn "krunner")     , ((modm .|. shiftMask, xK_q), spawn "dbus-send --print-reply --dest=org.kde.ksmserver /KSMServer org.kde.KSMServerInterface.logout int32:1 int32:0 int32:1")     ]
+ XMonad/Config/Mate.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+-- TODO: Remove when we depend on a version of xmonad that has unGrab.+{-# OPTIONS_GHC -Wno-deprecations  #-}+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+-----------------------------------------------------------------------------+-- |+-- Module       : XMonad.Config.Mate+-- Description  : Config for integrating xmonad with MATE.+-- Copyright    : (c) Brandon S Allbery KF8NH, 2014+-- License      : BSD+--+-- Maintainer   : allbery.b@gmail.com+-- Stability    :  unstable+-- Portability  :  unportable+--+-- This module provides a config suitable for use with the MATE desktop+-- environment.+--+-----------------------------------------------------------------------------++module XMonad.Config.Mate (+    -- * Usage+    -- $usage+    mateConfig,+    mateRun,+    matePanel,+    mateRegister,+    mateLogout,+    mateShutdown,+    desktopLayoutModifiers+    ) where++import System.Environment (getEnvironment)+import qualified Data.Map as M++import XMonad hiding (unGrab)+import XMonad.Config.Desktop+import XMonad.Prelude (toUpper)+import XMonad.Util.Run (safeSpawn)+import XMonad.Util.Ungrab (unGrab)++-- $usage+-- To use this module, start with the following @xmonad.hs@:+--+-- > import XMonad+-- > import XMonad.Config.Mate+-- >+-- > main = xmonad mateConfig+--+-- For examples of how to further customize @mateConfig@ see "XMonad.Config.Desktop".++mateConfig = desktopConfig+    { terminal = "mate-terminal"+    , keys     = mateKeys <> keys desktopConfig+    , startupHook = mateRegister >> startupHook desktopConfig }++mateKeys XConfig{modMask = modm} = M.fromList+    [ ((modm, xK_p), mateRun)+    , ((modm, xK_d), unGrab >> matePanel "MAIN_MENU")+    , ((modm .|. shiftMask, xK_q), mateLogout) ]++-- | Launch the "Run Application" dialog.  mate-panel must be running for this+-- to work.  partial application for existing keybinding compatibility.+mateRun :: X ()+mateRun = matePanel "RUN_DIALOG"++-- | Launch a panel action. Either the "Run Application" dialog ("run_dialog" parameter,+-- see above) or the main menu ("main_menu" parameter).  mate-panel must be running+-- for this to work.+matePanel :: String -> X ()+matePanel action = withDisplay $ \dpy -> do+    let panel = "_MATE_PANEL_ACTION"+    rw <- asks theRoot+    mate_panel <- getAtom panel+    panel_action <- getAtom (panel ++ "_" ++ map toUpper action)++    io $ allocaXEvent $ \e -> do+        setEventType e clientMessage+        setClientMessageEvent e rw mate_panel 32 panel_action 0+        sendEvent dpy rw False structureNotifyMask e+        sync dpy False++-- | Register xmonad with mate. 'dbus-send' must be in the $PATH with which+-- xmonad is started.+--+-- This action reduces a delay on startup only if you have configured+-- mate-session to start xmonad with a command such as (check local+-- documentation):+--+-- > dconf write /org/mate/desktop/session/required_components/windowmanager "'xmonad'"+--+-- (the extra quotes are required by dconf)+mateRegister :: MonadIO m => m ()+mateRegister = io $ do+    x <- lookup "DESKTOP_AUTOSTART_ID" <$> getEnvironment+    whenJust x $ \sessionId -> safeSpawn "dbus-send"+            ["--session"+            ,"--print-reply=literal"+            ,"--dest=org.mate.SessionManager"+            ,"/org/mate/SessionManager"+            ,"org.mate.SessionManager.RegisterClient"+            ,"string:xmonad"+            ,"string:"++sessionId]++-- | Display MATE logout dialog. This is the default mod-q action.+mateLogout :: MonadIO m => m ()+mateLogout = spawn "mate-session-save --logout-dialog"++-- | Display MATE shutdown dialog. You can override mod-q to invoke this, or bind it+-- to another key if you prefer.+mateShutdown :: MonadIO m => m ()+mateShutdown = spawn "mate-session-save --shutdown-dialog"
+ XMonad/Config/Prime.hs view
@@ -0,0 +1,691 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, KindSignatures, UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Config.Prime+-- Description :  Draft of a brand new config syntax for xmonad.+-- Copyright   :  Devin Mullins <devin.mullins@gmail.com>+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Devin Mullins <devin.mullins@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This is a draft of a brand new config syntax for xmonad. It aims to be:+--+--  * easier to copy/paste snippets from the docs+--+--  * easier to get the gist for what's going on, for you imperative programmers+--+-- It's brand new, so it's pretty much guaranteed to break or change syntax.+-- But what's the worst that could happen? Xmonad crashes and logs you out?+-- It probably won't do that. Give it a try.+--+-----------------------------------------------------------------------------++module XMonad.Config.Prime {-# DEPRECATED "This module is a perpetual draft and will therefore be removed from xmonad-contrib in the near future." #-} (+-- Note: The identifiers here are listed in the order that makes the most sense+-- for a user, while the definitions below are listed in the order that makes+-- the most sense for a developer.++-- * Start here+-- $start_here+xmonad,+nothing,+-- * Attributes you can set+-- $settables+normalBorderColor,+focusedBorderColor,+terminal,+modMask,+borderWidth,+focusFollowsMouse,+clickJustFocuses,+SettableClass(..),+UpdateableClass(..),++-- * Attributes you can add to+-- $summables+manageHook,+handleEventHook,+workspaces,+logHook,+startupHook,+clientMask,+rootMask,+SummableClass(..),++-- * Attributes you can add to or remove from+-- $removables+keys,+mouseBindings,+RemovableClass(..),++-- * Modifying the list of workspaces+-- $workspaces+withWorkspaces,+wsNames,+wsKeys,+wsActions,+wsSetName,++-- * Modifying the screen keybindings+-- $screens+withScreens,+sKeys,+sActions,+onScreens,++-- * Modifying the layoutHook+-- $layout+addLayout,+resetLayout,+modifyLayout,++-- * Updating the XConfig en masse+-- $update+startWith,+apply,+applyIO,++-- * The rest of the world+-- | Everything you know and love from the core "XMonad" module is available+-- for use in your config file, too.+module XMonad,+-- | (Almost) everything you know and love from the Haskell "Prelude" is+-- available for use in your config file. Note that '>>' has been overriden, so+-- if you want to create do-blocks for normal monads, you'll need some let+-- statements or a separate module. (See the Troubleshooting section.)+module Prelude,++-- * Core+-- | These are the building blocks on which the config language is built.+-- Regular people shouldn't need to know about these.+Prime,+Arr,+(>>),+ifThenElse,++-- * Example config+-- $example++-- * Troubleshooting+-- $troubleshooting+) where++import Prelude hiding ((>>), mod)+import qualified Prelude as P ((>>=), (>>))++import XMonad.Prelude (All)++import XMonad hiding (xmonad, XConfig(..))+import XMonad (XConfig(XConfig))+import qualified XMonad.StackSet as W+import qualified XMonad as X (xmonad, XConfig(..))++import XMonad.Util.EZConfig (additionalKeysP, additionalMouseBindings, checkKeymap, removeKeysP, removeMouseBindings)++-- $start_here+-- To start with, create a @xmonad.hs@ that looks like this:+--+-- > {-# LANGUAGE RebindableSyntax #-}+-- > import XMonad.Config.Prime+-- >+-- > -- Imports go here.+-- >+-- > main = xmonad $ do+-- >   nothing+-- >   -- Configs go here.+--+-- This will give you a default xmonad install, with room to grow. The lines+-- starting with double dashes are comments. You may delete them. Note that+-- Haskell is a bit precise about indentation. Make sure all the statements in+-- your do-block start at the same column, and make sure that any multi-line+-- statements are formatted with a hanging indent. (For an example, see the+-- 'keys =+' statement in the /Example config/ section, below.)+--+-- After changing your config file, restart xmonad with mod-q (where, by+-- default, "mod" == "alt").++--+-- The Prime "Monad"+--++-- | A Prime is a function that transforms an XConfig. It's not a monad, but we+-- turn on RebindableSyntax so we can abuse the pretty do notation.+type Prime l l' = Arr (XConfig l) (XConfig l')++-- | An Arr is a generalization of Prime. Don't reference the type, if you can+-- avoid it. It might go away in the future.+type Arr x y = x -> IO y++-- | Composes two Arrs using 'Prelude.>>=' from "Prelude".+(>>) :: Arr x y -> Arr y z -> Arr x z+(>>) x y c = (P.>>=) (x c) y++-- | Because of RebindableSyntax, this is necessary to enable you to use+-- if-then-else expressions. No need to call it directly.+ifThenElse :: Bool -> a -> a -> a+ifThenElse True  a _ = a+ifThenElse False _ b = b++-- | This is the xmonad main function. It passes 'XMonad.Config.def' (the+-- default 'XConfig') into your do-block, takes the modified config out of your+-- do-block, and then runs xmonad.+--+-- The do-block is a 'Prime'. Advanced readers can skip right to that+-- definition.++xmonad :: (Default a, Read (l Window), LayoutClass l Window) =>+          (a -> IO (XConfig l)) -> IO ()+xmonad prime = (P.>>=) (prime def) X.xmonad++-- | This doesn't modify the config in any way. It's just here for your initial+-- config because Haskell doesn't allow empty do-blocks. Feel free to delete it+-- once you've added other stuff.+nothing :: Prime l l+nothing = return++-- $settables+-- These are a bunch of attributes that you can set. Syntax looks like this:+--+-- >   terminal =: "urxvt"+--+-- Strings are double quoted, Dimensions are unquoted integers, booleans are+-- 'True' or 'False' (case-sensitive), and 'modMask' is usually 'mod1Mask' or+-- 'mod4Mask'.++class UpdateableClass s x y | s -> x y where+  -- | This lets you apply a function to an attribute (i.e. read, modify, write).+  (=.) :: s c -> (x -> y) -> Arr c c++class SettableClass s x y | s -> x y where+  -- | This lets you modify an attribute.+  (=:) :: s c -> y -> Arr c c++-- Undecideable instance. But it's nice to leave open the possibility to write+-- fields you can't read (e.g. `wmName =: ...`).+instance UpdateableClass s x y => SettableClass s x y where+  s =: y = s =. const y++data Settable x c = Settable (c -> x)      -- getter+                             (x -> c -> c) -- setter++instance UpdateableClass (Settable x) x x where+  (Settable g s =. f) c = return $ s (f $ g c) c++-- | Non-focused windows border color. Default: @\"#dddddd\"@+normalBorderColor :: Settable String (XConfig l)+normalBorderColor = Settable X.normalBorderColor (\x c -> c { X.normalBorderColor = x })++-- | Focused windows border color. Default: @\"#ff0000\"@+focusedBorderColor :: Settable String (XConfig l)+focusedBorderColor = Settable X.focusedBorderColor (\x c -> c { X.focusedBorderColor = x })++-- | The preferred terminal application. Default: @\"xterm\"@+terminal :: Settable String (XConfig l)+terminal = Settable X.terminal (\x c -> c { X.terminal = x })++-- | The mod modifier, as used by key bindings. Default: @mod1Mask@ (which is+-- probably alt on your computer).+modMask :: Settable KeyMask (XConfig l)+modMask = Settable X.modMask (\x c -> c { X.modMask = x })++-- | The border width (in pixels). Default: @1@+borderWidth :: Settable Dimension (XConfig l)+borderWidth = Settable X.borderWidth (\x c -> c { X.borderWidth = x })++-- | Whether window focus follows the mouse cursor on move, or requires a mouse+-- click. (Mouse? What's that?) Default: @True@+focusFollowsMouse :: Settable Bool (XConfig l)+focusFollowsMouse = Settable X.focusFollowsMouse (\x c -> c { X.focusFollowsMouse = x })++-- | If True, a mouse click on an inactive window focuses it, but the click is+-- not passed to the window. If False, the click is also passed to the window.+-- Default @True@+clickJustFocuses :: Settable Bool (XConfig l)+clickJustFocuses = Settable X.clickJustFocuses (\x c -> c { X.clickJustFocuses = x })++-- $summables+-- In addition to being able to set these attributes, they have a special+-- syntax for being able to add to them. The operator is @=+@ (the plus comes+-- /after/ the equals), but each attribute has a different syntax for what+-- comes after the operator.++class SummableClass s y | s -> y where+  -- | This lets you add to an attribute.+  (=+) :: s c -> y -> Arr c c+  infix 0 =+++data Summable x y c = Summable (c -> x)      -- getter+                               (x -> c -> c) -- setter+                               (x -> y -> x) -- accumulator++instance UpdateableClass (Summable x y) x x where+  (Summable g s _ =. f) c = return $ s (f $ g c) c++instance SummableClass (Summable x y) y where+  (Summable g s a =+ y) c = return $ s (g c `a` y) c++-- | The action to run when a new window is opened. Default:+--+-- >   manageHook =: composeAll [className =? "MPlayer" --> doFloat, className =? "Gimp" --> doFloat]+--+-- To add more rules to this list, you can say, for instance:+--+-- > import XMonad.StackSet+-- > ...+-- >   manageHook =+ (className =? "Emacs" --> doF kill)+-- >   manageHook =+ (className =? "Vim" --> doF shiftMaster)+--+-- Note that operator precedence mandates the parentheses here.+manageHook :: Summable ManageHook ManageHook (XConfig l)+manageHook = Summable X.manageHook (\x c -> c { X.manageHook = x }) (<>)++-- | Custom X event handler. Return @All True@ if the default handler should+-- also be run afterwards. Default does nothing. To add an event handler:+--+-- > import XMonad.Hooks.ServerMode+-- > ...+-- >   handleEventHook =+ serverModeEventHook+handleEventHook :: Summable (Event -> X All) (Event -> X All) (XConfig l)+handleEventHook = Summable X.handleEventHook (\x c -> c { X.handleEventHook = x }) (<>)++-- | List of workspaces' names. Default: @map show [1 .. 9 :: Int]@. Adding+-- appends to the end:+--+-- >   workspaces =+ ["0"]+--+-- This is useless unless you also create keybindings for this.+workspaces :: Summable [String] [String] (XConfig l)+workspaces = Summable X.workspaces (\x c -> c { X.workspaces = x }) (++)++-- | The action to perform when the windows set is changed. This happens+-- whenever focus change, a window is moved, etc. @logHook =+@ takes an @X ()@+-- and appends it via '(>>)'. For instance:+--+-- > import XMonad.Hooks.ICCCMFocus+-- > ...+-- >   logHook =+ takeTopFocus+--+-- Note that if your expression is parametrically typed (e.g. of type+-- @MonadIO m => m ()@), you'll need to explicitly annotate it, like so:+--+-- >   logHook =+ (io $ putStrLn "Hello, world!" :: X ())+logHook :: Summable (X ()) (X ()) (XConfig l)+logHook = Summable X.logHook (\x c -> c { X.logHook = x }) (P.>>)++-- | The action to perform on startup. @startupHook =+@ takes an @X ()@ and+-- appends it via '(>>)'. For instance:+--+-- > import XMonad.Hooks.SetWMName+-- > ...+-- >   startupHook =+ setWMName "LG3D"+--+-- Note that if your expression is parametrically typed (e.g. of type+-- @MonadIO m => m ()@), you'll need to explicitly annotate it, as documented+-- in 'logHook'.+startupHook :: Summable (X ()) (X ()) (XConfig l)+startupHook = Summable X.startupHook (\x c -> c { X.startupHook = x }) (P.>>)++-- | The client events that xmonad is interested in. This is useful in+-- combination with handleEventHook. Default: @structureNotifyMask .|.+-- enterWindowMask .|. propertyChangeMask@+--+-- >   clientMask =+ keyPressMask .|. keyReleaseMask+clientMask :: Summable EventMask EventMask (XConfig l)+clientMask = Summable X.clientMask (\x c -> c { X.clientMask = x }) (.|.)++-- | The root events that xmonad is interested in. This is useful in+-- combination with handleEventHook. Default: @substructureRedirectMask .|.+-- substructureNotifyMask .|. enterWindowMask .|. leaveWindowMask .|.+-- structureNotifyMask .|. buttonPressMask@+rootMask :: Summable EventMask EventMask (XConfig l)+rootMask = Summable X.rootMask (\x c -> c { X.rootMask = x }) (.|.)++-- $removables+-- The following support the the @=+@ for adding items and the @=-@ operator+-- for removing items.++class RemovableClass r y | r -> y where+  -- | This lets you remove from an attribute.+  (=-) :: r c -> y -> Arr c c+  infix 0 =-++data Keys c = Keys { kAdd :: [(String, X ())] -> c -> c,+                     kRemove :: [String] -> c -> c }++instance SummableClass Keys [(String, X ())] where+  Keys { kAdd = a } =+ newKeys = return . a newKeys++instance RemovableClass Keys [String] where+  Keys { kRemove = r } =- sadKeys = return . r sadKeys++-- | Key bindings to 'X' actions. Default: see @`man xmonad`@. 'keys'+-- takes a list of keybindings specified emacs-style, as documented in+-- 'XMonad.Util.EZConfig.mkKeyMap'. For example, to change the "kill window"+-- key:+--+-- >   keys =- ["M-S-c"]+-- >   keys =+ [("M-M1-x", kill)]+keys :: Keys (XConfig l)+keys = Keys {+  -- Note that since checkKeymap happens on newKeys, it doesn't check for+  -- duplicates between repeated applications. Probably OK. (Especially since+  -- overriding defaults is a common behavior.) Also note that there's no+  -- reference cycle here. Yay!+  kAdd = \newKeys c -> (c `additionalKeysP` newKeys) { X.startupHook = (P.>>) (X.startupHook c) (checkKeymap c newKeys) },+  kRemove = flip removeKeysP+}++data MouseBindings c = MouseBindings { mAdd :: [((ButtonMask, Button), Window -> X ())] -> c -> c,+                                       mRemove :: [(ButtonMask, Button)] -> c -> c }++instance SummableClass MouseBindings [((ButtonMask, Button), Window -> X ())] where+  MouseBindings { mAdd = a } =+ newBindings = return . a newBindings++instance RemovableClass MouseBindings [(ButtonMask, Button)] where+  MouseBindings { mRemove = r } =- sadBindings = return . r sadBindings++-- | Mouse button bindings to an 'X' actions on a window. Default: see @`man+-- xmonad`@. To make @mod-\<scrollwheel\>@ switch workspaces:+--+-- > import XMonad.Actions.CycleWS (nextWS, prevWS)+-- > ...+-- >   mouseBindings =+ [((mod4Mask, button4), const prevWS),+-- >                     ((mod4Mask, button5), const nextWS)]+--+-- Note that you need to specify the numbered mod-mask e.g. 'mod4Mask' instead+-- of just 'modMask'.+mouseBindings :: MouseBindings (XConfig l)+mouseBindings = MouseBindings {+  mAdd = flip additionalMouseBindings,+  mRemove = flip removeMouseBindings+}++-- $workspaces+-- Workspaces can be configured through 'workspaces', but then the 'keys' need+-- to be set, and this can be a bit laborious. 'withWorkspaces' provides a+-- convenient mechanism for common workspace updates.++-- | Configure workspaces through a Prime-like interface. Example:+--+-- >   withWorkspaces $ do+-- >     wsKeys =+ ["0"]+-- >     wsActions =+ [("M-M1-", windows . swapWithCurrent)]+-- >     wsSetName 1 "mail"+--+-- This will set 'workspaces' and add the necessary keybindings to 'keys'. Note+-- that it won't remove old keybindings; it's just not that clever.+withWorkspaces :: Arr WorkspaceConfig WorkspaceConfig -> Prime l l+withWorkspaces wsarr xconf = (P.>>=) (wsarr def) $ \wsconf -> wsprime wsconf xconf+  where wsprime :: WorkspaceConfig -> Prime l l+        wsprime wsconf =+          (workspaces =: allNames) >>+          (keys =+ [(mod ++ key, action name) | (name, key) <- zip allNames (wsKeys_ wsconf),+                                                (mod, action) <- wsActions_ wsconf])+          where allNames = zipWith chooseName (wsNames_ wsconf) (wsKeys_ wsconf)+                chooseName name keyspec = if not (null name) then name else keyspec++data WorkspaceConfig = WorkspaceConfig {+  wsNames_ :: [String],+  wsKeys_ :: [String],+  wsActions_ :: [(String, String -> X ())]+}++instance Default WorkspaceConfig where+  def = WorkspaceConfig {+    wsNames_ = repeat "",+    wsKeys_ = map (:[]) ['1'..'9'], -- The hungry monkey eats dots and turns them into numbers.+    wsActions_ = [("M-", windows . W.greedyView),+                  ("M-S-", windows . W.shift)]+  }++-- | The list of workspace names, like 'workspaces' but with two differences:+--+--   1. If any entry is the empty string, it'll be replaced with the+--      corresponding entry in 'wsKeys'.+--   2. The list is truncated to the size of 'wsKeys'.+--+-- The default value is @'repeat' ""@.+--+-- If you'd like to create workspaces without associated keyspecs, you can do+-- that afterwards, outside the 'withWorkspaces' block, with @'workspaces' =+@.+wsNames :: Settable [String] WorkspaceConfig+wsNames = Settable wsNames_ (\x c -> c { wsNames_ = x })++-- | The list of workspace keys. These are combined with the modifiers in+-- 'wsActions' to form the keybindings for navigating to workspaces. Default:+-- @["1","2",...,"9"]@.+wsKeys :: Summable [String] [String] WorkspaceConfig+wsKeys = Summable wsKeys_ (\x c -> c { wsKeys_ = x }) (++)++-- | Mapping from key prefix to command. Its type is @[(String, String ->+-- X())]@. The key prefix may be a modifier such as @\"M-\"@, or a submap+-- prefix such as @\"M-a \"@, or both, as in @\"M-a M-\"@. The command is a+-- function that takes a workspace name and returns an @X ()@. 'withWorkspaces'+-- creates keybindings for the cartesian product of 'wsKeys' and 'wsActions'.+--+-- Default:+--+-- > [("M-", windows . W.greedyView),+-- >  ("M-S-", windows . W.shift)]+wsActions :: Summable [(String, String -> X ())] [(String, String -> X ())] WorkspaceConfig+wsActions = Summable wsActions_ (\x c -> c { wsActions_ = x }) (++)++-- | A convenience for just modifying one entry in 'wsNames', in case you only+-- want a few named workspaces. Example:+--+-- >     wsSetName 1 "mail"+-- >     wsSetName 2 "web"+wsSetName :: Int -> String -> Arr WorkspaceConfig WorkspaceConfig+wsSetName index newName = wsNames =. zipWith (curry maybeSet) [0..]+  where maybeSet (i, oldName) | i == (index - 1) = newName+                              | otherwise = oldName++-- $screens+-- 'withScreens' provides a convenient mechanism to set keybindings for moving+-- between screens, much like 'withWorkspaces'.++-- | Configure screen keys through a Prime-like interface:+--+-- >   withScreens $ do+-- >     sKeys =: ["e", "r"]+--+-- This will add the necessary keybindings to 'keys'. Note that it won't remove+-- old keybindings; it's just not that clever.+withScreens :: Arr ScreenConfig ScreenConfig -> Prime l l+withScreens sarr xconf = (P.>>=) (sarr def) $ \sconf -> sprime sconf xconf+  where sprime :: ScreenConfig -> Prime l l+        sprime sconf =+          keys =+ [(mod ++ key, action sid) | (sid, key) <- zip [0..] (sKeys_ sconf),+                                              (mod, action) <- sActions_ sconf]++data ScreenConfig = ScreenConfig {+  sKeys_ :: [String],+  sActions_ :: [(String, ScreenId -> X ())]+}++instance Default ScreenConfig where+  def = ScreenConfig {+    sKeys_ = ["w", "e", "r"],+    sActions_ = [("M-", windows . onScreens W.view),+                 ("M-S-", windows . onScreens W.shift)]+  }+++-- | The list of screen keys. These are combined with the modifiers in+-- 'sActions' to form the keybindings for navigating to workspaces. Default:+-- @["w","e","r"]@.+sKeys :: Summable [String] [String] ScreenConfig+sKeys = Summable sKeys_ (\x c -> c { sKeys_ = x }) (++)++-- | Mapping from key prefix to command. Its type is @[(String, ScreenId ->+-- X())]@. Works the same as 'wsActions' except for a different function type.+--+-- Default:+--+-- > [("M-", windows . onScreens W.view),+-- >  ("M-S-", windows . onScreens W.shift)]+sActions :: Summable [(String, ScreenId -> X ())] [(String, ScreenId -> X ())] ScreenConfig+sActions = Summable sActions_ (\x c -> c { sActions_ = x }) (++)++-- | Converts a stackset transformer parameterized on the workspace type into one+-- parameterized on the screen type. For example, you can use @onScreens W.view+-- 0@ to navigate to the workspace on the 0th screen. If the screen id is not+-- recognized, the returned transformer acts as an identity function.+onScreens :: Eq s => (i -> W.StackSet i l a s sd -> W.StackSet i l a s sd) ->+                     s -> W.StackSet i l a s sd -> W.StackSet i l a s sd+onScreens f sc ws = maybe id f (W.lookupWorkspace sc ws) ws++-- $layout+-- Layouts are special. You can't modify them using the @=:@ or @=.@ operator.+-- You need to use the following functions.++-- | Add a layout to the list of layouts choosable with mod-space. For instance:+--+-- > import XMonad.Layout.Tabbed+-- > ...+-- >   addLayout simpleTabbed+addLayout :: (LayoutClass l Window, LayoutClass r Window) => r Window -> Prime l (Choose l r)+addLayout r c = return c { X.layoutHook = X.layoutHook c ||| r }++-- | Reset the layoutHook from scratch. For instance, to get rid of the wide+-- layout:+--+-- >   resetLayout $ Tall 1 (3/100) (1/2) ||| Full+--+-- (The dollar is like an auto-closing parenthesis, so all the stuff to the+-- right of it is treated like an argument to resetLayout.)+resetLayout :: (LayoutClass r Window) => r Window -> Prime l r+resetLayout r c = return c { X.layoutHook = r }++-- | Modify your 'layoutHook' with some wrapper function. You probably want to call+-- this after you're done calling 'addLayout'. Example:+--+-- > import XMonad.Layout.NoBorders+-- > ...+-- >   modifyLayout smartBorders+modifyLayout :: (LayoutClass r Window) => (l Window -> r Window) -> Prime l r+modifyLayout f c = return c { X.layoutHook = f $ X.layoutHook c }++-- $update+-- Finally, there are a few contrib modules that bundle multiple attribute+-- updates together. There are three types: 1) wholesale replacements for the+-- default config, 2) pure functions on the config, and 3) IO actions on the+-- config. The syntax for each is different. Examples:+--+-- 1) To start with a 'XMonad.Config.Gnome.gnomeConfig' instead of the default,+-- we use 'startWith':+--+-- > import XMonad.Config.Gnome+-- > ...+-- >   startWith gnomeConfig+--+-- 2) 'XMonad.Hooks.UrgencyHook.withUrgencyHook' is a pure function, so we need+-- to use 'apply':+--+-- > import XMonad.Hooks.UrgencyHook+-- > ...+-- >   apply $ withUrgencyHook dzenUrgencyHook+--+-- 3) 'XMonad.Hooks.DynamicLog.xmobar' returns an @IO (XConfig l)@, so we need+-- to use 'applyIO':+--+-- > import XMonad.Hooks.DynamicLog+-- > ...+-- >   applyIO xmobar++-- | Replace the current 'XConfig' with the given one. If you use this, you+-- probably want it to be the first line of your config.+startWith :: XConfig l' -> Prime l l'+startWith = const . return++-- | Turns a pure function on 'XConfig' into a 'Prime'.+apply :: (XConfig l -> XConfig l') -> Prime l l'+apply f = return . f++-- | Turns an IO function on 'XConfig' into a 'Prime'.+applyIO :: (XConfig l -> IO (XConfig l')) -> Prime l l'+applyIO = id  -- This is here in case we want to change the Prime type later.++-- $example+-- As an example, I've included below a subset of my current config. Note that+-- my import statements specify individual identifiers in parentheticals.+-- That's optional. The default is to import the entire module. I just find it+-- helpful to remind me where things came from.+--+-- > {-# LANGUAGE RebindableSyntax #-}+-- > import XMonad.Config.Prime+-- >+-- > import XMonad.Actions.CycleWS (prevWS, nextWS)+-- > import XMonad.Actions.SwapWorkspaces (swapWithCurrent)+-- > import XMonad.Actions.WindowNavigation (withWindowNavigation)+-- > import XMonad.Layout.Fullscreen (fullscreenSupport)+-- > import XMonad.Layout.NoBorders (smartBorders)+-- > import XMonad.Layout.Tabbed (simpleTabbed)+-- >+-- > main = xmonad $ do+-- >   modMask =: mod4Mask+-- >   normalBorderColor =: "#222222"+-- >   terminal =: "urxvt"+-- >   focusFollowsMouse =: False+-- >   resetLayout $ Tall 1 (3/100) (1/2) ||| simpleTabbed+-- >   modifyLayout smartBorders+-- >   apply fullscreenSupport+-- >   applyIO $ withWindowNavigation (xK_w, xK_a, xK_s, xK_d)+-- >   withWorkspaces $ do+-- >     wsKeys =+ ["0"]+-- >     wsActions =+ [("M-M1-", windows . swapWithCurrent)]+-- >   keys =+ [+-- >       ("M-,",                      sendMessage $ IncMasterN (-1)),+-- >       ("M-.",                      sendMessage $ IncMasterN 1),+-- >       ("M-M1-d",                   spawn "date | dzen2 -fg '#eeeeee' -p 2"),+-- >       ("C-S-q",                    return ()),+-- >       ("<XF86AudioLowerVolume>",   spawn "amixer set Master 5%-"),+-- >       ("<XF86AudioRaiseVolume>",   spawn "amixer set Master 5%+"),+-- >       ("M-M1-x",                   kill),+-- >       ("M-i",                      prevWS),+-- >       ("M-o",                      nextWS)+-- >     ]++-- $troubleshooting+-- === Only the last line of my config seems to take effect. What gives?+-- You're missing the @{-\# LANGUAGE RebindableSyntax \#-}@ line at the top.+--+-- === How do I do use normal monads like 'X' or 'IO'?+-- Here are a couple of ways:+--+-- > import qualified Prelude as P+-- > ...+-- > test1, test2 :: X ()+-- > test1 = spawn "echo Hi" P.>> spawn "echo Bye"+-- > test2 = do spawn "echo Hi"+-- >            spawn "echo Bye"+-- >   where (>>) = (P.>>)+--+-- === How do I use the old keyboard syntax?+-- You can use 'apply' and supply your own Haskell function. For instance:+--+-- > apply $ flip additionalKeys $ [((mod1Mask, xK_z), spawn "date | dzen2 -fg '#eeeeee' -p 2")]+--+-- === How do I run a command before xmonad starts (like 'spawnPipe')?+-- If you're using it for a status bar, see if 'XMonad.Hooks.DynamicLog.dzen'+-- or 'XMonad.Hooks.DynamicLog.xmobar' does what you want. If so, you can apply+-- it with 'applyIO'.+--+-- If not, you can write your own @XConfig l -> IO (XConfig l)@ and apply it+-- with 'applyIO'. When writing this function, see the above tip about using+-- normal monads.+--+-- Alternatively, you could do something like this this:+--+-- > import qualified Prelude as P (>>)+-- >+-- > main =+-- >   openFile ".xmonad.log" AppendMode >>= \log ->+-- >   hSetBuffering log LineBuffering P.>>+-- >   (xmonad $ do+-- >      nothing -- Prime config here.+-- >   )
XMonad/Config/Sjanssen.hs view
@@ -1,5 +1,11 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}-module XMonad.Config.Sjanssen (sjanssenConfig) where+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Config.Sjanssen+-- Description :  Spencer Janssen's xmonad config.+--+------------------------------------------------------------------------+module XMonad.Config.Sjanssen {-# DEPRECATED "This module contains a personal configuration, to be removed from xmonad-contrib.  If you use this module, please copy the relevant parts to your configuration or obtain a copy of it on https://xmonad.org/configurations.html and include it as a local module." #-} (sjanssenConfig) where  import XMonad hiding (Tall(..)) import qualified XMonad.StackSet as W@@ -21,22 +27,22 @@ import qualified Data.Map as M  sjanssenConfig =-    ewmh $ defaultConfig+    docks $ ewmh $ def         { terminal = "exec urxvt"         , workspaces = ["irc", "web"] ++ map show [3 .. 9 :: Int]-        , mouseBindings = \(XConfig {modMask = modm}) -> M.fromList $-                [ ((modm, button1), (\w -> focus w >> mouseMoveWindow w))-                , ((modm, button2), (\w -> focus w >> windows W.swapMaster))-                , ((modm.|. shiftMask, button1), (\w -> focus w >> mouseResizeWindow w)) ]-        , keys = \c -> mykeys c `M.union` keys defaultConfig c+        , mouseBindings = \XConfig {modMask = modm} -> M.fromList+                [ ((modm, button1), \w -> focus w >> mouseMoveWindow w)+                , ((modm, button2), \w -> focus w >> windows W.swapMaster)+                , ((modm.|. shiftMask, button1), \w -> focus w >> mouseResizeWindow w) ]+        , keys = \c -> mykeys c `M.union` keys def c         , logHook = dynamicLogString sjanssenPP >>= xmonadPropLog         , layoutHook  = modifiers layouts         , manageHook  = composeAll [className =? x --> doShift w                                     | (x, w) <- [ ("Firefox", "web")                                                 , ("Ktorrent", "7")                                                 , ("Amarokapp", "7")]]-                        <+> manageHook defaultConfig <+> manageDocks <+> manageSpawn-                        <+> (isFullscreen --> doFullFloat)+                        <> manageHook def <> manageSpawn+                        <> (isFullscreen --> doFullFloat)         , startupHook = mapM_ spawnOnce spawns         }  where@@ -50,20 +56,20 @@              , "trayer --transparent true --expand true --align right "                ++ "--edge bottom --widthtype request" ] -    mykeys (XConfig {modMask = modm}) = M.fromList $+    mykeys XConfig{modMask = modm} = M.fromList         [((modm,               xK_p     ), shellPromptHere myPromptConfig)         ,((modm .|. shiftMask, xK_Return), spawnHere =<< asks (terminal . config))         ,((modm .|. shiftMask, xK_c     ), kill1)         ,((modm .|. shiftMask .|. controlMask, xK_c     ), kill)-        ,((modm .|. shiftMask, xK_0     ), windows $ copyToAll)+        ,((modm .|. shiftMask, xK_0     ), windows copyToAll)         ,((modm,               xK_z     ), layoutScreens 2 $ TwoPane 0.5 0.5)         ,((modm .|. shiftMask, xK_z     ), rescreen)         , ((modm             , xK_b     ), sendMessage ToggleStruts)         ]      myFont = "xft:Bitstream Vera Sans Mono:pixelsize=10"-    myTheme = defaultTheme { fontName = myFont }-    myPromptConfig = defaultXPConfig+    myTheme = def { fontName = myFont }+    myPromptConfig = def                         { position = Top                         , font = myFont                         , showCompletionOnTab = True
XMonad/Config/Xfce.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Config.Xfce+-- Description  : Config for integrating xmonad with Xfce. -- Copyright    : (c) Ivan Miljenovic <Ivan.Miljenovic@gmail.com> -- License      : BSD --@@ -16,7 +17,8 @@ module XMonad.Config.Xfce (     -- * Usage     -- $usage-    xfceConfig+    xfceConfig,+    desktopLayoutModifiers     ) where  import XMonad@@ -25,7 +27,7 @@ import qualified Data.Map as M  -- $usage--- To use this module, start with the following @~\/.xmonad\/xmonad.hs@:+-- To use this module, start with the following @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Config.Xfce@@ -35,10 +37,10 @@ -- For examples of how to further customize @xfceConfig@ see "XMonad.Config.Desktop".  xfceConfig = desktopConfig-    { terminal = "Terminal"-    , keys     = xfceKeys <+> keys desktopConfig }+    { terminal = "xfce4-terminal"+    , keys     = xfceKeys <> keys desktopConfig } -xfceKeys (XConfig {modMask = modm}) = M.fromList $+xfceKeys XConfig{modMask = modm} = M.fromList     [ ((modm,               xK_p), spawn "xfrun4")     , ((modm .|. shiftMask, xK_p), spawn "xfce4-appfinder")     , ((modm .|. shiftMask, xK_q), spawn "xfce4-session-logout")
+ XMonad/Config/dmwit.xmobarrc view
@@ -0,0 +1,10 @@+Config {+    font         = "xft:Monospace:pixelsize=14,-*-*-*-r-*-*-16-*-*-*-*-*-*-*",+    bgColor      = "#000040",+    fgColor      = "#80c0ff",+    position     = TopSize C 100 26,+    lowerOnStart = True,+    commands     = [ Run Com "date" ["+%H:%M"] "" 30 ],+    sepChar      = "%",+    alignSep     = "}{"+}
XMonad/Doc.hs view
@@ -49,9 +49,9 @@ xmonad is a tiling window manager for X. The xmonad-contrib library collects third party tiling algorithms, hooks, configurations, scripts, and other extensions to xmonad.  The source for this library-is available from <http://code.haskell.org/XMonadContrib> via darcs:+is available from <https://github.com/xmonad/xmonad-contrib> via git: -> darcs get http://code.haskell.org/XMonadContrib+> git clone https://github.com/xmonad/xmonad-contrib.git  Each stable release of xmonad is accompanied by a stable release of the contrib library, which you should use if (and only if) you're
XMonad/Doc/Configuring.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Doc.Configuring+-- Description :  Brief xmonad tutorial. -- Copyright   :  (C) 2007 Don Stewart and Andrea Rossato -- License     :  BSD3 --@@ -8,11 +9,14 @@ -- Stability   :  unstable -- Portability :  portable ----- This is a brief tutorial that will teach you how to create a--- basic xmonad configuration.+-- This is a brief tutorial that will teach you how to create a basic+-- xmonad configuration.  For a more comprehensive tutorial, see the+-- <https://xmonad.org/TUTORIAL.html xmonad website>. -- -- For more detailed instructions on extending xmonad with the--- xmonad-contrib library, see "XMonad.Doc.Extending".+-- xmonad-contrib library, see+-- <https://xmonad.org/TUTORIAL.html the tutorial>+-- and "XMonad.Doc.Extending". -- ----------------------------------------------------------------------------- @@ -84,7 +88,7 @@ > >    import XMonad >->    main = xmonad $ defaultConfig+>    main = xmonad $ def >        { borderWidth        = 2 >        , terminal           = "urxvt" >        , normalBorderColor  = "#cccccc"@@ -148,4 +152,3 @@ is started.  -}-
XMonad/Doc/Developing.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Doc.Developing+-- Description :  Brief overview of the xmonad internals. -- Copyright   :  (C) 2007 Andrea Rossato -- License     :  BSD3 --@@ -67,6 +68,11 @@ --------------------------------------------------------------------------------  {- $writing++Here are some libraries that may be useful when writing your own module:++  - XMonad.Prelude: Re-export commonly used functions from prelude, as+    well as some xmonad-specific helpers. -}  {- $xmonad-libs@@ -80,7 +86,7 @@  Basically, xmonad and the xmonad-contrib libraries let users write their own window manager in just a few lines of code. While-@~\/.xmonad\/xmonad.hs@ at first seems to be simply a configuration+@xmonad.hs@ at first seems to be simply a configuration file, it is actually a complete Haskell program which uses the xmonad and xmonad-contrib libraries to create a custom window manager. @@ -100,13 +106,13 @@ xmonad installs a binary, @xmonad@, which must be executed by the Xsession starting script. This binary, whose code can be read in @Main.hs@ of the xmonad source tree, will use 'XMonad.Core.recompile'-to run @ghc@ in order to build a binary from @~\/.xmonad\/xmonad.hs@.+to run @ghc@ in order to build a binary from @xmonad.hs@. If this compilation process fails, for any reason, a default @main@ entry point will be used, which calls the 'XMonad.Main.xmonad' function with a default configuration.  Thus, the real @main@ entry point, the one that even the users' custom-window manager application in @~\/.xmonad\/xmonad.hs@ must call, is+window manager application in @xmonad.hs@ must call, is the 'XMonad.Main.xmonad' function. This function takes a configuration as its only argument, whose type ('XMonad.Core.XConfig') is defined in "XMonad.Core".@@ -243,32 +249,13 @@  {- $style -These are the coding guidelines for contributing to xmonad and the-xmonad contributed extensions.--* Comment every top level function (particularly exported funtions), and-  provide a type signature.--* Use Haddock syntax in the comments (see below).--* Follow the coding style of the other modules.--* Code should be compilable with "ghc-options: -Wall -Werror" set in the-xmonad-contrib.cabal file. There should be no warnings.--* Code should be free of any warnings or errors from the Hlint tool; use your-  best judgement on some warnings like eta-reduction or bracket removal, though.--* Partial functions should be avoided: the window manager should not-  crash, so never call 'error' or 'undefined'.--* Tabs are /illegal/. Use 4 spaces for indenting.--* Any pure function added to the core must have QuickCheck properties-  precisely defining its behaviour. Tests for everything else are encouraged.+For coding style guidelines while contributing, please see the+<https://github.com/xmonad/xmonad/blob/master/CONTRIBUTING.md#style-guidelines style guidelines>+of xmonad's CONTRIBUTING.md. -For examples of Haddock documentation syntax, have a look at other-extensions.  Important points are:+For examples of Haddock documentation syntax, have a look at+<https://haskell-haddock.readthedocs.io/en/latest/markup.html its documentation>+or other extensions.  Important points are:  * Every exported function (or even better, every function) should have   a Haddock comment explaining what it does, and providing examples.@@ -285,10 +272,17 @@  To generate and view the Haddock documentation for your extension, run -> runhaskell Setup haddock+> stack haddock --no-haddock-deps -and then point your browser to @\/path\/to\/XMonadContrib\/dist\/doc\/html\/xmonad-contrib\/index.html@.+If the builds succeeds, at the end stack should tell you where the+generated @index.html@ is located. +Alternatively, you can also run++> cabal haddock++to similar effect.+ For more information, see the Haddock documentation: <http://www.haskell.org/haddock/doc/html/index.html>. @@ -301,6 +295,6 @@ {- $license  New modules should identify the author, and be submitted under the-same license as xmonad (BSD3 license or freer).+same license as xmonad (BSD3).  -}
XMonad/Doc/Extending.hs view
@@ -1,1399 +1,696 @@--------------------------------------------------------------------------------- |--- Module      :  XMonad.Doc.Extending--- Copyright   :  (C) 2007 Andrea Rossato--- License     :  BSD3------ Maintainer  :  andrea.rossato@unibz.it--- Stability   :  unstable--- Portability :  portable------ This module documents the xmonad-contrib library and--- how to use it to extend the capabilities of xmonad.------ Reading this document should not require a deep knowledge of--- Haskell; the examples are intended to be useful and understandable--- for those users who do not know Haskell and don't want to have to--- learn it just to configure xmonad.  You should be able to get by--- just fine by ignoring anything you don't understand and using the--- provided examples as templates.  However, relevant Haskell features--- are discussed when appropriate, so this document will hopefully be--- useful for more advanced Haskell users as well.------ Those wishing to be totally hardcore and develop their own xmonad--- extensions (it's easier than it sounds, we promise!) should read--- the documentation in "XMonad.Doc.Developing".------ More configuration examples may be found on the Haskell wiki:------ <http://haskell.org/haskellwiki/Xmonad/Config_archive>-----------------------------------------------------------------------------------module XMonad.Doc.Extending-    (-    -- * The xmonad-contrib library-    -- $library--    -- ** Actions-    -- $actions--    -- ** Configurations-    -- $configs--    -- ** Hooks-    -- $hooks--    -- ** Layouts-    -- $layouts--    -- ** Prompts-    -- $prompts--    -- ** Utilities-    -- $utils--    -- * Extending xmonad-    -- $extending--    -- ** Editing key bindings-    -- $keys--    -- *** Adding key bindings-    -- $keyAdding--    -- *** Removing key bindings-    -- $keyDel--    -- *** Adding and removing key bindings-    -- $keyAddDel--    -- ** Editing mouse bindings-    -- $mouse--    -- ** Editing the layout hook-    -- $layoutHook--    -- ** Editing the manage hook-    -- $manageHook--    -- ** The log hook and external status bars-    -- $logHook-    ) where----------------------------------------------------------------------------------------  The XmonadContrib Library--------------------------------------------------------------------------------------{- $library--The xmonad-contrib (xmc) library is a set of extension modules-contributed by xmonad hackers and users, which provide additional-xmonad features.  Examples include various layout modes (tabbed,-spiral, three-column...), prompts, program launchers, the ability to-manipulate windows and workspaces in various ways, alternate-navigation modes, and much more.  There are also \"meta-modules\"-which make it easier to write new modules and extensions.--This is a concise yet complete overview of the xmonad-contrib modules.-For more information about any particular module, just click on its-name to view its Haddock documentation; each module should come with-extensive documentation.  If you find a module that could be better-documented, or has incorrect documentation, please report it as a bug-(<http://code.google.com/p/xmonad/issues/list>)!---}--{- $actions--In the @XMonad.Actions@ namespace you can find modules exporting-various functions that are usually intended to be bound to key-combinations or mouse actions, in order to provide functionality-beyond the standard keybindings provided by xmonad.--See "XMonad.Doc.Extending#Editing_key_bindings" for instructions on how to-edit your key bindings.--* "XMonad.Actions.Commands":-    Allows you to run internal xmonad commands (X () actions) using-    a dmenu menu in addition to key bindings.  Requires dmenu and-    the Dmenu XMonad.Actions module.--* "XMonad.Actions.ConstrainedResize":-    Lets you constrain the aspect ratio of a floating-    window (by, say, holding shift while you resize).-    Useful for making a nice circular XClock window.--* "XMonad.Actions.CopyWindow":-    Provides bindings to duplicate a window on multiple workspaces,-    providing dwm-like tagging functionality.--* "XMonad.Actions.CycleRecentWS":-    Provides bindings to cycle through most recently used workspaces-    with repeated presses of a single key (as long as modifier key is-    held down). This is similar to how many window managers handle-    window switching.--* "XMonad.Actions.CycleSelectedLayouts":-    This module allows to cycle through the given subset of layouts.--* "XMonad.Actions.CycleWS":-    Provides bindings to cycle forward or backward through the list of-    workspaces, to move windows between workspaces, and to cycle-    between screens. Replaces the former XMonad.Actions.RotView.--* "XMonad.Actions.CycleWindows":-    Provides bindings to cycle windows up or down on the current workspace-    stack while maintaining focus in place.--* "XMonad.Actions.DeManage":-    This module provides a method to cease management of a window-    without unmapping it. "XMonad.Hooks.ManageDocks" is a-    more automated solution if your panel supports it.--* "XMonad.Actions.DwmPromote":-    Dwm-like swap function for xmonad.-    Swaps focused window with the master window. If focus is in the-    master, swap it with the next window in the stack. Focus stays in the-    master.--* "XMonad.Actions.DynamicWorkspaces":-    Provides bindings to add and delete workspaces.  Note that you may only-    delete a workspace that is already empty.--* "XMonad.Actions.FindEmptyWorkspace":-    Find an empty workspace.--* "XMonad.Actions.FlexibleManipulate":-    Move and resize floating windows without warping the mouse.--* "XMonad.Actions.FlexibleResize":-    Resize floating windows from any corner.--* "XMonad.Actions.FloatKeys":-    Move and resize floating windows.--* "XMonad.Actions.FloatSnap":-    Move and resize floating windows using other windows and the edge of the-    screen as guidelines.--* "XMonad.Actions.FocusNth":-    Focus the nth window of the current workspace.--* "XMonad.Actions.GridSelect":-    GridSelect displays items(e.g. the opened windows) in a 2D grid and lets-    the user select from it with the cursor/hjkl keys or the mouse.--* "XMonad.Actions.MessageFeedback":-    Alternative to 'XMonad.Operations.sendMessage' that provides knowledge-    of whether the message was handled, and utility functions based on-    this facility.--* "XMonad.Actions.MouseGestures":-    Support for simple mouse gestures.--* "XMonad.Actions.MouseResize":-    A layout modifier to resize windows with the mouse by grabbing the-    window's lower right corner.--* "XMonad.Actions.NoBorders":-    This module provides helper functions for dealing with window borders.--* "XMonad.Actions.OnScreen":-    Control workspaces on different screens (in xinerama mode).--* "XMonad.Actions.PerWorkspaceKeys":-    Define key-bindings on per-workspace basis.--* "XMonad.Actions.PhysicalScreens":-    Manipulate screens ordered by physical location instead of ID--* "XMonad.Actions.Plane":-    This module has functions to navigate through workspaces in a bidimensional-    manner.--* "XMonad.Actions.Promote":-    Alternate promote function for xmonad.--* "XMonad.Actions.RandomBackground":-    An action to start terminals with a random background color--* "XMonad.Actions.RotSlaves":-    Rotate all windows except the master window and keep the focus in-    place.--* "XMonad.Actions.Search":-    A module for easily running Internet searches on web sites through xmonad.-    Modeled after the handy Surfraw CLI search tools at <https://secure.wikimedia.org/wikipedia/en/wiki/Surfraw>.--* "XMonad.Actions.SimpleDate":-    An example external contrib module for XMonad.-    Provides a simple binding to dzen2 to print the date as a popup menu.--* "XMonad.Actions.SinkAll":-    (Deprecated) Provides a simple binding that pushes all floating windows on the-    current workspace back into tiling. Instead, use the more general-    "XMonad.Actions.WithAll"--* "XMonad.Actions.SpawnOn":-    Provides a way to modify a window spawned by a command(e.g shift it to the workspace-    it was launched on) by using the _NET_WM_PID property that most windows set on creation.--* "XMonad.Actions.Submap":-    A module that allows the user to create a sub-mapping of key bindings.--* "XMonad.Actions.SwapWorkspaces":-    Lets you swap workspace tags, so you can keep related ones next to-    each other, without having to move individual windows.--* "XMonad.Actions.TagWindows":-    Functions for tagging windows and selecting them by tags.--* "XMonad.Actions.TopicSpace":-    Turns your workspaces into a more topic oriented system.--* "XMonad.Actions.UpdateFocus":-    Updates the focus on mouse move in unfocused windows.--* "XMonad.Actions.UpdatePointer":-    Causes the pointer to follow whichever window focus changes to.--* "XMonad.Actions.Warp":-    Warp the pointer to a given window or screen.--* "XMonad.Actions.WindowBringer":-    dmenu operations to bring windows to you, and bring you to windows.-    That is to say, it pops up a dmenu with window names, in case you forgot-    where you left your XChat.--* "XMonad.Actions.WindowGo":-    Defines a few convenient operations for raising (traveling to) windows based on XMonad's Query-    monad, such as 'runOrRaise'.--* "XMonad.Actions.WindowMenu":-    Uses "XMonad.Actions.GridSelect" to display a number of actions related to-    window management in the center of the focused window.--* "XMonad.Actions.WindowNavigation":-    Experimental rewrite of "XMonad.Layout.WindowNavigation".--* "XMonad.Actions.WithAll":-    Provides functions for performing a given action on all windows of-    the current workspace.--* "XMonad.Actions.WorkspaceCursors":-    Like "XMonad.Actions.Plane" for an arbitrary number of dimensions.---}--{- $configs--In the @XMonad.Config@ namespace you can find modules exporting the-configurations used by some of the xmonad and xmonad-contrib-developers.  You can look at them for examples while creating your own-configuration; you can also simply import them and use them as your-own configuration, possibly with some modifications.---* "XMonad.Config.Arossato"-    This module specifies my xmonad defaults.--* "XMonad.Config.Azerty"-    Fixes some keybindings for users of French keyboard layouts.--* "XMonad.Config.Desktop"-    This module provides core desktop environment settings used-    in the Gnome, Kde, and Xfce config configs. It is also useful-    for people using other environments such as lxde, or using-    tray or panel applications without full desktop environments.--* "XMonad.Config.Gnome"--* "XMonad.Config.Kde"--* "XMonad.Config.Sjanssen"--* "XMonad.Config.Xfce"---}--{- $hooks--In the @XMonad.Hooks@ namespace you can find modules exporting-hooks. Hooks are actions that xmonad performs when certain events-occur. The two most important hooks are:--* 'XMonad.Core.manageHook': this hook is called when a new window-  xmonad must take care of is created. This is a very powerful hook,-  since it lets us examine the new window's properties and act-  accordingly. For instance, we can configure xmonad to put windows-  belonging to a given application in the float layer, not to manage-  dock applications, or open them in a given workspace. See-  "XMonad.Doc.Extending#Editing_the_manage_hook" for more information on-  customizing 'XMonad.Core.manageHook'.--* 'XMonad.Core.logHook': this hook is called when the stack of windows-  managed by xmonad has been changed, by calling the-  'XMonad.Operations.windows' function. For instance-  "XMonad.Hooks.DynamicLog" will produce a string (whose format can be-  configured) to be printed to the standard output. This can be used-  to display some information about the xmonad state in a status bar.-  See "XMonad.Doc.Extending#The_log_hook_and_external_status_bars" for more-  information.--* 'XMonad.Core.handleEventHook': this hook is called on all events handled-  by xmonad, thus it is extremely powerful. See "Graphics.X11.Xlib.Extras"-  and xmonad source and development documentation for more details.--Here is a list of the modules found in @XMonad.Hooks@:--* "XMonad.Hooks.DynamicHooks":-    One-shot and permanent ManageHooks that can be updated at runtime.--* "XMonad.Hooks.DynamicLog": for use with 'XMonad.Core.logHook'; send-  information about xmonad's state to standard output, suitable for-  putting in a status bar of some sort. See-  "XMonad.Doc.Extending#The_log_hook_and_external_status_bars".--* "XMonad.Hooks.EwmhDesktops":-    Makes xmonad use the EWMH hints to tell panel applications about its-    workspaces and the windows therein. It also allows the user to interact-    with xmonad by clicking on panels and window lists.--* "XMonad.Hooks.FadeInactive":-    Makes XMonad set the _NET_WM_WINDOW_OPACITY atom for inactive windows,-    which causes those windows to become slightly translucent if something-    like xcompmgr is running--* "XMonad.Hooks.FloatNext":-    Hook and keybindings for automatically sending the next-    spawned window(s) to the floating layer.--* "XMonad.Hooks.InsertPosition":-    Configure where new windows should be added and which window should be-    focused.--* "XMonad.Hooks.ManageDocks":-    This module provides tools to automatically manage 'dock' type programs,-    such as gnome-panel, kicker, dzen, and xmobar.--* "XMonad.Hooks.ManageHelpers": provide helper functions to be used-  in @manageHook@.--* "XMonad.Hooks.Minimize":-    Handles window manager hints to minimize and restore windows. Use-    this with XMonad.Layout.Minimize.--* "XMonad.Hooks.Place":-    Automatic placement of floating windows.--* "XMonad.Hooks.RestoreMinimized":-    (Deprecated: Use XMonad.Hooks.Minimize) Lets you restore minimized-    windows (see "XMonad.Layout.Minimize") by selecting them on a-    taskbar (listens for _NET_ACTIVE_WINDOW and WM_CHANGE_STATE).--* "XMonad.Hooks.Script":-    Provides a simple interface for running a ~\/.xmonad\/hooks script with the-    name of a hook.--* "XMonad.Hooks.ServerMode": Allows sending commands to a running xmonad process.--* "XMonad.Hooks.SetCursor":-    Set a default mouse cursor on startup.--* "XMonad.Hooks.SetWMName":-    Sets the WM name to a given string, so that it could be detected using-    _NET_SUPPORTING_WM_CHECK protocol.  May be useful for making Java GUI-    programs work.--* "XMonad.Hooks.UrgencyHook":-    UrgencyHook lets you configure an action to occur when a window demands-    your attention. (In traditional WMs, this takes the form of \"flashing\"-    on your \"taskbar.\" Blech.)--* "XMonad.Hooks.WorkspaceByPos":-    Useful in a dual-head setup: Looks at the requested geometry of-    new windows and moves them to the workspace of the non-focused-    screen if necessary.--* "XMonad.Hooks.XPropManage":-    A ManageHook matching on XProperties.---}--{- $layouts--In the @XMonad.Layout@ namespace you can find modules exporting-contributed tiling algorithms, such as a tabbed layout, a circle, a spiral,-three columns, and so on.--You will also find modules which provide facilities for combining-different layouts, such as "XMonad.Layout.Combo", "XMonad.Layout.ComboP",-"XMonad.Layout.LayoutBuilder", "XMonad.Layout.SubLayouts", or-"XMonad.Layout.LayoutCombinators".--Layouts can be also modified with layout modifiers. A general-interface for writing layout modifiers is implemented in-"XMonad.Layout.LayoutModifier".--For more information on using those modules for customizing your-'XMonad.Core.layoutHook' see "XMonad.Doc.Extending#Editing_the_layout_hook".--* "XMonad.Layout.Accordion":-    LayoutClass that puts non-focused windows in ribbons at the top and bottom-    of the screen.--* "XMonad.Layout.AutoMaster":-    Provides layout modifier AutoMaster. It separates screen in two parts --    master and slave. Size of slave area automatically changes depending on-    number of slave windows.--* "XMonad.Layout.BorderResize":-    This layout modifier will allow to resize windows by dragging their-    borders with the mouse. However, it only works in layouts or modified-    layouts that react to the SetGeometry message.-    "XMonad.Layout.WindowArranger" can be used to create such a setup.-    BorderResize is probably most useful in floating layouts.--* "XMonad.Layout.BoringWindows":-    BoringWindows is an extension to allow windows to be marked boring--* "XMonad.Layout.CenteredMaster":-    Two layout modifiers. centerMaster places master window at center,-    on top of all other windows, which are managed by base layout.-    topRightMaster is similar, but places master window in top right corner-    instead of center.--* "XMonad.Layout.Circle":-    Circle is an elliptical, overlapping layout.--* "XMonad.Layout.Column":-    Provides Column layout that places all windows in one column. Windows-    heights are calculated from equation: H1/H2 = H2/H3 = ... = q, where q is-    given. With Shrink/Expand messages you can change the q value.--* "XMonad.Layout.Combo":-    A layout that combines multiple layouts.--* "XMonad.Layout.ComboP":-    A layout that combines multiple layouts and allows to specify where to put-    new windows.--* "XMonad.Layout.Cross":-    A Cross Layout with the main window in the center.--* "XMonad.Layout.Decoration":-    A layout modifier and a class for easily creating decorated-    layouts.--* "XMonad.Layout.DecorationMadness":-    A collection of decorated layouts: some of them may be nice, some-    usable, others just funny.--* "XMonad.Layout.Dishes":-    Dishes is a layout that stacks extra windows underneath the master-    windows.--* "XMonad.Layout.DragPane":-    Layouts that splits the screen either horizontally or vertically and-    shows two windows.  The first window is always the master window, and-    the other is either the currently focused window or the second window in-    layout order. See also "XMonad.Layout.MouseResizableTall"--* "XMonad.Layout.DwmStyle":-    A layout modifier for decorating windows in a dwm like style.--* "XMonad.Layout.FixedColumn":-    A layout much like Tall, but using a multiple of a window's minimum-    resize amount instead of a percentage of screen to decide where to-    split. This is useful when you usually leave a text editor or-    terminal in the master pane and like it to be 80 columns wide.--* "XMonad.Layout.Gaps":-    Create manually-sized gaps along edges of the screen which will not-    be used for tiling, along with support for toggling gaps on and-    off. You probably want "XMonad.Hooks.ManageDocks".--* "XMonad.Layout.Grid":-    A simple layout that attempts to put all windows in a square grid.--* "XMonad.Layout.GridVariants":-    Two layouts: one is a variant of the Grid layout that allows the-    desired aspect ratio of windows to be specified.  The other is like-    Tall but places a grid with fixed number of rows and columns in the-    master area and uses an aspect-ratio-specified layout for the-    slaves.--* "XMonad.Layout.HintedGrid":-    A not so simple layout that attempts to put all windows in a square grid-    while obeying their size hints.--* "XMonad.Layout.HintedTile":-    A gapless tiled layout that attempts to obey window size hints,-    rather than simply ignoring them.--* "XMonad.Layout.IM":-    Layout modfier suitable for workspace with multi-windowed instant messenger-    (like Psi or Tkabber).--* "XMonad.Layout.IndependentScreens":-    Utility functions for simulating independent sets of workspaces on-    each screen (like dwm's workspace model), using internal tags to-    distinguish workspaces associated with each screen.--* "XMonad.Layout.LayoutBuilder":-    A layout combinator that sends a specified number of windows to one rectangle-    and the rest to another.--* "XMonad.Layout.LayoutCombinators":-    The "XMonad.Layout.LayoutCombinators" module provides combinators-    for easily combining multiple layouts into one composite layout, as-    well as a way to jump directly to any particular layout (say, with-    a keybinding) without having to cycle through other layouts to get-    to it.--* "XMonad.Layout.LayoutHints":-    Make layouts respect size hints.--* "XMonad.Layout.LayoutModifier":-    A module for writing easy layout modifiers, which do not define a-    layout in and of themselves, but modify the behavior of or add new-    functionality to other layouts.  If you ever find yourself writing-    a layout which takes another layout as a parameter, chances are you-    should be writing a LayoutModifier instead!--    In case it is not clear, this module is not intended to help you-    configure xmonad, it is to help you write other extension modules.-    So get hacking!--* "XMonad.Layout.LayoutScreens":-    Divide a single screen into multiple screens.--* "XMonad.Layout.LimitWindows":-    A layout modifier that limits the number of windows that can be shown.--* "XMonad.Layout.MagicFocus":-    Automagically put the focused window in the master area.--* "XMonad.Layout.Magnifier":-    Screenshot  :  <http://caladan.rave.org/magnifier.png>-    This is a layout modifier that will make a layout increase the size-    of the window that has focus.--* "XMonad.Layout.Master":-    Layout modfier that adds a master window to another layout.--* "XMonad.Layout.Maximize":-    Temporarily yanks the focused window out of the layout to mostly fill-    the screen.--* "XMonad.Layout.MessageControl":-    Provides message escaping and filtering facilities which-    help control complex nested layouts.--* "XMonad.Layout.Minimize":-    Makes it possible to minimize windows, temporarily removing them-    from the layout until they are restored.--* "XMonad.Layout.Monitor":-    Layout modfier for displaying some window (monitor) above other windows--* "XMonad.Layout.Mosaic":-    Based on MosaicAlt, but aspect ratio messages always change the aspect-    ratios, and rearranging the window stack changes the window sizes.--* "XMonad.Layout.MosaicAlt":-    A layout which gives each window a specified amount of screen space-    relative to the others. Compared to the 'Mosaic' layout, this one-    divides the space in a more balanced way.--* "XMonad.Layout.MouseResizableTile":-    A layout in the spirit of "XMonad.Layout.ResizableTile", but with the option-    to use the mouse to adjust the layout.--* "XMonad.Layout.MultiToggle":-    Dynamically apply and unapply transformers to your window layout. This can-    be used to rotate your window layout by 90 degrees, or to make the-    currently focused window occupy the whole screen (\"zoom in\") then undo-    the transformation (\"zoom out\").--* "XMonad.Layout.Named":-    A module for assigning a name to a given layout.--* "XMonad.Layout.NoBorders":-    Make a given layout display without borders.  This is useful for-    full-screen or tabbed layouts, where you don't really want to waste a-    couple of pixels of real estate just to inform yourself that the visible-    window has focus.--* "XMonad.Layout.NoFrillsDecoration":-    Most basic version of decoration for windows without any additional-    modifications. In contrast to "XMonad.Layout.SimpleDecoration" this will-    result in title bars that span the entire window instead of being only the-    length of the window title.--* "XMonad.Layout.OneBig":-    Places one (master) window at top left corner of screen, and other (slave)-    windows at the top.--* "XMonad.Layout.PerWorkspace":-    Configure layouts on a per-workspace basis: use layouts and apply-    layout modifiers selectively, depending on the workspace.--* "XMonad.Layout.Reflect":-    Reflect a layout horizontally or vertically.--* "XMonad.Layout.ResizableTile":-    More useful tiled layout that allows you to change a width\/height of window.-    See also "XMonad.Layout.MouseResizableTile".--* "XMonad.Layout.ResizeScreen":-    A layout transformer to have a layout respect a given screen-    geometry. Mostly used with "Decoration" (the Horizontal and the-    Vertical version will react to SetTheme and change their dimension-    accordingly.--* "XMonad.Layout.Roledex":-    This is a completely pointless layout which acts like Microsoft's Flip 3D--* "XMonad.Layout.ShowWName":-    This is a layout modifier that will show the workspace name--* "XMonad.Layout.SimpleDecoration":-    A layout modifier for adding simple decorations to the windows of a-    given layout. The decorations are in the form of ion-like tabs-    for window titles.--* "XMonad.Layout.SimpleFloat":-    A basic floating layout.--* "XMonad.Layout.Simplest":-    A very simple layout. The simplest, afaik. Used as a base for-    decorated layouts.--* "XMonad.Layout.SimplestFloat":-    A basic floating layout like SimpleFloat but without the decoration.--* "XMonad.Layout.Spacing":-    Add a configurable amount of space around windows.--* "XMonad.Layout.Spiral":-    A spiral tiling layout.--* "XMonad.Layout.Square":-    A layout that splits the screen into a square area and the rest of the-    screen.-    This is probably only ever useful in combination with-    "XMonad.Layout.Combo".-    It sticks one window in a square region, and makes the rest-    of the windows live with what's left (in a full-screen sense).--* "XMonad.Layout.StackTile":-    A stacking layout, like dishes but with the ability to resize master pane.-    Mostly useful on small screens.--* "XMonad.Layout.SubLayouts":-    A layout combinator that allows layouts to be nested.--* "XMonad.Layout.TabBarDecoration":-    A layout modifier to add a bar of tabs to your layouts.--* "XMonad.Layout.Tabbed":-    A tabbed layout for the Xmonad Window Manager--* "XMonad.Layout.ThreeColumns":-    A layout similar to tall but with three columns. With 2560x1600 pixels this-    layout can be used for a huge main window and up to six reasonable sized-    slave windows.--* "XMonad.Layout.ToggleLayouts":-    A module to toggle between two layouts.--* "XMonad.Layout.TwoPane":-    A layout that splits the screen horizontally and shows two windows.  The-    left window is always the master window, and the right is either the-    currently focused window or the second window in layout order.--* "XMonad.Layout.WindowArranger":-    This is a pure layout modifier that will let you move and resize-    windows with the keyboard in any layout.--* "XMonad.Layout.WindowNavigation":-    WindowNavigation is an extension to allow easy navigation of a workspace.-    See also "XMonad.Actions.WindowNavigation".--* "XMonad.Layout.WorkspaceDir":-    WorkspaceDir is an extension to set the current directory in a workspace.-    Actually, it sets the current directory in a layout, since there's no way I-    know of to attach a behavior to a workspace.  This means that any terminals-    (or other programs) pulled up in that workspace (with that layout) will-    execute in that working directory.  Sort of handy, I think.-    Note this extension requires the 'directory' package to be installed.---}--{- $prompts--In the @XMonad.Prompt@ name space you can find modules providing-graphical prompts for getting user input and using it to perform-various actions.--The "XMonad.Prompt" provides a library for easily writing new prompt-modules.--These are the available prompts:--* "XMonad.Prompt.AppLauncher":-    A module for launch applicationes that receive parameters in the command-    line. The launcher call a prompt to get the parameters.--* "XMonad.Prompt.AppendFile":-    A prompt for appending a single line of text to a file.  Useful for-    keeping a file of notes, things to remember for later, and so on----    using a keybinding, you can write things down just about as quickly-    as you think of them, so it doesn't have to interrupt whatever else-    you're doing.-    Who knows, it might be useful for other purposes as well!--* "XMonad.Prompt.DirExec":-    A directory file executables prompt for XMonad. This might be useful if you-    don't want to have scripts in your PATH environment variable (same-    executable names, different behavior) - otherwise you might want to use-    "XMonad.Prompt.Shell" instead - but you want to have easy access to these-    executables through the xmonad's prompt.--* "XMonad.Prompt.Directory":-    A directory prompt for XMonad--* "XMonad.Prompt.Email":-    A prompt for sending quick, one-line emails, via the standard GNU-    \'mail\' utility (which must be in your $PATH).  This module is-    intended mostly as an example of using "XMonad.Prompt.Input" to-    build an action requiring user input.--* "XMonad.Prompt.Input":-    A generic framework for prompting the user for input and passing it-    along to some other action.--* "XMonad.Prompt.Layout":-    A layout-selection prompt for XMonad--* "XMonad.Prompt.Man":-    A manual page prompt for XMonad window manager.-    TODO-    * narrow completions by section number, if the one is specified-    (like @\/etc\/bash_completion@ does)--* "XMonad.Prompt.RunOrRaise":-    A prompt for XMonad which will run a program, open a file,-    or raise an already running program, depending on context.--* "XMonad.Prompt.Shell":-    A shell prompt for XMonad--* "XMonad.Prompt.Ssh":-    A ssh prompt for XMonad--* "XMonad.Prompt.Theme":-    A prompt for changing the theme of the current workspace--* "XMonad.Prompt.Window":-    xprompt operations to bring windows to you, and bring you to windows.--* "XMonad.Prompt.Workspace":-    A workspace prompt for XMonad--* "XMonad.Prompt.XMonad":-    A prompt for running XMonad commands--Usually a prompt is called by some key binding. See-"XMonad.Doc.Extending#Editing_key_bindings", which includes examples-of adding some prompts.---}--{- $utils--In the @XMonad.Util@ namespace you can find modules exporting various-utility functions that are used by the other modules of the-xmonad-contrib library.--There are also utilities for helping in configuring xmonad or using-external utilities.--A non complete list with a brief description:--* "XMonad.Util.Cursor": configure the default cursor/pointer glyph.--* "XMonad.Util.CustomKeys": configure key bindings (see-  "XMonad.Doc.Extending#Editing_key_bindings").--* "XMonad.Util.Dmenu":-    A convenient binding to dmenu.-    Requires the process-1.0 package--* "XMonad.Util.Dzen":-    Handy wrapper for dzen. Requires dzen >= 0.2.4.--* "XMonad.Util.EZConfig": configure key bindings easily, including a-  parser for writing key bindings in "M-C-x" style.--* "XMonad.Util.Font": A module for abstracting a font facility over-  Core fonts and Xft--* "XMonad.Util.Invisible":-    A data type to store the layout state--* "XMonad.Util.Loggers":-    A collection of simple logger functions and formatting utilities-    which can be used in the 'XMonad.Hooks.DynamicLog.ppExtras' field of-    a pretty-printing status logger format. See "XMonad.Hooks.DynamicLog"-    for more information.--* "XMonad.Util.NamedActions":-    A wrapper for keybinding configuration that can list the available-    keybindings.--* "XMonad.Util.NamedScratchpad":-    Like "XMonad.Util.Scratchpad" toggle windows to and from the current-    workspace. Supports several arbitrary applications at the same time.--* "XMonad.Util.NamedWindows":-    This module allows you to associate the X titles of windows with-    them.--* "XMonad.Util.Paste":-    A module for sending key presses to windows. This modules provides generalized-    and specialized functions for this task.--* "XMonad.Util.Replace":-    Implements a @--replace@ flag outside of core.--* "XMonad.Util.Run":-    This modules provides several commands to run an external process.-    It is composed of functions formerly defined in "XMonad.Util.Dmenu" (by-    Spencer Janssen), "XMonad.Util.Dzen" (by glasser\@mit.edu) and-    XMonad.Util.RunInXTerm (by Andrea Rossato).--* "XMonad.Util.Scratchpad":-    Very handy hotkey-launched toggleable floating terminal window.--* "XMonad.Util.StringProp":-    Internal utility functions for storing Strings with the root window.-    Used for global state like IORefs with string keys, but more latency,-    persistent between xmonad restarts.--* "XMonad.Util.Themes":-    A (hopefully) growing collection of themes for decorated layouts.--* "XMonad.Util.Timer":-    A module for setting up timers--* "XMonad.Util.Types":-    Miscellaneous commonly used types.--* "XMonad.Util.WindowProperties":-    EDSL for specifying window properties; various utilities related to window-    properties.--* "XMonad.Util.XSelection":-    A module for accessing and manipulating X Window's mouse selection (the buffer used in copy and pasting).-    'getSelection' and 'putSelection' are adaptations of Hxsel.hs and Hxput.hs from the XMonad-utils--* "XMonad.Util.XUtils":-    A module for painting on the screen---}----------------------------------------------------------------------------------------  Extending Xmonad--------------------------------------------------------------------------------------{- $extending-#Extending_xmonad#--Since the @xmonad.hs@ file is just another Haskell module, you may-import and use any Haskell code or libraries you wish, such as-extensions from the xmonad-contrib library, or other code you write-yourself.---}--{- $keys-#Editing_key_bindings#--Editing key bindings means changing the 'XMonad.Core.XConfig.keys'-field of the 'XMonad.Core.XConfig' record used by xmonad.  For-example, you could write:-->    import XMonad->->    main = xmonad $ defaultConfig { keys = myKeys }--and provide an appropriate definition of @myKeys@, such as:--> myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList->             [ ((modm, xK_F12), xmonadPrompt defaultXPConfig)->             , ((modm, xK_F3 ), shellPrompt  defaultXPConfig)->             ]--This particular definition also requires importing "XMonad.Prompt",-"XMonad.Prompt.Shell", "XMonad.Prompt.XMonad", and "Data.Map":--> import qualified Data.Map as M-> import XMonad.Prompt-> import XMonad.Prompt.Shell-> import XMonad.Prompt.XMonad--For a list of the names of particular keys (such as xK_F12, and so-on), see-<http://hackage.haskell.org/packages/archive/X11/latest/doc/html/Graphics-X11-Types.html>--Usually, rather than completely redefining the key bindings, as we did-above, we want to simply add some new bindings and\/or remove existing-ones.---}--{- $keyAdding-#Adding_key_bindings#--Adding key bindings can be done in different ways. See the end of this-section for the easiest ways. The type signature of-'XMonad.Core.XConfig.keys' is:-->    keys :: XConfig Layout -> M.Map (ButtonMask,KeySym) (X ())--In order to add new key bindings, you need to first create an-appropriate 'Data.Map.Map' from a list of key bindings using-'Data.Map.fromList'.  This 'Data.Map.Map' of new key bindings then-needs to be joined to a 'Data.Map.Map' of existing bindings using-'Data.Map.union'.--Since we are going to need some of the functions of the "Data.Map"-module, before starting we must first import this modules:-->    import qualified Data.Map as M---For instance, if you have defined some additional key bindings like-these:-->    myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList->             [ ((modm, xK_F12), xmonadPrompt defaultXPConfig)->             , ((modm, xK_F3 ), shellPrompt  defaultXPConfig)->             ]--then you can create a new key bindings map by joining the default one-with yours:-->    newKeys x  = myKeys x `M.union` keys defaultConfig x--Finally, you can use @newKeys@ in the 'XMonad.Core.XConfig.keys' field-of the configuration:-->    main = xmonad $ defaultConfig { keys = newKeys }--Alternatively, the '<+>' operator can be used which in this usage does exactly-the same as the explicit usage of 'M.union' and propagation of the config-argument, thanks to appropriate instances in "Data.Monoid".-->    main = xmonad $ defaultConfig { keys = myKeys <+> keys defaultConfig }--All together, your @~\/.xmonad\/xmonad.hs@ would now look like this:--->    module Main (main) where->->    import XMonad->->    import qualified Data.Map as M->    import Graphics.X11.Xlib->    import XMonad.Prompt->    import XMonad.Prompt.Shell->    import XMonad.Prompt.XMonad->->    main :: IO ()->    main = xmonad $ defaultConfig { keys = myKeys <+> keys defaultConfig }->->    myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList->             [ ((modm, xK_F12), xmonadPrompt defaultXPConfig)->             , ((modm, xK_F3 ), shellPrompt  defaultXPConfig)->             ]--There are much simpler ways to accomplish this, however, if you are-willing to use an extension module to help you configure your keys.-For instance, "XMonad.Util.EZConfig" and "XMonad.Util.CustomKeys" both-provide useful functions for editing your key bindings; "XMonad.Util.EZConfig" even lets you use emacs-style keybinding descriptions like \"M-C-<F12>\".-- -}--{- $keyDel-#Removing_key_bindings#--Removing key bindings requires modifying the 'Data.Map.Map' which-stores the key bindings.  This can be done with 'Data.Map.difference'-or with 'Data.Map.delete'.--For example, suppose you want to get rid of @mod-q@ and @mod-shift-q@-(you just want to leave xmonad running forever). To do this you need-to define @newKeys@ as a 'Data.Map.difference' between the default-map and the map of the key bindings you want to remove.  Like so:-->    newKeys x = keys defaultConfig x `M.difference` keysToRemove x->->    keysToRemove :: XConfig Layout ->    M.Map (KeyMask, KeySym) (X ())->    keysToRemove x = M.fromList->             [ ((modm              , xK_q ), return ())->             , ((modm .|. shiftMask, xK_q ), return ())->             ]--As you can see, it doesn't matter what actions we associate with the-keys listed in @keysToRemove@, so we just use @return ()@ (the-\"null\" action).--It is also possible to simply define a list of keys we want to unbind-and then use 'Data.Map.delete' to remove them. In that case we would-write something like:-->    newKeys x = foldr M.delete (keys defaultConfig x) (keysToRemove x)->->    keysToRemove :: XConfig Layout -> [(KeyMask, KeySym)]->    keysToRemove x =->             [ (modm              , xK_q )->             , (modm .|. shiftMask, xK_q )->             ]--Another even simpler possibility is the use of some of the utilities-provided by the xmonad-contrib library. Look, for instance, at-'XMonad.Util.EZConfig.removeKeys'.---}--{- $keyAddDel-#Adding_and_removing_key_bindings#--Adding and removing key bindings requires simply combining the steps-for removing and adding.  Here is an example from-"XMonad.Config.Arossato":-->    defKeys    = keys defaultConfig->    delKeys x  = foldr M.delete           (defKeys x) (toRemove x)->    newKeys x  = foldr (uncurry M.insert) (delKeys x) (toAdd    x)->    -- remove some of the default key bindings->    toRemove XConfig{modMask = modm} =->        [ (modm              , xK_j     )->        , (modm              , xK_k     )->        , (modm              , xK_p     )->        , (modm .|. shiftMask, xK_p     )->        , (modm .|. shiftMask, xK_q     )->        , (modm              , xK_q     )->        ] ++->        -- I want modm .|. shiftMask 1-9 to be free!->        [(shiftMask .|. modm, k) | k <- [xK_1 .. xK_9]]->    -- These are my personal key bindings->    toAdd XConfig{modMask = modm} =->        [ ((modm              , xK_F12   ), xmonadPrompt defaultXPConfig )->        , ((modm              , xK_F3    ), shellPrompt  defaultXPConfig )->        ] ++->        -- Use modm .|. shiftMask .|. controlMask 1-9 instead->        [( (m .|. modm, k), windows $ f i)->         | (i, k) <- zip (workspaces x) [xK_1 .. xK_9]->        ,  (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask .|. controlMask)]->        ]--You can achieve the same result using the "XMonad.Util.CustomKeys"-module; take a look at the 'XMonad.Util.CustomKeys.customKeys'-function in particular.--NOTE: modm is defined as the modMask you defined (or left as the default) in-your config.--}--{- $mouse-#Editing_mouse_bindings#--Most of the previous discussion of key bindings applies to mouse-bindings as well.  For example, you could configure button4 to close-the window you click on like so:-->    import qualified Data.Map as M->->    myMouse x  = [ (0, button4), (\w -> focus w >> kill) ]->->    newMouse x = M.union (mouseBindings defaultConfig x) (M.fromList (myMouse x))->->    main = xmonad $ defaultConfig { ..., mouseBindings = newMouse, ... }--Overriding or deleting mouse bindings works similarly.  You can also-configure mouse bindings much more easily using the-'XMonad.Util.EZConfig.additionalMouseBindings' and-'XMonad.Util.EZConfig.removeMouseBindings' functions from the-"XMonad.Util.EZConfig" module.---}--{- $layoutHook-#Editing_the_layout_hook#--When you start an application that opens a new window, when you change-the focused window, or move it to another workspace, or change that-workspace's layout, xmonad will use the 'XMonad.Core.layoutHook' for-reordering the visible windows on the visible workspace(s).--Since different layouts may be attached to different workspaces, and-you can change them, xmonad needs to know which one to use. In this-sense the layoutHook may be thought as the list of layouts that-xmonad will use for laying out windows on the screen(s).--The problem is that the layout subsystem is implemented with an-advanced feature of the Haskell programming language: type classes.-This allows us to very easily write new layouts, combine or modify-existing layouts, create layouts with internal state, etc. See-"XMonad.Doc.Extending#The_LayoutClass" for more information. This-means that we cannot simply have a list of layouts as we used to have-before the 0.5 release: a list requires every member to belong to the-same type!--Instead the combination of layouts to be used by xmonad is created-with a specific layout combinator: 'XMonad.Layout.|||'.--Suppose we want a list with the 'XMonad.Layout.Full',-'XMonad.Layout.Tabbed.tabbed' and-'XMonad.Layout.Accordion.Accordion' layouts. First we import, in our-@~\/.xmonad\/xmonad.hs@, all the needed modules:-->    import XMonad->->    import XMonad.Layout.Tabbed->    import XMonad.Layout.Accordion--Then we create the combination of layouts we need:-->    mylayoutHook = Full ||| tabbed shrinkText defaultTheme ||| Accordion---Now, all we need to do is change the 'XMonad.Core.layoutHook'-field of the 'XMonad.Core.XConfig' record, like so:-->    main = xmonad $ defaultConfig { layoutHook = mylayoutHook }--Thanks to the new combinator, we can apply a layout modifier to a-whole combination of layouts, instead of applying it to each one. For-example, suppose we want to use the-'XMonad.Layout.NoBorders.noBorders' layout modifier, from the-"XMonad.Layout.NoBorders" module (which must be imported):-->    mylayoutHook = noBorders (Full ||| tabbed shrinkText defaultTheme ||| Accordion)--If we want only the tabbed layout without borders, then we may write:-->    mylayoutHook = Full ||| noBorders (tabbed shrinkText defaultTheme) ||| Accordion--Our @~\/.xmonad\/xmonad.hs@ will now look like this:-->    import XMonad->->    import XMonad.Layout.Tabbed->    import XMonad.Layout.Accordion->    import XMonad.Layout.NoBorders->->    mylayoutHook = Full ||| noBorders (tabbed shrinkText defaultTheme) ||| Accordion->->    main = xmonad $ defaultConfig { layoutHook = mylayoutHook }--That's it!---}--{- $manageHook-#Editing_the_manage_hook#--The 'XMonad.Core.manageHook' is a very powerful tool for customizing-the behavior of xmonad with regard to new windows.  Whenever a new-window is created, xmonad calls the 'XMonad.Core.manageHook', which-can thus be used to perform certain actions on the new window, such as-placing it in a specific workspace, ignoring it, or placing it in the-float layer.--The default 'XMonad.Core.manageHook' causes xmonad to float MPlayer-and Gimp, and to ignore gnome-panel, desktop_window, kicker, and-kdesktop.--The "XMonad.ManageHook" module provides some simple combinators that-can be used to alter the 'XMonad.Core.manageHook' by replacing or adding-to the default actions.--Let's start by analyzing the default 'XMonad.Config.manageHook', defined-in "XMonad.Config":--->    manageHook :: ManageHook->    manageHook = composeAll->                    [ className =? "MPlayer"        --> doFloat->                    , className =? "Gimp"           --> doFloat->                    , resource  =? "desktop_window" --> doIgnore->                    , resource  =? "kdesktop"       --> doIgnore ]--'XMonad.ManageHook.composeAll' can be used to compose a list of-different 'XMonad.Config.ManageHook's. In this example we have a list-of 'XMonad.Config.ManageHook's formed by the following commands: the-Mplayer's and the Gimp's windows, whose 'XMonad.ManageHook.className'-are, respectively \"Mplayer\" and \"Gimp\", are to be placed in the-float layer with the 'XMonad.ManageHook.doFloat' function; the windows-whose resource names are respectively \"desktop_window\" and-\kdesktop\" are to be ignored with the 'XMonad.ManageHook.doIgnore'-function.--This is another example of 'XMonad.Config.manageHook', taken from-"XMonad.Config.Arossato":-->    myManageHook  = composeAll [ resource =? "realplay.bin" --> doFloat->                               , resource =? "win"          --> doF (W.shift "doc") -- xpdf->                               , resource =? "firefox-bin"  --> doF (W.shift "web")->                               ]->    newManageHook = myManageHook <+> manageHook defaultConfig---Again we use 'XMonad.ManageHook.composeAll' to compose a list of-different 'XMonad.Config.ManageHook's. The first one will put-RealPlayer on the float layer, the second one will put the xpdf-windows in the workspace named \"doc\", with 'XMonad.ManageHook.doF'-and 'XMonad.StackSet.shift' functions, and the third one will put all-firefox windows on the workspace called "web". Then we use the-'XMonad.ManageHook.<+>' combinator to compose @myManageHook@ with the-default 'XMonad.Config.manageHook' to form @newManageHook@.--Each 'XMonad.Config.ManageHook' has the form:-->    property =? match --> action--Where @property@ can be:--* 'XMonad.ManageHook.title': the window's title--* 'XMonad.ManageHook.resource': the resource name--* 'XMonad.ManageHook.className': the resource class name.--* 'XMonad.ManageHook.stringProperty' @somestring@: the contents of the-  property @somestring@.--(You can retrieve the needed information using the X utility named-@xprop@; for example, to find the resource class name, you can type--> xprop | grep WM_CLASS--at a prompt, then click on the window whose resource class you want to-know.)--@match@ is the string that will match the property value (for instance-the one you retrieved with @xprop@).--An  @action@ can be:--* 'XMonad.ManageHook.doFloat': to place the window in the float layer;--* 'XMonad.ManageHook.doIgnore': to ignore the window;--* 'XMonad.ManageHook.doF': to execute a function with the window as-  argument.--For example, suppose we want to add a 'XMonad.Config.manageHook' to-float RealPlayer, which usually has a 'XMonad.ManageHook.resource'-name of \"realplay.bin\".--First we need to import "XMonad.ManageHook":-->    import XMonad.ManageHook--Then we create our own 'XMonad.Config.manageHook':-->    myManageHook = resource =? "realplay.bin" --> doFloat--We can now use the 'XMonad.ManageHook.<+>' combinator to add our-'XMonad.Config.manageHook' to the default one:-->    newManageHook = myManageHook <+> manageHook defaultConfig--(Of course, if we wanted to completely replace the default-'XMonad.Config.manageHook', this step would not be necessary.) Now,-all we need to do is change the 'XMonad.Core.manageHook' field of the-'XMonad.Core.XConfig' record, like so:-->    main = xmonad defaultConfig { ..., manageHook = newManageHook, ... }--And we are done.--Obviously, we may wish to add more then one-'XMonad.Config.manageHook'. In this case we can use a list of hooks,-compose them all with 'XMonad.ManageHook.composeAll', and add the-composed to the default one.--For instance, if we want RealPlayer to float and thunderbird always-opened in the workspace named "mail", we can do so like this:-->    myManageHook = composeAll [ resource =? "realplay.bin"    --> doFloat->                              , resource =? "thunderbird-bin" --> doF (W.shift "mail")->                              ]--Remember to import the module that defines the 'XMonad.StackSet.shift'-function, "XMonad.StackSet", like this:-->    import qualified XMonad.StackSet as W--And then we can add @myManageHook@ to the default one to create-@newManageHook@ as we did in the previous example.--One more thing to note about this system is that if-a window matches multiple rules in a 'XMonad.Config.manageHook', /all/-of the corresponding actions will be run (in the order in which they-are defined).  This is a change from versions before 0.5, when only-the first rule that matched was run.--Finally, for additional rules and actions you can use in your-manageHook, check out the contrib module "XMonad.Hooks.ManageHelpers".---}--{- $logHook-#The_log_hook_and_external_status_bars#--When the stack of the windows managed by xmonad changes for any-reason, xmonad will call 'XMonad.Core.logHook', which can be used to-output some information about the internal state of xmonad, such as the-layout that is presently in use, the workspace we are in, the focused-window's title, and so on.--Extracting information about the internal xmonad state can be somewhat-difficult if you are not familiar with the source code. Therefore,-it's usually easiest to use a module that has been designed-specifically for logging some of the most interesting information-about the internal state of xmonad: "XMonad.Hooks.DynamicLog".  This-module can be used with an external status bar to print the produced-logs in a convenient way; the most commonly used status bars are dzen-and xmobar.--By default the 'XMonad.Core.logHook' doesn't produce anything. To-enable it you need first to import "XMonad.Hooks.DynamicLog":-->    import XMonad.Hooks.DynamicLog--Then you just need to update the 'XMonad.Core.logHook' field of the-'XMonad.Core.XConfig' record with one of the provided functions. For-example:-->    main = xmonad defaultConfig { logHook = dynamicLog }--More interesting configurations are also possible; see the-"XMonad.Hooks.DynamicLog" module for more possibilities.--You may now enjoy your extended xmonad experience.--Have fun!+{-# LANGUAGE CPP #-}+-- We need to link to the current version of xmonad-docs, but both+-- CURRENT_PACKAGE_VERSION and VERSION_xmonad_contrib contain quotation marks+-- that we can't get rid of using CPP, so as a workaround we define the+-- components separately in cpp-options and check that they're still in sync.+#if !__HLINT__ && \+    !( MIN_VERSION_xmonad_contrib(XMONAD_CONTRIB_VERSION_MAJOR, XMONAD_CONTRIB_VERSION_MINOR, XMONAD_CONTRIB_VERSION_PATCH) \+    && !MIN_VERSION_xmonad_contrib(XMONAD_CONTRIB_VERSION_MAJOR, XMONAD_CONTRIB_VERSION_MINOR, XMONAD_CONTRIB_VERSION_PATCH + 1) \+    )+#error "Please update XMONAD_CONTRIB_VERSION_* in xmonad-contrib.cabal"+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Doc.Extending+-- Description :  A module to document the xmonad-contrib library.+-- Copyright   :  (C) 2007 Andrea Rossato+-- License     :  BSD3+--+-- Maintainer  :  andrea.rossato@unibz.it+-- Stability   :  unstable+-- Portability :  portable+--+-- This module documents the xmonad-contrib library and guides you+-- through some more advanced parts of extending the capabilities of+-- xmonad.  If you're new to xmonad, you should first check out the+-- <https://xmonad.org/TUTORIAL.html tutorial> and treat this document+-- as supplemental reading.+--+-- Knowing Haskell is by no means a prerequisite for configuring xmonad+-- and the tutorial emphasizes this.  This document, however, does+-- assume a basic familiarity with the language.  This is so that we can+-- dive a bit deeper into what the different hooks do, or how to write+-- our own little functions to configure xmonad.+--+-- Those wishing to be totally hardcore and develop their own xmonad+-- extensions (it's easier than it sounds, we promise!) should read the+-- documentation in "XMonad.Doc.Developing".+--+-- More configuration examples can be found+-- <https://xmonad.org/TUTORIAL.html#closing-thoughts here>.+--+-----------------------------------------------------------------------------++module XMonad.Doc.Extending+    (+    -- * The xmonad-contrib library+    -- $library++    -- ** Actions+    -- $actions++    -- ** Hooks+    -- $hooks++    -- ** Layouts+    -- $layouts++    -- ** Prompts+    -- $prompts++    -- ** Utilities+    -- $utils++    -- * Extending xmonad+    -- $extending++    -- ** Adding key bindings+    -- $keys++    -- *** Removing key bindings+    -- $keyDel++    -- ** Editing mouse bindings+    -- $mouse++    -- ** Editing the layout hook #LayoutHook#+    -- $layoutHook++    -- ** Editing the manage hook #ManageHook#+    -- $manageHook++    ) where++--------------------------------------------------------------------------------+--+--  The XmonadContrib Library+--+--------------------------------------------------------------------------------++{- $library++The xmonad-contrib library is a set of extension modules contributed+by xmonad hackers and users that provide additional features to+xmonad.  Examples include various layout modes (tabbed, spiral,+three-column...), prompts, program launchers, the ability to+manipulate windows and workspaces in various ways, alternate+navigation modes, and much more.  There are also \"meta-modules\"+which make it easier to write new modules and extensions.++This is a description of the different namespaces in xmonad-contrib.+For more information about any particular module, go to the root of+the documentation and just click on its name to view its Haddock+documentation; each module should come with extensive documentation.+If you find a module that could be better documented, or has incorrect+documentation, please+<https://github.com/xmonad/xmonad-contrib/issues report it as a bug>!++First and foremost, xmonad defines its own prelude for commonly used+functions, as well as re-exports from @base@.++* "XMonad.Prelude":+    Utility functions and re-exports for a more ergonomic developing+    experience.++There are also other documentation modules, showing you around+individual parts of xmonad:++* "XMonad.Doc.Configuring":+    Brief tutorial that will teach you how to create a basic+    xmonad configuration.++* "XMonad.Doc.Developing":+    A brief overview of xmonad's internals.++A list of the contrib modules can be found at+<https://xmonad.github.io/xmonad-docs/xmonad-contrib-XMONAD_CONTRIB_VERSION_MAJOR.XMONAD_CONTRIB_VERSION_MINOR.XMONAD_CONTRIB_VERSION_PATCH/>+-}++{- $actions++In the @XMonad.Actions@ namespace you can find modules exporting+various functions that are usually intended to be bound to key+combinations or mouse actions, in order to provide functionality+beyond the standard keybindings offered by xmonad.++-}++{- $hooks++In the @XMonad.Hooks@ namespace you can find modules exporting+hooks—actions that xmonad performs when certain events occur.+The three most important hooks are:++* 'XMonad.Core.manageHook': this hook is called when a new window that+  xmonad must take care of is created. This is a very powerful hook,+  since it lets us examine the new window's properties and act+  accordingly. For instance, we can configure xmonad to put windows+  belonging to a given application in the float layer, not to manage+  dock applications, or open them in a given workspace. See [Editing the+  manage hook](#g:Editing_the_manage_hook) for more information on+  customizing 'XMonad.Core.manageHook'.++* 'XMonad.Core.logHook': this hook is called when the stack of windows+  managed by xmonad changes; for example, this is invoked at the end of+  the 'XMonad.Operations.windows' function. A big application for this+  is to display some information about xmonad in a status bar. The aptly+  named "XMonad.Hooks.StatusBar" will produce a string (whose format can+  be configured) to be written, for example, to an X11 property.++* 'XMonad.Core.handleEventHook': this hook is called on all events handled+  by xmonad, thus it is extremely powerful. See "Graphics.X11.Xlib.Extras"+  and xmonad source and development documentation for more details.++-}++{- $layouts++In the @XMonad.Layout@ namespace you can find modules exporting+contributed layout algorithms, such as a tabbed layout, a circle, a spiral,+three columns, and so on.++You will also find modules which provide facilities for combining+different layouts, such as "XMonad.Layout.Combo", "XMonad.Layout.ComboP",+"XMonad.Layout.LayoutBuilder", "XMonad.Layout.SubLayouts", or+"XMonad.Layout.LayoutCombinators".++Layouts can be also modified with layout modifiers. A general+interface for writing layout modifiers is implemented in+"XMonad.Layout.LayoutModifier".++For more information on using those modules for customizing your+'XMonad.Core.layoutHook' see [Editing the layout hook](#g:LayoutHook).++-}++{- $prompts++In the @XMonad.Prompt@ namespace you can find modules providing+graphical prompts for getting user input and using it to perform+various actions.++The "XMonad.Prompt" module provides a library for easily writing new+prompts.++-}++{- $utils++In the @XMonad.Util@ namespace you can find modules exporting various+utility functions that are used by the other modules of the+@xmonad-contrib@ library.++There are also utilities for helping in configuring xmonad or using+external utilities.++-}++--------------------------------------------------------------------------------+--+--  Extending Xmonad+--+--------------------------------------------------------------------------------++{- $extending+#Extending_xmonad#++Since the @xmonad.hs@ file is just another Haskell program, you may+import and use any Haskell code or libraries you wish, such as+extensions from the xmonad-contrib library, or other code you write+yourself.++-}++{- $keys++In the+<https://github.com/xmonad/xmonad/blob/master/TUTORIAL.md#customizing-xmonad customization section>+of the tutorial we have seen how to add new keys to xmonad with the help+of the 'XMonad.Util.EZConfig.additionalKeysP' function.  But how does+that work?  Assuming that library didn't exist yet, could we write it+ourselves?++Let's concentrate on the easier case of trying to write our own+'XMonad.Util.EZConfig.additionalKeys'.  This works exactly like its+almost-namesake, but requires you to specify the keys in the "default"+style—that is:++> main :: IO ()+> main = xmonad $ def+>   `additionalKeys`+>     [ ((mod1Mask, xK_m        ), spawn "echo 'Hi, mom!' | dzen2 -p 4")+>     , ((mod1Mask, xK_BackSpace), spawn "xterm")+>     ]++The extra work that 'XMonad.Util.EZConfig.additionalKeysP' does is only+in parsing the input string (turning @"M1-m"@ into @(mod1Mask, xK_m)@).+As we have seen in the tutorial, is also allows one to write @M@ and+have xmonad pick up on the correct modifier key to use—something which+'XMonad.Util.EZConfig.additionalKeys' can't do.++Editing key bindings means changing the 'XMonad.Core.keys' field of the+'XMonad.Core.XConfig' record used by xmonad.  For example, to override+/all/ of the default bindings with our own, we would write++> import XMonad+> import Data.Map (Map)+> import qualified Data.Map as Map+>+> main :: IO ()+> main = xmonad $ def { keys = myKeys }+>  where+>   myKeys :: XConfig l -> Map (ButtonMask, KeySym) (X ())+>   myKeys conf = Map.fromList+>     [ ((mod1Mask    , xK_m        ), spawn "echo 'Hi, mom!' | dzen2 -p 4")+>     , ((modMask conf, xK_BackSpace), spawn "xterm")+>     ]++Now, obviously we don't want to do that; we only want to add to existing+bindings (or, perhaps, override some of them with our own).  Let's break+@myKeys@ down a little.  You can think of the type signature of @myKeys@+(and hence also of @keys@) like this:++>    myKeys :: UserConfig -> Map KeyPress Action++It takes some user config and, from that, produces a map that associates+certain keypresses with actions to execute.  The reason why it might+take the user config may seem a bit mysterious at first, but it is for+the simple reason that some keybindings (like the workspace switching+ones) need access to the user config.  We have already seen this above+when we queried @modMask conf@.  If it helps, think of this as a+@Reader@ monad with the config being the read-only state.++This means that, as a first guess, the type signature of our version of+'XMonad.Util.EZConfig.additionalKeys' might look like++> myAdditionalKeys :: XConfig l+>                     -- ^ Base config with xmonad's default keybindings+>                  -> (XConfig l -> Map (ButtonMask, KeySym) (X ()))+>                     -- ^ User supplied keybindings+>                  -> XConfig l+>                     -- ^ Resulting config with everything merged together++However, even assuming a correct implementation, using this is not very+ergonomic:++> main = xmonad $ def+>  `myAdditionalKeys`+>    (\conf -> Map.fromList+>      [ ((mod1Mask    , xK_m        ), spawn "echo 'Hi, mom!' | dzen2 -p 4")+>      , ((modMask conf, xK_BackSpace), spawn "xterm")+>      ])++Having to specify a lambda with parentheses and call+'Data.Map.Strict.fromList' does not make for a good user experience.+Since one /always/ has to call that function anyways, we may well just+accept a list from the user and transform it to a map ourselves.  As an+additional simplification, how about we don't care about the config+argument at all and simply ask the user for a list?  The resulting+signature++> myAdditionalKeys :: XConfig l+>                  -> [(ButtonMask, KeySym), (X ())]+>                  -> XConfig l++looks exactly like what we want!  Note that this is also the time we+lose the ability to automagically fill in the correct modifier key,+since the input to @myAdditionalKeys@ is already structured data (as+opposed to just some strings that need to be parsed).++Now that we know what kind of data structure—that is, maps—we are+dealing with, the implementation of this function simply merges the two+together, preferring the user config to xmonad's defaults in case of any+conflicts.  Thankfully, someone else has already done the hard work and+written the merging function for us; it's called+'Data.Map.Strict.union'.++What's left is essentially playing "type tetris":++> myAdditionalKeys baseConf keyList =+>   let mergeKeylist conf = Map.fromList keyList `Map.union` (keys baseConf) conf+>    in baseConf { keys = mergeKeylist }++The function @mergeKeyList@ take some user config, transforms the custom+keybindings into a map (@Map.fromList keyList@), gets the keys from the+base config (remember @keys baseConf@ is again a function, morally of+type @UserConfig -> Map KeyPress Action@, and so we have to apply @conf@+to it in order to get a map!), and then merges these two maps together.+Since @mergeKeylist@ now has exactly the right type signature, we can+just set that as the keys.++If you like operators, 'Data.Monoid.<>' (or xmonad's alias for it,+'XMonad.ManageHook.<+>') does exactly the same as the explicit usage of+'Data.Map.Strict.union' because that's the specified binary operation in+the 'Data.Monoid.Monoid' instance for 'Data.Map.Strict.Map'.  Note that+the function works as expected (preferring user defined keys) because+'Data.Map.union' is /left biased/, which means that if the same key is+present in both maps it will prefer the associated value of the left+map.++Our function now works as expected:++> main :: IO ()+> main = xmonad $ def+>   `myAdditionalKeys`+>     [ ((mod1Mask, xK_m        ), spawn "echo 'Hi, mom!' | dzen2 -p 4")+>     , ((mod1Mask, xK_BackSpace), spawn "xterm")+>     ]++Lastly, if you want you can also emulate the automatic modifier+detection by 'XMonad.Util.EZConfig.additionalKeysP' by defining the bulk+of your config as a separate function++> myConfig = def { modMask = mod4Mask }++and then using that information++> main :: IO ()+> main = xmonad $ myConfig+>   `myAdditionalKeys`+>     [ ((mod, xK_m        ), spawn "echo 'Hi, mom!' | dzen2 -p 4")+>     , ((mod, xK_BackSpace), spawn "xterm")+>     ]+>  where mod = modMask myConfig++Hopefully you now feel well equipped to write some small functions that+extend xmonad an scratch a particular itch!++ -}++{- $keyDel+#Removing_key_bindings#++As we've learned, XMonad stores keybindings inside of a+'Data.Map.Strict.Map', which means that removing keybindings requires+modifying it.  This can be done with 'Data.Map.difference' or with+'Data.Map.Strict.delete'.++For example, suppose you want to entirely rid yourself of @"M-q"@ and+@"M-s-q"@ (you just want to leave xmonad running forever).  To do this+with bare @xmonad@, you need to define @newKeys@ as a+'Data.Map.Strict.difference' between the default map and the map of the+key bindings you want to remove.  Like so:++> newKeys :: XConfig l -> Map (KeyMask, KeySym) (X ())+> newKeys x = keys def x `M.difference` keysToRemove x+>+> keysToRemove :: XConfig l -> Map (KeyMask, KeySym) (X ())+> keysToRemove x = M.fromList+>          [ ((modm              , xK_q ), return ())+>          , ((modm .|. shiftMask, xK_q ), return ())+>          ]++As you can see, it doesn't matter what actions we associate with the+keys listed in @keysToRemove@, so we just use @return ()@ (the \"null\"+action).  Since @newKeys@ contains all of the default keys, you can+simply pass it to 'XMonad.Core.XConfig' as your map of keybindings:++> main :: IO ()+> main = xmonad $ def { keys = newKeys }++However, having to manually type @return ()@ every time seems like a+drag, doesn't it?  And this approach isn't at all compatible with adding+custom keybindings via 'XMonad.Util.EZConfig.additionalKeysP'!  Well,+good thing "XMonad.Util.EZConfig" also sports+'XMonad.Util.EZConfig.removeKeysP'.  You can use it as you would expect.++> main :: IO ()+> main = xmonad $ def+>   { … }+>  `removeKeysP` ["M-q", "M-S-q"]++Can you guess how 'XMonad.Util.EZConfig.removeKeysP' works?  It's almost+the same code we wrote above, just accepting a list of keybindings.  Try+to see if you can come up with an implementation of++> removeKeysP :: XConfig l -> [String] -> XConfig l++If you're done, just click on @# Source@ when viewing the+'XMonad.Util.EZConfig.removeKeysP' documentation (did you know that+Haddock lets you do that for every function?) and compare.++By the way, one can conveniently combine+'XMonad.Util.EZConfig.additionalKeysP' and+'XMonad.Util.EZConfig.removeKeysP' by just intuitively chaining them:++> main :: IO ()+> main = xmonad $ def+>   { … }+>  `additionalKeysP myKeys+>  `removeKeysP`    ["M-q", "M-S-q"]++If you don't use the @P@ alternatives of EZConfig, there is also an+aptly named 'XMonad.Util.EZConfig.removeKeys'.  Again, can you try to+come up with an implementation yourself that has the correct signature?++> removeKeys :: XConfig a -> [(KeyMask, KeySym)] -> XConfig a++In addition to 'Data.Map.Strict.delete', you will probably need to use+'foldr'.++-}++{- $mouse+#Editing_mouse_bindings#++Most of the previous discussion of key bindings applies to mouse+bindings as well.  For example, you could configure button4 to close+the window you click on like so:++>    import qualified Data.Map as M+>+>    myMouse x  = [ (0, button4), (\w -> focus w >> kill) ]+>+>    newMouse x = M.union (mouseBindings def x) (M.fromList (myMouse x))+>+>    main = xmonad $ def { ..., mouseBindings = newMouse, ... }++Overriding or deleting mouse bindings works similarly.  You can also+configure mouse bindings much more easily using the+'XMonad.Util.EZConfig.additionalMouseBindings' and+'XMonad.Util.EZConfig.removeMouseBindings' functions from the+"XMonad.Util.EZConfig" module.++-}++{- $layoutHook+#Editing_the_layout_hook#++When you start an application that opens a new window, when you change+the focused window, or move it to another workspace, or change that+workspace's layout, xmonad will use the 'XMonad.Core.layoutHook' for+reordering the visible windows on the visible workspace(s).++Since different layouts may be attached to different workspaces, and+you can change them, xmonad needs to know which one to use. In this+sense the layoutHook may be thought as the list of layouts that+xmonad will use for laying out windows on the screen(s).++The problem is that the layout subsystem is implemented with an+advanced feature of the Haskell programming language: type classes.+This allows us to very easily write new layouts, combine or modify+existing layouts, create layouts with internal state, etc. This+means that we cannot simply have a list of layouts: a list requires+every member to belong to the same type!++Instead the combination of layouts to be used by xmonad is created+with a specific layout combinator: 'XMonad.Layout.|||'.++Suppose we want a list with the 'XMonad.Layout.Full',+'XMonad.Layout.Tabbed.tabbed' and+'XMonad.Layout.Accordion.Accordion' layouts. First we import, in our+@xmonad.hs@, all the needed modules:++>    import XMonad+>+>    import XMonad.Layout.Tabbed+>    import XMonad.Layout.Accordion++Then we create the combination of layouts we need:++>    mylayoutHook = Full ||| tabbed shrinkText def ||| Accordion+++Now, all we need to do is change the 'XMonad.Core.layoutHook'+field of the 'XMonad.Core.XConfig' record, like so:++>    main = xmonad $ def { layoutHook = mylayoutHook }++Thanks to the new combinator, we can apply a layout modifier to a+whole combination of layouts, instead of applying it to each one. For+example, suppose we want to use the+'XMonad.Layout.NoBorders.noBorders' layout modifier, from the+"XMonad.Layout.NoBorders" module (which must be imported):++>    mylayoutHook = noBorders (Full ||| tabbed shrinkText def ||| Accordion)++If we want only the tabbed layout without borders, then we may write:++>    mylayoutHook = Full ||| noBorders (tabbed shrinkText def) ||| Accordion++Our @xmonad.hs@ will now look like this:++>    import XMonad+>+>    import XMonad.Layout.Tabbed+>    import XMonad.Layout.Accordion+>    import XMonad.Layout.NoBorders+>+>    mylayoutHook = Full ||| noBorders (tabbed shrinkText def) ||| Accordion+>+>    main = xmonad $ def { layoutHook = mylayoutHook }++That's it!++-}++{- $manageHook+#Editing_the_manage_hook#++The 'XMonad.Core.manageHook' is a very powerful tool for customizing+the behavior of xmonad with regard to new windows.  Whenever a new+window is created, xmonad calls the 'XMonad.Core.manageHook', which+can thus be used to perform certain actions on the new window, such as+placing it in a specific workspace, ignoring it, or placing it in the+float layer.++The default 'XMonad.Core.manageHook' causes xmonad to float MPlayer+and Gimp, and to ignore gnome-panel, desktop_window, kicker, and+kdesktop.++The "XMonad.ManageHook" module provides some simple combinators that+can be used to alter the 'XMonad.Core.manageHook' by replacing or adding+to the default actions.++Let's start by analyzing the default 'XMonad.Config.manageHook', defined+in "XMonad.Config":+++>    manageHook :: ManageHook+>    manageHook = composeAll+>                    [ className =? "MPlayer"        --> doFloat+>                    , className =? "Gimp"           --> doFloat+>                    , resource  =? "desktop_window" --> doIgnore+>                    , resource  =? "kdesktop"       --> doIgnore ]++'XMonad.ManageHook.composeAll' can be used to compose a list of+different 'XMonad.Config.ManageHook's. In this example we have a list+of 'XMonad.Config.ManageHook's formed by the following commands: the+Mplayer's and the Gimp's windows, whose 'XMonad.ManageHook.className'+are, respectively \"Mplayer\" and \"Gimp\", are to be placed in the+float layer with the 'XMonad.ManageHook.doFloat' function; the windows+whose resource names are respectively \"desktop_window\" and+\kdesktop\" are to be ignored with the 'XMonad.ManageHook.doIgnore'+function.++This is another example of 'XMonad.Config.manageHook', taken from+"XMonad.Config.Arossato":++>    myManageHook  = composeAll [ resource =? "realplay.bin" --> doFloat+>                               , resource =? "win"          --> doF (W.shift "doc") -- xpdf+>                               , resource =? "firefox-bin"  --> doF (W.shift "web")+>                               ]+>    newManageHook = myManageHook <> manageHook def+++Again we use 'XMonad.ManageHook.composeAll' to compose a list of+different 'XMonad.Config.ManageHook's. The first one will put+RealPlayer on the float layer, the second one will put the xpdf+windows in the workspace named \"doc\", with 'XMonad.ManageHook.doF'+and 'XMonad.StackSet.shift' functions, and the third one will put all+firefox windows on the workspace called "web". Then we use the+'<>' combinator to compose @myManageHook@ with the+default 'XMonad.Config.manageHook' to form @newManageHook@.++Each 'XMonad.Config.ManageHook' has the form:++>    property =? match --> action++Where @property@ can be:++* 'XMonad.ManageHook.title': the window's title++* 'XMonad.ManageHook.resource': the resource name++* 'XMonad.ManageHook.className': the resource class name.++* 'XMonad.ManageHook.stringProperty' @somestring@: the contents of the+  property @somestring@.++(You can retrieve the needed information using the X utility named+@xprop@; for example, to find the resource class name, you can type++> xprop | grep WM_CLASS++at a prompt, then click on the window whose resource class you want to+know.)++@match@ is the string that will match the property value (for instance+the one you retrieved with @xprop@).++An  @action@ can be:++* 'XMonad.ManageHook.doFloat': to place the window in the float layer;++* 'XMonad.ManageHook.doIgnore': to ignore the window;++* 'XMonad.ManageHook.doF': to execute a function with the window as+  argument.++For example, suppose we want to add a 'XMonad.Config.manageHook' to+float RealPlayer, which usually has a 'XMonad.ManageHook.resource'+name of \"realplay.bin\".++First we need to import "XMonad.ManageHook":++>    import XMonad.ManageHook++Then we create our own 'XMonad.Config.manageHook':++>    myManageHook = resource =? "realplay.bin" --> doFloat++We can now use the '<>' combinator to add our+'XMonad.Config.manageHook' to the default one:++>    newManageHook = myManageHook <> manageHook def++(Of course, if we wanted to completely replace the default+'XMonad.Config.manageHook', this step would not be necessary.) Now,+all we need to do is change the 'XMonad.Core.manageHook' field of the+'XMonad.Core.XConfig' record, like so:++>    main = xmonad def { ..., manageHook = newManageHook, ... }++And we are done.++Obviously, we may wish to add more then one+'XMonad.Config.manageHook'. In this case we can use a list of hooks,+compose them all with 'XMonad.ManageHook.composeAll', and add the+composed to the default one.++For instance, if we want RealPlayer to float and thunderbird always+opened in the workspace named "mail", we can do so like this:++>    myManageHook = composeAll [ resource =? "realplay.bin"    --> doFloat+>                              , resource =? "thunderbird-bin" --> doF (W.shift "mail")+>                              ]++Remember to import the module that defines the 'XMonad.StackSet.shift'+function, "XMonad.StackSet", like this:++>    import qualified XMonad.StackSet as W++And then we can add @myManageHook@ to the default one to create+@newManageHook@ as we did in the previous example.++One more thing to note about this system is that if+a window matches multiple rules in a 'XMonad.Config.manageHook', /all/+of the corresponding actions will be run (in the order in which they+are defined).  An alternative version where only the first rule that+matches is run is available as 'XMonad.Hooks.ManageHelpers.composeOne'.++For additional rules and actions you can use in your manageHook, check+out the contrib module "XMonad.Hooks.ManageHelpers".  -}
+ XMonad/Hooks/BorderPerWindow.hs view
@@ -0,0 +1,77 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.BorderPerWindow+-- Description :  Set border width for a window in a ManageHook.+-- Copyright   :  (c) 2021 Xiaokui Shu+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  subbyte@gmail.com+-- Stability   :  unstable+-- Portability :  unportable+--+-- Want to customize border width, for each window on all layouts? Want+-- specific window have no border on all layouts? Try this.+-----------------------------------------------------------------------------++module XMonad.Hooks.BorderPerWindow ( -- * Usage+                                      -- $usage+                                      defineBorderWidth+                                    , actionQueue++                                      -- * Design Considerations+                                      -- $design+                                    ) where+++import XMonad+import XMonad.Util.ActionQueue (enqueue, actionQueue)++-- $usage+--+-- To use this module, first import it+--+-- > import XMonad.Hooks.BorderPerWindow (defineBorderWidth, actionQueue)+--+-- Then specify which window to customize the border of in your+-- @manageHook@:+--+-- > myManageHook :: ManageHook+-- > myManageHook = composeAll+-- >     [ className =? "firefox"  --> defineBorderWidth 0+-- >     , className =? "Chromium" --> defineBorderWidth 0+-- >     , isDialog                --> defineBorderWidth 8+-- >     ]+--+-- Finally, add the 'actionQueue' combinator and @myManageHook@ to your+-- config:+--+-- > main = xmonad $ actionQueue $ def+-- >     { ...+-- >     , manageHook = myManageHook+-- >     , ...+-- >     }+--+-- Note that this module is incompatible with other ways of changing+-- borders, like "XMonad.Layout.NoBorders".  This is because we are+-- changing the border exactly /once/ (when the window first appears)+-- and not every time some condition is satisfied.++-- $design+--+-- 1. Keep it simple. Since the extension does not aim to change border setting+--    when layout changes, only execute the border setting function once to+--    avoid potential window flashing/jumping/scaling.+--+-- 2. The 'ManageHook' eDSL is a nice language for specifying windows. Let's+--    build on top of it and use it to specify window to define border.++defineBorderWidth :: Dimension -> ManageHook+defineBorderWidth bw = do+    w <- ask+    liftX . enqueue $ updateBorderWidth w bw+    idHook++updateBorderWidth :: Window -> Dimension -> X ()+updateBorderWidth w bw = do+    withDisplay $ \d -> io $ setWindowBorderWidth d w bw+    refresh
XMonad/Hooks/CurrentWorkspaceOnTop.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.CurrentWorkspaceOnTop+-- Description :  Ensure that windows on the current workspace are on top. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -22,25 +22,26 @@     currentWorkspaceOnTop     ) where +import qualified Data.List.NonEmpty as NE (nonEmpty)+import qualified Data.Map as M import XMonad+import XMonad.Prelude (NonEmpty ((:|)), when) import qualified XMonad.StackSet as S import qualified XMonad.Util.ExtensibleState as XS-import Control.Monad(when)-import qualified Data.Map as M  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.CurrentWorkspaceOnTop -- >--- > main = xmonad $ defaultConfig {+-- > main = xmonad $ def { -- >    ... -- >    logHook = currentWorkspaceOnTop -- >    ... -- >  } -- -data CWOTState = CWOTS String deriving Typeable+newtype CWOTState = CWOTS String  instance ExtensionClass CWOTState where   initialValue = CWOTS ""@@ -55,15 +56,17 @@         let s = S.current ws             wsp = S.workspace s             viewrect = screenRect $ S.screenDetail s-            tmpStack = (S.stack wsp) >>= S.filter (`M.notMember` S.floating ws)+            tmpStack = S.stack wsp >>= S.filter (`M.notMember` S.floating ws)         (rs, ml') <- runLayout wsp { S.stack = tmpStack } viewrect         updateLayout curTag ml'         let this = S.view curTag ws-            fltWins = filter (flip M.member (S.floating ws)) $ S.index this-            wins = fltWins ++ (map fst rs)  -- order: first all floating windows, then the order the layout returned+            fltWins = filter (`M.member` S.floating ws) $ S.index this+            wins = fltWins ++ map fst rs  -- order: first all floating windows, then the order the layout returned         -- end of reimplementation -        when (not . null $ wins) $ do-            io $ raiseWindow d (head wins)  -- raise first window of current workspace to the very top,-            io $ restackWindows d wins      -- then use restackWindows to let all other windows from the workspace follow+        case NE.nonEmpty wins of+            Nothing         -> pure ()+            Just (w :| ws') -> do+                io $ raiseWindow d w            -- raise first window of current workspace to the very top,+                io $ restackWindows d (w : ws') -- then use restackWindows to let all other windows from the workspace follow         XS.put(CWOTS curTag)
XMonad/Hooks/DebugEvents.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.DebugEvents+-- Description :  Dump diagnostic information about X11 events received by xmonad. -- Copyright   :  (c) Brandon S Allbery KF8NH, 2012 -- License     :  BSD3-style (see LICENSE) --@@ -24,29 +25,24 @@ import           XMonad                               hiding (windowEvent                                                              ,(-->)                                                              )+import           XMonad.Prelude                       hiding (fi, bool)  import           XMonad.Hooks.DebugKeyEvents                 (debugKeyEvents) import           XMonad.Util.DebugWindow                     (debugWindow)  -- import           Graphics.X11.Xlib.Extras.GetAtomName        (getAtomName) -import           Control.Exception.Extensible         as E+import           Control.Exception                    as E import           Control.Monad.State import           Control.Monad.Reader-import           Data.Char                                   (isDigit)-import           Data.List                                   (genericIndex-                                                             ,genericLength-                                                             ,unfoldr-                                                             ) import           Codec.Binary.UTF8.String-import           Data.Maybe                                  (fromMaybe)-import           Data.Monoid-import           Foreign+import           Foreign                                     hiding (void) import           Foreign.C.Types import           Numeric                                     (showHex) import           System.Exit import           System.IO import           System.Process+import           GHC.Stack                                   (HasCallStack, prettyCallStack, callStack)  -- | Event hook to dump all received events.  You should probably not use this --   unconditionally; it will produce massive amounts of output.@@ -56,17 +52,17 @@ -- | Dump an X11 event.  Can't be used directly as a 'handleEventHook'. debugEventsHook' :: Event -> X () -debugEventsHook' (ConfigureRequestEvent {ev_window       = w-                                        ,ev_parent       = p-                                        ,ev_x            = x-                                        ,ev_y            = y-                                        ,ev_width        = wid-                                        ,ev_height       = ht-                                        ,ev_border_width = bw-                                        ,ev_above        = above-                                        ,ev_detail       = place-                                        ,ev_value_mask   = msk-                                        }) = do+debugEventsHook' ConfigureRequestEvent{ev_window       = w+                                      ,ev_parent       = p+                                      ,ev_x            = x+                                      ,ev_y            = y+                                      ,ev_width        = wid+                                      ,ev_height       = ht+                                      ,ev_border_width = bw+                                      ,ev_above        = above+                                      ,ev_detail       = place+                                      ,ev_value_mask   = msk+                                      } = do   windowEvent "ConfigureRequest" w   windowEvent "  parent"         p --  mask <- quickFormat msk $ dumpBits wmCRMask@@ -89,95 +85,93 @@                            ]   say "  requested" s -debugEventsHook' (ConfigureEvent        {ev_window = w-                                        ,ev_above  = above-                                        }) = do+debugEventsHook' ConfigureEvent        {ev_window = w+                                       ,ev_above  = above+                                       } = do   windowEvent "Configure" w   -- most of the content is covered by debugWindow   when (above /= none) $ debugWindow above >>= say "  above" -debugEventsHook' (MapRequestEvent       {ev_window     = w-                                        ,ev_parent     = p-                                        }) =+debugEventsHook' MapRequestEvent       {ev_window     = w+                                       ,ev_parent     = p+                                       } =   windowEvent "MapRequest" w >>   windowEvent "  parent"   p -debugEventsHook' e@(KeyEvent {ev_event_type = t})+debugEventsHook' e@KeyEvent {ev_event_type = t}     | t == keyPress =   io (hPutStr stderr "KeyPress ") >>   debugKeyEvents e >>   return () -debugEventsHook' (ButtonEvent           {ev_window = w-                                        ,ev_state  = s-                                        ,ev_button = b-                                        }) = do+debugEventsHook' ButtonEvent           {ev_window = w+                                       ,ev_state  = s+                                       ,ev_button = b+                                       } = do   windowEvent "Button" w   nl <- gets numberlockMask   let msk | s == 0    = ""-          | otherwise = "modifiers " ++ vmask nl s+          | otherwise = "modifiers " ++ keymaskToString nl s   say "  button" $ show b ++ msk -debugEventsHook' (DestroyWindowEvent    {ev_window = w-                                        }) =+debugEventsHook' DestroyWindowEvent    {ev_window = w+                                        } =   windowEvent "DestroyWindow" w -debugEventsHook' (UnmapEvent            {ev_window = w-                                        }) =+debugEventsHook' UnmapEvent            {ev_window = w+                                       } =   windowEvent "Unmap" w -debugEventsHook' (MapNotifyEvent        {ev_window = w-                                        }) =+debugEventsHook' MapNotifyEvent        {ev_window = w+                                       } =   windowEvent "MapNotify" w  {- way too much output; suppressed. -debugEventsHook' (CrossingEvent         {ev_window    = w-                                        ,ev_subwindow = s-                                        }) =+debugEventsHook' (CrossingEvent        {ev_window    = w+                                       ,ev_subwindow = s+                                       }) =   windowEvent "Crossing"    w >>   windowEvent "  subwindow" s -}-debugEventsHook' (CrossingEvent         {}) =+debugEventsHook' CrossingEvent         {} =   return () -debugEventsHook' (SelectionRequest      {ev_requestor = rw-                                        ,ev_owner     = ow-                                        ,ev_selection = a-                                        }) =+debugEventsHook' SelectionRequest      {ev_requestor = rw+                                       ,ev_owner     = ow+                                       ,ev_selection = a+                                       } =   windowEvent "SelectionRequest" rw >>   windowEvent "  owner"          ow >>   atomEvent   "  atom"           a -debugEventsHook' (PropertyEvent         {ev_window    = w-                                        ,ev_atom      = a-                                        ,ev_propstate = s-                                        }) = do+debugEventsHook' PropertyEvent         {ev_window    = w+                                       ,ev_atom      = a+                                       ,ev_propstate = s+                                       } = do   a' <- atomName a   -- too many of these, and they're not real useful-  if a' `elem` ["_NET_WM_USER_TIME"---               ,"_NET_WM_WINDOW_OPACITY"-               ] then return () else do-  windowEvent "Property on" w-  s' <- case s of-          1 -> return "deleted"-          0 -> dumpProperty a a' w (7 + length a')-          _ -> error "Illegal propState; Xlib corrupted?"-  say "  atom" $ a' ++ s'+  if a' == "_NET_WM_USER_TIME" then return () else do+    windowEvent "Property on" w+    s' <- case s of+            1 -> return "deleted"+            0 -> dumpProperty a a' w (7 + length a')+            _ -> error "Illegal propState; Xlib corrupted?"+    say "  atom" $ a' ++ s' -debugEventsHook' (ExposeEvent           {ev_window = w-                                        }) =+debugEventsHook' ExposeEvent           {ev_window = w+                                       } =   windowEvent "Expose" w -debugEventsHook' (ClientMessageEvent    {ev_window       = w-                                        ,ev_message_type = a-                                        -- @@@ they did it again!  no ev_format,-                                        --     and ev_data is [CInt]-                                        -- @@@ and get a load of the trainwreck-                                        --     that is setClientMessageEvent!---                                        ,ev_format       = b-                                        ,ev_data         = vs'-                                        }) = do+debugEventsHook' ClientMessageEvent    {ev_window       = w+                                       ,ev_message_type = a+                                       -- @@@ they did it again!  no ev_format,+                                       --     and ev_data is [CInt]+                                       -- @@@ and get a load of the trainwreck+                                       --     that is setClientMessageEvent!+--                                     ,ev_format       = b+                                       ,ev_data         = vs'+                                       } = do   windowEvent "ClientMessage on" w   n <- atomName a   -- this is a sort of custom property@@ -188,7 +182,7 @@                   ta <- getAtom ta'                   return (ta,b,l)   let wl = bytes b-  vs <- io $ take (l * wl) `fmap` splitCInt vs'+  vs <- io $ take (l * wl) <$> splitCInt vs'   s <- dumpProperty' w a n ta b vs 0 (10 + length n)   say "  message" $ n ++ s @@ -197,7 +191,7 @@ -- | Emit information about an atom. atomName   :: Atom -> X String atomName a =  withDisplay $ \d ->-  io $ fromMaybe ("(unknown atom " ++ show a ++ ")") `fmap` getAtomName d a+  io $ fromMaybe ("(unknown atom " ++ show a ++ ")") <$> getAtomName d a  -- | Emit an atom with respect to the current event. atomEvent     :: String -> Atom -> X ()@@ -209,7 +203,7 @@  -- | Helper to emit tagged event information. say     :: String -> String -> X ()-say l s =  trace $ l ++ ' ':s+say l s =  XMonad.trace $ l ++ ' ':s  -- | Deconstuct a list of 'CInt's into raw bytes splitCInt    :: [CInt] -> IO Raw@@ -224,28 +218,6 @@                   ,("WM_SAVE_YOURSELF"  ,("STRING"            , 8,0))                   ] --- | Convert a modifier mask into a useful string-vmask                 :: KeyMask -> KeyMask -> String-vmask numLockMask msk =  unwords $-                         reverse $-                         fst     $-                         foldr vmask' ([],msk) masks-    where-      masks = map (\m -> (m,show m)) [0..toEnum (bitSize msk - 1)] ++-              [(numLockMask,"num"  )-              ,(   lockMask,"lock" )-              ,(controlMask,"ctrl" )-              ,(  shiftMask,"shift")-              ,(   mod5Mask,"mod5" )-              ,(   mod4Mask,"mod4" )-              ,(   mod3Mask,"mod3" )-              ,(   mod2Mask,"mod2" )-              ,(   mod1Mask,"mod1" )-              ]-      vmask'   _   a@( _,0)                = a-      vmask' (m,s)   (ss,v) | v .&. m == m = (s : ss,v .&. complement m)-      vmask'   _        r                  = r- -- formatting properties.  ick. --  -- @@@ Document the parser.  Someday.@@ -268,20 +240,21 @@                         }  newtype Decoder a = Decoder (ReaderT Decode (StateT DecodeState X) a)-#ifndef __HADDOCK__+     deriving (Functor              ,Applicative              ,Monad              ,MonadIO+             ,MonadFail              ,MonadState  DecodeState              ,MonadReader Decode              )-#endif + -- | Retrive, parse, and dump a window property.  As all the high-level property---   interfaces lose information necessary to decode properties correctly, we +--   interfaces lose information necessary to decode properties correctly, we --   work at the lowest level available.-dumpProperty          :: Atom -> String -> Window -> Int -> X String+dumpProperty          :: HasCallStack => Atom -> String -> Window -> Int -> X String dumpProperty a n w i  =  do   prop <- withDisplay $ \d ->     io     $@@ -305,9 +278,9 @@               vsp     case rc of       0 -> do-        fmt <- fromIntegral `fmap` peek fmtp-        vs' <-                     peek vsp-        sz  <- fromIntegral `fmap` peek szp+        fmt <- fromIntegral <$> peek fmtp+        vs' <-                  peek vsp+        sz  <- fromIntegral <$> peek szp         case () of           () | fmt == none     -> xFree vs' >> return (Left   "(property deleted)"   )              | sz < 0          -> xFree vs' >> return (Left $ "(illegal bit size " ++@@ -317,9 +290,9 @@                                                               show sz              ++                                                               ")"                    )              | otherwise       -> do-                 len <- fromIntegral `fmap` peek lenp+                 len <- fromIntegral <$> peek lenp                  -- that's as in "ack! it's fugged!"-                 ack <- fromIntegral `fmap` peek ackp+                 ack <- fromIntegral <$> peek ackp                  vs <- peekArray (len * bytes sz) vs'                  _ <- xFree vs'                  return $ Right (fmt,sz,ack,vs)@@ -330,7 +303,8 @@  -- @@@ am I better off passing in the Decode and DecodeState? -- | Parse and dump a property (or a 'ClientMessage').-dumpProperty'                             :: Window -- source window+dumpProperty'                             :: HasCallStack+                                          => Window -- source window                                           -> Atom   -- property id                                           -> String -- property name                                           -> Atom   -- property type@@ -361,11 +335,11 @@   (_,ds') <- runDecode dec ds $ dumpProp a n   let fin = length (value ds')       len = length vs-      lost = if ack == 0 then "" else "and " ++ show ack ++ " lost bytes"+      lost = if ack == 0 then "" else " and " ++ show ack ++ " lost bytes"       unk = case () of               () | fin == len -> "undecodeable "                  | fin == 0   -> "."-                 | otherwise  -> "and remainder (" ++ show (len - fin) ++ '/':show len ++ ")"+                 | otherwise  -> " and remainder (" ++ show (len - fin) ++ '/':show len ++ ")"   (_,ds'') <- if fin == 0               then return (True,ds')               else runDecode dec' (withJoint' unk ds' ) $ dumpArray dump8@@ -376,7 +350,7 @@  -- | A simplified version of 'dumpProperty\'', to format random values from --   events.-quickFormat     :: (Storable i, Integral i) => [i] -> Decoder Bool -> X String+quickFormat     :: (HasCallStack, Storable i, Integral i) => [i] -> Decoder Bool -> X String quickFormat v f =  do   let vl = length v   vs <- io $@@ -406,10 +380,10 @@ bytes   :: Int -> Int bytes w =  w `div` 8 --- | The top level property decoder, for a wide variety of standard ICCCM and ---   EWMH window properties.  We pass part of the 'ReaderT' as arguments for +-- | The top level property decoder, for a wide variety of standard ICCCM and+--   EWMH window properties.  We pass part of the 'ReaderT' as arguments for --   pattern matching.-dumpProp                                              :: Atom -> String -> Decoder Bool+dumpProp                                              :: HasCallStack => Atom -> String -> Decoder Bool  dumpProp _ "CLIPBOARD"                                =  dumpSelection dumpProp _ "_NET_SUPPORTED"                           =  dumpArray dumpAtom@@ -453,10 +427,13 @@ dumpProp _ "_NET_WM_VISIBLE_NAME"                     =  dumpUTF dumpProp _ "_NET_WM_ICON_NAME"                        =  dumpUTF dumpProp _ "_NET_WM_VISIBLE_ICON_NAME"                =  dumpUTF-dumpProp _ "_NET_WM_DESKTOP"                          =  dumpExcept [(0xFFFFFFFF,"all")]-                                                                    dump32+-- @@@ the property is CARDINAL; the message is _NET_WM_DESKTOP of 5 dump32s+--     [desktop/all, source indication, 3 zeroes]+-- dumpProp _ "_NET_WM_DESKTOP"                          =  dumpExcept [(0xFFFFFFFF,"all")]+--                                                                     dump32+dumpProp _ "_NET_WM_DESKTOP"                          =  dumpSetDesktop dumpProp _ "_NET_WM_WINDOW_TYPE"                      =  dumpArray dumpAtom-dumpProp _ "_NET_WM_STATE"                            =  dumpArray dumpAtom+dumpProp _ "_NET_WM_STATE"                            =  dumpNWState dumpProp _ "_NET_WM_ALLOWED_ACTIONS"                  =  dumpArray dumpAtom dumpProp _ "_NET_WM_STRUT"                            =  dumpList [("left gap"  ,dump32)                                                                   ,("right gap" ,dump32)@@ -494,6 +471,12 @@                                                                   ] dumpProp _ "_NET_WM_SYNC_REQUEST_COUNTER"             =  dumpExcept [(0,"illegal value 0")]                                                                     dump64+dumpProp _ "_NET_WM_OPAQUE_REGION"                    =  dumpArray $ dumpList [("x",dump32)+                                                                              ,("y",dump32)+                                                                              ,("w",dump32)+                                                                              ,("h",dump32)+                                                                              ]+dumpProp _ "_NET_WM_BYPASS_COMPOSITOR"                =  dumpEnum cpState dumpProp _ "_NET_STARTUP_ID"                          =  dumpUTF dumpProp _ "WM_PROTOCOLS"                             =  dumpArray dumpAtom dumpProp _ "WM_COLORMAP_WINDOWS"                      =  dumpArray dumpWindow@@ -519,12 +502,12 @@              | a == sECONDARY                         =  dumpSelection                -- this is gross              | a == wM_TRANSIENT_FOR                  =  do-                 root <- fromIntegral `fmap` inX (asks theRoot)+                 root <- fromIntegral <$> inX (asks theRoot)                  w <- asks window-                 WMHints {wmh_window_group = group} <-+                 WMHints {wmh_window_group = wgroup} <-                    inX $ asks display >>= io . flip getWMHints w-                 dumpExcept [(0   ,"window group " ++ show group)-                            ,(root,"window group " ++ show group)+                 dumpExcept [(0   ,"window group " ++ show wgroup)+                            ,(root,"window group " ++ show wgroup)                             ]                             dumpWindow              | a == rESOURCE_MANAGER                  =  dumpString@@ -548,8 +531,8 @@                                                                              ]                                                                    )                                                                   ]-             | a == wM_NORMAL_HINTS                   =  (...)-             | a == wM_ZOOM_HINTS                     =  (...) -- same as previous+             | a == wM_NORMAL_HINTS                   =  dumpSizeHints+             | a == wM_ZOOM_HINTS                     =  dumpSizeHints              | a == rGB_DEFAULT_MAP                   =  (...) -- XStandardColormap              | a == rGB_BEST_MAP                      =  (...) -- "              | a == rGB_RED_MAP                       =  (...) -- "@@ -594,27 +577,27 @@ withIndent w =  local (\r -> r {indent = indent r + w})  -- dump an array of items.  this dumps the entire property-dumpArray      :: Decoder Bool -> Decoder Bool+dumpArray      :: HasCallStack => Decoder Bool -> Decoder Bool dumpArray item =  do   withIndent 1 $ append "[" >> withJoint "" (dumpArray' item "")  -- step through values as an array, ending on parse error or end of list-dumpArray'          :: Decoder Bool -> String -> Decoder Bool+dumpArray'          :: HasCallStack => Decoder Bool -> String -> Decoder Bool dumpArray' item pfx =  do   vs <- gets value-  if vs == []+  if null vs     then append "]"     else append pfx >> whenD item (dumpArray' item ",")  -- keep parsing until a parse step fails -- @@@ which points out that all my uses of @whenX (return ...)@ are actually 'when', --     which suggests that 'whenX' is *also* the same function... yep.  ISAGN-whenD     :: Monad m => m Bool -> m Bool -> m Bool+whenD     :: (HasCallStack, Monad m) => m Bool -> m Bool -> m Bool whenD p f =  p >>= \b -> if b then f else return False  -- verify a decoder parameter, else call error reporter -- once again, it's more general than I originally wrote-guardR                  :: (MonadReader r m, Eq v)+guardR                  :: (HasCallStack, MonadReader r m, Eq v)                         => (r -> v)                -- value selector                         -> v                       -- expected value                         -> (v -> v -> m a)         -- error reporter@@ -625,43 +608,47 @@   if v == val then good else err v val  -- this is kinda dumb-fi       :: Bool -> a -> a -> a+fi       :: HasCallStack => Bool -> a -> a -> a fi p n y =  if p then y else n -- flip (if' p), if that existed  -- verify we have the expected word size-guardSize      :: Int -> Decoder Bool -> Decoder Bool+guardSize      :: HasCallStack => Int -> Decoder Bool -> Decoder Bool -- see XSync documentation for this insanity-guardSize 64 =  guardR width 32 propSizeErr . guardSize' 8         propShortErr-guardSize  w =  guardR width  w propSizeErr . guardSize' (bytes w) propShortErr+guardSize 64 =  guardR width 32 propSizeErr . guardSize' 8         (propShortErr' 1)+guardSize  w =  guardR width  w propSizeErr . guardSize' (bytes w) (propShortErr' 2) -guardSize'       :: Int -> Decoder a -> Decoder a -> Decoder a-guardSize' l n y =  gets value >>= \vs -> fi (length vs >= l) n y+guardSize'       :: HasCallStack => Int -> Decoder a -> Decoder a -> Decoder a+guardSize' l n y =  gets value >>= \vs -> fi (length vs >= bytes l) n y +-- @guardSize@ doesn't work with empty arrays+guardSize''       :: HasCallStack => Int -> Decoder a -> Decoder a -> Decoder a+guardSize'' l n y =  gets value >>= \vs -> fi (null vs || length vs >= bytes l) n y+ -- verify we have the expected property type-guardType    :: Atom -> Decoder Bool -> Decoder Bool+guardType    :: HasCallStack => Atom -> Decoder Bool -> Decoder Bool guardType  t =  guardR pType t propTypeErr  -- dump a structure as a named tuple-dumpList       :: [(String,Decoder Bool)] -> Decoder Bool+dumpList       :: HasCallStack => [(String,Decoder Bool)] -> Decoder Bool dumpList proto =  do   a <- asks pType   dumpList'' (maxBound :: CULong) (map (\(s,d) -> (s,d,a)) proto) "("  -- same but elements have their own distinct types-dumpList'       :: [(String,Decoder Bool,Atom)] -> Decoder Bool+dumpList'       :: HasCallStack => [(String,Decoder Bool,Atom)] -> Decoder Bool dumpList' proto =  dumpList'' (maxBound :: CULong) proto "("  -- same but only dump elements identified by provided mask-dumpListByMask     :: CULong -> [(String,Decoder Bool)] -> Decoder Bool+dumpListByMask     :: HasCallStack => CULong -> [(String,Decoder Bool)] -> Decoder Bool dumpListByMask m p =  do   a <- asks pType   dumpList'' m (map (\(s,d) -> (s,d,a)) p) "("  -- and the previous two combined-dumpListByMask'     :: CULong -> [(String,Decoder Bool,Atom)] -> Decoder Bool+dumpListByMask'     :: HasCallStack => CULong -> [(String,Decoder Bool,Atom)] -> Decoder Bool dumpListByMask' m p =  dumpList'' m p "(" -dumpList''                    :: CULong -> [(String,Decoder Bool,Atom)] -> String -> Decoder Bool+dumpList''                    :: HasCallStack => CULong -> [(String,Decoder Bool,Atom)] -> String -> Decoder Bool dumpList'' _ []           _   =  append ")" >> return True dumpList'' 0 _            _   =  append ")" >> return True dumpList'' m ((l,p,t):ps) sep = do@@ -686,22 +673,20 @@  -- do the getTextProperty dance, the hard way. -- @@@ @COMPOUND_TEXT@ not supported yet.-dumpString :: Decoder Bool+dumpString :: HasCallStack => 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+    () | fmt == cOMPOUND_TEXT -> guardSize'' 16 (propShortErr' 3) ( ... )+       | fmt == sTRING        -> guardSize''  8 (propShortErr' 4) $ 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''+                                                           s'      = drop 1 s''                                                         in Just (w,s')                                    case ss of                                      [s] -> append $ show s@@ -711,11 +696,11 @@                                                 go []       _ = append "]"                                              in append "[" >> go ss' ""        | fmt == uTF8_STRING   -> dumpUTF -- duplicate type test instead of code :)-       | otherwise            -> (inX $ atomName fmt) >>=+       | otherwise            -> inX (atomName fmt) >>=                                  failure . ("unrecognized string type " ++)  -- show who owns a selection-dumpSelection :: Decoder Bool+dumpSelection :: HasCallStack => Decoder Bool dumpSelection =  do   -- system selections contain a window ID; others are random   -- note that the window ID will be the same as the owner, so@@ -729,29 +714,40 @@       append $ "owned by " ++ w  -- for now, not querying Xkb-dumpXKlInds :: Decoder Bool+dumpXKlInds :: HasCallStack => Decoder Bool dumpXKlInds =  guardType iNTEGER $ do-                 n <- fmap fromIntegral `fmap` getInt' 32+                 n <- fmap fromIntegral <$> getInt' 32                  case n of-                   Nothing -> propShortErr+                   Nothing -> propShortErr' 5                    Just is -> append $ "indicators " ++ unwords (dumpInds is 1 1 [])   where-    dumpInds                               :: Word32 -> Word32 -> Int -> [String] -> [String]+    dumpInds                               :: HasCallStack => Word32 -> Word32 -> Int -> [String] -> [String]     dumpInds n bt c bs | n == 0 && c == 1 =  ["none"]                        | n == 0           =  bs                        | n .&. bt /= 0    =  dumpInds (n .&. complement bt)                                                       (bt `shiftL` 1)                                                       (c + 1)-                                                      ((show c):bs)+                                                      (show c:bs)                        | otherwise        =  dumpInds n                                                       (bt `shiftL` 1)                                                       (c + 1)                                                       bs  -- decode an Atom-dumpAtom :: Decoder Bool-dumpAtom =-  guardType aTOM $ do++dumpAtom :: HasCallStack => Decoder Bool+dumpAtom = dumpAtom'' aTOM++{-+dumpAtom' :: HasCallStack => String -> Decoder Bool+dumpAtom' t' = do+  t <- inX $ getAtom t'+  dumpAtom'' t+-}++dumpAtom'' :: HasCallStack => Atom -> Decoder Bool+dumpAtom'' t =+  guardType t $ do   a <- getInt' 32   case a of     Nothing -> return False@@ -759,15 +755,16 @@            an <- inX $ atomName $ fromIntegral a'            append an -dumpWindow :: Decoder Bool+dumpWindow :: HasCallStack => Decoder Bool dumpWindow =  guardSize 32 $ guardType wINDOW $ do                 w <- getInt' 32                 case w of                   Nothing -> return False+                  Just 0  -> append "none"                   Just w' -> inX (debugWindow (fromIntegral w')) >>= append  -- a bit of a hack; as a Property it's a wINDOW, as a ClientMessage it's a list-dumpActiveWindow :: Decoder Bool+dumpActiveWindow :: HasCallStack => Decoder Bool dumpActiveWindow =  guardSize 32 $ do                       t <- asks pType                       nAW <- inX $ getAtom "_NET_ACTIVE_WINDOW"@@ -781,49 +778,87 @@                                      t' <- inX $ atomName t                                      failure $ concat ["(bad type "                                                       ,t'-                                                      ,"; expected WINDOW or _NET_ACTIVE_WINDOW"+                                                      ,"; expected WINDOW or _NET_ACTIVE_WINDOW)"                                                       ]++-- likewise but for _NET_WM_DESKTOP+dumpSetDesktop :: HasCallStack => Decoder Bool+dumpSetDesktop =  guardSize 32 $ do+                    t <- asks pType+                    nWD <- inX $ getAtom "_NET_WM_DESKTOP"+                    case () of+                      () | t == cARDINAL -> dumpExcept [(0xFFFFFFFF,"all")]+                                                       dump32+                         | t == nWD      -> dumpList' [("desktop",dumpExcept [(0xFFFFFFFF,"all")]+                                                                             dump32              ,cARDINAL)+                                                      ,("source" ,dumpEnum awSource              ,cARDINAL)+                                                      ]+                      _                -> do+                                     t' <- inX $ atomName t+                                     failure $ concat ["(bad type "+                                                      ,t'+                                                      ,"; expected CARDINAL or _NET_WM_DESKTOP)"+                                                      ]++-- and again for _NET_WM_STATE+dumpNWState :: HasCallStack => Decoder Bool+dumpNWState =  guardSize'' 32 propShortErr $ do+                    t <- asks pType+                    nWS <- inX $ getAtom "_NET_WM_STATE"+                    case () of+                      () | t == aTOM -> dumpArray dumpAtom+                         | t == nWS  -> dumpList' [("action",dumpEnum nwAction,cARDINAL)+                                                  ,("atom1" ,dumpAtom         ,aTOM)+                                                  ,("atom2" ,dumpAtom         ,aTOM)+                                                  ]+                      _                -> do+                                     t' <- inX $ atomName t+                                     failure $ concat ["(bad type "+                                                      ,t'+                                                      ,"; expected ATOM or _NET_WM_STATE)"+                                                      ]+ -- dump a generic CARDINAL value-dumpInt   :: Int -> Decoder Bool+dumpInt   :: HasCallStack => Int -> Decoder Bool dumpInt w =  guardSize w $ guardType cARDINAL $ getInt w show  -- INTEGER is the signed version of CARDINAL-dumpInteger   :: Int -> Decoder Bool+dumpInteger   :: HasCallStack => Int -> Decoder Bool dumpInteger w =  guardSize w $ guardType iNTEGER $ getInt w (show . signed w)  -- reinterpret an unsigned as a signed-signed     :: Int -> Integer -> Integer+signed     :: HasCallStack => Int -> Integer -> Integer signed w i =  bit (w + 1) - i  -- and wrappers to keep the parse list in bounds-dump64 :: Decoder Bool+dump64 :: HasCallStack => Decoder Bool dump64 =  dumpInt 64 -dump32 :: Decoder Bool+dump32 :: HasCallStack => Decoder Bool dump32 =  dumpInt 32  {- not used in standard properties-dump16 :: Decoder Bool+dump16 :: HasCallStack => Decoder Bool dump16 =  dumpInt 16 -} -dump8 :: Decoder Bool+dump8 :: HasCallStack => Decoder Bool dump8 =  dumpInt 8  -- I am assuming for the moment that this is a single string. -- This might be false; consider the way the STRING properties -- handle lists.-dumpUTF :: Decoder Bool+dumpUTF :: HasCallStack => Decoder Bool dumpUTF =  do   uTF8_STRING <- inX $ getAtom "UTF8_STRING"-  guardType uTF8_STRING $ guardSize 8 $ do-  s <- gets value-  modify (\r -> r {value = []})-  append . show . decode . map fromIntegral $ s-  return True+  guardType uTF8_STRING $ guardSize'' 8 propShortErr $ do+    s <- gets value+    modify (\r -> r {value = []})+    append . show . decode . map fromIntegral $ s+    return True  -- dump an enumerated value using a translation table-dumpEnum'        :: [String] -> Atom -> Decoder Bool+dumpEnum'        :: HasCallStack => [String] -> Atom -> Decoder Bool dumpEnum' ss fmt =  guardType fmt $                     getInt 32     $                     \r -> case () of@@ -832,15 +867,16 @@                                | otherwise             -> genericIndex ss r  -- we do not, unlike @xev@, try to ascii-art pixmaps.-dumpPixmap :: Decoder Bool+dumpPixmap :: HasCallStack => Decoder Bool dumpPixmap =  guardType pIXMAP $ do                 p' <- getInt' 32                 case p' of                   Nothing -> return False+                  Just 0  -> append "none"                   Just p  -> do                     append $ "pixmap " ++ showHex p ""                     g' <- inX $ withDisplay $ \d -> io $-                            Just `fmap` getGeometry d (fromIntegral p)+                            (Just <$> getGeometry d (fromIntegral p))                             `E.catch`                             \e -> case fromException e of                                     Just x -> throw e `const` (x `asTypeOf` ExitSuccess)@@ -860,46 +896,80 @@                                      ,")"                                      ] -dumpOLAttrs :: Decoder Bool+dumpOLAttrs :: HasCallStack => Decoder Bool dumpOLAttrs = do   pt <- inX $ getAtom "_OL_WIN_ATTR"   guardType pt $ do     msk <- getInt' 32     case msk of-      Nothing   -> propShortErr+      Nothing   -> propShortErr' 7       Just msk' -> dumpListByMask (fromIntegral msk') [("window type" ,dumpAtom     )                                                       ,("menu"        ,dump32       ) -- @@@ unk                                                       ,("pushpin"     ,dumpEnum bool)                                                       ,("limited menu",dump32       ) -- @@@ unk                                                       ] -dumpMwmHints :: Decoder Bool+dumpMwmHints :: HasCallStack => Decoder Bool dumpMwmHints =  do   ta <- asks property   guardType ta $ do     msk <- getInt' 32     case msk of-      Nothing   -> propShortErr-      Just msk' -> dumpListByMask (fromIntegral msk') [("functions"  ,dumpBits mwmFuncs    )-                                                      ,("decorations",dumpBits mwmDecos    )-                                                      ,("input mode" ,dumpEnum mwmInputMode)-                                                      ,("status"     ,dumpBits mwmState    )-                                                      ]+      Nothing   -> propShortErr' 8+      Just msk' -> dumpListByMask' (fromIntegral msk') [("functions"  ,dumpBits mwmFuncs    ,cARDINAL)+                                                       ,("decorations",dumpBits mwmDecos    ,cARDINAL)+                                                       ,("input mode" ,dumpEnum mwmInputMode,cARDINAL) -- @@@ s/b iNTEGER?+                                                       ,("status"     ,dumpBits mwmState    ,cARDINAL)+                                                       ] -dumpMwmInfo :: Decoder Bool+dumpMwmInfo :: HasCallStack => Decoder Bool dumpMwmInfo =  do   ta <- asks property   guardType ta $ dumpList' [("flags" ,dumpBits mwmHints,cARDINAL)                            ,("window",dumpWindow       ,wINDOW  )                            ]-             ++dumpSizeHints :: HasCallStack => Decoder Bool+dumpSizeHints =  do+  guardType wM_SIZE_HINTS $ do+    -- flags, 4 unused CARD32s, fields as specified by flags+    msk <- fmap fromIntegral <$> getInt' 32+    eat (4 * 4) >> pure False+    case msk of+      Nothing   -> propShortErr' 9+      Just msk' -> dumpListByMask' msk' [("min size"    ,dumpSize  ,cARDINAL)+                                        ,("max size"    ,dumpSize  ,cARDINAL)+                                        ,("increment"   ,dumpSize  ,cARDINAL)+                                        ,("aspect ratio",dumpAspect,cARDINAL)+                                        ,("base size"   ,dumpSize  ,cARDINAL)+                                        ,("gravity"     ,dumpGrav  ,cARDINAL)+                                        ]++dumpSize :: HasCallStack => Decoder Bool+dumpSize =  append "(" >> dump32 >> append "," >> dump32 >> append ")"++dumpAspect :: HasCallStack => Decoder Bool+dumpAspect =  do+  -- have to do this manually since it doesn't really fit+  append "min = "+  dump32+  append "/"+  dump32+  append ", max = "+  dump32+  append "/"+  dump32++dumpGrav :: HasCallStack => Decoder Bool+dumpGrav =  dumpEnum wmGravity+ -- the most common case-dumpEnum    :: [String] -> Decoder Bool+dumpEnum    :: HasCallStack => [String] -> Decoder Bool dumpEnum ss =  dumpEnum' ss cARDINAL  -- implement exceptional cases atop a normal dumper -- @@@ there's gotta be a better way-dumpExcept           :: [(Integer,String)] -> Decoder Bool -> Decoder Bool+dumpExcept           :: HasCallStack => [(Integer,String)] -> Decoder Bool -> Decoder Bool dumpExcept xs item = do   -- this horror brought to you by reparsing to get the right value for our use   sp <- get@@ -910,11 +980,12 @@     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 -dumpExcept'                                      :: [(Integer,String)]+dumpExcept'                                      :: HasCallStack+                                                 => [(Integer,String)]                                                  -> DecodeState                                                  -> Integer                                                  -> Decoder Bool@@ -924,7 +995,7 @@  -- use @ps@ to get process information. -- @@@@ assumes a POSIX @ps@, not a BSDish one.-dumpPid :: Decoder Bool+dumpPid :: HasCallStack => Decoder Bool dumpPid =  guardType cARDINAL $ do              n <- getInt' 32              case n of@@ -936,23 +1007,23 @@                       case o of                         Nothing -> append $ "pid " ++ pid                         Just p' -> do-                                  prc <- io $ lines `fmap` hGetContents p'+                                  prc <- io $ lines <$> hGetContents p'                                   -- deliberately forcing it                                   append $ if length prc < 2                                            then "pid " ++ pid                                            else prc !! 1 -dumpTime :: Decoder Bool+dumpTime :: HasCallStack => Decoder Bool dumpTime =  append "server event # " >> dump32 -dumpState :: Decoder Bool+dumpState :: HasCallStack => Decoder Bool dumpState =  do   wM_STATE <- inX $ getAtom "WM_STATE"   guardType wM_STATE $ dumpList' [("state"      ,dumpEnum wmState,cARDINAL)                                  ,("icon window",dumpWindow      ,wINDOW  )                                  ] -dumpMotifDragReceiver :: Decoder Bool+dumpMotifDragReceiver :: HasCallStack => Decoder Bool dumpMotifDragReceiver =  do   ta <- inX $ getAtom "_MOTIF_DRAG_RECEIVER_INFO"   guardType ta $ dumpList' [("endian"    ,dumpMotifEndian,cARDINAL)@@ -960,11 +1031,11 @@                            ,("style"     ,dumpMDropStyle ,cARDINAL) -- @@@ dummy                            ] -dumpMDropStyle :: Decoder Bool+dumpMDropStyle :: HasCallStack => Decoder Bool dumpMDropStyle =  do   d <- getInt' 8   pad 1 $ case d of-            Nothing             -> propShortErr+            Nothing             -> propShortErr' 9             Just ps | ps == 0   -> pad 12 $ append "none"                     | ps == 1   -> pad 12 $ append "drop only"                     | ps == 2   ->          append "prefer preregister " >> dumpMDPrereg@@ -974,7 +1045,7 @@                     | ps == 6   -> pad 12 $ append "prefer receiver"                     | otherwise -> failure $ "unknown drop style " ++ show ps -dumpMDPrereg :: Decoder Bool+dumpMDPrereg :: HasCallStack => Decoder Bool dumpMDPrereg =  do   -- this is a bit ugly; we pretend to be extending the above dumpList'   append ","@@ -984,7 +1055,7 @@   append "drop sites = "   dsc' <- getInt' 16   case dsc' of-    Nothing  -> propShortErr+    Nothing  -> propShortErr' 10     Just dsc -> do       withIndent 13 $ append (show dsc)       pad 2 $ do@@ -992,36 +1063,36 @@         append "total size = "         withIndent 13 dump32         dumpMDBlocks $ fromIntegral dsc-    + dumpMDBlocks   :: Int -> Decoder Bool dumpMDBlocks _ =  propSimple "(drop site info)" -- @@@ maybe later if needed -dumpMotifEndian :: Decoder Bool+dumpMotifEndian :: HasCallStack => Decoder Bool dumpMotifEndian =  guardType cARDINAL $ guardSize 8 $ do-  c <- map twiddle `fmap` eat 1+  c <- map twiddle <$> eat 1   case c of     ['l'] -> append "little"     ['B'] -> append "big"     _     -> failure "bad endian flag" -pad     :: Int -> Decoder Bool -> Decoder Bool+pad     :: HasCallStack => Int -> Decoder Bool -> Decoder Bool pad n p =  do   vs <- gets value   if length vs < n-    then propShortErr+    then propShortErr' 11     else modify (\r -> r {value = drop n vs}) >> p -dumpPercent :: Decoder Bool+dumpPercent :: HasCallStack => Decoder Bool dumpPercent =  guardType cARDINAL $ do                  n <- getInt' 32                  case n of                    Nothing -> return False-                   Just n' -> +                   Just n' ->                        let pct = 100 * fromIntegral n' / fromIntegral (maxBound :: Word32)                            pct :: Double                         in append $ show (round pct :: Integer) ++ "%" -dumpWmHints :: Decoder Bool+dumpWmHints :: HasCallStack => Decoder Bool dumpWmHints =   guardType wM_HINTS $ do   msk <- getInt' 32@@ -1038,7 +1109,7 @@                                  ,("window_group" ,dumpWindow      ,wINDOW  )                                  ] -dumpBits    :: [String] -> Decoder Bool+dumpBits    :: HasCallStack => [String] -> Decoder Bool dumpBits bs =  guardType cARDINAL $ do                  n <- getInt' 32                  case n of@@ -1096,6 +1167,9 @@             ,"pager/task list"             ] +cpState :: [String]+cpState =  ["no preference","disable compositing","force compositing"]+ {- eventually... wmHintsFlags :: [String] wmHintsFlags =  ["Input"@@ -1139,6 +1213,12 @@ wmState :: [String] wmState =  ["Withdrawn","Normal","Zoomed (obsolete)","Iconified","Inactive"] +nwAction :: [String]+nwAction =  ["Clear", "Set", "Toggle"]++wmGravity :: [String]+wmGravity =  ["forget/unmap","NW","N","NE","W","C","E","SW","S","SE","static"]+ nwmEnum                  :: Maybe String                          -> [String]                          -> [String]@@ -1148,7 +1228,7 @@ -- and the lowest level coercions --  -- parse and return an integral value-getInt'    :: Int -> Decoder (Maybe Integer)+getInt'    :: HasCallStack => Int -> Decoder (Maybe Integer) -- see XSync documentation for this insanity getInt' 64 =  guardR width 32 (\a e -> propSizeErr a e >> return Nothing) $               guardSize' 8 (propShortErr >> return Nothing) $ do@@ -1156,8 +1236,8 @@                 hi <- inhale 32                 return $ Just $ lo + hi * (fromIntegral (maxBound :: Word32) + 1) getInt' w  =  guardR width w  (\a e -> propSizeErr a e >> return Nothing) $-              guardSize' (bytes w) (propShortErr >> return Nothing)       $-              Just `fmap` inhale w+              guardSize' (bytes w) (propShortErr' 13 >> return Nothing)       $+              Just <$> inhale w  -- parse an integral value and feed it to a show-er of some kind getInt     :: Int -> (Integer -> String) -> Decoder Bool@@ -1187,7 +1267,7 @@  eat   :: Int -> Decoder Raw eat n =  do-  (bs,rest) <- splitAt n `fmap` gets value+  (bs,rest) <- gets (splitAt n . value)   modify (\r -> r {value = rest})   return bs @@ -1198,8 +1278,8 @@ append =  append' True  -- and the same but for errors-failure :: String -> Decoder Bool-failure =  append' False+failure :: HasCallStack => String -> Decoder Bool+failure =  append' False . (++ prettyCallStack callStack)  -- common appender append'     :: Bool -> String -> Decoder Bool@@ -1213,8 +1293,12 @@ propSimple s =  modify (\r -> r {value = []}) >> append s  -- report various errors-propShortErr :: Decoder Bool+propShortErr :: HasCallStack => Decoder Bool propShortErr =  failure "(property ended prematurely)"++-- debug version+propShortErr'   :: HasCallStack => Int -> Decoder Bool+propShortErr' n =  failure $ "(short prop " ++ show n ++ ")"  propSizeErr     :: Int -> Int -> Decoder Bool propSizeErr e a =  failure $ "(bad bit width " ++
XMonad/Hooks/DebugKeyEvents.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Hooks.DebugKeyEvents+-- Description  : Track key events. -- Copyright    : (c) 2011 Brandon S Allbery <allbery.b@gmail.com> -- License      : BSD --@@ -18,6 +20,7 @@                                    ) where  import           XMonad.Core+import           XMonad.Prelude import           XMonad.Operations               (cleanMask)  import           Graphics.X11.Xlib@@ -25,8 +28,6 @@  import           Control.Monad.State             (gets) import           Data.Bits-import           Data.List                       (intercalate)-import           Data.Monoid import           Numeric                         (showHex) import           System.IO                       (hPutStrLn                                                  ,stderr)@@ -40,7 +41,7 @@ -- -- If you already have a handleEventHook then you should append it: ----- >      , handleEventHook = ... <+> debugKeyEvents+-- >      , handleEventHook = ... <> debugKeyEvents -- -- Logged key events look like: --@@ -50,33 +51,32 @@ -- the key; @mask@ is raw, and @clean@ is what @xmonad@ sees after -- sanitizing it (removing @numberLockMask@, etc.) ----- For more detailed instructions on editing the logHook see:------ "XMonad.Doc.Extending#The_log_hook_and_external_status_bars"+-- For more detailed instructions on editing the logHook see+-- <https://xmonad.org/TUTORIAL.html#make-xmonad-and-xmobar-talk-to-each-other the tutorial>.  -- | Print key events to stderr for debugging debugKeyEvents :: Event -> X All-debugKeyEvents (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code})+debugKeyEvents KeyEvent{ev_event_type = t, ev_state = m, ev_keycode = code}   | t == keyPress =       withDisplay $ \dpy -> do         sym <- io $ keycodeToKeysym dpy code 0         msk <- cleanMask m         nl <- gets numberlockMask-        io $ hPutStrLn stderr $ intercalate " " ["keycode"-                                                ,show code-                                                ,"sym"-                                                ,show sym-                                                ," ("-                                                ,hex sym-                                                ," \""-                                                ,keysymToString sym-                                                ,"\") mask"-                                                ,hex m-                                                ,"(" ++ vmask nl m ++ ")"-                                                ,"clean"-                                                ,hex msk-                                                ,"(" ++ vmask nl msk ++ ")"-                                                ]+        io $ hPutStrLn stderr $ unwords ["keycode"+                                        ,show code+                                        ,"sym"+                                        ,show sym+                                        ," ("+                                        ,hex sym+                                        ," \""+                                        ,keysymToString sym+                                        ,"\") mask"+                                        ,hex m+                                        ,"(" ++ vmask nl m ++ ")"+                                        ,"clean"+                                        ,hex msk+                                        ,"(" ++ vmask nl msk ++ ")"+                                        ]         return (All True) debugKeyEvents _ = return (All True) @@ -86,12 +86,12 @@  -- | Convert a modifier mask into a useful string vmask                 :: KeyMask -> KeyMask -> String-vmask numLockMask msk =  intercalate " " $+vmask numLockMask msk =  unwords $                          reverse $                          fst $                          foldr vmask' ([],msk) masks     where-      masks = map (\m -> (m,show m)) [0..toEnum (bitSize msk - 1)] +++      masks = map (\m -> (m,show m)) [0..toEnum (finiteBitSize msk - 1)] ++               [(numLockMask,"num"  )               ,(   lockMask,"lock" )               ,(controlMask,"ctrl" )
XMonad/Hooks/DebugStack.hs view
@@ -1,93 +1,109 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.DebugStack--- Copyright   :  (c) Brandon S Allbery KF8NH, 2012+-- Description :  Dump the state of the StackSet.+-- Copyright   :  (c) Brandon S Allbery KF8NH, 2014 -- License     :  BSD3-style (see LICENSE) -- -- Maintainer  :  allbery.b@gmail.com -- Stability   :  unstable -- Portability :  not portable ----- Dump the state of the 'StackSet'.  A @logHook@ and @handleEventHook@ are+-- Dump the state of the 'StackSet'. A @logHook@ and @handleEventHook@ are -- also provided. -- -----------------------------------------------------------------------------  module XMonad.Hooks.DebugStack (debugStack+                               ,debugStackFull                                ,debugStackString+                               ,debugStackFullString                                ,debugStackLogHook+                               ,debugStackFullLogHook                                ,debugStackEventHook+                               ,debugStackFullEventHook                                ) where  import           XMonad.Core-import qualified XMonad.StackSet         as W+import           XMonad.Prelude+import qualified XMonad.StackSet                                       as W  import           XMonad.Util.DebugWindow  import           Graphics.X11.Types                  (Window) import           Graphics.X11.Xlib.Extras            (Event) -import           Control.Monad                       (foldM)-import           Data.Map                            (toList)-import           Data.Monoid                         (All(..))+import           Data.Map                            (member) --- | Print the state of the current window stack to @stderr@, which for most---   installations goes to @~/.xsession-errors@.  "XMonad.Util.DebugWindow"---   is used to display the individual windows.+-- | Print the state of the current window stack for the current workspace to+--   @stderr@, which for most installations goes to @~/.xsession-errors@.+--   "XMonad.Util.DebugWindow" is used to display the individual windows. debugStack :: X () debugStack =  debugStackString >>= trace --- | The above packaged as a 'logHook'.  (Currently this is identical.)+-- | Print the state of the current window stack for all workspaces to+--   @stderr@, which for most installations goes to @~/.xsession-errors@.+--   "XMonad.Util.DebugWindow" is used to display the individual windows.+debugStackFull :: X ()+debugStackFull =  debugStackFullString >>= trace++-- | 'debugStack' packaged as a 'logHook'. (Currently this is identical.) debugStackLogHook :: X () debugStackLogHook =  debugStack --- | The above packaged as a 'handleEventHook'.  You almost certainly do not+-- | 'debugStackFull packaged as a 'logHook'. (Currently this is identical.)+debugStackFullLogHook :: X ()+debugStackFullLogHook =  debugStackFull++-- | 'debugStack' packaged as a 'handleEventHook'. You almost certainly do not --   want to use this unconditionally, as it will cause massive amounts of --   output and possibly slow @xmonad@ down severely.  debugStackEventHook   :: Event -> X All debugStackEventHook _ =  debugStack >> return (All True) --- | Dump the state of the current 'StackSet' as a multiline 'String'.+-- | 'debugStackFull' packaged as a 'handleEventHook'. You almost certainly do+--   not want to use this unconditionally, as it will cause massive amounts of+--   output and possibly slow @xmonad@ down severely.++debugStackFullEventHook   :: Event -> X All+debugStackFullEventHook _ =  debugStackFull >> return (All True)++-- | Dump the state of the current workspace in the 'StackSet' as a multiline 'String'.+debugStackString :: X String+debugStackString =  withWindowSet $ debugStackWs . W.workspace . W.current++-- | Dump the state of all workspaces in the 'StackSet' as a multiline 'String'.+-- @@@ this is in stackset order, which is roughly lru-ish+debugStackFullString :: X String+debugStackFullString =  withWindowSet $ fmap (intercalate "\n") . mapM debugStackWs . W.workspaces++-- | Dump the state of a workspace in the current 'StackSet' as a multiline 'String'. --   @---   stack [    mm---         ,(*) ww---         ,    ww---         ]---   float {    ww---         ,    ww---         }+--   Workspace "foo::+--     mm+--   * ww+--    ^ww --   @------ One thing I'm not sure of is where the zipper is when focus is on a--- floating window.-debugStackString :: X String-debugStackString =  withWindowSet $ \ws -> do-                      s <- emit "stack" ("[","]") (W.peek ws)                    $ W.index    ws-                      f <- emit "float" ("{","}") (W.peek ws) $ map fst $ toList $ W.floating ws-                      return $ s ++ f+--   * indicates the focused window, ^ indicates a floating window+debugStackWs   :: W.Workspace String (Layout Window) Window -> X String+debugStackWs w =  withWindowSet $ \ws -> do+  let cur = if wt == W.currentTag ws then " (current)" else ""+      wt  = W.tag w+  s <- emit ws $ W.integrate' . W.stack $ w+  return $ intercalate "\n" $ ("Workspace " ++ show wt ++ cur):s   where-    emit :: String -> (String,String) -> Maybe Window -> [Window] -> X String-    emit title (lb,rb) _       [] = return $ title ++ " " ++ lb ++ rb ++ "]\n"-    emit title (lb,rb) focused ws = do-      (_,_,_,_,ss) <- foldM emit' (title,lb,rb,focused,"") ws-      return $ ss                               ++-               replicate (length title + 1) ' ' ++-               rb                               ++-               "\n"+    emit       :: WindowSet -> [Window] -> X [String]+    emit _  [] =  return ["    -empty workspace-"]+    emit ww ws = do+      (_,ss) <- foldM emit' (ww,[]) ws+      return ss -    emit' :: (String,String,String,Maybe Window,String)+    emit' :: (WindowSet,[String])           -> Window-          -> X (String,String,String,Maybe Window,String)-    emit' (t,l,r,f,a) w = do-      w' <- emit'' f w-      return (replicate (length t) ' '-             ,',' : replicate (length l - 1) ' '-             ,r-             ,f-             ,a ++ t ++ " " ++ l ++ w' ++ "\n"-             )-    emit'' :: Maybe Window -> Window -> X String-    emit'' focus win =-      let fi f = if win == f then "(*) " else "    "-       in (maybe "    " fi focus ++) `fmap` debugWindow win+          -> X (WindowSet,[String])+    emit' (ws,a) w' = do+      let focus = if Just w' == W.peek ws then '*' else ' '+          float = if w' `member` W.floating ws then '^' else ' '+      s <- debugWindow w'+      return (ws,(focus:float:s):a)
XMonad/Hooks/DynamicBars.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.DynamicBars+-- Description :  Manage per-screen status bars. -- Copyright   :  (c) Ben Boeckel 2012 -- License     :  BSD-style (as xmonad) --@@ -12,93 +13,135 @@ -- ----------------------------------------------------------------------------- -module XMonad.Hooks.DynamicBars (+module XMonad.Hooks.DynamicBars {-# DEPRECATED "Use XMonad.Hooks.StatusBar instead" #-} (   -- * Usage   -- $usage     DynamicStatusBar   , DynamicStatusBarCleanup+  , DynamicStatusBarPartialCleanup   , dynStatusBarStartup+  , dynStatusBarStartup'   , dynStatusBarEventHook+  , dynStatusBarEventHook'   , multiPP+  , multiPPFormat   ) where  import Prelude -import Control.Concurrent.MVar-import Control.Monad import Control.Monad.Trans (lift) import Control.Monad.Writer (WriterT, execWriterT, tell) -import Data.Maybe-import Data.Monoid-import Data.Traversable (traverse)- import Graphics.X11.Xinerama import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras import Graphics.X11.Xrandr  import System.IO-import System.IO.Unsafe  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W import XMonad.Hooks.DynamicLog+import qualified XMonad.Util.ExtensibleState as XS  -- $usage -- Provides a few helper functions to manage per-screen status bars while -- dynamically responding to screen changes. A startup action, event hook, and -- a way to separate PP styles based on the screen's focus are provided: ----- * The 'dynStatusBarStartup' hook which initializes the status bars.+-- * The 'dynStatusBarStartup' hook which initializes the status bars. The+-- first argument is an `ScreenId -> IO Handle` which spawns a status bar on the+-- given screen and returns the pipe which the string should be written to.+-- The second argument is a `IO ()` to shut down all status bars. This should+-- be placed in your `startupHook`. -- -- * The 'dynStatusBarEventHook' hook which respawns status bars when the--- number of screens changes.+-- number of screens changes. The arguments are the same as for the+-- `dynStatusBarStartup` function. This should be placed in your+-- `handleEventHook`. --+-- * Each of the above functions have an alternate form+-- (`dynStatusBarStartup'` and `dynStatusBarEventHook'`) which use a cleanup+-- function which takes an additional `ScreenId` argument which allows for+-- more fine-grained control for shutting down a specific screen's status bar.+-- -- * The 'multiPP' function which allows for different output based on whether--- the screen for the status bar has focus.+-- the screen for the status bar has focus (the first argument) or not (the+-- second argument). This is for use in your `logHook`. --+-- * The 'multiPPFormat' function is the same as the 'multiPP' function, but it+-- also takes in a function that can customize the output to status bars.+-- -- The hooks take a 'DynamicStatusBar' function which is given the id of the -- screen to start up and returns the 'Handle' to the pipe to write to. The -- 'DynamicStatusBarCleanup' argument should tear down previous instances. It -- is called when the number of screens changes and on startup. -- -data DynStatusBarInfo = DynStatusBarInfo-  { dsbInfoScreens :: [ScreenId]-  , dsbInfoHandles :: [Handle]+newtype DynStatusBarInfo = DynStatusBarInfo+  { dsbInfo :: [(ScreenId, Handle)]   } +instance ExtensionClass DynStatusBarInfo where+  initialValue = DynStatusBarInfo []+ type DynamicStatusBar = ScreenId -> IO Handle type DynamicStatusBarCleanup = IO ()+type DynamicStatusBarPartialCleanup = ScreenId -> IO () --- Global state-statusBarInfo :: MVar DynStatusBarInfo-statusBarInfo = unsafePerformIO $ newMVar (DynStatusBarInfo [] [])+dynStatusBarSetup :: X ()+dynStatusBarSetup = do+  dpy <- asks display+  root <- asks theRoot+  io $ xrrSelectInput dpy root rrScreenChangeNotifyMask  dynStatusBarStartup :: DynamicStatusBar -> DynamicStatusBarCleanup -> X ()-dynStatusBarStartup sb cleanup = liftIO $ do-  dpy <- openDisplay ""-  xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask-  closeDisplay dpy+dynStatusBarStartup sb cleanup = do+  dynStatusBarSetup   updateStatusBars sb cleanup +dynStatusBarStartup' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()+dynStatusBarStartup' sb cleanup = do+  dynStatusBarSetup+  updateStatusBars' sb cleanup+ dynStatusBarEventHook :: DynamicStatusBar -> DynamicStatusBarCleanup -> Event -> X All-dynStatusBarEventHook sb cleanup (RRScreenChangeNotifyEvent {}) = liftIO (updateStatusBars sb cleanup) >> return (All True)-dynStatusBarEventHook _  _       _                              = return (All True)+dynStatusBarEventHook sb cleanup = dynStatusBarRun (updateStatusBars sb cleanup) -updateStatusBars :: DynamicStatusBar -> DynamicStatusBarCleanup -> IO ()-updateStatusBars sb cleanup = liftIO $ do-  dsbInfo <- takeMVar statusBarInfo+dynStatusBarEventHook' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> Event -> X All+dynStatusBarEventHook' sb cleanup = dynStatusBarRun (updateStatusBars' sb cleanup)++dynStatusBarRun :: X () -> Event -> X All+dynStatusBarRun action RRScreenChangeNotifyEvent{} = action >> return (All True)+dynStatusBarRun _      _                           = return (All True)++updateStatusBars :: DynamicStatusBar -> DynamicStatusBarCleanup -> X ()+updateStatusBars sb cleanup = do+  (dsbInfoScreens, dsbInfoHandles) <- XS.get <&> unzip . dsbInfo   screens <- getScreens-  if (screens /= (dsbInfoScreens dsbInfo))-    then do-      mapM hClose (dsbInfoHandles dsbInfo)-      cleanup-      newHandles <- mapM sb screens-      putMVar statusBarInfo (DynStatusBarInfo screens newHandles)-    else putMVar statusBarInfo dsbInfo+  when (screens /= dsbInfoScreens) $ do+      newHandles <- liftIO $ do+          hClose `mapM_` dsbInfoHandles+          cleanup+          mapM sb screens+      XS.put $ DynStatusBarInfo (zip screens newHandles) +updateStatusBars' :: DynamicStatusBar -> DynamicStatusBarPartialCleanup -> X ()+updateStatusBars' sb cleanup = do+  (dsbInfoScreens, dsbInfoHandles) <- XS.get <&> (unzip . dsbInfo)+  screens <- getScreens+  when (screens /= dsbInfoScreens) $ do+      let oldInfo = zip dsbInfoScreens dsbInfoHandles+      let (infoToKeep, infoToClose) = partition (flip elem screens . fst) oldInfo+      newInfo <- liftIO $ do+          mapM_ (hClose . snd) infoToClose+          mapM_ (cleanup . fst) infoToClose+          let newScreens = screens \\ dsbInfoScreens+          newHandles <- mapM sb newScreens+          return $ zip newScreens newHandles+      XS.put . DynStatusBarInfo $ infoToKeep ++ newInfo+ ----------------------------------------------------------------------------- -- The following code is from adamvo's xmonad.hs file. -- http://www.haskell.org/haskellwiki/Xmonad/Config_archive/adamvo%27s_xmonad.hs@@ -106,10 +149,13 @@ multiPP :: PP -- ^ The PP to use if the screen is focused         -> PP -- ^ The PP to use otherwise         -> X ()-multiPP focusPP unfocusPP = do-  dsbInfo <- liftIO $ readMVar statusBarInfo-  multiPP' dynamicLogString focusPP unfocusPP (dsbInfoHandles dsbInfo)+multiPP = multiPPFormat dynamicLogString +multiPPFormat :: (PP -> X String) -> PP -> PP -> X ()+multiPPFormat dynlStr focusPP unfocusPP = do+  (_, dsbInfoHandles) <- XS.get <&> unzip . dsbInfo+  multiPP' dynlStr focusPP unfocusPP dsbInfoHandles+ multiPP' :: (PP -> X String) -> PP -> PP -> [Handle] -> X () multiPP' dynlStr focusPP unfocusPP handles = do   st <- get@@ -120,13 +166,12 @@         out <- lift $ dynlStr $ if isFoc then focusPP else unfocusPP         when isFoc $ get >>= tell . Last . Just         return out-  traverse put . getLast+  traverse_ put . getLast     =<< execWriterT . (io . zipWithM_ hPutStrLn handles <=< mapM pickPP) . catMaybes     =<< mapM screenWorkspace (zipWith const [0 .. ] handles)-  return () -getScreens :: IO [ScreenId]-getScreens = do+getScreens :: MonadIO m => m [ScreenId]+getScreens = liftIO $ do   screens <- do     dpy <- openDisplay ""     rects <- getScreenInfo dpy
XMonad/Hooks/DynamicHooks.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.DynamicHooks+-- Description :  One-shot and permanent ManageHooks that can be updated at runtime. -- Copyright   :  (c) Braden Shepherdson 2008 -- License     :  BSD-style (as xmonad) --@@ -23,12 +23,9 @@   ) where  import XMonad+import XMonad.Prelude import qualified XMonad.Util.ExtensibleState as XS -import Data.List-import Data.Maybe (listToMaybe)-import Data.Monoid- -- $usage -- Provides two new kinds of 'ManageHooks' that can be defined at runtime. --@@ -41,7 +38,7 @@ -- -- To use this module, add 'dynamicMasterHook' to your 'manageHook': ----- > xmonad { manageHook = myManageHook <+> dynamicMasterHook }+-- > xmonad { manageHook = myManageHook <> dynamicMasterHook } -- -- You can then use the supplied functions in your keybindings: --@@ -51,7 +48,6 @@ data DynamicHooks = DynamicHooks     { transients :: [(Query Bool, ManageHook)]     , permanent  :: ManageHook }-                    deriving Typeable  instance ExtensionClass DynamicHooks where     initialValue = DynamicHooks [] idHook@@ -62,19 +58,19 @@ -- doFloat and doIgnore are idempotent. -- | Master 'ManageHook' that must be in your @xmonad.hs@ 'ManageHook'. dynamicMasterHook :: ManageHook-dynamicMasterHook = (ask >>= \w -> liftX (do+dynamicMasterHook = ask >>= \w -> liftX $ do   dh <- XS.get   (Endo f)  <- runQuery (permanent dh) w   ts <- mapM (\(q,a) -> runQuery q w >>= \x -> return (x,(q, a))) (transients dh)   let (ts',nts) = partition fst ts   gs <- mapM (flip runQuery w . snd . snd) ts'-  let (Endo g) = maybe (Endo id) id $ listToMaybe gs+  let (Endo g) = fromMaybe (Endo id) $ listToMaybe gs   XS.put $ dh { transients = map snd nts }   return $ Endo $ f . g-                                       ))+ -- | Appends the given 'ManageHook' to the permanent dynamic 'ManageHook'. addDynamicHook :: ManageHook -> X ()-addDynamicHook m = updateDynamicHook (<+> m)+addDynamicHook m = updateDynamicHook (<> m)  -- | Modifies the permanent 'ManageHook' with an arbitrary function. updateDynamicHook :: (ManageHook -> ManageHook) -> X ()@@ -90,4 +86,4 @@ -- > oneShotHook dynHooksRef (className =? "example) doFloat -- oneShotHook :: Query Bool -> ManageHook -> X ()-oneShotHook q a = XS.modify $ \dh -> dh { transients = (q,a):(transients dh) }+oneShotHook q a = XS.modify $ \dh -> dh { transients = (q,a):transients dh }
+ XMonad/Hooks/DynamicIcons.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.DynamicIcons+-- Description :  Dynamically update workspace names based on its contents\/windows on it.+-- Copyright   :  (c) Ivy Pierlot <ivyp@outlook.com.au>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Ivy Pierlot <ivyp@outlook.com.au>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Dynamically augment workspace names logged to a status bar+-- based on the contents (windows) of the workspace.+-----------------------------------------------------------------------------++module XMonad.Hooks.DynamicIcons (+    -- * Usage+    -- $usage++    -- * Creating Dynamic Icons+    iconsPP, dynamicLogIconsWithPP, appIcon,++    -- * Customization+    dynamicIconsPP, getWorkspaceIcons,+    IconConfig(..),+    iconsFmtAppend, iconsFmtReplace, wrapUnwords,+    iconsGetAll, iconsGetFocus,++    ) where+import XMonad++import qualified XMonad.StackSet as S+import qualified Data.Map as M++import XMonad.Hooks.StatusBar.PP+import XMonad.Prelude (for, maybeToList, (<&>), (<=<), (>=>))++-- $usage+-- Dynamically augment Workspace's 'WorkspaceId' as shown on a status bar+-- based on the 'Window's inside the Workspace.+--+-- Icons are specified by a @Query [String]@, which is something like a+-- 'ManageHook' (and uses the same syntax) that returns a list of 'String's+-- (icons). This 'Query' is evaluated for each window and the results are+-- joined together. 'appIcon' is a useful shortcut here.+--+-- For example:+--+-- > myIcons :: Query [String]+-- > myIcons = composeAll+-- >   [ className =? "discord" --> appIcon "\xfb6e"+-- >   , className =? "Discord" --> appIcon "\xf268"+-- >   , className =? "Firefox" --> appIcon "\63288"+-- >   , className =? "Spotify" <||> className =? "spotify" --> appIcon "阮"+-- >   ]+--+-- then you can add it to your "XMonad.Hooks.StatusBar" config:+--+-- > myBar = statusBarProp "xmobar" (iconsPP myIcons myPP)+-- > main = xmonad . withSB myBar $ … $ def+--+-- Here is an example of this+--+-- <<https://user-images.githubusercontent.com/300342/111010930-36a54300-8398-11eb-8aec-b3059b04fa31.png>>+--+-- Note: You can use any string you want here.+-- The example shown here uses NerdFont Icons to represent open applications.+--+-- If you want to customize formatting and/or combine this with other+-- 'PP' extensions like "XMonad.Util.ClickableWorkspaces", here's a more+-- advanced example how to do that:+--+-- > myIconConfig = def{ iconConfigIcons = myIcons, iconConfigFmt = iconsFmtAppend concat }+-- > myBar = statusBarProp "xmobar" (clickablePP =<< dynamicIconsPP myIconConfig myPP)+-- > main = xmonad . withSB myBar . … $ def+--+-- This can be also used with "XMonad.Hooks.DynamicLog":+--+-- > main = xmonad $ … $ def+-- >   { logHook = dynamicLogIconsWithPP myIcons xmobarPP+-- >   , … }+--+-- or with more customziation:+--+-- > myIconConfig = def{ iconConfigIcons = myIcons, iconConfigFmt = iconsFmtAppend concat }+-- > main = xmonad $ … $ def+-- >   { logHook = xmonadPropLog =<< dynamicLogString =<< clickablePP =<<+-- >               dynamicIconsPP myIconConfig xmobarPP+-- >   , … }+++-- | Shortcut for configuring single icons.+appIcon :: String -> Query [String]+appIcon = pure . pure++-- | Adjusts the 'PP' and then runs 'dynamicLogWithPP'+dynamicLogIconsWithPP :: Query [String] -- ^ The 'IconSet' to use+                      -> PP -- ^ The 'PP' to alter+                      -> X () -- ^ The resulting 'X' action+dynamicLogIconsWithPP q = dynamicLogWithPP <=< iconsPP q++-- | Adjusts the 'PP' with the given 'IconSet'+iconsPP :: Query [String] -- ^ The 'IconSet' to use+        -> PP -- ^ The 'PP' to alter+        -> X PP -- ^ The resulting 'X PP'+iconsPP q = dynamicIconsPP def{ iconConfigIcons = q }++-- | Modify a pretty-printer, 'PP', to augment+-- workspace names with icons based on the contents (windows) of the workspace.+dynamicIconsPP :: IconConfig -> PP -> X PP+dynamicIconsPP ic pp = getWorkspaceIcons ic <&> \ren -> pp{ ppRename = ppRename pp >=> ren }++-- | Returns a function for 'ppRename' that augments workspaces with icons+-- according to the provided 'IconConfig'.+getWorkspaceIcons :: IconConfig -> X (String -> WindowSpace -> String)+getWorkspaceIcons conf@IconConfig{..} = fmt <$> getWorkspaceIcons' conf+  where+    fmt icons s w = iconConfigFmt s (M.findWithDefault [] (S.tag w) icons)++getWorkspaceIcons' :: IconConfig  -> X (M.Map WorkspaceId [String])+getWorkspaceIcons' IconConfig{..} = do+    ws <- gets (S.workspaces . windowset)+    is <- for ws $ foldMap (runQuery iconConfigIcons) <=< iconConfigFilter . S.stack+    pure $ M.fromList (zip (map S.tag ws) is)++-- | Datatype for expanded 'Icon' configurations+data IconConfig = IconConfig+    { iconConfigIcons :: Query [String]+      -- ^ What icons to use for each window.+    , iconConfigFmt :: WorkspaceId -> [String] -> String+      -- ^ How to format the result, see 'iconsFmtReplace', 'iconsFmtAppend'.+    , iconConfigFilter :: Maybe (S.Stack Window) -> X [Window]+      -- ^ Which windows (icons) to show.+    }++instance Default IconConfig where+    def = IconConfig+        { iconConfigIcons = mempty+        , iconConfigFmt = iconsFmtReplace (wrapUnwords "{" "}")+        , iconConfigFilter = iconsGetAll+        }++-- | 'iconConfigFmt' that replaces the workspace name with icons, if any.+--+-- First parameter specifies how to concatenate multiple icons. Useful values+-- include: 'concat', 'unwords', 'wrapUnwords'.+--+-- ==== __Examples__+--+-- >>> iconsFmtReplace concat "1" []+-- "1"+--+-- >>> iconsFmtReplace concat "1" ["A", "B"]+-- "AB"+--+-- >>> iconsFmtReplace (wrapUnwords "{" "}") "1" ["A", "B"]+-- "{A B}"+iconsFmtReplace :: ([String] -> String) -> WorkspaceId -> [String] -> String+iconsFmtReplace cat ws is | null is   = ws+                          | otherwise = cat is++-- | 'iconConfigFmt' that appends icons to the workspace name.+--+-- First parameter specifies how to concatenate multiple icons. Useful values+-- include: 'concat', 'unwords', 'wrapUnwords'.+--+-- ==== __Examples__+--+-- >>> iconsFmtAppend concat "1" []+-- "1"+--+-- >>> iconsFmtAppend concat "1" ["A", "B"]+-- "1:AB"+iconsFmtAppend :: ([String] -> String) -> WorkspaceId -> [String] -> String+iconsFmtAppend cat ws is | null is   = ws+                         | otherwise = ws ++ ':' : cat is++-- | Join words with spaces, and wrap the result in delimiters unless there+-- was exactly one element.+--+-- ==== __Examples__+--+-- >>> wrapUnwords "{" "}" ["A", "B"]+-- "{A B}"+--+-- >>> wrapUnwords "{" "}" ["A"]+-- "A"+--+-- >>> wrapUnwords "{" "}" []+-- ""+wrapUnwords :: String -> String -> [String] -> String+wrapUnwords _ _ [x] = x+wrapUnwords l r xs  = wrap l r (unwords xs)++-- | 'iconConfigFilter' that shows all windows of every workspace.+iconsGetAll :: Maybe (S.Stack Window) -> X [Window]+iconsGetAll = pure . S.integrate'++-- | 'iconConfigFilter' that shows only the focused window for each workspace.+iconsGetFocus :: Maybe (S.Stack Window) -> X [Window]+iconsGetFocus = pure . maybeToList . fmap S.focus
XMonad/Hooks/DynamicLog.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleContexts, PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.DynamicLog+-- Description :  Send information about xmonad's state to an X11 property or standard output. -- Copyright   :  (c) Don Stewart <dons@cse.unsw.edu.au> -- License     :  BSD3-style (see LICENSE) --@@ -10,6 +11,16 @@ -- Stability   :  unstable -- Portability :  unportable --+-- __Note:__ This module is a __compatibility wrapper__ for the following:+--+-- * "XMonad.Hooks.StatusBar"+-- * "XMonad.Hooks.StatusBar.PP"+--+-- DynamicLog API is frozen and users are encouraged to migrate to these+-- modern replacements.+--+-- /Original description and documentation follows:/+-- -- xmonad calls the logHook with every internal state update, which is -- useful for (among other things) outputting status information to an -- external status bar program such as xmobar or dzen.  DynamicLog@@ -23,72 +34,59 @@     -- $usage      -- * Drop-in loggers-    dzen,+    xmobarProp,     xmobar,     statusBar,+    dzen,+    dzenWithFlags,     dynamicLog,     dynamicLogXinerama, -    xmonadPropLog',     xmonadPropLog,+    xmonadPropLog',+    xmonadDefProp,      -- * Build your own formatter     dynamicLogWithPP,     dynamicLogString,-    PP(..), defaultPP,+    PP(..), def,      -- * Example formatters     dzenPP, xmobarPP, sjanssenPP, byorgeyPP,      -- * Formatting utilities-    wrap, pad, trim, shorten,-    xmobarColor, xmobarStrip,-    dzenColor, dzenEscape, dzenStrip,+    wrap, pad, trim, shorten, shorten', shortenLeft, shortenLeft',+    xmobarColor, xmobarAction, xmobarBorder,+    xmobarRaw, xmobarStrip, xmobarStripTags,+    dzenColor, dzenEscape, dzenStrip, filterOutWsPP,      -- * Internal formatting functions     pprWindowSet,-    pprWindowSetXinerama--    -- * To Do-    -- $todo+    pprWindowSetXinerama,    ) where  -- Useful imports -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.Ord ( comparing )-import qualified Data.Map as M-import qualified XMonad.StackSet as S--import Foreign.C (CChar)- import XMonad -import XMonad.Util.WorkspaceCompare-import XMonad.Util.NamedWindows-import XMonad.Util.Run- import XMonad.Layout.LayoutModifier-import XMonad.Hooks.UrgencyHook import XMonad.Hooks.ManageDocks+import XMonad.Hooks.StatusBar.PP+import XMonad.Hooks.StatusBar  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: ----- >    import XMonad--- >    import XMonad.Hooks.DynamicLog+-- > import XMonad+-- > import XMonad.Hooks.DynamicLog -- -- If you just want a quick-and-dirty status bar with zero effort, try -- the 'xmobar' or 'dzen' functions: -- -- > main = xmonad =<< xmobar myConfig -- >--- > myConfig = defaultConfig { ... }+-- > myConfig = def { ... } -- -- There is also 'statusBar' if you'd like to use another status bar, or would -- like to use different formatting options.  The 'xmobar', 'dzen', and@@ -99,7 +97,7 @@ -- ('dynamicLog' or 'dynamicLogXinerama') by simply setting your logHook to the -- appropriate function, for instance: ----- > main = xmonad $ defaultConfig {+-- > main = xmonad $ def { -- >    ... -- >    logHook = dynamicLog -- >    ...@@ -124,9 +122,9 @@ -- > -- > main = do -- >     h <- spawnPipe "xmobar -options -foo -bar"--- >     xmonad $ defaultConfig {+-- >     xmonad $ def { -- >       ...--- >       logHook = dynamicLogWithPP $ defaultPP { ppOutput = hPutStrLn h }+-- >       logHook = dynamicLogWithPP $ def { ppOutput = hPutStrLn h } -- -- If you use @spawnPipe@, be sure to redefine the 'ppOutput' field of -- your pretty-printer as in the example above; by default the status@@ -138,102 +136,76 @@ -- changes, you could make a keybinding to cycle the layout and -- display the current status: ----- >    , ((mod1Mask, xK_a     ), sendMessage NextLayout >> (dynamicLogString myPP >>= \d->spawn $"xmessage "++d))+-- >    , ((mod1Mask, xK_a     ), sendMessage NextLayout >> (dynamicLogString myPP >>= xmessage)) -- --- $todo+------------------------------------------------------------------------++-- | Run xmonad with a dzen status bar with specified dzen+--   command line arguments. -----   * incorporate dynamicLogXinerama into the PP framework somehow+-- > main = xmonad =<< dzenWithFlags flags myConfig+-- >+-- > myConfig = def { ... }+-- >+-- > flags = "-e onstart lower -w 800 -h 24 -ta l -fg #a8a3f7 -bg #3f3c6d" -----   * add an xmobarEscape function--------------------------------------------------------------------------+-- This function works much in the same way as the 'dzen' function, only that it+-- can also be used to customize the arguments passed to dzen2, e.g changing the+-- default width and height of dzen2.+--+-- You should use this function only when the default 'dzen' function does not+-- serve your purpose.+--+dzenWithFlags :: LayoutClass l Window+              => String     -- ^ Flags to give to @dzen@+              -> XConfig l  -- ^ The base config+              -> IO (XConfig (ModifiedLayout AvoidStruts l))+dzenWithFlags flags = statusBar ("dzen2 " ++ flags) dzenPP toggleStrutsKey  -- | Run xmonad with a dzen status bar set to some nice defaults. -- -- > main = xmonad =<< dzen myConfig -- >--- > myConfig = defaultConfig { ... }------ 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.+-- > myConfig = def { ... } ----- The binding uses the XMonad.Hooks.ManageDocks module to automatically--- handle screen placement for dzen, and enables 'mod-b' for toggling--- the menu bar.+-- This works pretty much the same as the 'xmobar' function. -- dzen :: LayoutClass l Window-     => XConfig l -> IO (XConfig (ModifiedLayout AvoidStruts l))-dzen conf = statusBar ("dzen2 " ++ flags) dzenPP toggleStrutsKey conf+     => XConfig l  -- ^ The base config+     -> IO (XConfig (ModifiedLayout AvoidStruts l))+dzen = dzenWithFlags flags  where     fg      = "'#a8a3f7'" -- n.b quoting     bg      = "'#3f3c6d'"-    flags   = "-e 'onstart=lower' -w 400 -ta l -fg " ++ fg ++ " -bg " ++ bg-+    flags   = "-e 'onstart=lower' -dock -w 400 -ta l -fg " ++ fg ++ " -bg " ++ bg --- | Run xmonad with a xmobar status bar set to some nice defaults.------ > main = xmonad =<< xmobar myConfig--- >--- > myConfig = defaultConfig { ... }------ This works pretty much the same as 'dzen' function above.---+-- | This function works like 'xmobarProp', but uses pipes instead of+-- property-based logging. xmobar :: LayoutClass l Window-       => XConfig l -> IO (XConfig (ModifiedLayout AvoidStruts l))-xmobar conf = statusBar "xmobar" xmobarPP toggleStrutsKey conf+       => XConfig l  -- ^ The base config+       -> IO (XConfig (ModifiedLayout AvoidStruts l))+xmobar = statusBar "xmobar" xmobarPP toggleStrutsKey --- | Modifies the given base configuration to launch the given status bar,--- send status information to that bar, and allocate space on the screen edges--- for the bar.+-- | Like 'statusBarProp', but uses pipes instead of property-based logging.+-- Only use this function if your status bar does not support reading from a+-- property of the root window. statusBar :: LayoutClass l Window-          => String    -- ^ the command line to launch the status bar-          -> PP        -- ^ the pretty printing options+          => String    -- ^ The command line to launch the status bar+          -> PP        -- ^ The pretty printing options           -> (XConfig Layout -> (KeyMask, KeySym))-                       -- ^ the desired key binding to toggle bar visibility-          -> XConfig l -- ^ the base config+                       -- ^ The desired key binding to toggle bar visibility+          -> XConfig l -- ^ The base config           -> IO (XConfig (ModifiedLayout AvoidStruts l))-statusBar cmd pp k conf = do-    h <- spawnPipe cmd-    return $ conf-        { layoutHook = avoidStruts (layoutHook conf)-        , logHook = do-                        logHook conf-                        dynamicLogWithPP pp { ppOutput = hPutStrLn h }-        , manageHook = manageHook conf <+> manageDocks-        , keys       = liftM2 M.union keys' (keys conf)-        }- where-    keys' = (`M.singleton` sendMessage ToggleStruts) . k---- | Write a string to a property on the root window.  This property is of--- type UTF8_STRING. The string must have been processed by encodeString--- (dynamicLogString does this).-xmonadPropLog' :: String -> String -> X ()-xmonadPropLog' prop msg = do-    d <- asks display-    r <- asks theRoot-    xlog <- getAtom prop-    ustring <- getAtom "UTF8_STRING"-    io $ changeProperty8 d r xlog ustring propModeReplace (encodeCChar msg)- where-    encodeCChar :: String -> [CChar]-    encodeCChar = map (fromIntegral . ord)---- | Write a string to the _XMONAD_LOG property on the root window.-xmonadPropLog :: String -> X ()-xmonadPropLog = xmonadPropLog' "_XMONAD_LOG"+statusBar cmd pp k conf= do+  sb <- statusBarPipe cmd (pure pp)+  return $ withEasySB sb k conf  -- | -- Helper function which provides ToggleStruts keybinding -- toggleStrutsKey :: XConfig t -> (KeyMask, KeySym)-toggleStrutsKey XConfig{modMask = modm} = (modm, xK_b )--------------------------------------------------------------------------+toggleStrutsKey = defToggleStrutsKey  -- | An example log hook, which prints status information to stdout in -- the default format:@@ -246,58 +218,7 @@ -- To customize the output format, see 'dynamicLogWithPP'. -- dynamicLog :: X ()-dynamicLog = dynamicLogWithPP defaultPP---- | Format the current status using the supplied pretty-printing format,---   and write it to stdout.-dynamicLogWithPP :: PP -> X ()-dynamicLogWithPP pp = dynamicLogString pp >>= io . ppOutput pp---- | The same as 'dynamicLogWithPP', except it simply returns the status---   as a formatted string without actually printing it to stdout, to---   allow for further processing, or use in some application other than---   a status bar.-dynamicLogString :: PP -> X String-dynamicLogString pp = do--    winset <- gets windowset-    urgents <- readUrgents-    sort' <- ppSort pp--    -- layout description-    let ld = description . S.layout . S.workspace . S.current $ winset--    -- workspace list-    let ws = pprWindowSet sort' urgents pp winset--    -- window title-    wt <- maybe (return "") (fmap show . getName) . S.peek $ winset--    -- run extra loggers, ignoring any that generate errors.-    extras <- mapM (flip catchX (return Nothing)) $ ppExtras pp--    return $ encodeString . sepBy (ppSep pp) . ppOrder pp $-                        [ ws-                        , ppLayout pp ld-                        , ppTitle  pp $ ppTitleSanitize pp wt-                        ]-                        ++ catMaybes extras---- | Format the workspace information, given a workspace sorting function,---   a list of urgent windows, a pretty-printer format, and the current---   WindowSet.-pprWindowSet :: WorkspaceSort -> [Window] -> PP -> WindowSet -> String-pprWindowSet sort' urgents pp s = sepBy (ppWsSep pp) . map fmt . sort' $-            map S.workspace (S.current s : S.visible s) ++ S.hidden s-   where this     = S.currentTag s-         visibles = map (S.tag . S.workspace) (S.visible s)--         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-                        | isJust (S.stack w)                                            = ppHidden-                        | otherwise                                                     = ppHiddenNoWindows+dynamicLog = dynamicLogWithPP def  -- | -- Workspace logger with a format designed for Xinerama:@@ -312,230 +233,34 @@ -- using 'dynamicLogWithPP' by setting 'ppSort' to /getSortByXineramaRule/ from -- "XMonad.Util.WorkspaceCompare".  For example, ----- > defaultPP { ppCurrent = dzenColor "red" "#efebe7"--- >           , ppVisible = wrap "[" "]"--- >           , ppSort    = getSortByXineramaRule--- >           }+-- > def { ppCurrent = dzenColor "red" "#efebe7"+-- >     , ppVisible = wrap "[" "]"+-- >     , ppSort    = getSortByXineramaRule+-- >     } dynamicLogXinerama :: X () dynamicLogXinerama = withWindowSet $ io . putStrLn . pprWindowSetXinerama -pprWindowSetXinerama :: WindowSet -> String-pprWindowSetXinerama ws = "[" ++ unwords onscreen ++ "] " ++ unwords offscreen-  where onscreen  = map (S.tag . S.workspace)-                        . sortBy (comparing S.screen) $ S.current ws : S.visible ws-        offscreen = map S.tag . filter (isJust . S.stack)-                        . sortBy (comparing S.tag) $ S.hidden ws---- | Wrap a string in delimiters, unless it is empty.-wrap :: String  -- ^ left delimiter-     -> String  -- ^ right delimiter-     -> String  -- ^ output string-     -> String-wrap _ _ "" = ""-wrap l r m  = l ++ m ++ r---- | Pad a string with a leading and trailing space.-pad :: String -> String-pad = wrap " " " "---- | Trim leading and trailing whitespace from a string.-trim :: String -> String-trim = f . f-    where f = reverse . dropWhile isSpace---- | Limit a string to a certain length, adding "..." if truncated.-shorten :: Int -> String -> String-shorten n xs | length xs < n = xs-             | otherwise     = take (n - length end) xs ++ end- where-    end = "..."---- | Output a list of strings, ignoring empty ones and separating the---   rest with the given separator.-sepBy :: String   -- ^ separator-      -> [String] -- ^ fields to output-      -> String-sepBy sep = concat . intersperse sep . filter (not . null)---- | Use dzen escape codes to output a string with given foreground---   and background colors.-dzenColor :: String  -- ^ foreground color: a color name, or #rrggbb format-          -> String  -- ^ background color-          -> String  -- ^ output string-          -> String-dzenColor fg bg = wrap (fg1++bg1) (fg2++bg2)- where (fg1,fg2) | null fg = ("","")-                 | otherwise = ("^fg(" ++ fg ++ ")","^fg()")-       (bg1,bg2) | null bg = ("","")-                 | otherwise = ("^bg(" ++ bg ++ ")","^bg()")---- | Escape any dzen metacharacters.-dzenEscape :: String -> String-dzenEscape = concatMap (\x -> if x == '^' then "^^" else [x])---- | Strip dzen formatting or commands.-dzenStrip :: String -> String-dzenStrip = strip [] where-    strip keep x-      | null x              = keep-      | "^^" `isPrefixOf` x = strip (keep ++ "^") (drop 2 x)-      | '^' == head x       = strip keep (drop 1 . dropWhile (/= ')') $ x)-      | otherwise           = let (good,x') = span (/= '^') x-                              in strip (keep ++ good) x'---- | Use xmobar escape codes to output a string with given foreground---   and background colors.-xmobarColor :: String  -- ^ foreground color: a color name, or #rrggbb format-            -> String  -- ^ background color-            -> String  -- ^ output string-            -> String-xmobarColor fg bg = wrap t "</fc>"- where t = concat ["<fc=", fg, if null bg then "" else "," ++ bg, ">"]---- ??? add an xmobarEscape function?---- | Strip xmobar markup.-xmobarStrip :: String -> String-xmobarStrip = xmobarStripTags ["fc","icon","action"] where--xmobarStripTags :: [String] -- ^ tags-        -> String -> String -- ^ with all <tag>...</tag> removed-xmobarStripTags tags = strip [] where-    strip keep [] = keep-    strip keep x-        | rest: _ <- mapMaybe dropTag tags = strip keep rest---        | '<':xs <- x = strip (keep ++ "<") xs-        | (good,x') <- span (/= '<') x = strip (keep ++ good) x' -- this is n^2 bad... but titles have few tags-      where dropTag :: String -> Maybe String-            dropTag tag = msum [fmap dropTilClose (openTag tag `stripPrefix` x),-                                                   closeTag tag `stripPrefix` x]--    dropTilClose, openTag, closeTag :: String -> String-    dropTilClose = drop 1 . dropWhile (/= '>')-    openTag str = "<" ++ str ++ "="-    closeTag str = "</" ++ str ++ ">"---- | The 'PP' type allows the user to customize the formatting of---   status information.-data PP = PP { ppCurrent :: WorkspaceId -> String-               -- ^ how to print the tag of the currently focused-               -- workspace-             , ppVisible :: WorkspaceId -> String-               -- ^ how to print tags of visible but not focused-               -- workspaces (xinerama only)-             , ppHidden  :: WorkspaceId -> String-               -- ^ how to print tags of hidden workspaces which-               -- contain windows-             , ppHiddenNoWindows :: WorkspaceId -> String-               -- ^ how to print tags of empty hidden workspaces-             , ppUrgent :: WorkspaceId -> String-               -- ^ format to be applied to tags of urgent workspaces.-             , ppSep :: String-               -- ^ separator to use between different log sections-               -- (window name, layout, workspaces)-             , ppWsSep :: String-               -- ^ separator to use between workspace tags-             , ppTitle :: String -> String-               -- ^ window title format-             , ppTitleSanitize :: String -> String-              -- ^  escape / sanitizes input to 'ppTitle'-             , ppLayout :: String -> String-               -- ^ layout name format-             , ppOrder :: [String] -> [String]-               -- ^ how to order the different log sections. By-               --   default, this function receives a list with three-               --   formatted strings, representing the workspaces,-               --   the layout, and the current window title,-               --   respectively. If you have specified any extra-               --   loggers in 'ppExtras', their output will also be-               --   appended to the list.  To get them in the reverse-               --   order, you can just use @ppOrder = reverse@.  If-               --   you don't want to display the current layout, you-               --   could use something like @ppOrder = \\(ws:_:t:_) ->-               --   [ws,t]@, and so on.-             , ppSort :: X ([WindowSpace] -> [WindowSpace])-               -- ^ how to sort the workspaces.  See-               -- "XMonad.Util.WorkspaceCompare" for some useful-               -- sorts.-             , ppExtras :: [X (Maybe String)]-               -- ^ loggers for generating extra information such as-               -- time and date, system load, battery status, and so-               -- on.  See "XMonad.Util.Loggers" for examples, or create-               -- your own!-             , ppOutput :: String -> IO ()-               -- ^ applied to the entire formatted string in order to-               -- output it.  Can be used to specify an alternative-               -- output method (e.g. write to a pipe instead of-               -- stdout), and\/or to perform some last-minute-               -- formatting.-             }---- | The default pretty printing options, as seen in 'dynamicLog'.-defaultPP :: PP-defaultPP = PP { ppCurrent         = wrap "[" "]"-               , ppVisible         = wrap "<" ">"-               , ppHidden          = id-               , ppHiddenNoWindows = const ""-               , ppUrgent          = id-               , ppSep             = " : "-               , ppWsSep           = " "-               , ppTitle           = shorten 80-               , ppTitleSanitize   = xmobarStrip . dzenEscape-               , ppLayout          = id-               , ppOrder           = id-               , ppOutput          = putStrLn-               , ppSort            = getSortByIndex-               , ppExtras          = []-               }---- | Settings to emulate dwm's statusbar, dzen only.-dzenPP :: PP-dzenPP = defaultPP { ppCurrent  = dzenColor "white" "#2b4f98" . pad-                   , ppVisible  = dzenColor "black" "#999999" . pad-                   , ppHidden   = dzenColor "black" "#cccccc" . pad-                   , ppHiddenNoWindows = const ""-                   , ppUrgent   = dzenColor "red" "yellow" . pad-                   , ppWsSep    = ""-                   , ppSep      = ""-                   , ppLayout   = dzenColor "black" "#cccccc" .-                                  (\ x -> pad $ case x of-                                            "TilePrime Horizontal" -> "TTT"-                                            "TilePrime Vertical"   -> "[]="-                                            "Hinted Full"          -> "[ ]"-                                            _                      -> x-                                  )-                   , ppTitle    = ("^bg(#324c80) " ++) . dzenEscape-                   }---- | Some nice xmobar defaults.-xmobarPP :: PP-xmobarPP = defaultPP { ppCurrent = xmobarColor "yellow" "" . wrap "[" "]"-                     , ppTitle   = xmobarColor "green"  "" . shorten 40-                     , ppVisible = wrap "(" ")"-                     , ppUrgent  = xmobarColor "red" "yellow"-                     }---- | The options that sjanssen likes to use with xmobar, as an--- example.  Note the use of 'xmobarColor' and the record update on--- 'defaultPP'.-sjanssenPP :: PP-sjanssenPP = defaultPP { ppCurrent = xmobarColor "white" "black"-                       , ppTitle = xmobarColor "#00ee00" "" . shorten 120-                       }---- | The options that byorgey likes to use with dzen, as another example.-byorgeyPP :: PP-byorgeyPP = defaultPP { ppHiddenNoWindows = showNamedWorkspaces-                      , ppHidden  = dzenColor "black"  "#a8a3f7" . pad-                      , ppCurrent = dzenColor "yellow" "#a8a3f7" . pad-                      , ppUrgent  = dzenColor "red"    "yellow"  . pad-                      , ppSep     = " | "-                      , ppWsSep   = ""-                      , ppTitle   = shorten 70-                      , ppOrder   = reverse-                      }-  where showNamedWorkspaces wsId = if any (`elem` wsId) ['a'..'z']-                                       then pad wsId-                                       else ""+-- | Run xmonad with a property-based xmobar status bar set to some nice+-- defaults.+--+-- > main = xmonad $ xmobarProp myConfig+-- >+-- > myConfig = def { ... }+--+-- The intent is that the above config file should provide a nice+-- status bar with minimal effort. Note that you still need to configure+-- xmobar to use the @XMonadLog@ plugin instead of the default @StdinReader@,+-- see above.+--+-- If you wish to customize the status bar format at all, use the modernized+-- interface provided by the "XMonad.Hooks.StatusBar" and+-- "XMonad.Hooks.StatusBar.PP" modules instead.+--+-- The binding uses the "XMonad.Hooks.ManageDocks" module to automatically+-- handle screen placement for xmobar, and enables 'mod-b' for toggling+-- the menu bar.+xmobarProp :: LayoutClass l Window+           => XConfig l  -- ^ The base config+           -> XConfig (ModifiedLayout AvoidStruts l)+xmobarProp =+  withEasySB (statusBarProp "xmobar" (pure xmobarPP)) toggleStrutsKey
+ XMonad/Hooks/DynamicProperty.hs view
@@ -0,0 +1,24 @@+-- |+-- Module      :  XMonad.Hooks.DynamicProperty+-- Description :  Apply a ManageHook to an already-mapped window.+-- Copyright   :  (c) Brandon S Allbery, 2015+-- License     :  BSD3-style (see LICENSE)+-- Maintainer  :  allbery.b@gmail.com+--+module XMonad.Hooks.DynamicProperty {-# DEPRECATED "Use \"XMonad.Hooks.OnPropertyChange\" instead." #-}+                                    ( module XMonad.Hooks.OnPropertyChange+                                    , dynamicPropertyChange+                                    , dynamicTitle+                                    ) where++import XMonad+import XMonad.Hooks.OnPropertyChange+import XMonad.Prelude++-- | 'dynamicPropertyChange' = 'onXPropertyChange'+dynamicPropertyChange :: String -> ManageHook -> Event -> X All+dynamicPropertyChange = onXPropertyChange++-- | 'dynamicTitle' = 'onTitleChange'+dynamicTitle :: ManageHook -> Event -> X All+dynamicTitle = onTitleChange
XMonad/Hooks/EwmhDesktops.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternGuards #-}+ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Hooks.EwmhDesktops+-- Description  : Make xmonad use the extended window manager hints (EWMH). -- Copyright    : (c) 2007, 2008 Joachim Breitner <mail@joachim-breitner.de> -- License      : BSD --@@ -8,109 +13,436 @@ -- Stability    : unstable -- Portability  : unportable ----- Makes xmonad use the EWMH hints to tell panel applications about its--- workspaces and the windows therein. It also allows the user to interact--- with xmonad by clicking on panels and window lists.+-- Makes xmonad use the+-- <https://specifications.freedesktop.org/wm-spec/latest/ EWMH>+-- hints to tell panel applications about its workspaces and the windows+-- therein. It also allows the user to interact with xmonad by clicking on+-- panels and window lists. ----------------------------------------------------------------------------- module XMonad.Hooks.EwmhDesktops (     -- * Usage     -- $usage     ewmh,+    ewmhFullscreen,+    ewmhDesktopsManageHook,+    ewmhDesktopsMaybeManageHook,++    -- * Customization+    -- $customization++    -- ** Sorting/filtering of workspaces+    -- $customSort+    addEwmhWorkspaceSort, setEwmhWorkspaceSort,++    -- ** Renaming of workspaces+    -- $customRename+    addEwmhWorkspaceRename, setEwmhWorkspaceRename,++    -- ** Window activation+    -- $customActivate+    setEwmhActivateHook,++    -- ** Workspace switching+    -- $customWorkspaceSwitch+    setEwmhSwitchDesktopHook,++    -- ** Fullscreen+    -- $customFullscreen+    setEwmhFullscreenHooks,++    -- ** @_NET_DESKTOP_VIEWPORT@+    -- $customManageDesktopViewport+    disableEwmhManageDesktopViewport,++    -- $customHiddenWorkspaceMapper+    setEwmhHiddenWorkspaceToScreenMapping,+    -- ** @_NET_WM_STATE_{ABOVE,BELOW}@+    -- $customManageAboveBelowState+    enableEwmhManageAboveBelowState,++    -- * Standalone hooks (deprecated)     ewmhDesktopsStartup,     ewmhDesktopsLogHook,     ewmhDesktopsLogHookCustom,     ewmhDesktopsEventHook,     ewmhDesktopsEventHookCustom,-    fullscreenEventHook+    fullscreenEventHook,+    fullscreenStartup,     ) where  import Codec.Binary.UTF8.String (encode)-import Data.List-import Data.Maybe-import Data.Monoid+import Data.Bits+import qualified Data.Map.Strict as M  import XMonad-import Control.Monad+import XMonad.Prelude import qualified XMonad.StackSet as W +import XMonad.Hooks.ManageHelpers import XMonad.Hooks.SetWMName-import XMonad.Util.XUtils (fi) import XMonad.Util.WorkspaceCompare import XMonad.Util.WindowProperties (getProp32)+import qualified XMonad.Util.ExtensibleConf as XC+import qualified XMonad.Util.ExtensibleState as XS  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Hooks.EwmhDesktops -- >--- > main = xmonad $ ewmh defaultConfig{ handleEventHook =--- >            handleEventHook defaultConfig <+> fullscreenEventHook }+-- > main = xmonad $ … . ewmhFullscreen . ewmh . … $ def{…} ----- You may also be interested in 'avoidStruts' from "XMonad.Hooks.ManageDocks".-+-- or, if fullscreen handling is not desired, just+--+-- > main = xmonad $ … . ewmh . … $ def{…}+--+-- You may also be interested in 'XMonad.Hooks.ManageDocks.docks' and+-- 'XMonad.Hooks.UrgencyHook.withUrgencyHook', which provide support for other+-- parts of the+-- <https://specifications.freedesktop.org/wm-spec/latest/ EWMH specification>. --- | Add EWMH functionality to the given config.  See above for an example.+-- | Add EWMH support for workspaces (virtual desktops) to the given+-- 'XConfig'.  See above for an example. ewmh :: XConfig a -> XConfig a-ewmh c = c { startupHook     = startupHook c +++ ewmhDesktopsStartup-           , handleEventHook = handleEventHook c +++ ewmhDesktopsEventHook-           , logHook         = logHook c +++ ewmhDesktopsLogHook }- where x +++ y = mappend x y+ewmh c = c { startupHook     = ewmhDesktopsStartup <> startupHook c+           , handleEventHook = ewmhDesktopsEventHook <> handleEventHook c+           , logHook         = ewmhDesktopsLogHook <> logHook c+           , manageHook      = ewmhDesktopsManageHook' <> manageHook c } --- |--- Initializes EwmhDesktops and advertises EWMH support to the X--- server-ewmhDesktopsStartup :: X ()-ewmhDesktopsStartup = setSupported --- |--- Notifies pagers and window lists, such as those in the gnome-panel--- of the current state of workspaces and windows.-ewmhDesktopsLogHook :: X ()-ewmhDesktopsLogHook = ewmhDesktopsLogHookCustom id--- |--- Generalized version of ewmhDesktopsLogHook that allows an arbitrary--- user-specified function to transform the workspace list (post-sorting)-ewmhDesktopsLogHookCustom :: ([WindowSpace] -> [WindowSpace]) -> X ()-ewmhDesktopsLogHookCustom f = withWindowSet $ \s -> do-    sort' <- getSortByIndex-    let ws = f $ sort' $ W.workspaces s+-- $customization+-- It's possible to customize the behaviour of 'ewmh' in several ways: -    -- Number of Workspaces-    setNumberOfDesktops (length ws)+-- | Customizable configuration for EwmhDesktops+data EwmhDesktopsConfig =+    EwmhDesktopsConfig+        { workspaceSort :: X WorkspaceSort+            -- ^ configurable workspace sorting/filtering+        , workspaceRename :: X (String -> WindowSpace -> String)+            -- ^ configurable workspace rename (see 'XMonad.Hooks.StatusBar.PP.ppRename')+        , activateHook :: ManageHook+            -- ^ configurable handling of window activation requests+        , fullscreenHooks :: (ManageHook, ManageHook)+            -- ^ configurable handling of fullscreen state requests+        , switchDesktopHook :: WorkspaceId -> WindowSet -> WindowSet+            -- ^ configurable action for handling _NET_CURRENT_DESKTOP+        , manageDesktopViewport :: Bool+            -- ^ manage @_NET_DESKTOP_VIEWPORT@?+        , hiddenWorkspaceToScreen :: WindowSet -> WindowSpace -> WindowScreen+            -- ^ map hidden workspaces to screens for @_NET_DESKTOP_VIEWPORT@+        , handleAboveBelowState :: Bool+            -- ^ handle @_NET_WM_STATE_ABOVE@ and @_NET_WM_STATE_BELOW@?+        } -    -- Names thereof-    setDesktopNames (map W.tag ws)+instance Default EwmhDesktopsConfig where+    def = EwmhDesktopsConfig+        { workspaceSort = getSortByIndex+        , workspaceRename = pure pure+        , activateHook = doFocus+        , fullscreenHooks = (doFullFloat, doSink)+        , switchDesktopHook = W.view+        , manageDesktopViewport = True+        -- Hidden workspaces are mapped to the current screen by default.+        , hiddenWorkspaceToScreen = \winset _ -> W.current winset+        , handleAboveBelowState = False+        } -    -- 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 -    -- Current desktop-    case (elemIndex (W.currentTag s) $ map W.tag ws) of-      Nothing -> return ()-      Just curr -> do-        setCurrentDesktop curr+-- $customSort+-- The list of workspaces exposed to EWMH pagers (like+-- <https://github.com/taffybar/taffybar taffybar> and+-- <https://github.com/polybar/polybar polybar>) and clients (such as+-- <http://tomas.styblo.name/wmctrl/ wmctrl> and+-- <https://github.com/jordansissel/xdotool/ xdotool>) may be sorted and/or+-- filtered via a user-defined function.+--+-- To show visible workspaces first, one may switch to a Xinerama-aware+-- sorting function:+--+-- > import XMonad.Util.WorkspaceCompare+-- >+-- > mySort = getSortByXineramaRule+-- > main = xmonad $ … . setEwmhWorkspaceSort mySort . ewmh . … $ def{…}+--+-- Another useful example is not exposing the hidden scratchpad workspace:+--+-- > import XMonad.Util.NamedScratchpad+-- > import XMonad.Util.WorkspaceCompare+-- >+-- > myFilter = filterOutWs [scratchpadWorkspaceTag]+-- > main = xmonad $ … . addEwmhWorkspaceSort (pure myFilter) . ewmh . … $ def{…} -        -- 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+-- | Add (compose after) an arbitrary user-specified function to sort/filter+-- the workspace list. The default/initial function is 'getSortByIndex'. This+-- can be used to e.g. filter out scratchpad workspaces. Workspaces /must not/+-- be renamed here.+addEwmhWorkspaceSort :: X WorkspaceSort -> XConfig l -> XConfig l+addEwmhWorkspaceSort f = XC.modifyDef $ \c -> c{ workspaceSort = liftA2 (.) f (workspaceSort c) } -    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+-- | Like 'addEwmhWorkspaceSort', but replace it instead of adding/composing.+setEwmhWorkspaceSort :: X WorkspaceSort -> XConfig l -> XConfig l+setEwmhWorkspaceSort f = XC.modifyDef $ \c -> c{ workspaceSort = f } -    setActiveWindow -    return ()+-- $customRename+-- The workspace names exposed to EWMH pagers and other clients (e.g.+-- <https://arbtt.nomeata.de/ arbtt>) may be altered using a similar+-- interface to 'XMonad.Hooks.StatusBar.PP.ppRename'. To configure workspace+-- renaming, use 'addEwmhWorkspaceRename'.+--+-- As an example, to expose workspaces uppercased:+--+-- > import Data.Char+-- >+-- > myRename :: String -> WindowSpace -> String+-- > myRename s _w = map toUpper s+-- >+-- > main = xmonad $ … . addEwmhWorkspaceRename (pure myRename) . ewmh . … $ def{…}+--+-- Some modules like "XMonad.Actions.WorkspaceNames" provide ready-made+-- integrations:+--+-- > import XMonad.Actions.WorkspaceNames+-- >+-- > main = xmonad $ … . workspaceNamesEwmh . ewmh . … $ def{…}+--+-- The above ensures workspace names are exposed through EWMH. --- |--- Intercepts messages from pagers and similar applications and reacts on them.+-- | Add (compose after) an arbitrary user-specified function to rename each+-- workspace. This works just like 'XMonad.Hooks.StatusBar.PP.ppRename': the+-- @WindowSpace -> …@ acts as a Reader monad. Useful with+-- "XMonad.Actions.WorkspaceNames", "XMonad.Layout.IndependentScreens",+-- "XMonad.Hooks.DynamicIcons".+addEwmhWorkspaceRename :: X (String -> WindowSpace -> String) -> XConfig l -> XConfig l+addEwmhWorkspaceRename f = XC.modifyDef $ \c -> c{ workspaceRename = liftA2 (<=<) f (workspaceRename c) }++-- | Like 'addEwmhWorkspaceRename', but replace it instead of adding/composing.+setEwmhWorkspaceRename :: X (String -> WindowSpace -> String) -> XConfig l -> XConfig l+setEwmhWorkspaceRename f = XC.modifyDef $ \c -> c{ workspaceRename = f }+++-- $customActivate+-- When a client sends a @_NET_ACTIVE_WINDOW@ request to activate a window, by+-- default that window is activated by invoking the 'doFocus' 'ManageHook'.+-- <https://specifications.freedesktop.org/wm-spec/1.5/ar01s03.html#idm45623294083744 The EWMH specification suggests>+-- that a window manager may instead just mark the window as urgent, and this+-- can be achieved using the following:+--+-- > import XMonad.Hooks.UrgencyHook+-- >+-- > main = xmonad $ … . setEwmhActivateHook doAskUrgent . ewmh . … $ def{…}+--+-- One may also wish to ignore activation requests from certain applications+-- entirely:+--+-- > import XMonad.Hooks.ManageHelpers+-- >+-- > myActivateHook :: ManageHook+-- > myActivateHook =+-- >   className /=? "Google-chrome" <&&> className /=? "google-chrome" --> doFocus+-- >+-- > main = xmonad $ … . setEwmhActivateHook myActivateHook . ewmh . … $ def{…}+--+-- Arbitrarily complex hooks can be used. This last example marks Chrome+-- windows as urgent and focuses everything else:+--+-- > myActivateHook :: ManageHook+-- > myActivateHook = composeOne+-- >   [ className =? "Google-chrome" <||> className =? "google-chrome" -?> doAskUrgent+-- >   , pure True -?> doFocus ]+--+-- See "XMonad.ManageHook", "XMonad.Hooks.ManageHelpers", "XMonad.Hooks.Focus" and+-- "XMonad.Layout.IndependentScreens" for functions that can be useful here.++-- | Set (replace) the hook which is invoked when a client sends a+-- @_NET_ACTIVE_WINDOW@ request to activate a window. The default is 'doFocus'+-- which focuses the window immediately, switching workspace if necessary.+-- 'XMonad.Hooks.UrgencyHook.doAskUrgent' is a less intrusive alternative.+--+-- More complex hooks can be constructed using combinators from+-- "XMonad.ManageHook", "XMonad.Hooks.ManageHelpers" and "XMonad.Hooks.Focus".+setEwmhActivateHook :: ManageHook -> XConfig l -> XConfig l+setEwmhActivateHook h = XC.modifyDef $ \c -> c{ activateHook = h }+++-- $customWorkspaceSwitch+-- When a client sends a @_NET_CURRENT_DESKTOP@ request to switch to a workspace,+-- the default action used to do that is the 'W.view' function.+-- This may not be the desired behaviour in all configurations.+--+-- For example if using the "XMonad.Layout.IndependentScreens" the default action+-- might move a workspace to a screen that it isn't supposed to be on.+-- This behaviour can be fixed using the following:+--+-- > import XMonad.Actions.OnScreen+-- > import XMonad.Layout.IndependentScreens+-- >+-- > main = xmonad $ ... . setEwmhSwitchDesktopHook focusWorkspace . ewmh . ... $+-- >  def{+-- >    ...+-- >      workspaces = withScreens 2 (workspaces def)+-- >    ...+-- >  }++-- | Set (replace) the action which is invoked when a client sends a+-- @_NET_CURRENT_DESKTOP@ request to switch workspace.+setEwmhSwitchDesktopHook :: (WorkspaceId -> WindowSet -> WindowSet) -> XConfig l -> XConfig l+setEwmhSwitchDesktopHook action = XC.modifyDef $ \c -> c{ switchDesktopHook = action }+++-- $customFullscreen+-- When a client sends a @_NET_WM_STATE@ request to add\/remove\/toggle the+-- @_NET_WM_STATE_FULLSCREEN@ state, 'ewmhFullscreen' uses a pair of hooks to+-- make the window fullscreen and revert its state. The default hooks are+-- stateless: windows are fullscreened by turning them into fullscreen floats,+-- and reverted by sinking them into the tiling layer. This behaviour can be+-- configured by supplying a pair of 'ManageHook's to 'setEwmhFullscreenHooks'.+--+-- See "XMonad.Actions.ToggleFullFloat" for a pair of hooks that store the+-- original state of floating windows.++-- | Set (replace) the hooks invoked when clients ask to add/remove the+-- $_NET_WM_STATE_FULLSCREEN@ state. The defaults are 'doFullFloat' and+-- 'doSink'.+setEwmhFullscreenHooks :: ManageHook -> ManageHook -> XConfig l -> XConfig l+setEwmhFullscreenHooks f uf = XC.modifyDef $ \c -> c{ fullscreenHooks = (f, uf) }+++-- $customManageDesktopViewport+-- Setting @_NET_DESKTOP_VIEWPORT@ is typically desired but can lead to a+-- confusing workspace list in polybar, where this information is used to+-- re-group the workspaces by monitor. See+-- <https://github.com/polybar/polybar/issues/2603 polybar#2603>.+--+-- To avoid this, you can use:+--+-- > main = xmonad $ … . disableEwmhManageDesktopViewport . ewmh . … $ def{…}+--+-- Note that if you apply this configuration in an already running environment,+-- the property may remain at its previous value. It can be removed by running:+--+-- > xprop -root -remove _NET_DESKTOP_VIEWPORT+--+-- Which should immediately fix your bar.+--+disableEwmhManageDesktopViewport :: XConfig l -> XConfig l+disableEwmhManageDesktopViewport = XC.modifyDef $ \c -> c{ manageDesktopViewport = False }++-- $customManageAboveBelowState+-- Some applications use the @_NET_WM_STATE_ABOVE@ and @_NET_WM_STATE_BELOW@+-- states to request being kept above or below other windows. By default, xmonad+-- does not handle these states. To enable handling of these states, you can use+-- the following hook:+--+-- > main = xmonad $ … . enableEwmhManageAboveBelowState . ewmh . … $ def{…}+--+-- This will make xmonad respond to requests to set these states by calling+-- lowerWindow and raiseWindow respectively.+enableEwmhManageAboveBelowState :: XConfig l -> XConfig l+enableEwmhManageAboveBelowState = XC.modifyDef (\c -> c{handleAboveBelowState = True})++aboveBelowManageHook :: ManageHook+aboveBelowManageHook =+    ((isEnabled <&&> isInProperty "_NET_WM_STATE" "_NET_WM_STATE_BELOW") --> doLower)+        <> ((isEnabled <&&> isInProperty "_NET_WM_STATE" "_NET_WM_STATE_ABOVE") --> doRaise)+  where+    isEnabled = liftX (XC.withDef (pure . handleAboveBelowState))++aboveBelowEventHook :: Event -> X ()+aboveBelowEventHook+    ClientMessageEvent{ev_event_display = dpy, ev_window = w, ev_message_type = typ, ev_data = action : dats} =+        do+            wmstate <- getAtom "_NET_WM_STATE"+            above <- getAtom "_NET_WM_STATE_ABOVE"+            below <- getAtom "_NET_WM_STATE_BELOW"++            wstate <- fromMaybe [] <$> getProp32 wmstate w++            let isAbove = fi above `elem` wstate+                isBelow = fi below `elem` wstate+                chWstate f = io $ changeProperty32 dpy w wmstate aTOM propModeReplace (f wstate)+                raise = chWstate (filter (/= fi below) . (fi above :)) >> io (raiseWindow dpy w)+                lower = chWstate (filter (/= fi above) . (fi below :)) >> io (lowerWindow dpy w)+                clear st = chWstate (filter (/= fi st))+            when (typ == wmstate) $+                if+                        -- remove+                        | action == 0 -> do+                            when (fi above `elem` dats && isAbove) $ clear above+                            when (fi below `elem` dats && isBelow) $ clear below+                        -- add+                        | action == 1 -> do+                            when (fi above `elem` dats && not isAbove) raise+                            when (fi below `elem` dats && not isBelow) lower+                        -- toggle+                        | action == 2 -> do+                            when (fi above `elem` dats) $+                                if isAbove+                                    then clear above+                                    else raise+                            when (fi below `elem` dats) $+                                if isBelow+                                    then clear below+                                    else lower+                        | otherwise -> trace ("Bad _NET_WM_STATE with data =" <> show action)+            mempty+aboveBelowEventHook _ = mempty++-- $customHiddenWorkspaceMapper+--+-- Mapping the hidden workspaces to the current screen is a good default behavior,+-- but it makes the assumption that workspaces don't belong to a sepcific screen.+-- If the default behaviour is undesired, for example when using "XMonad.Layout.IndependentScreens",+-- it can be customized.+--+-- The following example demonstrates a way to configure the mapping when using "XMonad.Layout.IndependentScreens":+--+-- > import XMonad.Layout.IndependentScreens+-- >+-- > customMapper :: WindowSet -> (WindowSpace -> WindowScreen)+-- > customMapper winset (Workspace wsid _ _) = fromMaybe (W.current winset) maybeMappedScreen+-- >  where+-- >    screenId = unmarshallS wsid+-- >    maybeMappedScreen = screenOnMonitor screenId winset+-- >+-- >+-- > main = xmonad $ ... . setEwmhHiddenWorkspaceToScreenMapping customMapper . ewmh . ... $ def{...}++-- | Set (replace) the function responsible for mapping the hidden workspaces to screens.+setEwmhHiddenWorkspaceToScreenMapping :: (WindowSet -> (WindowSpace -> WindowScreen))+                                        -- ^ Function that given the current WindowSet+                                        -- produces a function to maps a (hidden) workspace to a screen.+                                        -> XConfig l -> XConfig l+setEwmhHiddenWorkspaceToScreenMapping mapper = XC.modifyDef $ \c -> c{ hiddenWorkspaceToScreen = mapper }+++-- | Initializes EwmhDesktops and advertises EWMH support to the X server.+{-# DEPRECATED ewmhDesktopsStartup "Use ewmh instead." #-}+ewmhDesktopsStartup :: X ()+ewmhDesktopsStartup = setSupported >> XC.withDef ewmhDesktopsStartupHook'++-- | Notifies pagers and window lists, such as those in the gnome-panel of the+-- current state of workspaces and windows.+{-# DEPRECATED ewmhDesktopsLogHook "Use ewmh instead." #-}+ewmhDesktopsLogHook :: X ()+ewmhDesktopsLogHook = XC.withDef ewmhDesktopsLogHook'++-- | Generalized version of ewmhDesktopsLogHook that allows an arbitrary+-- user-specified function to sort/filter the workspace list (post-sorting).+{-# DEPRECATED ewmhDesktopsLogHookCustom "Use ewmh and addEwmhWorkspaceSort instead." #-}+ewmhDesktopsLogHookCustom :: WorkspaceSort -> X ()+ewmhDesktopsLogHookCustom f =+    ewmhDesktopsLogHook' def{ workspaceSort = (f .) <$> workspaceSort def }++-- | Manage hook that EWMH extensions can hook into. Should be named+-- ewmhDesktopsManageHook for consistency with ewmhDesktopsLogHook for example,+-- but that name is taken.+ewmhDesktopsManageHook' :: ManageHook+ewmhDesktopsManageHook' = aboveBelowManageHook++-- | Intercepts messages from pagers and similar applications and reacts on them.+-- -- Currently supports: -- --  * _NET_CURRENT_DESKTOP (switching desktops)@@ -118,62 +450,243 @@ --  * _NET_WM_DESKTOP (move windows to other desktops) -- --  * _NET_ACTIVE_WINDOW (activate another window, changing workspace if needed)+--+--  * _NET_CLOSE_WINDOW (close window)+{-# DEPRECATED ewmhDesktopsEventHook "Use ewmh instead." #-} ewmhDesktopsEventHook :: Event -> X All-ewmhDesktopsEventHook = ewmhDesktopsEventHookCustom id+ewmhDesktopsEventHook = XC.withDef . ewmhDesktopsEventHook' --- |--- Generalized version of ewmhDesktopsEventHook that allows an arbitrary--- user-specified function to transform the workspace list (post-sorting)-ewmhDesktopsEventHookCustom :: ([WindowSpace] -> [WindowSpace]) -> Event -> X All-ewmhDesktopsEventHookCustom f e = handle f e >> return (All True)+-- | Generalized version of ewmhDesktopsEventHook that allows an arbitrary+-- user-specified function to sort/filter the workspace list (post-sorting).+{-# DEPRECATED ewmhDesktopsEventHookCustom "Use ewmh and addEwmhWorkspaceSort instead." #-}+ewmhDesktopsEventHookCustom :: WorkspaceSort -> Event -> X All+ewmhDesktopsEventHookCustom f e =+    ewmhDesktopsEventHook' e def{ workspaceSort = (f .) <$> workspaceSort def } -handle :: ([WindowSpace] -> [WindowSpace]) -> Event -> X ()-handle f (ClientMessageEvent {-               ev_window = w,-               ev_message_type = mt,-               ev_data = d-       }) = withWindowSet $ \s -> do-       sort' <- getSortByIndex-       let ws = f $ sort' $ W.workspaces s+-- | Cached @_NET_DESKTOP_NAMES@, @_NET_NUMBER_OF_DESKTOPS@+newtype DesktopNames = DesktopNames [String] deriving Eq+instance ExtensionClass DesktopNames where initialValue = DesktopNames [] -       a_cd <- getAtom "_NET_CURRENT_DESKTOP"-       a_d <- getAtom "_NET_WM_DESKTOP"-       a_aw <- getAtom "_NET_ACTIVE_WINDOW"-       a_cw <- getAtom "_NET_CLOSE_WINDOW"-       a_ignore <- mapM getAtom ["XMONAD_TIMER"]-       if  mt == a_cd then do-               let n = head d-               if 0 <= n && fi n < length ws then-                       windows $ W.view (W.tag (ws !! fi n))-                 else  trace $ "Bad _NET_CURRENT_DESKTOP with data[0]="++show n-        else if mt == a_d then do-               let n = head d-               if 0 <= n && fi n < length ws then-                       windows $ W.shiftWin (W.tag (ws !! fi n)) w-                 else  trace $ "Bad _NET_DESKTOP with data[0]="++show n-        else if mt == a_aw then do-               windows $ W.focusWindow w-        else if mt == a_cw then do-               killWindow w-        else if mt `elem` a_ignore then do-           return ()-        else do-          -- The Message is unknown to us, but that is ok, not all are meant-          -- to be handled by the window manager-          return ()-handle _ _ = return ()+-- | Cached @_NET_CLIENT_LIST@+newtype ClientList = ClientList [Window] deriving Eq+instance ExtensionClass ClientList where initialValue = ClientList [none] --- |--- An event hook to handle applications that wish to fullscreen using the--- _NET_WM_STATE protocol. This includes users of the gtk_window_fullscreen()+-- | Cached @_NET_CLIENT_LIST_STACKING@+newtype ClientListStacking = ClientListStacking [Window] deriving Eq+instance ExtensionClass ClientListStacking where initialValue = ClientListStacking [none]++-- | Cached @_NET_CURRENT_DESKTOP@+newtype CurrentDesktop = CurrentDesktop Int deriving Eq+instance ExtensionClass CurrentDesktop where initialValue = CurrentDesktop (complement 0)++-- | Cached @_NET_WM_DESKTOP@+newtype WindowDesktops = WindowDesktops (M.Map Window Int) deriving Eq+instance ExtensionClass WindowDesktops where initialValue = WindowDesktops (M.singleton none (complement 0))++-- | Cached @_NET_ACTIVE_WINDOW@+newtype ActiveWindow = ActiveWindow Window deriving Eq+instance ExtensionClass ActiveWindow where initialValue = ActiveWindow (complement none)++-- | Cached @_NET_DESKTOP_VIEWPORT@+newtype MonitorTags = MonitorTags [WorkspaceId] deriving (Show,Eq)+instance ExtensionClass MonitorTags where initialValue = MonitorTags []++-- | 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 = whenX . XS.modified . const++ewmhDesktopsStartupHook' :: EwmhDesktopsConfig -> X ()+ewmhDesktopsStartupHook' EwmhDesktopsConfig{handleAboveBelowState} =+    when+        handleAboveBelowState+        (addSupported ["_NET_WM_STATE", "_NET_WM_STATE_ABOVE", "_NET_WM_STATE_BELOW"])++ewmhDesktopsLogHook' :: EwmhDesktopsConfig -> X ()+ewmhDesktopsLogHook' EwmhDesktopsConfig{workspaceSort, workspaceRename, manageDesktopViewport, hiddenWorkspaceToScreen} = withWindowSet $ \s -> do+    sort' <- workspaceSort+    let ws = sort' $ W.workspaces s++    -- Set number of workspaces and names thereof+    rename <- workspaceRename+    let desktopNames = [ rename (W.tag w) w | w <- ws ]+    whenChanged (DesktopNames desktopNames) $ do+        setNumberOfDesktops (length desktopNames)+        setDesktopNames desktopNames++    -- Set client list which should be sorted by window age. We just+    -- guess that StackSet contains windows list in this order which+    -- isn't true but at least gives consistency with windows cycling+    let clientList = nub . concatMap (W.integrate' . W.stack) $ ws+    whenChanged (ClientList clientList) $ setClientList clientList++    -- @ws@ is sorted in the "workspace order", which, by default, is+    -- the lexicographical sorting on @WorkspaceId@.+    -- @_NET_CLIENT_LIST_STACKING@ is expected to be in the "bottom-to-top+    -- stacking order".  It is unclear what that would mean for windows on+    -- invisible workspaces, but it seems reasonable to assume that windows on+    -- the current workspace should be "at the top".  With the focused window to+    -- be the top most, meaning the last.+    --+    -- There has been a number of discussions on the order of windows within a+    -- workspace.  See:+    --+    --   https://github.com/xmonad/xmonad-contrib/issues/567+    --   https://github.com/xmonad/xmonad-contrib/pull/568+    --   https://github.com/xmonad/xmonad-contrib/pull/772+    let clientListStacking =+          let wsInFocusOrder = W.hidden s+                               ++ (map W.workspace . W.visible) s+                               ++ [W.workspace $ W.current s]+              stackWindows (W.Stack cur up down) = reverse up ++ down ++ [cur]+              workspaceWindows = maybe [] stackWindows . W.stack+              -- In case a window is a member of multiple workspaces, we keep+              -- only the last occurrence in the list.  One that is closer to+              -- the top in the focus order.+              uniqueKeepLast = reverse . nub . reverse+           in uniqueKeepLast $ concatMap workspaceWindows wsInFocusOrder+    whenChanged (ClientListStacking clientListStacking) $+      setClientListStacking clientListStacking++    -- Set current desktop number+    let current = W.currentTag s `elemIndex` map W.tag ws+    whenChanged (CurrentDesktop $ fromMaybe 0 current) $+        mapM_ setCurrentDesktop current++    -- 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) $+        mapM_ (uncurry setWindowDesktop) (M.toList windowDesktops)++    -- Set active window+    let activeWindow' = fromMaybe none (W.peek s)+    whenChanged (ActiveWindow activeWindow') $ setActiveWindow activeWindow'++    -- Set desktop Viewport+    when manageDesktopViewport $ do+        let visibleScreens = W.current s : W.visible s+            currentTags    = map (W.tag . W.workspace) visibleScreens+        whenChanged (MonitorTags currentTags) $ mkViewPorts s hiddenWorkspaceToScreen (map W.tag ws)++-- | Create the viewports from the current 'WindowSet' and a list of+-- already sorted workspace IDs.+mkViewPorts :: WindowSet -> (WindowSet -> WindowSpace -> WindowScreen) -> [WorkspaceId] -> X ()+mkViewPorts winset hiddenWorkspaceMapper = setDesktopViewport . concat . mapMaybe (viewPorts M.!?)+  where+    foc = W.current winset+    viewPorts :: M.Map WorkspaceId [Position]+    viewPorts = M.fromList $ map mkVisibleViewPort (foc : W.visible winset)+                          ++ map (uncurry mkViewPort) hiddenWorkspacesWithScreens++    hiddenWorkspacesWithScreens :: [(WindowScreen,WindowSpace)]+    hiddenWorkspacesWithScreens = map (\x -> (hiddenWorkspaceMapper winset x, x)) (W.hidden winset)++    mkViewPort :: WindowScreen -> WindowSpace -> (WorkspaceId, [Position])+    mkViewPort scr w = (W.tag w, mkPos scr)++    mkVisibleViewPort :: WindowScreen -> (WorkspaceId, [Position])+    mkVisibleViewPort x = mkViewPort x (W.workspace x)++    mkPos :: WindowScreen -> [Position]+    mkPos scr = [rect_x (rect scr), rect_y (rect scr)]+      where rect = screenRect . W.screenDetail++ewmhDesktopsEventHook' :: Event -> EwmhDesktopsConfig -> X All+ewmhDesktopsEventHook'+        e@ClientMessageEvent{ev_window = w, ev_message_type = mt, ev_data = d}+        EwmhDesktopsConfig{workspaceSort, activateHook, switchDesktopHook, handleAboveBelowState} =+    withWindowSet $ \s -> do+        sort' <- workspaceSort+        let ws = sort' $ W.workspaces s++        a_cd <- getAtom "_NET_CURRENT_DESKTOP"+        a_d <- getAtom "_NET_WM_DESKTOP"+        a_aw <- getAtom "_NET_ACTIVE_WINDOW"+        a_cw <- getAtom "_NET_CLOSE_WINDOW"++        if  | mt == a_cw ->+                killWindow w+            | mt == a_cd, n : _ <- d, Just ww <- ws !? fi n ->+                if W.currentTag s == W.tag ww then mempty else windows $ switchDesktopHook (W.tag ww)+            | mt == a_cd ->+                trace $ "Bad _NET_CURRENT_DESKTOP with data=" ++ show d+            | not (w `W.member` s) ->+                -- do nothing for unmanaged windows; it'd be just a useless+                -- refresh which breaks menus/popups of misbehaving apps that+                -- send _NET_ACTIVE_WINDOW requests for override-redirect wins+                mempty+            | mt == a_d, n : _ <- d, Just ww <- ws !? fi n ->+                if W.findTag w s == Just (W.tag ww) then mempty else windows $ W.shiftWin (W.tag ww) w+            | mt == a_d ->+                trace $ "Bad _NET_WM_DESKTOP with data=" ++ show d+            | mt == a_aw, 2 : _ <- d ->+                -- when the request comes from a pager, honor it unconditionally+                -- https://specifications.freedesktop.org/wm-spec/wm-spec-1.3.html#sourceindication+                if W.peek s == Just w then mempty else windows $ W.focusWindow w+            | mt == a_aw -> do+                if W.peek s == Just w then mempty else windows . appEndo =<< runQuery activateHook w+            | otherwise ->+                -- The Message is unknown to us, but that is ok, not all are meant+                -- to be handled by the window manager+                mempty+        when handleAboveBelowState (aboveBelowEventHook e)+        mempty+ewmhDesktopsEventHook' _ _ = mempty++-- | A 'ManageHook' that shifts windows to the workspace they want to be in.+-- Useful for restoring browser windows to where they were before restart.+--+-- To only use this for browsers (which might be a good idea, as many apps try+-- to restore their window to their original position, but it's rarely+-- desirable outside of security updates of multi-window apps like a browser),+-- use this:+--+-- > stringProperty "WM_WINDOW_ROLE" =? "browser" --> ewmhDesktopsManageHook+ewmhDesktopsManageHook :: ManageHook+ewmhDesktopsManageHook = maybeToDefinite ewmhDesktopsMaybeManageHook++-- | 'ewmhDesktopsManageHook' as a 'MaybeManageHook' for use with+-- 'composeOne'. Returns 'Nothing' if the window didn't indicate any desktop+-- preference, otherwise 'Just' (even if the preferred desktop was out of+-- bounds).+ewmhDesktopsMaybeManageHook :: MaybeManageHook+ewmhDesktopsMaybeManageHook = desktop >>= traverse doShiftI+  where+    doShiftI :: Int -> ManageHook+    doShiftI d = do+        sort' <- liftX . XC.withDef $ \EwmhDesktopsConfig{workspaceSort} -> workspaceSort+        ws <- liftX . gets $ map W.tag . sort' . W.workspaces . windowset+        maybe idHook doShift $ ws !? d++-- | Add EWMH fullscreen functionality to the given config.+ewmhFullscreen :: XConfig a -> XConfig a+ewmhFullscreen c = c { startupHook     = startupHook c <> fullscreenStartup+                     , handleEventHook = handleEventHook c <> fullscreenEventHook }++-- | Advertises EWMH fullscreen support to the X server.+{-# DEPRECATED fullscreenStartup "Use ewmhFullscreen instead." #-}+fullscreenStartup :: X ()+fullscreenStartup = setFullscreenSupported++-- | An event hook to handle applications that wish to fullscreen using the+-- @_NET_WM_STATE@ protocol. This includes users of the @gtk_window_fullscreen()@ -- function, such as Totem, Evince and OpenOffice.org. -- -- Note this is not included in 'ewmh'.+{-# DEPRECATED fullscreenEventHook "Use ewmhFullscreen instead." #-} fullscreenEventHook :: Event -> X All-fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do+fullscreenEventHook = XC.withDef . fullscreenEventHook'++fullscreenEventHook' :: Event -> EwmhDesktopsConfig -> X All+fullscreenEventHook'+    ClientMessageEvent{ev_event_display = dpy, ev_window = win, ev_message_type = typ, ev_data = action:dats}+    EwmhDesktopsConfig{fullscreenHooks = (fullscreenHook, unFullscreenHook)} = do+  managed <- isClient win   wmstate <- getAtom "_NET_WM_STATE"   fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN"-  wstate <- fromMaybe [] `fmap` getProp32 wmstate win+  wstate <- fromMaybe [] <$> getProp32 wmstate win    let isFull = fromIntegral fullsc `elem` wstate @@ -181,34 +694,31 @@       remove = 0       add = 1       toggle = 2-      ptype = 4 -- The atom property type for changeProperty-      chWstate f = io $ changeProperty32 dpy win wmstate ptype propModeReplace (f wstate)+      chWstate f = io $ changeProperty32 dpy win wmstate aTOM propModeReplace (f wstate) -  when (typ == wmstate && fi fullsc `elem` dats) $ do-    when (action == add || (action == toggle && not isFull)) $ do+  when (managed && typ == wmstate && fi fullsc `elem` dats) $ do+    when (not isFull && (action == add || action == toggle)) $ do       chWstate (fi fullsc:)-      windows $ W.float win $ W.RationalRect 0 0 1 1-    when (action == remove || (action == toggle && isFull)) $ do+      windows . appEndo =<< runQuery fullscreenHook win+    when (isFull && (action == remove || action == toggle)) $ do       chWstate $ delete (fi fullsc)-      windows $ W.sink win+      windows . appEndo =<< runQuery unFullscreenHook win    return $ All True -fullscreenEventHook _ = return $ All True+fullscreenEventHook' _ _ = return $ All True  setNumberOfDesktops :: (Integral a) => a -> X () setNumberOfDesktops n = withDisplay $ \dpy -> do     a <- getAtom "_NET_NUMBER_OF_DESKTOPS"-    c <- getAtom "CARDINAL"     r <- asks theRoot-    io $ changeProperty32 dpy r a c propModeReplace [fromIntegral n]+    io $ changeProperty32 dpy r a cARDINAL propModeReplace [fromIntegral n]  setCurrentDesktop :: (Integral a) => a -> X () setCurrentDesktop i = withDisplay $ \dpy -> do     a <- getAtom "_NET_CURRENT_DESKTOP"-    c <- getAtom "CARDINAL"     r <- asks theRoot-    io $ changeProperty32 dpy r a c propModeReplace [fromIntegral i]+    io $ changeProperty32 dpy r a cARDINAL propModeReplace [fromIntegral i]  setDesktopNames :: [String] -> X () setDesktopNames names = withDisplay $ \dpy -> do@@ -221,26 +731,39 @@  setClientList :: [Window] -> X () setClientList wins = withDisplay $ \dpy -> do-    -- (What order do we really need? Something about age and stacking)     r <- asks theRoot-    c <- getAtom "WINDOW"     a <- getAtom "_NET_CLIENT_LIST"-    io $ changeProperty32 dpy r a c propModeReplace (fmap fromIntegral wins)-    a' <- getAtom "_NET_CLIENT_LIST_STACKING"-    io $ changeProperty32 dpy r a' c propModeReplace (fmap fromIntegral wins)+    io $ changeProperty32 dpy r a wINDOW propModeReplace (fmap fromIntegral wins) +setClientListStacking :: [Window] -> X ()+setClientListStacking wins = withDisplay $ \dpy -> do+    r <- asks theRoot+    a <- getAtom "_NET_CLIENT_LIST_STACKING"+    io $ changeProperty32 dpy r a wINDOW propModeReplace (fmap fromIntegral wins)+ setWindowDesktop :: (Integral a) => Window -> a -> X () setWindowDesktop win i = withDisplay $ \dpy -> do     a <- getAtom "_NET_WM_DESKTOP"-    c <- getAtom "CARDINAL"-    io $ changeProperty32 dpy win a c propModeReplace [fromIntegral i]+    io $ changeProperty32 dpy win a cARDINAL propModeReplace [fromIntegral i] +setActiveWindow :: Window -> X ()+setActiveWindow w = withDisplay $ \dpy -> do+    r <- asks theRoot+    a <- getAtom "_NET_ACTIVE_WINDOW"+    io $ changeProperty32 dpy r a wINDOW propModeReplace [fromIntegral w]++setDesktopViewport :: [Position] -> X ()+setDesktopViewport positions = withDisplay $ \dpy -> do+    r <- asks theRoot+    a <- io $ internAtom dpy "_NET_DESKTOP_VIEWPORT" True+    io $ changeProperty32 dpy r a cARDINAL propModeReplace (map fi positions)+ setSupported :: X () setSupported = withDisplay $ \dpy -> do     r <- asks theRoot     a <- getAtom "_NET_SUPPORTED"-    c <- getAtom "ATOM"     supp <- mapM getAtom ["_NET_WM_STATE_HIDDEN"+                         ,"_NET_WM_STATE_DEMANDS_ATTENTION"                          ,"_NET_NUMBER_OF_DESKTOPS"                          ,"_NET_CLIENT_LIST"                          ,"_NET_CLIENT_LIST_STACKING"@@ -249,15 +772,22 @@                          ,"_NET_ACTIVE_WINDOW"                          ,"_NET_WM_DESKTOP"                          ,"_NET_WM_STRUT"+                         ,"_NET_WM_STRUT_PARTIAL"+                         ,"_NET_DESKTOP_VIEWPORT"                          ]-    io $ changeProperty32 dpy r a c propModeReplace (fmap fromIntegral supp)+    io $ changeProperty32 dpy r a aTOM propModeReplace (fmap fromIntegral supp)      setWMName "xmonad" -setActiveWindow :: X ()-setActiveWindow = withWindowSet $ \s -> withDisplay $ \dpy -> do-    let w = fromMaybe none (W.peek s)+-- TODO: use in SetWMName, UrgencyHook+addSupported :: [String] -> X ()+addSupported props = withDisplay $ \dpy -> do     r <- asks theRoot-    a <- getAtom "_NET_ACTIVE_WINDOW"-    c <- getAtom "WINDOW"-    io $ changeProperty32 dpy r a c propModeReplace [fromIntegral w]+    a <- getAtom "_NET_SUPPORTED"+    newSupportedList <- mapM (fmap fromIntegral . getAtom) props+    io $ do+        supportedList <- join . maybeToList <$> getWindowProperty32 dpy a r+        changeProperty32 dpy r a aTOM propModeReplace (nub $ newSupportedList ++ supportedList)++setFullscreenSupported :: X ()+setFullscreenSupported = addSupported ["_NET_WM_STATE", "_NET_WM_STATE_FULLSCREEN"]
XMonad/Hooks/FadeInactive.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Hooks.FadeInactive+-- Description :  Set the _NET_WM_WINDOW_OPACITY atom for inactive windows. -- Copyright    : (c) 2008 Justin Bogner <mail@justinbogner.com> -- License      : BSD --@@ -27,11 +28,11 @@     ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W-import Control.Monad  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad -- > import XMonad.Hooks.FadeInactive@@ -40,19 +41,18 @@ -- > myLogHook = fadeInactiveLogHook fadeAmount -- >     where fadeAmount = 0.8 -- >--- > main = xmonad defaultConfig { logHook = myLogHook }+-- > main = xmonad def { logHook = myLogHook } -- -- fadeAmount can be any rational between 0 and 1. -- you will need to have xcompmgr <http://freedesktop.org/wiki/Software/xapps> -- or something similar for this to do anything ----- For more detailed instructions on editing the logHook see:------ "XMonad.Doc.Extending#The_log_hook_and_external_status_bars"------ For more detailed instructions on editing the layoutHook see:+-- For more detailed instructions on editing the logHook see+-- <https://xmonad.org/TUTORIAL.html#make-xmonad-and-xmobar-talk-to-each-other the tutorial>. ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | Converts a percentage to the format required for _NET_WM_WINDOW_OPACITY rationalToOpacity :: Integral a => Rational -> a@@ -64,8 +64,7 @@ setOpacity :: Window -> Rational -> X () setOpacity w t = withDisplay $ \dpy -> do     a <- getAtom "_NET_WM_WINDOW_OPACITY"-    c <- getAtom "CARDINAL"-    io $ changeProperty32 dpy w a c propModeReplace [rationalToOpacity t]+    io $ changeProperty32 dpy w a cARDINAL propModeReplace [rationalToOpacity t]  -- | Fades a window out by setting the opacity fadeOut :: Rational -> Window -> X ()@@ -92,7 +91,7 @@  -- | Returns True if the window doesn't have the focus. isUnfocused :: Query Bool-isUnfocused = ask >>= \w -> liftX . gets $ maybe True (w /=) . W.peek . windowset+isUnfocused = ask >>= \w -> liftX . gets $ (Just w /=) . W.peek . windowset  -- | Returns True if the window doesn't have the focus, and the window is on the -- current workspace. This is specifically handy in a multi monitor setup@@ -104,7 +103,7 @@   w <- ask   ws <- liftX $ gets windowset   let thisWS = w `elem` W.index ws-      unfocused = maybe True (w /=) $ W.peek ws+      unfocused = Just w /= W.peek ws   return $ thisWS && unfocused  -- | Fades out every window by the amount returned by the query.@@ -112,4 +111,4 @@ fadeOutLogHook qry = withWindowSet $ \s -> do     let visibleWins = (W.integrate' . W.stack . W.workspace . W.current $ s) ++                       concatMap (W.integrate' . W.stack . W.workspace) (W.visible s)-    forM_ visibleWins $ liftM2 (=<<) setOpacity (runQuery qry)+    forM_ visibleWins $ liftA2 (=<<) setOpacity (runQuery qry)
XMonad/Hooks/FadeWindows.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.FadeWindows+-- Description :  A more flexible and general compositing interface than FadeInactive. -- Copyright   :  Brandon S Allbery KF8NH <allbery.b@gmail.com> -- License     :  BSD --@@ -49,6 +50,7 @@                                 ) where  import           XMonad.Core+import           XMonad.Prelude import           XMonad.ManageHook                       (liftX) import qualified XMonad.StackSet             as W @@ -56,12 +58,10 @@                                                          ,isUnfocused                                                          ) -import           Control.Monad                           (forM_) import           Control.Monad.Reader                    (ask                                                          ,asks) import           Control.Monad.State                     (gets) import qualified Data.Map                    as M-import           Data.Monoid  import           Graphics.X11.Xlib.Extras                (Event(..)) @@ -75,19 +75,28 @@ -- >     , handleEventHook = fadeWindowsEventHook -- >     {- ... -} -- >--- > myFadeHook = composeAll [isUnfocused --> transparency 0.2--- >                         ,                opaque+-- > myFadeHook = composeAll [                 opaque+-- >                         , isUnfocused --> transparency 0.2 -- >                         ] -- -- The above is like FadeInactive with a fade value of 0.2. ----- FadeHooks do not accumulate; instead, they compose from right to--- left like 'ManageHook's, so the above example @myFadeHook@ will--- render unfocused windows at 4/5 opacity and the focused window--- as opaque.  The 'opaque' hook above is optional, by the way, as any--- unmatched window will be opaque by default.+-- 'FadeHook's do not accumulate; instead, they compose from right to+-- left like 'ManageHook's, so in the above example @myFadeHook@ will+-- render unfocused windows at 4/5 opacity and the focused window as+-- opaque.  This means that, in particular, the order in the above+-- example is important. ----- This module is best used with "XMonad.Hooks.MoreManageHelpers", which+-- The 'opaque' hook above is optional, by the way, as any unmatched+-- window will be opaque by default.  If you want to make all windows a+-- bit transparent by default, you can replace 'opaque' with something+-- like+--+-- > transparency 0.93+--+-- at the top of @myFadeHook@.+--+-- This module is best used with "XMonad.Hooks.ManageHelpers", which -- exports a number of Queries that can be used in either @ManageHook@ -- or @FadeHook@. --@@ -96,9 +105,8 @@ -- aren't running a compositing manager, the opacity will be recorded -- but won't take effect until a compositing manager is started. ----- For more detailed instructions on editing the 'logHook' see:------ "XMonad.Doc.Extending#The_log_hook_and_external_status_bars"+-- For more detailed instructions on editing the 'logHook' see+-- <https://xmonad.org/TUTORIAL.html#make-xmonad-and-xmobar-talk-to-each-other the tutorial>. -- -- For more detailed instructions on editing the 'handleEventHook', -- see:@@ -115,7 +123,7 @@ -- a tight loop trying to fade the popup in).  I find it useful to -- have a key binding to restart the compositing manager; for example, ----- main = xmonad $ defaultConfig {+-- main = xmonad $ def { --                   {- ... -} --                 } --                 `additionalKeysP`@@ -129,10 +137,12 @@ -- to make it obay the monoid laws data Opacity = Opacity Rational | OEmpty +instance Semigroup Opacity where+  r <> OEmpty = r+  _ <> r      = r+ instance Monoid Opacity where   mempty                  = OEmpty-  r      `mappend` OEmpty = r-  _      `mappend` r      = r  -- | A FadeHook is similar to a ManageHook, but records window opacity. type FadeHook = Query Opacity@@ -160,17 +170,17 @@ opacity =  doS . Opacity . clampRatio  fadeTo, translucence, fadeBy :: Rational -> FadeHook--- ^ An alias for 'transparency'.+-- | An alias for 'transparency'. fadeTo       = transparency--- ^ An alias for 'transparency'.+-- | An alias for 'transparency'. translucence = transparency--- ^ An alias for 'transparency'.+-- | An alias for 'opacity'. fadeBy       = opacity  invisible, solid :: FadeHook--- ^ An alias for 'transparent'.+-- | An alias for 'transparent'. invisible    = transparent--- ^ An alias for 'opaque'.+-- | An alias for 'opaque'. solid        = opaque  -- | Like 'doF', but usable with 'ManageHook'-like hooks that@@ -201,15 +211,15 @@   forM_ visibleWins $ \w -> do     o <- userCodeDef (Opacity 1) (runQuery h w)     setOpacity w $ case o of-                     OEmpty    -> 0.93+                     OEmpty    -> 1                      Opacity r -> r  -- | A 'handleEventHook' to handle fading and unfading of newly mapped --   or unmapped windows; this avoids problems with layouts such as---   "XMonad.Layout.Full" or "XMonad.Layout.Tabbed".  This hook may+--   'XMonad.Layout.Full' or "XMonad.Layout.Tabbed".  This hook may --   also be useful with "XMonad.Hooks.FadeInactive". fadeWindowsEventHook                     :: Event -> X All-fadeWindowsEventHook (MapNotifyEvent {}) =+fadeWindowsEventHook MapNotifyEvent{} =   -- we need to run the fadeWindowsLogHook.  only one way...   asks config >>= logHook >> return (All True) fadeWindowsEventHook _                   =  return (All True)
+ XMonad/Hooks/FloatConfigureReq.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE LambdaCase #-}+-- |+-- Module      :  XMonad.Hooks.FloatConfigureReq+-- Description :  Customize handling of floating windows' move\/resize\/restack requests (ConfigureRequest).+-- Copyright   :  (c) 2024 Tomáš Janoušek <tomi@nomi.cz>+-- License     :  BSD3+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>+--+-- xmonad normally honours those requests by doing exactly what the client+-- application asked, and refreshing. There are some misbehaving clients,+-- however, that:+--+-- * try to move their window to the last known absolute position regardless+--   of the current xrandr/xinerama layout+--+-- * move their window to 0, 0 for no particular reason (e.g. rxvt-unicode)+--+-- * issue lots of no-op requests causing flickering (e.g. Steam)+--+-- This module provides a replacement handler for 'ConfigureRequestEvent' to+-- work around such misbehaviours.+--+module XMonad.Hooks.FloatConfigureReq (+    -- * Usage+    -- $usage+    MaybeMaybeManageHook,+    floatConfReqHook,++    -- * Known workarounds+    fixSteamFlicker,+    fixSteamFlickerMMMH,+    ) where++import qualified Data.Map.Strict as M+import XMonad+import XMonad.Hooks.ManageHelpers+import XMonad.Prelude+import qualified XMonad.StackSet as W++-- $usage+-- To use this, include the following in your @xmonad.hs@:+--+-- > import XMonad.Hooks.FloatConfigureReq+-- > import XMonad.Hooks.ManageHelpers+--+-- > myFloatConfReqHook :: MaybeMaybeManageHook+-- > myFloatConfReqHook = composeAll+-- >     [ … ]+--+-- > myEventHook :: Event -> X All+-- > myEventHook = mconcat+-- >     [ …+-- >     , floatConfReqHook myFloatConfReqHook+-- >     , … ]+--+-- > main = xmonad $ …+-- >               $ def{ handleEventHook = myEventHook+-- >                    , … }+--+-- Then fill the @myFloatConfReqHook@ with whatever custom rules you need.+--+-- As an example, the following will prevent rxvt-unicode from moving its+-- (floating) window to 0, 0 after a font change but still ensure its size+-- increment hints are respected:+--+-- > className =? "URxvt" -?> pure <$> doFloat+--+-- Another example that avoids flickering and xmonad slowdowns caused by the+-- Steam client (completely ignore all its requests, none of which are+-- meaningful in the context of a tiling WM):+--+-- > map toLower `fmap` className =? "steam" -?> mempty+--+-- (this example is also available as 'fixSteamFlickerMMMH' to be added to+-- one's @myFloatConfReqHook@ and also 'fixSteamFlicker' to be added directly+-- to one's 'handleEventHook')++-- | A variant of 'MaybeManageHook' that additionally may or may not make+-- changes to the 'WindowSet'.+type MaybeMaybeManageHook = Query (Maybe (Maybe (Endo WindowSet)))++-- | Customizable handler for a 'ConfigureRequestEvent'. If the event's+-- 'ev_window' is a managed floating window, the provided+-- 'MaybeMaybeManageHook' is consulted and its result interpreted as follows:+--+--  * @Nothing@ - no match, fall back to the default handler+--+--  * @Just Nothing@ - match but ignore, no refresh, just send ConfigureNotify+--+--  * @Just (Just a)@ - match, modify 'WindowSet', refresh, send ConfigureNotify+floatConfReqHook :: MaybeMaybeManageHook -> Event -> X All+floatConfReqHook mh ConfigureRequestEvent{ev_window = w} =+    runQuery (join <$> (isFloatQ -?> mh)) w >>= \case+        Nothing -> mempty+        Just e -> do+            whenJust e (windows . appEndo)+            sendConfEvent+            pure (All False)+  where+    sendConfEvent = withDisplay $ \dpy ->+        withWindowAttributes dpy w $ \wa -> do+            io . allocaXEvent $ \ev -> do+                -- We may have made no changes to the window size/position+                -- and thus the X server didn't emit any ConfigureNotify,+                -- so we need to send the ConfigureNotify ourselves to make+                -- sure there is a reply to this ConfigureRequestEvent and the+                -- window knows we (possibly) ignored its request.+                setEventType ev configureNotify+                setConfigureEvent ev w w+                    (wa_x wa) (wa_y wa) (wa_width wa)+                    (wa_height wa) (wa_border_width wa) none (wa_override_redirect wa)+                sendEvent dpy w False 0 ev+floatConfReqHook _ _ = mempty++-- | A 'Query' to determine if a window is floating.+isFloatQ :: Query Bool+isFloatQ = ask >>= \w -> liftX . gets $ M.member w . W.floating . windowset++-- | A pre-packaged 'floatConfReqHook' that fixes flickering of the Steam client by ignoring 'ConfigureRequestEvent's on any of its floating windows.+--+-- To use this, add 'fixSteamFlicker' to your 'handleEventHook'.+fixSteamFlicker :: Event -> X All+fixSteamFlicker = floatConfReqHook fixSteamFlickerMMMH++fixSteamFlickerMMMH :: MaybeMaybeManageHook+fixSteamFlickerMMMH = map toLower `fmap` className =? "steam" -?> mempty
XMonad/Hooks/FloatNext.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.FloatNext+-- Description :  Automatically send the next spawned window(s) to the floating layer. -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -30,7 +30,7 @@                               , willFloatNext                               , willFloatAllNew -                                -- * 'DynamicLog' utilities+                                -- * Status bar utilities                                 -- $pp                               , willFloatNextPP                               , willFloatAllNewPP@@ -47,13 +47,13 @@ -- to automatically send the next spawned window(s) to the floating -- layer. ----- You can use it by including the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use it by including the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.FloatNext -- -- and adding 'floatNextHook' to your 'ManageHook': ----- > myManageHook = floatNextHook <+> manageHook defaultConfig+-- > myManageHook = floatNextHook <> manageHook def -- -- The 'floatNext' and 'toggleFloatNext' functions can be used in key -- bindings to float the next spawned window:@@ -97,10 +97,10 @@ -- $pp -- The following functions are used to display the current -- state of 'floatNext' and 'floatAllNew' in your--- 'XMonad.Hooks.DynamicLog.dynamicLogWithPP'.+-- "XMonad.Hooks.StatusBar.PP". -- 'willFloatNextPP' and 'willFloatAllNewPP' should be added--- to the 'XMonad.Hooks.DynamicLog.ppExtras' field of your--- 'XMonad.Hooks.DynamicLog.PP'.+-- to the 'XMonad.Hooks.StatusBar.PP.ppExtras' field of your+-- "XMonad.Hooks.StatusBar.PP". -- -- Use 'runLogHook' to refresh the output of your 'logHook', so -- that the effects of a 'floatNext'/... will be visible
+ XMonad/Hooks/Focus.hs view
@@ -0,0 +1,546 @@+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# OPTIONS_HADDOCK show-extensions     #-}++-- |+-- Module:      XMonad.Hooks.Focus+-- Description: Extends ManageHook EDSL to work on focused windows and current workspace.+-- Copyright:   sgf-dma, 2016+-- Maintainer:  sgf.dma@gmail.com+--+-- Extends "XMonad.ManageHook" EDSL to work on focused windows and current+-- workspace.+--++module XMonad.Hooks.Focus+    (+      -- $main++      -- * FocusQuery.+      --+      -- $focusquery+      Focus (..)+    , FocusLock (..)+    , toggleLock+    , focusLockOn+    , focusLockOff+    , FocusQuery+    , runFocusQuery+    , FocusHook++      -- * Lifting into FocusQuery.+      --+      -- $lift+    , liftQuery+    , new+    , focused+    , focused'+    , focusedOn+    , focusedOn'+    , focusedCur+    , focusedCur'+    , newOn+    , newOnCur+    , unlessFocusLock++      -- * Commonly used actions for modifying focus.+      --+      -- $common+    , keepFocus+    , switchFocus+    , keepWorkspace+    , switchWorkspace++      -- * Running FocusQuery.+      --+      -- $running+    , manageFocus++      -- * Example configurations.+      --+      -- $examples+    , activateSwitchWs+    , activateOnCurrentWs+    , activateOnCurrentKeepFocus+    )+  where++import Control.Arrow ((&&&))+import Control.Monad.Reader++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W+import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Hooks.ManageHelpers (currentWs)+++-- $main+--+-- This module provides monad on top of Query monad providing additional+-- information about new window:+--+--  - workspace, where new window will appear;+--  - focused window on workspace, where new window will appear;+--  - current workspace;+--+-- And a property in extensible state:+--+--  - is focus lock enabled? Focus lock instructs all library's 'FocusHook'+--  functions to not move focus or switch workspace.+--+-- Lifting operations for standard 'ManageHook' EDSL combinators into+-- 'FocusQuery' monad allowing to run these combinators on focused window and+-- common actions for keeping focus and\/or workspace, switching focus and\/or+-- workspace are also provided.+--+-- == Quick start.+--+-- I may use one of predefined configurations.+--+-- 1. The default window activation behavior (switch to workspace with+--    activated window and switch focus to it) expressed using this module:+--+--      > import XMonad+--      >+--      > import XMonad.Hooks.EwmhDesktops+--      > import XMonad.Hooks.Focus+--      >+--      > main :: IO ()+--      > main = do+--      >         let ah :: ManageHook+--      >             ah = activateSwitchWs+--      >             xcf = setEwmhActivateHook ah+--      >                 . ewmh $ def{ modMask = mod4Mask }+--      >         xmonad xcf+--+-- 2. Or i may move activated window to current workspace and switch focus to+--    it:+--+--      >         let ah :: ManageHook+--      >             ah = activateOnCurrentWs+--+-- 3. Or move activated window to current workspace, but keep focus unchanged:+--+--      >         let ah :: ManageHook+--      >             ah = activateOnCurrentKeepFocus+--+-- 4. I may use regular 'ManageHook' combinators for filtering, which windows+--    may activate. E.g. activate all windows, except firefox:+--+--      >         let ah :: ManageHook+--      >             ah  = not <$> (className =? "Firefox" <||> className =? "Firefox-esr" <||> className =? "Iceweasel")+--      >                     --> activateSwitchWs+--+-- 5. Or even use 'FocusHook' combinators. E.g. activate all windows, unless+--    xterm is focused on /current/ workspace:+--+--      >         let ah :: ManageHook+--      >             ah  = manageFocus (not <$> focusedCur (className =? "XTerm")+--      >                     --> liftQuery activateSwitchWs)+--+--      or activate all windows, unless focused window on the workspace,+--      /where activated window is/, is not a xterm:+--+--      >         let ah :: ManageHook+--      >             ah  = manageFocus (not <$> focused (className =? "XTerm")+--      >                     --> liftQuery activateSwitchWs)+--+-- == Defining FocusHook.+--+-- I may define my own 'FocusHook' like:+--+-- >    activateFocusHook :: FocusHook+-- >    activateFocusHook = composeAll+-- >            -- If 'gmrun' is focused on workspace, on which+-- >            -- /activated window/ is, keep focus unchanged. But i+-- >            -- may still switch workspace (thus, i use 'composeAll').+-- >            -- See 'keepFocus' properties in the docs below.+-- >            [ focused (className =? "Gmrun")+-- >                            --> keepFocus+-- >            -- Default behavior for activated windows: switch+-- >            -- workspace and focus.+-- >            , return True   --> switchWorkspace <> switchFocus+-- >            ]+-- >+-- >    newFocusHook :: FocusHook+-- >    newFocusHook      = composeOne+-- >            -- Always switch focus to 'gmrun'.+-- >            [ new (className =? "Gmrun")        -?> switchFocus+-- >            -- And always keep focus on 'gmrun'. Note, that+-- >            -- another 'gmrun' will steal focus from already+-- >            -- running one.+-- >            , focused (className =? "Gmrun")    -?> keepFocus+-- >            -- If firefox dialog prompt (e.g. master password+-- >            -- prompt) is focused on current workspace and new+-- >            -- window appears here too, keep focus unchanged+-- >            -- (note, used predicates: @newOnCur <&&> focused@ is+-- >            -- the same as @newOnCur <&&> focusedCur@, but is+-- >            -- /not/ the same as just 'focusedCur' )+-- >            , newOnCur <&&> focused+-- >                ((className =? "Firefox" <||> className =? "Firefox-esr" <||> className =? "Iceweasel") <&&> isDialog)+-- >                                                -?> keepFocus+-- >            -- Default behavior for new windows: switch focus.+-- >            , return True                       -?> switchFocus+-- >            ]+--+-- And then use it:+--+-- >    import XMonad+-- >    import XMonad.Util.EZConfig+-- >+-- >    import XMonad.Hooks.EwmhDesktops+-- >    import XMonad.Hooks.ManageHelpers+-- >    import XMonad.Hooks.Focus+-- >+-- >+-- >    main :: IO ()+-- >    main = do+-- >            let newFh :: ManageHook+-- >                newFh = manageFocus newFocusHook+-- >                acFh :: ManageHook+-- >                acFh = manageFocus activateFocusHook+-- >                xcf = setEwmhActivateHook acFh+-- >                    . ewmh $ def+-- >                             { manageHook   = newFh <> manageHook def+-- >                             , modMask      = mod4Mask+-- >                             }+-- >                        `additionalKeys` [((mod4Mask, xK_v), toggleLock)]+-- >            xmonad xcf+--+-- Note:+--+--  - /mod4Mask+v/ key toggles focus lock (when enabled, neither focus nor+--  workspace won't be switched).+--  - I need "XMonad.Hooks.EwmhDesktops" module for enabling window+--  activation.+--  - 'FocusHook' in 'manageHook' will be called /only/ for new windows.+--  - 'FocusHook' in 'setEwmhActivateHook' will be called /only/ for activated windows.+--+--  Alternatively, i may construct a single 'FocusHook' for both new and+--  activated windows and then just add it to both 'manageHook' and 'setEwmhActivateHook':+--+-- >            let fh :: Bool -> ManageHook+-- >                fh activated = manageFocus $ composeOne+-- >                        [ pure activated -?> activateFocusHook+-- >                        , pure True      -?> newFocusHook+-- >                        ]+-- >                xcf = setEwmhActivateHook (fh True)+-- >                    . ewmh $ def+-- >                             { manageHook   = fh False <> manageHook def+-- >                             , modMask      = mod4Mask+-- >                             }+-- >                        `additionalKeys` [((mod4Mask, xK_v), toggleLock)]+--+-- And more technical notes:+--+--  - 'FocusHook' will run /many/ times, so it usually should not keep state+--  or save results. Precisely, it may do anything, but it must be idempotent+--  to operate properly.+--  - 'FocusHook' will see new window at workspace, where functions on the+--  /right/ from it in 'ManageHook' monoid place it.  In other words, in+--  @(Endo WindowSet)@ monoid i may see changes only from functions applied+--  /before/ (more to the right in function composition). Thus, it's better to+--  add 'FocusHook' the last.+--  - 'FocusHook' functions won't see window shift to another workspace made+--  by function from 'FocusHook' itself: new window workspace is determined+--  /before/ running 'FocusHook' and even if later one of 'FocusHook'+--  functions moves window to another workspace, predicates ('focused',+--  'newOn', etc) will still think new window is at workspace it was before.+--  This can be worked around by splitting 'FocusHook' into several different+--  values and evaluating each one separately, like:+--+--      > (FH2 -- manageFocus --> MH2) <> (FH1 -- manageFocus --> MH1) <> ..+--+--      E.g.+--+--      > manageFocus FH2 <> manageFocus FH1 <> ..+--+--      now @FH2@ will see window shift made by @FH1@.+--+-- Another interesting example is moving all activated windows to current+-- workspace by default, and applying 'FocusHook' after:+--+-- >    import XMonad+-- >    import XMonad.Util.EZConfig+-- >+-- >    import XMonad.Hooks.EwmhDesktops+-- >    import XMonad.Hooks.ManageHelpers+-- >    import XMonad.Hooks.Focus+-- >+-- >    main :: IO ()+-- >    main = do+-- >            let fh :: Bool -> ManageHook+-- >                fh activated = manageFocus $ composeOne+-- >                        [ pure activated -?> (newOnCur --> keepFocus)+-- >                        , pure True      -?> newFocusHook+-- >                        ]+-- >                xcf = setEwmhActivateHook (fh True <> activateOnCurrentWs)+-- >                    . ewmh $ def+-- >                             { manageHook = fh False <> manageHook def+-- >                             , modMask    = mod4Mask+-- >                             }+-- >                        `additionalKeys` [((mod4Mask, xK_v), toggleLock)]+-- >            xmonad xcf+-- >+-- >    newFocusHook :: FocusHook+-- >    newFocusHook      = composeOne+-- >            -- Always switch focus to 'gmrun'.+-- >            [ new (className =? "Gmrun")        -?> switchFocus+-- >            -- And always keep focus on 'gmrun'. Note, that+-- >            -- another 'gmrun' will steal focus from already+-- >            -- running one.+-- >            , focused (className =? "Gmrun")    -?> keepFocus+-- >            -- If firefox dialog prompt (e.g. master password+-- >            -- prompt) is focused on current workspace and new+-- >            -- window appears here too, keep focus unchanged+-- >            -- (note, used predicates: @newOnCur <&&> focused@ is+-- >            -- the same as @newOnCur <&&> focusedCur@, but is+-- >            -- /not/ the same as just 'focusedCur' )+-- >            , newOnCur <&&> focused+-- >                ((className =? "Firefox" <||> className =? "Firefox-esr" <||> className =? "Iceweasel") <&&> isDialog)+-- >                                                -?> keepFocus+-- >            -- Default behavior for new windows: switch focus.+-- >            , return True                       -?> switchFocus+-- >            ]+--+-- Note here:+--+--  - i keep focus, when activated window appears on current workspace, in+--  this example.+--  - when @pure activated -?> (newOnCur --> keepFocus)@ runs, activated+--  window will be /already/ on current workspace, thus, if i do not want to+--  move some activated windows, i should filter them out before applying+--  @activateOnCurrentWs@ 'FocusHook'.+++-- FocusQuery.+-- $focusquery++-- | Information about current workspace and focus.+data Focus          = Focus+                        { -- | Workspace, where new window appears.+                          newWorkspace      :: WorkspaceId+                          -- | Focused window on workspace, where new window+                          -- appears.+                        , focusedWindow     :: Maybe Window+                          -- | Current workspace.+                        , currentWorkspace  :: WorkspaceId+                        }+  deriving (Show)+instance Default Focus where+    def             = Focus+                        { focusedWindow     = Nothing+                        , newWorkspace      = ""+                        , currentWorkspace  = ""+                        }++newtype FocusLock   = FocusLock {getFocusLock :: Bool}+  deriving (Show)+instance ExtensionClass FocusLock where+    initialValue    = FocusLock False++-- | Toggle stored focus lock state.+toggleLock :: X ()+toggleLock          = XS.modify (\(FocusLock b) -> FocusLock (not b))++-- | Lock focus.+focusLockOn :: X ()+focusLockOn         = XS.modify (const (FocusLock True))++-- | Unlock focus.+focusLockOff :: X ()+focusLockOff        = XS.modify (const (FocusLock False))++-- | Monad on top of 'Query' providing additional information about new+-- window.+newtype FocusQuery a = FocusQuery (ReaderT Focus Query a)+  deriving newtype (Functor, Applicative, Monad, MonadReader Focus, MonadIO)+  deriving (Semigroup, Monoid) via Ap FocusQuery a++runFocusQuery :: FocusQuery a -> Focus -> Query a+runFocusQuery (FocusQuery m)    = runReaderT m++type FocusHook = FocusQuery (Endo WindowSet)+++-- Lifting into 'FocusQuery'.+-- $lift++-- | Lift 'Query' into 'FocusQuery' monad. The same as 'new'.+liftQuery :: Query a -> FocusQuery a+liftQuery           = FocusQuery . lift++-- | Run 'Query' on new window.+new :: Query a -> FocusQuery a+new                 = liftQuery++-- | Run 'Query' on focused window on workspace, where new window appears. If+-- there is no focused window, return 'False'.+focused :: Query Bool -> FocusQuery Bool+focused m           = getAny <$> focused' (Any <$> m)+-- | More general version of 'focused'.+focused' :: Monoid a => Query a -> FocusQuery a+focused' m          = do+    mw <- asks focusedWindow+    liftQuery (maybe mempty (flip local m . const) mw)++-- | Run 'Query' on window focused at particular workspace. If there is no+-- focused window, return 'False'.+focusedOn :: WorkspaceId -> Query Bool -> FocusQuery Bool+focusedOn i m       = getAny <$> focusedOn' i (Any <$> m)+-- | More general version of 'focusedOn'.+focusedOn' :: Monoid a => WorkspaceId -> Query a -> FocusQuery a+focusedOn' i m      = liftQuery $ do+    mw <- liftX $ withWindowSet (return . W.peek . W.view i)+    maybe mempty (flip local m . const) mw++-- | Run 'Query' on focused window on current workspace. If there is no+-- focused window, return 'False'.  Note,+--+-- > focused <&&> newOnCur != focusedCur+--+-- The first will affect only new or activated window appearing on current+-- workspace, while the last will affect any window: focus even for windows+-- appearing on other workpsaces will depend on focus on /current/ workspace.+focusedCur :: Query Bool -> FocusQuery Bool+focusedCur m        = getAny <$> focusedCur' (Any <$> m)+-- | More general version of 'focusedCur'.+focusedCur' :: Monoid a => Query a -> FocusQuery a+focusedCur' m       = asks currentWorkspace >>= \i -> focusedOn' i m++-- | Does new window appear at particular workspace?+newOn :: WorkspaceId -> FocusQuery Bool+newOn i             = asks ((i ==) . newWorkspace)+-- | Does new window appear at current workspace?+newOnCur :: FocusQuery Bool+newOnCur            = asks currentWorkspace >>= newOn++-- | Execute 'Query', unless focus is locked.+unlessFocusLock :: Monoid a => Query a -> Query a+unlessFocusLock m   = do+    FocusLock b <- liftX XS.get+    when' (not b) m++-- Commonly used actions for modifying focus.+--+-- $common+-- Operations in each pair 'keepFocus' and 'switchFocus', 'keepWorkspace' and+-- 'switchWorkspace' overwrite each other (the letftmost will determine what+-- happened):+--+-- prop> keepFocus       <> switchFocus     = keepFocus+-- prop> switchFocus     <> keepFocus       = switchFocus+-- prop> keepWorkspace   <> switchWorkspace = keepWorkspace+-- prop> switchWorkspace <> keepWorkspace   = switchWorkspace+--+-- and operations from different pairs are commutative:+--+-- prop> keepFocus   <> switchWorkspace = switchWorkspace <> keepFocus+-- prop> switchFocus <> switchWorkspace = switchWorkspace <> switchFocus+--+-- etc.++-- | Keep focus on workspace (may not be current), where new window appears.+-- Workspace will not be switched. This operation is idempotent and+-- effectively returns focus to window focused on that workspace before+-- applying @(Endo WindowSet)@ function.+keepFocus :: FocusHook+keepFocus           = focused' $ ask >>= \w -> doF $ \ws ->+                        W.view (W.currentTag ws) . W.focusWindow w $ ws++-- | Switch focus to new window on workspace (may not be current), where new+-- window appears. Workspace will not be switched. This operation is+-- idempotent.+switchFocus :: FocusHook+switchFocus         = do+    FocusLock b <- liftQuery . liftX $ XS.get+    if b+      -- When focus lock is enabled, call 'keepFocus' explicitly (still no+      -- 'keepWorkspace') to overwrite default behavior.+      then keepFocus+      else new $ ask >>= \w -> doF $ \ws ->+            W.view (W.currentTag ws) . W.focusWindow w $ ws++-- | Keep current workspace. Focus will not be changed at either current or+-- new window's  workspace. This operation is idempotent and effectively+-- switches to workspace, which was current before applying @(Endo WindowSet)@+-- function.+keepWorkspace :: FocusHook+keepWorkspace       = do+    ws <- asks currentWorkspace+    liftQuery . doF $ W.view ws++-- | Switch workspace to one, where new window appears. Focus will not be+-- changed at either current or new window's workspace. This operation is+-- idempotent.+switchWorkspace :: FocusHook+switchWorkspace     = do+    FocusLock b <- liftQuery . liftX $ XS.get+    if b+      -- When focus lock is enabled, call 'keepWorkspace' explicitly (still no+      -- 'keepFocus') to overwrite default behavior.+      then keepWorkspace+      else do+        ws <- asks newWorkspace+        liftQuery . doF $ W.view ws++-- Running FocusQuery.+-- $running++-- | I don't know at which workspace new window will appear until @(Endo+-- WindowSet)@ function from 'windows' in "XMonad.Operations" actually run,+-- but in @(Endo WindowSet)@ function i can't already execute monadic actions,+-- because it's pure. So, i compute result for every workspace here and just+-- use it later in @(Endo WindowSet)@ function.  Note, though, that this will+-- execute monadic actions many times, and therefore assume, that result of+-- 'FocusHook' does not depend on the number of times it was executed.+manageFocus :: FocusHook -> ManageHook+manageFocus m       = do+    fws <- liftX . withWindowSet $ return+      . map (W.tag &&& fmap W.focus . W.stack) . W.workspaces+    ct  <- currentWs+    let r = def {currentWorkspace = ct}+    hs <- forM fws $ \(i, mw) -> do+      f <- runFocusQuery m (r {focusedWindow = mw, newWorkspace = i})+      return (i, f)+    reader (selectHook hs) >>= doF+  where+    -- | Select and apply @(Endo WindowSet)@ function depending on which+    -- workspace new window appeared now.+    selectHook :: [(WorkspaceId, Endo WindowSet)] -> Window -> WindowSet -> WindowSet+    selectHook cfs nw ws    = fromMaybe ws $ do+        i <- W.findTag nw ws+        f <- lookup i cfs+        return (appEndo f ws)++when' :: (Monad m, Monoid a) => Bool -> m a -> m a+when' b mx+  | b               = mx+  | otherwise       = return mempty++-- Exmaple configurations.+-- $examples++-- | Default EWMH window activation behavior: switch to workspace with+-- activated window and switch focus to it. Not to be used in a 'manageHook'.+activateSwitchWs :: ManageHook+activateSwitchWs    = manageFocus (switchWorkspace <> switchFocus)++-- | Move activated window to current workspace. Not to be used in a 'manageHook'.+activateOnCurrent' :: ManageHook+activateOnCurrent'  = currentWs >>= unlessFocusLock . doShift++-- | Move activated window to current workspace and switch focus to it. Note,+-- that i need to explicitly call 'switchFocus' here, because otherwise, when+-- activated window is /already/ on current workspace, focus won't be+-- switched. Not to be used in a 'manageHook'.+activateOnCurrentWs :: ManageHook+activateOnCurrentWs = manageFocus (newOnCur --> switchFocus) <> activateOnCurrent'++-- | Move activated window to current workspace, but keep focus unchanged.+-- Not to be used in a 'manageHook'.+activateOnCurrentKeepFocus :: ManageHook+activateOnCurrentKeepFocus  = manageFocus (newOnCur --> keepFocus) <> activateOnCurrent'
− XMonad/Hooks/ICCCMFocus.hs 
@@ -1,42 +0,0 @@--------------------------------------------------------------------------------- |--- Module       : XMonad.Hooks.ICCCMFocus--- License      : BSD------ Maintainer   : Tony Morris <haskell@tmorris.net>------ Implemented in your @logHook@, Java swing applications will not misbehave--- when it comes to taking and losing focus.------ This has been done by taking the patch in <http://code.google.com/p/xmonad/issues/detail?id=177> and refactoring it so that it can be included in @~\/.xmonad\/xmonad.hs@.------ @---    conf' =---      conf {---        logHook = takeTopFocus---      }--- @-------------------------------------------------------------------------------module XMonad.Hooks.ICCCMFocus-{-# DEPRECATED "XMonad.Hooks.ICCCMFocus: xmonad>0.10 core merged issue 177" #-}-(-  atom_WM_TAKE_FOCUS-, takeFocusX-, takeTopFocus-) where--import XMonad-import XMonad.Hooks.SetWMName-import qualified XMonad.StackSet as W--takeFocusX ::-  Window-  -> X ()-takeFocusX _w = return ()---- | The value to add to your log hook configuration.-takeTopFocus ::-  X ()-takeTopFocus =-  (withWindowSet $ maybe (setFocusX =<< asks theRoot) takeFocusX . W.peek) >> setWMName "LG3D"-
XMonad/Hooks/InsertPosition.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.InsertPosition+-- Description :  Configure where new windows should be added and how focus should shift. -- Copyright   :  (c) 2009 Adam Vogt -- License     :  BSD-style (see xmonad/LICENSE) --@@ -16,24 +17,30 @@ module XMonad.Hooks.InsertPosition (     -- * Usage     -- $usage-    insertPosition+    setupInsertPosition, insertPosition     ,Focus(..), Position(..)     ) where -import XMonad(ManageHook, MonadReader(ask))+import XMonad (ManageHook, MonadReader (ask), XConfig (manageHook))+import XMonad.Prelude (Endo (Endo), find) import qualified XMonad.StackSet as W-import Control.Applicative((<$>))-import Data.Maybe(fromMaybe)-import Data.List(find)-import Data.Monoid(Endo(Endo))  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module by importing it in your @xmonad.hs@: -- -- > import XMonad.Hooks.InsertPosition--- > xmonad defaultConfig { manageHook = insertPosition Master Newer <+> myManageHook } ----- You should you put the manageHooks that use 'doShift' to take effect+-- You then just have to add 'setupInsertPosition' to your @main@ function:+--+-- > main = xmonad $ … $ setupInsertPosition Master Newer $ def { … }+--+-- Alternatively (i.e., you should /not/ do this if you already have set+-- up the above combinator), you can also directly insert+-- 'insertPosition' into your manageHook:+--+-- > xmonad def { manageHook = insertPosition Master Newer <> myManageHook }+--+-- NOTE: You should you put the manageHooks that use 'doShift' to take effect -- /before/ 'insertPosition', so that the window order will be consistent. -- Because ManageHooks compose from right to left (like function composition -- '.'), this means that 'insertPosition' should be the leftmost ManageHook.@@ -41,13 +48,18 @@ data Position = Master | End | Above | Below data Focus = Newer | Older +-- | A combinator for setting up 'insertPosition'.+setupInsertPosition :: Position -> Focus -> XConfig a -> XConfig a+setupInsertPosition pos foc cfg =+  cfg{ manageHook = insertPosition pos foc <> manageHook cfg }+ -- | insertPosition. A manage hook for placing new windows. XMonad's default is -- the same as using: @insertPosition Above Newer@. insertPosition :: Position -> Focus -> ManageHook insertPosition pos foc = Endo . g <$> ask   where     g w = viewingWs w (updateFocus w . ins w . W.delete' w)-    ins w = (\f ws -> fromMaybe id (W.focusWindow <$> W.peek ws) $ f ws) $+    ins w = (\f ws -> maybe id W.focusWindow (W.peek ws) $ f ws) $         case pos of             Master -> W.insertUp w . W.focusMaster             End    -> insertDown w . W.modify' focusLast'@@ -70,5 +82,7 @@ insertDown w = W.swapDown . W.insertUp w  focusLast' ::  W.Stack a -> W.Stack a-focusLast' st = let ws = W.integrate st-    in W.Stack (last ws) (tail $ reverse ws) []+focusLast' st =+  case reverse (W.integrate st) of+    []       -> st+    (l : ws) -> W.Stack l ws []
+ XMonad/Hooks/ManageDebug.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.ManageDebug+-- Description :  A manageHook and associated logHook for debugging ManageHooks.+-- Copyright   :  (c) Brandon S Allbery KF8NH, 2014+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  allbery.b@gmail.com+-- Stability   :  unstable+-- Portability :  not portable+--+-- A @manageHook@ and associated @logHook@ for debugging 'ManageHook's.+-- Simplest usage: wrap your xmonad config in the @debugManageHook@ combinator.+-- Or use @debugManageHookOn@ for a triggerable version, specifying the+-- triggering key sequence in "XMonad.Util.EZConfig" syntax. Or use the+-- individual hooks in whatever way you see fit.+--+-----------------------------------------------------------------------------+--+--++module XMonad.Hooks.ManageDebug (debugManageHook+                                ,debugManageHookOn+                                ,manageDebug+                                ,maybeManageDebug+                                ,manageDebugLogHook+                                ,debugNextManagedWindow+                                ) where++import           XMonad+import           XMonad.Hooks.DebugStack+import           XMonad.Util.DebugWindow+import           XMonad.Util.EZConfig+import qualified XMonad.Util.ExtensibleState                                                 as XS++-- state for manageHook debugging to trigger logHook debugging+data MSDFinal = DoLogHook | SkipLogHook deriving Show+data MSDTrigger = MSDActivated | MSDInactive deriving Show+data ManageStackDebug = MSD MSDFinal MSDTrigger deriving Show+instance ExtensionClass ManageStackDebug where+  initialValue = MSD SkipLogHook MSDInactive++-- | A combinator to add full 'ManageHook' debugging in a single operation.+debugManageHook :: XConfig l -> XConfig l+debugManageHook cf = cf {logHook    = manageDebugLogHook <> logHook    cf+                        ,manageHook = manageDebug        <> manageHook cf+                        }++-- | A combinator to add triggerable 'ManageHook' debugging in a single operation.+--   Specify a key sequence as a string in "XMonad.Util.EZConfig" syntax; press+--   this key before opening the window to get just that logged.+debugManageHookOn :: String -> XConfig l -> XConfig l+debugManageHookOn key cf = cf {logHook    = manageDebugLogHook <> logHook    cf+                              ,manageHook = maybeManageDebug   <> manageHook cf+                              }+                           `additionalKeysP`+                           [(key,debugNextManagedWindow)]++-- | Place this at the start of a 'ManageHook', or possibly other places for a+--   more limited view. It will show the current 'StackSet' state and the new+--   window, and set a flag so that @manageDebugLogHook@ will display the+--   final 'StackSet' state.+--+--   Note that the initial state shows only the current workspace; the final+--   one shows all workspaces, since your 'manageHook' might use e.g. 'doShift',+manageDebug :: ManageHook+manageDebug = do+  w <- ask+  liftX $ do+    trace "== manageHook; current stack =="+    debugStackString >>= trace+    ws <- debugWindow w+    trace $ "new window:\n  " ++ ws+    -- technically we don't care about go here, since only maybeManageDebug+    -- uses it+    XS.modify $ \(MSD _ go') -> MSD DoLogHook go'+  idHook++-- | @manageDebug@ only if the user requested it with @debugNextManagedWindow@.+maybeManageDebug :: ManageHook+maybeManageDebug = do+  go <- liftX $ do+    MSD _ go' <- XS.get+    -- leave it active, as we may manage multiple windows before the logHook+    -- so we now deactivate it in the logHook+    return go'+  case go of+    MSDActivated -> manageDebug+    _            -> idHook++-- | If @manageDebug@ has set the debug-stack flag, show the stack.+manageDebugLogHook :: X ()+manageDebugLogHook = do+                       MSD log' _ <- XS.get+                       case log' of+                         DoLogHook -> do+                                  trace "== manageHook; final stack =="+                                  debugStackFullString >>= trace+                                  -- see comment in maybeManageDebug+                                  XS.put $ MSD SkipLogHook MSDInactive+                         _         -> idHook++-- | Request that the next window to be managed be @manageDebug@-ed. This can+--   be used anywhere an X action can, such as key bindings, mouse bindings+--   (presumably with 'const'), 'startupHook', etc.+debugNextManagedWindow :: X ()+debugNextManagedWindow = XS.modify $ \(MSD log' _) -> MSD log' MSDActivated
XMonad/Hooks/ManageDocks.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP #-}--- deriving Typeable for ghc-6.6 compatibility, which is retained in the core+{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses, CPP, LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Hooks.ManageDocks+-- Description :  Automatically manage 'dock' type programs. -- Copyright    : (c) Joachim Breitner <mail@joachim-breitner.de> -- License      : BSD --@@ -16,8 +16,7 @@ module XMonad.Hooks.ManageDocks (     -- * Usage     -- $usage-    manageDocks, checkDock, AvoidStruts, avoidStruts, avoidStrutsOn,-    docksEventHook,+    docks, manageDocks, checkDock, AvoidStruts(..), avoidStruts, avoidStrutsOn, onAllDocks,     ToggleStruts(..),     SetStruts(..),     module XMonad.Util.Types,@@ -28,8 +27,11 @@     RectC(..), #endif -    -- for XMonad.Actions.FloatSnap-    calcGap+    -- * For developers of other modules ("XMonad.Actions.FloatSnap")+    calcGap,++    -- * Standalone hooks (deprecated)+    docksEventHook, docksStartupHook,     ) where  @@ -39,35 +41,28 @@ import XMonad.Layout.LayoutModifier import XMonad.Util.Types import XMonad.Util.WindowProperties (getProp32s)-import XMonad.Util.XUtils (fi)-import Data.Monoid (All(..))+import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Prelude -import qualified Data.Set as S+import qualified Data.Set        as S+import qualified Data.Map        as M+import qualified XMonad.StackSet as W  -- $usage--- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@:+-- To use this module, add the following import to @xmonad.hs@: -- -- > import XMonad.Hooks.ManageDocks ----- The first component is a 'ManageHook' which recognizes these--- windows and de-manages them, so that xmonad does not try to tile--- them.  To enable it:+-- Wrap your xmonad config with a call to 'docks', like so: ----- > manageHook = ... <+> manageDocks+-- > main = xmonad $ … . docks . … $ def{…} ----- The second component is a layout modifier that prevents windows--- from overlapping these dock windows.  It is intended to replace--- xmonad's so-called \"gap\" support.  First, you must add it to your--- list of layouts:+-- Then add 'avoidStruts' or 'avoidStrutsOn' layout modifier to your layout+-- to prevent windows from overlapping these windows. -- -- > layoutHook = avoidStruts (tall ||| mirror tall ||| ...) -- >                   where  tall = Tall 1 (3/100) (1/2) ----- The third component is an event hook that causes new docks to appear--- immediately, instead of waiting for the next focus change.------ > handleEventHook = ... <+> docksEventHook--- -- 'AvoidStruts' also supports toggling the dock gaps; add a keybinding -- similar to: --@@ -87,48 +82,122 @@ -- -- > layoutHook = avoidStrutsOn [U,L] (tall ||| mirror tall ||| ...) ----- /Important note/: if you are switching from manual gaps--- (defaultGaps in your config) to avoidStruts (recommended, since--- manual gaps will probably be phased out soon), be sure to switch--- off all your gaps (with mod-b) /before/ reloading your config with--- avoidStruts!  Toggling struts with a 'ToggleStruts' message will--- not work unless your gaps are set to zero.--- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -- +-- | Add docks functionality to the given config.  See above for an example.+docks :: XConfig a -> XConfig a+docks c = c { startupHook     = docksStartupHook <> startupHook c+            , handleEventHook = docksEventHook <> handleEventHook c+            , manageHook      = manageDocks <> manageHook c }++type WindowStruts = M.Map Window [Strut]++data UpdateDocks = UpdateDocks+instance Message UpdateDocks++refreshDocks :: X ()+refreshDocks = sendMessage UpdateDocks++-- Nothing means cache hasn't been initialized yet+newtype StrutCache = StrutCache { fromStrutCache :: Maybe WindowStruts }+    deriving Eq++instance ExtensionClass StrutCache where+    initialValue = StrutCache Nothing++modifiedStrutCache :: (Maybe WindowStruts -> X WindowStruts) -> X Bool+modifiedStrutCache f = XS.modifiedM $ fmap (StrutCache . Just) . f . fromStrutCache++getStrutCache :: X WindowStruts+getStrutCache = do+    cache <- maybeInitStrutCache =<< XS.gets fromStrutCache+    cache <$ XS.put (StrutCache (Just cache))++updateStrutCache :: Window -> X Bool+updateStrutCache w = modifiedStrutCache $ updateStrut w <=< maybeInitStrutCache++deleteFromStrutCache :: Window -> X Bool+deleteFromStrutCache w = modifiedStrutCache $ fmap (M.delete w) . maybeInitStrutCache++maybeInitStrutCache :: Maybe WindowStruts -> X WindowStruts+maybeInitStrutCache = maybe (queryDocks >>= foldlM (flip updateStrut) M.empty) pure+  where+    queryDocks = withDisplay $ \dpy -> do+        (_, _, wins) <- io . queryTree dpy =<< asks theRoot+        filterM (runQuery checkDock) wins++updateStrut :: Window -> WindowStruts -> X WindowStruts+updateStrut w cache = do+    when (w `M.notMember` cache) $ requestDockEvents w+    strut <- getStrut w+    pure $ M.insert w strut cache++-- | Perform the given action on all docks.+onAllDocks :: (Window -> X ()) -> X ()+onAllDocks act = traverse_ (act . fst) . M.toList =<< getStrutCache+ -- | Detects if the given window is of type DOCK and if so, reveals---   it, but does not manage it. If the window has the STRUT property---   set, adjust the gap accordingly.+--   it, but does not manage it. manageDocks :: ManageHook-manageDocks = checkDock --> doIgnore+manageDocks = checkDock --> (doIgnore <> doRequestDockEvents)+  where+    doRequestDockEvents = ask >>= liftX . requestDockEvents >> mempty --- | Checks if a window is a DOCK or DESKTOP window+-- | Request events for a dock window.+-- (Only if not already a client to avoid overriding 'clientMask')+requestDockEvents :: Window -> X ()+requestDockEvents w = whenX (not <$> isClient w) $ withDisplay $ \dpy ->+    withWindowAttributes dpy w $ \attrs -> io $ selectInput dpy w $+        wa_your_event_mask attrs .|. propertyChangeMask .|. structureNotifyMask++-- | Checks if a window is a DOCK or DESKTOP window.+-- Ignores xmonad's own windows (usually _NET_WM_WINDOW_TYPE_DESKTOP) to avoid+-- unnecessary refreshes. checkDock :: Query Bool-checkDock = ask >>= \w -> liftX $ do-    dock <- getAtom "_NET_WM_WINDOW_TYPE_DOCK"-    desk <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"-    mbr <- getProp32s "_NET_WM_WINDOW_TYPE" w-    case mbr of-        Just rs -> return $ any (`elem` [dock,desk]) (map fromIntegral rs)-        _       -> return False+checkDock = isDockOrDesktop <&&> (not <$> isXMonad)+  where+    isDockOrDesktop = ask >>= \w -> liftX $ do+        dock <- getAtom "_NET_WM_WINDOW_TYPE_DOCK"+        desk <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"+        mbr <- getProp32s "_NET_WM_WINDOW_TYPE" w+        case mbr of+            Just rs -> return $ any ((`elem` [dock,desk]) . fromIntegral) rs+            _       -> return False+    isXMonad = className =? "xmonad"  -- | Whenever a new dock appears, refresh the layout immediately to avoid the -- new dock.+{-# DEPRECATED docksEventHook "Use docks instead." #-} docksEventHook :: Event -> X All-docksEventHook (MapNotifyEvent {ev_window = w}) = do-    whenX ((not `fmap` (isClient w)) <&&> runQuery checkDock w) refresh+docksEventHook MapNotifyEvent{ ev_window = w } = do+    whenX (runQuery checkDock w <&&> (not <$> isClient w)) $+        whenX (updateStrutCache w) refreshDocks     return (All True)+docksEventHook PropertyEvent{ ev_window = w+                            , ev_atom = a } = do+    nws <- getAtom "_NET_WM_STRUT"+    nwsp <- getAtom "_NET_WM_STRUT_PARTIAL"+    when (a == nws || a == nwsp) $+        whenX (updateStrutCache w) refreshDocks+    return (All True)+docksEventHook DestroyWindowEvent{ ev_window = w } = do+    whenX (deleteFromStrutCache w) refreshDocks+    return (All True) docksEventHook _ = return (All True) +{-# DEPRECATED docksStartupHook "Use docks instead." #-}+docksStartupHook :: X ()+docksStartupHook = void getStrutCache+ -- | Gets the STRUT config, if present, in xmonad gap order getStrut :: Window -> X [Strut] getStrut w = do     msp <- getProp32s "_NET_WM_STRUT_PARTIAL" w     case msp of         Just sp -> return $ parseStrutPartial sp-        Nothing -> fmap (maybe [] parseStrut) $ getProp32s "_NET_WM_STRUT" w+        Nothing -> maybe [] parseStrut <$> getProp32s "_NET_WM_STRUT" w  where     parseStrut xs@[_, _, _, _] = parseStrutPartial . take 12 $ xs ++ cycle [minBound, maxBound]     parseStrut _ = []@@ -141,41 +210,46 @@ -- | Goes through the list of windows and find the gap so that all --   STRUT settings are satisfied. calcGap :: S.Set Direction2D -> X (Rectangle -> Rectangle)-calcGap ss = withDisplay $ \dpy -> do+calcGap ss = do     rootw <- asks theRoot-    -- We don't keep track of dock like windows, so we find all of them here-    (_,_,wins) <- io $ queryTree dpy rootw-    struts <- (filter careAbout . concat) `fmap` mapM getStrut wins+    struts <- filter careAbout . concat . M.elems <$> getStrutCache -    -- we grab the window attributes of the root window rather than checking-    -- the width of the screen because xlib caches this info and it tends to-    -- be incorrect after RAndR-    wa <- io $ getWindowAttributes dpy rootw-    let screen = r2c $ Rectangle (fi $ wa_x wa) (fi $ wa_y wa) (fi $ wa_width wa) (fi $ wa_height wa)+    -- If possible, we grab the window attributes of the root window rather+    -- than checking the width of the screen because xlib caches this info+    -- and it tends to be incorrect after RAndR+    screen <- safeGetWindowAttributes rootw >>= \case+        Nothing -> gets $ r2c . screenRect . W.screenDetail . W.current . windowset+        Just wa -> pure . r2c $ Rectangle (fi $ wa_x wa) (fi $ wa_y wa) (fi $ wa_width wa) (fi $ wa_height wa)     return $ \r -> c2r $ foldr (reduce screen) (r2c r) struts   where careAbout (s,_,_,_) = s `S.member` ss  -- | Adjust layout automagically: don't cover up any docks, status --   bars, etc.+--+--   Note that this modifier must be applied before any modifier that+--   changes the screen rectangle, or struts will be applied in the wrong+--   place and may affect the other modifier(s) in odd ways. This is+--   most commonly seen with the 'spacing' modifier and friends. avoidStruts :: LayoutClass l a => l a -> ModifiedLayout AvoidStruts l a avoidStruts = avoidStrutsOn [U,D,L,R]  -- | Adjust layout automagically: don't cover up docks, status bars,---   etc. on the indicated sides of the screen.  Valid sides are U---   (top), D (bottom), R (right), or L (left).+--   etc. on the indicated sides of the screen.  Valid sides are 'U'+--   (top), 'D' (bottom), 'R' (right), or 'L' (left). The warning in+--   'avoidStruts' applies to this modifier as well. avoidStrutsOn :: LayoutClass l a =>                  [Direction2D]               -> l a               -> ModifiedLayout AvoidStruts l a-avoidStrutsOn ss = ModifiedLayout $ AvoidStruts $ S.fromList ss+avoidStrutsOn ss = ModifiedLayout $ AvoidStruts (S.fromList ss) -data AvoidStruts a = AvoidStruts (S.Set Direction2D) deriving ( Read, Show )+newtype AvoidStruts a = AvoidStruts (S.Set Direction2D) deriving ( Read, Show )  -- | Message type which can be sent to an 'AvoidStruts' layout --   modifier to alter its behavior. data ToggleStruts = ToggleStruts                   | ToggleStrut Direction2D-  deriving (Read,Show,Typeable)+  deriving (Read,Show)  instance Message ToggleStruts @@ -201,27 +275,36 @@ data SetStruts = SetStruts { addedStruts   :: [Direction2D]                            , removedStruts :: [Direction2D] -- ^ These are removed from the currently set struts before 'addedStruts' are added.                            }-  deriving (Read,Show,Typeable)+  deriving (Read,Show)  instance Message SetStruts  instance LayoutModifier AvoidStruts a where     modifyLayout (AvoidStruts ss) w r = do-        nr <- fmap ($ r) (calcGap ss)-        runLayout w nr+        srect <- fmap ($ r) (calcGap ss)+        -- Ensure _NET_WORKAREA is not set.+        -- See: https://github.com/xmonad/xmonad-contrib/pull/79+        rmWorkarea+        runLayout w srect -    pureMess (AvoidStruts ss) m+    pureMess as@(AvoidStruts ss) m         | Just ToggleStruts    <- fromMessage m = Just $ AvoidStruts (toggleAll ss)         | Just (ToggleStrut s) <- fromMessage m = Just $ AvoidStruts (toggleOne s ss)         | Just (SetStruts n k) <- fromMessage m         , let newSS = S.fromList n `S.union` (ss S.\\ S.fromList k)         , newSS /= ss = Just $ AvoidStruts newSS+        | Just UpdateDocks <- fromMessage m = Just as         | otherwise = Nothing       where toggleAll x | S.null x = S.fromList [minBound .. maxBound]                         | otherwise = S.empty             toggleOne x xs | x `S.member` xs = S.delete x xs                            | otherwise   = x `S.insert` xs +rmWorkarea :: X ()+rmWorkarea = withDisplay $ \dpy -> do+    a <- getAtom "_NET_WORKAREA"+    r <- asks theRoot+    io (deleteProperty dpy r a)  -- | (Direction, height\/width, initial pixel, final pixel). @@ -264,9 +347,5 @@ -- Precondition for every input range @(x, y)@: @x '<=' y@. -- -- A range @(x, y)@ is assumed to include every pixel from @x@ to @y@.- overlaps :: Ord a => (a, a) -> (a, a) -> Bool-(a, b) `overlaps` (x, y) =-  inRange (a, b) x || inRange (a, b) y || inRange (x, y) a-  where-  inRange (i, j) k = i <= k && k <= j+(a, b) `overlaps` (x, y) = not (b < x || y < a) -- not disjoint
XMonad/Hooks/ManageHelpers.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Hooks.ManageHelpers+-- Description  : Helper functions to be used in manageHook. -- Copyright    : (c) Lukas Mai -- License      : BSD --@@ -13,7 +15,7 @@ -- -- > import XMonad.Hooks.ManageHelpers -- > main =--- >     xmonad defaultConfig{+-- >     xmonad def{ -- >         ... -- >         manageHook = composeOne [ -- >             isKDETrayWindow -?> doIgnore,@@ -23,22 +25,44 @@ -- >         ], -- >         ... -- >     }+--+-- Here's how you can define more helpers like the ones from this module:+--+-- > -- some function you want to transform into an infix operator+-- > f :: a -> b -> Bool+-- >+-- > -- a new helper+-- > q ***? x = fmap (\a -> f a x) q   -- or: (\b -> f x b)+-- > -- or+-- > q ***? x = fmap (`f` x) q         -- or: (x `f`)+--+-- Any existing operator can be "lifted" in the same way:+--+-- > q ++? x = fmap (++ x) q  module XMonad.Hooks.ManageHelpers (     Side(..),     composeOne,-    (-?>), (/=?), (<==?), (</=?), (-->>), (-?>>),+    (-?>), (/=?), (^?), (~?), ($?), (<==?), (</=?), (-->>), (-?>>),     currentWs,+    windowTag,     isInProperty,     isKDETrayWindow,     isFullscreen,+    isMinimized,     isDialog,+    isNotification,     pid,+    desktop,     transientTo,     maybeToDefinite,     MaybeManageHook,     transience,     transience',+    clientLeader,+    sameBy,+    shiftToSame,+    shiftToSame',     doRectFloat,     doFullFloat,     doCenterFloat,@@ -46,16 +70,18 @@     doFloatAt,     doFloatDep,     doHideIgnore,+    doSink,+    doLower,+    doRaise,+    doFocus,     Match, ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W import XMonad.Util.WindowProperties (getProp32s) -import Data.Maybe-import Data.Monoid- import System.Posix (ProcessID)  -- | Denotes a side of a screen. @S@ stands for South, @NE@ for Northeast@@ -73,29 +99,39 @@ -- | An alternative 'ManageHook' composer. Unlike 'composeAll' it stops as soon as -- a candidate returns a 'Just' value, effectively running only the first match -- (whereas 'composeAll' continues and executes all matching rules).-composeOne :: [MaybeManageHook] -> ManageHook-composeOne = foldr try idHook+composeOne :: (Monoid a, Monad m) => [m (Maybe a)] -> m a+composeOne = foldr try (return mempty)     where     try q z = do         x <- q-        case x of-            Just h -> return h-            Nothing -> z+        maybe z return x  infixr 0 -?>, -->>, -?>>  -- | q \/=? x. if the result of q equals x, return False-(/=?) :: Eq a => Query a -> a -> Query Bool+(/=?) :: (Eq a, Functor m) => m a -> a -> m Bool q /=? x = fmap (/= x) q +-- | q ^? x. if the result of @x `isPrefixOf` q@, return True+(^?) :: (Eq a, Functor m) => m [a] -> [a] -> m Bool+q ^? x = fmap (x `isPrefixOf`) q++-- | q ~? x. if the result of @x `isInfixOf` q@, return True+(~?) :: (Eq a, Functor m) => m [a] -> [a] -> m Bool+q ~? x = fmap (x `isInfixOf`) q++-- | q $? x. if the result of @x `isSuffixOf` q@, return True+($?) :: (Eq a, Functor m) => m [a] -> [a] -> m Bool+q $? x = fmap (x `isSuffixOf`) q+ -- | q <==? x. if the result of q equals x, return True grouped with q-(<==?) :: Eq a => Query a -> a -> Query (Match a)+(<==?) :: (Eq a, Functor m) => m a -> a -> m (Match a) q <==? x = fmap (`eq` x) q     where     eq q' x' = Match (q' == x') q'  -- | q <\/=? x. if the result of q notequals x, return True grouped with q-(</=?) :: Eq a => Query a -> a -> Query (Match a)+(</=?) :: (Eq a, Functor m) => m a -> a -> m (Match a) q </=? x = fmap (`neq` x) q     where     neq q' x' = Match (q' /= x') q'@@ -103,19 +139,19 @@ -- | A helper operator for use in 'composeOne'. It takes a condition and an action; -- if the condition fails, it returns 'Nothing' from the 'Query' so 'composeOne' will -- go on and try the next rule.-(-?>) :: Query Bool -> ManageHook -> MaybeManageHook+(-?>) :: (Functor m, Monad m) => m Bool -> m a -> m (Maybe a) p -?> f = do     x <- p     if x then fmap Just f else return Nothing  -- | A helper operator for use in 'composeAll'. It takes a condition and a function taking a grouped datum to action.  If 'p' is true, it executes the resulting action.-(-->>) :: Query (Match a) -> (a -> ManageHook) -> ManageHook+(-->>) :: (Monoid b, Monad m) => m (Match a) -> (a -> m b) -> m b p -->> f = do     Match b m <- p-    if b then (f m) else mempty+    if b then f m else return mempty  -- | A helper operator for use in 'composeOne'.  It takes a condition and a function taking a groupdatum to action.  If 'p' is true, it executes the resulting action.  If it fails, it returns 'Nothing' from the 'Query' so 'composeOne' will go on and try the next rule.-(-?>>) :: Query (Match a) -> (a -> ManageHook) -> MaybeManageHook+(-?>>) :: (Functor m, Monad m) => m (Match a) -> (a -> m b) -> m (Maybe b) p -?>> f = do     Match b m <- p     if b then fmap  Just (f m) else return Nothing@@ -124,6 +160,10 @@ currentWs :: Query WorkspaceId currentWs = liftX (withWindowSet $ return . W.currentTag) +-- | Return the workspace tag of a window, if already managed+windowTag :: Query (Maybe WorkspaceId)+windowTag = ask >>= \w -> liftX $ withWindowSet $ return . W.findTag w+ -- | A predicate to check whether a window is a KDE system tray icon. isKDETrayWindow :: Query Bool isKDETrayWindow = ask >>= \w -> liftX $ do@@ -146,17 +186,42 @@ isFullscreen :: Query Bool isFullscreen = isInProperty "_NET_WM_STATE" "_NET_WM_STATE_FULLSCREEN" +-- | A predicate to check whether a window is hidden (minimized).+-- See also "XMonad.Actions.Minimize".+isMinimized :: Query Bool+isMinimized = isInProperty "_NET_WM_STATE" "_NET_WM_STATE_HIDDEN"+ -- | A predicate to check whether a window is a dialog.+--+-- See <https://specifications.freedesktop.org/wm-spec/wm-spec-1.5.html#idm46485863906176>. isDialog :: Query Bool isDialog = isInProperty "_NET_WM_WINDOW_TYPE" "_NET_WM_WINDOW_TYPE_DIALOG" +-- | A predicate to check whether a window is a notification.+--+-- See <https://specifications.freedesktop.org/wm-spec/wm-spec-1.5.html#idm46485863906176>.+isNotification :: Query Bool+isNotification =+  isInProperty "_NET_WM_WINDOW_TYPE" "_NET_WM_WINDOW_TYPE_NOTIFICATION"++-- | This function returns 'Just' the @_NET_WM_PID@ property for a+-- particular window if set, 'Nothing' otherwise.+--+-- See <https://specifications.freedesktop.org/wm-spec/wm-spec-1.5.html#idm45623487788432>. pid :: Query (Maybe ProcessID)-pid = ask >>= \w -> liftX $ do-    p <- getProp32s "_NET_WM_PID" w-    return $ case p of-        Just [x] -> Just (fromIntegral x)-        _        -> Nothing+pid = ask >>= \w -> liftX $ getProp32s "_NET_WM_PID" w <&> \case+    Just [x] -> Just (fromIntegral x)+    _        -> Nothing +-- | This function returns 'Just' the @_NET_WM_DESKTOP@ property for a+-- particular window if set, 'Nothing' otherwise.+--+-- See <https://specifications.freedesktop.org/wm-spec/wm-spec-1.5.html#idm46181547492704>.+desktop :: Query (Maybe Int)+desktop = ask >>= \w -> liftX $ getProp32s "_NET_WM_DESKTOP" w <&> \case+    Just [x] -> Just (fromIntegral x)+    _        -> Nothing+ -- | A predicate to check whether a window is Transient. -- It holds the result which might be the window it is transient to -- or it might be 'Nothing'.@@ -169,19 +234,50 @@ -- | A convenience 'MaybeManageHook' that will check to see if a window -- is transient, and then move it to its parent. transience :: MaybeManageHook-transience = transientTo </=? Nothing -?>> move-    where-    move mw = maybe idHook (doF . move') mw-    move' w s = maybe s (`W.shift` s) (W.findTag w s)+transience = transientTo </=? Nothing -?>> maybe idHook doShiftTo  -- | 'transience' set to a 'ManageHook' transience' :: ManageHook transience' = maybeToDefinite transience +-- | This function returns 'Just' the @WM_CLIENT_LEADER@ property for a+-- particular window if set, 'Nothing' otherwise. Note that, generally,+-- the window ID returned from this property (by firefox, for example)+-- corresponds to an unmapped or unmanaged dummy window. For this to be+-- useful in most cases, it should be used together with 'sameBy'.+--+-- See <https://tronche.com/gui/x/icccm/sec-5.html>.+clientLeader :: Query (Maybe Window)+clientLeader = ask >>= \w -> liftX $ getProp32s "WM_CLIENT_LEADER" w <&> \case+    Just [x] -> Just (fromIntegral x)+    _        -> Nothing++-- | For a given window, 'sameBy' returns all windows that have a matching+-- property (e.g. those obtained from Queries of 'clientLeader' and 'pid').+sameBy :: Eq prop => Query (Maybe prop) -> Query [Window]+sameBy prop = prop >>= \case+    Nothing -> pure []+    propVal -> ask >>= \w -> liftX . withWindowSet $ \s ->+        filterM (fmap (propVal ==) . runQuery prop) (W.allWindows s \\ [w])++-- | 'MaybeManageHook' that moves the window to the same workspace as the+-- first other window that has the same value of a given 'Query'. Useful+-- Queries for this include 'clientLeader' and 'pid'.+shiftToSame :: Eq prop => Query (Maybe prop) -> MaybeManageHook+shiftToSame prop = sameBy prop </=? [] -?>> maybe idHook doShiftTo . listToMaybe++-- | 'shiftToSame' set to a 'ManageHook'+shiftToSame' :: Eq prop => Query (Maybe prop) -> ManageHook+shiftToSame' = maybeToDefinite . shiftToSame+ -- | converts 'MaybeManageHook's to 'ManageHook's-maybeToDefinite :: MaybeManageHook -> ManageHook+maybeToDefinite :: (Monoid a, Functor m) => m (Maybe a) -> m a maybeToDefinite = fmap (fromMaybe mempty) +-- | Move the window to the same workspace as another window.+doShiftTo :: Window -> ManageHook+doShiftTo target = doF . shiftTo =<< ask+  where shiftTo w s = maybe s (\t -> W.shiftWin t w s) (W.findTag target s)  -- | Floats the new window in the given rectangle. doRectFloat :: W.RationalRect  -- ^ The rectangle to float the window in. 0 to 1; x, y, w, h.@@ -212,12 +308,14 @@ doSideFloat side = doFloatDep move   where     move (W.RationalRect _ _ w h) = W.RationalRect cx cy w h-      where cx =      if side `elem` [SC,C ,NC] then (1-w)/2-                 else if side `elem` [SW,CW,NW] then 0-                 else {- side `elem` [SE,CE,NE] -}   1-w-            cy =      if side `elem` [CE,C ,CW] then (1-h)/2-                 else if side `elem` [NE,NC,NW] then 0-                 else {- side `elem` [SE,SC,SW] -}   1-h+      where cx+              | side `elem` [SC,C ,NC] = (1-w)/2+              | side `elem` [SW,CW,NW] = 0+              | otherwise = {- side `elem` [SE,CE,NE] -} 1-w+            cy+              | side `elem` [CE,C ,CW] = (1-h)/2+              | side `elem` [NE,NC,NW] = 0+              | otherwise = {- side `elem` [SE,SC,SW] -} 1-h  -- | Floats a new window with its original size, but centered. doCenterFloat :: ManageHook@@ -226,3 +324,21 @@ -- | Hides window and ignores it. doHideIgnore :: ManageHook doHideIgnore = ask >>= \w -> liftX (hide w) >> doF (W.delete w)++-- | Sinks a window+doSink :: ManageHook+doSink = doF . W.sink =<< ask++-- | Lower an unmanaged window. Useful together with 'doIgnore' to lower+-- special windows that for some reason don't do it themselves.+doLower :: ManageHook+doLower = ask >>= \w -> liftX $ withDisplay $ \dpy -> io (lowerWindow dpy w) >> mempty++-- | Raise an unmanaged window. Useful together with 'doIgnore' to raise+-- special windows that for some reason don't do it themselves.+doRaise :: ManageHook+doRaise = ask >>= \w -> liftX $ withDisplay $ \dpy -> io (raiseWindow dpy w) >> mempty++-- | Focus a window (useful in 'XMonad.Hooks.EwmhDesktops.setActivateHook').+doFocus :: ManageHook+doFocus = doF . W.focusWindow =<< ask
XMonad/Hooks/Minimize.hs view
@@ -1,6 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.Minimize+-- Description :  Handle window manager hints to minimize and restore windows. -- Copyright   :  (c) Justin Bogner 2010 -- License     :  BSD3-style (see LICENSE) --@@ -9,7 +10,7 @@ -- Portability :  not portable -- -- Handles window manager hints to minimize and restore windows. Use--- this with XMonad.Layout.Minimize.+-- this with "XMonad.Layout.Minimize". -- ----------------------------------------------------------------------------- @@ -19,35 +20,35 @@       minimizeEventHook     ) where -import Data.Monoid-import Control.Monad(when)- import XMonad-import XMonad.Layout.Minimize+import XMonad.Actions.Minimize+import XMonad.Prelude  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.Minimize -- > import XMonad.Layout.Minimize -- > -- > myHandleEventHook = minimizeEventHook -- > myLayout = minimize (Tall 1 (3/100) (1/2)) ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout--- >                             , handleEventHook = myHandleEventHook }+-- > main = xmonad def { layoutHook = myLayout+-- >                   , handleEventHook = myHandleEventHook }  minimizeEventHook :: Event -> X All-minimizeEventHook (ClientMessageEvent {ev_window = w,-                                       ev_message_type = mt,-                                       ev_data = dt}) = do+minimizeEventHook ClientMessageEvent{ev_window = w,+                                     ev_message_type = mt,+                                     ev_data = dt} = do     a_aw <- getAtom "_NET_ACTIVE_WINDOW"     a_cs <- getAtom "WM_CHANGE_STATE" -    when (mt == a_aw) $ sendMessage (RestoreMinimizedWin w)-    when (mt == a_cs) $ do-      let message = fromIntegral . head $ dt-      when (message == normalState) $ sendMessage (RestoreMinimizedWin w)-      when (message == iconicState) $ minimizeWindow w+    when (mt == a_aw) $ maximizeWindow w+    when (mt == a_cs) $ case listToMaybe dt of+      Nothing  -> pure ()+      Just dth -> do+        let message = fromIntegral dth+        when (message == normalState) $ maximizeWindow w+        when (message == iconicState) $ minimizeWindow w      return (All True) minimizeEventHook _ = return (All True)
+ XMonad/Hooks/Modal.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.Modal+-- Description :  Implements true modality in xmonad key-bindings.+-- Copyright   :  (c) 2018  L. S. Leary+-- License     :  BSD3-style (see LICENSE)+--+-- Author      :  L. S. Leary+-- Maintainer  :  Yecine Megdiche <yecine.megdiche@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module implements modal keybindings for xmonad.+--+--------------------------------------------------------------------------------++-- --< Imports & Exports >-- {{{+module XMonad.Hooks.Modal+  (+ -- * Usage+ -- $Usage+    modal+  , modeWithExit+  , mode+  , Mode+  , mkKeysEz+  , setMode+  , exitMode+ -- * Provided Modes #ProvidedModes#+ -- $ProvidedModes+  , noModModeLabel+  , noModMode+  , floatModeLabel+  , floatMode+  , overlayedFloatModeLabel+  , overlayedFloatMode+  , floatMap+  , overlay+ -- * Logger+  , logMode+  ) where++-- core+import           XMonad+-- base+import           Data.Bits                     ( (.&.)+                                               , complement+                                               )+import           Data.List+import qualified Data.Map.Strict               as M+-- contrib+import           XMonad.Actions.FloatKeys      ( keysMoveWindow+                                               , keysResizeWindow+                                               )+import           XMonad.Prelude+import           XMonad.Util.EZConfig          ( parseKeyCombo+                                               , mkKeymap+                                               )+import qualified XMonad.Util.ExtensibleConf    as XC+import qualified XMonad.Util.ExtensibleState   as XS+import           XMonad.Util.Grab+import           XMonad.Util.Loggers+import           XMonad.Util.Parser            ( runParser )++-- }}}++-- Original Draft By L.S.Leary : https://gist.github.com/LSLeary/6741b0572d62db3f0cea8e6618141b2f++-- --< Usage >-- {{{++-- $Usage+--+-- This module provides modal keybindings in xmonad. If you're not familiar with+-- modal keybindings from Vim, you can think of modes as submaps from+-- "XMonad.Actions.Submap", but after each action you execute, you land back in+-- the submap until you explicitly exit the submap. To use this module you+-- should apply the 'modal' function to the config, which will setup the list of+-- modes (or rather, @XConfig Layout -> Mode@) you provide:+--+-- >+-- > import XMonad+-- > import XMonad.Hooks.Modal+-- > import XMonad.Util.EZConfig+-- > import qualified Data.Map as M+-- >+-- > main :: IO ()+-- > main =+-- >   xmonad+-- >     . modal [noModMode, floatMode 10, overlayedFloatMode 10, sayHelloMode]+-- >     $ def+-- >     `additionalKeysP` [ ("M-S-n", setMode noModModeLabel)+-- >                       , ("M-S-r", setMode floatModeLabel)+-- >                       , ("M-S-z", setMode overlayedFloatModeLabel)+-- >                       , ("M-S-h", setMode "Hello")+-- >                       ]+-- >+-- > sayHelloMode :: Mode+-- > sayHelloMode = mode "Hello" $ mkKeysEz+-- >   [ ("h", xmessage "Hello, World!")+-- >   , ("M-g", xmessage "Goodbye, World!")+-- >   ]+--+-- Alternatively, one could have defined @sayHelloMode@ as+--+-- > sayHelloMode :: Mode+-- > sayHelloMode = mode "Hello" $ \cfg ->+-- >   M.fromList [ ((noModMask, xK_h), xmessage "Hello, World!")+-- >              , ((modMask cfg, xK_g), xmessage "Goodbye, World!")+-- >              ]+--+-- In short, a 'Mode' has a label describing its purpose, as well as+-- attached keybindings. These are of the form+--+--   - @[(String, X ())]@, or+--+--   - @XConfig Layout -> M.Map (ButtonMask, KeySym) (X ())@.+--+-- The former—accessible via 'mkKeysEz'—is how specifying keys work with+-- "XMonad.Util.EZConfig", while the latter is more geared towards how+-- defining keys works by default in xmonad. Note that, by default,+-- modes are exited with the Escape key. If one wishes to customise+-- this, the 'modeWithExit' function should be used instead of 'mode'+-- when defining a new mode.+--+-- The label of the active mode can be logged with 'logMode' to be+-- displayed in a status bar, for example (For more information check+-- "XMonad.Util.Loggers"). Some examples are included in [the provided+-- modes](#g:ProvidedModes).++-- }}}++-- --< Types >-- {{{++-- | From a list of "XMonad.Util.EZConfig"-style bindings, generate a+-- key representation.+--+-- >>> mkKeysEz [("h", xmessage "Hello, world!")]+mkKeysEz :: [(String, X ())] -> (XConfig Layout -> M.Map (ButtonMask, KeySym) (X ()))+mkKeysEz = flip mkKeymap++-- | The mode type. Use 'mode' or 'modeWithExit' to create modes.+data Mode = Mode+  { label     :: !String+  , boundKeys :: !(XConfig Layout -> M.Map (ButtonMask, KeySym) (X ()))+  }++-- | Newtype for the extensible config.+newtype ModeConfig = MC [Mode] deriving Semigroup++-- | Newtype for the extensible state.+newtype CurrentMode = CurrentMode+  { currentMode :: Maybe Mode+  }++instance ExtensionClass CurrentMode where+  initialValue = CurrentMode Nothing++-- }}}++-- --< Private >-- {{{++-- | The active keybindings corresponding to the active 'Mode' (or lack+-- thereof).+currentKeys :: X (M.Map (ButtonMask, KeySym) (X ()))+currentKeys = do+  cnf <- asks config+  XS.gets currentMode >>= \case+    Just m  -> pure (boundKeys m cnf)+    Nothing -> join keys <$> asks config++-- | Grab the keys corresponding to the active 'Mode' (or lack thereof).+regrab :: X ()+regrab = grab . M.keys =<< currentKeys++-- | Called after changing the mode. Grabs the correct keys and runs the+-- 'logHook'.+refreshMode :: X ()+refreshMode = regrab >> asks config >>= logHook++-- | Event hook to control the keybindings.+modalEventHook :: Event -> X All+modalEventHook = customRegrabEvHook regrab <> \case+  KeyEvent { ev_event_type = t, ev_state = m, ev_keycode = code }+    | t == keyPress -> withDisplay $ \dpy -> do+      kp  <- (,) <$> cleanMask m <*> io (keycodeToKeysym dpy code 0)+      kbs <- currentKeys+      userCodeDef () (whenJust (M.lookup kp kbs) id)+      pure (All False)+  _ -> pure (All True)++-- }}}++-- --< Public >-- {{{++-- | Adds the provided modes to the user's config, and sets up the bells+-- and whistles needed for them to work.+modal :: [Mode] -> XConfig l -> XConfig l+modal modes = XC.once+  (\cnf -> cnf { startupHook     = startupHook cnf <> initModes+               , handleEventHook = handleEventHook cnf <> modalEventHook+               }+  )+  (MC modes)+  where initModes = XS.put (CurrentMode Nothing) >> refreshMode++-- | Create a 'Mode' from the given binding to 'exitMode', label and+-- keybindings.+modeWithExit :: String -> String -> (XConfig Layout -> M.Map (KeyMask, KeySym) (X ())) -> Mode+modeWithExit exitKey mlabel keys = Mode mlabel $ \cnf ->+  let exit = fromMaybe (0, xK_Escape) $ runParser (parseKeyCombo cnf) exitKey+   in M.insert exit exitMode (keys cnf)++-- | Create a 'Mode' from the given label and keybindings. Sets the+-- @escape@ key to 'exitMode'.+mode :: String -> (XConfig Layout -> M.Map (KeyMask, KeySym) (X ())) -> Mode+mode = modeWithExit "<Escape>"++-- | Set the current 'Mode' based on its label.+setMode :: String -> X ()+setMode l = do+  XC.with $ \(MC ls) -> case find ((== l) . label) ls of+    Nothing -> mempty+    Just m  -> do+      XS.modify $ \cm -> cm { currentMode = Just m }+      refreshMode++-- | Exits the current mode.+exitMode :: X ()+exitMode = do+  XS.modify $ \m -> m { currentMode = Nothing }+  refreshMode++-- | A 'Logger' to display the current mode.+logMode :: Logger+logMode = fmap label <$> XS.gets currentMode++-- Provided modes+noModModeLabel, floatModeLabel, overlayedFloatModeLabel :: String+noModModeLabel = "NoMod"+floatModeLabel = "Float"+overlayedFloatModeLabel = "Overlayed Float"++-- | In this 'Mode', all keybindings are available without the need for pressing+-- the modifier. Pressing @escape@ exits the mode.+noModMode :: Mode+noModMode =+  mode noModModeLabel $ \cnf -> stripModifier (modMask cnf) (keys cnf cnf)++-- | Generates the keybindings for 'floatMode' and 'overlayedFloatMode'.+floatMap+  :: KeyMask -- ^ Move mask+  -> KeyMask -- ^ Enlarge mask+  -> KeyMask -- ^ Shrink mask+  -> Int -- ^ Step size+  -> M.Map (ButtonMask, KeySym) (X ())+floatMap move enlarge shrink s = M.fromList+  [ -- move+    ((move, xK_h)          , withFocused (keysMoveWindow (-s, 0)))+  , ((move, xK_j)          , withFocused (keysMoveWindow (0, s)))+  , ((move, xK_k)          , withFocused (keysMoveWindow (0, -s)))+  , ((move, xK_l)          , withFocused (keysMoveWindow (s, 0)))+  -- enlarge+  , ((enlarge, xK_h), withFocused (keysResizeWindow (s, 0) (1, 0)))+  , ((enlarge, xK_j), withFocused (keysResizeWindow (0, s) (0, 0)))+  , ((enlarge, xK_k), withFocused (keysResizeWindow (0, s) (0, 1)))+  , ((enlarge, xK_l), withFocused (keysResizeWindow (s, 0) (0, 0)))+  -- shrink+  , ((shrink, xK_h), withFocused (keysResizeWindow (-s, 0) (0, 0)))+  , ((shrink, xK_j), withFocused (keysResizeWindow (0, -s) (0, 1)))+  , ((shrink, xK_k), withFocused (keysResizeWindow (0, -s) (0, 0)))+  , ((shrink, xK_l), withFocused (keysResizeWindow (-s, 0) (1, 0)))+  , ((noModMask, xK_Escape), exitMode)+  ]++-- | A mode to control floating windows with @{hijk}@, @M-{hijk}@ and+-- @M-S-{hijk}@ in order to respectively move, enlarge and+-- shrink windows.+floatMode+  :: Int -- ^ Step size+  -> Mode+floatMode i = mode floatModeLabel $ \XConfig { modMask } ->+  floatMap noModMask modMask (modMask .|. shiftMask) i++-- | Similar to 'resizeMode', but keeps the bindings of the original+-- config active.+overlayedFloatMode+  :: Int -- ^ Step size+  -> Mode+overlayedFloatMode = overlay overlayedFloatModeLabel . floatMode++-- | Modifies a mode so that the keybindings are merged with those from+-- the config instead of replacing them.+overlay+  :: String  -- ^ Label for the new mode+  -> Mode -- ^ Base mode+  -> Mode+overlay label m = Mode label $ \cnf -> boundKeys m cnf <> keys cnf cnf++-- | Strips the modifier key from the provided keybindings.+stripModifier+  :: ButtonMask -- ^ Modifier to remove+  -> M.Map (ButtonMask, KeySym) (X ()) -- ^ Original keybinding map+  -> M.Map (ButtonMask, KeySym) (X ())+stripModifier mask = M.mapKeys $ \(m, k) -> (m .&. complement mask, k)++-- }}}
+ XMonad/Hooks/OnPropertyChange.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.OnPropertyChange+-- Description :  Apply a manageHook on a property (e.g., @WM_CLASS@) change+-- Copyright   :  (c) Brandon S Allbery, 2015+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  allbery.b@gmail.com+-- Stability   :  unstable+-- Portability :  not portable+--+-- Module to apply a ManageHook to an already-mapped window when a property+-- changes. This would commonly be used to match browser windows by title,+-- since the final title will only be set after (a) the window is mapped,+-- (b) its document has been loaded, (c) all load-time scripts have run.+-- (Don't blame browsers for this; it's inherent in HTML and the DOM. And+-- changing title dynamically is explicitly permitted by ICCCM and EWMH;+-- you don't really want to have your editor window umapped/remapped to+-- show the current document and modified state in the titlebar, do you?)+--+-- This is a handleEventHook that triggers on a PropertyChange event. It+-- currently ignores properties being removed, in part because you can't+-- do anything useful in a ManageHook involving nonexistence of a property.+--+-- This module could also be useful for Electron applications like Spotify+-- which sets its WM_CLASS too late for window manager to map it properly.+--+-----------------------------------------------------------------------------++module XMonad.Hooks.OnPropertyChange (+  -- * Usage+  -- $usage+  onXPropertyChange,+  onTitleChange,+  onClassChange,+) where++import XMonad+import XMonad.Prelude++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Hooks.OnPropertyChange+--+-- Enable it by including in you handleEventHook definition:+--+-- >  main = xmonad $ def+-- >      { ...+-- >      , handleEventHook = onXPropertyChange "WM_NAME" (title =? "Spotify" --> doShift "5")+-- >      , ...+-- >      }+--+-- Or you could create a dynamicManageHook as below:+--+-- > myDynamicManageHook :: ManageHook+-- > myDynamicManageHook =+-- >  composeAll+-- >    [ className =? "Spotify" --> doShift (myWorkspaces !! 4),+-- >      title =? "maybe_special_terminal" <||> title =? "special_terminal" --> doCenterFloat,+-- >      className =? "dynamicApp" <&&> title =? "dynamic_app" --> doCenterFloat+-- >    ]+--+-- And then use it in your handleEventHookDefinition:+--+-- >  main = xmonad $ def+-- >      { ...+-- >      , handleEventHook = onXPropertyChange "WM_NAME" myDynamicManageHook+-- >      , ...+-- >      }+--++-- |+-- Run a 'ManageHook' when a specific property is changed on a window. Note+-- that this will run on any window which changes the property, so you should+-- be very specific in your 'ManageHook' matching (lots of windows change+-- their titles on the fly!):+--+-- > onXPropertyChange "WM_NAME" (className =? "Iceweasel" <&&> title =? "whatever" --> doShift "2")+--+-- Note that the fixity of (-->) won't allow it to be mixed with ($), so you+-- can't use the obvious $ shorthand.+--+-- > onXPropertyChange "WM_NAME" $ title =? "Foo" --> doFloat -- won't work!+--+-- Consider instead phrasing it like any+-- other 'ManageHook':+--+-- >  main = xmonad $ def+-- >      { ...+-- >      , handleEventHook = onXPropertyChange "WM_NAME" myDynHook+-- >      , ...+-- >      }+-- >+-- >    myDynHook = composeAll [...]+--+onXPropertyChange :: String -> ManageHook -> Event -> X All+onXPropertyChange prop hook PropertyEvent { ev_window = w, ev_atom = a, ev_propstate = ps } = do+  pa <- getAtom prop+  when (ps == propertyNewValue && a == pa) $ do+    g <- appEndo <$> userCodeDef (Endo id) (runQuery hook w)+    windows g+  return mempty -- so anything else also processes it+onXPropertyChange _ _ _ = return mempty++-- | A shorthand for dynamic titles; i.e., applications changing their+-- @WM_NAME@ property.+onTitleChange :: ManageHook -> Event -> X All+-- strictly, this should also check _NET_WM_NAME. practically, both will+-- change and each gets its own PropertyEvent, so we'd need to record that+-- we saw the event for that window and ignore the second one. Instead, just+-- trust that nobody sets only _NET_WM_NAME. (I'm sure this will prove false,+-- since there's always someone who can't bother being compliant.)+onTitleChange = onXPropertyChange "WM_NAME"++-- | A shorthand for dynamic resource and class names; i.e.,+-- applications changing their @WM_CLASS@ property.+onClassChange :: ManageHook -> Event -> X All+onClassChange = onXPropertyChange "WM_CLASS"
XMonad/Hooks/Place.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.Place+-- Description :  Automatic placement of floating windows. -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -34,18 +36,14 @@   import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as S  import XMonad.Layout.WindowArranger import XMonad.Actions.FloatKeys-import XMonad.Util.XUtils  import qualified Data.Map as M import Data.Ratio ((%))-import Data.List (sortBy, minimumBy, partition)-import Data.Maybe (fromMaybe, catMaybes)-import Data.Monoid (Endo(..))-import Control.Monad (guard, join) import Control.Monad.Trans (lift)  -- $usage@@ -53,17 +51,17 @@ -- floating windows at appropriate positions on the screen, as well -- as an 'X' action to manually trigger repositioning. ----- You can use this module by including the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module by including the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.Place -- -- and adding 'placeHook' to your 'manageHook', for example: ----- > main = xmonad $ defaultConfig { manageHook = placeHook simpleSmart--- >                                              <+> manageHook defaultConfig }+-- > main = xmonad $ def { manageHook = placeHook simpleSmart+-- >                                    <> manageHook def } -- -- Note that 'placeHook' should be applied after most other hooks, especially hooks--- such as 'doFloat' and 'doShift'. Since hooks combined with '<+>' are applied from+-- such as 'doFloat' and 'doShift'. Since hooks combined with '<>' are applied from -- right to left, this means that 'placeHook' should be the /first/ hook in your chain. -- -- You can also define a key to manually trigger repositioning with 'placeFocused' by@@ -166,16 +164,16 @@                       -- use X.A.FloatKeys if the window is floating, send                      -- a WindowArranger message otherwise.-                   case elem window floats of-                     True -> keysMoveWindowTo (x', y') (0, 0) window-                     False -> sendMessage $ SetGeometry r'+                   if window `elem` floats+                     then keysMoveWindowTo (x', y') (0, 0) window+                     else sendMessage $ SetGeometry r'   -- | Hook to automatically place windows when they are created. placeHook :: Placement -> ManageHook placeHook p = do window <- ask                  r <- Query $ lift $ getWindowRectangle window-                 allRs <- Query $ lift $ getAllRectangles+                 allRs <- Query $ lift getAllRectangles                  pointer <- Query $ lift $ getPointer window                   return $ Endo $ \theWS -> fromMaybe theWS $@@ -188,21 +186,22 @@                         -- spawned. Each of them also needs an associated screen                         -- rectangle; for hidden workspaces, we use the current                         -- workspace's screen.-                      let infos = filter ((window `elem`) . stackContents . S.stack . fst)+                      let infos = find ((window `elem`) . stackContents . S.stack . fst)                                      $ [screenInfo $ S.current theWS]-                                        ++ (map screenInfo $ S.visible theWS)-                                        ++ zip (S.hidden theWS) (repeat currentRect)--                      guard(not $ null infos)+                                        ++ map screenInfo (S.visible theWS)+                                        ++ map (, currentRect) (S.hidden theWS) -                      let (workspace, screen) = head infos-                          rs = catMaybes $ map (flip M.lookup allRs)-                               $ organizeClients workspace window floats-                          r' = purePlaceWindow p screen rs pointer r-                          newRect = r2rr screen r'-                          newFloats = M.insert window newRect (S.floating theWS)+                      case infos of+                        Nothing   -> empty+                        Just info -> do+                          let (workspace, screen) = info+                              rs = mapMaybe (`M.lookup` allRs)+                                   $ organizeClients workspace window floats+                              r' = purePlaceWindow p screen rs pointer r+                              newRect = r2rr screen r'+                              newFloats = M.insert window newRect (S.floating theWS) -                      return $ theWS { S.floating = newFloats }+                          return $ theWS { S.floating = newFloats }   placeWindow :: Placement -> Window@@ -225,7 +224,7 @@                 -> Rectangle -- ^ The window to be placed                 -> Rectangle purePlaceWindow (Bounds (t,r,b,l) p') (Rectangle sx sy sw sh) rs p w-  = let s' = (Rectangle (sx + fi l) (sy + fi t) (sw - l - r) (sh - t - b))+  = let s' = Rectangle (sx + fi l) (sy + fi t) (sw - l - r) (sh - t - b)     in checkBounds s' $ purePlaceWindow p' s' rs p w  purePlaceWindow (Fixed ratios) s _ _ w = placeRatio ratios s w@@ -279,7 +278,7 @@ stackContents = maybe [] S.integrate  screenInfo :: S.Screen i l a sid ScreenDetail -> (S.Workspace i l a, Rectangle)-screenInfo (S.Screen { S.workspace = ws, S.screenDetail = (SD s)}) = (ws, s)+screenInfo S.Screen{ S.workspace = ws, S.screenDetail = (SD s)} = (ws, s)  getWindowRectangle :: Window -> X Rectangle getWindowRectangle window@@ -329,8 +328,7 @@ getNecessaryData window ws floats   = do r <- getWindowRectangle window -       rs <- return (organizeClients ws window floats)-             >>= mapM getWindowRectangle+       rs <- mapM getWindowRectangle (organizeClients ws window floats)         pointer <- getPointer window
XMonad/Hooks/PositionStoreHooks.hs view
@@ -1,6 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.PositionStoreHooks+-- Description :  Hooks for XMonad.Util.PositionStore. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -34,20 +35,17 @@     ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W import XMonad.Util.PositionStore import XMonad.Hooks.ManageDocks import XMonad.Layout.Decoration  import System.Random(randomRIO)-import Control.Applicative((<$>))-import Control.Monad(when)-import Data.Maybe-import Data.Monoid import qualified Data.Set as S  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.PositionStoreHooks --@@ -55,25 +53,24 @@ -- as 'positionStoreEventHook' to your event hooks. To be accurate -- about window sizes, the module needs to know if any decoration is in effect. -- This is specified with the first argument: Supply 'Nothing' for no decoration,--- otherwise use 'Just defaultTheme' or similar to inform the module about the+-- otherwise use 'Just def' or similar to inform the module about the -- decoration theme used. ----- > myManageHook = positionStoreManageHook Nothing <+> manageHook defaultConfig+-- > myManageHook = positionStoreManageHook Nothing <> manageHook def -- > myHandleEventHook = positionStoreEventHook -- >--- > main = xmonad defaultConfig { manageHook = myManageHook--- >                             , handleEventHook = myHandleEventHook--- >                             }+-- > main = xmonad def { manageHook = myManageHook+-- >                   , handleEventHook = myHandleEventHook+-- >                   } --  positionStoreManageHook :: Maybe Theme -> ManageHook positionStoreManageHook mDecoTheme = ask >>= liftX . positionStoreInit mDecoTheme >> idHook  positionStoreInit :: Maybe Theme -> Window -> X ()-positionStoreInit mDecoTheme w  = withDisplay $ \d -> do+positionStoreInit mDecoTheme w  = withDisplay $ \d -> withWindowAttributes d w $ \wa -> do         let decoH = maybe 0 decoHeight mDecoTheme   -- take decoration into account, which - in its current                                                     -- form - makes windows smaller to make room for it-        wa <- io $ getWindowAttributes d w         ws <- gets windowset         arbitraryOffsetX <- randomIntOffset         arbitraryOffsetY <- randomIntOffset@@ -88,19 +85,19 @@             else do                 sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa)                 let sr = screenRect . W.screenDetail $ sc-                sr' <- fmap ($ sr) (calcGap $ S.fromList [minBound .. maxBound])    -- take docks into account, accepting-                                                                                    -- a somewhat unfortunate inter-dependency-                                                                                    -- with 'XMonad.Hooks.ManageDocks'+                sr' <- fmap ($ sr) (calcGap $ S.fromList [minBound .. maxBound]) -- take docks into account, accepting+                                                                                       -- a somewhat unfortunate inter-dependency+                                                                                       -- with 'XMonad.Hooks.ManageDocks'                 modifyPosStore (\ps -> posStoreInsert ps w                                         (Rectangle (fi $ wa_x wa) (fi (wa_y wa) - fi decoH)                                             (fi $ wa_width wa) (decoH + fi (wa_height wa))) sr' )     where-        randomIntOffset :: X (Int)+        randomIntOffset :: X Int         randomIntOffset = io $ randomRIO (42, 242)  positionStoreEventHook :: Event -> X All-positionStoreEventHook (DestroyWindowEvent {ev_window = w, ev_event_type = et}) = do-    when (et == destroyNotify) $ do-        modifyPosStore (\ps -> posStoreRemove ps w)+positionStoreEventHook DestroyWindowEvent{ev_window = w, ev_event_type = et} = do+    when (et == destroyNotify) $+        modifyPosStore (`posStoreRemove` w)     return (All True) positionStoreEventHook _ = return (All True)
+ XMonad/Hooks/RefocusLast.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, MultiWayIf #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.RefocusLast+-- Description :  Hooks and actions to refocus the previous window.+-- Copyright   :  (c) 2018  L. S. Leary+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  L. S. Leary+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides hooks and actions that keep track of recently focused windows on a+-- per workspace basis and automatically refocus the last window on loss of the+-- current (if appropriate as determined by user specified criteria).+--------------------------------------------------------------------------------++-- --< Imports & Exports >-- {{{++module XMonad.Hooks.RefocusLast (+  -- * Usage+  -- $Usage+  -- * Hooks+  refocusLastLogHook,+  refocusLastLayoutHook,+  refocusLastWhen,+  -- ** Predicates+  -- $Predicates+  refocusingIsActive,+  isFloat,+  -- * Actions+  toggleRefocusing,+  toggleFocus,+  swapWithLast,+  refocusWhen,+  shiftRLWhen,+  updateRecentsOn,+  -- * Types+  -- $Types+  RecentWins(..),+  RecentsMap(..),+  RefocusLastLayoutHook(..),+  RefocusLastToggle(..),+  -- * Library functions+  withRecentsIn,+) where++import XMonad+import XMonad.Prelude (All (..), asum, fromMaybe, when)+import qualified XMonad.StackSet as W+import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Util.Stack (findS, mapZ_)+import XMonad.Layout.LayoutModifier++import qualified Data.Map.Strict as M++-- }}}++-- --< Usage >-- {{{++-- $Usage+-- To use this module, you must either include 'refocusLastLogHook' in your log+-- hook __or__ 'refocusLastLayoutHook' in your layout hook; don't use both.+-- This suffices to make use of both 'toggleFocus' and 'shiftRLWhen' but will+-- not refocus automatically upon loss of the current window; for that you must+-- include in your event hook @'refocusLastWhen' pred@ for some valid @pred@.+--+-- The event hooks that trigger refocusing only fire when a window is lost+-- completely, not when it's simply e.g. moved to another workspace. Hence you+-- will need to use @'shiftRLWhen' pred@ or @'refocusWhen' pred@ as appropriate+-- if you want the same behaviour in such cases.+--+-- Example configuration:+--+-- > import XMonad+-- > import XMonad.Hooks.RefocusLast+-- > import qualified Data.Map.Strict as M+-- >+-- > main :: IO ()+-- > main = xmonad def+-- >     { handleEventHook = refocusLastWhen myPred <> handleEventHook def+-- >     , logHook         = refocusLastLogHook     <> logHook         def+-- > --  , layoutHook      = refocusLastLayoutHook   $  layoutHook      def+-- >     , keys            = refocusLastKeys        <> keys            def+-- >     } where+-- >         myPred = refocusingIsActive <||> isFloat+-- >         refocusLastKeys cnf+-- >           = M.fromList+-- >           $ ((modMask cnf              , xK_a), toggleFocus)+-- >           : ((modMask cnf .|. shiftMask, xK_a), swapWithLast)+-- >           : ((modMask cnf              , xK_b), toggleRefocusing)+-- >           : [ ( (modMask cnf .|. shiftMask, n)+-- >               , windows =<< shiftRLWhen myPred wksp+-- >               )+-- >             | (n, wksp) <- zip [xK_1..xK_9] (workspaces cnf)+-- >             ]+--++-- }}}++-- --< Types >-- {{{++-- $Types+-- The types and constructors used in this module are exported principally to+-- aid extensibility; typical users will have nothing to gain from this section.++-- | Data type holding onto the previous and current @Window@.+data RecentWins = Recent { previous :: !Window, current :: !Window }+  deriving (Show, Read, Eq)++-- | Newtype wrapper for a @Map@ holding the @RecentWins@ for each workspace.+--   Is an instance of @ExtensionClass@ with persistence of state.+newtype RecentsMap = RecentsMap (M.Map WorkspaceId RecentWins)+  deriving (Show, Read, Eq)++instance ExtensionClass RecentsMap where+  initialValue = RecentsMap M.empty+  extensionType = PersistentExtension++-- | A 'LayoutModifier' that updates the 'RecentWins' for a workspace upon+--   relayout.+data RefocusLastLayoutHook a = RefocusLastLayoutHook+  deriving (Show, Read)++instance LayoutModifier RefocusLastLayoutHook a where+  modifyLayout _ w@(W.Workspace tg _ _) r = updateRecentsOn tg >> runLayout w r++-- | A newtype on @Bool@ to act as a universal toggle for refocusing.+newtype RefocusLastToggle = RefocusLastToggle { refocusing :: Bool }+  deriving (Show, Read, Eq)++instance ExtensionClass RefocusLastToggle where+  initialValue  = RefocusLastToggle { refocusing = True }+  extensionType = PersistentExtension++-- }}}++-- --< Public Hooks >-- {{{++-- | A log hook recording the current workspace's most recently focused windows+--   into extensible state.+refocusLastLogHook :: X ()+refocusLastLogHook = withWindowSet (updateRecentsOn . W.currentTag)++-- | Records a workspace's recently focused windows into extensible state upon+--   relayout. Potentially a less wasteful alternative to @refocusLastLogHook@,+--   as it does not run on @WM_NAME@ @propertyNotify@ events.+refocusLastLayoutHook :: l a -> ModifiedLayout RefocusLastLayoutHook l a+refocusLastLayoutHook = ModifiedLayout RefocusLastLayoutHook++-- | Given a predicate on the event window determining whether or not to act,+--   construct an event hook that runs iff the core xmonad event handler will+--   unmanage the window, and which shifts focus to the last focused window on+--   the appropriate workspace if desired.+refocusLastWhen :: Query Bool -> Event -> X All+refocusLastWhen p event = All True <$ case event of+  UnmapEvent { ev_send_event = synth, ev_window = w } -> do+    e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap)+    when (synth || e == 0) (refocusLast w)+  DestroyWindowEvent {                ev_window = w } -> refocusLast w+  _                                                   -> return ()+  where+    refocusLast w = whenX (runQuery p w) . withWindowSet $ \ws ->+      whenJust (W.findTag w ws) $ \tag ->+        withRecentsIn tag () $ \lw cw ->+          when (w == cw) . modify $ \xs ->+            xs { windowset = tryFocusIn tag [lw] ws }++-- }}}++-- --< Predicates >-- {{{++-- $Predicates+-- Impure @Query Bool@ predicates on event windows for use as arguments to+-- 'refocusLastWhen', 'shiftRLWhen' and 'refocusWhen'. Can be combined with+-- '<||>' or '<&&>'. Use like e.g.+--+-- > , handleEventHook = refocusLastWhen refocusingIsActive+--+-- or in a keybinding:+--+-- > windows =<< shiftRLWhen (refocusingIsActive <&&> isFloat) "3"+--+-- It's also valid to use a property lookup like @className =? "someProgram"@ as+-- a predicate, and it should function as expected with e.g. @shiftRLWhen@.+-- In the event hook on the other hand, the window in question has already been+-- unmapped or destroyed, so external lookups to X properties don't work:+-- only the information fossilised in xmonad's state is available.++-- | Holds iff refocusing is toggled active.+refocusingIsActive :: Query Bool+refocusingIsActive = (liftX . XS.gets) refocusing++-- | Holds iff the event window is a float.+isFloat :: Query Bool+isFloat = ask >>= \w -> (liftX . gets) (M.member w . W.floating . windowset)++-- }}}++-- --< Public Actions >-- {{{++-- | Toggle automatic refocusing at runtime. Has no effect unless the+--   @refocusingIsActive@ predicate has been used.+toggleRefocusing :: X ()+toggleRefocusing = XS.modify (RefocusLastToggle . not . refocusing)++-- | Refocuses the previously focused window; acts as a toggle.+--   Is not affected by @toggleRefocusing@.+toggleFocus :: X ()+toggleFocus = withRecents $ \lw cw ->+  when (cw /= lw) . windows $ tryFocus [lw]++-- | Swaps the current and previous windows of the current workspace.+--   Is not affected by @toggleRefocusing@.+swapWithLast :: X ()+swapWithLast = withRecents $ \lw cw ->+  when (cw /= lw) . windows . modify''. mapZ_ $ \w ->+    if | (w == lw) -> cw+       | (w == cw) -> lw+       | otherwise ->  w+  where modify'' f = W.modify (f Nothing) (f . Just)++-- | Given a target workspace and a predicate on its current window, produce a+--   'windows' suitable function that will refocus that workspace appropriately.+--   Allows you to hook refocusing into any action you can run through+--   @windows@. See the implementation of @shiftRLWhen@ for a straight-forward+--   usage example.+refocusWhen :: Query Bool -> WorkspaceId -> X (WindowSet -> WindowSet)+refocusWhen p tag = withRecentsIn tag id $ \lw cw -> do+  b <- runQuery p cw+  return (if b then tryFocusIn tag [cw, lw] else id)++-- | Sends the focused window to the specified workspace, refocusing the last+--   focused window if the predicate holds on the current window. Note that the+--   native version of this, @windows . W.shift@, has a nice property that this+--   does not: shifting a window to another workspace then shifting it back+--   preserves its place in the stack. Can be used in a keybinding like e.g.+--+-- > windows =<< shiftRLWhen refocusingIsActive "3"+--+--   or+--+-- > (windows <=< shiftRLWhen refocusingIsActive) "3"+--+--   where '<=<' is imported from "Control.Monad".+shiftRLWhen :: Query Bool -> WorkspaceId -> X (WindowSet -> WindowSet)+shiftRLWhen p to = withWindowSet $ \ws -> do+  refocus <- refocusWhen p (W.currentTag ws)+  let shift = maybe id (W.shiftWin to) (W.peek ws)+  return (refocus . shift)++-- | Perform an update to the 'RecentWins' for the specified workspace.+--   The RefocusLast log and layout hooks are both implemented trivially in+--   terms of this function. Only exported to aid extensibility.+updateRecentsOn :: WorkspaceId -> X ()+updateRecentsOn tag = withWindowSet $ \ws ->+  whenJust (W.peek $ W.view tag ws) $ \fw -> do+    m <- getRecentsMap+    let insertRecent l c = XS.put . RecentsMap $ M.insert tag (Recent l c) m+    case M.lookup tag m of+      Just (Recent _ cw) -> when (cw /= fw) (insertRecent cw fw)+      Nothing            ->                  insertRecent fw fw++-- }}}++-- --< Utilities >-- {{{++-- | Focuses the first window in the list it can find on the current workspace.+tryFocus :: [Window] -> WindowSet -> WindowSet+tryFocus wins = W.modify' $ \s ->+  fromMaybe s . asum $ (\w -> findS (== w) s) <$> wins++-- | Operate the above on a specified workspace.+tryFocusIn :: WorkspaceId -> [Window] -> WindowSet -> WindowSet+tryFocusIn tag wins ws =+  W.view (W.currentTag ws) . tryFocus wins . W.view tag $ ws++-- | Get the RecentsMap out of extensible state and remove its newtype wrapper.+getRecentsMap :: X (M.Map WorkspaceId RecentWins)+getRecentsMap = XS.get >>= \(RecentsMap m) -> return m++-- | Perform an X action dependent on successful lookup of the RecentWins for+--   the specified workspace, or return a default value.+withRecentsIn :: WorkspaceId -> a -> (Window -> Window -> X a) -> X a+withRecentsIn tag dflt f = maybe (return dflt) (\(Recent lw cw) -> f lw cw)+                         . M.lookup tag+                       =<< getRecentsMap++-- | The above specialised to the current workspace and unit.+withRecents :: (Window -> Window -> X ()) -> X ()+withRecents f = withWindowSet $ \ws -> withRecentsIn (W.currentTag ws) () f++-- }}}
+ XMonad/Hooks/Rescreen.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module      :  XMonad.Hooks.Rescreen+-- Description :  Custom hooks for screen (xrandr) configuration changes.+-- Copyright   :  (c) 2021 Tomáš Janoušek <tomi@nomi.cz>+-- License     :  BSD3+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>+--+-- Custom hooks for screen (xrandr) configuration changes.+--+module XMonad.Hooks.Rescreen (+    -- * Usage+    -- $usage+    addAfterRescreenHook,+    addRandrChangeHook,+    setRescreenWorkspacesHook,+    setRescreenDelay,+    RescreenConfig(..),+    rescreenHook,+    ) where++import Control.Concurrent (threadDelay)+import Graphics.X11.Xrandr+import XMonad+import XMonad.Prelude+import qualified XMonad.Util.ExtensibleConf as XC++-- $usage+-- This module provides a replacement for the screen configuration change+-- handling in core that enables attaching custom hooks to screen (xrandr)+-- configuration change events. These can be used to restart/reposition status+-- bars or systrays automatically after xrandr+-- ('XMonad.Hooks.StatusBar.dynamicSBs' uses this module internally), as well+-- as to actually invoke xrandr or autorandr when an output is (dis)connected.+--+-- To use this, include the following in your @xmonad.hs@:+--+-- > import XMonad.Hooks.Rescreen+--+-- define your custom hooks:+--+-- > myAfterRescreenHook :: X ()+-- > myAfterRescreenHook = spawn "fbsetroot -solid red"+--+-- > myRandrChangeHook :: X ()+-- > myRandrChangeHook = spawn "autorandr --change"+--+-- and hook them into your 'xmonad' config:+--+-- > main = xmonad $ …+-- >               . addAfterRescreenHook myAfterRescreenHook+-- >               . addRandrChangeHook myRandrChangeHook+-- >               . …+-- >               $ def{…}+--+-- See documentation of 'rescreenHook' for details about when these hooks are+-- called.++-- | Hook configuration for 'rescreenHook'.+data RescreenConfig = RescreenConfig+    { afterRescreenHook :: X () -- ^ hook to invoke after 'rescreen'+    , randrChangeHook :: X () -- ^ hook for other randr changes, e.g. (dis)connects+    , rescreenWorkspacesHook :: Last (X ()) -- ^ hook to invoke instead of 'rescreen'+    , rescreenDelay :: Last Int -- ^ delay (in microseconds) to wait for events to settle+    }++instance Default RescreenConfig where+    def = RescreenConfig+        { afterRescreenHook = mempty+        , randrChangeHook = mempty+        , rescreenWorkspacesHook = mempty+        , rescreenDelay = mempty+        }++instance Semigroup RescreenConfig where+    RescreenConfig arh rch rwh rd <> RescreenConfig arh' rch' rwh' rd' =+        RescreenConfig (arh <> arh') (rch <> rch') (rwh <> rwh') (rd <> rd')++instance Monoid RescreenConfig where+    mempty = def++-- | Attach custom hooks to screen (xrandr) configuration change events.+-- Replaces the built-in rescreen handling of xmonad core with:+--+-- 1. listen to 'RRScreenChangeNotifyEvent' in addition to 'ConfigureEvent' on+--    the root window+-- 2. whenever such event is received:+-- 3. clear any other similar events (Xorg server emits them in bunches)+-- 4. if any event was 'ConfigureEvent', 'rescreen' and invoke 'afterRescreenHook'+-- 5. if there was no 'ConfigureEvent', invoke 'randrChangeHook' only+--+-- 'afterRescreenHook' is useful for restarting/repositioning status bars and+-- systray.+--+-- 'randrChangeHook' may be used to automatically trigger xrandr (or perhaps+-- autorandr) when outputs are (dis)connected.+--+-- 'rescreenWorkspacesHook' allows tweaking the 'rescreen' implementation,+-- to change the order workspaces are assigned to physical screens for+-- example.+--+-- 'rescreenDelay' makes xmonad wait a bit for events to settle (after the+-- first event is received) — useful when multiple @xrandr@ invocations are+-- being used to change the screen layout.+--+-- Note that 'rescreenHook' is safe to use several times, 'rescreen' is still+-- done just once and hooks are invoked in sequence (except+-- 'rescreenWorkspacesHook', which has a replace rather than sequence+-- semantics), also just once.+rescreenHook :: RescreenConfig -> XConfig l -> XConfig l+rescreenHook = XC.once hook . catchUserCode+  where+    hook c = c+        { startupHook = startupHook c <> rescreenStartupHook+        , handleEventHook = handleEventHook c <> rescreenEventHook }+    catchUserCode rc@RescreenConfig{..} = rc+        { afterRescreenHook = userCodeDef () afterRescreenHook+        , randrChangeHook = userCodeDef () randrChangeHook+        , rescreenWorkspacesHook = flip catchX rescreen <$> rescreenWorkspacesHook+        }++-- | Shortcut for 'rescreenHook'.+addAfterRescreenHook :: X () -> XConfig l -> XConfig l+addAfterRescreenHook h = rescreenHook def{ afterRescreenHook = h }++-- | Shortcut for 'rescreenHook'.+addRandrChangeHook :: X () -> XConfig l -> XConfig l+addRandrChangeHook h = rescreenHook def{ randrChangeHook = h }++-- | Shortcut for 'rescreenHook'.+setRescreenWorkspacesHook :: X () -> XConfig l -> XConfig l+setRescreenWorkspacesHook h = rescreenHook def{ rescreenWorkspacesHook = pure h }++-- | Shortcut for 'rescreenHook'.+setRescreenDelay :: Int -> XConfig l -> XConfig l+setRescreenDelay d = rescreenHook def{ rescreenDelay = pure d }++-- | Startup hook to listen for @RRScreenChangeNotify@ events.+rescreenStartupHook :: X ()+rescreenStartupHook = do+    dpy <- asks display+    root <- asks theRoot+    io $ xrrSelectInput dpy root rrScreenChangeNotifyMask++-- | Event hook with custom rescreen/randr hooks. See 'rescreenHook' for more.+rescreenEventHook :: Event -> X All+rescreenEventHook e = do+    shouldHandle <- case e of+        ConfigureEvent{ ev_window = w } -> isRoot w+        RRScreenChangeNotifyEvent{ ev_window = w } -> isRoot w+        _ -> pure False+    if shouldHandle+        then All False <$ handleEvent e+        else mempty++handleEvent :: Event -> X ()+handleEvent e = XC.with $ \RescreenConfig{..} -> do+    -- Xorg emits several events after every change, clear them to prevent+    -- triggering the hook multiple times.+    whenJust (getLast rescreenDelay) (io . threadDelay)+    moreConfigureEvents <- clearTypedWindowEvents (ev_window e) configureNotify+    _ <- clearTypedWindowRREvents (ev_window e) rrScreenChangeNotify+    -- If there were any ConfigureEvents, this is an actual screen+    -- configuration change, so rescreen and fire rescreenHook. Otherwise,+    -- this is just a connect/disconnect, fire randrChangeHook.+    if ev_event_type e == configureNotify || moreConfigureEvents+        then fromMaybe rescreen (getLast rescreenWorkspacesHook) >> afterRescreenHook+        else randrChangeHook++-- | Remove all X events of a given window and type from the event queue,+-- return whether there were any.+clearTypedWindowEvents :: Window -> EventType -> X Bool+clearTypedWindowEvents w t = withDisplay $ \d -> io $ allocaXEvent (go d)+  where+    go d e' = do+        sync d False+        gotEvent <- checkTypedWindowEvent d w t e'+        e <- if gotEvent then Just <$> getEvent e' else pure Nothing+        gotEvent <$ if+            | not gotEvent -> mempty+            | (ev_window <$> e) == Just w -> void $ go d e'+            -- checkTypedWindowEvent checks ev_event instead of ev_window, so+            -- we may need to put some events back+            | otherwise -> allocaXEvent (go d) >> io (putBackEvent d e')++clearTypedWindowRREvents :: Window -> EventType -> X Bool+clearTypedWindowRREvents w t =+    rrEventBase >>= \case+        Just base -> clearTypedWindowEvents w (base + t)+        Nothing -> pure False++rrEventBase :: X (Maybe EventType)+rrEventBase = withDisplay $ \d ->+    fmap (fromIntegral . fst) <$> io (xrrQueryExtension d)
− XMonad/Hooks/RestoreMinimized.hs 
@@ -1,49 +0,0 @@-------------------------------------------------------------------------------- |--- Module      :  XMonad.Hooks.RestoreMinimized--- Copyright   :  (c) Jan Vornberger 2009--- License     :  BSD3-style (see LICENSE)------ Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de--- Stability   :  unstable--- Portability :  not portable------ (Deprecated: Use XMonad.Hooks.Minimize) Lets you restore minimized--- windows (see "XMonad.Layout.Minimize") by selecting them on a--- taskbar (listens for _NET_ACTIVE_WINDOW and WM_CHANGE_STATE).-----------------------------------------------------------------------------------module XMonad.Hooks.RestoreMinimized-    ( -- * Usage-      -- $usage-      RestoreMinimized (..)-    , restoreMinimizedEventHook-    ) where--import Data.Monoid-import Control.Monad(when)--import XMonad-import XMonad.Layout.Minimize---- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:------ > import XMonad.Hooks.RestoreMinimized--- >--- > myHandleEventHook = restoreMinimizedEventHook--- >--- > main = xmonad defaultConfig { handleEventHook = myHandleEventHook }--data RestoreMinimized = RestoreMinimized deriving ( Show, Read )--restoreMinimizedEventHook :: Event -> X All-restoreMinimizedEventHook (ClientMessageEvent {ev_window = w,-                                                ev_message_type = mt}) = do-    a_aw <- getAtom "_NET_ACTIVE_WINDOW"-    a_cs <- getAtom "WM_CHANGE_STATE"-    when (mt == a_aw || mt == a_cs) $ do-        sendMessage (RestoreMinimizedWin w)-    return (All True)-restoreMinimizedEventHook _ = return (All True)
XMonad/Hooks/ScreenCorners.hs view
@@ -1,127 +1,142 @@-{-# LANGUAGE DeriveDataTypeable #-}------------------------------------------------------------------------------+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+ -- | -- Module      :  XMonad.Hooks.ScreenCorners--- Copyright   :  (c) 2009 Nils Schweinsberg+-- Description :  Run X () actions by touching the edge of your screen with your mouse.+-- Copyright   :  (c) 2009-2025 Nils Schweinsberg, 2015 Evgeny Kurnevsky, 2024 Yuanle Song -- License     :  BSD3-style (see LICENSE) ----- Maintainer  :  Nils Schweinsberg <mail@n-sch.de>+-- Maintainer  :  Nils Schweinsberg <mail@nils.cc> -- Stability   :  unstable -- Portability :  unportable -- -- Run @X ()@ actions by touching the edge of your screen with your mouse.---------------------------------------------------------------------------------- module XMonad.Hooks.ScreenCorners-    (-    -- * Usage+  ( -- * Usage     -- $usage      -- * Adding screen corners-      ScreenCorner (..)-    , addScreenCorner-    , addScreenCorners+    ScreenCorner (..),+    addScreenCorner,+    addScreenCorners,      -- * Event hook-    , screenCornerEventHook-    ) where+    screenCornerEventHook, -import Data.Monoid-import Data.List (find)-import XMonad-import XMonad.Util.XUtils (fi)+    -- * Layout hook+    screenCornerLayoutHook,+  )+where  import qualified Data.Map as M+import XMonad+import XMonad.Layout.LayoutModifier+import XMonad.Prelude import qualified XMonad.Util.ExtensibleState as XS -data ScreenCorner = SCUpperLeft-                  | SCUpperRight-                  | SCLowerLeft-                  | SCLowerRight-                  deriving (Eq, Ord, Show)--+data ScreenCorner+  = SCUpperLeft+  | SCUpperRight+  | SCLowerLeft+  | SCLowerRight+  | SCTop+  | SCBottom+  | SCLeft+  | SCRight+  deriving (Eq, Ord, Show)  -------------------------------------------------------------------------------- -- ExtensibleState modifications --------------------------------------------------------------------------------  newtype ScreenCornerState = ScreenCornerState (M.Map Window (ScreenCorner, X ()))-    deriving Typeable  instance ExtensionClass ScreenCornerState where-    initialValue = ScreenCornerState M.empty+  initialValue = ScreenCornerState M.empty  -- | Add one single @X ()@ action to a screen corner addScreenCorner :: ScreenCorner -> X () -> X () addScreenCorner corner xF = do--    ScreenCornerState m <- XS.get-    (win,xFunc) <- case find (\(_,(sc,_)) -> sc == corner) (M.toList m) of--                        Just (w, (_,xF')) -> return (w, xF' >> xF) -- chain X actions-                        Nothing           -> flip (,) xF `fmap` createWindowAt corner+  ScreenCornerState m <- XS.get+  (win, xFunc) <- case find (\(_, (sc, _)) -> sc == corner) (M.toList m) of+    Just (w, (_, xF')) -> return (w, xF' >> xF) -- chain X actions+    Nothing -> (,xF) <$> createWindowAt corner -    XS.modify $ \(ScreenCornerState m') -> ScreenCornerState $ M.insert win (corner,xFunc) m'+  XS.modify $ \(ScreenCornerState m') -> ScreenCornerState $ M.insert win (corner, xFunc) m'  -- | Add a list of @(ScreenCorner, X ())@ tuples-addScreenCorners :: [ (ScreenCorner, X ()) ] -> X ()-addScreenCorners = mapM_ (\(corner, xF) -> addScreenCorner corner xF)-+addScreenCorners :: [(ScreenCorner, X ())] -> X ()+addScreenCorners = mapM_ (uncurry addScreenCorner)  -------------------------------------------------------------------------------- -- Xlib functions -------------------------------------------------------------------------------- --- "Translate" a ScreenCorner to real (x,y) Positions+-- "Translate" a ScreenCorner to real (x,y) Positions with proper width and+-- height. createWindowAt :: ScreenCorner -> X Window-createWindowAt SCUpperLeft = createWindowAt' 0 0+createWindowAt SCUpperLeft = createWindowAt' 0 0 1 1 createWindowAt SCUpperRight = withDisplay $ \dpy ->-    let w = displayWidth  dpy (defaultScreen dpy) - 1-    in createWindowAt' (fi w) 0-+  let w = displayWidth dpy (defaultScreen dpy) - 1+   in createWindowAt' (fi w) 0 1 1 createWindowAt SCLowerLeft = withDisplay $ \dpy ->-    let h = displayHeight dpy (defaultScreen dpy) - 1-    in createWindowAt' 0 (fi h)-+  let h = displayHeight dpy (defaultScreen dpy) - 1+   in createWindowAt' 0 (fi h) 1 1 createWindowAt SCLowerRight = withDisplay $ \dpy ->-    let w = displayWidth  dpy (defaultScreen dpy) - 1-        h = displayHeight dpy (defaultScreen dpy) - 1-    in createWindowAt' (fi w) (fi h)---- Create a new X window at a (x,y) Position-createWindowAt' :: Position -> Position -> X Window-createWindowAt' x y = withDisplay $ \dpy -> io $ do--    rootw <- rootWindow dpy (defaultScreen dpy)--    let-        visual   = defaultVisualOfScreen $ defaultScreenOfDisplay dpy-        attrmask = cWOverrideRedirect+  let w = displayWidth dpy (defaultScreen dpy) - 1+      h = displayHeight dpy (defaultScreen dpy) - 1+   in createWindowAt' (fi w) (fi h) 1 1+createWindowAt SCTop = withDisplay $ \dpy ->+  let w = displayWidth dpy (defaultScreen dpy) - 1+      -- leave some gap so corner and edge can work nicely when they overlap+      threshold = 150+   in createWindowAt' threshold 0 (fi $ fi w - threshold * 2) 1+createWindowAt SCBottom = withDisplay $ \dpy ->+  let w = displayWidth dpy (defaultScreen dpy) - 1+      h = displayHeight dpy (defaultScreen dpy) - 1+      threshold = 150+   in createWindowAt' threshold (fi h) (fi $ fi w - threshold * 2) 1+createWindowAt SCLeft = withDisplay $ \dpy ->+  let h = displayHeight dpy (defaultScreen dpy) - 1+      threshold = 150+   in createWindowAt' 0 threshold 1 (fi $ fi h - threshold * 2)+createWindowAt SCRight = withDisplay $ \dpy ->+  let w = displayWidth dpy (defaultScreen dpy) - 1+      h = displayHeight dpy (defaultScreen dpy) - 1+      threshold = 150+   in createWindowAt' (fi w) threshold 1 (fi $ fi h - threshold * 2) -    w <- allocaSetWindowAttributes $ \attributes -> do+-- Create a new X window at a (x,y) Position, with given width and height.+createWindowAt' :: Position -> Position -> Dimension -> Dimension -> X Window+createWindowAt' x y width height = withDisplay $ \dpy -> io $ do+  rootw <- rootWindow dpy (defaultScreen dpy) -        set_override_redirect attributes True-        createWindow dpy        -- display-                     rootw      -- parent window-                     x          -- x-                     y          -- y-                     1          -- width-                     1          -- height-                     0          -- border width-                     0          -- depth-                     inputOnly  -- class-                     visual     -- visual-                     attrmask   -- valuemask-                     attributes -- attributes+  let visual = defaultVisualOfScreen $ defaultScreenOfDisplay dpy+      attrmask = cWOverrideRedirect -    -- we only need mouse entry events-    selectInput dpy w enterWindowMask-    mapWindow dpy w-    sync dpy False-    return w+  w <- allocaSetWindowAttributes $ \attributes -> do+    set_override_redirect attributes True+    createWindow+      dpy -- display+      rootw -- parent window+      x -- x+      y -- y+      width -- width+      height -- height+      0 -- border width+      0 -- depth+      inputOnly -- class+      visual -- visual+      attrmask -- valuemask+      attributes -- attributes +  -- we only need mouse entry events+  selectInput dpy w enterWindowMask+  mapWindow dpy w+  sync dpy False+  return w  -------------------------------------------------------------------------------- -- Event hook@@ -129,25 +144,40 @@  -- | Handle screen corner events screenCornerEventHook :: Event -> X All-screenCornerEventHook CrossingEvent { ev_window = win } = do+screenCornerEventHook CrossingEvent {ev_window = win} = do+  ScreenCornerState m <- XS.get -    ScreenCornerState m <- XS.get+  case M.lookup win m of+    Just (_, xF) -> xF+    Nothing -> return () -    case M.lookup win m of-         Just (_, xF) -> xF-         Nothing      -> return ()+  return (All True)+screenCornerEventHook _ = return (All True) -    return (All True)+--------------------------------------------------------------------------------+-- Layout hook+-------------------------------------------------------------------------------- -screenCornerEventHook _ = return (All True)+data ScreenCornerLayout a = ScreenCornerLayout+  deriving (Read, Show) +instance LayoutModifier ScreenCornerLayout a where+  hook ScreenCornerLayout = withDisplay $ \dpy -> do+    ScreenCornerState m <- XS.get+    io $ mapM_ (raiseWindow dpy) $ M.keys m+  unhook = hook +screenCornerLayoutHook :: l a -> ModifiedLayout ScreenCornerLayout l a+screenCornerLayoutHook = ModifiedLayout ScreenCornerLayout+ --------------------------------------------------------------------------------+ -- $usage ----- This extension adds KDE-like screen corners to XMonad. By moving your cursor--- into one of your screen corners you can trigger an @X ()@ action, for--- example @"XMonad.Actions.GridSelect".goToSelected@ or+-- This extension adds KDE-like screen corners and GNOME Hot Edge like+-- features to XMonad. By moving your cursor into one of your screen corners+-- or edges, you can trigger an @X ()@ action, for example+-- @"XMonad.Actions.GridSelect".goToSelected@ or -- @"XMonad.Actions.CycleWS".nextWS@ etc. -- -- To use it, import it on top of your @xmonad.hs@:@@ -158,10 +188,19 @@ -- -- > myStartupHook = do -- >     ...--- >     addScreenCorner SCUpperRight (goToSelected defaultGSConfig { gs_cellwidth = 200})+-- >     addScreenCorner SCUpperRight (goToSelected def { gs_cellwidth = 200})+-- >     addScreenCorner SCBottom (goToSelected def) -- >     addScreenCorners [ (SCLowerRight, nextWS) -- >                      , (SCLowerLeft,  prevWS) -- >                      ]+--+-- Then add layout hook:+--+-- > myLayout = screenCornerLayoutHook $ tiled ||| Mirror tiled ||| Full where+-- >     tiled   = Tall nmaster delta ratio+-- >     nmaster = 1+-- >     ratio   = 1 / 2+-- >     delta   = 3 / 100 -- -- And finally wait for screen corner events in your event hook: --
XMonad/Hooks/Script.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : XMonad.Hooks.Script+-- Description : Simple interface for running a ~\/.xmonad\/hooks script with the name of a hook. -- Copyright   : (c) Trevor Elliott <trevor@galois.com> -- License     : BSD3-style (see LICENSE) --@@ -34,7 +35,7 @@ -- For example, if you wanted to run the hook "startup" in your script every -- time your startup hook ran, you could modify your xmonad config as such: ----- > main = xmonad $ defaultConfig {+-- > main = xmonad $ def { -- >   ... -- >   startupHook = execScriptHook "startup" -- >   ...@@ -44,8 +45,8 @@ -- @~\/.xmonad\/hooks startup@ will also.  -- | Execute a named script hook-execScriptHook :: MonadIO m => String -> m ()+execScriptHook :: String -> X () execScriptHook hook = do-  xmonadDir <- getXMonadDir+  xmonadDir <- asks (cfgDir . directories)   let script = xmonadDir ++ "/hooks "   spawn (script ++ hook)
XMonad/Hooks/ServerMode.hs view
@@ -1,105 +1,103 @@+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.ServerMode--- Copyright   :  (c) Andrea Rossato and David Roundy 2007+-- Description :  Send commands to a running xmonad process.+-- Copyright   :  (c) Peter Olson 2013 and Andrea Rossato and David Roundy 2007 -- License     :  BSD-style (see xmonad/LICENSE) ----- Maintainer  :  andrea.rossato@unibz.it+-- Maintainer  :  polson2@hawk.iit.edu -- Stability   :  unstable -- Portability :  unportable -- -- This is an 'EventHook' that will receive commands from an external--- client.------ This is the example of a client:------ > import Graphics.X11.Xlib--- > import Graphics.X11.Xlib.Extras--- > import System.Environment--- > import Data.Char--- >--- > usage :: String -> String--- > usage n = "Usage: " ++ n ++ " command number\nSend a command number to a running instance of XMonad"--- >--- > main :: IO ()--- > main = do--- >   args <- getArgs--- >   pn <- getProgName--- >   let com = case args of--- >               [] -> error $ usage pn--- >               w -> (w !! 0)--- >   sendCommand com--- >--- > sendCommand :: String -> IO ()--- > sendCommand s = do--- >   d   <- openDisplay ""--- >   rw  <- rootWindow d $ defaultScreen d--- >   a <- internAtom d "XMONAD_COMMAND" False--- >   allocaXEvent $ \e -> do--- >                   setEventType e clientMessage--- >                   setClientMessageEvent e rw a 32 (fromIntegral (read s)) currentTime--- >                   sendEvent d rw False structureNotifyMask e--- >                   sync d False------ compile with: @ghc --make sendCommand.hs@------ run with------ > sendCommand command number------ For instance:+-- client. Also consider "XMonad.Hooks.EwmhDesktops" together with+-- @wmctrl@. ----- > sendCommand 0+-- See @scripts/xmonadctl.hs@ for the client. -----  will ask to xmonad to print the list of command numbers in--- stderr (so you can read it in @~\/.xsession-errors@). -----------------------------------------------------------------------------  module XMonad.Hooks.ServerMode     ( -- * Usage       -- $usage-      ServerMode (..)-    , serverModeEventHook+      serverModeEventHook     , serverModeEventHook'+    , serverModeEventHookCmd+    , serverModeEventHookCmd'+    , serverModeEventHookF     ) where -import Control.Monad (when)-import Data.Monoid import System.IO  import XMonad+import XMonad.Prelude import XMonad.Actions.Commands  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Hooks.ServerMode--- > import XMonad.Actions.Commands ----- Then edit your @handleEventHook@ by adding the 'serverModeEventHook':------ > main = xmonad defaultConfig { handleEventHook = serverModeEventHook }-----data ServerMode = ServerMode deriving ( Show, Read )+-- Then edit your @handleEventHook@ by adding the appropriate event hook from below  -- | Executes a command of the list when receiving its index via a special ClientMessageEvent--- (indexing starts at 1)+-- (indexing starts at 1). Sending index 0 will ask xmonad to print the list of command numbers+-- in stderr (so that you can read it in @~\/.xsession-errors@). Uses "XMonad.Actions.Commands#defaultCommands" as the default.+--+-- > main = xmonad def { handleEventHook = serverModeEventHook }+--+-- > xmonadctl 0 # tells xmonad to output command list+-- > xmonadctl 1 # tells xmonad to switch to workspace 1+-- serverModeEventHook :: Event -> X All serverModeEventHook = serverModeEventHook' defaultCommands  -- | serverModeEventHook' additionally takes an action to generate the list of -- commands. serverModeEventHook' :: X [(String,X ())] -> Event -> X All-serverModeEventHook' cmdAction (ClientMessageEvent {ev_message_type = mt, ev_data = dt}) = do-        d <- asks display-        a <- io $ internAtom d "XMONAD_COMMAND" False-        when (mt == a && dt /= []) $ do-             cl <- cmdAction-             let listOfCommands = map (uncurry (++)) . zip (map show ([1..] :: [Int])) . map ((++) " - " . fst)-             case lookup (fromIntegral (head dt) :: Int) (zip [1..] cl) of-                  Just (_,action) -> action-                  Nothing         -> mapM_ (io . hPutStrLn stderr) . listOfCommands $ cl-        return (All True)-serverModeEventHook' _ _ = return (All True)+serverModeEventHook' cmdAction = serverModeEventHookF "XMONAD_COMMAND" (mapM_ helper . words)+        where helper cmd = do cl <- cmdAction+                              case lookup cmd (zip (map show [1 :: Integer ..]) cl) of+                                Just (_,action) -> action+                                Nothing         -> mapM_ (io . hPutStrLn stderr) . listOfCommands $ cl+              listOfCommands cl = zipWith (++) (map show [1 :: Int ..]) (map ((++) " - " . fst) cl)+++-- | Executes a command of the list when receiving its name via a special ClientMessageEvent.+-- Uses "XMonad.Actions.Commands#defaultCommands" as the default.+--+-- > main = xmonad def { handleEventHook = serverModeEventHookCmd }+--+-- > xmonadctl run # Tells xmonad to generate a run prompt+--+serverModeEventHookCmd :: Event -> X All+serverModeEventHookCmd = serverModeEventHookCmd' defaultCommands++-- | Additionally takes an action to generate the list of commands+serverModeEventHookCmd' :: X [(String,X ())] -> Event -> X All+serverModeEventHookCmd' cmdAction = serverModeEventHookF "XMONAD_COMMAND" (mapM_ helper . words)+        where helper cmd = do cl <- cmdAction+                              fromMaybe (io $ hPutStrLn stderr ("Couldn't find command " ++ cmd)) (lookup cmd cl)++-- | Listens for an atom, then executes a callback function whenever it hears it.+-- A trivial example that prints everything supplied to it on xmonad's standard out:+--+-- > main = xmonad def { handleEventHook = serverModeEventHookF "XMONAD_PRINT" (io . putStrLn) }+--+-- > xmonadctl -a XMONAD_PRINT "hello world"+--+serverModeEventHookF :: String -> (String -> X ()) -> Event -> X All+serverModeEventHookF key func ClientMessageEvent {ev_message_type = mt, ev_data = dt} = do+  d <- asks display+  atm <- io $ internAtom d key False+  if | mt == atm, Just dth <- listToMaybe dt -> do+         let atom = fromIntegral dth+         cmd <- io $ getAtomName d atom+         case cmd of+           Just command -> func command+           Nothing -> io $ hPutStrLn stderr ("Couldn't retrieve atom " ++ show atom)+     | otherwise -> pure ()+  return (All True)+serverModeEventHookF _ _ _ = return (All True)
XMonad/Hooks/SetWMName.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.SetWMName+-- Description :  Set the WM name to a given string. -- Copyright   :  © 2007 Ivan Tarasov <Ivan.Tarasov@gmail.com> -- License     :  BSD --@@ -11,10 +12,10 @@ -- Sets the WM name to a given string, so that it could be detected using -- _NET_SUPPORTING_WM_CHECK protocol. ----- May be useful for making Java GUI programs work, just set WM name to "LG3D"+-- May be useful for making Java GUI programs work, just set WM name to \"LG3D\" -- and use Java 1.6u1 (1.6.0_01-ea-b03 works for me) or later. ----- To your @~\/.xmonad\/xmonad.hs@ file, add the following line:+-- To your @xmonad.hs@ file, add the following line: -- -- > import XMonad.Hooks.SetWMName --@@ -32,21 +33,20 @@ -- fails miserably by guessing absolutely bogus values. -- -- For detailed instructions on editing your hooks, see--- "XMonad.Doc.Extending#4".+-- <https://xmonad.org/TUTORIAL.html the tutorial> and "XMonad.Doc.Extending". -----------------------------------------------------------------------------  module XMonad.Hooks.SetWMName (-    setWMName) where+      setWMName+    , getWMName+    )+  where -import Control.Monad (join)-import Data.Char (ord)-import Data.List (nub)-import Data.Maybe (fromJust, listToMaybe, maybeToList) import Foreign.C.Types (CChar)- import Foreign.Marshal.Alloc (alloca)  import XMonad+import XMonad.Prelude (fromJust, join, listToMaybe, maybeToList, nub, ord)  -- | sets WM name setWMName :: String -> X ()@@ -61,26 +61,26 @@     dpy <- asks display     io $ do         -- _NET_SUPPORTING_WM_CHECK atom of root and support windows refers to the support window-        mapM_ (\w -> changeProperty32 dpy w atom_NET_SUPPORTING_WM_CHECK wINDOW 0 [fromIntegral supportWindow]) [root, supportWindow]+        mapM_ (\w -> changeProperty32 dpy w atom_NET_SUPPORTING_WM_CHECK wINDOW propModeReplace [fromIntegral supportWindow]) [root, supportWindow]         -- set WM_NAME in supportWindow (now only accepts latin1 names to eliminate dependency on utf8 encoder)-        changeProperty8 dpy supportWindow atom_NET_WM_NAME atom_UTF8_STRING 0 (latin1StringToCCharList name)+        changeProperty8 dpy supportWindow atom_NET_WM_NAME atom_UTF8_STRING propModeReplace (latin1StringToCCharList name)         -- declare which _NET protocols are supported (append to the list if it exists)-        supportedList <- fmap (join . maybeToList) $ getWindowProperty32 dpy atom_NET_SUPPORTED_ATOM root-        changeProperty32 dpy root atom_NET_SUPPORTED_ATOM aTOM 0 (nub $ fromIntegral atom_NET_SUPPORTING_WM_CHECK : fromIntegral atom_NET_WM_NAME : supportedList)+        supportedList <- join . maybeToList <$> getWindowProperty32 dpy atom_NET_SUPPORTED_ATOM root+        changeProperty32 dpy root atom_NET_SUPPORTED_ATOM aTOM propModeReplace (nub $ fromIntegral atom_NET_SUPPORTING_WM_CHECK : fromIntegral atom_NET_WM_NAME : supportedList)   where-    netSupportingWMCheckAtom :: X Atom-    netSupportingWMCheckAtom = getAtom "_NET_SUPPORTING_WM_CHECK"-     latin1StringToCCharList :: String -> [CChar]-    latin1StringToCCharList str = map (fromIntegral . ord) str+    latin1StringToCCharList = map (fromIntegral . ord) -    getSupportWindow :: X Window-    getSupportWindow = withDisplay $ \dpy -> do-        atom_NET_SUPPORTING_WM_CHECK <- netSupportingWMCheckAtom-        root <- asks theRoot-        supportWindow <- fmap (join . fmap listToMaybe) $ io $ getWindowProperty32 dpy atom_NET_SUPPORTING_WM_CHECK root-        validateWindow (fmap fromIntegral supportWindow)+netSupportingWMCheckAtom :: X Atom+netSupportingWMCheckAtom = getAtom "_NET_SUPPORTING_WM_CHECK" +getSupportWindow :: X Window+getSupportWindow = withDisplay $ \dpy -> do+    atom_NET_SUPPORTING_WM_CHECK <- netSupportingWMCheckAtom+    root <- asks theRoot+    supportWindow <- (listToMaybe =<<) <$> io (getWindowProperty32 dpy atom_NET_SUPPORTING_WM_CHECK root)+    validateWindow (fmap fromIntegral supportWindow)+  where     validateWindow :: Maybe Window -> X Window     validateWindow w = do         valid <- maybe (return False) isValidWindow w@@ -110,3 +110,7 @@         io $ mapWindow dpy window   -- not sure if this is needed         io $ lowerWindow dpy window -- not sure if this is needed         return window++-- | Get WM name.+getWMName :: X String+getWMName = getSupportWindow >>= runQuery title
+ XMonad/Hooks/ShowWName.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE InstanceSigs #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.ShowWName+-- Description :  Like 'XMonad.Layout.ShowWName', but as a logHook+-- Copyright   :  (c) 2022  Tony Zorman+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Tony Zorman <soliditsallgood@mailbox.org>+--+-- Flash the names of workspaces name when switching to them.  This is a+-- reimplementation of "XMonad.Layout.ShowWName" as a logHook.+-----------------------------------------------------------------------------++module XMonad.Hooks.ShowWName (+  -- * Usage+  -- $usage+  showWNameLogHook,+  SWNConfig(..),+  flashName,+) where++import qualified XMonad.StackSet             as W+import qualified XMonad.Util.ExtensibleState as XS++import XMonad+import XMonad.Layout.ShowWName (SWNConfig (..))+import XMonad.Prelude+import XMonad.Util.XUtils (WindowConfig (..), showSimpleWindow)++import Control.Concurrent (threadDelay)++{- $usage++You can use this module with the following in your+@xmonad.hs@:++> import XMonad.Hooks.ShowWName+>+> main :: IO ()+> main = xmonad $ def+>   { logHook = showWNameLogHook def+>   }++Whenever a workspace gains focus, the above logHook will flash its name.+You can customise the duration of the flash, as well as colours by+customising the 'SWNConfig' argument that 'showWNameLogHook' takes.++Alternatively, you can also bind 'flashName' to a key and manually+invoke it when you want to know which workspace you are on.+-}++-- | LogHook for flashing the name of a workspace upon entering it.+showWNameLogHook :: SWNConfig -> X ()+showWNameLogHook cfg = do+  LastShown s <- XS.get+  foc         <- withWindowSet (pure . W.currentTag)+  unless (s == foc) $ do+    flashName cfg+    XS.put (LastShown foc)++-- | Flash the name of the currently focused workspace.+flashName :: SWNConfig -> X ()+flashName cfg = do+  n <- withWindowSet (pure . W.currentTag)+  showSimpleWindow cfg' [n] >>= \w -> void . xfork $ do+    dpy <- openDisplay ""+    threadDelay (fromEnum $ swn_fade cfg * 1000000) -- 1_000_000 needs GHC 8.6.x and up+    void $ destroyWindow dpy w+    closeDisplay dpy+ where+  cfg' :: WindowConfig+  cfg' = def{ winFont = swn_font cfg, winBg = swn_bgcolor cfg, winFg = swn_color cfg }++-- | Last shown workspace.+newtype LastShown = LastShown WorkspaceId+  deriving (Show, Read)++instance ExtensionClass LastShown where+  initialValue :: LastShown+  initialValue  = LastShown ""++  extensionType :: LastShown -> StateExtension+  extensionType = PersistentExtension
+ XMonad/Hooks/StatusBar.hs view
@@ -0,0 +1,573 @@+{-# LANGUAGE FlexibleContexts, TypeApplications, TupleSections  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.StatusBar+-- Description :  Composable and dynamic status bars.+-- Copyright   :  (c) Yecine Megdiche <yecine.megdiche@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Yecine Megdiche <yecine.megdiche@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- xmonad calls the logHook with every internal state update, which is+-- useful for (among other things) outputting status information to an+-- external status bar program such as xmobar or dzen.+--+-- This module provides a composable interface for (re)starting these status+-- bars and logging to them, either using pipes or X properties. There's also+-- "XMonad.Hooks.StatusBar.PP" which provides an abstraction and some+-- utilities for customization what is logged to a status bar. Together, these+-- are a modern replacement for "XMonad.Hooks.DynamicLog", which is now just a+-- compatibility wrapper.+--+-----------------------------------------------------------------------------++module XMonad.Hooks.StatusBar (+  -- * Usage+  -- $usage+  StatusBarConfig(..),+  withSB,+  withEasySB,+  defToggleStrutsKey,++  -- * Available Configs+  -- $availableconfigs+  statusBarProp,+  statusBarPropTo,+  statusBarGeneric,+  statusBarPipe,++  -- * Multiple Status Bars+  -- $multiple++  -- * Dynamic Status Bars+  -- $dynamic+  dynamicSBs,+  dynamicEasySBs,++  -- * Property Logging utilities+  xmonadPropLog,+  xmonadPropLog',+  xmonadDefProp,++  -- * Managing status bar Processes+  -- $sbprocess+  spawnStatusBar,+  killStatusBar,+  killAllStatusBars,+  startAllStatusBars,+  ) where++import Control.Exception (SomeException, try)+import Data.IORef (newIORef, readIORef, writeIORef)+import qualified Codec.Binary.UTF8.String as UTF8 (encode)+import qualified Data.Map as M+import System.IO (hClose)+import System.Posix.Signals (sigTERM, signalProcessGroup)+import System.Posix.Types (ProcessID)++import Foreign.C (CChar)++import XMonad+import XMonad.Prelude++import XMonad.Util.Run+import qualified XMonad.Util.ExtensibleState as XS++import XMonad.Layout.LayoutModifier+import XMonad.Hooks.ManageDocks+import XMonad.Hooks.Rescreen+import XMonad.Hooks.StatusBar.PP+import qualified XMonad.StackSet as W++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad+-- > import XMonad.Hooks.StatusBar+-- > import XMonad.Hooks.StatusBar.PP+--+-- The easiest way to use this module with xmobar, as well as any other+-- status bar that supports property logging, is to use 'statusBarProp'+-- with 'withEasySB'; these take care of the necessary plumbing:+--+-- > mySB = statusBarProp "xmobar" (pure xmobarPP)+-- > main = xmonad $ withEasySB mySB defToggleStrutsKey def+--+-- You can read more about X11 properties+-- [here](https://en.wikipedia.org/wiki/X_Window_System_core_protocol#Properties)+-- or+-- [here](https://tronche.com/gui/x/xlib/window-information/properties-and-atoms.html),+-- although you don't have to understand them in order to use the functions+-- mentioned above.+--+-- Most users will, however, want to customize the logging and integrate it+-- into their existing custom xmonad configuration. The 'withSB'+-- function is more appropriate in this case: it doesn't touch your+-- keybindings, layout modifiers, or event hooks; instead, you're expected+-- to configure "XMonad.Hooks.ManageDocks" yourself. Here's what that might+-- look like:+--+-- > mySB = statusBarProp "xmobar" (pure myPP)+-- > main = xmonad . withSB mySB . ewmh . docks $ def {...}+--+-- You then have to tell your status bar to read from the @_XMONAD_LOG@ property+-- of the root window.  In the case of xmobar, this is achieved by simply using+-- the @XMonadLog@ plugin instead of @StdinReader@ in your @.xmobarrc@:+--+-- > Config { ...+-- >        , commands = [ Run XMonadLog, ... ]+-- >        , template = "%XMonadLog% }{ ..."+-- >        }+--+-- If you don't have an @.xmobarrc@, create it; the @XMonadLog@ plugin is not+-- part of the default xmobar configuration and your status bar will not show+-- workspace information otherwise!+--+-- With 'statusBarProp', you need to use property logging. Make sure the+-- status bar you use supports reading a property string from the root window,+-- or use some kind of wrapper that reads the property and pipes it into the+-- bar (e.g. @xmonadpropread | dzen2@, see @scripts/xmonadpropread.hs@). The+-- default property is @_XMONAD_LOG@, which is conveniently saved in 'xmonadDefProp'.+-- You can use another property by using the function 'statusBarPropTo'.+--+-- If your status bar does not support property-based logging, you may also try+-- 'statusBarPipe'.+-- It can be used in the same way as 'statusBarProp' above (for xmobar, you now+-- have to use the @StdinReader@ plugin in your @.xmobarrc@).  Instead of+-- writing to a property, this function opens a pipe and makes the given status+-- bar read from that pipe.+-- Please be aware that this kind of setup is very bug-prone and hence is+-- discouraged: if anything goes wrong with the bar, xmonad will freeze!+--+-- Also note that 'statusBarPipe' returns 'IO StatusBarConfig', so+-- you need to evaluate it before passing it to 'withSB' or 'withEasySB':+--+-- > main = do+-- >   mySB <- statusBarPipe "xmobar" (pure myPP)+-- >   xmonad $ withSB mySB myConf+++-- $plumbing+-- If you do not want to use any of the "batteries included" functions above,+-- you can also add all of the necessary plumbing yourself (the source of+-- 'withSB' might come in handy here).+--+-- 'xmonadPropLog' allows you to write a string to the @_XMONAD_LOG@ property of+-- the root window.  Together with 'dynamicLogString', you can now simply set+-- your 'logHook' to the appropriate function; for instance:+--+-- > main = xmonad $ def {+-- >    ...+-- >    , logHook = xmonadPropLog =<< dynamicLogString myPP+-- >    ...+-- >    }+--+-- If you want to define your own property name, use 'xmonadPropLog'' instead of+-- 'xmonadPropLog'.+--+-- If you just want to use the default pretty-printing format, you can replace+-- @myPP@ with 'def' in the above 'logHook'.+--+-- Note that setting 'logHook' only sets up xmonad's output; you are+-- responsible for starting your own status bar program and making sure it reads+-- from the property that xmonad writes to.  To start your bar, simply put it+-- into your 'startupHook'.  You will also have also have to add 'docks' and+-- 'avoidStruts' to your config.  Putting all of this together would look+-- something like+--+-- > import XMonad.Util.SpawnOnce (spawnOnce)+-- > import XMonad.Hooks.ManageDocks (avoidStruts, docks)+-- >+-- > main = do+-- >     xmonad $ docks $ def {+-- >       ...+-- >       , logHook     = xmonadPropLog =<< dynamicLogString myPP+-- >       , startupHook = spawnOnce "xmobar"+-- >       , layoutHook  = avoidStruts myLayout+-- >       ...+-- >       }+-- > myPP = def { ... }+-- > myLayout = ...+--+-- If you want a keybinding to toggle your bar, you will also need to add this+-- to the rest of your keybindings.+--+-- The above has the problem that xmobar will not get restarted whenever you+-- restart xmonad ('XMonad.Util.SpawnOnce.spawnOnce' will simply prevent your+-- chosen status bar from spawning again). Using 'statusBarProp', however, takes+-- care of the necessary plumbing /and/ keeps track of the started status bars, so+-- they can be correctly restarted with xmonad. This is achieved using+-- 'spawnStatusBar' to start them and 'killStatusBar' to kill+-- previously started bars.+--+-- Even if you don't use a status bar, you can still use 'dynamicLogString' to+-- show on-screen notifications in response to some events. For example, to show+-- the current layout when it changes, you could make a keybinding to cycle the+-- layout and display the current status:+--+-- > ((mod1Mask, xK_a), sendMessage NextLayout >> (dynamicLogString myPP >>= xmessage))+--+-- If you use a status bar that does not support reading from a property+-- (like dzen), and you don't want to use the 'statusBar' function, you can,+-- again, also manually add all of the required components, like this:+--+-- > import XMonad.Util.Run (hPutStrLn, spawnPipe)+-- >+-- > main = do+-- >     h <- spawnPipe "dzen2 -options -foo -bar"+-- >     xmonad $ def {+-- >       ...+-- >       , logHook = dynamicLogWithPP $ def { ppOutput = hPutStrLn h }+-- >       ...+-- >       }+--+-- In the above, note that if you use @spawnPipe@ you need to redefine the+-- 'ppOutput' field of your pretty-printer; by default the status will be+-- printed to stdout rather than the pipe you create. This was meant to be+-- used together with running xmonad piped to a status bar like so: @xmonad |+-- dzen2@, and is what the old 'XMonad.Hooks.DynamicLog.dynamicLog' assumes,+-- but it isn't recommended in modern setups. Applications launched from+-- xmonad inherit its stdout and stderr, and will print their own garbage to+-- the status bar.+++-- | This datataype abstracts a status bar to provide a common interface+-- functions like 'statusBarPipe' or 'statusBarProp'. Once defined, a status+-- bar can be incorporated in 'XConfig' by using 'withSB' or+-- 'withEasySB', which take care of the necessary plumbing.+data StatusBarConfig = StatusBarConfig  { sbLogHook     :: X ()+                                        -- ^ What and how to log to the status bar.+                                        , sbStartupHook :: X ()+                                        -- ^ How to start the status bar.+                                        , sbCleanupHook :: X ()+                                        -- ^ How to kill the status bar.+                                        }++instance Semigroup StatusBarConfig where+    StatusBarConfig l s c <> StatusBarConfig l' s' c' =+      StatusBarConfig (l <> l') (s <> s') (c <> c')++instance Monoid StatusBarConfig where+    mempty = StatusBarConfig mempty mempty mempty++-- | Per default, all the hooks do nothing.+instance Default StatusBarConfig where+    def = mempty++-- | Incorporates a 'StatusBarConfig' into an 'XConfig' by taking care of the+-- necessary plumbing (starting, restarting and logging to it).+--+-- Using this function multiple times to combine status bars may result in+-- only one status bar working properly. See the section on using multiple+-- status bars for more details.+withSB :: LayoutClass l Window+       => StatusBarConfig    -- ^ The status bar config+       -> XConfig l          -- ^ The base config+       -> XConfig l+withSB (StatusBarConfig lh sh ch) conf = conf+    { logHook     = logHook conf *> lh+    , startupHook = startupHook conf *> ch *> sh+    }++-- | Like 'withSB', but takes an extra key to toggle struts. It also+-- applies the 'avoidStruts' layout modifier and the 'docks' combinator.+--+-- Using this function multiple times to combine status bars may result in+-- only one status bar working properly. See the section on using multiple+-- status bars for more details.+withEasySB :: LayoutClass l Window+           => StatusBarConfig -- ^ The status bar config+           -> (XConfig Layout -> (KeyMask, KeySym))+                              -- ^ The key binding+           -> XConfig l       -- ^ The base config+           -> XConfig (ModifiedLayout AvoidStruts l)+withEasySB sb k conf = docks . withSB sb $ conf+    { layoutHook = avoidStruts (layoutHook conf)+    , keys       = (<>) <$> keys' <*> keys conf+    }+  where+    k' conf' = case k conf' of+        (0, 0) ->+            -- This usually means the user passed 'def' for the keybinding+            -- function, and is otherwise meaningless to harmful depending on+            -- whether 383ffb7 has been applied to xmonad or not. So do what+            -- they probably intend.+            --+            -- A user who wants no keybinding function should probably use+            -- 'withSB' instead, especially since NoSymbol didn't do anything+            -- sane before 383ffb7. ++bsa+            defToggleStrutsKey conf'+        key -> key+    keys' = (`M.singleton` sendMessage ToggleStruts) . k'++-- | Default @mod-b@ key binding for 'withEasySB'+defToggleStrutsKey :: XConfig t -> (KeyMask, KeySym)+defToggleStrutsKey XConfig{modMask = modm} = (modm, xK_b)++-- | Creates a 'StatusBarConfig' that uses property logging to @_XMONAD_LOG@, which+-- is set in 'xmonadDefProp'+statusBarProp :: String -- ^ The command line to launch the status bar+              -> X PP   -- ^ The pretty printing options+              -> StatusBarConfig+statusBarProp = statusBarPropTo xmonadDefProp++-- | Like 'statusBarProp', but lets you define the property+statusBarPropTo :: String -- ^ Property to write the string to+                -> String -- ^ The command line to launch the status bar+                -> X PP   -- ^ The pretty printing options+                -> StatusBarConfig+statusBarPropTo prop cmd pp = statusBarGeneric cmd $+    xmonadPropLog' prop =<< dynamicLogString =<< pp++-- | A generic 'StatusBarConfig' that launches a status bar but takes a+-- generic @X ()@ logging function instead of a 'PP'. This has several uses:+--+-- * With 'xmonadPropLog' or 'xmonadPropLog'' in the logging function, a+--   custom non-'PP'-based logger can be used for logging into an @xmobar@.+--+-- * With 'mempty' as the logging function, it's possible to manage a status+--   bar that reads information from EWMH properties like @taffybar@.+--+-- * With 'mempty' as the logging function, any other dock like @trayer@ or+--   @stalonetray@ can be managed by this module.+statusBarGeneric :: String -- ^ The command line to launch the status bar+                 -> X ()   -- ^ What and how to log to the status bar ('sbLogHook')+                 -> StatusBarConfig+statusBarGeneric cmd lh = def+    { sbLogHook     = lh+    , sbStartupHook = spawnStatusBar cmd+    , sbCleanupHook = killStatusBar cmd+    }++-- | Like 'statusBarProp', but uses pipe-based logging instead.+statusBarPipe :: String -- ^ The command line to launch the status bar+              -> X PP   -- ^ The pretty printing options+              -> IO StatusBarConfig+statusBarPipe cmd xpp = do+    hRef <- newIORef Nothing+    return $ def+        { sbStartupHook = io (writeIORef hRef . Just =<< spawnPipe cmd)+        , sbLogHook     = do+              h' <- io (readIORef hRef)+              whenJust h' $ \h -> io . hPutStrLn h =<< dynamicLogString =<< xpp+        , sbCleanupHook = io+                          $   readIORef hRef+                          >>= (`whenJust` hClose)+                          >>  writeIORef hRef Nothing+        }+++-- $multiple+-- 'StatusBarConfig' is a 'Monoid', which means that multiple status bars can+-- be combined together using '<>' or 'mconcat' and passed to 'withSB'.+--+-- Here's an example of what such declarative configuration of multiple status+-- bars may look like:+--+-- > -- Make sure to setup the xmobar configs accordingly+-- > xmobarTop    = statusBarPropTo "_XMONAD_LOG_1" "xmobar -x 0 ~/.config/xmobar/xmobarrc_top"    (pure ppTop)+-- > xmobarBottom = statusBarPropTo "_XMONAD_LOG_2" "xmobar -x 0 ~/.config/xmobar/xmobarrc_bottom" (pure ppBottom)+-- > xmobar1      = statusBarPropTo "_XMONAD_LOG_3" "xmobar -x 1 ~/.config/xmobar/xmobarrc1"       (pure pp1)+-- >+-- > main = xmonad $ withSB (xmobarTop <> xmobarBottom <> xmobar1) myConfig+--+-- And here is an example of the related xmobar configuration for the multiple+-- status bars mentioned above:+--+-- > xmobarrc_top+-- > Config { ...+-- >        , commands = [ Run XPropertyLog "_XMONAD_LOG_1", ... ]+-- >        , template = "%_XMONAD_LOG_1% }{ ..."+-- >        }+--+-- The above example also works if the different status bars support different+-- logging methods: you could mix property logging and logging via pipes.+-- One thing to keep in mind is that if multiple bars read from the same+-- property, their content will be the same. If you want to use property-based+-- logging with multiple bars, they should read from different properties.+--+-- "XMonad.Util.Loggers" includes loggers that can be bound to specific screens,+-- like 'logCurrentOnScreen', that might be useful with multiple screens.+--+-- Long-time xmonad users will note that the above config is equivalent to+-- the following less robust and more verbose configuration that they might+-- find in their old configs:+--+-- > main = do+-- >   -- do not use this, this is an example of a deprecated config+-- >   xmproc0 <- spawnPipe "xmobar -x 0 ~/.config/xmobar/xmobarrc_top"+-- >   xmproc1 <- spawnPipe "xmobar -x 0 ~/.config/xmobar/xmobarrc_bottom"+-- >   xmproc2 <- spawnPipe "xmobar -x 1 ~/.config/xmobar/xmobarrc1"+-- >   xmonad $ def {+-- >     ...+-- >     , logHook = dynamicLogWithPP ppTop { ppOutput = hPutStrLn xmproc0 }+-- >              >> dynamicLogWithPP ppBottom { ppOutput = hPutStrLn xmproc1 }+-- >              >> dynamicLogWithPP pp1 { ppOutput = hPutStrLn xmproc2 }+-- >     ...+-- >   }+--+-- By using the new interface, the config becomes more declarative and there's+-- less room for errors.+--+-- The only *problem* now is that the status bars will not be updated when your screen+-- configuration changes (by plugging in a monitor, for example). Check the section+-- on dynamic status bars for how to do that.++-- $dynamic+-- Using multiple status bars by just combining them with '<>' works well+-- as long as the screen configuration does not change often. If it does,+-- you should use 'dynamicSBs': by providing a function that creates+-- status bars, it takes care of setting up the event hook, the log hook+-- and the startup hook necessary to make the status bars, well, dynamic.+--+-- > xmobarTop    = statusBarPropTo "_XMONAD_LOG_1" "xmobar -x 0 ~/.config/xmobar/xmobarrc_top"    (pure ppTop)+-- > xmobarBottom = statusBarPropTo "_XMONAD_LOG_2" "xmobar -x 0 ~/.config/xmobar/xmobarrc_bottom" (pure ppBottom)+-- > xmobar1      = statusBarPropTo "_XMONAD_LOG_3" "xmobar -x 1 ~/.config/xmobar/xmobarrc1"       (pure pp1)+-- >+-- > barSpawner :: ScreenId -> StatusBarConfig+-- > barSpawner 0 = xmobarTop <> xmobarBottom -- two bars on the main screen+-- > barSpawner 1 = xmobar1+-- > barSpawner _ = mempty -- nothing on the rest of the screens+-- >+-- > main = xmonad $ dynamicSBs (pure . barSpawner) (def { ... })+--+-- Make sure you specify which screen to place the status bar on (in xmobar,+-- this is achieved by the @-x@ argument). In addition to making sure that your+-- status bar lands where you intended it to land, the commands are used+-- internally to keep track of the status bars.+--+-- Note also that this interface can be used with one screen, or if+-- the screen configuration doesn't change.++newtype ActiveSBs = ASB {getASBs :: [(ScreenId,  StatusBarConfig)]}++instance ExtensionClass ActiveSBs where+  initialValue = ASB []++-- | Given a function to create status bars, 'dynamicSBs'+-- adds the dynamic status bar capabilities to the config.+-- For a version of this function that applies 'docks' and+-- 'avoidStruts', check 'dynamicEasySBs'.+--+-- Heavily inspired by "XMonad.Hooks.DynamicBars"+dynamicSBs :: (ScreenId -> X StatusBarConfig) -> XConfig l -> XConfig l+dynamicSBs f conf = addAfterRescreenHook (updateSBs f) $ conf+  { startupHook = startupHook conf >> killAllStatusBars >> updateSBs f+  , logHook     = logHook conf >> logSBs+  }++-- | Like 'dynamicSBs', but applies 'docks' to the+-- resulting config and adds 'avoidStruts' to the+-- layout.+dynamicEasySBs :: LayoutClass l Window+               => (ScreenId -> X StatusBarConfig)+               -> XConfig l+               -> XConfig (ModifiedLayout AvoidStruts l)+dynamicEasySBs f conf =+  docks . dynamicSBs f $ conf { layoutHook = avoidStruts (layoutHook conf) }++-- | Given the function to create status bars, update+-- the status bars by killing those that shouldn't be+-- visible anymore and creates any missing status bars+updateSBs :: (ScreenId -> X StatusBarConfig) -> X ()+updateSBs f = do+  actualScreens    <- withWindowSet $ return . map W.screen . W.screens+  (toKeep, toKill) <-+    partition ((`elem` actualScreens) . fst) . getASBs <$> XS.get+  -- Kill the status bars+  cleanSBs (map snd toKill)+  -- Create new status bars if needed+  let missing = actualScreens \\ map fst toKeep+  added <- traverse (\s -> (s,) <$> f s) missing+  traverse_ (sbStartupHook . snd) added+  XS.put (ASB (toKeep ++ added))++-- | Run 'sbLogHook' for the saved 'StatusBarConfig's+logSBs :: X ()+logSBs = XS.get >>= traverse_ (sbLogHook . snd) . getASBs++-- | Kill the given 'StatusBarConfig's from the given+-- list+cleanSBs :: [StatusBarConfig] -> X ()+cleanSBs = traverse_ sbCleanupHook++-- | The default property xmonad writes to. (@_XMONAD_LOG@).+xmonadDefProp :: String+xmonadDefProp = "_XMONAD_LOG"++-- | Write a string to the @_XMONAD_LOG@ property on the root window.+xmonadPropLog :: String -> X ()+xmonadPropLog = xmonadPropLog' xmonadDefProp++-- | Write a string to a property on the root window.  This property is of type+-- @UTF8_STRING@.+xmonadPropLog' :: String  -- ^ Property name+               -> String  -- ^ Message to be written to the property+               -> X ()+xmonadPropLog' prop msg = do+    d <- asks display+    r <- asks theRoot+    xlog <- getAtom prop+    ustring <- getAtom "UTF8_STRING"+    io $ changeProperty8 d r xlog ustring propModeReplace (encodeCChar msg)+ where+    encodeCChar :: String -> [CChar]+    encodeCChar = map fromIntegral . UTF8.encode+++-- This newtype wrapper, together with the ExtensionClass instance make use of+-- the extensible state to save the PIDs bewteen xmonad restarts.+newtype StatusBarPIDs = StatusBarPIDs { getPIDs :: M.Map String ProcessID }+  deriving (Show, Read)++instance ExtensionClass StatusBarPIDs where+  initialValue = StatusBarPIDs mempty+  extensionType = PersistentExtension++-- | Kills the status bar started with 'spawnStatusBar' using the given command+-- and resets the state. This could go for example at the beginning of the+-- startupHook, to kill the status bars that need to be restarted.+--+-- Concretely, this function sends a 'sigTERM' to the saved PIDs using+-- 'signalProcessGroup' to effectively terminate all processes, regardless+-- of how many were started by using  'spawnStatusBar'.+--+-- There is one caveat to keep in mind: to keep the implementation simple;+-- no checks are executed before terminating the processes. This means: if the+-- started process dies for some reason, and enough time passes for the PIDs+-- to wrap around, this function might terminate another process that happens+-- to have the same PID. However, this isn't a typical usage scenario.+killStatusBar :: String -- ^ The command used to start the status bar+                 -> X ()+killStatusBar cmd = do+    XS.gets (M.lookup cmd . getPIDs) >>= flip whenJust (io . killPid)+    XS.modify (StatusBarPIDs . M.delete cmd . getPIDs)++killPid :: ProcessID -> IO ()+killPid pidToKill = void $ try @SomeException (signalProcessGroup sigTERM pidToKill)++-- | Spawns a status bar and saves its PID together with the commands that was+-- used to start it. This is useful when the status bars should be restarted+-- with xmonad. Use this in combination with 'killStatusBar'.+--+-- Note: in some systems, multiple processes might start, even though one command is+-- provided. This means the first PID, of the group leader, is saved.+spawnStatusBar :: String -- ^ The command used to spawn the status bar+               -> X ()+spawnStatusBar cmd = do+  newPid <- spawnPID cmd+  XS.modify (StatusBarPIDs . M.insert cmd newPid . getPIDs)++-- | Kill all status bars started with 'spawnStatusBar'. Note the+-- caveats in 'cleanupStatusBar'+killAllStatusBars :: X ()+killAllStatusBars =+  XS.gets (M.elems . getPIDs) >>= io . traverse_ killPid >> XS.put (StatusBarPIDs mempty)++-- | Start all status bars. Note that you do not need this in your startup hook.+-- This can be bound to a keybinding for example to be used in tandem with+-- `killAllStatusBars`.+startAllStatusBars :: X ()+startAllStatusBars = XS.get >>= traverse_ (sbStartupHook . snd) . getASBs
+ XMonad/Hooks/StatusBar/PP.hs view
@@ -0,0 +1,559 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE FlexibleContexts    #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.StatusBar.PP+-- Description :  The pretty-printing abstraction for handling status bars.+-- Copyright   :  (c) Don Stewart <dons@cse.unsw.edu.au>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Don Stewart <dons@cse.unsw.edu.au>+-- Stability   :  unstable+-- Portability :  unportable+--+-- xmonad calls the logHook with every internal state update, which is+-- useful for (among other things) outputting status information to an+-- external status bar program such as xmobar or dzen.+--+-- This module provides a pretty-printing abstraction and utilities that can+-- be used to customize what is logged to a status bar. See+-- "XMonad.Hooks.StatusBar" for an abstraction over starting these status+-- bars. Together these are a modern replacement for+-- "XMonad.Hooks.DynamicLog", which is now just a compatibility wrapper.+--+-----------------------------------------------------------------------------++module XMonad.Hooks.StatusBar.PP (+    -- * Usage+    -- $usage++    -- * Build your own formatter+    PP(..), def,+    dynamicLogString,+    dynamicLogString',+    dynamicLogWithPP,++    -- * Predicates and formatters+    -- $predicates+    WS(..), WSPP, WSPP', fallbackPrinters,+    isUrgent, isCurrent, isVisible, isVisibleNoWindows, isHidden,++    -- * Example formatters+    dzenPP, xmobarPP, sjanssenPP, byorgeyPP,++    -- * Formatting utilities+    wrap, pad, trim, shorten, shorten', shortenLeft, shortenLeft',+    xmobarColor, xmobarFont, xmobarAction, xmobarBorder,+    xmobarRaw, xmobarStrip, xmobarStripTags,+    dzenColor, dzenEscape, dzenStrip, filterOutWsPP,++    -- * Internal formatting functions+    pprWindowSet,+    pprWindowSetXinerama++    ) where++import Control.Monad.Reader+import Control.DeepSeq+import qualified Data.List.NonEmpty as NE++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as S++import XMonad.Util.NamedWindows+import XMonad.Util.WorkspaceCompare+import XMonad.Hooks.UrgencyHook++-- $usage+-- An example usage for this module would be:+--+-- > import XMonad+-- > import XMonad.Hooks.StatusBar+-- > import XMonad.Hooks.StatusBar.PP+-- >+-- > myPP = def { ppCurrent = xmobarColor "black" "white" }+-- > mySB = statusBarProp "xmobar" (pure myPP)+-- > main = xmonad . withEasySB mySB defToggleStrutsKey $ myConfig+--+-- Check "XMonad.Hooks.StatusBar" for more examples and an in depth+-- explanation.++-- | The 'PP' type allows the user to customize the formatting of+--   status information.+data PP = PP { ppCurrent :: WorkspaceId -> String+               -- ^ how to print the tag of the currently focused+               -- workspace+             , ppVisible :: WorkspaceId -> String+               -- ^ how to print tags of visible but not focused+               -- workspaces (xinerama only)+             , ppHidden  :: WorkspaceId -> String+               -- ^ how to print tags of hidden workspaces which+               -- 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.+             , ppRename :: String -> WindowSpace -> String+               -- ^ rename/augment the workspace tag+               --   (note that @WindowSpace -> …@ acts as a Reader monad)+             , ppSep :: String+               -- ^ separator to use between different log sections+               -- (window name, layout, workspaces)+             , ppWsSep :: String+               -- ^ separator to use between workspace tags+             , ppTitle :: String -> String+               -- ^ window title format for the focused window. To display+               -- the titles of all windows—even unfocused ones—check+               -- 'XMonad.Util.Loggers.logTitles'.+             , ppTitleSanitize :: String -> String+              -- ^ escape / sanitizes input to 'ppTitle'+             , ppLayout :: String -> String+               -- ^ layout name format+             , ppOrder :: [String] -> [String]+               -- ^ how to order the different log sections. By+               --   default, this function receives a list with three+               --   formatted strings, representing the workspaces,+               --   the layout, and the current window titles,+               --   respectively. If you have specified any extra+               --   loggers in 'ppExtras', their output will also be+               --   appended to the list.  To get them in the reverse+               --   order, you can just use @ppOrder = reverse@.  If+               --   you don't want to display the current layout, you+               --   could use something like @ppOrder = \\(ws:_:t:_) ->+               --   [ws,t]@, and so on.+             , ppSort :: X ([WindowSpace] -> [WindowSpace])+               -- ^ how to sort the workspaces.  See+               -- "XMonad.Util.WorkspaceCompare" for some useful+               -- sorts.+             , ppExtras :: [X (Maybe String)]+               -- ^ loggers for generating extra information such as+               -- time and date, system load, battery status, and so+               -- on.  See "XMonad.Util.Loggers" for examples, or create+               -- your own!+             , ppOutput :: String -> IO ()+               -- ^ applied to the entire formatted string in order to+               -- output it.  Can be used to specify an alternative+               -- output method (e.g. write to a pipe instead of+               -- stdout), and\/or to perform some last-minute+               -- formatting. Note that this is only used by+               -- 'dynamicLogWithPP'; it won't work with 'dynamicLogString' or+               -- "XMonad.Hooks.StatusBar".+             , ppPrinters :: WSPP+               -- ^ extend workspace types with custom predicates.+               -- Check $predicates for more details.+             }++-- | The default pretty printing options:+--+-- > 1 2 [3] 4 7 : full : title+--+-- That is, the currently populated workspaces, the current+-- workspace layout, and the title of the focused window.+instance Default PP where+  def = PP { ppCurrent          = wrap "[" "]"+           , ppVisible          = wrap "<" ">"+           , ppHidden           = id+           , ppHiddenNoWindows  = const ""+           , ppVisibleNoWindows = Nothing+           , ppUrgent           = id+           , ppRename           = pure+           , ppSep              = " : "+           , ppWsSep            = " "+           , ppTitle            = shorten 80+           , ppTitleSanitize    = xmobarStrip . dzenEscape+           , ppLayout           = id+           , ppOrder            = id+           , ppOutput           = putStrLn+           , ppSort             = getSortByIndex+           , ppExtras           = []+           , ppPrinters         = empty+           }++-- | Format the current status using the supplied pretty-printing format,+--   and write it to stdout.+dynamicLogWithPP :: PP -> X ()+dynamicLogWithPP pp = dynamicLogString pp >>= io . ppOutput pp++-- | The same as 'dynamicLogWithPP', except it simply returns the status+--   as a formatted string without actually printing it to stdout, to+--   allow for further processing, or use in some application other than+--   a status bar.+dynamicLogString :: PP -> X String+dynamicLogString pp = userCodeDef "_|_" (dynamicLogString' pp)++-- | The guts of 'dynamicLogString'. Forces the result, so it may throw+--   an exception (most commonly because 'ppOrder' is non-total). Use+--   'dynamicLogString' for a version that catches the exception and+--   produces an error string.+dynamicLogString' :: PP -> X String+dynamicLogString' pp = do++    winset <- gets windowset+    urgents <- readUrgents+    sort' <- ppSort pp++    -- layout description+    let ld = description . S.layout . S.workspace . S.current $ winset++    -- workspace list+    let ws = pprWindowSet sort' urgents pp winset++    -- run extra loggers, ignoring any that generate errors.+    extras <- mapM (userCodeDef Nothing) $ ppExtras pp++    -- window title+    wt <- maybe (pure "") (fmap show . getName) . S.peek $ winset++    return $! force $ sepBy (ppSep pp) . ppOrder pp $+                        [ ws+                        , ppLayout pp ld+                        , ppTitle  pp $ ppTitleSanitize pp wt+                        ]+                        ++ catMaybes extras++-- | Format the workspace information, given a workspace sorting function,+--   a list of urgent windows, a pretty-printer format, and the current+--   WindowSet.+pprWindowSet :: WorkspaceSort -> [Window] -> PP -> WindowSet -> String+pprWindowSet sort' urgents pp s = sepBy (ppWsSep pp) . map fmt . sort' $+            map S.workspace (S.current s : S.visible s) ++ S.hidden s+  where+    fmt :: WindowSpace -> String+    fmt w = pr (ppRename pp (S.tag w) w)+      where+        printers = ppPrinters pp <|> fallbackPrinters+        pr = fromMaybe id $ runReaderT printers $+            WS{ wsUrgents = urgents, wsWindowSet = s, wsWS = w, wsPP = pp }++-- $predicates+-- Using 'WSPP' with 'ppPrinters' allows extension modules (and users) to+-- extend 'PP' with new workspace types beyond 'ppCurrent', 'ppUrgent', and+-- the rest.++-- | The data available to 'WSPP''.+data WS = WS{ wsUrgents :: [Window] -- ^ Urgent windows+            , wsWindowSet :: WindowSet -- ^ The entire 'WindowSet', for context+            , wsWS :: WindowSpace -- ^ The 'WindowSpace' being formatted+            , wsPP :: PP -- ^ The actual final 'PP'+            }++-- XXX: ReaderT instead of -> because there is no+--+-- > instance Alternative (Λa. r -> Maybe a)+--+-- (there cannot be, Haskell has no Λ), and there is no+--+-- > instance Alternative (Compose ((->) r) Maybe)+--+-- either, and even if there was, Compose isn't very practical.+--+-- But we don't need Alternative for WS -> Bool, so we use the simple+-- function-based reader for the condition functions, as their definitions are+-- much prettier that way. This may be a bit confusing. :-/+type WSPP' = ReaderT WS Maybe++-- | The type allowing to build formatters (and predicates). See+-- the source 'fallbackPrinters' for an example.+type WSPP = WSPP' (WorkspaceId -> String)++-- | For a 'PP' @pp@, @fallbackPrinters pp@ returns the default 'WSPP'+-- used to format workspaces: the formatter chosen corresponds to the+-- first matching workspace type, respecting the following precedence:+-- 'ppUrgent', 'ppCurrent', 'ppVisible', 'ppVisibleNoWindows', 'ppHidden',+-- 'ppHiddenNoWindows'.+--+-- This can be useful if one needs to use the default set of formatters and+-- post-process their output. (For pre-processing their input, there's+-- 'ppRename'.)+fallbackPrinters :: WSPP+fallbackPrinters = isUrgent            ?-> ppUrgent+               <|> isCurrent'          ?-> ppCurrent+               <|> isVisible'          ?-> ppVisible+               <|> isVisibleNoWindows' ?-> liftA2 fromMaybe ppVisible ppVisibleNoWindows+               <|> isHidden'           ?-> ppHidden+               <|> pure True           ?-> ppHiddenNoWindows+  where+    cond ?-> ppr = (asks cond >>= guard) *> asks (ppr . wsPP)++-- | Predicate for urgent workspaces.+isUrgent :: WS -> Bool+isUrgent WS{..} = any (\x -> (== Just (S.tag wsWS)) (S.findTag x wsWindowSet)) wsUrgents++-- | Predicate for the current workspace. Caution: assumes default+-- precedence is respected.+isCurrent' :: WS -> Bool+isCurrent' WS{..} = S.tag wsWS == S.currentTag wsWindowSet++-- | Predicate for the current workspace.+isCurrent :: WS -> Bool+isCurrent = (not <$> isUrgent) <&&> isCurrent'++-- | Predicate for visible workspaces. Caution: assumes default+-- precedence is respected.+isVisible' :: WS -> Bool+isVisible' = isVisibleNoWindows' <&&> isJust . S.stack . wsWS++-- | Predicate for visible workspaces.+isVisible :: WS -> Bool+isVisible = (not <$> isUrgent) <&&> (not <$> isCurrent') <&&> isVisible'++-- | Predicate for visible workspaces that have no windows. Caution:+-- assumes default precedence is respected.+isVisibleNoWindows' :: WS -> Bool+isVisibleNoWindows' WS{..} = S.tag wsWS `elem` visibles+  where visibles = map (S.tag . S.workspace) (S.visible wsWindowSet)++-- | Predicate for visible workspaces that have no windows.+isVisibleNoWindows :: WS -> Bool+isVisibleNoWindows =+    (not <$> isUrgent)+        <&&> (not <$> isCurrent')+        <&&> (not <$> isVisible')+        <&&> isVisibleNoWindows'++-- | Predicate for non-empty hidden workspaces. Caution: assumes default+-- precedence is respected.+isHidden' :: WS -> Bool+isHidden' = isJust . S.stack . wsWS++-- | Predicate for hidden workspaces.+isHidden :: WS -> Bool+isHidden =+    (not <$> isUrgent)+        <&&> (not <$> isCurrent')+        <&&> (not <$> isVisible')+        <&&> (not <$> isVisibleNoWindows')+        <&&> isHidden'++pprWindowSetXinerama :: WindowSet -> String+pprWindowSetXinerama ws = "[" ++ unwords onscreen ++ "] " ++ unwords offscreen+  where onscreen  = map (S.tag . S.workspace)+                        . sortOn S.screen $ S.current ws : S.visible ws+        offscreen = map S.tag . filter (isJust . S.stack)+                        . sortOn S.tag $ S.hidden ws++-- | Wrap a string in delimiters, unless it is empty.+wrap :: String  -- ^ left delimiter+     -> String  -- ^ right delimiter+     -> String  -- ^ output string+     -> String+wrap _ _ "" = ""+wrap l r m  = l ++ m ++ r++-- | Pad a string with a leading and trailing space.+pad :: String -> String+pad = wrap " " " "++-- | Trim leading and trailing whitespace from a string.+trim :: String -> String+trim = f . f+    where f = reverse . dropWhile isSpace++-- | Limit a string to a certain length, adding "..." if truncated.+shorten :: Int -> String -> String+shorten = shorten' "..."++-- | Limit a string to a certain length, adding @end@ if truncated.+shorten' :: String -> Int -> String -> String+shorten' end n xs | length xs < n = xs+                  | otherwise     = take (n - length end) xs ++ end++-- | Like 'shorten', but truncate from the left instead of right.+shortenLeft :: Int -> String -> String+shortenLeft = shortenLeft' "..."++-- | Like 'shorten'', but truncate from the left instead of right.+shortenLeft' :: String -> Int -> String -> String+shortenLeft' end n xs | l < n     = xs+                      | otherwise = end ++ drop (l - n + length end) xs+ where l = length xs++-- | Output a list of strings, ignoring empty ones and separating the+--   rest with the given separator.+sepBy :: String   -- ^ separator+      -> [String] -- ^ fields to output+      -> String+sepBy sep = intercalate sep . filter (not . null)++-- | Use dzen escape codes to output a string with given foreground+--   and background colors.+dzenColor :: String  -- ^ foreground color: a color name, or #rrggbb format+          -> String  -- ^ background color+          -> String  -- ^ output string+          -> String+dzenColor fg bg = wrap (fg1++bg1) (fg2++bg2)+ where (fg1,fg2) | null fg = ("","")+                 | otherwise = ("^fg(" ++ fg ++ ")","^fg()")+       (bg1,bg2) | null bg = ("","")+                 | otherwise = ("^bg(" ++ bg ++ ")","^bg()")++-- | Escape any dzen metacharacters.+dzenEscape :: String -> String+dzenEscape = concatMap (\x -> if x == '^' then "^^" else [x])++-- | Strip dzen formatting or commands.+dzenStrip :: String -> String+dzenStrip = strip [] where+    strip keep x+      | null x              = keep+      | "^^" `isPrefixOf` x = strip (keep ++ "^") (drop 2 x)+      | "^"  `isPrefixOf` x = strip keep (drop 1 . dropWhile (/= ')') $ x)+      | otherwise           = let (good,x') = span (/= '^') x+                              in strip (keep ++ good) x'++-- | Use xmobar escape codes to output a string with the font at the given index+xmobarFont :: Int     -- ^ index: index of the font to use (0: standard font)+           -> String  -- ^ output string+           -> String+xmobarFont index = wrap ("<fn=" ++ show index ++ ">") "</fn>"++-- | Use xmobar escape codes to output a string with given foreground+--   and background colors.+xmobarColor :: String  -- ^ foreground color: a color name, or #rrggbb format+            -> String  -- ^ background color+            -> String  -- ^ output string+            -> String+xmobarColor fg bg = wrap t "</fc>"+ where t = concat ["<fc=", fg, if null bg then "" else "," ++ bg, ">"]++-- | Encapsulate text with an action. The text will be displayed, and the+-- action executed when the displayed text is clicked. Illegal input is not+-- filtered, allowing xmobar to display any parse errors. Uses xmobar's new+-- syntax wherein the command is surrounded by backticks.+xmobarAction :: String+                -- ^ Command. Use of backticks (`) will cause a parse error.+             -> String+                -- ^ Buttons 1-5, such as "145". Other characters will cause a+                -- parse error.+             -> String+                -- ^ Displayed/wrapped text.+             -> String+xmobarAction command button = wrap l r+    where+        l = "<action=`" ++ command ++ "` button=" ++ button ++ ">"+        r = "</action>"++-- | Use xmobar box to add a border to an arbitrary string.+xmobarBorder :: String -- ^ Border type. Possible values: VBoth, HBoth, Full,+                       -- Top, Bottom, Left or Right+             -> String -- ^ color: a color name, or #rrggbb format+             -> Int    -- ^ width in pixels+             -> String -- ^ output string+             -> String+xmobarBorder border color width = wrap prefix "</box>"+  where+    prefix = "<box type=" ++ border ++ " width=" ++ show width ++ " color="+      ++ color ++ ">"++-- | Encapsulate arbitrary text for display only, i.e. untrusted content if+-- wrapped (perhaps from window titles) will be displayed only, with all tags+-- ignored. Introduced in xmobar 0.21; see their documentation. Be careful not+-- to shorten the result.+xmobarRaw :: String -> String+xmobarRaw "" = ""+xmobarRaw s  = concat ["<raw=", show $ length s, ":", s, "/>"]++-- | Strip xmobar markup, specifically the \<fc\>, \<icon\> and \<action\> tags+-- and the matching tags like \</fc\>.+xmobarStrip :: String -> String+xmobarStrip = converge (xmobarStripTags ["fc","icon","action"])++converge :: (Eq a) => (a -> a) -> a -> a+converge f a+  = fst . NE.head . notEmpty -- If this function terminates, we will find a match.+  . dropWhile (uncurry (/=))+  . zip xs+  $ drop 1 xs+ where xs = iterate f a++xmobarStripTags :: [String] -- ^ tags+        -> String -> String -- ^ with all \<tag\>...\</tag\> removed+xmobarStripTags tags = strip [] where+    strip keep [] = keep+    strip keep x+        | rest: _ <- mapMaybe dropTag tags = strip keep rest+++        | '<':xs <- x = strip (keep ++ "<") xs+        | (good,x') <- span (/= '<') x = strip (keep ++ good) x' -- this is n^2 bad... but titles have few tags+      where dropTag :: String -> Maybe String+            dropTag tag = msum [fmap dropTilClose (openTag tag `stripPrefix` x),+                                                   closeTag tag `stripPrefix` x]++    dropTilClose, openTag, closeTag :: String -> String+    dropTilClose = drop 1 . dropWhile (/= '>')+    openTag str = "<" ++ str ++ "="+    closeTag str = "</" ++ str ++ ">"++-- | Transforms a pretty-printer into one not displaying the given workspaces.+--+-- For example, filtering out the @NSP@ workspace before giving the 'PP' to+-- 'dynamicLogWithPP':+--+-- > logHook = dynamicLogWithPP . filterOutWsPP [scratchpadWorkspaceTag] $ def+--+-- Here is another example, when using "XMonad.Layout.IndependentScreens".  If+-- you have handles @hLeft@ and @hRight@ for bars on the left and right screens,+-- respectively, and @pp@ is a pretty-printer function that takes a handle, you+-- could write+--+-- > logHook = let log screen handle = dynamicLogWithPP . filterOutWsPP [scratchpadWorkspaceTag] . marshallPP screen . pp $ handle+-- >           in log 0 hLeft >> log 1 hRight+filterOutWsPP :: [WorkspaceId] -> PP -> PP+filterOutWsPP ws pp = pp { ppSort = (. filterOutWs ws) <$> ppSort pp }++-- | Settings to emulate dwm's statusbar, dzen only.+dzenPP :: PP+dzenPP = def+  { ppCurrent         = dzenColor "white" "#2b4f98" . pad+  , ppVisible         = dzenColor "black" "#999999" . pad+  , ppHidden          = dzenColor "black" "#cccccc" . pad+  , ppHiddenNoWindows = const ""+  , ppUrgent          = dzenColor "red" "yellow" . pad+  , ppWsSep           = ""+  , ppSep             = ""+  , ppLayout          = dzenColor "black" "#cccccc"+                          . (\x -> pad $ case x of+                              "TilePrime Horizontal" -> "TTT"+                              "TilePrime Vertical"   -> "[]="+                              "Hinted Full"          -> "[ ]"+                              _                      -> x+                            )+  , ppTitle           = ("^bg(#324c80) " ++) . dzenEscape+  }++-- | Some nice xmobar defaults.+xmobarPP :: PP+xmobarPP = def { ppCurrent = xmobarColor "yellow" "" . wrap "[" "]"+               , ppTitle   = xmobarColor "green" "" . shorten 40+               , ppVisible = wrap "(" ")"+               , ppUrgent  = xmobarColor "red" "yellow"+               }++-- | The options that sjanssen likes to use with xmobar, as an+-- example.  Note the use of 'xmobarColor' and the record update on+-- 'def'.+sjanssenPP :: PP+sjanssenPP = def { ppCurrent = xmobarColor "white" "black"+                 , ppTitle   = xmobarColor "#00ee00" "" . shorten 120+                 }++-- | The options that byorgey likes to use with dzen, as another example.+byorgeyPP :: PP+byorgeyPP = def { ppHiddenNoWindows = showNamedWorkspaces+                , ppHidden          = dzenColor "black" "#a8a3f7" . pad+                , ppCurrent         = dzenColor "yellow" "#a8a3f7" . pad+                , ppUrgent          = dzenColor "red" "yellow" . pad+                , ppSep             = " | "+                , ppWsSep           = ""+                , ppTitle           = shorten 70+                , ppOrder           = reverse+                }+ where+  showNamedWorkspaces wsId =+    if any (`elem` wsId) ['a' .. 'z'] then pad wsId else ""
+ XMonad/Hooks/StatusBar/WorkspaceScreen.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}++{- |+ Module      :  XMonad.Hooks.StatusBar.WorkspaceScreen+ Description :  Combine workspace names with screen information+ Copyright   :  (c) Yecine Megdiche <yecine.megdiche@gmail.com>+ License     :  BSD3-style (see LICENSE)++ Maintainer  :  Yecine Megdiche <yecine.megdiche@gmail.com>+ Stability   :  unstable+ Portability :  unportable++ In multi-head setup, it might be useful to have screen information of the+ visible workspaces combined with the workspace name, for example in a status+ bar. This module provides utility functions to do just that.+-}+module XMonad.Hooks.StatusBar.WorkspaceScreen+    (+    -- * Usage+    -- $usage+      combineWithScreen+    , combineWithScreenName+    , combineWithScreenNumber+    , WorkspaceScreenCombiner+    -- * Limitations+    -- $limitations+    ) where++import           Graphics.X11.Xrandr+import           XMonad+import           XMonad.Hooks.StatusBar.PP+import           XMonad.Prelude+import qualified XMonad.StackSet               as W++{- $usage+ You can use this module with the following in your @xmonad.hs@:++ > import XMonad+ > import XMonad.Hooks.StatusBar+ > import XMonad.Hooks.StatusBar.PP+ > import XMonad.Hooks.StatusBar.WorkspaceScreen++ For example, to add the screen number in parentheses to each visible+ workspace number, you can use 'combineWithScreenNumber':++ > myWorkspaceScreenCombiner :: WorkspaceId -> String -> String+ > myWorkspaceScreenCombiner w sc = w <> wrap "(" ")" sc+ >+ > mySB = statusBarProp "xmobar" (combineWithScreenNumber myWorkspaceScreenCombiner xmobarPP)+ > main = xmonad $ withEasySB mySB defToggleStrutsKey def++ This will annotate the workspace names as following:++ > [1(0)] 2 3 4 <5(1)> 6 7 8 9++ To use the screen's name instead, checkout 'combineWithScreenName':++ > [1(eDP-1)] 2 3 4 <5(HDMI-1)> 6 7 8 9++ For advanced cases, use 'combineWithScreen'.+-}++{- $limitations+ For simplicity, this module assumes xmonad screen ids match screen/monitor+ numbers as managed by the X server (for example, as given by @xrandr+ --listactivemonitors@). Thus, it may not work well when screens show an+ overlapping range of the framebuffer, e.g. when using a projector. This also+ means that it doesn't work with "XMonad.Layout.LayoutScreens".+ (This isn't difficult to fix, PRs welcome.)+-}++-- | Type synonym for a function that combines a workspace name with a screen.+type WorkspaceScreenCombiner = WorkspaceId -> WindowScreen -> String++-- | A helper function that returns a list of screen names.+screenNames :: X [Maybe String]+screenNames = do+    XConf { display, theRoot } <- ask+    let getName mi = getAtomName display (xrr_moninf_name mi)+    io+        $   maybe (pure []) (traverse getName)+        =<< xrrGetMonitors display theRoot True++-- | Combine a workspace name with the screen name it's visible on.+combineWithScreenName :: (WorkspaceId -> String -> String) -> PP -> X PP+combineWithScreenName c = combineWithScreen $ do+    screens <- screenNames+    return $ \w sc -> maybe w (c w) $ join (screens !? fi (W.screen sc))++-- | Combine a workspace name with the screen number it's visible on.+combineWithScreenNumber :: (WorkspaceId -> String -> String) -> PP -> X PP+combineWithScreenNumber c =+    combineWithScreen . return $ \w sc -> c w (show @Int . fi . W.screen $ sc)++-- | Combine a workspace name with a screen according to the given+-- 'WorkspaceScreenCombiner'.+combineWithScreen :: X WorkspaceScreenCombiner -> PP -> X PP+combineWithScreen xCombiner pp = do+    combiner <- xCombiner+    ss       <- withWindowSet (return . W.screens)+    return $ pp+        { ppRename = ppRename pp <=< \s w ->+            maybe s (combiner s) (find ((== W.tag w) . W.tag . W.workspace) ss)+        }
+ XMonad/Hooks/TaffybarPagerHints.hs view
@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.TaffybarPagerHints+-- Description :  Export additional X properties for [taffybar](https://github.com/taffybar/taffybar).+-- Copyright   :  (c) 2020 Ivan Malison+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Ivan Malison <ivanmalison@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module exports additional X properties that allow+-- [taffybar](https://github.com/taffybar/taffybar) to understand the state of+-- XMonad.+--+-----------------------------------------------------------------------------++module XMonad.Hooks.TaffybarPagerHints (+    -- $usage+    pagerHints,+    pagerHintsLogHook,+    pagerHintsEventHook,++    setCurrentLayoutProp,+    setVisibleWorkspacesProp,+    ) where++import Codec.Binary.UTF8.String (encode)+import Foreign.C.Types (CInt)++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W++-- $usage+--+-- You can use this module with the following in your @xmonad.hs@ file:+--+-- > import XMonad.Hooks.TaffybarPagerHints (pagerHints)+-- >+-- > main = xmonad $ ewmh $ pagerHints $ def+-- > ...++-- | The \"Current Layout\" custom hint.+xLayoutProp :: X Atom+xLayoutProp = getAtom "_XMONAD_CURRENT_LAYOUT"++-- | The \"Visible Workspaces\" custom hint.+xVisibleProp :: X Atom+xVisibleProp = getAtom "_XMONAD_VISIBLE_WORKSPACES"++-- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom+-- hints to the given config.+pagerHints :: XConfig a -> XConfig a+pagerHints c =+  c { handleEventHook = handleEventHook c <> pagerHintsEventHook+    , logHook = logHook c <> pagerHintsLogHook+    }++-- | Update the current values of both custom hints.+pagerHintsLogHook :: X ()+pagerHintsLogHook = do+  withWindowSet+    (setCurrentLayoutProp . description . W.layout . W.workspace . W.current)+  withWindowSet+    (setVisibleWorkspacesProp . map (W.tag . W.workspace) . W.visible)++-- | Set the value of the \"Current Layout\" custom hint to the one given.+setCurrentLayoutProp :: String -> X ()+setCurrentLayoutProp l = withDisplay $ \dpy -> do+  r <- asks theRoot+  a <- xLayoutProp+  c <- getAtom "UTF8_STRING"+  let l' = map fromIntegral (encode l)+  io $ changeProperty8 dpy r a c propModeReplace l'++-- | Set the value of the \"Visible Workspaces\" hint to the one given.+setVisibleWorkspacesProp :: [String] -> X ()+setVisibleWorkspacesProp vis = withDisplay $ \dpy -> do+  r  <- asks theRoot+  a  <- xVisibleProp+  c  <- getAtom "UTF8_STRING"+  let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis+  io $ changeProperty8 dpy r a c propModeReplace vis'++-- | Handle all \"Current Layout\" events received from pager widgets, and+-- set the current layout accordingly.+pagerHintsEventHook :: Event -> X All+pagerHintsEventHook ClientMessageEvent+                      { ev_message_type = mt+                      , ev_data = d+                      } = withWindowSet $ \_ -> do+  a <- xLayoutProp+  when (mt == a) $ sendLayoutMessage d+  return (All True)+pagerHintsEventHook _ = return (All True)++-- | Request a change in the current layout by sending an internal message+-- to XMonad.+sendLayoutMessage :: [CInt] -> X ()+sendLayoutMessage (x:_) | x < 0     = sendMessage FirstLayout+                        | otherwise = sendMessage NextLayout+sendLayoutMessage [] = return ()
XMonad/Hooks/ToggleHook.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.ToggleHook+-- Description :  Hook and keybindings for toggling hook behavior. -- Copyright   :  Ben Boeckel <mathstuf@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -30,7 +30,7 @@                                , willHookNext                                , willHookAllNew -                                 -- * 'DynamicLog' utilities+                                 -- * Status bar utilities                                  -- $pp                                , willHookNextPP                                , willHookAllNewPP@@ -39,10 +39,9 @@ import Prelude hiding (all)  import XMonad+import XMonad.Prelude (guard, join) import qualified XMonad.Util.ExtensibleState as XS -import Control.Monad (join,guard)-import Control.Applicative ((<$>)) import Control.Arrow (first, second)  import Data.Map@@ -63,7 +62,7 @@  {- The current state is kept here -} -data HookState = HookState { hooks :: Map String (Bool, Bool) } deriving (Typeable, Read, Show)+newtype HookState = HookState { hooks :: Map String (Bool, Bool) } deriving (Read, Show)  instance ExtensionClass HookState where     initialValue = HookState empty@@ -78,19 +77,19 @@ -- This module provides actions (that can be set as keybindings) -- to be able to cause hooks to be occur on a conditional basis. ----- You can use it by including the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use it by including the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.ToggleHook -- -- and adding 'toggleHook name hook' to your 'ManageHook' where @name@ is the -- name of the hook and @hook@ is the hook to execute based on the state. ----- > myManageHook = toggleHook "float" doFloat <+> manageHook defaultConfig+-- > myManageHook = toggleHook "float" doFloat <> manageHook def -- -- Additionally, toggleHook' is provided to toggle between two hooks (rather -- than on/off). ----- > myManageHook = toggleHook' "oldfocus" (const id) W.focusWindow <+> manageHook defaultConfig+-- > myManageHook = toggleHook' "oldfocus" (const id) W.focusWindow <> manageHook def -- -- The 'hookNext' and 'toggleHookNext' functions can be used in key -- bindings to set whether the hook is applied or not.@@ -144,10 +143,10 @@ -- $pp -- The following functions are used to display the current -- state of 'hookNext' and 'hookAllNew' in your--- 'XMonad.Hooks.DynamicLog.dynamicLogWithPP'.--- 'willHookNextPP' and 'willHookAllNewPP' should be added--- to the 'XMonad.Hooks.DynamicLog.ppExtras' field of your--- 'XMonad.Hooks.DynamicLog.PP'.+-- "XMonad.Hooks.StatusBar". 'willHookNextPP' and+-- 'willHookAllNewPP' should be added to the+-- 'XMonad.Hooks.StatusBar.PP.ppExtras' field of your+-- "XMonad.Hooks.StatusBar.PP". -- -- Use 'runLogHook' to refresh the output of your 'logHook', so -- that the effects of a 'hookNext'/... will be visible
XMonad/Hooks/UrgencyHook.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards, DeriveDataTypeable,-  FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.UrgencyHook+-- Description :  Configure an action to occur when a window demands your attention. -- Copyright   :  Devin Mullins <me@twifkak.com> -- License     :  BSD3-style (see LICENSE) --@@ -30,9 +30,6 @@                                  -- ** Useful keybinding                                  -- $keybinding -                                 -- ** Note-                                 -- $note-                                  -- * Troubleshooting                                  -- $troubleshooting @@ -61,9 +58,11 @@                                  NoUrgencyHook(..),                                  BorderUrgencyHook(..),                                  FocusHook(..),+                                 filterUrgencyHook, filterUrgencyHook',                                  minutes, seconds,+                                 askUrgent, doAskUrgent,                                  -- * Stuff for developers:-                                 readUrgents, withUrgents,+                                 readUrgents, withUrgents, clearUrgents',                                  StdoutUrgencyHook(..),                                  SpawnUrgencyHook(..),                                  UrgencyHook(urgencyHook),@@ -72,20 +71,20 @@                                  ) where  import XMonad+import XMonad.Prelude (fi, delete, fromMaybe, listToMaybe, maybeToList, when, (\\)) import qualified XMonad.StackSet as W +import XMonad.Hooks.ManageHelpers (windowTag) import XMonad.Util.Dzen (dzenWithArgs, seconds) import qualified XMonad.Util.ExtensibleState as XS import XMonad.Util.NamedWindows (getName) import XMonad.Util.Timer (TimerId, startTimer, handleTimer)+import XMonad.Util.WindowProperties (getProp32) -import Control.Applicative ((<$>))-import Control.Monad (when) import Data.Bits (testBit)-import Data.List (delete, (\\))-import Data.Maybe (listToMaybe, maybeToList) import qualified Data.Set as S import System.IO (hPutStrLn, stderr)+import Foreign.C.Types (CLong)  -- $usage --@@ -104,7 +103,7 @@ -- 'withUrgencyHook'. For example: -- -- > main = xmonad $ withUrgencyHook dzenUrgencyHook { args = ["-bg", "darkgreen", "-xs", "1"] }--- >               $ defaultConfig+-- >               $ def -- -- This will pop up a dzen bar for five seconds telling you you've got an -- urgent window.@@ -116,23 +115,18 @@ -- extra popup, install NoUrgencyHook, as so: -- -- > main = xmonad $ withUrgencyHook NoUrgencyHook--- >               $ defaultConfig+-- >               $ def ----- Now, your "XMonad.Hooks.DynamicLog" must be set up to display the urgent--- windows. If you're using the 'dzen' or 'dzenPP' functions from that module,--- then you should be good. Otherwise, you want to figure out how to set--- 'ppUrgent'.+-- Now, your "XMonad.Hooks.StatusBar.PP" must be set up to display the urgent+-- windows. If you're using the 'dzen' (from "XMonad.Hooks.DynamicLog") or+-- 'dzenPP' functions from that module, then you should be good. Otherwise,+-- you want to figure out how to set 'ppUrgent'.  -- $keybinding -- -- You can set up a keybinding to jump to the window that was recently marked -- urgent. See an example at 'focusUrgent'. --- $note--- Note: UrgencyHook installs itself as a LayoutModifier, so if you modify your--- urgency hook and restart xmonad, you may need to rejigger your layout by--- hitting mod-shift-space.- -- $troubleshooting -- -- There are three steps to get right:@@ -203,21 +197,22 @@ -- instead. withUrgencyHook :: (LayoutClass l Window, UrgencyHook h) =>                    h -> XConfig l -> XConfig l-withUrgencyHook hook conf = withUrgencyHookC hook urgencyConfig conf+withUrgencyHook hook = withUrgencyHookC hook def  -- | This lets you modify the defaults set in 'urgencyConfig'. An example: ----- > withUrgencyHookC dzenUrgencyHook { ... } urgencyConfig { suppressWhen = Focused }+-- > withUrgencyHookC dzenUrgencyHook { ... } def { suppressWhen = Focused } -- -- (Don't type the @...@, you dolt.) See 'UrgencyConfig' for details on configuration. withUrgencyHookC :: (LayoutClass l Window, UrgencyHook h) =>                     h -> UrgencyConfig -> XConfig l -> XConfig l withUrgencyHookC hook urgConf conf = conf {         handleEventHook = \e -> handleEvent (WithUrgencyHook hook urgConf) e >> handleEventHook conf e,-        logHook = cleanupUrgents (suppressWhen urgConf) >> logHook conf+        logHook = cleanupUrgents (suppressWhen urgConf) >> logHook conf,+        startupHook = cleanupStaleUrgents >> startupHook conf     } -data Urgents = Urgents { fromUrgents :: [Window] } deriving (Read,Show,Typeable)+newtype Urgents = Urgents { fromUrgents :: [Window] } deriving (Read,Show)  onUrgents :: ([Window] -> [Window]) -> Urgents -> Urgents onUrgents f = Urgents . f . fromUrgents@@ -247,20 +242,25 @@ -- -- The interval arguments are in seconds. See the 'minutes' helper. data RemindWhen = Dont                    -- ^ triggering once is enough-                | Repeatedly Int Interval -- ^ repeat <arg1> times every <arg2> seconds-                | Every Interval          -- ^ repeat every <arg1> until the urgency hint is cleared+                | Repeatedly Int Interval -- ^ repeat \<arg1\> times every \<arg2\> seconds+                | Every Interval          -- ^ repeat every \<arg1\> until the urgency hint is cleared                 deriving (Read, Show)  -- | A prettified way of multiplying by 60. Use like: @(5 `minutes`)@. minutes :: Rational -> Rational minutes secs = secs * 60 --- | The default 'UrgencyConfig'. suppressWhen = Visible, remindWhen = Dont.--- Use a variation of this in your config just as you use a variation of--- defaultConfig for your xmonad definition.+-- | The default 'UrgencyConfig': @urgencyConfig = 'def'@. urgencyConfig :: UrgencyConfig-urgencyConfig = UrgencyConfig { suppressWhen = Visible, remindWhen = Dont }+urgencyConfig = def+{-# DEPRECATED urgencyConfig "Use def insetad." #-} +-- | The default 'UrgencyConfig': @suppressWhen = 'Visible', remindWhen = 'Dont'@.+-- Use a variation of this in your config just as you would use any+-- other instance of 'def'.+instance Default UrgencyConfig where+  def = UrgencyConfig { suppressWhen = Visible, remindWhen = Dont }+ -- | Focuses the most recently urgent window. Good for what ails ya -- I mean, your keybindings. -- Example keybinding: --@@ -273,7 +273,7 @@ -- -- > , ((modm .|. shiftMask, xK_BackSpace), clearUrgents) clearUrgents :: X ()-clearUrgents = adjustUrgents (const []) >> adjustReminders (const [])+clearUrgents = withUrgents clearUrgents'  -- | X action that returns a list of currently urgent windows. You might use -- it, or 'withUrgents', in your custom logHook, to display the workspaces that@@ -285,6 +285,12 @@ withUrgents :: ([Window] -> X a) -> X a withUrgents f = readUrgents >>= f +-- | Cleanup urgency and reminders for windows that no longer exist.+cleanupStaleUrgents :: X ()+cleanupStaleUrgents = withWindowSet $ \ws -> do+    adjustUrgents (filter (`W.member` ws))+    adjustReminders (filter ((`W.member` ws) . window))+ adjustUrgents :: ([Window] -> [Window]) -> X () adjustUrgents = XS.modify . onUrgents @@ -296,7 +302,7 @@                          , window    :: Window                          , interval  :: Interval                          , remaining :: Maybe Int-                         } deriving (Show,Read,Eq,Typeable)+                         } deriving (Show,Read,Eq)  instance ExtensionClass [Reminder] where     initialValue = []@@ -310,12 +316,33 @@ adjustReminders :: ([Reminder] -> [Reminder]) -> X () adjustReminders = XS.modify -clearUrgency :: Window -> X ()-clearUrgency w = adjustUrgents (delete w) >> adjustReminders (filter $ (w /=) . window)  data WithUrgencyHook h = WithUrgencyHook h UrgencyConfig     deriving (Read, Show) +-- | Change the _NET_WM_STATE property by applying a function to the list of atoms.+changeNetWMState :: Display -> Window -> ([CLong] -> [CLong]) -> X ()+changeNetWMState dpy w f = do+   wmstate <- getAtom "_NET_WM_STATE"+   wstate  <- fromMaybe [] <$> getProp32 wmstate w+   io $ changeProperty32 dpy w wmstate aTOM propModeReplace (f wstate)+   return ()++-- | Add an atom to the _NET_WM_STATE property.+addNetWMState :: Display -> Window -> Atom -> X ()+addNetWMState dpy w atom = changeNetWMState dpy w (fromIntegral atom :)++-- | Remove an atom from the _NET_WM_STATE property.+removeNetWMState :: Display -> Window -> Atom -> X ()+removeNetWMState dpy w atom = changeNetWMState dpy w $ delete (fromIntegral atom)++-- | Get the _NET_WM_STATE propertly as a [CLong]+getNetWMState :: Window -> X [CLong]+getNetWMState w = do+    a_wmstate <- getAtom "_NET_WM_STATE"+    fromMaybe [] <$> getProp32 a_wmstate w++ -- The Non-ICCCM Manifesto: -- Note: Some non-standard choices have been made in this implementation to -- account for the fact that things are different in a tiling window manager:@@ -331,20 +358,40 @@ handleEvent :: UrgencyHook h => WithUrgencyHook h -> Event -> X () handleEvent wuh event =     case event of-      PropertyEvent { ev_event_type = t, ev_atom = a, ev_window = w } -> do+     -- WM_HINTS urgency flag+      PropertyEvent { ev_event_type = t, ev_atom = a, ev_window = w } ->           when (t == propertyNotify && a == wM_HINTS) $ withDisplay $ \dpy -> do               WMHints { wmh_flags = flags } <- io $ getWMHints dpy w-              if (testBit flags urgencyHintBit) then do-                  adjustUrgents (\ws -> if elem w ws then ws else w : ws)-                  callUrgencyHook wuh w-                else-                  clearUrgency w-              userCodeDef () =<< asks (logHook . config)+              if testBit flags urgencyHintBit then markUrgent w else markNotUrgent w+      -- Window destroyed       DestroyWindowEvent {ev_window = w} ->-          clearUrgency w+          markNotUrgent w+      -- _NET_WM_STATE_DEMANDS_ATTENTION requested by client+      ClientMessageEvent {ev_event_display = dpy, ev_window = w, ev_message_type = t, ev_data = action:atoms} -> do+          a_wmstate <- getAtom "_NET_WM_STATE"+          a_da      <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION"+          wstate    <- getNetWMState w+          let demandsAttention = fromIntegral a_da `elem` wstate+              remove = 0+              add    = 1+              toggle = 2+          when (t == a_wmstate && fromIntegral a_da `elem` atoms) $ do+            when (action == add || (action == toggle && not demandsAttention)) $ do+              markUrgent w+              addNetWMState dpy w a_da+            when (action == remove || (action == toggle && demandsAttention)) $ do+              markNotUrgent w+              removeNetWMState dpy w a_da       _ ->           mapM_ handleReminder =<< readReminders       where handleReminder reminder = handleTimer (timer reminder) event $ reminderHook wuh reminder+            markUrgent w = do+                adjustUrgents (\ws -> if w `elem` ws then ws else w : ws)+                callUrgencyHook wuh w+                userCodeDef () =<< asks (logHook . config)+            markNotUrgent w = do+                adjustUrgents (delete w) >> adjustReminders (filter $ (w /=) . window)+                userCodeDef () =<< asks (logHook . config)  callUrgencyHook :: UrgencyHook h => WithUrgencyHook h -> Window -> X () callUrgencyHook (WithUrgencyHook hook UrgencyConfig { suppressWhen = sw, remindWhen = rw }) w =@@ -376,10 +423,16 @@ shouldSuppress sw w = elem w <$> suppressibleWindows sw  cleanupUrgents :: SuppressWhen -> X ()-cleanupUrgents sw = do-    sw' <- suppressibleWindows sw-    adjustUrgents (\\ sw') >> adjustReminders (filter $ ((`notElem` sw') . window))+cleanupUrgents sw = clearUrgents' =<< suppressibleWindows sw +-- | Clear urgency status of selected windows.+clearUrgents' :: [Window] -> X ()+clearUrgents' ws = do+    a_da <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION"+    dpy <- withDisplay return+    mapM_ (\w -> removeNetWMState dpy w a_da) ws+    adjustUrgents (\\ ws) >> adjustReminders (filter ((`notElem` ws) . window))+ suppressibleWindows :: SuppressWhen -> X [Window] suppressibleWindows Visible  = gets $ S.toList . mapped suppressibleWindows OnScreen = gets $ W.index . windowset@@ -444,26 +497,30 @@  borderUrgencyHook :: String -> Window -> X () borderUrgencyHook = urgencyHook . BorderUrgencyHook-data BorderUrgencyHook = BorderUrgencyHook { urgencyBorderColor :: !String }+newtype BorderUrgencyHook = BorderUrgencyHook { urgencyBorderColor :: String }                        deriving (Read, Show)  instance UrgencyHook BorderUrgencyHook where   urgencyHook BorderUrgencyHook { urgencyBorderColor = cs } w =-    withDisplay $ \dpy -> io $ do-      c' <- initColor dpy cs+    withDisplay $ \dpy -> do+      c' <- io (initColor dpy cs)       case c' of-        Just c -> setWindowBorder dpy w c-        _      -> hPutStrLn stderr $ concat ["Warning: bad urgentBorderColor "-                                            ,show cs-                                            ," in BorderUrgencyHook"-                                            ]+        Just c -> setWindowBorderWithFallback dpy w cs c+        _      -> io $ hPutStrLn stderr $ concat ["Warning: bad urgentBorderColor "+                                                 ,show cs+                                                 ," in BorderUrgencyHook"+                                                 ]  -- | Flashes when a window requests your attention and you can't see it. -- Defaults to a duration of five seconds, and no extra args to dzen. -- See 'DzenUrgencyHook'. dzenUrgencyHook :: DzenUrgencyHook-dzenUrgencyHook = DzenUrgencyHook { duration = seconds 5, args = [] }+dzenUrgencyHook = def +-- | @'def' = 'dzenUrgencyHook'@.+instance Default DzenUrgencyHook where+  def = DzenUrgencyHook { duration = seconds 5, args = [] }+ -- | Spawn a commandline thing, appending the window id to the prefix string -- you provide. (Make sure to add a space if you need it.) Do your crazy -- xcompmgr thing.@@ -481,3 +538,42 @@  instance UrgencyHook StdoutUrgencyHook where     urgencyHook    _ w = io $ putStrLn $ "Urgent: " ++ show w++-- | urgencyhook such that windows on certain workspaces+-- never get urgency set.+--+-- Useful for scratchpad workspaces perhaps:+--+-- > main = xmonad (withUrgencyHook (filterUrgencyHook ["NSP", "SP"]) def)+filterUrgencyHook :: [WorkspaceId] -> Window -> X ()+filterUrgencyHook skips = filterUrgencyHook' $ maybe False (`elem` skips) <$> windowTag++-- | 'filterUrgencyHook' that takes a generic 'Query' to select which windows+-- should never be marked urgent.+filterUrgencyHook' :: Query Bool -> Window -> X ()+filterUrgencyHook' q w = whenX (runQuery q w) (clearUrgents' [w])++-- | Mark the given window urgent.+--+-- (The implementation is a bit hacky: send a _NET_WM_STATE ClientMessage to+-- ourselves. This is so that we respect the 'SuppressWhen' of the configured+-- urgency hooks. If this module if ever migrated to the ExtensibleConf+-- infrastrcture, we'll then invoke markUrgent directly.)+askUrgent :: Window -> X ()+askUrgent w = withDisplay $ \dpy -> do+    rw <- asks theRoot+    a_wmstate <- getAtom "_NET_WM_STATE"+    a_da      <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION"+    let state_add = 1+    let source_pager = 2+    io $ allocaXEvent $ \e -> do+        setEventType e clientMessage+        setClientMessageEvent' e w a_wmstate 32 [state_add, fi a_da, 0, source_pager]+        sendEvent dpy rw False (substructureRedirectMask .|. substructureNotifyMask) e++-- | Helper for 'ManageHook' that marks the window as urgent (unless+-- suppressed, see 'SuppressWhen'). Useful in+-- 'XMonad.Hooks.EwmhDesktops.setEwmhActivateHook' and also in combination+-- with "XMonad.Hooks.InsertPosition", "XMonad.Hooks.Focus".+doAskUrgent :: ManageHook+doAskUrgent = ask >>= \w -> liftX (askUrgent w) >> mempty
+ XMonad/Hooks/WallpaperSetter.hs view
@@ -0,0 +1,224 @@+-----------------------------------+-- |+-- Module      : XMonad.Hooks.WallpaperSetter+-- Description : Change the wallpapers depending on visible workspaces.+-- Copyright   : (c) Anton Pirogov, 2014+-- License     : BSD3+--+-- Maintainer  : Anton Pirogov <anton.pirogov@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- Log hook which changes the wallpapers depending on visible workspaces.+-----------------------------------+module XMonad.Hooks.WallpaperSetter (+  -- * Usage+  -- $usage+  wallpaperSetter+, WallpaperConf(..)+, Wallpaper(..)+, WallpaperList(..)+, defWallpaperConf+, defWPNamesJpg, defWPNamesPng, defWPNames+  -- *TODO+  -- $todo+) where+import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as S+import qualified XMonad.Util.ExtensibleState as XS++import System.IO+import System.Process+import System.Directory (getHomeDirectory, doesFileExist, doesDirectoryExist, getDirectoryContents)+import System.FilePath ((</>))+import System.Random (randomRIO)++import qualified Data.Map as M++-- $usage+-- This module requires imagemagick and feh to be installed, as these are utilized+-- for the required image transformations and the actual setting of the wallpaper.+--+-- This was especially tested with multi-head setups - if you have two monitors and swap+-- the workspaces, the wallpapers will be swapped too, scaled accordingly and rotated if necessary+-- (e.g. if you are using your monitor rotated but only have wide wallpapers).+--+-- Add a log hook like this:+--+-- > myWorkspaces = ["1:main","2:misc","3","4"]+-- > ...+-- > main = xmonad $ def {+-- >   logHook = wallpaperSetter defWallpaperConf {+-- >                                wallpapers = defWPNames myWorkspaces+-- >                                          <> WallpaperList [("1:main",WallpaperDir "1")]+-- >                             }+-- >   }+-- > ...++-- $todo+-- * implement a kind of image cache like in wallpaperd to remove or at least reduce the lag+--+-- * find out how to merge multiple images from stdin to one (-> for caching all pictures in memory)++-- | internal. to use XMonad state for memory in-between log-hook calls and remember PID of old external call+data WCState = WCState (Maybe [WorkspaceId]) (Maybe ProcessHandle)+instance ExtensionClass WCState where+  initialValue = WCState Nothing Nothing++-- | Represents a wallpaper+data Wallpaper = WallpaperFix FilePath -- ^ Single, fixed wallpaper+               | WallpaperDir FilePath -- ^ Random wallpaper from this subdirectory+               deriving (Eq, Show, Read)++newtype WallpaperList = WallpaperList [(WorkspaceId, Wallpaper)]+  deriving (Show,Read)++instance Semigroup WallpaperList where+  WallpaperList w1 <> WallpaperList w2 =+    WallpaperList $ M.toList $ M.fromList w2 `M.union` M.fromList w1++instance Monoid WallpaperList where+  mempty = WallpaperList []++-- | Complete wallpaper configuration passed to the hook+data WallpaperConf = WallpaperConf {+    wallpaperBaseDir :: FilePath  -- ^ Where the wallpapers reside (if empty, will look in \~\/.wallpapers/)+  , wallpapers :: WallpaperList   -- ^ List of the wallpaper associations for workspaces+  } deriving (Show, Read)++-- | default configuration. looks in \~\/.wallpapers/ for WORKSPACEID.jpg+defWallpaperConf :: WallpaperConf+defWallpaperConf = WallpaperConf "" $ WallpaperList []++instance Default WallpaperConf where+    def = defWallpaperConf++{-# DEPRECATED defWPNames "Use defWPNamesJpg instead" #-}+defWPNames :: [WorkspaceId] -> WallpaperList+defWPNames = defWPNamesJpg++-- | Return the default association list (maps @name@ to @name.jpg@, non-alphanumeric characters are omitted)+defWPNamesJpg :: [WorkspaceId] -> WallpaperList+defWPNamesJpg xs = WallpaperList $ map (\x -> (x, WallpaperFix (filter isAlphaNum x ++ ".jpg"))) xs++-- | Like 'defWPNamesJpg', but map @name@ to @name.png@ instead.+defWPNamesPng :: [WorkspaceId] -> WallpaperList+defWPNamesPng xs = WallpaperList $ map (\x -> (x, WallpaperFix (filter isAlphaNum x ++ ".png"))) xs++-- | Add this to your log hook with the workspace configuration as argument.+wallpaperSetter :: WallpaperConf -> X ()+wallpaperSetter wpconf = do+  WCState oldws h <- XS.get+  visws <- getVisibleWorkspaces+  when (Just visws /= oldws) $ do++    wpconf' <- completeWPConf wpconf+    wspicpaths <- getPicPathsAndWSRects wpconf'++    -- terminate old call if any to prevent unnecessary CPU overload when switching WS too fast+    case h of+      Nothing -> return ()+      Just pid -> liftIO $ terminateProcess pid++    handle <- applyWallpaper wspicpaths+    XS.put $ WCState (Just visws) $ Just handle++-- Helper functions+-------------------++-- | Picks a random element from a list+pickFrom :: [a] -> IO a+pickFrom list = do+  i <- randomRIO (0,length list - 1)+  return $ list !! i++-- | get absolute picture path of the given wallpaper picture+-- or select a random one if it is a directory+getPicPath :: WallpaperConf -> Wallpaper -> IO (Maybe FilePath)+getPicPath conf (WallpaperDir dir) = do+  direxists <- doesDirectoryExist $ wallpaperBaseDir conf </> dir+  if direxists+    then do files <- getDirectoryContents $ wallpaperBaseDir conf </> dir+            let files' = filter (not . ("." `isPrefixOf`)) files+            file <- pickFrom files'+            return $ Just $ wallpaperBaseDir conf </> dir </> file+    else return Nothing+getPicPath conf (WallpaperFix file) = do+  exist <- doesFileExist path+  return $ if exist then Just path else Nothing+  where path = wallpaperBaseDir conf </> file++-- | Take a path to a picture, return (width, height) if the path is a valid picture+-- (requires imagemagick tool identify to be installed)+getPicRes :: FilePath -> IO (Maybe (Int,Int))+getPicRes picpath = do+  (_, Just outh,_,_pid) <- createProcess $ (proc "identify" ["-format", "%w %h", picpath]) { std_out = CreatePipe }+  output <- hGetContents outh+  return $ case map reads (words output) of+    -- mapM Text.Read.readMaybe is better but only in ghc>=7.6+    [[(w,"")],[(h,"")]] -> Just (w,h)+    _ -> Nothing++-- |complete unset fields to default values (wallpaper directory = ~/.wallpapers,+--  expects a file "NAME.jpg" for each workspace named NAME)+completeWPConf :: WallpaperConf -> X WallpaperConf+completeWPConf (WallpaperConf dir (WallpaperList ws)) = do+  home <- liftIO getHomeDirectory+  winset <- gets windowset+  let tags = map S.tag $ S.workspaces winset+      dir' = if null dir then home </> ".wallpapers" else dir+      ws'  = if null ws then defWPNames tags else WallpaperList ws+  return (WallpaperConf dir' ws')++getVisibleWorkspaces :: X [WorkspaceId]+getVisibleWorkspaces = do+  winset <- gets windowset+  return $ map (S.tag . S.workspace) . sortOn S.screen $ S.current winset : S.visible winset++getPicPathsAndWSRects :: WallpaperConf -> X [(Rectangle, FilePath)]+getPicPathsAndWSRects wpconf = do+  winset <- gets windowset+  paths <- liftIO getPicPaths+  visws <- getVisibleWorkspaces+  let visscr = S.current winset : S.visible winset+      visrects = M.fromList $ map (\x -> ((S.tag . S.workspace) x, S.screenDetail x)) visscr+      getRect tag = screenRect $ fromJust $ M.lookup tag visrects+      foundpaths = [ (getRect n, p) | (n, Just p) <- paths, n `elem` visws ]+  return foundpaths+  where getPicPaths = mapM (\(x,y) -> getPicPath wpconf y+                             >>= \p -> return (x,p)) wl+        WallpaperList wl   = wallpapers wpconf++-- | Gets a list of geometry rectangles and filenames, builds and sets wallpaper+applyWallpaper :: [(Rectangle, FilePath)] -> X ProcessHandle+applyWallpaper parts = do+  winset <- gets windowset+  let (vx,vy) = getVScreenDim winset+  layers <- liftIO $ mapM layerCommand parts+  let basepart ="convert -size " ++ show vx ++ "x" ++ show vy ++ " xc:black"+      endpart =" jpg:- | feh --no-xinerama --bg-tile --no-fehbg -"+      cmd = basepart ++ unwords layers ++ endpart+  liftIO $ runCommand cmd+++getVScreenDim :: S.StackSet i l a sid ScreenDetail -> (Integer, Integer)+getVScreenDim = foldr (maxXY . screenRect . S.screenDetail) (0,0) . S.screens+  where maxXY (Rectangle x y w h) (mx,my) = ( fromIntegral (fromIntegral x+w) `max` mx+                                            , fromIntegral (fromIntegral y+h) `max` my )++needsRotation :: Rectangle -> (Int,Int) -> Bool+needsRotation rect (px,py) = let wratio, pratio :: Double+                                 wratio = fromIntegral (rect_width rect) / fromIntegral (rect_height rect)+                                 pratio = fromIntegral px / fromIntegral py+                             in wratio > 1 && pratio < 1 || wratio < 1 && pratio > 1++layerCommand :: (Rectangle, FilePath) -> IO String+layerCommand (rect, path) = do+  res <- getPicRes path+  return $ case needsRotation rect <$> res of+    Nothing -> ""+    Just rotate -> let size = show (rect_width rect) ++ "x" ++ show (rect_height rect) in+                     " \\( '"++path++"' "++(if rotate then "-rotate 90 " else "")+                      ++ " -scale "++size++"^ -gravity center -extent "++size++" +gravity \\)"+                      ++ " -geometry +" ++ show (rect_x rect) ++ "+" ++ show (rect_y rect) ++ " -composite "
+ XMonad/Hooks/WindowSwallowing.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE NamedFieldPuns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.WindowSwallowing+-- Description :  Temporarily hide parent windows when opening other programs.+-- Copyright   :  (c) 2020 Leon Kowarschick+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Leon Kowarschick. <thereal.elkowar@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides a handleEventHook that implements window swallowing.+--+-- If you open a GUI-window (i.e. feh) from the terminal,+-- the terminal will normally still be shown on screen, unnecessarily+-- taking up space on the screen.+-- With window swallowing, can detect that you opened a window from within another+-- window, and allows you "swallow" that parent window for the time the new+-- window is running.+--+-- __NOTE__ that this does not always work perfectly:+--+-- - Because window swallowing needs to check the process hierarchy, it requires+--   both the child and the parent to be distinct processes. This means that+--   applications which implement instance sharing cannot be supported by window swallowing.+--   Most notably, this excludes some terminal emulators as well as tmux+--   from functioning as the parent process. It also excludes a good amount of+--   child programs, because many graphical applications do implement instance sharing.+--   For example, window swallowing will probably not work with your browser.+--+-- - To check the process hierarchy, we need to be able to get the process ID+--   by looking at the window. This requires the @_NET_WM_PID@ X-property to be set.+--   If any application you want to use this with does not provide the @_NET_WM_PID@,+--   there is not much you can do except for reaching out to the author of that+--   application and asking them to set that property. Additionally,+--   applications running in their own PID namespace, such as those in+--   Flatpak, can't set a correct @_NET_WM_PID@ even if they wanted to.+-----------------------------------------------------------------------------+module XMonad.Hooks.WindowSwallowing+  ( -- * Usage+    -- $usage+    swallowEventHook, swallowEventHookSub+  )+where+import           XMonad+import           XMonad.Prelude+import qualified XMonad.StackSet               as W+import           XMonad.Layout.SubLayouts+import qualified XMonad.Util.ExtensibleState   as XS+import           XMonad.Util.WindowProperties+import           XMonad.Util.Process            ( getPPIDChain )+import qualified Data.Map.Strict               as M+import           System.Posix.Types             ( ProcessID )++-- $usage+-- You can use this module by including  the following in your @xmonad.hs@:+--+-- > import XMonad.Hooks.WindowSwallowing+--+-- and using 'swallowEventHook' somewhere in your 'handleEventHook', for example:+--+-- > myHandleEventHook = swallowEventHook (className =? "Alacritty" <||> className =? "Termite") (return True)+--+-- The variant 'swallowEventHookSub' can be used if a layout from "XMonad.Layout.SubLayouts" is used;+-- instead of swallowing the window it will merge the child window with the parent. (this does not work with floating windows)+--+-- For more information on editing your handleEventHook and key bindings,+-- see <https://xmonad.org/TUTORIAL.html the tutorial> and "XMonad.Doc.Extending".++-- | Run @action@ iff both parent- and child queries match and the child+-- is a child by PID.+--+-- A 'MapRequestEvent' is called right before a window gets opened. We+-- intercept that call to possibly open the window ourselves, swapping+-- out it's parent processes window for the new window in the stack.+handleMapRequestEvent :: Query Bool -> Query Bool -> Window -> (Window -> X ()) -> X ()+handleMapRequestEvent parentQ childQ childWindow action =+  -- For a window to be opened from within another window, that other window+  -- must be focused. Thus the parent window that would be swallowed has to be+  -- the currently focused window.+  withFocused $ \parentWindow -> do+    -- First verify that both windows match the given queries+    parentMatches <- runQuery parentQ parentWindow+    childMatches  <- runQuery childQ childWindow+    when (parentMatches && childMatches) $ do+      -- read the windows _NET_WM_PID properties+      childWindowPid  <- getProp32s "_NET_WM_PID" childWindow+      parentWindowPid <- getProp32s "_NET_WM_PID" parentWindow+      case (parentWindowPid, childWindowPid) of+        (Just (parentPid : _), Just (childPid : _)) -> do+          -- check if the new window is a child process of the last focused window+          -- using the process ids.+          isChild <- liftIO $ fi childPid `isChildOf` fi parentPid+          when isChild $ do+            action parentWindow+        _ -> return ()+      return ()++-- | handleEventHook that will merge child windows via+-- "XMonad.Layout.SubLayouts" when they are opened from another window.+swallowEventHookSub+  :: Query Bool -- ^ query the parent window has to match for window swallowing to occur.+                --   Set this to @return True@ to run swallowing for every parent.+  -> Query Bool -- ^ query the child window has to match for window swallowing to occur.+                --   Set this to @return True@ to run swallowing for every child+  -> Event      -- ^ The event to handle.+  -> X All+swallowEventHookSub parentQ childQ event =+  All True <$ case event of+    MapRequestEvent{ev_window=childWindow} ->+      handleMapRequestEvent parentQ childQ childWindow $ \parentWindow -> do+        manage childWindow+        sendMessage (Merge parentWindow childWindow)+    _ -> pure ()++-- | handleEventHook that will swallow child windows when they are+-- opened from another window.+swallowEventHook+  :: Query Bool -- ^ query the parent window has to match for window swallowing to occur.+                --   Set this to @return True@ to run swallowing for every parent.+  -> Query Bool -- ^ query the child window has to match for window swallowing to occur.+                --   Set this to @return True@ to run swallowing for every child+  -> Event      -- ^ The event to handle.+  -> X All+swallowEventHook parentQ childQ event = do+  case event of+    MapRequestEvent{ev_window=childWindow} ->+      handleMapRequestEvent parentQ childQ childWindow $ \parentWindow -> do+        -- We set the newly opened window as the focused window, replacing the parent window.+        -- If the parent window was floating, we transfer that data to the child,+        -- such that it shows up at the same position, with the same dimensions.+        windows+          ( W.modify' (\x -> x { W.focus = childWindow })+          . moveFloatingState parentWindow childWindow+          )+        XS.modify (addSwallowedParent parentWindow childWindow)++    -- This is called in many circumstances, most notably for us:+    -- right before a window gets closed. We store the current+    -- state of the window stack here, such that we know where the+    -- child window was on the screen when restoring the swallowed parent process.+    ConfigureEvent{} -> withWindowSet $ \ws -> do+      XS.modify . setStackBeforeWindowClosing . currentStack $ ws+      XS.modify . setFloatingBeforeWindowClosing . W.floating $ ws++    -- This is called right after any window closes.+    DestroyWindowEvent { ev_event = eventId, ev_window = childWindow } ->+      -- Because DestroyWindowEvent is emitted a lot more often then you think,+      -- this check verifies that the event is /actually/ about closing a window.+      when (eventId == childWindow) $ do+        -- we get some data from the extensible state, most notably we ask for+        -- the \"parent\" window of the now closed window.+        maybeSwallowedParent <- XS.gets (getSwallowedParent childWindow)+        maybeOldStack        <- XS.gets stackBeforeWindowClosing+        oldFloating          <- XS.gets floatingBeforeClosing+        case (maybeSwallowedParent, maybeOldStack) of+          -- If there actually is a corresponding swallowed parent window for this window,+          -- we will try to restore it.+          -- Because there are some cases where the stack-state is not stored correctly in the ConfigureEvent hook,+          -- we have to first check if the stack-state is valid.+          -- If it is, we can restore the parent exactly where the child window was before being closed.+          -- If the stored stack-state is invalid however, we still restore the window+          -- by just inserting it as the focused window in the stack.+          --+          -- After restoring, we remove the information about the swallowing from the state.+          (Just parent, Nothing) -> do+            windows (insertIntoStack parent)+            deleteState childWindow+          (Just parent, Just oldStack) -> do+            stackStoredCorrectly <- do+              curStack <- withWindowSet (return . currentStack)+              let oldLen = length (W.integrate oldStack)+              let curLen = length (W.integrate' curStack)+              return (oldLen - 1 == curLen && childWindow == W.focus oldStack)++            if stackStoredCorrectly+              then windows+                (\ws ->+                  updateCurrentStack+                      (const $ Just $ oldStack { W.focus = parent })+                    $ moveFloatingState childWindow parent+                    $ ws { W.floating = oldFloating }+                )+              else windows (insertIntoStack parent)+            deleteState childWindow+          _ -> return ()+    _ -> return ()+  return $ All True+ where+  deleteState :: Window -> X ()+  deleteState childWindow = do+    XS.modify $ removeSwallowed childWindow+    XS.modify $ setStackBeforeWindowClosing Nothing++-- | insert a window as focused into the current stack, moving the previously focused window down the stack+insertIntoStack :: a -> W.StackSet i l a sid sd -> W.StackSet i l a sid sd+insertIntoStack win = W.modify+  (Just $ W.Stack win [] [])+  (\s -> Just $ s { W.focus = win, W.down = W.focus s : W.down s })++-- | run a pure transformation on the Stack of the currently focused workspace.+updateCurrentStack+  :: (Maybe (W.Stack a) -> Maybe (W.Stack a))+  -> W.StackSet i l a sid sd+  -> W.StackSet i l a sid sd+updateCurrentStack f = W.modify (f Nothing) (f . Just)++currentStack :: W.StackSet i l a sid sd -> Maybe (W.Stack a)+currentStack = W.stack . W.workspace . W.current+++-- | move the floating state from one window to another, sinking the original window+moveFloatingState+  :: Ord a+  => a -- ^ window to move from+  -> a -- ^ window to move to+  -> W.StackSet i l a s sd+  -> W.StackSet i l a s sd+moveFloatingState from to ws = ws+  { W.floating = M.delete from $ maybe (M.delete to (W.floating ws))+                                       (\r -> M.insert to r (W.floating ws))+                                       (M.lookup from (W.floating ws))+  }++-- | check if a given process is a child of another process. This depends on "pstree" being in the PATH+-- NOTE: this does not work if the child process does any kind of process-sharing.+isChildOf+  :: ProcessID -- ^ child PID+  -> ProcessID -- ^ parent PID+  -> IO Bool+isChildOf child parent = (parent `elem`) <$> getPPIDChain child++data SwallowingState =+  SwallowingState+    { currentlySwallowed       :: M.Map Window Window         -- ^ mapping from child window window to the currently swallowed parent window+    , stackBeforeWindowClosing :: Maybe (W.Stack Window)      -- ^ current stack state right before DestroyWindowEvent is sent+    , floatingBeforeClosing    :: M.Map Window W.RationalRect -- ^ floating map of the stackset right before DestroyWindowEvent is sent+    } deriving (Show)++getSwallowedParent :: Window -> SwallowingState -> Maybe Window+getSwallowedParent win SwallowingState { currentlySwallowed } =+  M.lookup win currentlySwallowed++addSwallowedParent :: Window -> Window -> SwallowingState -> SwallowingState+addSwallowedParent parent child s@SwallowingState { currentlySwallowed } =+  s { currentlySwallowed = M.insert child parent currentlySwallowed }++removeSwallowed :: Window -> SwallowingState -> SwallowingState+removeSwallowed child s@SwallowingState { currentlySwallowed } =+  s { currentlySwallowed = M.delete child currentlySwallowed }++setStackBeforeWindowClosing+  :: Maybe (W.Stack Window) -> SwallowingState -> SwallowingState+setStackBeforeWindowClosing stack s = s { stackBeforeWindowClosing = stack }++setFloatingBeforeWindowClosing+  :: M.Map Window W.RationalRect -> SwallowingState -> SwallowingState+setFloatingBeforeWindowClosing x s = s { floatingBeforeClosing = x }++instance ExtensionClass SwallowingState where+  initialValue = SwallowingState { currentlySwallowed       = mempty+                                 , stackBeforeWindowClosing = Nothing+                                 , floatingBeforeClosing    = mempty+                                 }
XMonad/Hooks/WorkspaceByPos.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE LambdaCase #-} ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Hooks.WorkspaceByPos+-- Description :  Move new window to non-focused screen based on its requested geometry. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -21,30 +23,29 @@     ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W-import XMonad.Util.XUtils (fi) -import Data.Maybe-import Control.Applicative((<$>))-import Control.Monad.Error ((<=<),guard,lift,runErrorT,throwError)+import Control.Monad.Except (runExceptT, throwError)+import Control.Monad.Trans (lift)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.WorkspaceByPos -- >--- > myManageHook = workspaceByPos <+> manageHook defaultConfig+-- > myManageHook = workspaceByPos <> manageHook def -- >--- > main = xmonad defaultConfig { manageHook = myManageHook }+-- > main = xmonad def { manageHook = myManageHook }  workspaceByPos :: ManageHook workspaceByPos = (maybe idHook doShift <=< liftX . needsMoving) =<< ask  needsMoving :: Window -> X (Maybe WorkspaceId)-needsMoving w = withDisplay $ \d -> do-    -- only relocate windows with non-zero position-    wa <- io $ getWindowAttributes d w-    fmap (const Nothing `either` Just) . runErrorT $ do+needsMoving w = safeGetWindowAttributes w >>= \case+    Nothing -> pure Nothing+    Just wa -> fmap (either (const Nothing) Just) . runExceptT $ do+        -- only relocate windows with non-zero position         guard $ wa_x wa /= 0 || wa_y wa /= 0         ws <- gets windowset         sc <- lift $ fromMaybe (W.current ws)
+ XMonad/Hooks/WorkspaceHistory.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DerivingVia #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Hooks.WorkspaceHistory+-- Description :  Keep track of workspace viewing order.+-- Copyright   :  (c) 2013 Dmitri Iouchtchenko+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Dmitri Iouchtchenko <johnnyspoon@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Keeps track of workspace viewing order.+--+-----------------------------------------------------------------------------++module XMonad.Hooks.WorkspaceHistory (+      -- * Usage+      -- $usage+      -- * Hooking+    workspaceHistoryHook+  , workspaceHistoryHookExclude+      -- * Querying+  , workspaceHistory+  , workspaceHistoryByScreen+  , workspaceHistoryWithScreen+    -- * Handling edits+  , workspaceHistoryTransaction+  , workspaceHistoryModify+  ) where++import Control.Applicative+import Control.DeepSeq+import Prelude+import XMonad+import XMonad.StackSet hiding (delete, filter, new)+import XMonad.Prelude (delete, find, foldl', groupBy, nub, sortBy, listToMaybe)+import qualified XMonad.Util.ExtensibleState as XS++-- $usage+-- To record the order in which you view workspaces, you can use this+-- module with the following in your @xmonad.hs@:+--+-- > import XMonad.Hooks.WorkspaceHistory (workspaceHistoryHook)+--+-- Then add the hook to your 'logHook':+--+-- >  main = xmonad $ def+-- >      { ...+-- >      , logHook = ... >> workspaceHistoryHook >> ...+-- >      , ...+-- >      }+--+-- If you want to completely exclude certain workspaces from entering+-- the history, you can use 'workspaceHistoryHookExclude' instead.  For+-- example, to ignore the named scratchpad workspace:+--+-- > import XMonad.Util.NamedScratchpad (scratchpadWorkspaceTag)+-- > ...+-- > , logHook = ... >> workspaceHistoryHookExclude [scratchpadWorkspaceTag] >> ...+--+-- To make use of the collected data, a query function is provided.++newtype WorkspaceHistory = WorkspaceHistory+  { history :: [(ScreenId, WorkspaceId)] -- ^ Workspace Screens in+                                         -- reverse-chronological order.+  }+  deriving (Read, Show)+  deriving NFData via [(Int, WorkspaceId)]++instance ExtensionClass WorkspaceHistory where+    initialValue = WorkspaceHistory []+    extensionType = PersistentExtension++-- | A 'logHook' that keeps track of the order in which workspaces have+-- been viewed.+workspaceHistoryHook :: X ()+workspaceHistoryHook = workspaceHistoryHookExclude []++-- | Like 'workspaceHistoryHook', but with the ability to exclude+-- certain workspaces.+workspaceHistoryHookExclude :: [WorkspaceId] -> X ()+workspaceHistoryHookExclude ws = XS.modify' . update =<< gets windowset+  where+    update :: WindowSet -> WorkspaceHistory -> WorkspaceHistory+    update s = force . updateLastActiveOnEachScreenExclude ws s++workspaceHistoryWithScreen :: X [(ScreenId, WorkspaceId)]+workspaceHistoryWithScreen = XS.gets history++workspaceHistoryByScreen :: X [(ScreenId, [WorkspaceId])]+workspaceHistoryByScreen =+  map (\wss -> (maybe 0 fst (listToMaybe wss), map snd wss)) .+  groupBy (\a b -> fst a == fst b) .+  sortBy (\a b -> compare (fst a) $ fst b)<$>+  workspaceHistoryWithScreen++-- | A list of workspace tags in the order they have been viewed, with the+-- most recent first. No duplicates are present, but not all workspaces are+-- guaranteed to appear, and there may be workspaces that no longer exist.+workspaceHistory :: X [WorkspaceId]+workspaceHistory = nub . map snd <$> XS.gets history++workspaceHistoryTransaction :: X () -> X ()+workspaceHistoryTransaction action = do+  startingHistory <- XS.gets history+  action+  new <- flip updateLastActiveOnEachScreen (WorkspaceHistory startingHistory) <$> gets windowset+  XS.put $! force new++-- | Update the last visible workspace on each monitor if needed+-- already there, or move it to the front if it is.+updateLastActiveOnEachScreen :: WindowSet -> WorkspaceHistory -> WorkspaceHistory+updateLastActiveOnEachScreen = updateLastActiveOnEachScreenExclude []++-- | Like 'updateLastActiveOnEachScreen', but with the ability to+-- exclude certain workspaces.+updateLastActiveOnEachScreenExclude :: [WorkspaceId] -> WindowSet -> WorkspaceHistory -> WorkspaceHistory+updateLastActiveOnEachScreenExclude ws StackSet {current = cur, visible = vis} wh =+  WorkspaceHistory { history = doUpdate cur $ foldl' updateLastForScreen (history wh) $ vis ++ [cur] }+  where+    firstOnScreen sid = find ((== sid) . fst)+    doUpdate Screen {workspace = Workspace { tag = wid }, screen = sid} curr =+      let newEntry = (sid, wid)+       in if wid `elem` ws then curr else newEntry : delete newEntry curr+    updateLastForScreen curr Screen {workspace = Workspace { tag = wid }, screen = sid} =+      let newEntry = (sid, wid)+          alreadyCurrent = Just newEntry == firstOnScreen sid curr+      in if alreadyCurrent || wid `elem` ws then curr else newEntry : delete newEntry curr++-- | Modify a the workspace history with a given pure function.+workspaceHistoryModify :: ([(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]) -> X ()+workspaceHistoryModify action = XS.modify' $ force . WorkspaceHistory . action . history
XMonad/Hooks/XPropManage.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Hooks.XPropManage+-- Description  : ManageHook matching on XProperties. -- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de> -- License      : BSD --@@ -19,15 +20,13 @@                  ) where  import Control.Exception as E-import Data.Char (chr)-import Data.Monoid (mconcat, Endo(..))- import Control.Monad.Trans (lift)  import XMonad+import XMonad.Prelude (Endo (..), chr)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Hooks.XPropManage -- > import qualified XMonad.StackSet as W@@ -58,7 +57,7 @@ -- should work fine. Others might not work. -- -type XPropMatch = ([(Atom, [String] -> Bool)], (Window -> X (WindowSet -> WindowSet)))+type XPropMatch = ([(Atom, [String] -> Bool)], Window -> X (WindowSet -> WindowSet))  pmX :: (Window -> X ()) -> Window -> X (WindowSet -> WindowSet) pmX f w = f w >> return id@@ -73,10 +72,10 @@       mkQuery (a, tf)    = fmap tf (getQuery a)       mkHook func        = ask >>= Query . lift . fmap Endo . func -getProp :: Display -> Window -> Atom -> X ([String])+getProp :: Display -> Window -> Atom -> X [String] getProp d w p = do     prop <- io $ E.catch (getTextProperty d w p >>= wcTextPropertyToTextList d) (\(_ :: IOException) -> return [[]])-    let filt q | q == wM_COMMAND = concat . map splitAtNull+    let filt q | q == wM_COMMAND = concatMap splitAtNull                | otherwise       = id     return (filt p prop) @@ -84,7 +83,7 @@ getQuery p = ask >>= \w ->  Query . lift $ withDisplay $ \d -> getProp d w p  splitAtNull :: String -> [String]-splitAtNull s = case dropWhile (== (chr 0)) s of+splitAtNull s = case dropWhile (== chr 0) s of     "" -> []     s' -> w : splitAtNull s''-          where (w, s'') = break (== (chr 0)) s'+          where (w, s'') = break (== chr 0) s'
XMonad/Layout/Accordion.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Accordion+-- Description :  Put non-focused windows in ribbons at the top and bottom of the screen. -- Copyright   :  (c) glasser@mit.edu -- License     :  BSD --@@ -24,18 +25,18 @@ import Data.Ratio  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Accordion -- -- Then edit your @layoutHook@ by adding the Accordion layout: -- -- > myLayout = Accordion ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  data Accordion a = Accordion deriving ( Read, Show )
XMonad/Layout/AutoMaster.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.AutoMaster+-- Description :  Change size of the stack area depending on the number of its windows. -- Copyright   :  (c) 2009 Ilya Portnov -- License     :  BSD3-style (see LICENSE) --@@ -20,19 +21,21 @@                              -- $usage                              autoMaster, AutoMaster                             ) where-import Control.Monad- import XMonad-import qualified XMonad.StackSet as W import XMonad.Layout.LayoutModifier+import XMonad.Prelude+import qualified XMonad.StackSet as W +import Control.Arrow (first)++ -- $usage -- This module defines layout modifier named autoMaster. It separates -- screen in two parts - master and slave. Master windows are arranged -- in one row, in slave area underlying layout is run. Size of slave area -- automatically increases when number of slave windows is increasing. ----- You can use this module by adding folowing in your @xmonad.hs@:+-- You can use this module by adding following in your @xmonad.hs@: -- -- > import XMonad.Layout.AutoMaster --@@ -57,7 +60,7 @@ autoMess (AutoMaster k bias delta) m = msum [fmap resize (fromMessage m),                                              fmap incmastern (fromMessage m)]     where incmastern (IncMasterN d) = AutoMaster (max 1 (k+d)) bias delta-          resize Expand = AutoMaster k (min ( 0.4)  $ bias+delta) delta+          resize Expand = AutoMaster k (min 0.4  $ bias+delta) delta           resize Shrink = AutoMaster k (max (-0.4)  $ bias-delta) delta  -- | Main layout function@@ -73,33 +76,33 @@     let n = length ws     if null ws then         runLayout wksp rect-        else do-          if (n<=k) then-              return ((divideRow rect ws),Nothing)+        else+          if n<=k then+              return (divideRow rect ws,Nothing)               else do               let master = take k ws-              let filtStack = stack >>= W.filter (\w -> not (w `elem` master))+              let filtStack = stack >>= W.filter (`notElem` master)               wrs <- runLayout (wksp {W.stack = filtStack}) (slaveRect rect n bias)-              return ((divideRow (masterRect rect n bias) master) ++ (fst wrs),-                      snd wrs)+              return $ first (divideRow (masterRect rect n bias) master ++)+                             wrs  -- | Calculates height of master area, depending on number of windows. masterHeight :: Int -> Float -> Float-masterHeight n bias = (calcHeight n) + bias+masterHeight n bias = calcHeight n + bias     where calcHeight :: Int -> Float           calcHeight 1 = 1.0-          calcHeight m = if (m<9) then (43/45) - (fromIntegral m)*(7/90) else (1/3)+          calcHeight m = if m<9 then (43/45) - fromIntegral m*(7/90) else 1/3  -- | Rectangle for master area masterRect :: Rectangle -> Int -> Float -> Rectangle masterRect (Rectangle sx sy sw sh) n bias = Rectangle sx sy sw h-    where h = round $ (fromIntegral sh)*(masterHeight n bias)+    where h = round $ fromIntegral sh*masterHeight n bias  -- | Rectangle for slave area slaveRect :: Rectangle -> Int -> Float -> Rectangle slaveRect (Rectangle sx sy sw sh) n bias = Rectangle sx (sy+mh) sw h-    where mh = round $ (fromIntegral sh)*(masterHeight n bias)-          h  = round $ (fromIntegral sh)*(1-masterHeight n bias)+    where mh = round $ fromIntegral sh*masterHeight n bias+          h  = round $ fromIntegral sh*(1-masterHeight n bias)  -- | Divide rectangle between windows divideRow :: Rectangle -> [a] -> [(a, Rectangle)]@@ -120,4 +123,3 @@               l a ->               ModifiedLayout AutoMaster l a autoMaster nmaster delta = ModifiedLayout (AutoMaster nmaster 0 delta)-
+ XMonad/Layout/AvoidFloats.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TupleSections #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.AvoidFloats+-- Description :  Avoid floats when placing tiled windows.+-- Copyright   :  (c) 2014 Anders Engstrom <ankaan@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  (c) Anders Engstrom <ankaan@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Find a maximum empty rectangle around floating windows and use that area+-- to display non-floating windows.+--+-----------------------------------------------------------------------------++module XMonad.Layout.AvoidFloats (+                                   -- * Usage+                                   -- $usage+                                   avoidFloats,+                                   avoidFloats',+                                   AvoidFloatMsg(..),+                                   AvoidFloatItemMsg(..),+                                 ) where++import XMonad+import XMonad.Layout.LayoutModifier+import XMonad.Prelude (fi, mapMaybe, maximumBy, sortOn)+import qualified XMonad.StackSet as W++import Data.Ord+import qualified Data.Map as M+import qualified Data.Set as S++-- $usage+-- You can use this module with the following in your @xmonad.hs@ file:+--+-- > import XMonad.Layout.AvoidFloats+--+-- and modify the layouts to call avoidFloats on the layouts where you want the+-- non-floating windows to not be behind floating windows.+--+-- > layoutHook = ... ||| avoidFloats Full ||| ...+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".+--+-- Then add appropriate key bindings, for example:+--+-- > ,((modm .|. shiftMask, xK_b), sendMessage AvoidFloatToggle)+-- > ,((modm .|. controlMask, xK_b), withFocused $ sendMessage . AvoidFloatToggleItem)+-- > ,((modm .|. shiftMask .|. controlMask, xK_b), sendMessage (AvoidFloatSet False) >> sendMessage AvoidFloatClearItems)+--+-- For detailed instructions on editing your key bindings, see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.+--+-- Note that this module is incompatible with an old way of configuring+-- "XMonad.Actions.FloatSnap". If you are having problems, please update your+-- configuration.++-- | Avoid floating windows unless the resulting area for windows would be too small.+--   In that case, use the whole screen as if this layout modifier wasn't there.+--   No windows are avoided by default, they need to be added using signals.+avoidFloats+    :: l a  -- ^ Layout to modify.+    -> ModifiedLayout AvoidFloats l a+avoidFloats = avoidFloats' 100 100 False++-- | Avoid floating windows unless the resulting area for windows would be too small.+--   In that case, use the whole screen as if this layout modifier wasn't there.+avoidFloats'+    :: Int  -- ^ Minimum width of the area used for non-floating windows.+    -> Int  -- ^ Minimum height of the area used for non-floating windows.+    -> Bool -- ^ If floating windows should be avoided by default.+    -> l a  -- ^ Layout to modify.+    -> ModifiedLayout AvoidFloats l a+avoidFloats' w h act = ModifiedLayout (AvoidFloats Nothing S.empty w h act)++data AvoidFloats a = AvoidFloats+    { cache :: Maybe ((M.Map a W.RationalRect, Rectangle), Rectangle)+    , chosen :: S.Set a+    , minw :: Int+    , minh :: Int+    , avoidAll :: Bool+    } deriving (Read, Show)++-- | Change the state of the whole avoid float layout modifier.+data AvoidFloatMsg+    = AvoidFloatToggle        -- ^ Toggle between avoiding all or only selected.+    | AvoidFloatSet Bool      -- ^ Set if all all floating windows should be avoided.+    | AvoidFloatClearItems    -- ^ Clear the set of windows to specifically avoid.++-- | Change the state of the avoid float layout modifier conserning a specific window.+data AvoidFloatItemMsg a+    = AvoidFloatAddItem a     -- ^ Add a window to always avoid.+    | AvoidFloatRemoveItem a  -- ^ Stop always avoiding selected window.+    | AvoidFloatToggleItem a  -- ^ Toggle between always avoiding selected window.++instance Message AvoidFloatMsg+instance Typeable a => Message (AvoidFloatItemMsg a)++instance LayoutModifier AvoidFloats Window where+    modifyLayoutWithUpdate lm w r = withDisplay $ \d -> do+        floating <- gets $ W.floating . windowset+        case cache lm of+            Just (key, mer) | key == (floating,r) -> (, Nothing) <$> runLayout w mer+            _ -> do rs <- io $ map toRect <$> mapM (getWindowAttributes d) (filter shouldAvoid $ M.keys floating)+                    let mer = maximumBy (comparing area) $ filter bigEnough $ maxEmptyRectangles r rs+                    (, Just $ pruneWindows $ lm { cache = Just ((floating,r),mer) }) <$> runLayout w mer+        where+            toRect :: WindowAttributes -> Rectangle+            toRect wa = let b = fi $ wa_border_width wa+                        in Rectangle (fi $ wa_x wa) (fi $ wa_y wa) (fi $ wa_width wa + 2*b) (fi $ wa_height wa + 2*b)++            bigEnough :: Rectangle -> Bool+            bigEnough rect = rect_width rect >= fi (minw lm) && rect_height rect >= fi (minh lm)++            shouldAvoid a = avoidAll lm || a `S.member` chosen lm++    pureMess lm m+        | Just AvoidFloatToggle <- fromMessage m =                                 Just $ lm { avoidAll = not (avoidAll lm), cache = Nothing }+        | Just (AvoidFloatSet s) <- fromMessage m, s /= avoidAll lm =              Just $ lm { avoidAll = s, cache = Nothing }+        | Just AvoidFloatClearItems <- fromMessage m =                             Just $ lm { chosen = S.empty, cache = Nothing }+        | Just (AvoidFloatAddItem a) <- fromMessage m, a `S.notMember` chosen lm = Just $ lm { chosen = S.insert a (chosen lm), cache = Nothing }+        | Just (AvoidFloatRemoveItem a) <- fromMessage m, a `S.member` chosen lm = Just $ lm { chosen = S.delete a (chosen lm), cache = Nothing }+        | Just (AvoidFloatToggleItem a) <- fromMessage m =                         let op = if a `S.member` chosen lm then S.delete else S.insert+                                                                                   in Just $ lm { chosen = op a (chosen lm), cache = Nothing }+        | otherwise =                                                              Nothing++pruneWindows :: AvoidFloats Window -> AvoidFloats Window+pruneWindows lm = case cache lm of+    Nothing -> lm+    Just ((floating,_),_) -> lm { chosen = S.filter (`M.member` floating) (chosen lm) }++-- | Find all maximum empty rectangles (MERs) that are axis aligned. This is+--   done in O(n^2) time using a modified version of the algoprithm MERAlg 1+--   described in \"On the maximum empty rectangle problem\" by A. Naamad, D.T.+--   Lee and W.-L HSU. Published in Discrete Applied Mathematics 8 (1984.)+maxEmptyRectangles :: Rectangle -> [Rectangle] -> [Rectangle]+maxEmptyRectangles br rectangles = filter (\a -> area a > 0) $ upAndDownEdge ++ noneOrUpEdge ++ downEdge+    where+        upAndDownEdge = findGaps br rectangles+        noneOrUpEdge = concatMap (everyLower br bottoms) bottoms+        downEdge = mapMaybe (bottomEdge br bottoms) bottoms+        bottoms = sortOn bottom $ splitContainers rectangles++everyLower :: Rectangle -> [Rectangle] -> Rectangle -> [Rectangle]+everyLower br bottoms r = let (rs, boundLeft, boundRight, boundRects) = foldr (everyUpper r) ([], left br, right br, reverse bottoms) bottoms+                              (boundLeft', boundRight', _) = shrinkBounds boundLeft boundRight boundRects r (top br)+                          in mkRect boundLeft' boundRight' (top br) (top r) ?: rs++everyUpper+    :: Rectangle                         -- ^ The current rectangle where the top edge is used.+    -> Rectangle                         -- ^ The current rectangle where the bottom edge is used.+    -> ([Rectangle],Int,Int,[Rectangle]) -- ^ List of MERs found so far, left bound, right bound and list of rectangles used for bounds.+    -> ([Rectangle],Int,Int,[Rectangle])+everyUpper lower upper (rs, boundLeft, boundRight, boundRects) = (r?:rs, boundLeft', boundRight', boundRects')+    where+        r = mkRect boundLeft' boundRight' (bottom upper) (top lower)+        (boundLeft', boundRight', boundRects') = shrinkBounds boundLeft boundRight boundRects lower (bottom upper)++shrinkBounds :: Int -> Int -> [Rectangle] -> Rectangle -> Int -> (Int, Int, [Rectangle])+shrinkBounds boundLeft boundRight boundRects lower upperLimit = (boundLeft', boundRight', boundRects')+    where+        (shrinkers, boundRects') = span (\a -> bottom a > upperLimit) boundRects+        (boundLeft', boundRight') = foldr (shrinkBounds' lower) (boundLeft, boundRight) $ filter (\a -> top a < top lower) shrinkers++shrinkBounds' :: Rectangle -> Rectangle -> (Int, Int) -> (Int, Int)+shrinkBounds' mr r (boundLeft, boundRight)+    | right r < right mr = (max boundLeft $ right r, boundRight)+    | left r > left mr = (boundLeft, min boundRight $ left r)+    | otherwise = (right r, left r) -- r is horizontally covering all of mr; make sure the area of this rectangle will always be 0.++bottomEdge :: Rectangle -> [Rectangle] -> Rectangle -> Maybe Rectangle+bottomEdge br bottoms r = let rs = filter (\a -> bottom r < bottom a && top a < bottom br) bottoms+                              boundLeft = maximum $ left br : filter (< right r) (map right rs)+                              boundRight = minimum $ right br : filter (> left r) (map left rs)+                          in if any (\a -> left a <= left r && right r <= right a) rs+                             then Nothing+                             else mkRect boundLeft boundRight (bottom r) (bottom br)++-- | Split rectangles that horizontally fully contains another rectangle+--   without sharing either the left or right side.+splitContainers :: [Rectangle] -> [Rectangle]+splitContainers rects = splitContainers' [] $ sortOn rect_width rects+    where+        splitContainers' :: [Rectangle] -> [Rectangle] -> [Rectangle]+        splitContainers' res [] = res+        splitContainers' res (r:rs) = splitContainers' (r:res) $ concatMap (doSplit r) rs++        doSplit :: Rectangle -> Rectangle -> [Rectangle]+        doSplit guide r+            | left guide <= left r || right r <= right guide = [r]+            | otherwise = let w0 = fi (rect_x guide - rect_x r) + (rect_width guide `div` 2)+                              w1 = rect_width r - w0+                          in  [ Rectangle (rect_x r)          (rect_y r) w0 (rect_height r)+                              , Rectangle (rect_x r + fi w0)  (rect_y r) w1 (rect_height r)+                              ]++-- | Find all horizontal gaps that are left empty from top to bottom of screen.+findGaps+    :: Rectangle    -- ^ Bounding rectangle.+    -> [Rectangle]  -- ^ List of all rectangles that can cover areas in the bounding rectangle.+    -> [Rectangle]+findGaps br rs = let (gaps,end) = foldr findGaps' ([], left br) $ sortOn (Down . left) $ filter inBounds rs+                     lastgap = mkRect end (right br) (top br) (bottom br)+                 in lastgap?:gaps+    where+        findGaps' :: Rectangle -> ([Rectangle], Int) -> ([Rectangle], Int)+        findGaps' r (gaps, end) = let gap = mkRect end (left r) (top br) (bottom br)+                                  in (gap?:gaps, max end (right r))++        inBounds :: Rectangle -> Bool+        inBounds r = left r < right br && left br < right r++(?:) :: Maybe a -> [a] -> [a]+Just x ?: xs = x:xs+_ ?: xs = xs++left, right, top, bottom, area :: Rectangle -> Int+left r = fi (rect_x r)+right r = fi (rect_x r) + fi (rect_width r)+top r = fi (rect_y r)+bottom r = fi (rect_y r) + fi (rect_height r)+area r = fi (rect_width r * rect_height r)++mkRect :: Int -> Int -> Int -> Int -> Maybe Rectangle+mkRect l r t b = let rect = Rectangle (fi l) (fi t) (fi $ max 0 $ r-l) (fi $ max 0 $ b-t)+                 in if area rect > 0+                    then Just rect+                    else Nothing
+ XMonad/Layout/BinaryColumn.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.BinaryColumn+-- Description :  A layout that places all windows in one column.+-- Copyright   :  (c) 2009 Ilya Portnov, (c) 2018 Campbell Barton+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Campbell Barton <ideasman42@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides Column layout that places all windows in one column.+-- Each window is half the height of the previous,+-- except for the last pair of windows.+--+-- Note: Originally based on "XMonad.Layout.Column" with changes:+--+-- * Adding/removing windows doesn't resize all other windows.+-- (last window pair exception).+-- * Minimum window height option.+--+-----------------------------------------------------------------------------++module XMonad.Layout.BinaryColumn (+                             -- * Usage+                             -- $usage+                             BinaryColumn (..)+                            ) where+import XMonad+import qualified XMonad.StackSet+import qualified Data.List++-- $usage+-- This module defines layout named BinaryColumn.+-- It places all windows in one column.+-- Windows heights are calculated to prevent window resizing whenever+-- a window is added or removed.+-- This is done by keeping the last two windows in the stack the same height.+--+-- You can use this module by adding following in your @xmonad.hs@:+--+-- > import XMonad.Layout.BinaryColumn+--+-- Then add layouts to your layoutHook:+--+-- > myLayoutHook = BinaryColumn 1.0 32 ||| ...+--+-- The first value causes the master window to take exactly half of the screen,+-- the second ensures that windows are no less than 32 pixels tall.+--+-- Shrink/Expand can be used to adjust the first value by increments of 0.1.+--+-- * 2.0 uses all space for the master window+-- (minus the space for windows which get their fixed height).+-- * 0.0 gives an evenly spaced grid.+-- Negative values reverse the sizes so the last+-- window in the stack becomes larger.+--++data BinaryColumn a = BinaryColumn Float Int+  deriving (Read, Show)++instance XMonad.LayoutClass BinaryColumn a where+  pureLayout = columnLayout+  pureMessage = columnMessage++columnMessage :: BinaryColumn a -> SomeMessage -> Maybe (BinaryColumn a)+columnMessage (BinaryColumn q min_size) m = fmap resize (fromMessage m)+  where+    resize Shrink = BinaryColumn (max (-2.0) (q - 0.1)) min_size+    resize Expand = BinaryColumn (min   2.0  (q + 0.1)) min_size++columnLayout :: BinaryColumn a+  -> XMonad.Rectangle+  -> XMonad.StackSet.Stack a+  -> [(a, XMonad.Rectangle)]+columnLayout (BinaryColumn scale min_size) rect stack = zip ws rects+  where+    ws = XMonad.StackSet.integrate stack+    n = length ws+    scale_abs = abs scale+    heights_noflip =+      let+        -- Regular case: check for min size.+        f m size divide False = let+          m_fl = fromIntegral m+          m_prev_fl = fromIntegral (m + 1)+          div_test = min divide m_prev_fl+          value_test = round (fromIntegral size / div_test) :: Integer+          value_max = size - toInteger (min_size * m)+          (value, divide_next, no_room) =+            if value_test < value_max then+              (value_test, divide, False)+            else+              (value_max, m_fl, True)+          size_next = size - value+          m_next = m - 1+          in value+          : f m_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 m size divide True = let+          divide_next = fromIntegral m+          value_even = (fromIntegral size / divide)+          value = round value_even :: Integer++          m_next = m - 1+          size_next = size - value+          in value+          : f m_next size_next divide_next True+      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 = zipWith (curry (mkRect rect)) 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)
+ XMonad/Layout/BinarySpacePartition.hs view
@@ -0,0 +1,873 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.BinarySpacePartition+-- Description :  New windows split the focused window in half; based off of BSPWM.+-- Copyright   :  (c) 2013 Ben Weitzman    <benweitzman@gmail.com>+--                    2015 Anton Pirogov   <anton.pirogov@gmail.com>+--                    2019 Mateusz Karbowy <obszczymucha@gmail.com+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Ben Weitzman <benweitzman@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Layout where new windows will split the focused window in half, based off of BSPWM+--+-----------------------------------------------------------------------------++module XMonad.Layout.BinarySpacePartition (+  -- * Usage+  -- $usage+    emptyBSP+  , BinarySpacePartition+  , Rotate(..)+  , Swap(..)+  , ResizeDirectional(.., ExpandTowards, ShrinkFrom, MoveSplit)+  , TreeRotate(..)+  , TreeBalance(..)+  , FocusParent(..)+  , SelectMoveNode(..)+  , Direction2D(..)+  , SplitShiftDirectional(..)+  ) where++import XMonad+import XMonad.Prelude hiding (insert)+import qualified XMonad.StackSet as W+import XMonad.Hooks.ManageHelpers (isMinimized)+import XMonad.Util.Stack hiding (Zipper)+import XMonad.Util.Types++-- for mouse resizing+import XMonad.Layout.WindowArranger (WindowArrangerMsg(SetGeometry))+-- for "focus parent" node border+import XMonad.Util.XUtils++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Ratio ((%))++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Layout.BinarySpacePartition+--+-- Then add the layout, using the default BSP (BinarySpacePartition)+--+-- > myLayout = emptyBSP ||| etc ..+--+-- It may be a good idea to use "XMonad.Actions.Navigation2D" to move between the windows.+--+-- This layout responds to SetGeometry and is compatible with e.g. "XMonad.Actions.MouseResize"+-- or "XMonad.Layout.BorderResize". You should probably try both to decide which is better for you,+-- if you want to be able to resize the splits with the mouse.+--+-- If you don't want to use the mouse, add the following key bindings to resize the splits with the keyboard:+--+-- > , ((modm .|. altMask,                 xK_l     ), sendMessage $ ExpandTowards R)+-- > , ((modm .|. altMask,                 xK_h     ), sendMessage $ ExpandTowards L)+-- > , ((modm .|. altMask,                 xK_j     ), sendMessage $ ExpandTowards D)+-- > , ((modm .|. altMask,                 xK_k     ), sendMessage $ ExpandTowards U)+-- > , ((modm .|. altMask .|. ctrlMask ,   xK_l     ), sendMessage $ ShrinkFrom R)+-- > , ((modm .|. altMask .|. ctrlMask ,   xK_h     ), sendMessage $ ShrinkFrom L)+-- > , ((modm .|. altMask .|. ctrlMask ,   xK_j     ), sendMessage $ ShrinkFrom D)+-- > , ((modm .|. altMask .|. ctrlMask ,   xK_k     ), sendMessage $ ShrinkFrom U)+-- > , ((modm,                             xK_r     ), sendMessage Rotate)+-- > , ((modm,                             xK_s     ), sendMessage Swap)+-- > , ((modm,                             xK_n     ), sendMessage FocusParent)+-- > , ((modm .|. ctrlMask,                xK_n     ), sendMessage SelectNode)+-- > , ((modm .|. shiftMask,               xK_n     ), sendMessage MoveNode)+-- > , ((modm .|. shiftMask .|. ctrlMask , xK_j     ), sendMessage $ SplitShift Prev)+-- > , ((modm .|. shiftMask .|. ctrlMask , xK_k     ), sendMessage $ SplitShift Next)+--+-- Here's an alternative key mapping, this time using additionalKeysP,+-- arrow keys, and slightly different behavior when resizing windows+--+-- > , ("M-M1-<Left>",    sendMessage $ ExpandTowards L)+-- > , ("M-M1-<Right>",   sendMessage $ ShrinkFrom L)+-- > , ("M-M1-<Up>",      sendMessage $ ExpandTowards U)+-- > , ("M-M1-<Down>",    sendMessage $ ShrinkFrom U)+-- > , ("M-M1-C-<Left>",  sendMessage $ ShrinkFrom R)+-- > , ("M-M1-C-<Right>", sendMessage $ ExpandTowards R)+-- > , ("M-M1-C-<Up>",    sendMessage $ ShrinkFrom D)+-- > , ("M-M1-C-<Down>",  sendMessage $ ExpandTowards D)+-- > , ("M-s",            sendMessage $ Swap)+-- > , ("M-M1-s",         sendMessage $ Rotate)+-- > , ("M-S-C-j",        sendMessage $ SplitShift Prev)+-- > , ("M-S-C-k",        sendMessage $ SplitShift Next)+--+-- Note that @ExpandTowards x@, @ShrinkFrom x@, and @MoveSplit x@ are+-- the same as respectively @ExpandTowardsBy x 0.05@, @ShrinkFromBy x 0.05@+-- and @MoveSplitBy x 0.05@.+--+-- If you have many windows open and the layout begins to look too hard to manage, you can 'Balance'+-- the layout, so that the current splittings are discarded and windows are tiled freshly in a way that+-- the split depth is minimized. You can combine this with 'Equalize', which does not change your tree,+-- but tunes the split ratios in a way that each window gets the same amount of space:+--+-- > , ((myModMask,               xK_a),     sendMessage Balance)+-- > , ((myModMask .|. shiftMask, xK_a),     sendMessage Equalize)+--++-- | Message for rotating the binary tree around the parent node of the window to the left or right+data TreeRotate = RotateL | RotateR+instance Message TreeRotate++-- | Message to balance the tree in some way (Balance retiles the windows, Equalize changes ratios)+data TreeBalance = Balance | Equalize+instance Message TreeBalance++-- | Message for resizing one of the cells in the BSP+data ResizeDirectional =+        ExpandTowardsBy Direction2D Rational+      | ShrinkFromBy Direction2D Rational+      | MoveSplitBy Direction2D Rational+instance Message ResizeDirectional++-- | @ExpandTowards x@ is now the equivalent of @ExpandTowardsBy x 0.05@+pattern ExpandTowards :: Direction2D -> ResizeDirectional+pattern ExpandTowards d = ExpandTowardsBy d 0.05++-- | @ShrinkFrom x@ is now the equivalent of @ShrinkFromBy x 0.05@+pattern ShrinkFrom :: Direction2D -> ResizeDirectional+pattern ShrinkFrom d = ShrinkFromBy d 0.05++-- | @MoveSplit x@ is now the equivalent of @MoveSplitBy x 0.05@+pattern MoveSplit :: Direction2D -> ResizeDirectional+pattern MoveSplit d = MoveSplitBy d 0.05++-- | Message for rotating a split (horizontal/vertical) in the BSP+data Rotate = Rotate+instance Message Rotate++-- | Message for swapping the left child of a split with the right child of split+data Swap = Swap+instance Message Swap++-- | Message to cyclically select the parent node instead of the leaf+data FocusParent = FocusParent+instance Message FocusParent++-- | Message to move nodes inside the tree+data SelectMoveNode = SelectNode | MoveNode+instance Message SelectMoveNode++data Axis = Horizontal | Vertical deriving (Show, Read, Eq)++-- | Message for shifting window by splitting its neighbour+newtype SplitShiftDirectional = SplitShift Direction1D+instance Message SplitShiftDirectional++oppositeDirection :: Direction2D -> Direction2D+oppositeDirection U = D+oppositeDirection D = U+oppositeDirection L = R+oppositeDirection R = L++oppositeAxis :: Axis -> Axis+oppositeAxis Vertical = Horizontal+oppositeAxis Horizontal = Vertical++toAxis :: Direction2D -> Axis+toAxis U = Horizontal+toAxis D = Horizontal+toAxis L = Vertical+toAxis R = Vertical++split :: Axis -> Rational -> Rectangle -> (Rectangle, Rectangle)+split Horizontal r (Rectangle sx sy sw sh) = (r1, r2) where+    r1 = Rectangle sx sy sw sh'+    r2 = Rectangle sx (sy + fromIntegral sh') sw (sh - sh')+    sh' = floor $ fromIntegral sh * r+split Vertical r (Rectangle sx sy sw sh) = (r1, r2) where+    r1 = Rectangle sx sy sw' sh+    r2 = Rectangle (sx + fromIntegral sw') sy (sw - sw') sh+    sw' = floor $ fromIntegral sw * r++data Split = Split { axis :: Axis+                   , ratio :: Rational+                   } deriving (Show, Read, Eq)++oppositeSplit :: Split -> Split+oppositeSplit (Split d r) = Split (oppositeAxis d) r++increaseRatio :: Split -> Rational -> Split+increaseRatio (Split d r) delta = Split d (min 0.9 (max 0.1 (r + delta)))++data Tree a = Leaf Int | Node { value :: a+                          , left :: Tree a+                          , right :: Tree a+                          } deriving (Show, Read, Eq)++numLeaves :: Tree a -> Int+numLeaves (Leaf _) = 1+numLeaves (Node _ l r) = numLeaves l + numLeaves r++-- right or left rotation of a (sub)tree, no effect if rotation not possible+rotTree :: Direction2D -> Tree a -> Tree a+rotTree _ (Leaf n) = Leaf n+rotTree R n@(Node _ (Leaf _) _) = n+rotTree L n@(Node _ _ (Leaf _)) = n+rotTree R (Node sp (Node sp2 l2 r2) r) = Node sp2 l2 (Node sp r2 r)+rotTree L (Node sp l (Node sp2 l2 r2)) = Node sp2 (Node sp l l2) r2+rotTree _ t = t+++data Crumb a = LeftCrumb a (Tree a) | RightCrumb a (Tree a) deriving (Show, Read, Eq)++swapCrumb :: Crumb a -> Crumb a+swapCrumb (LeftCrumb s t) = RightCrumb s t+swapCrumb (RightCrumb s t) = LeftCrumb s t++parentVal :: Crumb a -> a+parentVal (LeftCrumb s _) = s+parentVal (RightCrumb s _) = s++modifyParentVal :: (a -> a) -> Crumb a -> Crumb a+modifyParentVal f (LeftCrumb s t) = LeftCrumb (f s) t+modifyParentVal f (RightCrumb s t) = RightCrumb (f s) t++type Zipper a = (Tree a, [Crumb a])++toZipper :: Tree a -> Zipper a+toZipper t = (t, [])++goLeft :: Zipper a -> Maybe (Zipper a)+goLeft (Leaf _, _) = Nothing+goLeft (Node x l r, bs) = Just (l, LeftCrumb x r:bs)++goRight :: Zipper a -> Maybe (Zipper a)+goRight (Leaf _, _) = Nothing+goRight (Node x l r, bs) = Just (r, RightCrumb x l:bs)++goUp :: Zipper a -> Maybe (Zipper a)+goUp (_, []) = Nothing+goUp (t, LeftCrumb x r:cs) = Just (Node x t r, cs)+goUp (t, RightCrumb x l:cs) = Just (Node x l t, cs)++goSibling :: Zipper a -> Maybe (Zipper a)+goSibling (_, []) = Nothing+goSibling z@(_, LeftCrumb _ _:_) = Just z >>= goUp >>= goRight+goSibling z@(_, RightCrumb _ _:_) = Just z >>= goUp >>= goLeft++top :: Zipper a -> Zipper a+top z = maybe z top (goUp z)++toTree :: Zipper a -> Tree a+toTree = fst . top++goToNthLeaf :: Int -> Zipper a -> Maybe (Zipper a)+goToNthLeaf _ z@(Leaf _, _) = Just z+goToNthLeaf n z@(t, _) =+  if numLeaves (left t) > n+  then do z' <- goLeft z+          goToNthLeaf n z'+  else do z' <- goRight z+          goToNthLeaf (n - (numLeaves . left $ t)) z'++toggleSplits :: Tree Split -> Tree Split+toggleSplits (Leaf l) = Leaf l+toggleSplits (Node s l r) = Node (oppositeSplit s) (toggleSplits l) (toggleSplits r)++splitCurrent :: Zipper Split -> Maybe (Zipper Split)+splitCurrent (Leaf _, []) = Just (Node (Split Vertical 0.5) (Leaf 0) (Leaf 0), [])+splitCurrent (Leaf _, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) (Leaf 0) (Leaf 0), crumb:cs)+splitCurrent (n, []) = Just (Node (Split Vertical 0.5) (Leaf 0) (toggleSplits n), [])+splitCurrent (n, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) (Leaf 0) (toggleSplits n), crumb:cs)++removeCurrent :: Zipper a -> Maybe (Zipper a)+removeCurrent (Leaf _, LeftCrumb _ r:cs) = Just (r, cs)+removeCurrent (Leaf _, RightCrumb _ l:cs) = Just (l, cs)+removeCurrent (Leaf _, []) = Nothing+removeCurrent (Node _ (Leaf _) r@Node{}, cs) = Just (r, cs)+removeCurrent (Node _ l@Node{} (Leaf _), cs) = Just (l, cs)+removeCurrent (Node _ (Leaf _) (Leaf _), cs) = Just (Leaf 0, cs)+removeCurrent z@(Node{}, _) = goLeft z >>= removeCurrent++rotateCurrent :: Zipper Split -> Maybe (Zipper Split)+rotateCurrent l@(_, []) = Just l+rotateCurrent (n, c:cs) = Just (n, modifyParentVal oppositeSplit c:cs)++swapCurrent :: Zipper a -> Maybe (Zipper a)+swapCurrent l@(_, []) = Just l+swapCurrent (n, c:cs) = Just (n, swapCrumb c:cs)++insertLeftLeaf :: Tree Split -> Zipper Split -> Maybe (Zipper Split)+insertLeftLeaf (Leaf n) (Node x l r, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) (Leaf n) (Node x l r), crumb:cs)+insertLeftLeaf (Leaf n) (Leaf x, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) (Leaf n) (Leaf x), crumb:cs)+insertLeftLeaf Node{} z = Just z+insertLeftLeaf _ _ = Nothing++insertRightLeaf :: Tree Split -> Zipper Split -> Maybe (Zipper Split)+insertRightLeaf (Leaf n) (Node x l r, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) (Node x l r) (Leaf n), crumb:cs)+insertRightLeaf (Leaf n) (Leaf x, crumb:cs) = Just (Node (Split (oppositeAxis . axis . parentVal $ crumb) 0.5) (Leaf x) (Leaf n), crumb:cs)+insertRightLeaf Node{} z = Just z+insertRightLeaf _ _ = Nothing++findRightLeaf :: Zipper Split -> Maybe (Zipper Split)+findRightLeaf n@(Node{}, _) = goRight n >>= findRightLeaf+findRightLeaf l@(Leaf _, _) = Just l++findLeftLeaf :: Zipper Split -> Maybe (Zipper Split)+findLeftLeaf n@(Node{}, _) = goLeft n+findLeftLeaf l@(Leaf _, _) = Just l++findTheClosestLeftmostLeaf :: Zipper Split -> Maybe (Zipper Split)+findTheClosestLeftmostLeaf s@(_, (RightCrumb _ _):_) = goUp s >>= goLeft >>= findRightLeaf+findTheClosestLeftmostLeaf s@(_, (LeftCrumb _ _):_) = goUp s >>= findTheClosestLeftmostLeaf+findTheClosestLeftmostLeaf _ = Nothing++findTheClosestRightmostLeaf :: Zipper Split -> Maybe (Zipper Split)+findTheClosestRightmostLeaf s@(_, (RightCrumb _ _):_) = goUp s >>= findTheClosestRightmostLeaf+findTheClosestRightmostLeaf s@(_, (LeftCrumb _ _):_) = goUp s >>= goRight >>= findLeftLeaf+findTheClosestRightmostLeaf _ = Nothing++splitShiftLeftCurrent :: Zipper Split -> Maybe (Zipper Split)+splitShiftLeftCurrent l@(_, []) = Just l+splitShiftLeftCurrent l@(_, (RightCrumb _ _):_) = Just l -- Do nothing. We can swap windows instead.+splitShiftLeftCurrent l@(n, _) = removeCurrent l >>= findTheClosestLeftmostLeaf >>= insertRightLeaf n++splitShiftRightCurrent :: Zipper Split -> Maybe (Zipper Split)+splitShiftRightCurrent l@(_, []) = Just l+splitShiftRightCurrent l@(_, (LeftCrumb _ _):_) = Just l -- Do nothing. We can swap windows instead.+splitShiftRightCurrent l@(n, _) = removeCurrent l >>= findTheClosestRightmostLeaf >>= insertLeftLeaf n++isAllTheWay :: Direction2D -> Rational -> Zipper Split -> Bool+isAllTheWay _ _ (_, []) = True+isAllTheWay R _ (_, LeftCrumb s _:_)+  | axis s == Vertical = False+isAllTheWay L _ (_, RightCrumb s _:_)+  | axis s == Vertical = False+isAllTheWay D _ (_, LeftCrumb s _:_)+  | axis s == Horizontal = False+isAllTheWay U _ (_, RightCrumb s _:_)+  | axis s == Horizontal = False+isAllTheWay dir diff z = fromMaybe False $ goUp z >>= Just . isAllTheWay dir diff++expandTreeTowards :: Direction2D -> Rational -> Zipper Split -> Maybe (Zipper Split)+expandTreeTowards _ _ z@(_, []) = Just z+expandTreeTowards dir diff z+  | isAllTheWay dir diff z = shrinkTreeFrom (oppositeDirection dir) diff z+expandTreeTowards R diff (t, LeftCrumb s r:cs)+  | axis s == Vertical = Just (t, LeftCrumb (increaseRatio s diff) r:cs)+expandTreeTowards L diff (t, RightCrumb s l:cs)+  | axis s == Vertical = Just (t, RightCrumb (increaseRatio s (-diff)) l:cs)+expandTreeTowards D diff (t, LeftCrumb s r:cs)+  | axis s == Horizontal = Just (t, LeftCrumb (increaseRatio s diff) r:cs)+expandTreeTowards U diff (t, RightCrumb s l:cs)+  | axis s == Horizontal = Just (t, RightCrumb (increaseRatio s (-diff)) l:cs)+expandTreeTowards dir diff z = goUp z >>= expandTreeTowards dir diff++shrinkTreeFrom :: Direction2D -> Rational -> Zipper Split -> Maybe (Zipper Split)+shrinkTreeFrom _ _ z@(_, []) = Just z+shrinkTreeFrom R diff z@(_, LeftCrumb s _:_)+  | axis s == Vertical = Just z >>= goSibling >>= expandTreeTowards L diff+shrinkTreeFrom L diff z@(_, RightCrumb s _:_)+  | axis s == Vertical = Just z >>= goSibling >>= expandTreeTowards R diff+shrinkTreeFrom D diff z@(_, LeftCrumb s _:_)+  | axis s == Horizontal = Just z >>= goSibling >>= expandTreeTowards U diff+shrinkTreeFrom U diff z@(_, RightCrumb s _:_)+  | axis s == Horizontal = Just z >>= goSibling >>= expandTreeTowards D diff+shrinkTreeFrom dir diff z = goUp z >>= shrinkTreeFrom dir diff++-- Direction2D refers to which direction the divider should move.+autoSizeTree :: Direction2D -> Rational -> Zipper Split -> Maybe (Zipper Split)+autoSizeTree _ _ z@(_, []) = Just z+autoSizeTree d f z =+    Just z >>= getSplit (toAxis d) >>= resizeTree d f++-- resizing once found the correct split. YOU MUST FIND THE RIGHT SPLIT FIRST.+resizeTree :: Direction2D -> Rational -> Zipper Split -> Maybe (Zipper Split)+resizeTree _ _ z@(_, []) = Just z+resizeTree R diff z@(_, LeftCrumb _ _:_) =+  Just z >>= expandTreeTowards R diff+resizeTree L diff z@(_, LeftCrumb _ _:_) =+  Just z >>= shrinkTreeFrom    R diff+resizeTree U diff z@(_, LeftCrumb _ _:_) =+  Just z >>= shrinkTreeFrom    D diff+resizeTree D diff z@(_, LeftCrumb _ _:_) =+  Just z >>= expandTreeTowards D diff+resizeTree R diff z@(_, RightCrumb _ _:_) =+  Just z >>= shrinkTreeFrom    L diff+resizeTree L diff z@(_, RightCrumb _ _:_) =+  Just z >>= expandTreeTowards L diff+resizeTree U diff z@(_, RightCrumb _ _:_) =+  Just z >>= expandTreeTowards U diff+resizeTree D diff z@(_, RightCrumb _ _:_) =+  Just z >>= shrinkTreeFrom    U diff++getSplit :: Axis -> Zipper Split -> Maybe (Zipper Split)+getSplit _ (_, []) = Nothing+getSplit d z =+ do let fs = findSplit d z+    if isNothing fs+      then findClosest d z+      else fs++findClosest :: Axis -> Zipper Split -> Maybe (Zipper Split)+findClosest _ z@(_, []) = Just z+findClosest d z@(_, LeftCrumb s _:_)+  | axis s == d = Just z+findClosest d z@(_, RightCrumb s _:_)+  | axis s == d = Just z+findClosest d z = goUp z >>= findClosest d++findSplit :: Axis -> Zipper Split -> Maybe (Zipper Split)+findSplit _ (_, []) = Nothing+findSplit d z@(_, LeftCrumb s _:_)+  | axis s == d = Just z+findSplit d z = goUp z >>= findSplit d++resizeSplit :: Direction2D -> (Rational,Rational) -> Zipper Split -> Maybe (Zipper Split)+resizeSplit _ _ z@(_, []) = Just z+resizeSplit dir (xsc,ysc) z = case goToBorder dir z of+  Nothing -> Just z+  Just (t@Node{}, crumb) -> Just $ case dir of+    R -> (t{value=sp{ratio=scaleRatio (ratio sp) xsc}}, crumb)+    D -> (t{value=sp{ratio=scaleRatio (ratio sp) ysc}}, crumb)+    L -> (t{value=sp{ratio=1-scaleRatio (1-ratio sp) xsc}}, crumb)+    U -> (t{value=sp{ratio=1-scaleRatio (1-ratio sp) ysc}}, crumb)+    where sp = value t+          scaleRatio r fac = min 0.9 $ max 0.1 $ r*fac+  Just (Leaf{}, _) ->+    undefined -- silence -Wincomplete-uni-patterns (goToBorder/goUp never return a Leaf)++-- starting from a leaf, go to node representing a border of the according window+goToBorder :: Direction2D -> Zipper Split -> Maybe (Zipper Split)+goToBorder L z@(_, RightCrumb (Split Vertical _) _:_) = goUp z+goToBorder L z = goUp z >>= goToBorder L+goToBorder R z@(_, LeftCrumb  (Split Vertical _) _:_) = goUp z+goToBorder R z = goUp z >>= goToBorder R+goToBorder U z@(_, RightCrumb (Split Horizontal _) _:_) = goUp z+goToBorder U z = goUp z >>= goToBorder U+goToBorder D z@(_, LeftCrumb  (Split Horizontal _) _:_) = goUp z+goToBorder D z = goUp z >>= goToBorder D++-- takes a list of indices and numerates the leaves of a given tree+numerate :: [Int] -> Tree a -> Tree a+numerate ns t = snd $ num ns t+  where num (n:nns) (Leaf _) = (nns, Leaf n)+        num [] (Leaf _) = ([], Leaf 0)+        num n (Node s l r) = (n'', Node s nl nr)+          where (n', nl)  = num n l+                (n'', nr) = num n' r++-- return values of leaves from left to right as list+flatten :: Tree a -> [Int]+flatten (Leaf n) = [n]+flatten (Node _ l r) = flatten l++flatten r++-- adjust ratios to make window areas equal+equalize :: Zipper Split -> Maybe (Zipper Split)+equalize (t, cs) = Just (eql t, cs)+  where eql (Leaf n) = Leaf n+        eql n@(Node s l r) = Node s{ratio=fromIntegral (numLeaves l) % fromIntegral (numLeaves n)}+                                  (eql l) (eql r)++-- generate a symmetrical balanced tree for n leaves from given tree, preserving leaf labels+balancedTree :: Zipper Split -> Maybe (Zipper Split)+balancedTree (t, cs) =  Just (numerate (flatten t) $ balanced (numLeaves t), cs)+  where balanced 1 = Leaf 0+        balanced 2 = Node (Split Horizontal 0.5) (Leaf 0) (Leaf 0)+        balanced m = Node (Split Horizontal 0.5) (balanced (m`div`2)) (balanced (m-m`div`2))++-- attempt to rotate splits optimally in order choose more quad-like rects+optimizeOrientation :: Rectangle -> Zipper Split -> Maybe (Zipper Split)+optimizeOrientation rct (t, cs) = Just (opt t rct, cs)+  where opt (Leaf v) _ = Leaf v+        opt (Node sp l r) rect = Node sp' (opt l lrect) (opt r rrect)+         where (Rectangle _ _ w1 h1,Rectangle _ _ w2 h2) = split (axis sp) (ratio sp) rect+               (Rectangle _ _ w3 h3,Rectangle _ _ w4 h4) = split (axis $ oppositeSplit sp) (ratio sp) rect+               f w h = if w > h then w'/h' else h'/w' where (w',h') = (fromIntegral w :: Double, fromIntegral h :: Double)+               wratio = min (f w1 h1) (f w2 h2)+               wratio' = min (f w3 h3) (f w4 h4)+               sp' = if wratio<wratio' then sp else oppositeSplit sp+               (lrect, rrect) = split (axis sp') (ratio sp') rect+++-- initially focused leaf, path from root to selected node, window ids of borders highlighting the selection+data NodeRef = NodeRef { refLeaf :: Int, refPath :: [Direction2D], refWins :: [Window] } deriving (Show,Read,Eq)+noRef :: NodeRef+noRef = NodeRef (-1) [] []++goToNode :: NodeRef -> Zipper a -> Maybe (Zipper a)+goToNode (NodeRef _ dirs _) z = foldM gofun z dirs+  where gofun z' L = goLeft z'+        gofun z' R = goRight z'+        gofun _ _ = Nothing++toNodeRef :: Int -> Maybe (Zipper Split) -> NodeRef+toNodeRef _ Nothing = noRef+toNodeRef l (Just (_, cs)) = NodeRef l (reverse $ map crumbToDir cs) []+  where crumbToDir (LeftCrumb _ _) = L+        crumbToDir (RightCrumb _ _) = R++-- returns the leaf a noderef is leading to, if any+nodeRefToLeaf :: NodeRef -> Maybe (Zipper a) -> Maybe Int+nodeRefToLeaf n (Just z) = case goToNode n z of+  Just (Leaf l, _) -> Just l+  Just (Node{}, _) -> Nothing+  Nothing -> Nothing+nodeRefToLeaf _ Nothing = Nothing++leafToNodeRef :: Int -> BinarySpacePartition a -> NodeRef+leafToNodeRef l b = toNodeRef l (makeZipper b >>= goToNthLeaf l)++data BinarySpacePartition a = BinarySpacePartition { getOldRects :: [(Window,Rectangle)]+                                                   , getFocusedNode :: NodeRef+                                                   , getSelectedNode :: NodeRef+                                                   , getTree :: Maybe (Tree Split) } deriving (Show, Read,Eq)++-- | an empty BinarySpacePartition to use as a default for adding windows to.+emptyBSP :: BinarySpacePartition a+emptyBSP = BinarySpacePartition [] noRef noRef Nothing++makeBSP :: Tree Split -> BinarySpacePartition a+makeBSP = BinarySpacePartition [] noRef noRef . Just++makeZipper :: BinarySpacePartition a -> Maybe (Zipper Split)+makeZipper (BinarySpacePartition _ _ _ Nothing) = Nothing+makeZipper (BinarySpacePartition _ _ _ (Just t)) = Just . toZipper $ t++size :: BinarySpacePartition a -> Int+size = maybe 0 numLeaves . getTree++zipperToBinarySpacePartition :: Maybe (Zipper Split) -> BinarySpacePartition b+zipperToBinarySpacePartition Nothing = emptyBSP+zipperToBinarySpacePartition (Just z) = BinarySpacePartition [] noRef noRef . Just . toTree . top $ z++rectangles :: BinarySpacePartition a -> Rectangle -> [Rectangle]+rectangles (BinarySpacePartition _ _ _ Nothing) _ = []+rectangles (BinarySpacePartition _ _ _ (Just (Leaf _))) rootRect = [rootRect]+rectangles (BinarySpacePartition _ _ _ (Just node)) rootRect =+    rectangles (makeBSP . left $ node) leftBox +++    rectangles (makeBSP . right $ node) rightBox+    where (leftBox, rightBox) = split (axis info) (ratio info) rootRect+          info = value node++getNodeRect :: BinarySpacePartition a -> Rectangle -> NodeRef -> Rectangle+getNodeRect b r n = fromMaybe (Rectangle 0 0 1 1) (makeZipper b >>= goToNode n >>= getRect [])+  where getRect ls (_, []) = Just $ foldl (\r' (s,f) -> f $ split' s r') r ls+        getRect ls z@(_, LeftCrumb s _:_) = goUp z >>= getRect ((s,fst):ls)+        getRect ls z@(_, RightCrumb s _:_) = goUp z >>= getRect ((s,snd):ls)+        split' s = split (axis s) (ratio s)++doToNth :: (Zipper Split -> Maybe (Zipper Split)) -> BinarySpacePartition a -> BinarySpacePartition a+doToNth f b = b{getTree=getTree $ zipperToBinarySpacePartition $ makeZipper b >>= goToNode (getFocusedNode b) >>= f}++splitNth :: BinarySpacePartition a -> BinarySpacePartition a+splitNth (BinarySpacePartition _ _ _ Nothing) = makeBSP (Leaf 0)+splitNth b = doToNth splitCurrent b++removeNth :: BinarySpacePartition a -> BinarySpacePartition a+removeNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP+removeNth (BinarySpacePartition _ _ _ (Just (Leaf _))) = emptyBSP+removeNth b = doToNth removeCurrent b++rotateNth :: BinarySpacePartition a -> BinarySpacePartition a+rotateNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP+rotateNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+rotateNth b = doToNth rotateCurrent b++swapNth :: BinarySpacePartition a -> BinarySpacePartition a+swapNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP+swapNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+swapNth b = doToNth swapCurrent b++splitShiftNth :: Direction1D -> BinarySpacePartition a -> BinarySpacePartition a+splitShiftNth _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP+splitShiftNth _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+splitShiftNth Prev b = doToNth splitShiftLeftCurrent b+splitShiftNth Next b = doToNth splitShiftRightCurrent b++growNthTowards :: Direction2D -> Rational -> BinarySpacePartition a -> BinarySpacePartition a+growNthTowards _ _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP+growNthTowards _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+growNthTowards dir diff b = doToNth (expandTreeTowards dir diff) b++shrinkNthFrom :: Direction2D -> Rational -> BinarySpacePartition a -> BinarySpacePartition a+shrinkNthFrom _ _ (BinarySpacePartition _ _ _ Nothing)= emptyBSP+shrinkNthFrom _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+shrinkNthFrom dir diff b = doToNth (shrinkTreeFrom dir diff) b++autoSizeNth :: Direction2D -> Rational -> BinarySpacePartition a -> BinarySpacePartition a+autoSizeNth _ _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP+autoSizeNth _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+autoSizeNth dir diff b = doToNth (autoSizeTree dir diff) b++resizeSplitNth :: Direction2D -> (Rational,Rational) -> BinarySpacePartition a -> BinarySpacePartition a+resizeSplitNth _ _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP+resizeSplitNth _ _ b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+resizeSplitNth dir sc b = doToNth (resizeSplit dir sc) b++-- rotate tree left or right around parent of nth leaf+rotateTreeNth :: Direction2D -> BinarySpacePartition a -> BinarySpacePartition a+rotateTreeNth _ (BinarySpacePartition _ _ _ Nothing) = emptyBSP+rotateTreeNth U b = b+rotateTreeNth D b = b+rotateTreeNth dir b@(BinarySpacePartition _ _ _ (Just _)) =+  doToNth (\t -> case goUp t of+                Nothing     -> Just t+                Just (t', c) -> Just (rotTree dir t', c)) b++equalizeNth :: BinarySpacePartition a -> BinarySpacePartition a+equalizeNth (BinarySpacePartition _ _ _ Nothing) = emptyBSP+equalizeNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) = b+equalizeNth b = doToNth equalize b++rebalanceNth :: BinarySpacePartition a -> Rectangle -> BinarySpacePartition a+rebalanceNth (BinarySpacePartition _ _ _ Nothing) _ = emptyBSP+rebalanceNth b@(BinarySpacePartition _ _ _ (Just (Leaf _))) _ = b+rebalanceNth b r = doToNth (balancedTree >=> optimizeOrientation r) b++flattenLeaves :: BinarySpacePartition a -> [Int]+flattenLeaves (BinarySpacePartition _ _ _ Nothing) = []+flattenLeaves (BinarySpacePartition _ _ _ (Just t)) = flatten t++-- we do this before an action to look afterwards which leaves moved where+numerateLeaves :: BinarySpacePartition a -> BinarySpacePartition a+numerateLeaves b@(BinarySpacePartition _ _ _ Nothing) = b+numerateLeaves b@(BinarySpacePartition _ _ _ (Just t)) = b{getTree=Just $ numerate ns t}+  where ns = [0..(numLeaves t-1)]++-- if there is a selected and focused node and the focused is not a part of selected,+-- move selected node to be a child of focused node+moveNode :: BinarySpacePartition a -> BinarySpacePartition a+moveNode b@(BinarySpacePartition _ (NodeRef (-1) _ _) _ _) = b+moveNode b@(BinarySpacePartition _ _ (NodeRef (-1) _ _) _) = b+moveNode b@(BinarySpacePartition _ _ _ Nothing) = b+moveNode b@(BinarySpacePartition _ f s (Just ot)) =+  case makeZipper b >>= goToNode s of+    Just (n, LeftCrumb _ t:cs)  -> b{getTree=Just $ insert n $ top (t, cs)}+    Just (n, RightCrumb _ t:cs) -> b{getTree=Just $ insert n $ top (t, cs)}+    _ -> b+  where insert t z = case goToNode f z of+          Nothing -> ot --return original tree (abort)+          Just (n, c:cs) -> toTree (Node (Split (oppositeAxis . axis . parentVal $ c) 0.5) t n, c:cs)+          Just (n, []) -> toTree (Node (Split Vertical 0.5) t n, [])++------------------------------------------++-- returns index of focused window or 0 for empty stack+index :: W.Stack a -> Int+index s = case toIndex (Just s) of+            (_, Nothing) -> 0+            (_, Just int) -> int++--move windows to new positions according to tree transformations, keeping focus on originally focused window+--CAREFUL here! introduce a bug here and have fun debugging as your windows start to disappear or explode+adjustStack :: Maybe (W.Stack Window)  --original stack+            -> Maybe (W.Stack Window)  --stack without floating windows+            -> [Window]                --just floating windows of this WS+            -> Maybe (BinarySpacePartition Window) -- Tree with numbered leaves telling what to move where+            -> Maybe (W.Stack Window)  --resulting stack+adjustStack orig Nothing _ _ = orig    --no new stack -> no changes+adjustStack orig _ _ Nothing = orig    --empty tree   -> no changes+adjustStack orig s fw (Just b) =+ if length ls<length ws then orig      --less leaves than non-floating windows -> tree incomplete, no changes+ else fromIndex ws' fid'+ where ws' = mapMaybe (`M.lookup` wsmap) ls ++ fw+       fid' = fromMaybe 0 $ elemIndex focused ws'+       wsmap = M.fromList $ zip [0..] ws -- map: old index in list -> window+       ls = flattenLeaves b              -- get new index ordering from tree+       (ws,fid) = toIndex s+       focused = ws !! fromMaybe 0 fid++--replace the window stack of the managed workspace with our modified stack+replaceStack :: Maybe (W.Stack Window) -> X ()+replaceStack s = do+  st <- get+  let wset = windowset st+      cur  = W.current wset+      wsp  = W.workspace cur+  put st{windowset=wset{W.current=cur{W.workspace=wsp{W.stack=s}}}}++replaceFloating :: M.Map Window W.RationalRect -> X ()+replaceFloating wsm = do+  st <- get+  let wset = windowset st+  put st{windowset=wset{W.floating=wsm}}++-- some helpers to filter windows+--+getFloating :: X [Window]+getFloating = M.keys . W.floating <$> gets windowset -- all floating windows++getHidden :: X [Window]+getHidden = getStackSet >>= filterM (runQuery isMinimized) . W.integrate'++getStackSet :: X (Maybe (W.Stack Window))+getStackSet = W.stack . W.workspace . W.current <$> gets windowset -- windows on this WS (with floating)++getScreenRect :: X Rectangle+getScreenRect = screenRect . W.screenDetail . W.current <$> gets windowset++withoutFloating :: [Window] -> [Window] -> Maybe (W.Stack Window) -> Maybe (W.Stack Window)+withoutFloating fs hs = maybe Nothing (unfloat fs hs)++-- ignore messages if current focus is on floating window, otherwise return stack without floating+unfloat :: [Window] -> [Window] -> W.Stack Window -> Maybe (W.Stack Window)+unfloat fs hs s = if W.focus s `elem` fs+      then Nothing+      else Just $ s{W.up = W.up s \\ (fs ++ hs), W.down = W.down s \\ (fs ++ hs)}++instance LayoutClass BinarySpacePartition Window where+  doLayout b r s = do+    let b' = layout b+    b'' <- updateNodeRef b' (size b/=size b') r+    let rs = rectangles b'' r+        wrs = zip ws rs+    return (wrs, Just b''{getOldRects=wrs})+    where+      ws = W.integrate s+      l = length ws+      layout bsp+        | l == sz = bsp+        | l > sz = layout $ splitNth bsp+        | otherwise = layout $ removeNth bsp+        where sz = size bsp++  handleMessage b_orig m+   | Just msg@(SetGeometry _) <- fromMessage m = handleResize b msg+   | Just FocusParent <- fromMessage m = do+       let n = getFocusedNode b+       let n' = toNodeRef (refLeaf n) (makeZipper b >>= goToNode n >>= goUp)+       return $ Just b{getFocusedNode=n'{refWins=refWins n}}+   | Just SelectNode <- fromMessage m = do+       let n = getFocusedNode b+       let s = getSelectedNode b+       removeBorder $ refWins s+       let s' = if refLeaf n == refLeaf s && refPath n == refPath s+                then noRef else n{refWins=[]}+       return $ Just b{getSelectedNode=s'}+   | otherwise = do+       ws <- getStackSet+       fs <- getFloating+       hs <- getHidden+       r <- getScreenRect+       -- removeBorder $ refWins $ getSelectedNode b+       let lws = withoutFloating fs hs ws                                 -- tiled windows on WS+           lfs = maybe [] W.integrate ws \\ maybe [] W.integrate lws      -- untiled windows on WS+           b'  = handleMesg r                -- transform tree (concerns only tiled windows)+           ws' = adjustStack ws lws lfs b'   -- apply transformation to window stack, reintegrate floating wins+       replaceStack ws'+       return b'+    where handleMesg r = msum [ fmap resize        (fromMessage m)+                              , fmap rotate        (fromMessage m)+                              , fmap swap          (fromMessage m)+                              , fmap rotateTr      (fromMessage m)+                              , fmap (balanceTr r) (fromMessage m)+                              , fmap move          (fromMessage m)+                              , fmap splitShift    (fromMessage m)+                              ]+          resize (ExpandTowardsBy dir diff) = growNthTowards dir diff b+          resize (ShrinkFromBy dir diff) = shrinkNthFrom dir diff b+          resize (MoveSplitBy dir diff) = autoSizeNth dir diff b+          rotate Rotate = resetFoc $ rotateNth b+          swap Swap = resetFoc $ swapNth b+          rotateTr RotateL = resetFoc $ rotateTreeNth L b+          rotateTr RotateR = resetFoc $ rotateTreeNth R b+          balanceTr _ Equalize = resetFoc $ equalizeNth b+          balanceTr r Balance  = resetFoc $ rebalanceNth b r+          move MoveNode = resetFoc $ moveNode b+          move SelectNode = b --should not happen here, is done above, as we need X monad+          splitShift (SplitShift dir) = resetFoc $ splitShiftNth dir b++          b = numerateLeaves b_orig+          resetFoc bsp = bsp{getFocusedNode=(getFocusedNode bsp){refLeaf= -1}+                            ,getSelectedNode=(getSelectedNode bsp){refLeaf= -1}}++  description _  = "BSP"++-- React to SetGeometry message to work with BorderResize/MouseResize+handleResize :: BinarySpacePartition Window -> WindowArrangerMsg -> X (Maybe (BinarySpacePartition Window))+handleResize b (SetGeometry newrect@(Rectangle _ _ w h)) = do+  ws <- getStackSet+  fs <- getFloating+  hs <- getHidden+  case W.focus <$> ws of+    Nothing -> return Nothing+    Just win -> do+      (_,_,_,_,_,mx,my,_) <- withDisplay (\d -> io $ queryPointer d win)+      let oldrect@(Rectangle _ _ ow oh) = fromMaybe (Rectangle 0 0 0 0) $ lookup win $ getOldRects b+      let (xsc,ysc)   = (fi w % fi ow, fi h % fi oh)+          (xsc',ysc') = (rough xsc, rough ysc)+          dirs = changedDirs oldrect newrect (fi mx,fi my)+          n = elemIndex win $ maybe [] W.integrate $ withoutFloating fs hs ws+      -- unless (isNothing dir) $ debug $+      --       show (fi x-fi ox,fi y-fi oy) ++ show (fi w-fi ow,fi h-fi oh)+      --       ++ show dir ++ " " ++ show win ++ " " ++ show (mx,my)+      return $ case n of+                Just _ -> Just $ foldl' (\b' d -> resizeSplitNth d (xsc',ysc') b') b dirs+                Nothing -> Nothing --focused window is floating -> ignore+  where rough v = min 1.5 $ max 0.75 v -- extreme scale factors are forbidden+handleResize _ _ = return Nothing++-- find out which borders have been pulled. We need the old and new rects and the mouse coordinates+changedDirs :: Rectangle -> Rectangle -> (Int,Int) -> [Direction2D]+changedDirs (Rectangle _ _ ow oh) (Rectangle _ _ w h) (mx,my) = catMaybes [lr, ud]+ where lr = if ow==w then Nothing+            else Just (if (fi mx :: Double) >  (fi ow :: Double)/2 then R else L)+       ud = if oh==h then Nothing+            else Just (if (fi my :: Double) > (fi oh :: Double)/2 then D else U)++-- node focus border helpers+----------------------------+updateNodeRef :: BinarySpacePartition Window -> Bool -> Rectangle -> X (BinarySpacePartition Window)+updateNodeRef b force r = do+    let n = getFocusedNode b+    let s = getSelectedNode b+    removeBorder (refWins n++refWins s)+    l <- getCurrFocused+    b' <- if refLeaf n /= l || refLeaf n == (-1) || force+            then return b{getFocusedNode=leafToNodeRef l b}+            else return b+    b'' <- if force then return b'{getSelectedNode=noRef} else return b'+    renderBorders r b''+  where getCurrFocused = maybe 0 index <$> (withoutFloating <$> getFloating <*> getHidden <*> getStackSet)++-- create border around focused node if necessary+renderBorders :: Rectangle -> BinarySpacePartition a -> X (BinarySpacePartition a)+renderBorders r b = do+  let l = nodeRefToLeaf (getFocusedNode b) $ makeZipper b+  wssel <- if refLeaf (getSelectedNode b)/=(-1)+           then createBorder (getNodeRect b r (getSelectedNode b)) $ Just "#00ff00"+           else return []+  let b' = b{getSelectedNode=(getSelectedNode b){refWins=wssel}}+  if refLeaf (getFocusedNode b')==(-1) || isJust l || size b'<2 then return b'+    else do+      ws' <- createBorder (getNodeRect b' r (getFocusedNode b')) Nothing+      return b'{getFocusedNode=(getFocusedNode b'){refWins=ws'}}++-- create a window for each border line, show, add into stack and set floating+createBorder :: Rectangle -> Maybe String -> X [Window]+createBorder (Rectangle wx wy ww wh) c = do+  bw <- asks (borderWidth.config)+  bc <- case c of+         Nothing -> asks (focusedBorderColor.config)+         Just s -> return s+  let rects = [ Rectangle wx wy ww (fi bw)+              , Rectangle wx wy (fi bw) wh+              , Rectangle wx (wy+fi wh-fi bw) ww (fi bw)+              , Rectangle (wx+fi ww-fi bw) wy (fi bw) wh+              ]+  ws <- mapM (\r -> createNewWindow r Nothing bc False) rects+  showWindows ws+  replaceStack . maybe Nothing (\s -> Just s{W.down=W.down s ++ ws}) =<< getStackSet+  replaceFloating . M.union (M.fromList $ zip ws $ map toRR rects) . W.floating . windowset =<< get+  modify (\s -> s{mapped=mapped s `S.union` S.fromList ws})+  -- show <$> mapM isClient ws >>= debug+  return ws+  where toRR (Rectangle x y w h) = W.RationalRect (fi x) (fi y) (fi w) (fi h)++-- remove border line windows from stack + floating, kill+removeBorder :: [Window] -> X ()+removeBorder ws = do+  modify (\s -> s{mapped = mapped s `S.difference` S.fromList ws})+  replaceFloating . flip (foldl (flip M.delete)) ws . W.floating . windowset =<< get+  replaceStack . maybe Nothing (\s -> Just s{W.down=W.down s \\ ws}) =<< getStackSet+  deleteWindows ws
XMonad/Layout/BorderResize.hs view
@@ -2,6 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.BorderResize+-- Description :  Resize windows by dragging their borders with the mouse. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -23,6 +24,7 @@     ( -- * Usage       -- $usage       borderResize+    , borderResizeNear     , BorderResize (..)     , RectWithBorders, BorderInfo,     ) where@@ -31,16 +33,16 @@ import XMonad.Layout.Decoration import XMonad.Layout.WindowArranger import XMonad.Util.XUtils-import Control.Monad(when)+import XMonad.Prelude(when) import qualified Data.Map as M  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.BorderResize -- > myLayout = borderResize (... layout setup that reacts to SetGeometry ...)--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } --  type BorderBlueprint = (Rectangle, Glyph, BorderType)@@ -57,27 +59,34 @@  type RectWithBorders = (Rectangle, [BorderInfo]) -data BorderResize a = BR (M.Map Window RectWithBorders) deriving (Show, Read)--brBorderSize :: Dimension-brBorderSize = 2+data BorderResize a = BR+  { brBorderSize  :: !Dimension+  -- ^ Still resize when this number of pixels around the border.+  , brWrsLastTime :: !(M.Map Window RectWithBorders)+  }+  deriving (Show, Read)  borderResize :: l a -> ModifiedLayout BorderResize l a-borderResize = ModifiedLayout (BR M.empty)+borderResize = borderResizeNear 2 +-- | Like 'borderResize', but takes the number of pixels near the border+-- up to which dragging still resizes a window.+borderResizeNear :: Dimension -> l a -> ModifiedLayout BorderResize l a+borderResizeNear borderSize = ModifiedLayout (BR borderSize M.empty)+ instance LayoutModifier BorderResize Window where     redoLayout _       _ Nothing  wrs = return (wrs, Nothing)-    redoLayout (BR wrsLastTime) _ _ wrs = do+    redoLayout (BR borderSize wrsLastTime) _ _ wrs = do             let correctOrder = map fst wrs                 wrsCurrent = M.fromList wrs                 wrsGone = M.difference wrsLastTime wrsCurrent                 wrsAppeared = M.difference wrsCurrent wrsLastTime                 wrsStillThere = M.intersectionWith testIfUnchanged wrsLastTime wrsCurrent             handleGone wrsGone-            wrsCreated <- handleAppeared wrsAppeared-            let wrsChanged = handleStillThere wrsStillThere+            wrsCreated <- handleAppeared borderSize wrsAppeared+            let wrsChanged = handleStillThere borderSize wrsStillThere                 wrsThisTime = M.union wrsChanged wrsCreated-            return (compileWrs wrsThisTime correctOrder, Just $ BR wrsThisTime)+            return (compileWrs wrsThisTime correctOrder, Just $ BR borderSize wrsThisTime)             -- What we return is the original wrs with the new border             -- windows inserted at the correct positions - this way, the core             -- will restack the borders correctly.@@ -90,16 +99,16 @@                     then (Nothing, entry)                     else (Just rCurrent, entry) -    handleMess (BR wrsLastTime) m+    handleMess (BR borderSize wrsLastTime) m         | Just e <- fromMessage m :: Maybe Event =             handleResize (createBorderLookupTable wrsLastTime) e >> return Nothing         | Just _ <- fromMessage m :: Maybe LayoutMessages =-            handleGone wrsLastTime >> return (Just $ BR M.empty)+            handleGone wrsLastTime >> return (Just $ BR borderSize M.empty)     handleMess _ _ = return Nothing  compileWrs :: M.Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)] compileWrs wrsThisTime correctOrder = let wrs = reorder (M.toList wrsThisTime) correctOrder-                                      in concat $ map compileWr wrs+                                      in concatMap compileWr wrs  compileWr :: (Window, RectWithBorders) -> [(Window, Rectangle)] compileWr (w, (r, borderInfos)) =@@ -109,73 +118,73 @@ handleGone :: M.Map Window RectWithBorders -> X () handleGone wrsGone = mapM_ deleteWindow borderWins     where-        borderWins = map bWin . concat . map snd . M.elems $ wrsGone+        borderWins = map bWin . concatMap snd . M.elems $ wrsGone -handleAppeared :: M.Map Window Rectangle -> X (M.Map Window RectWithBorders)-handleAppeared wrsAppeared = do+handleAppeared :: Dimension -> M.Map Window Rectangle -> X (M.Map Window RectWithBorders)+handleAppeared borderSize wrsAppeared = do     let wrs = M.toList wrsAppeared-    wrsCreated <- mapM handleSingleAppeared wrs+    wrsCreated <- mapM (handleSingleAppeared borderSize) wrs     return $ M.fromList wrsCreated -handleSingleAppeared :: (Window, Rectangle) -> X (Window, RectWithBorders)-handleSingleAppeared (w, r) = do-    let borderBlueprints = prepareBorders r+handleSingleAppeared :: Dimension ->(Window, Rectangle) -> X (Window, RectWithBorders)+handleSingleAppeared borderSize (w, r) = do+    let borderBlueprints = prepareBorders borderSize r     borderInfos <- mapM createBorder borderBlueprints     return (w, (r, borderInfos)) -handleStillThere :: M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders-handleStillThere wrsStillThere = M.map handleSingleStillThere wrsStillThere+handleStillThere :: Dimension -> M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders+handleStillThere borderSize = M.map (handleSingleStillThere borderSize) -handleSingleStillThere :: (Maybe Rectangle, RectWithBorders) -> RectWithBorders-handleSingleStillThere (Nothing, entry) = entry-handleSingleStillThere (Just rCurrent, (_, borderInfos)) = (rCurrent, updatedBorderInfos)+handleSingleStillThere :: Dimension -> (Maybe Rectangle, RectWithBorders) -> RectWithBorders+handleSingleStillThere _            (Nothing, entry)                  = entry+handleSingleStillThere borderSize (Just rCurrent, (_, borderInfos)) = (rCurrent, updatedBorderInfos)     where-        changedBorderBlueprints = prepareBorders rCurrent-        updatedBorderInfos = map updateBorderInfo . zip borderInfos $ changedBorderBlueprints+        changedBorderBlueprints = prepareBorders borderSize rCurrent+        updatedBorderInfos = zipWith (curry updateBorderInfo) borderInfos changedBorderBlueprints           -- assuming that the four borders are always in the same order  updateBorderInfo :: (BorderInfo, BorderBlueprint) -> BorderInfo updateBorderInfo (borderInfo, (r, _, _)) = borderInfo { bRect = r }  createBorderLookupTable :: M.Map Window RectWithBorders -> [(Window, (BorderType, Window, Rectangle))]-createBorderLookupTable wrsLastTime = concat $ map processSingleEntry $ M.toList wrsLastTime+createBorderLookupTable wrsLastTime = concatMap processSingleEntry (M.toList wrsLastTime)     where         processSingleEntry :: (Window, RectWithBorders) -> [(Window, (BorderType, Window, Rectangle))]         processSingleEntry (w, (r, borderInfos)) = for borderInfos $ \bi -> (bWin bi, (bType bi, w, r)) -prepareBorders :: Rectangle -> [BorderBlueprint]-prepareBorders (Rectangle x y wh ht) =-    [((Rectangle (x + fi wh - fi brBorderSize) y brBorderSize ht), xC_right_side , RightSideBorder),-     ((Rectangle x y brBorderSize ht)                            , xC_left_side  , LeftSideBorder),-     ((Rectangle x y wh brBorderSize)                            , xC_top_side   , TopSideBorder),-     ((Rectangle x (y + fi ht - fi brBorderSize) wh brBorderSize), xC_bottom_side, BottomSideBorder)+prepareBorders :: Dimension -> Rectangle -> [BorderBlueprint]+prepareBorders borderSize (Rectangle x y wh ht) =+    [(Rectangle (x + fi wh - fi borderSize) y borderSize ht, xC_right_side , RightSideBorder),+     (Rectangle x y borderSize ht                          , xC_left_side  , LeftSideBorder),+     (Rectangle x y wh borderSize                          , xC_top_side   , TopSideBorder),+     (Rectangle x (y + fi ht - fi borderSize) wh borderSize, xC_bottom_side, BottomSideBorder)     ]  handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X () handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et }     | et == buttonPress, Just edge <- lookup ew borders =     case edge of-        (RightSideBorder, hostWin, (Rectangle hx hy _ hht)) ->+        (RightSideBorder, hostWin, Rectangle hx hy _ hht) ->             mouseDrag (\x _ -> do                             let nwh = max 1 $ fi (x - hx)                                 rect = Rectangle hx hy nwh hht                             focus hostWin                             when (x - hx > 0) $ sendMessage (SetGeometry rect)) (focus hostWin)-        (LeftSideBorder, hostWin, (Rectangle hx hy hwh hht)) ->+        (LeftSideBorder, hostWin, Rectangle hx hy hwh hht) ->             mouseDrag (\x _ -> do-                            let nx = max 0 $ min (hx + fi hwh) $ x+                            let nx = max 0 $ min (hx + fi hwh) x                                 nwh = max 1 $ hwh + fi (hx - x)                                 rect = Rectangle nx hy nwh hht                             focus hostWin                             when (x < hx + fi hwh) $ sendMessage (SetGeometry rect)) (focus hostWin)-        (TopSideBorder, hostWin, (Rectangle hx hy hwh hht)) ->+        (TopSideBorder, hostWin, Rectangle hx hy hwh hht) ->             mouseDrag (\_ y -> do-                            let ny = max 0 $ min (hy + fi hht) $ y+                            let ny = max 0 $ min (hy + fi hht) y                                 nht = max 1 $ hht + fi (hy - y)                                 rect = Rectangle hx ny hwh nht                             focus hostWin                             when (y < hy + fi hht) $ sendMessage (SetGeometry rect)) (focus hostWin)-        (BottomSideBorder, hostWin, (Rectangle hx hy hwh _)) ->+        (BottomSideBorder, hostWin, Rectangle hx hy hwh _) ->             mouseDrag (\_ y -> do                             let nht = max 1 $ fi (y - hy)                                 rect = Rectangle hx hy hwh nht@@ -183,7 +192,7 @@                             when (y - hy > 0) $ sendMessage (SetGeometry rect)) (focus hostWin) handleResize _ _ = return () -createBorder :: BorderBlueprint -> X (BorderInfo)+createBorder :: BorderBlueprint -> X BorderInfo createBorder (borderRect, borderCursor, borderType) = do     borderWin <- createInputWindow borderCursor borderRect     return BI { bWin = borderWin, bRect = borderRect, bType = borderType }@@ -214,10 +223,10 @@  reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)] reorder wrs order =-    let ordered = concat $ map (pickElem wrs) order-        rest = filter (\(w, _) -> not (w `elem` order)) wrs+    let ordered = concatMap (pickElem wrs) order+        rest = filter (\(w, _) -> w `notElem` order) wrs     in ordered ++ rest     where-        pickElem list e = case (lookup e list) of+        pickElem list e = case lookup e list of                                 Just result -> [(e, result)]                                 Nothing -> []
XMonad/Layout/BoringWindows.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.BoringWindows+-- Description :  Mark windows as boring. -- Copyright   :  (c) 2008  David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -18,8 +19,10 @@                                    -- * Usage                                    -- $usage                                    boringWindows, boringAuto,-                                   markBoring, clearBoring,-                                   focusUp, focusDown, focusMaster,+                                   markBoring, markBoringEverywhere,+                                   clearBoring, focusUp, focusDown,+                                   focusMaster, swapUp, swapDown,+                                   siftUp, siftDown,                                     UpdateBoring(UpdateBoring),                                    BoringMessage(Replace,Merge),@@ -32,24 +35,24 @@  import XMonad.Layout.LayoutModifier(ModifiedLayout(..),                                     LayoutModifier(handleMessOrMaybeModifyIt, redoLayout))-import XMonad(Typeable, LayoutClass, Message, X, fromMessage,-              sendMessage, windows, withFocused, Window)-import Control.Applicative((<$>))-import Data.List((\\), union)-import Data.Maybe(fromMaybe, listToMaybe, maybeToList)+import XMonad(LayoutClass, Message, X, fromMessage,+              broadcastMessage, sendMessage, windows, withFocused, Window)+import XMonad.Prelude+import XMonad.Util.Stack (reverseS)+import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import qualified XMonad.StackSet as W  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.BoringWindows -- -- Then edit your @layoutHook@ by adding the layout modifier: -- -- > myLayout = boringWindows (Full ||| etc..)--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- Then to your keybindings, add: --@@ -57,36 +60,48 @@ -- > , ((modm, xK_k), focusDown) -- > , ((modm, xK_m), focusMaster) ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".   data BoringMessage = FocusUp | FocusDown | FocusMaster | IsBoring Window | ClearBoring                      | Replace String [Window]                      | Merge String [Window]-                     deriving ( Read, Show, Typeable )+                     | SwapUp+                     | SwapDown+                     | SiftUp+                     | SiftDown+                     deriving ( Read, Show )  instance Message BoringMessage  -- | UpdateBoring is sent before attempting to view another boring window, so -- that layouts have a chance to mark boring windows. data UpdateBoring = UpdateBoring-    deriving (Typeable) instance Message UpdateBoring -markBoring, clearBoring, focusUp, focusDown, focusMaster :: X ()+markBoring, clearBoring, focusUp, focusDown, focusMaster, swapUp, swapDown, siftUp, siftDown :: X () markBoring = withFocused (sendMessage . IsBoring) clearBoring = sendMessage ClearBoring focusUp = sendMessage UpdateBoring >> sendMessage FocusUp focusDown = sendMessage UpdateBoring >> sendMessage FocusDown focusMaster = sendMessage UpdateBoring >> sendMessage FocusMaster+swapUp = sendMessage UpdateBoring >> sendMessage SwapUp+swapDown = sendMessage UpdateBoring >> sendMessage SwapDown+siftUp = sendMessage UpdateBoring >> sendMessage SiftUp+siftDown = sendMessage UpdateBoring >> sendMessage SiftDown +-- | Mark current focused window boring for all layouts.+-- This is useful in combination with the "XMonad.Actions.CopyWindow" module.+markBoringEverywhere :: X ()+markBoringEverywhere = withFocused (broadcastMessage . IsBoring)+ data BoringWindows a = BoringWindows     { namedBoring :: M.Map String [a] -- ^ store borings with a specific source     , chosenBoring :: [a]             -- ^ user-chosen borings     , hiddenBoring :: Maybe [a]       -- ^ maybe mark hidden windows-    } deriving (Show,Read,Typeable)+    } deriving (Show,Read)  boringWindows :: (LayoutClass l a, Eq a) => l a -> ModifiedLayout BoringWindows l a boringWindows = ModifiedLayout (BoringWindows M.empty [] Nothing)@@ -96,13 +111,13 @@ boringAuto = ModifiedLayout (BoringWindows M.empty [] (Just []))  instance LayoutModifier BoringWindows Window where-    redoLayout (b@BoringWindows { hiddenBoring = bs }) _r mst arrs = do+    redoLayout b@BoringWindows{ hiddenBoring = bs } _r mst arrs = do         let bs' = W.integrate' mst \\ map fst arrs-        return (arrs, Just $ b { hiddenBoring = const bs' <$> bs } )+        return (arrs, Just $ b { hiddenBoring = bs' <$ bs } )      handleMessOrMaybeModifyIt bst@(BoringWindows nbs cbs lbs) m         | Just (Replace k ws) <- fromMessage m-        , maybe True (ws/=) (M.lookup k nbs) =+        , Just ws /= M.lookup k nbs =             let nnb = if null ws then M.delete k nbs                           else M.insert k ws nbs             in rjl bst { namedBoring = nnb }@@ -125,10 +140,27 @@                                             . skipBoring W.focusUp'   -- no boring window gets the focus                                             . focusMaster'                                return Nothing-        where skipBoring f st = fromMaybe st $ listToMaybe-                                $ filter ((`notElem` W.focus st:bs) . W.focus)-                                $ take (length $ W.integrate st)-                                $ iterate f st+        | Just SwapUp <- fromMessage m =+                            do windows $ W.modify' skipBoringSwapUp+                               return Nothing+        | Just SwapDown <- fromMessage m =+                            do windows $ W.modify' (reverseS . skipBoringSwapUp . reverseS)+                               return Nothing+        | Just SiftUp <- fromMessage m =+                            do windows $ W.modify' (siftUpSkipping bs)+                               return Nothing+        | Just SiftDown <- fromMessage m =+                            do windows $ W.modify' (reverseS . siftUpSkipping bs . reverseS)+                               return Nothing+        where skipBoring = skipBoring' ((`notElem` bs) . W.focus)+              skipBoringSwapUp = skipBoring'+                                   (maybe True (`notElem` bs) . listToMaybe . W.down)+                                   swapUp'+              skipBoring' p f st = fromMaybe st+                                   $ find p+                                   $ drop 1+                                   $ take (length $ W.integrate st)+                                   $ iterate f st               bs = concat $ cbs:maybeToList lbs ++ M.elems nbs               rjl = return . Just . Left     handleMessOrMaybeModifyIt _ _ = return Nothing@@ -137,7 +169,20 @@ -- 'Stack' rather than an entire 'StackSet'. focusMaster' :: W.Stack a -> W.Stack a focusMaster' c@(W.Stack _ [] _) = c-focusMaster' (W.Stack t ls rs) = W.Stack x [] (xs ++ t : rs) where (x:xs) = reverse ls+focusMaster' (W.Stack t (l:ls) rs) = W.Stack x [] (xs ++ t : rs) where (x :| xs) = NE.reverse (l :| ls)++swapUp' :: W.Stack a -> W.Stack a+swapUp' (W.Stack t (l:ls) rs) = W.Stack t ls (l:rs)+swapUp' (W.Stack t []     rs) = W.Stack t (reverse rs) []++siftUpSkipping :: Eq a => [a] -> W.Stack a -> W.Stack a+siftUpSkipping bs (W.Stack t ls rs)+  | (skips, l:ls') <- spanLeft  = W.Stack t ls' (reverse skips ++ l : rs)+  | (skips, r:rs') <- spanRight = W.Stack t (rs' ++ r : ls) (reverse skips)+  | otherwise                   = W.Stack t ls rs+  where+    spanLeft  = span (`elem` bs) ls+    spanRight = span (`elem` bs) (reverse rs)  {- $simplest
XMonad/Layout/ButtonDecoration.hs view
@@ -2,6 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ButtonDecoration+-- Description :  Decoration that includes buttons, executing actions when clicked on. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -32,7 +33,7 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.DecorationAddons -- > import XMonad.Layout.ButtonDecoration@@ -40,17 +41,17 @@ -- Then edit your @layoutHook@ by adding the ButtonDecoration to -- your layout: ----- > myL = buttonDeco shrinkText defaultThemeWithButtons (layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }+-- > myL = buttonDeco shrinkText defaultThemeWithButtons (layoutHook def)+-- > main = xmonad def { layoutHook = myL } --  buttonDeco :: (Eq a, Shrinker s) => s -> Theme            -> l a -> ModifiedLayout (Decoration ButtonDecoration s) l a buttonDeco s c = decoration s c $ NFD True -data ButtonDecoration a = NFD Bool deriving (Show, Read)+newtype ButtonDecoration a = NFD Bool deriving (Show, Read)  instance Eq a => DecorationStyle ButtonDecoration a where     describeDeco _ = "ButtonDeco"-    decorationCatchClicksHook _ mainw dFL dFR = titleBarButtonHandler mainw dFL dFR+    decorationCatchClicksHook _ = titleBarButtonHandler     decorationAfterDraggingHook _ (mainw, _) decoWin = focus mainw >> handleScreenCrossing mainw decoWin >> return ()
+ XMonad/Layout/CenterMainFluid.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.CenterMainFluid+-- Description :  Three column layout with master in center and unoccupied spaces reserved.+-- Copyright   :  (c) 2023 Mahdi Seyedan+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  Mahdi Seyedan. <mahdisn78@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- A three column layout with main column in the center and+-- two stack columns surrounding it. There will be always+-- a pane in the center column and unoccupied spaces on the+-- sides are reserved.+-- It's best suited for ultrawide montiors, where a single+-- stretched window might be annoying.+-----------------------------------------------------------------------------++module XMonad.Layout.CenterMainFluid+  ( -- * Usage+    -- $usage+    CenterMainFluid (..)+  ) where++import XMonad+import qualified XMonad.StackSet as W+import Control.Monad (msum)++-- $usage+-- You can use this module by adding following in your @xmonad.hs@:+--+-- > import XMonad.Layout.CenterMainFluid+--+-- Then edit your @layoutHook@ by adding the CenterMainFluid layout:+--+-- > myLayoutHook = CenterMainFluid 1 (3/100) (70/100) ||| ...+-- > main = xmonad def { layoutHook = myLayout }+--+-- The first argument specifies how many windows initially appear in the center+-- column. The second argument specifies the amount to resize while resizing+-- and the third argument specifies the initial size of the center column.+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".+++-- | Arguments are nmaster, delta, fraction. Supports 'Shrink', 'Expand' and+-- 'IncMasterN'+data CenterMainFluid a = CenterMainFluid+  { cmfNMaster :: !Int             -- ^ The default number of windows in the center pane (default: 1)+  , cmfRatioIncrement :: !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100)+  , cmfRatio :: !Rational          -- ^ Default proportion of screen occupied by the center pane (default: 70/100)+  }+  deriving (Show,Read)++instance LayoutClass CenterMainFluid a where++    pureLayout (CenterMainFluid nmaster _ frac) r s+        | frac == 0 = drop nmaster layout+        | frac == 1 = take nmaster layout+        | otherwise = layout+      where layout = zip ws rs+            ws = W.integrate s+            rs = tile3 frac r nmaster (length ws)++    pureMessage (CenterMainFluid nmaster delta frac) m =+            msum [fmap resize     (fromMessage m)+                 ,fmap incmastern (fromMessage m)]++      where resize Shrink             = CenterMainFluid nmaster delta (max 0 $ frac-delta)+            resize Expand             = CenterMainFluid nmaster delta (min 1 $ frac+delta)+            incmastern (IncMasterN d) = CenterMainFluid (max 0 (nmaster+d)) delta frac++    description _ = "CenterMainFluid"++tile3 :: Rational -> Rectangle -> Int -> Int -> [Rectangle]+tile3 f r nmaster n+  | nmaster <= 0 || n <= nmaster = splitVertically n middleR+  | otherwise = masters ++ rights ++ lefts+      where (leftR, middleR, rightR) = split3HorizontallyBy f r+            (halfN, remaining) = (n - nmaster) `divMod` 2+            masters = splitVertically nmaster middleR+            lefts = splitVertically halfN leftR+            rights = splitVertically (halfN + remaining) rightR++-- | Divide the screen into three rectangles, using a rational to specify the ratio of center one+split3HorizontallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle, Rectangle)+split3HorizontallyBy f (Rectangle sx sy sw sh) =+  ( Rectangle sx sy sidew sh+  , Rectangle (sx + fromIntegral sidew) sy middlew sh+  , Rectangle (sx + fromIntegral sidew + fromIntegral middlew) sy sidew sh+  )+  where middlew = floor $ fromIntegral sw * f+        sidew = (sw - fromIntegral middlew) `div` 2
+ XMonad/Layout/CenteredIfSingle.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.CenteredIfSingle+-- Description :  If only a single window is shown, center it on screen+-- Copyright   :  (c) 2021 Leon Kowarschick+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  Leon Kowarschick. <TheElkOfWar@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- A layout modifier that, if there is only a single window on screen, places+-- that window in the center of the screen.+-- This is especially useful on wide screen setups, where the window would otherwise+-- be unnecessarily far away from the center of your field of vision.+--+-----------------------------------------------------------------------------++module XMonad.Layout.CenteredIfSingle+  ( -- * Usage+    -- $usage+    centeredIfSingle, CenteredIfSingle+  ) where++import XMonad+import XMonad.Layout.LayoutModifier+import XMonad.Prelude (fi)++-- $usage+-- You can use this module by including  the following in your @xmonad.hs@:+--+-- > import XMonad.Layout.CenteredIfSingle+--+-- and adding the 'centeredIfSingle' layoutmodifier to your layouts.+--+-- > myLayoutHook = centeredIfSingle 0.7 0.8 Grid ||| ...+--+-- For more information on configuring your layouts see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>+-- and "XMonad.Doc.Extending".+++-- | Layout Modifier that places a window in the center of the screen,+-- leaving room on the left and right if there is only a single window.+-- The first argument is the horizontal and the second one the vertical+-- ratio of the screen the centered window should take up.  Both numbers+-- should be between 0.0 and 1.0.+data CenteredIfSingle a = CenteredIfSingle !Double !Double+  deriving (Show, Read)++instance LayoutModifier CenteredIfSingle Window where+  pureModifier (CenteredIfSingle ratioX ratioY) r _ [(onlyWindow, _)] = ([(onlyWindow, rectangleCenterPiece ratioX ratioY r)], Nothing)+  pureModifier _ _ _ winRects = (winRects, Nothing)++-- | Layout Modifier that places a window in the center of the screen,+-- leaving room on all sides if there is only a single window+centeredIfSingle :: Double -- ^ Horizontal ratio of the screen the centered window should take up; should be a value between 0.0 and 1.0+                 -> Double -- ^ Vertical ratio; should also be a value between 0.0 and 1.0+                 -> l a    -- ^ The layout that will be used if more than one window is open+                 -> ModifiedLayout CenteredIfSingle l a+centeredIfSingle ratioX ratioY = ModifiedLayout (CenteredIfSingle ratioX ratioY)++-- | Calculate the center piece of a rectangle given the percentage of the outer rectangle it should occupy.+rectangleCenterPiece :: Double -> Double -> Rectangle -> Rectangle+rectangleCenterPiece ratioX ratioY (Rectangle rx ry rw rh) = Rectangle startX startY width height+  where+    startX = rx + left+    startY = ry + top++    width  = newSize rw left+    height = newSize rh top++    left = rw `scaleBy` ratioX+    top  = rh `scaleBy` ratioY++newSize :: Dimension -> Position -> Dimension+newSize dim pos = fi $ fi dim - pos * 2++scaleBy :: Dimension -> Double -> Position+scaleBy dim ratio = floor $ fi dim * (1.0 - ratio) / 2
XMonad/Layout/CenteredMaster.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.CenteredMaster+-- Description :  Place the master pane on top of other windows; in the center or top right. -- Copyright   :  (c) 2009 Ilya Portnov -- License     :  BSD-style (see xmonad/LICENSE) --@@ -29,13 +30,15 @@ import XMonad.Layout.LayoutModifier import qualified XMonad.StackSet as W +import Control.Arrow (first)+ -- $usage -- This module defines two new layout modifiers: centerMaster and topRightMaster. -- centerMaster places master window at center of screen, on top of others. -- All other windows in background are managed by base layout. -- topRightMaster is like centerMaster, but places master window in top right corner instead of center. ----- Yo can use this module by adding folowing in your @xmonad.hs@:+-- You can use this module by adding following in your @xmonad.hs@: -- -- > import XMonad.Layout.CenteredMaster --@@ -76,15 +79,13 @@  applyPosition pos wksp rect = do   let stack = W.stack wksp-  let ws = W.integrate' $ stack-  if null ws then-     runLayout wksp rect-     else do-       let first = head ws-       let other = tail ws-       let filtStack = stack >>= W.filter (first /=)+  let ws = W.integrate' stack+  case ws of+    []               -> runLayout wksp rect+    (firstW : other) -> do+       let filtStack = stack >>= W.filter (firstW /=)        wrs <- runLayout (wksp {W.stack = filtStack}) rect-       return ((first, place pos other rect) : fst wrs, snd wrs)+       return $ first ((firstW, place pos other rect) :) wrs  -- | Place master window (it's Rectangle is given), using the given Positioner. -- If second argument is empty (that is, there is only one window on workspace),@@ -107,5 +108,3 @@         h = round (fromIntegral sh * ry)         x = sx + fromIntegral (sw-w) `div` 2         y = sy + fromIntegral (sh-h) `div` 2--
XMonad/Layout/Circle.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Circle+-- Description :  An elliptical, overlapping layout. -- Copyright   :  (c) Peter De Wachter -- License     :  BSD-style (see LICENSE) --@@ -14,62 +16,29 @@ -- ----------------------------------------------------------------------------- -module XMonad.Layout.Circle (-                             -- * Usage-                             -- $usage-                             Circle (..)-                            ) where -- actually it's an ellipse+module XMonad.Layout.Circle {-# DEPRECATED "Use XMonad.Layout.CircleEx instead" #-}+  ( -- * Usage+    -- $usage+    pattern Circle+  ) where -- actually it's an ellipse -import Data.List-import XMonad-import XMonad.StackSet (integrate, peek)+import GHC.Real (Ratio(..))+import XMonad.Layout.CircleEx  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Circle -- -- Then edit your @layoutHook@ by adding the Circle layout: -- -- > myLayout = Circle ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"--data Circle a = Circle deriving ( Read, Show )--instance LayoutClass Circle Window where-    doLayout Circle r s = do layout <- raiseFocus $ circleLayout r $ integrate s-                             return (layout, Nothing)--circleLayout :: Rectangle -> [a] -> [(a, Rectangle)]-circleLayout _ []     = []-circleLayout r (w:ws) = master : rest-    where master = (w, center r)-          rest   = zip ws $ map (satellite r) [0, pi * 2 / fromIntegral (length ws) ..]--raiseFocus :: [(Window, Rectangle)] -> X [(Window, Rectangle)]-raiseFocus xs = do focused <- withWindowSet (return . peek)-                   return $ case find ((== focused) . Just . fst) xs of-                              Just x  -> x : delete x xs-                              Nothing -> xs--center :: Rectangle -> Rectangle-center (Rectangle sx sy sw sh) = Rectangle x y w h-    where s = sqrt 2 :: Double-          w = round (fromIntegral sw / s)-          h = round (fromIntegral sh / s)-          x = sx + fromIntegral (sw - w) `div` 2-          y = sy + fromIntegral (sh - h) `div` 2+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -satellite :: Rectangle -> Double -> Rectangle-satellite (Rectangle sx sy sw sh) a = Rectangle (sx + round (rx + rx * cos a))-                                                (sy + round (ry + ry * sin a))-                                                w h-    where rx = fromIntegral (sw - w) / 2-          ry = fromIntegral (sh - h) / 2-          w = sw * 10 `div` 25-          h = sh * 10 `div` 25+pattern Circle :: CircleEx a+pattern Circle = CircleEx 1 (70 :% 99) (2 :% 5) 1 0
+ XMonad/Layout/CircleEx.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.CircleEx+-- Description :  An elliptical, overlapping layout—extended version.+-- Copyright   :  (c) Peter De Wachter, Ilya V. Portnov+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Ilya V. Portnov <portnov84@rambler.ru>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Circle is an elliptical, overlapping layout. Original code by Peter De Wachter,+-- extended by Ilya Porntov.+-----------------------------------------------------------------------------++module XMonad.Layout.CircleEx (+    -- * Usage+    -- $usage+    CircleEx (..), circle, circleEx,+    CircleExMsg (..)+  )+  where++import Data.Ratio++import XMonad+import XMonad.StackSet (Stack)+import XMonad.Prelude+import qualified XMonad.StackSet as W++-- $usage+--+-- The layout puts the first N windows (called master) into the center of+-- screen. All others (called secondary, or stack) are organized in a circle+-- (well, ellipse). When opening a new secondary window, its size will be+-- slightly smaller than that of its predecessor (this is configurable). If+-- the number of master windows is set to zero, all windows will be arranged+-- in a circle. If there is more than one master window, they will be stacked+-- in the center on top of each other. The size of each additional master+-- window will again be slightly smaller than that of the former.+--+-- Since a picture says more than a thousand words, you see one+-- <https://github.com/xmonad/xmonad-contrib/assets/50166980/90ef1273-5201-4380-8b94-9e62d3c98e1c here>.+--+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Layout.CircleEx+--+-- Then edit your @layoutHook@ by adding the 'CircleEx' layout:+--+-- > myCircle = circleEx {cDelta = -3*pi/4}+-- > myLayout = myCircle ||| Full ||| etc..+-- > main = xmonad def { layoutHook = myLayout }+--+-- This layout understands standard messages:+--+-- * 'IncMasterN': increase or decrease the number of master windows.+-- * 'Shrink' and 'Expand': change the size of master windows.+--+-- More layout-specific messages are also supported, see 'CircleExMsg' below.+--+-- For more detailed instructions on editing the layoutHook see:+-- "XMonad.Doc.Extending#Editing_the_layout_hook"++-- | The layout data type. It is recommended to not use the 'CircleEx' data+-- constructor directly, and instead rely on record update syntax; for+-- example: @circleEx {cMasterRatio = 4%5}@. In this way you can avoid nasty+-- surprises if one day additional fields are added to @CircleEx@.+data CircleEx a = CircleEx+    { cNMaster :: !Int          -- ^ Number of master windows. Default value is 1.+    , cMasterRatio :: !Rational -- ^ Size of master window in relation to screen size.+                                --   Default value is @4%5@.+    , cStackRatio :: !Rational  -- ^ Size of first secondary window in relation to screen size.+                                --   Default value is @3%5@.+    , cMultiplier :: !Rational  -- ^ Coefficient used to calculate the sizes of subsequent secondary+                                --   windows. The size of the next window is calculated as the+                                --   size of the previous one multiplied by this value.+                                --   This value is also used to scale master windows, in case+                                --   there is more than one.+                                --   Default value is @5%6@. Set this to 1 if you want all secondary+                                --   windows to have the same size.+    , cDelta :: !Double         -- ^ Angle of rotation of the whole circle layout. Usual values+                                --   are from 0 to 2π, although it will work outside+                                --   this range as well. Default value of 0 means that the first+                                --   secondary window will be placed at the right side of screen.+    } deriving (Eq, Show, Read)++-- | Circle layout with default settings:+--+-- * Number of master windows is set to 1+-- * @cMasterRatio@ is set to @70/99@, which is nearly @1/sqrt(2)@+-- * @cStackRatio@ is set to @2/5@+-- * @cMultiplier@ is set to 1, which means all secondary windows+--   will have the same size+--+-- This can be used as a drop-in replacement for "XMonad.Layout.Circle".+circle :: CircleEx a+circle = CircleEx 1 (70%99) (2%5) 1 0++-- | Another variant of default settings for circle layout:+--+-- * Number of master windows is set to 1+-- * @cMasterRatio@ is set to @4/5@+-- * @cStackRatio@ is set to @3/5@+-- * @cMultiplier@ is set to @5/6@+--+circleEx :: CircleEx a+circleEx = CircleEx 1 (4%5) (3%5) (5%6) 0++-- | Specific messages understood by CircleEx layout.+data CircleExMsg+  = Rotate !Double            -- ^ Rotate secondary windows by specific angle+  | IncStackRatio !Rational   -- ^ Increase (or decrease, with negative value) sizes of secondary windows+  | IncMultiplier !Rational   -- ^ Increase 'cMultiplier'.+  deriving (Eq, Show)++instance Message CircleExMsg++instance LayoutClass CircleEx Window where+  doLayout :: CircleEx Window -> Rectangle -> Stack Window -> X ([(Window, Rectangle)], Maybe (CircleEx Window))+  doLayout layout rect stack = do+    result <- raiseFocus $ circleLayout layout rect $ W.integrate stack+    return (result, Nothing)++  pureMessage :: CircleEx Window -> SomeMessage -> Maybe (CircleEx Window)+  pureMessage layout m =+      msum [changeMasterN <$> fromMessage m,+            resize <$> fromMessage m,+            specific <$> fromMessage m]+    where+      deltaSize = 11 % 10++      resize :: Resize -> CircleEx a+      resize Shrink = layout {cMasterRatio = max 0.1 $ min 1.0 $ cMasterRatio layout / deltaSize}+      resize Expand = layout {cMasterRatio = max 0.1 $ min 1.0 $ cMasterRatio layout * deltaSize}++      changeMasterN :: IncMasterN -> CircleEx a+      changeMasterN (IncMasterN d) = layout {cNMaster = max 0 (cNMaster layout + d)}++      specific :: CircleExMsg -> CircleEx a+      specific (Rotate delta) = layout {cDelta = delta + cDelta layout}+      specific (IncStackRatio delta) = layout {cStackRatio = max 0.1 $ min 2.0 $ delta + cStackRatio layout}+      specific (IncMultiplier delta) = layout {cMultiplier = max 0.1 $ min 2.0 $ delta + cMultiplier layout}++circleLayout :: CircleEx a -> Rectangle -> [a] -> [(a, Rectangle)]+circleLayout _ _ [] = []+circleLayout (CircleEx {..}) rectangle wins =+    master (take cNMaster wins) ++ rest (drop cNMaster wins)+  where+    master :: [a] -> [(a, Rectangle)]+    master ws = zip ws $ map (placeCenter cMasterRatio cMultiplier rectangle)+                           [cNMaster-1, cNMaster-2 .. 0]+    rest :: [a] -> [(a, Rectangle)]+    rest ws = zip ws $ zipWith (placeSatellite cStackRatio cMultiplier rectangle)+                        (map (+ cDelta) [0, pi*2 / fromIntegral (length ws) ..])+                        [0 ..]+++raiseFocus :: [(Window, Rectangle)] -> X [(Window, Rectangle)]+raiseFocus wrs = do+  focused <- withWindowSet (return . W.peek)+  return $ case find ((== focused) . Just . fst) wrs of+             Just x  -> x : delete x wrs+             Nothing -> wrs++placeCenter :: Rational -> Rational -> Rectangle -> Int -> Rectangle+placeCenter ratio multiplier (Rectangle x y width height) n = Rectangle x' y' width' height'+  where+    m = ratio * multiplier ^ n+    width' = round (m * fromIntegral width)+    height' = round (m * fromIntegral height)+    x' = x + fromIntegral (width - width') `div` 2+    y' = y + fromIntegral (height - height') `div` 2++placeSatellite :: Rational -> Rational -> Rectangle -> Double -> Int -> Rectangle+placeSatellite ratio multiplier (Rectangle x y width height) alpha n =+    Rectangle x' y' width' height'+  where+    m = ratio * multiplier ^ n+    x' = x + round (rx + rx * cos alpha)+    y' = y + round (ry + ry * sin alpha)+    rx = fromIntegral (width - width') / 2+    ry = fromIntegral (height - height') / 2+    width' = round (fromIntegral width * m)+    height' = round (fromIntegral height * m)
XMonad/Layout/Column.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Column+-- Description :  Layout that places all windows in one column. -- Copyright   :  (c) 2009 Ilya Portnov -- License     :  BSD3-style (see LICENSE) --@@ -10,7 +11,7 @@ -- Portability :  unportable -- -- Provides Column layout that places all windows in one column. Windows--- heights are calculated from equation: H1/H2 = H2/H3 = ... = q, where q is+-- heights are calculated from the equation: H1/H2 = H2/H3 = ... = q, where q is -- given. With Shrink/Expand messages you can change the q value. -- -----------------------------------------------------------------------------@@ -24,12 +25,12 @@ import qualified XMonad.StackSet as W  -- $usage--- This module defines layot named Column. It places all windows in one--- column. Windows heights are calculated from equation: H1/H2 = H2/H3 = ... =+-- This module defines layout named Column. It places all windows in one+-- column. Windows heights are calculated from the equation: H1/H2 = H2/H3 = ... = -- q, where `q' is given (thus, windows heights are members of geometric -- progression). With Shrink/Expand messages one can change the `q' value. ----- You can use this module by adding folowing in your @xmonad.hs@:+-- You can use this module by adding following in your @xmonad.hs@: -- -- > import XMonad.Layout.Column --@@ -40,7 +41,7 @@ -- In this example, each next window will have height 1.6 times less then -- previous window. -data Column a = Column Float deriving (Read,Show)+newtype Column a = Column Float deriving (Read,Show)  instance LayoutClass Column a where     pureLayout = columnLayout@@ -57,15 +58,13 @@           n = length ws           heights = map (xn n rect q) [1..n]           ys = [fromIntegral $ sum $ take k heights | k <- [0..n-1]]-          rects = map (mkRect rect) $ zip heights ys+          rects = zipWith (curry (mkRect rect)) heights ys  mkRect :: Rectangle -> (Dimension,Position) -> Rectangle mkRect (Rectangle xs ys ws _) (h,y) = Rectangle xs (ys+fromIntegral y) ws h  xn :: Int -> Rectangle -> Float -> Int -> Dimension xn n (Rectangle _ _ _ h) q k = if q==1 then-                                  h `div` (fromIntegral n)+                                  h `div` fromIntegral n                                else-                                  round ((fromIntegral h)*q^(n-k)*(1-q)/(1-q^n))--+                                  round (fromIntegral h*q^(n-k)*(1-q)/(1-q^n))
+ XMonad/Layout/Columns.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module: XMonad.Layout.Columns+-- Description: A layout which tiles the windows in columns.+-- Copyright: Jean-Charles Quillet+-- License: BSD-style (see LICENSE)+--+-- Maintainer: none+-- Stability: unstable+-- Portability: unportable+--+-- A layout which tiles the windows in columns. The windows can be moved and+-- resized in every directions.+--+-- The first window appears in a single column in the center of the screen. Its+-- width is configurable (See 'coOneWindowWidth').+--+-- The second window appears in a second column. Starting with two columns, they+-- fill up the screen.+--+-- Subsequent windows appear on the bottom of the last columns.+module XMonad.Layout.Columns+  ( -- * Usage+    -- $usage+    ColumnsLayout (..),++    -- * Messages+    Focus (..),+    Move (..),+    Resize (..),++    -- * Tools+    focusDown,+    focusUp,+  )+where++import Control.Applicative ((<|>))+import Control.Arrow (Arrow (first), second)+import Control.Monad (guard)+import Control.Monad.State (modify)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.Foldable (Foldable (..))+import Data.List (scanl')+import Data.Maybe (listToMaybe)+import Data.Ratio ((%))+import XMonad+  ( LayoutClass (..),+    Message,+    Rectangle (..),+    SomeMessage,+    Window,+    WindowSet,+    X,+    XState (..),+    fromMessage,+    gets,+    scaleRationalRect,+    sendMessage,+  )+import qualified XMonad.Operations as O+import XMonad.StackSet+  ( RationalRect (..),+    Screen (..),+    Stack (..),+    StackSet (..),+    integrate,+    peek,+  )+import qualified XMonad.StackSet as StackSet++-- $usage+-- Add 'Columns' to your @layoutHook@ with an initial empty state:+--+-- > myLayout = Full ||| Columns 1 []+--+-- Here is an example of keybindings:+--+-- > -- Focus up/down+-- > ((modm, xK_Tab), focusDown),+-- > ((modm .|. shiftMask, xK_Tab), focusUp),+-- > -- Move windows around+-- > ((modm .|. shiftMask, xK_l), sendMessage MoveRight),+-- > ((modm .|. shiftMask, xK_h), sendMessage MoveLeft),+-- > ((modm .|. shiftMask, xK_k), sendMessage MoveUp),+-- > ((modm .|. shiftMask, xK_j), sendMessage MoveDown),+-- > -- Resize them+-- > ((modm .|. controlMask, xK_l), sendMessage HorizontalExpand),+-- > ((modm .|. controlMask, xK_h), sendMessage HorizontalShrink),+-- > ((modm .|. controlMask, xK_k), sendMessage VerticalExpand),+-- > ((modm .|. controlMask, xK_j), sendMessage VerticalShrink),+--+-- This layout is known to work with:+--+-- * "XMonad.Layout.WindowNavigation" for changing focus with a direction using+-- 'XMonad.Layout.WindowNavigation.Go' messages.+-- * 'XMonad.Layout.SubLayouts.subTabbed' for docking windows together with+-- tabs. Note that sometimes when undocking windows, the layout is reset. This is+-- a minor annoyance caused by the difficulty to track windows in the sublayout.++-- | The windows can be moved in every directions.+--+-- Horizontally, a window alone in its column cannot be moved before the first+-- or after the last column. If not alone, moving the window outside those+-- limits will create a new column.+-- The windows can also be moved vertically in their column.+data Move = MoveLeft | MoveRight | MoveUp | MoveDown deriving (Show, Read)++instance Message Move++-- | The windows can be resized in every directions.+--+-- When resizing horizontally:+--+-- * if the window to be resized is not in the last column+--+--      * then the right side of the window will be moved+--      * the last column will compensate the size change+--+-- * if the window is in the last column+--+--      * then the left side of the window will be moved+--      * the column on the left of the current one will compensate the size change+--+-- The same applies when resizing vertically using the bottom side of the+-- window unless it is the last window in the column in which case we use the+-- top side.+data Resize+  = VerticalShrink+  | VerticalExpand+  | HorizontalShrink+  | HorizontalExpand+  deriving (Show, Read)++instance Message Resize++-- | The layout handles focus change messages.+--+-- Built-in focus cannot be used here because @XMonad@ does not make it easy to+-- change the order of windows in the focus list. See also 'focusUp' and+-- 'focusDown' functions.+data Focus = FocusUp | FocusDown+  deriving (Show, Read)++instance Message Focus++-- | A column is a list of windows with their relative vertical dimensions.+type Column = [(Rational, Window)]++-- | The layout is a list of 'Column' with their relative horizontal dimensions.+type Columns = [(Rational, Column)]++data ColumnsLayout a = Columns+  { -- | With of the first column when there is only one window. Usefull on wide+    -- screens.+    coOneWindowWidth :: Rational,+    -- | The current state+    coColumns :: Columns+  }+  deriving (Show, Read)++instance LayoutClass ColumnsLayout Window where+  description _ = layoutDescription++  doLayout (Columns oneWindowWidth columns) rectangle stack =+    pure (rectangles, Just (Columns oneWindowWidth columns'))+    where+      hackedColumns = hackForTabs columns stack+      columns' = updateWindowList hackedColumns stack+      rectangles = toRectangles rectangle' columns'+      -- If there is only one window, we set the destination rectangle according+      -- to the width in the layout setting.+      rectangle'+        | (length . toList $ stack) == 1 =+            scaleRationalRect rectangle singleColumnRR+        | otherwise = rectangle+      singleColumnOffset = (1 - oneWindowWidth) / 2+      singleColumnRR = RationalRect singleColumnOffset 0 oneWindowWidth 1++  handleMessage layout@(Columns oneWindowWidth columns) message = do+    mbStack <- runMaybeT $ handleFocus' =<< getStack+    changedFocus <- traverse updateStack' mbStack++    movedOrResized <-+      runMaybeT $+        Columns oneWindowWidth+          <$> (handleMoveOrResize' =<< peekFocus)++    pure $ movedOrResized <|> changedFocus+    where+      getStack = MaybeT . gets $ StackSet.stack . workspace . current . windowset+      handleFocus' = hoistMaybe . handleFocus columns message+      -- A 'Just' needs to be return for the new stack to be taken into account+      updateStack' s = modify (setStack s) >> pure layout+      peekFocus = MaybeT . gets $ peek . windowset+      handleMoveOrResize' = hoistMaybe . handleMoveOrResize columns message+      hoistMaybe = MaybeT . pure++layoutDescription :: String+layoutDescription = "Columns"++-- | Change the keyboard focus to the previous window+focusUp :: X ()+focusUp =+  sendMsgOrOnWindowsSet FocusUp StackSet.focusUp+    =<< getCurrentLayoutDescription++-- | Change the keyboard focus to the next window+focusDown :: X ()+focusDown =+  sendMsgOrOnWindowsSet FocusDown StackSet.focusDown+    =<< getCurrentLayoutDescription++sendMsgOrOnWindowsSet :: (Message a) => a -> (WindowSet -> WindowSet) -> String -> X ()+sendMsgOrOnWindowsSet message f description'+  | description' == layoutDescription = sendMessage message+  | otherwise = O.windows f++getCurrentLayoutDescription :: X String+getCurrentLayoutDescription =+  gets+    ( description+        . StackSet.layout+        . workspace+        . current+        . windowset+    )++setStack :: Stack Window -> XState -> XState+setStack stack state =+  state+    { windowset =+        (windowset state)+          { current =+              (current $ windowset state)+                { workspace =+                    (workspace . current $ windowset state)+                      { StackSet.stack = Just stack+                      }+                }+          }+    }++handleFocus :: Columns -> SomeMessage -> Stack Window -> Maybe (Stack Window)+handleFocus columns message stack+  | Just FocusDown <- fromMessage message = setFocus' stack <$> mbNext+  | Just FocusUp <- fromMessage message = setFocus' stack <$> mbPrevious+  | otherwise = Nothing+  where+    focused = focus stack+    windows = columnsToWindows columns+    exists = focused `elem` windows+    mbNext = guard exists >> next focused windows+    mbPrevious = guard exists >> previous focused windows+    setFocus' = flip setFocus+    previous a = next a . reverse+    setFocus w = until ((==) w . focus) StackSet.focusDown'+    next _ [] = Nothing+    next a (x : xs)+      | a == x = listToMaybe xs+      | otherwise = next a (xs <> [x])++oldNewWindows :: Columns -> Stack Window -> ([Window], [Window])+oldNewWindows columns stack = (old, new)+  where+    old = filter (`notElem` stackList) windows+    new = filter (`notElem` windows) stackList+    stackList = toList stack+    windows = columnsToWindows columns++-- | Add the new windows to the layout and remove the old ones.+updateWindowList :: Columns -> Stack Window -> Columns+updateWindowList columns stack = addWindows newWindows (removeWindows oldWindows columns)+  where+    (oldWindows, newWindows) = oldNewWindows columns stack++-- | If one window disappeared and another appeared, we assume that the sublayout+-- tabs just changed focused.+hackForTabs :: Columns -> Stack Window -> Columns+hackForTabs columns stack = mapWindow replace columns+  where+    replace window+      | (w1 : _, [w2]) <- oldNewWindows columns stack =+          if window == w1+            then w2+            else window+      | otherwise = window++toRectangles :: Rectangle -> [(Rational, [(Rational, a)])] -> [(a, Rectangle)]+toRectangles rectangle columns =+  second (scaleRationalRect rectangle) <$> windowsAndRectangles+  where+    offsetsAndRatios = toOffsetRatio (second toOffsetRatio <$> columns)+    windowsAndRectangles = foldMap toWindowAndRectangle offsetsAndRatios+    toWindowAndRectangle (x, w, cs) = (\(y, h, ws) -> (ws, RationalRect x y w h)) <$> cs++onFocused :: (a -> a) -> Stack a -> Stack a+onFocused f (Stack a before after) = Stack (f a) before after++onFocusedM :: (Monad m) => (a -> m a) -> Stack a -> m (Stack a)+onFocusedM f (Stack a before after) = Stack <$> f a <*> pure before <*> pure after++onFocusedOrPrevious :: (a -> a) -> Stack a -> Stack a+onFocusedOrPrevious f (Stack a (a' : others) []) = Stack a (f a' : others) []+onFocusedOrPrevious f stack = onFocused f stack++handleMoveOrResize :: Columns -> SomeMessage -> Window -> Maybe Columns+handleMoveOrResize columns message window+  | Just msg <- fromMessage message = move msg window columns+  | Just HorizontalShrink <- fromMessage message =+      onFocusedOrPrevious' shrink <$> findInColumns window columns+  | Just HorizontalExpand <- fromMessage message =+      onFocusedOrPrevious' expand <$> findInColumns window columns+  | Just VerticalExpand <- fromMessage message =+      onFocusedM'+        (fmap (onFocusedOrPrevious' shrink) . findInColumn window)+        =<< findInColumns window columns+  | Just VerticalShrink <- fromMessage message =+      onFocusedM'+        (fmap (onFocusedOrPrevious' expand) . findInColumn window)+        =<< findInColumns window columns+  | otherwise = Nothing+  where+    expand = first $ flip (+) (3 / 100)+    shrink = first $ flip (-) (3 / 100)+    onFocusedM' f = fmap integrate . onFocusedM (sequence . second f)+    onFocusedOrPrevious' f = sanitize . integrate . onFocusedOrPrevious f++move :: Move -> Window -> Columns -> Maybe Columns+move direction window columns =+  case (direction, findInColumns window columns) of+    (MoveRight, Just (Stack (_, [(_, _)]) _ [])) -> Nothing+    (MoveLeft, Just (Stack (_, [(_, _)]) [] _)) -> Nothing+    (MoveRight, Just (Stack column@(_, [(_, _)]) before (next : others))) ->+      let (column', next') = swapWindowBetween window column next+       in Just . integrate $ Stack column' before (next' : others)+    (MoveLeft, Just (Stack column@(_, [(_, _)]) (previous : others) after)) ->+      let (column', previous') = swapWindowBetween window column previous+       in Just . integrate $ Stack column' (previous' : others) after+    (MoveRight, Just stack) ->+      let (newColumns', Stack column before after) = rationalize newColumns stack+          windows = removeWindow window column+       in Just . integrate $ Stack windows before (newColumns' <> after)+    (MoveLeft, Just stack) ->+      let (newColumns', Stack column before after) = rationalize newColumns stack+          windows = removeWindow window column+       in Just . integrate $ Stack windows (newColumns' <> before) after+    (MoveUp, Just stack) -> integrate <$> onFocusedM (swapWindowUp window) stack+    (MoveDown, Just stack) -> integrate <$> onFocusedM (swapWindowDown window) stack+    _ -> Nothing+  where+    newColumns = [[(1, window)]]++mapWindow :: (Window -> Window) -> Columns -> Columns+mapWindow = fmap . fmap . fmap . fmap++columnsToWindows :: Columns -> [Window]+columnsToWindows = foldMap ((: []) . snd) . foldMap snd++swapWindowBetween ::+  Window ->+  (Rational, Column) ->+  (Rational, Column) ->+  ((Rational, Column), (Rational, Column))+swapWindowBetween window from to = (removed, added)+  where+    removed = removeWindow window from+    added = appendWindows [window] to++swapWindowUp :: Window -> (Rational, Column) -> Maybe (Rational, Column)+swapWindowUp window (width, column)+  | Just (Stack (height, _) (previous : before') after) <- findInColumn window column =+      Just (width, integrate $ Stack previous ((height, window) : before') after)+  | otherwise = Nothing++swapWindowDown :: Window -> (Rational, Column) -> Maybe (Rational, Column)+swapWindowDown window (width, column)+  | Just (Stack (height, _) before (next : others)) <- findInColumn window column =+      Just (width, integrate $ Stack next before ((height, window) : others))+  | otherwise = Nothing++-- | Adjust the ratio of a list or a stack of elts so that when adding new+--  elements:+-- - the new elements are distributed according to the total number of elements+-- - the existing elements keep their proportion in the remaining space+rationalize ::+  (Functor f, Foldable f) =>+  [a] ->+  f (Rational, a) ->+  ([(Rational, a)], f (Rational, a))+rationalize new existing = (new', existing')+  where+    nbNew = fromIntegral $ length new+    nbInColumn = fromIntegral $ length existing+    newRatio = nbNew % (nbNew + nbInColumn)+    existingRatio = 1 - newRatio+    new' = fitElements newRatio new+    existing' = first (* existingRatio) <$> existing++append :: [a] -> [(Rational, a)] -> [(Rational, a)]+append new existing = uncurry (flip mappend) (rationalize new existing)++appendWindows ::+  [Window] ->+  (Rational, [(Rational, Window)]) ->+  (Rational, [(Rational, Window)])+appendWindows windows = second (append windows)++fitElements :: Rational -> [a] -> [(Rational, a)]+fitElements dimension elts = (dimension',) <$> elts+  where+    dimension' = dimension / fromIntegral (length elts)++singleColumn :: Rational -> Rational -> [Window] -> Columns+singleColumn width height windows = [(width, fitElements height windows)]++findElement' :: (a -> Bool) -> [(Rational, a)] -> Maybe (Stack (Rational, a))+findElement' predicate list+  | (before, c : after) <- break (predicate . snd) list =+      Just $ Stack c (reverse before) after+  | otherwise = Nothing++findInColumns :: Window -> Columns -> Maybe (Stack (Rational, Column))+findInColumns window = findElement' (any ((== window) . snd))++findInColumn :: Window -> Column -> Maybe (Stack (Rational, Window))+findInColumn window = findElement' (== window)++removeWindows :: [Window] -> Columns -> Columns+removeWindows windows = removeEmptyColumns . fmap (second removeWindows')+  where+    inWindows (_, window) = window `notElem` windows+    removeWindows' = normalize . filter inWindows+    removeEmptyColumns = normalize . filter (not . null . snd)++removeWindow :: Window -> (Rational, Column) -> (Rational, Column)+removeWindow window = second (normalize . filter ((/= window) . snd))++addWindows :: [Window] -> Columns -> Columns+addWindows [] columns = columns+-- When there is only one column, create a new one on the right+addWindows windows [(_, windows')] = (1 % 2, windows') : singleColumn (1 % 2) 1 windows+-- When there is more, append the windows to the last column+addWindows windows columns+  | Just (columns', column) <- unsnoc columns =+      sanitizeColumns $ columns' <> [appendWindows windows column]+  | otherwise = singleColumn 1 1 windows++-- | Make sure the sum of all dimensions is 1+normalize :: [(Rational, a)] -> [(Rational, a)]+normalize elts = fmap (first (/ total)) elts+  where+    total = sum (fst <$> elts)++-- | Update the last dimension so that the sum of all dimensions is 1+sanitize :: [(Rational, a)] -> [(Rational, a)]+sanitize list+  | Just (elts, (_, a)) <- unsnoc list = elts <> [(1 - sum (fst <$> elts), a)]+  | otherwise = []++-- | Same on the whole layout+sanitizeColumns :: Columns -> Columns+sanitizeColumns = sanitize . fmap (second sanitize)++toOffsetRatio :: [(Rational, a)] -> [(Rational, Rational, a)]+toOffsetRatio ra = zipWith toTruple ra positions+  where+    toTruple (dimension, a) position = (position, dimension, a)+    positions = scanl' (\position (dimension, _) -> position + dimension) 0 ra++unsnoc :: [a] -> Maybe ([a], a)+unsnoc [] = Nothing+unsnoc (x : xs)+  | Just (is, l) <- unsnoc xs = Just (x : is, l)+  | otherwise = Just ([], x)
XMonad/Layout/Combo.hs view
@@ -1,9 +1,13 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses,-             UndecidableInstances, PatternGuards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE UndecidableInstances #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Combo+-- Description :  A layout that combines multiple layouts. -- Copyright   :  (c) David Roundy <droundy@darcs.net> -- License     :  BSD-style (see LICENSE) --@@ -22,27 +26,26 @@                             CombineTwo                            ) where -import Data.List ( delete, intersect, (\\) )-import Data.Maybe ( isJust ) import XMonad hiding (focus)-import XMonad.StackSet ( integrate', Workspace (..), Stack(..) )-import XMonad.Layout.WindowNavigation ( MoveWindowToWindow(..) )-import qualified XMonad.StackSet as W ( differentiate )+import XMonad.Layout.WindowNavigation (MoveWindowToWindow (..))+import XMonad.Prelude (delete, fromMaybe, intersect, isJust, (\\), listToMaybe)+import XMonad.StackSet (Stack (..), Workspace (..), integrate')+import XMonad.Util.Stack (zipperFocusedAtFirstOf)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Combo -- -- and add something like ----- > combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf)+-- > combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText def) (tabbed shrinkText def) -- -- to your layouts. ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- combineTwo is a new simple layout combinator. It allows the -- combination of two layouts using a third to split the screen@@ -57,7 +60,7 @@ -- >    , ((modm .|. controlMask .|. shiftMask, xK_Down ), sendMessage $ Move D) -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -- -- These bindings will move a window into the sublayout that is -- up\/down\/left\/right of its current position.  Note that there is some@@ -77,42 +80,42 @@ instance (LayoutClass l (), LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a)     => LayoutClass (CombineTwo (l ()) l1 l2) a where     runLayout (Workspace _ (C2 f w2 super l1 l2) s) rinput = arrange (integrate' s)-        where arrange [] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage ReleaseResources)-                              l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage ReleaseResources)-                              super' <- maybe super id `fmap`+        where arrange [] = do l1' <- fromMaybe l1 <$> handleMessage l1 (SomeMessage ReleaseResources)+                              l2' <- fromMaybe l2 <$> handleMessage l2 (SomeMessage ReleaseResources)+                              super' <- fromMaybe super <$>                                         handleMessage super (SomeMessage ReleaseResources)                               return ([], Just $ C2 [] [] super' l1' l2')-              arrange [w] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage ReleaseResources)-                               l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage ReleaseResources)-                               super' <- maybe super id `fmap`+              arrange [w] = do l1' <- fromMaybe l1 <$> handleMessage l1 (SomeMessage ReleaseResources)+                               l2' <- fromMaybe l2 <$> handleMessage l2 (SomeMessage ReleaseResources)+                               super' <- fromMaybe super <$>                                          handleMessage super (SomeMessage ReleaseResources)                                return ([(w,rinput)], Just $ C2 [w] [w] super' l1' l2')               arrange origws =-                  do let w2' = case origws `intersect` w2 of [] -> [head origws]+                  do let w2' = case origws `intersect` w2 of [] -> take 1 origws                                                              [x] -> [x]                                                              x -> case origws \\ x of                                                                   [] -> init x                                                                   _ -> x                          superstack = Stack { focus=(), up=[], down=[()] }-                         s1 = differentiate f' (origws \\ w2')-                         s2 = differentiate f' w2'+                         s1 = zipperFocusedAtFirstOf f' (origws \\ w2')+                         s2 = zipperFocusedAtFirstOf f' w2'                          f' = case s of (Just s') -> focus s':delete (focus s') f                                         Nothing -> f                      ([((),r1),((),r2)], msuper') <- runLayout (Workspace "" super (Just superstack)) rinput                      (wrs1, ml1') <- runLayout (Workspace "" l1 s1) r1                      (wrs2, ml2') <- runLayout (Workspace "" l2 s2) r2                      return (wrs1++wrs2, Just $ C2 f' w2'-                                     (maybe super id msuper') (maybe l1 id ml1') (maybe l2 id ml2'))+                                     (fromMaybe super msuper') (fromMaybe l1 ml1') (fromMaybe l2 ml2'))     handleMessage (C2 f ws2 super l1 l2) m         | Just (MoveWindowToWindow w1 w2) <- fromMessage m,           w1 `notElem` ws2,-          w2 `elem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m-                             l2' <- maybe l2 id `fmap` handleMessage l2 m+          w2 `elem` ws2 = do l1' <- fromMaybe l1 <$> handleMessage l1 m+                             l2' <- fromMaybe l2 <$> handleMessage l2 m                              return $ Just $ C2 f (w1:ws2) super l1' l2'         | Just (MoveWindowToWindow w1 w2) <- fromMessage m,           w1 `elem` ws2,-          w2 `notElem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m-                                l2' <- maybe l2 id `fmap` handleMessage l2 m+          w2 `notElem` ws2 = do l1' <- fromMaybe l1 <$> handleMessage l1 m+                                l2' <- fromMaybe l2 <$> handleMessage l2 m                                 let ws2' = case delete w1 ws2 of [] -> [w2]                                                                  x -> x                                 return $ Just $ C2 f ws2' super l1' l2'@@ -121,24 +124,16 @@                          msuper' <- broadcastPrivate m [super]                          if isJust msuper' || isJust ml1' || isJust ml2'                             then return $ Just $ C2 f ws2-                                                 (maybe super head msuper')-                                                 (maybe l1 head ml1')-                                                 (maybe l2 head ml2')+                                                 (fromMaybe super (listToMaybe =<< msuper'))+                                                 (fromMaybe l1    (listToMaybe =<< ml1'))+                                                 (fromMaybe l2    (listToMaybe =<< ml2'))                             else return Nothing     description (C2 _ _ super l1 l2) = "combining "++ description l1 ++" and "++                                        description l2 ++" with "++ description super --differentiate :: Eq q => [q] -> [q] -> Maybe (Stack q)-differentiate (z:zs) xs | z `elem` xs = Just $ Stack { focus=z-                                                     , up = reverse $ takeWhile (/=z) xs-                                                     , down = tail $ dropWhile (/=z) xs }-                        | otherwise = differentiate zs xs-differentiate [] xs = W.differentiate xs- broadcastPrivate :: LayoutClass l b => SomeMessage -> [l b] -> X (Maybe [l b]) broadcastPrivate a ol = do nml <- mapM f ol                            if any isJust nml-                              then return $ Just $ zipWith ((flip maybe) id) ol nml+                              then return $ Just $ zipWith (`maybe` id) ol nml                               else return Nothing     where f l = handleMessage l a `catchX` return Nothing
XMonad/Layout/ComboP.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, PatternGuards #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ComboP+-- Description :  Combine multiple layouts and specify where to put new windows. -- Copyright   :  (c) Konstantin Sobolev <konstantin.sobolev@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -20,33 +21,33 @@                              combineTwoP,                              CombineTwoP,                              SwapWindow(..),+                             PartitionWins(..),                              Property(..)                             ) where -import Data.List ( delete, intersect, (\\) )-import Data.Maybe ( isJust )-import Control.Monad import XMonad hiding (focus)-import XMonad.StackSet ( Workspace (..), Stack(..) ) import XMonad.Layout.WindowNavigation-import XMonad.Util.WindowProperties+import XMonad.Prelude+import XMonad.StackSet ( Workspace (..), Stack(..) ) import qualified XMonad.StackSet as W+import XMonad.Util.Stack (zipperFocusedAtFirstOf)+import XMonad.Util.WindowProperties  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.ComboP -- -- and add something like ----- > combineTwoP (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf) (ClassName "Firefox")+-- > combineTwoP (TwoPane 0.03 0.5) (tabbed shrinkText def) (tabbed shrinkText def) (ClassName "Firefox") -- -- to your layouts. This way all windows with class = \"Firefox\" will always go -- to the left pane, all others - to the right. ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- 'combineTwoP' is a simple layout combinator based on 'combineTwo' from Combo, with -- addition of a 'Property' which tells where to put new windows. Windows mathing@@ -64,13 +65,23 @@ -- >    , ((modm .|. controlMask .|. shiftMask, xK_s    ), sendMessage $ SwapWindow) -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  data SwapWindow =  SwapWindow        -- ^ Swap window between panes                  | SwapWindowN Int   -- ^ Swap window between panes in the N-th nested ComboP. @SwapWindowN 0@ equals to SwapWindow-                 deriving (Read, Show, Typeable)+                 deriving (Read, Show) instance Message SwapWindow +data PartitionWins = PartitionWins  -- ^ Reset the layout and+                                    -- partition all windows into the+                                    -- correct sub-layout.  Useful for+                                    -- when window properties have+                                    -- changed and you want ComboP to+                                    -- update which layout a window+                                    -- belongs to.+                   deriving (Read, Show)+instance Message PartitionWins+ data CombineTwoP l l1 l2 a = C2P [a] [a] [a] l (l1 a) (l2 a) Property                                 deriving (Read, Show) @@ -88,18 +99,19 @@             superstack = Just Stack { focus=(), up=[], down=[()] }             f' = focus s:delete (focus s) f  -- list of focused windows, contains 2 elements at most         in do-            matching <- (hasProperty prop) `filterM` new  -- new windows matching predecate-            let w1' = w1c ++ matching                     -- updated first pane windows-                w2' = w2c ++ (new \\ matching)            -- updated second pane windows-                s1 = differentiate f' w1'                 -- first pane stack-                s2 = differentiate f' w2'                 -- second pane stack+            matching <- hasProperty prop `filterM` new  -- new windows matching predecate+            let w1' = w1c ++ matching                   -- updated first pane windows+                w2' = w2c ++ (new \\ matching)          -- updated second pane windows+                s1 = zipperFocusedAtFirstOf f' w1'      -- first pane stack+                s2 = zipperFocusedAtFirstOf f' w2'      -- second pane stack             ([((),r1),((),r2)], msuper') <- runLayout (Workspace "" super superstack) rinput             (wrs1, ml1') <- runLayout (Workspace "" l1 s1) r1             (wrs2, ml2') <- runLayout (Workspace "" l2 s2) r2-            return  (wrs1++wrs2, Just $ C2P f' w1' w2' (maybe super id msuper')-                (maybe l1 id ml1') (maybe l2 id ml2') prop)+            return  (wrs1++wrs2, Just $ C2P f' w1' w2' (fromMaybe super msuper')+                (fromMaybe l1 ml1') (fromMaybe l2 ml2') prop)      handleMessage us@(C2P f ws1 ws2 super l1 l2 prop) m+        | Just PartitionWins   <- fromMessage m = return . Just $ C2P [] [] [] super l1 l2 prop         | Just SwapWindow      <- fromMessage m = swap us         | Just (SwapWindowN 0) <- fromMessage m = swap us         | Just (SwapWindowN n) <- fromMessage m = forwardToFocused us $ SomeMessage $ SwapWindowN $ n-1@@ -117,13 +129,13 @@                          msuper' <- handleMessage super m                          if isJust msuper' || isJust ml1' || isJust ml2'                             then return $ Just $ C2P f ws1 ws2-                                                 (maybe super id msuper')-                                                 (maybe l1 id ml1')-                                                 (maybe l2 id ml2') prop+                                                 (fromMaybe super msuper')+                                                 (fromMaybe l1 ml1')+                                                 (fromMaybe l2 ml2') prop                             else return Nothing      description (C2P _ _ _ super l1 l2 prop) = "combining " ++ description l1 ++ " and "++-                                description l2 ++ " with " ++ description super ++ " using "++ (show prop)+                                description l2 ++ " with " ++ description super ++ " using "++ show prop  -- send focused window to the other pane. Does nothing if we don't -- own the focused window@@ -154,7 +166,7 @@             then return Nothing             else handleMessage super m     if isJust ml1 || isJust ml2 || isJust ms-        then return $ Just $ C2P f ws1 ws2 (maybe super id ms) (maybe l1 id ml1) (maybe l2 id ml2) prop+        then return $ Just $ C2P f ws1 ws2 (fromMaybe super ms) (fromMaybe l1 ml1) (fromMaybe l2 ml2) prop         else return Nothing  -- forwards message m to layout l if focused window is among w@@ -162,19 +174,8 @@ forwardIfFocused l w m = do     mst <- gets (W.stack . W.workspace . W.current . windowset)     maybe (return Nothing) send mst where-    send st = if (W.focus st) `elem` w+    send st = if W.focus st `elem` w                 then handleMessage l m                 else return Nothing---- code from CombineTwo--- given two sets of zs and xs takes the first z from zs that also belongs to xs--- and turns xs into a stack with z being current element. Acts as--- StackSet.differentiate if zs and xs don't intersect-differentiate :: Eq q => [q] -> [q] -> Maybe (Stack q)-differentiate (z:zs) xs | z `elem` xs = Just $ Stack { focus=z-                                                     , up = reverse $ takeWhile (/=z) xs-                                                     , down = tail $ dropWhile (/=z) xs }-                        | otherwise = differentiate zs xs-differentiate [] xs = W.differentiate xs  -- vim:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20:
XMonad/Layout/Cross.hs view
@@ -2,6 +2,7 @@  -- | -- Module      :  XMonad.Layout.Cross+-- Description :  A Cross Layout with the main window in the center. -- Copyright   :  (c) Luis Cabellos <zhen.sydow@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -11,7 +12,7 @@ -- -- A Cross Layout with the main window in the center. ---module XMonad.Layout.Cross(+module XMonad.Layout.Cross {-# DEPRECATED "Use XMonad.Layout.Circle or XMonad.Layout.ThreeColumn.ThreeColMid instead" #-} (                           -- * Usage                           -- $usage                           simpleCross@@ -19,22 +20,22 @@  import XMonad( Dimension, Rectangle(..), LayoutClass(..), Resize(..), fromMessage ) import XMonad.StackSet( focus, up, down )-import Control.Monad( msum )+import XMonad.Prelude( msum )  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Cross -- -- Then edit your @layoutHook@ by adding one of the Cross layouts: -- -- > myLayout =  simpleCross ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } --  -- apply a factor to a Rectangle Dimension (<%>) :: Dimension -> Rational -> Dimension-d <%> f = floor $ f * (fromIntegral d)+d <%> f = floor $ f * fromIntegral d  -- | The Cross Layout draws the focused window in the center of the screen --   and part of the other windows on the sides. The 'Shrink' and 'Expand'@@ -57,10 +58,10 @@ simpleCross = Cross (4/5) (1/100)  instance LayoutClass Cross a where-    pureLayout (Cross f _) r s = [(focus s, mainRect r f)] ++-                                 (zip winCycle (upRects r f)) ++-                                 (zip (reverse winCycle) (downRects r f))-        where winCycle = (up s) ++ (reverse (down s))+    pureLayout (Cross f _) r s = [(focus s, mainRect r f)]+                              ++ zip winCycle (upRects r f)+                              ++ zip (reverse winCycle) (downRects r f)+        where winCycle = up s ++ reverse (down s)      pureMessage (Cross f d) m = msum [fmap resize (fromMessage m)]         where resize Shrink = Cross (max (1/100) $ f - d) d@@ -71,8 +72,8 @@ -- get the Rectangle for the focused window mainRect :: Rectangle -> Rational -> Rectangle mainRect (Rectangle rx ry rw rh) f = Rectangle-                                     (rx + (fromIntegral (rw <%> invf)))-                                     (ry + (fromIntegral (rh <%> invf)))+                                     (rx + fromIntegral (rw <%> invf))+                                     (ry + fromIntegral (rh <%> invf))                                      (rw <%> f) (rh <%> f)     where invf = (1/2) * (1-f) @@ -88,25 +89,24 @@  topRectangle :: Rectangle -> Rational -> Rectangle topRectangle (Rectangle rx ry rw rh) f = Rectangle-                                         (rx + (fromIntegral (rw <%> ((1-f)*(1/2)))))+                                         (rx + fromIntegral (rw <%> ((1-f)*(1/2))))                                          ry                                          (rw <%> f) (rh <%> ((1-f)*(1/2)))  rightRectangle :: Rectangle -> Rational -> Rectangle rightRectangle (Rectangle rx ry rw rh) f = Rectangle-                                           (rx + (fromIntegral (rw - (rw <%> (1/2)))))-                                           (ry + (fromIntegral (rh <%> ((1-f)*(1/2)))))+                                           (rx + fromIntegral (rw - (rw <%> (1/2))))+                                           (ry + fromIntegral (rh <%> ((1-f)*(1/2))))                                            (rw <%> (1/2)) (rh <%> f)  bottomRectangle :: Rectangle -> Rational -> Rectangle bottomRectangle (Rectangle rx ry rw rh) f = Rectangle-                                            (rx + (fromIntegral (rw <%> ((1-f)*(1/2)))))-                                            (ry + (fromIntegral (rh - (rh <%> ((1-f)*(1/2))))))+                                            (rx + fromIntegral (rw <%> ((1-f)*(1/2))))+                                            (ry + fromIntegral (rh - (rh <%> ((1-f)*(1/2)))))                                             (rw <%> f) (rh <%> ((1-f)*(1/2)))  leftRectangle :: Rectangle -> Rational -> Rectangle leftRectangle (Rectangle rx ry rw rh) f = Rectangle                                           rx-                                           (ry + (fromIntegral (rh <%> ((1-f)*(1/2)))))+                                           (ry + fromIntegral (rh <%> ((1-f)*(1/2))))                                            (rw <%> (1/2)) (rh <%> f)-
XMonad/Layout/Decoration.hs view
@@ -1,7 +1,13 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE TupleSections         #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Decoration+-- Description :  A layout modifier and a class for easily creating decorated layouts. -- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger -- License     :  BSD-style (see xmonad/LICENSE) --@@ -17,7 +23,7 @@     ( -- * Usage:       -- $usage       decoration-    , Theme (..), defaultTheme+    , Theme (..), def     , Decoration     , DecorationMsg (..)     , DecorationStyle (..)@@ -30,12 +36,10 @@     , DecorationState, OrigWin     ) where -import Control.Monad (when)-import Data.Maybe-import Data.List import Foreign.C.Types(CInt)  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W import XMonad.Hooks.UrgencyHook import XMonad.Layout.LayoutModifier@@ -68,18 +72,21 @@ -- -- For a collection of 'Theme's see "XMonad.Util.Themes" data Theme =-    Theme { activeColor        :: String                   -- ^ Color of the active window-          , inactiveColor       :: String                   -- ^ Color of the inactive window-          , urgentColor         :: String                   -- ^ Color of the urgent window-          , activeBorderColor   :: String                   -- ^ Color of the border of the active window-          , inactiveBorderColor :: String                   -- ^ Color of the border of the inactive window-          , urgentBorderColor   :: String                   -- ^ Color of the border of the urgent window-          , activeTextColor     :: String                   -- ^ Color of the text of the active window-          , inactiveTextColor   :: String                   -- ^ Color of the text of the inactive window-          , urgentTextColor     :: String                   -- ^ Color of the text of the urgent window-          , fontName            :: String                   -- ^ Font name-          , decoWidth           :: Dimension                -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle')-          , decoHeight          :: Dimension                -- ^ Height of the decorations+    Theme { activeColor         :: String                  -- ^ Color of the active window+          , inactiveColor       :: String                  -- ^ Color of the inactive window+          , urgentColor         :: String                  -- ^ Color of the urgent window+          , activeBorderColor   :: String                  -- ^ Color of the border of the active window+          , inactiveBorderColor :: String                  -- ^ Color of the border of the inactive window+          , urgentBorderColor   :: String                  -- ^ Color of the border of the urgent window+          , activeBorderWidth   :: Dimension               -- ^ Width of the border of the active window+          , inactiveBorderWidth :: Dimension               -- ^ Width of the border of the inactive window+          , urgentBorderWidth   :: Dimension               -- ^ Width of the border of the urgent window+          , activeTextColor     :: String                  -- ^ Color of the text of the active window+          , inactiveTextColor   :: String                  -- ^ Color of the text of the inactive window+          , urgentTextColor     :: String                  -- ^ Color of the text of the urgent window+          , fontName            :: String                  -- ^ Font name+          , decoWidth           :: Dimension               -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle')+          , decoHeight          :: Dimension               -- ^ Height of the decorations           , windowTitleAddons   :: [(String, Align)]       -- ^ Extra text to appear in a window's title bar.                                                            --    Refer to for a use "XMonad.Layout.ImageButtonDecoration"           , windowTitleIcons    :: [([[Bool]], Placement)] -- ^ Extra icons to appear in a window's title bar.@@ -87,18 +94,25 @@           } deriving (Show, Read)  -- | The default xmonad 'Theme'.-defaultTheme :: Theme-defaultTheme =+instance Default Theme where+  def =     Theme { activeColor         = "#999999"           , inactiveColor       = "#666666"           , urgentColor         = "#FFFF00"           , activeBorderColor   = "#FFFFFF"           , inactiveBorderColor = "#BBBBBB"           , urgentBorderColor   = "##00FF00"+          , activeBorderWidth   = 1+          , inactiveBorderWidth = 1+          , urgentBorderWidth   = 1           , activeTextColor     = "#FFFFFF"           , inactiveTextColor   = "#BFBFBF"           , urgentTextColor     = "#FF0000"+#ifdef XFT+          , fontName            = "xft:monospace"+#else           , fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"+#endif           , decoWidth           = 200           , decoHeight          = 20           , windowTitleAddons   = []@@ -107,7 +121,7 @@  -- | A 'Decoration' layout modifier will handle 'SetTheme', a message -- to dynamically change the decoration 'Theme'.-data DecorationMsg = SetTheme Theme deriving ( Typeable )+newtype DecorationMsg = SetTheme Theme instance Message DecorationMsg  -- | The 'Decoration' state component, where the list of decorated@@ -139,7 +153,7 @@      -- | The description that the 'Decoration' modifier will display.     describeDeco :: ds a -> String-    describeDeco ds = show ds+    describeDeco = show      -- | Shrink the window's rectangle when applying a decoration.     shrink :: ds a -> Rectangle -> Rectangle -> Rectangle@@ -147,7 +161,7 @@      -- | The decoration event hook     decorationEventHook :: ds a -> DecorationState -> Event -> X ()-    decorationEventHook ds s e = handleMouseFocusDrag ds s e+    decorationEventHook = handleMouseFocusDrag      -- | A hook that can be used to catch the cases when the user     -- clicks on the decoration. If you return True here, the click event@@ -163,7 +177,7 @@     -- The hook can be overwritten if a different way of handling the dragging     -- is required.     decorationWhileDraggingHook :: ds a -> CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()-    decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleDraggingInProgress ex ey (mainw, r) x y+    decorationWhileDraggingHook _ = handleDraggingInProgress      -- | This hoook is called after a window has been dragged using the decoration.     decorationAfterDraggingHook :: ds a -> (Window, Rectangle) -> Window -> X ()@@ -228,10 +242,9 @@                                     toDel = todel d dwrs                                     toAdd = toadd a wrs                                 deleteDecos (map snd toDel)-                                let ndwrs = zip toAdd $ repeat (Nothing,Nothing)+                                let ndwrs = map (, (Nothing,Nothing)) toAdd                                 ndecos <- resync (ndwrs ++ del_dwrs d dwrs) wrs                                 processState (s {decos = ndecos })-        | otherwise        = return (wrs, Nothing)          where           ws        = map fst wrs@@ -272,7 +285,7 @@                               updateDecos sh t (font s) ndwrs                               return (dwrs_to_wrs ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh t ds)) -    handleMess (Decoration (I (Just s@(DS {decos = dwrs}))) sh t ds) m+    handleMess (Decoration (I (Just s@DS{decos = dwrs})) sh t ds) m         | Just e <- fromMessage m                = do decorationEventHook ds s e                                                       handleEvent sh t s e                                                       return Nothing@@ -291,9 +304,9 @@ handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X () handleEvent sh t (DS dwrs fs) e     | PropertyEvent {ev_window = w} <- e-    , Just i <- w `elemIndex`             (map (fst . fst) dwrs) = updateDeco sh t fs (dwrs !! i)+    , Just i <- w `elemIndex` map (fst . fst) dwrs      = updateDeco sh t fs (dwrs !! i)     | ExposeEvent   {ev_window = w} <- e-    , Just i <- w `elemIndex` (catMaybes $ map (fst . snd) dwrs) = updateDeco sh t fs (dwrs !! i)+    , Just i <- w `elemIndex` mapMaybe (fst . snd) dwrs = updateDeco sh t fs (dwrs !! i) handleEvent _ _ _ _ = return ()  -- | Mouse focus and mouse drag are handled by the same function, this@@ -305,11 +318,11 @@                                                 , ev_y_root     = ey }     | et == buttonPress     , Just ((mainw,r), (_, decoRectM)) <- lookFor ew dwrs = do-        let Just (Rectangle dx _ dwh _) = decoRectM+        let Rectangle dx _ dwh _ = fromJust decoRectM             distFromLeft = ex - fi dx             distFromRight = fi dwh - (ex - fi dx)         dealtWith <- decorationCatchClicksHook ds mainw (fi distFromLeft) (fi distFromRight)-        when (not dealtWith) $ do+        unless dealtWith $             mouseDrag (\x y -> focus mainw >> decorationWhileDraggingHook ds ex ey (mainw, r) x y)                         (decorationAfterDraggingHook ds (mainw, r) ew) handleMouseFocusDrag _ _ _ = return ()@@ -364,17 +377,21 @@ createDecos _ _ _ _ _ [] = return []  createDecoWindow :: Theme -> Rectangle -> X Window-createDecoWindow t r = let mask = Just (exposureMask .|. buttonPressMask) in-                       createNewWindow r mask (inactiveColor t) True+createDecoWindow t r = do+  let mask = Just (exposureMask .|. buttonPressMask)+  w <- createNewWindow r mask (inactiveColor t) True+  d <- asks display+  io $ setClassHint d w (ClassHint "xmonad-decoration" "xmonad")+  pure w  showDecos :: [DecoWin] -> X ()-showDecos = showWindows . catMaybes . map fst . filter (isJust . snd)+showDecos = showWindows . mapMaybe fst . filter (isJust . snd)  hideDecos :: [DecoWin] -> X ()-hideDecos = hideWindows . catMaybes . map fst+hideDecos = hideWindows . mapMaybe fst  deleteDecos :: [DecoWin] -> X ()-deleteDecos = deleteWindows . catMaybes . map fst+deleteDecos = deleteWindows . mapMaybe fst  updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X () updateDecos s t f = mapM_ $ updateDeco s t f@@ -383,25 +400,30 @@ -- structure and the needed 'Rectangle's updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X () updateDeco sh t fs ((w,_),(Just dw,Just (Rectangle _ _ wh ht))) = do-  nw  <- getName w+  -- xmonad-contrib #809+  -- qutebrowser will happily shovel a 389K multiline string into @_NET_WM_NAME@+  -- and the 'defaultShrinker' (a) doesn't handle multiline strings well (b) is+  -- quadratic due to using 'init'+  nw  <- fmap (take 2048 . takeWhile (/= '\n') . show) (getName w)   ur  <- readUrgents   dpy <- asks display-  let focusColor win ic ac uc = (maybe ic (\focusw -> case () of-                                                       _ | focusw == win -> ac-                                                         | win `elem` ur -> uc-                                                         | otherwise     -> ic) . W.peek)-                                `fmap` gets windowset-  (bc,borderc,tc) <- focusColor w (inactiveColor t, inactiveBorderColor t, inactiveTextColor t)-                                  (activeColor   t, activeBorderColor   t, activeTextColor   t)-                                  (urgentColor   t, urgentBorderColor   t, urgentTextColor   t)+  let focusColor win ic ac uc = maybe ic (\focusw -> case () of+                                                      _ | focusw == win -> ac+                                                        | win `elem` ur -> uc+                                                        | otherwise     -> ic) . W.peek+                                <$> gets windowset+  (bc,borderc,borderw,tc) <-+    focusColor w (inactiveColor t, inactiveBorderColor t, inactiveBorderWidth t, inactiveTextColor t)+                 (activeColor   t, activeBorderColor   t, activeBorderWidth   t, activeTextColor   t)+                 (urgentColor   t, urgentBorderColor   t, urgentBorderWidth   t, urgentTextColor   t)   let s = shrinkIt sh   name <- shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy fs n-                                  return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)+                                  return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) nw   let als = AlignCenter : map snd (windowTitleAddons t)       strs = name : map fst (windowTitleAddons t)       i_als = map snd (windowTitleIcons t)       icons = map fst (windowTitleIcons t)-  paintTextAndIcons dw fs wh ht 1 bc borderc tc bc als strs i_als icons+  paintTextAndIcons dw fs wh ht borderw bc borderc tc bc als strs i_als icons updateDeco _ _ _ (_,(Just w,Nothing)) = hideWindow w updateDeco _ _ _ _ = return ()
XMonad/Layout/DecorationAddons.hs view
@@ -1,6 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.DecorationAddons+-- Description :  Various stuff that can be added to the decoration. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -24,14 +25,13 @@ import qualified XMonad.StackSet as W import XMonad.Layout.Decoration import XMonad.Actions.WindowMenu-import XMonad.Layout.Minimize+import XMonad.Actions.Minimize import XMonad.Layout.Maximize import XMonad.Hooks.ManageDocks import XMonad.Util.Font import XMonad.Util.PositionStore -import Control.Applicative((<$>))-import Data.Maybe+import XMonad.Prelude import qualified Data.Set as S  minimizeButtonOffset :: Int@@ -52,23 +52,20 @@ -- See 'defaultThemeWithButtons' below. titleBarButtonHandler :: Window -> Int -> Int -> X Bool titleBarButtonHandler mainw distFromLeft distFromRight = do-    let action = if (fi distFromLeft <= 3 * buttonSize)-                        then focus mainw >> windowMenu >> return True-                  else if (fi distFromRight >= closeButtonOffset &&-                           fi distFromRight <= closeButtonOffset + buttonSize)-                              then focus mainw >> kill >> return True-                  else if (fi distFromRight >= maximizeButtonOffset &&-                           fi distFromRight <= maximizeButtonOffset + (2 * buttonSize))-                             then focus mainw >> sendMessage (maximizeRestore mainw) >> return True-                  else if (fi distFromRight >= minimizeButtonOffset &&-                           fi distFromRight <= minimizeButtonOffset + buttonSize)-                             then focus mainw >> minimizeWindow mainw >> return True-                  else return False+    let action+          | fi distFromLeft <= 3 * buttonSize = focus mainw >> windowMenu >> return True+          | fi distFromRight >= closeButtonOffset &&+            fi distFromRight <= closeButtonOffset + buttonSize = focus mainw >> kill >> return True+          | fi distFromRight >= maximizeButtonOffset &&+            fi distFromRight <= maximizeButtonOffset + (2 * buttonSize) = focus mainw >> sendMessage (maximizeRestore mainw) >> return True+          | fi distFromRight >= minimizeButtonOffset &&+            fi distFromRight <= minimizeButtonOffset + buttonSize = focus mainw >> minimizeWindow mainw >> return True+          | otherwise = return False     action  -- | Intended to be used together with 'titleBarButtonHandler'. See above. defaultThemeWithButtons :: Theme-defaultThemeWithButtons = defaultTheme {+defaultThemeWithButtons = def {                             windowTitleAddons = [ (" (M)", AlignLeft)                                                 , ("_"   , AlignRightOffset minimizeButtonOffset)                                                 , ("[]"  , AlignRightOffset maximizeButtonOffset)@@ -89,7 +86,7 @@     maybeWksp <- screenWorkspace $ W.screen sc     let targetWksp = maybeWksp >>= \wksp ->                         W.findTag w ws >>= \currentWksp ->-                        if (currentWksp /= wksp)+                        if currentWksp /= wksp                             then Just wksp                             else Nothing     case targetWksp of
+ XMonad/Layout/DecorationEx.hs view
@@ -0,0 +1,106 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx+-- Description :  Advanced window decorations module for XMonad+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- This set of modules contains a set of type classes and their implementations+-- which define a flexible and extensible mechanism of window decorations.+--+-- <<https://github.com/xmonad/xmonad-contrib/assets/50166980/ccc20e1b-6762-48d9-8195-579f77a98396>>+-- Click <https://github.com/xmonad/xmonad-contrib/assets/50166980/64847a85-33c4-4b5f-8ec8-df73d3e4d58d here>+-- for a larger version.+--+-- Within this mechanism, there are the following entities which define+-- how decorations will look and work:+--+-- * Main object is @DecorationEx@ layout modifier. It is from where everything+--   starts. It creates, shows and hides decoration windows (rectangles) when+--   needed. It is parameterized with decoration geometry, decoration engine and+--   theme. It calls these components to do their parts of the work.+-- * @DecorationGeometry@ defines where decoration rectangles should be placed.+--   For example, standard horizontal bar above each window; or tab bar.+-- * @DecorationEngine@ defines how decorations look and how they react on clicks.+--   Different implementations of the decoration engine can use different APIs+--   to draw decorations. Within this package, there is one implementation +--   (@TextDecoration@), which uses plain Xlib calls, and displays decoration+--   widgets with text fragments, like @[X]@ or @[_]@. Other engines can, for+--   example, use the Cairo library to draw nice gradients and image-based widgets.+-- * A Decoration widget is an element placed on a window decoration. It defines how+--   it looks and how it responds to clicks. Examples include usual window +--   buttons (minimize, maximize, close), window icon, window title.+-- * A Decoration theme defines colors and fonts for the decoration engine. It also+--   contains a list of decoration widgets and says where to place them (at the+--   left, at the right or in the center).+-- +-- This mechanism makes major use of parameterized data types and type families,+-- in order to make it possible to define different types of decorations, and+-- easily combine different aspects of decorations. For example, each decoration+-- engine can be combined with each decoration geometry.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx (+  -- * Usage:+  -- $usage++  -- * Standard decoration settings+  decorationEx,+  textDecoration, textTabbed, dwmStyleDeco,+  -- * Decoration-related types+  TextDecoration (..), DefaultGeometry (..),+  TabbedGeometry (..), DwmGeometry (..),+  DecorationEx,+  -- * Theme types+  BoxBorders (..), BorderColors,+  SimpleStyle (..), GenericTheme (..),+  ThemeEx,+  -- * Widget types+  StandardCommand (..), GenericWidget (..),+  StandardWidget,+  -- * Utility functions for themes+  themeEx, borderColor, shadowBorder,+  -- * Convinience re-exports+  Shrinker (..), shrinkText,+  -- * Standard widgets+  titleW, toggleStickyW, minimizeW,+  maximizeW, closeW, dwmpromoteW,+  moveToNextGroupW, moveToPrevGroupW+  ) where++import XMonad.Layout.Decoration+import XMonad.Layout.DecorationEx.Common+import XMonad.Layout.DecorationEx.Widgets+import XMonad.Layout.DecorationEx.Geometry+import XMonad.Layout.DecorationEx.LayoutModifier+import XMonad.Layout.DecorationEx.TextEngine+import XMonad.Layout.DecorationEx.TabbedGeometry+import XMonad.Layout.DecorationEx.DwmGeometry++-- $usage+--+-- You can use this module with the following in your+-- @xmonad.hs@:+--+-- > import XMonad.Layout.DecorationEx+-- Then edit your @layoutHook@ by adding the DwmStyle decoration to+-- your layout:+--+-- > myTheme = ThemeEx {...}+-- > myL = textDecoration shrinkText myTheme (layoutHook def)+-- > main = xmonad def { layoutHook = myL }+--+-- For more detailed instructions on editing the layoutHook see:+--+-- "XMonad.Doc.Extending#Editing_the_layout_hook"+--+-- This module exports only some definitions from it's submodules,+-- most likely to be used from user configurations. To define+-- your own decoration types you will likely have to import specific+-- submodules.+
+ XMonad/Layout/DecorationEx/Common.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.Common+-- Description :  Declaration of types used by DecorationEx module,+--                and commonly used utility functions.+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module exposes a number of types which are used by other sub-modules+-- of "XMonad.Layout.DecorationEx" module.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.Common (+    -- * Common types+    WindowDecoration (..)+  , WindowCommand (..)+  , DecorationWidget (..)+  , WidgetPlace (..)+  , WidgetLayout (..)+  , HasWidgets (..)+  , ClickHandler (..)+  , ThemeAttributes (..)+  , XPaintingContext+  , BoxBorders (..)+  , BorderColors+  , ThemeStyleType (..)+  , SimpleStyle (..)+  , GenericTheme (..)+  , ThemeEx +  -- * Utilities+  , widgetLayout+  , windowStyleType+  , genericWindowStyle+  , themeEx+  , borderColor+  , shadowBorder+  ) where++import qualified Data.Map as M+import Data.Bits (testBit)++import XMonad+import qualified XMonad.StackSet as W+import XMonad.Hooks.UrgencyHook+import qualified XMonad.Layout.Decoration as D++-- | Information about decoration of one window+data WindowDecoration = WindowDecoration {+    wdOrigWindow :: !Window         -- ^ Original window (one being decorated)+  , wdOrigWinRect :: !Rectangle     -- ^ Rectangle of original window+  , wdDecoWindow :: !(Maybe Window) -- ^ Decoration window, or Nothing if this window should not be decorated+  , wdDecoRect :: !(Maybe Rectangle) -- ^ Rectangle for decoration window+  , wdWidgets :: ![WidgetPlace]      -- ^ Places for widgets+  }++-- | Type class for window commands (such as maximize or close window)+class (Read cmd, Show cmd) => WindowCommand cmd where+  -- | Execute the command+  executeWindowCommand :: cmd -> Window -> X Bool++  -- | Is the command currently in `checked' state. +  -- For example, for 'sticky' command, check if the+  -- window is currently sticky.+  isCommandChecked :: cmd -> Window -> X Bool++-- | Type class for decoration widgets+class (WindowCommand (WidgetCommand widget), Read widget, Show widget)+  => DecorationWidget widget where+  -- | Type of window commands which this type of widgets can execute+  type WidgetCommand widget++  -- | Get window command which is associated with this widget.+  widgetCommand :: widget -> Int -> WidgetCommand widget++  -- | Check if the widget is shrinkable, i.e. if it's width+  -- can be reduced if there is not enough place in the decoration.+  isShrinkable :: widget -> Bool++-- | Layout of widgets+data WidgetLayout a = WidgetLayout {+    wlLeft :: ![a]     -- ^ Widgets that should be aligned to the left side of decoration+  , wlCenter :: ![a]   -- ^ Widgets that should be in the center of decoration+  , wlRight :: ![a]    -- ^ Widgets taht should be aligned to the right side of decoration+  }++-- | Data type describing where the decoration widget (e.g. window button)+-- should be placed.+-- All coordinates are relative to decoration rectangle.+data WidgetPlace = WidgetPlace {+    wpTextYPosition :: !Position -- ^ Y position of text base line+                                 -- (for widgets like window title or text-based buttons)+  , wpRectangle :: !Rectangle    -- ^ Rectangle where to place the widget+  }+  deriving (Show)++-- | Generic data type which is used to+-- describe characteristics of rectangle borders.+data BoxBorders a = BoxBorders {+    bxTop :: !a+  , bxRight :: !a+  , bxBottom :: !a+  , bxLeft :: !a+  } deriving (Eq, Read, Show)++-- | Convinience data type describing colors of decoration rectangle borders.+type BorderColors = BoxBorders String++-- | Data type describing look of window decoration+-- in particular state (active or inactive)+data SimpleStyle = SimpleStyle {+    sBgColor :: !String                 -- ^ Decoration background color+  , sTextColor :: !String               -- ^ Text (foreground) color+  , sTextBgColor :: !String             -- ^ Text background color+  , sDecoBorderWidth :: !Dimension      -- ^ Width of border of decoration rectangle. Set to 0 to disable the border.+  , sDecorationBorders :: !BorderColors -- ^ Colors of borders of decoration rectangle.+  }+  deriving (Show, Read)++-- | Type class for themes, which claims that+-- the theme contains the list of widgets and their alignments.+class HasWidgets theme widget where+  themeWidgets :: theme widget -> WidgetLayout widget++-- | Type class for themes, which claims that+-- the theme can describe how the decoration should respond+-- to clicks on decoration itself (between widgets).+class ClickHandler theme widget where+  -- | This is called when the user clicks on the decoration rectangle+  -- (not on one of widgets).+  onDecorationClick :: theme widget+                    -> Int                          -- ^ Mouse button number+                    -> Maybe (WidgetCommand widget)++  -- | Determine if it is possible to drag window by it's decoration+  -- with mouse button.+  isDraggingEnabled :: theme widget+                    -> Int          -- ^ Mouse button number+                    -> Bool++-- | Type class for themes, which claims that the theme+-- is responsible for determining looks of decoration.+class (Read theme, Show theme) => ThemeAttributes theme where+  -- | Type which describes looks of decoration in one+  -- of window states (active, inactive, urgent, etc).+  type Style theme++  -- | Select style based on window state.+  selectWindowStyle :: theme -> Window -> X (Style theme)++  -- | Define padding between decoration rectangle and widgets.+  widgetsPadding :: theme -> BoxBorders Dimension+  +  -- | Initial background color of decoration rectangle.+  -- When decoration widget is created, it is initially filled+  -- with this color.+  defaultBgColor :: theme -> String++  -- | Font name defined in the theme.+  themeFontName :: theme -> String++-- | Generic Theme data type. This is used+-- by @TextEngine@ and can be used by other relatively+-- simple decoration engines.+data GenericTheme style widget = GenericTheme {+    exActive :: !style                                  -- ^ Decoration style for active (focused) windows+  , exInactive :: !style                                -- ^ Decoration style for inactive (unfocused) windows+  , exUrgent :: !style                                  -- ^ Decoration style for urgent windows+  , exPadding :: !(BoxBorders Dimension)                -- ^ Padding between decoration rectangle and widgets+  , exFontName :: !String                               -- ^ Font name+  , exOnDecoClick :: !(M.Map Int (WidgetCommand widget)) -- ^ Correspondence between mouse button number and window command.+  , exDragWindowButtons :: ![Int]                       -- ^ For which mouse buttons dragging is enabled+  , exWidgetsLeft :: ![widget]                          -- ^ Widgets that should appear at the left of decoration rectangle (listed left to right)+  , exWidgetsCenter :: ![widget]                        -- ^ Widgets that should appear in the center of decoration rectangle (listed left to right)+  , exWidgetsRight :: ![widget]                         -- ^ Widgets that should appear at the right of decoration rectangle (listed left to right)+  }++deriving instance (Show widget, Show (WidgetCommand widget), Show style) => Show (GenericTheme style widget)+deriving instance (Read widget, Read (WidgetCommand widget), Read style) => Read (GenericTheme style widget)++-- | Convience type for themes used by @TextDecoration@.+type ThemeEx widget = GenericTheme SimpleStyle widget++instance HasWidgets (GenericTheme style) widget where+  themeWidgets theme = WidgetLayout (exWidgetsLeft theme) (exWidgetsCenter theme) (exWidgetsRight theme)++-- | Supported states of windows (on which looks of decorations can depend).+data ThemeStyleType = ActiveWindow | UrgentWindow | InactiveWindow+  deriving (Eq, Show, Read)++-- | Utility function to convert WidgetLayout to plain list of widgets.+widgetLayout :: WidgetLayout widget -> [widget]+widgetLayout ws = wlLeft ws ++ wlCenter ws ++ wlRight ws++-- | Painting context for decoration engines based on plain X11 calls.+type XPaintingContext = (Display, Pixmap, GC)++instance (Show widget, Read widget, Read (WidgetCommand widget), Show (WidgetCommand widget))+        => ThemeAttributes (ThemeEx widget) where+  type Style (ThemeEx widget) = SimpleStyle+  selectWindowStyle theme w = genericWindowStyle w theme+  defaultBgColor t = sBgColor $ exInactive t+  widgetsPadding = exPadding+  themeFontName = exFontName++instance ClickHandler (GenericTheme SimpleStyle) widget where+  onDecorationClick theme button = M.lookup button (exOnDecoClick theme)+  isDraggingEnabled theme button = button `elem` exDragWindowButtons theme++-- | Generic utility function to select style from @GenericTheme@+-- based on current state of the window.+genericWindowStyle :: Window -> GenericTheme style widget -> X style+genericWindowStyle win theme = do+  styleType <- windowStyleType win+  return $ case styleType of+             ActiveWindow -> exActive theme+             InactiveWindow -> exInactive theme+             UrgentWindow -> exUrgent theme++-- | Detect type of style to be used from current state of the window.+windowStyleType :: Window -> X ThemeStyleType+windowStyleType win = do+  mbFocused <- W.peek <$> gets windowset+  isWmStateUrgent <- (win `elem`) <$> readUrgents+  isUrgencyBitSet <- withDisplay $ \dpy -> do+                       hints <- io $ getWMHints dpy win+                       return $ wmh_flags hints `testBit` urgencyHintBit+  if isWmStateUrgent || isUrgencyBitSet+    then return UrgentWindow+    else return $+      case mbFocused of+        Nothing -> InactiveWindow+        Just focused+          | focused == win -> ActiveWindow+          | otherwise -> InactiveWindow++-- | Convert Theme type from "XMonad.Layout.Decoration" to +-- theme type used by "XMonad.Layout.DecorationEx.TextEngine".+themeEx :: Default (WidgetCommand widget) => D.Theme -> ThemeEx widget+themeEx t =+    GenericTheme {+          exActive = SimpleStyle (D.activeColor t) (D.activeTextColor t) (D.activeColor t) (D.activeBorderWidth t) (borderColor $ D.activeColor t)+        , exInactive = SimpleStyle (D.inactiveColor t) (D.inactiveTextColor t) (D.inactiveColor t) (D.inactiveBorderWidth t) (borderColor $ D.inactiveColor t)+        , exUrgent = SimpleStyle (D.urgentColor t) (D.urgentTextColor t) (D.urgentColor t) (D.urgentBorderWidth t) (borderColor $ D.urgentColor t)+        , exPadding = BoxBorders 0 4 0 4+        , exFontName = D.fontName t+        , exOnDecoClick = M.fromList [(1, def)]+        , exDragWindowButtons = [1]+        , exWidgetsLeft = []+        , exWidgetsCenter = []+        , exWidgetsRight = []+      }++instance Default (WidgetCommand widget) => Default (ThemeEx widget) where+  def = themeEx (def :: D.Theme)++borderColor :: String -> BorderColors+borderColor c = BoxBorders c c c c++shadowBorder :: String -> String -> BorderColors+shadowBorder highlight shadow = BoxBorders highlight shadow shadow highlight+
+ XMonad/Layout/DecorationEx/DwmGeometry.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.DwmGeometry+-- Description :  DWM-style window decoration geometry+-- Copyright   :  (c) 2007 Andrea Rossato, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- This defines window decorations which are shown as a bar of fixed width+-- on top of window.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.DwmGeometry (+    -- * Usage:+    -- $usage+    DwmGeometry (..),+    dwmStyleDeco, dwmStyleDecoEx+  ) where ++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W+import XMonad.Layout.LayoutModifier+import qualified XMonad.Layout.Decoration as D++import XMonad.Layout.DecorationEx.LayoutModifier+import XMonad.Layout.DecorationEx.Common+import XMonad.Layout.DecorationEx.Geometry+import XMonad.Layout.DecorationEx.Widgets+import XMonad.Layout.DecorationEx.TextEngine++-- $usage+-- You can use this module with the following in your+-- @xmonad.hs@:+--+-- > import XMonad.Layout.DecorationEx.DwmStyle+-- Then edit your @layoutHook@ by adding the DwmStyle decoration to+-- your layout:+--+-- > myL = dwmStyleDeco shrinkText (layoutHook def)+-- > main = xmonad def { layoutHook = myL }+--+-- For more detailed instructions on editing the layoutHook see:+--+-- "XMonad.Doc.Extending#Editing_the_layout_hook"++-- | Decoration geometry data type+data DwmGeometry a = DwmGeometry {+      dwmShowForFocused :: !Bool         -- ^ Whether to show decorations on focused windows+    , dwmHorizontalPosition :: !Rational -- ^ Horizontal position of decoration rectangle.+                                         -- 0 means place it at left corner, 1 - place it at+                                         -- right corner, @1%2@ - place it at center.+    , dwmDecoHeight :: !Dimension        -- ^ Height of decoration rectangle+    , dwmDecoWidth :: !Dimension         -- ^ Width of decoration rectangle+  }+  deriving (Show, Read)++instance Default (DwmGeometry a) where+  def = DwmGeometry False 1 20 200++instance DecorationGeometry DwmGeometry Window where+  describeGeometry _ = "DwmStyle"++  pureDecoration (DwmGeometry {..}) _ stack _ (w, Rectangle x y windowWidth _) =+    let width = min windowWidth dwmDecoWidth+        halfWidth = width `div` 2+        minCenterX = x + fi halfWidth+        maxCenterX = x + fi windowWidth - fromIntegral halfWidth+        centerX = round ((1 - dwmHorizontalPosition)*fi minCenterX + dwmHorizontalPosition*fi maxCenterX) :: Position+        decoX = centerX - fi halfWidth+        focusedWindow = W.focus stack+        isFocused = focusedWindow == w+    in  if (not dwmShowForFocused && isFocused) || not (D.isInStack stack w)+          then Nothing+          else Just $ Rectangle decoX y width dwmDecoHeight++  shrinkWindow _ _ windowRect = windowRect++-- | Add a decoration to window layout. Widgets are indicated with text fragments using TextDecoration;+-- decoration placement can be adjusted.+dwmStyleDecoEx :: D.Shrinker shrinker    +             => shrinker               -- ^ Strings shrinker, for example @shrinkText@+             -> DwmGeometry Window+             -> ThemeEx StandardWidget -- ^ Decoration theme (font, colors, widgets, etc)+             -> l Window               -- ^ Layout to be decorated+             -> ModifiedLayout (DecorationEx TextDecoration StandardWidget DwmGeometry shrinker) l Window+dwmStyleDecoEx shrinker geom theme = decorationEx shrinker theme TextDecoration geom++-- | Add a decoration to window layout. Widgets are indicated with text fragments using TextDecoration;+-- decoration placement is similar to DWM.+dwmStyleDeco :: D.Shrinker shrinker    +             => shrinker               -- ^ Strings shrinker, for example @shrinkText@+             -> ThemeEx StandardWidget -- ^ Decoration theme (font, colors, widgets, etc)+             -> l Window               -- ^ Layout to be decorated+             -> ModifiedLayout (DecorationEx TextDecoration StandardWidget DwmGeometry shrinker) l Window+dwmStyleDeco shrinker = dwmStyleDecoEx shrinker def+
+ XMonad/Layout/DecorationEx/Engine.hs view
@@ -0,0 +1,511 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DefaultSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.Engine+-- Description :  Type class and its default implementation for window decoration engines.+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module defines @DecorationEngine@ type class, and default implementation for it.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.Engine (+    -- * DecorationEngine class+    DecorationEngine (..),+    -- * Auxiliary data types+    DrawData (..), +    DecorationLayoutState (..),+    -- * Re-exports from X.L.Decoration+    Shrinker (..), shrinkText,+    -- * Utility functions+    mkDrawData,+    paintDecorationSimple+  ) where++import Control.Monad+import Data.Kind+import Foreign.C.Types (CInt)++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W+import XMonad.Layout.Decoration (Shrinker (..), shrinkWhile, shrinkText)+import XMonad.Layout.DraggingVisualizer (DraggingVisualizerMsg (..))+import XMonad.Layout.DecorationAddons (handleScreenCrossing)+import XMonad.Util.Font+import XMonad.Util.NamedWindows (getName)++import XMonad.Layout.DecorationEx.Common++-- | Auxiliary type for data which are passed from+-- decoration layout modifier to decoration engine.+data DrawData engine widget = DrawData {+    ddEngineState :: !(DecorationEngineState engine)     -- ^ Decoration engine state+  , ddStyle :: !(Style (Theme engine widget))  -- ^ Graphics style of the decoration. This defines colors, fonts etc+                                                        -- which are to be used for this particular window in it's current state.+  , ddOrigWindow :: !Window                             -- ^ Original window to be decorated+  , ddWindowTitle :: !String                            -- ^ Original window title (not shrinked yet)+  , ddDecoRect :: !Rectangle                            -- ^ Decoration rectangle+  , ddWidgets :: !(WidgetLayout widget)         -- ^ Widgets to be placed on decoration+  , ddWidgetPlaces :: !(WidgetLayout WidgetPlace)       -- ^ Places where widgets must be shown+  }++-- | State of decoration engine+data DecorationLayoutState engine = DecorationLayoutState {+    dsStyleState :: !(DecorationEngineState engine) -- ^ Engine-specific state+  , dsDecorations :: ![WindowDecoration]            -- ^ Mapping between decoration windows and original windows+  }++-- | Decoration engines type class.+-- Decoration engine is responsible for drawing something inside decoration rectangle.+-- It is also responsible for handling X11 events (such as clicks) which happen+-- within decoration rectangle.+-- Decoration rectangles are defined by DecorationGeometry implementation.+class (Read (engine widget a), Show (engine widget a),+       Eq a,+       DecorationWidget widget,+       HasWidgets (Theme engine) widget,+       ClickHandler (Theme engine) widget,+       ThemeAttributes (Theme engine widget))+    => DecorationEngine engine widget a where++    -- | Type of themes used by decoration engine.+    -- This type must be parameterized over a widget type,+    -- because a theme will contain a list of widgets.+    type Theme engine :: Type -> Type           +                                          +    -- | Type of data used by engine as a context during painting;+    -- for plain X11-based implementation this is Display, Pixmap+    -- and GC.+    type DecorationPaintingContext engine + +    -- | Type of state used by the decoration engine.+    -- This can contain some resources that should be initialized+    -- and released at time, such as X11 fonts.+    type DecorationEngineState engine     ++    -- | Give a name to decoration engine.+    describeEngine :: engine widget a -> String++    -- | Initialize state of the engine.+    initializeState :: engine widget a       -- ^ Decoration engine instance+                    -> geom a                -- ^ Decoration geometry instance+                    -> Theme engine widget   -- ^ Theme to be used+                    -> X (DecorationEngineState engine)++    -- | Release resources held in engine state.+    releaseStateResources :: engine widget a              -- ^ Decoration engine instance+                          -> DecorationEngineState engine -- ^ Engine state+                          -> X ()++    -- | Calculate place which will be occupied by one widget.+    -- NB: X coordinate of the returned rectangle will be ignored, because+    -- the rectangle will be moved to the right or to the left for proper alignment+    -- of widgets.+    calcWidgetPlace :: engine widget a         -- ^ Decoration engine instance+                    -> DrawData engine widget  -- ^ Information about window and decoration+                    -> widget                  -- ^ Widget to be placed+                    -> X WidgetPlace++    -- | Place widgets along the decoration bar.+    placeWidgets :: Shrinker shrinker+                 => engine widget a              -- ^ Decoration engine instance+                 -> Theme engine widget          -- ^ Theme to be used+                 -> shrinker                     -- ^ Strings shrinker+                 -> DecorationEngineState engine -- ^ Current state of the engine+                 -> Rectangle                    -- ^ Decoration rectangle+                 -> Window                       -- ^ Original window to be decorated+                 -> WidgetLayout widget          -- ^ Widgets layout+                 -> X (WidgetLayout WidgetPlace)+    placeWidgets engine theme _ decoStyle decoRect window wlayout = do+        let leftWidgets = wlLeft wlayout+            rightWidgets = wlRight wlayout+            centerWidgets = wlCenter wlayout++        dd <- mkDrawData engine theme decoStyle window decoRect+        let paddedDecoRect = pad (widgetsPadding theme) (ddDecoRect dd)+            paddedDd = dd {ddDecoRect = paddedDecoRect}+        rightRects <- alignRight engine paddedDd rightWidgets+        leftRects <- alignLeft engine paddedDd leftWidgets+        let wantedLeftWidgetsWidth = sum $ map (rect_width . wpRectangle) leftRects+            wantedRightWidgetsWidth = sum $ map (rect_width . wpRectangle) rightRects+            hasShrinkableOnLeft = any isShrinkable leftWidgets+            hasShrinkableOnRight = any isShrinkable rightWidgets+            decoWidth = rect_width decoRect+            (leftWidgetsWidth, rightWidgetsWidth)+              | hasShrinkableOnLeft = +                  (min (decoWidth - wantedRightWidgetsWidth) wantedLeftWidgetsWidth,+                      wantedRightWidgetsWidth)+              | hasShrinkableOnRight =+                  (wantedLeftWidgetsWidth,+                      min (decoWidth - wantedLeftWidgetsWidth) wantedRightWidgetsWidth)+              | otherwise = (wantedLeftWidgetsWidth, wantedRightWidgetsWidth)+            ddForCenter = paddedDd {ddDecoRect = padCenter leftWidgetsWidth rightWidgetsWidth paddedDecoRect}+        centerRects <- alignCenter engine ddForCenter centerWidgets+        let shrinkedLeftRects = packLeft (rect_x paddedDecoRect) $ shrinkPlaces leftWidgetsWidth $ zip leftRects (map isShrinkable leftWidgets)+            shrinkedRightRects = packRight (rect_width paddedDecoRect) $ shrinkPlaces rightWidgetsWidth $ zip rightRects (map isShrinkable rightWidgets)+        return $ WidgetLayout shrinkedLeftRects centerRects shrinkedRightRects+      where+        shrinkPlaces targetWidth ps =+          let nShrinkable = length (filter snd ps)+              totalUnshrinkedWidth = sum $ map (rect_width . wpRectangle . fst) $ filter (not . snd) ps+              shrinkedWidth = (targetWidth - totalUnshrinkedWidth) `div` fi nShrinkable++              resetX place = place {wpRectangle = (wpRectangle place) {rect_x = 0}}++              adjust (place, True) = resetX $ place {wpRectangle = (wpRectangle place) {rect_width = shrinkedWidth}}+              adjust (place, False) = resetX place+          in  map adjust ps++        pad p (Rectangle _ _ w h) =+          Rectangle (fi (bxLeft p)) (fi (bxTop p))+                    (w - bxLeft p - bxRight p)+                    (h - bxTop p - bxBottom p)+      +        padCenter left right (Rectangle x y w h) =+          Rectangle (x + fi left) y+                    (w - left - right) h++    -- | Shrink window title so that it would fit in decoration.+    getShrinkedWindowName :: Shrinker shrinker+                          => engine widget a              -- ^ Decoration engine instance+                          -> shrinker                     -- ^ Strings shrinker+                          -> DecorationEngineState engine -- ^ State of decoration engine+                          -> String                       -- ^ Original window title+                          -> Dimension                    -- ^ Width of rectangle in which the title should fit+                          -> Dimension                    -- ^ Height of rectangle in which the title should fit+                          -> X String++    default getShrinkedWindowName :: (Shrinker shrinker, DecorationEngineState engine ~ XMonadFont)+                                  => engine widget a -> shrinker -> DecorationEngineState engine -> String -> Dimension -> Dimension -> X String+    getShrinkedWindowName _ shrinker font name wh _ = do+      let s = shrinkIt shrinker+      dpy <- asks display+      shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy font n+                              return $ size > fromIntegral wh) name++    -- | Mask of X11 events on which the decoration engine should do something.+    -- @exposureMask@ should be included here so that decoration engine could+    -- repaint decorations when they are shown on screen.+    -- @buttonPressMask@ should be included so that decoration engine could+    -- response to mouse clicks.+    -- Other events can be added to custom implementations of DecorationEngine.+    decorationXEventMask :: engine widget a -> EventMask+    decorationXEventMask _ = exposureMask .|. buttonPressMask++    -- | List of X11 window property atoms of original (client) windows,+    -- change of which should trigger repainting of decoration.+    -- For example, if @WM_NAME@ changes it means that we have to redraw+    -- window title.+    propsToRepaintDecoration :: engine widget a -> X [Atom]+    propsToRepaintDecoration _ =+      mapM getAtom ["WM_NAME", "_NET_WM_NAME", "WM_STATE", "WM_HINTS"]++    -- | Generic event handler, which recieves X11 events on decoration+    -- window.+    -- Default implementation handles mouse clicks and drags.+    decorationEventHookEx :: Shrinker shrinker+                          => engine widget a+                          -> Theme engine widget+                          -> DecorationLayoutState engine+                          -> shrinker+                          -> Event+                          -> X ()+    decorationEventHookEx = handleMouseFocusDrag++    -- | Event handler for clicks on decoration window.+    -- This is called from default implementation of "decorationEventHookEx".+    -- This should return True, if the click was handled (something happened+    -- because of that click). If this returns False, the click can be considered+    -- as a beginning of mouse drag.+    handleDecorationClick :: engine widget a      -- ^ Decoration engine instance+                          -> Theme engine widget  -- ^ Decoration theme+                          -> Rectangle            -- ^ Decoration rectangle+                          -> [Rectangle]          -- ^ Rectangles where widgets are placed+                          -> Window               -- ^ Original (client) window+                          -> Int                  -- ^ Mouse click X coordinate+                          -> Int                  -- ^ Mouse click Y coordinate+                          -> Int                  -- ^ Mouse button number+                          -> X Bool+    handleDecorationClick = decorationHandler++    -- | Event handler which is called during mouse dragging.+    -- This is called from default implementation of "decorationEventHookEx".+    decorationWhileDraggingHook :: engine widget a      -- ^ Decoration engine instance+                                -> CInt                 -- ^ Event X coordinate+                                -> CInt                 -- ^ Event Y coordinate+                                -> (Window, Rectangle)  -- ^ Original window and it's rectangle+                                -> Position             -- ^ X coordinate of new pointer position during dragging+                                -> Position             -- ^ Y coordinate of new pointer position during dragging+                                -> X ()+    decorationWhileDraggingHook _ = handleDraggingInProgress++    -- | This hoook is called after a window has been dragged using the decoration.+    -- This is called from default implementation of "decorationEventHookEx".+    decorationAfterDraggingHook :: engine widget a     -- ^ Decoration engine instance+                                -> (Window, Rectangle) -- ^ Original window and its rectangle+                                -> Window              -- ^ Decoration window+                                -> X ()+    decorationAfterDraggingHook _ds (w, _r) decoWin = do+      focus w+      hasCrossed <- handleScreenCrossing w decoWin+      unless hasCrossed $ do+        sendMessage DraggingStopped+        performWindowSwitching w++    -- | Draw everything required on the decoration window.+    -- This method should draw background (flat or gradient or whatever),+    -- borders, and call @paintWidget@ method to draw window widgets+    -- (buttons and title).+    paintDecoration :: Shrinker shrinker+                    => engine widget a         -- ^ Decoration engine instance+                    -> a                       -- ^ Decoration window+                    -> Dimension               -- ^ Decoration window width+                    -> Dimension               -- ^ Decoration window height+                    -> shrinker                -- ^ Strings shrinker instance+                    -> DrawData engine widget  -- ^ Details about what to draw+                    -> Bool                    -- ^ True when this method is called during Expose event+                    -> X ()++    -- | Paint one widget on the decoration window.+    paintWidget :: Shrinker shrinker+                => engine widget a                  -- ^ Decoration engine instance+                -> DecorationPaintingContext engine -- ^ Decoration painting context+                -> WidgetPlace                      -- ^ Place (rectangle) where the widget should be drawn+                -> shrinker                         -- ^ Strings shrinker instance+                -> DrawData engine widget           -- ^ Details about window decoration+                -> widget                           -- ^ Widget to be drawn+                -> Bool                             -- ^ True when this method is called during Expose event+                -> X ()++handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()+handleDraggingInProgress ex ey (mainw, r) x y = do+    let rect = Rectangle (x - (fi ex - rect_x r))+                         (y - (fi ey - rect_y r))+                         (rect_width  r)+                         (rect_height r)+    sendMessage $ DraggingWindow mainw rect++performWindowSwitching :: Window -> X ()+performWindowSwitching win =+    withDisplay $ \d -> do+       root <- asks theRoot+       (_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root+       ws <- gets windowset+       let allWindows = W.index ws+       -- do a little double check to be sure+       when ((win `elem` allWindows) && (selWin `elem` allWindows)) $ do+                let allWindowsSwitched = map (switchEntries win selWin) allWindows+                let (ls, notEmpty -> t :| rs) = break (win ==) allWindowsSwitched+                let newStack = W.Stack t (reverse ls) rs+                windows $ W.modify' $ const newStack+    where+        switchEntries a b x+            | x == a    = b+            | x == b    = a+            | otherwise = x++ignoreX :: WidgetPlace -> WidgetPlace+ignoreX place = place {wpRectangle = (wpRectangle place) {rect_x = 0}}++alignLeft :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]+alignLeft engine dd widgets = do+    places <- mapM (calcWidgetPlace engine dd) widgets+    return $ packLeft (rect_x $ ddDecoRect dd) $ map ignoreX places++packLeft :: Position -> [WidgetPlace] -> [WidgetPlace]+packLeft _ [] = []+packLeft x0 (place : places) =+  let rect = wpRectangle place+      x' = x0 + rect_x rect+      rect' = rect {rect_x = x'}+      place' = place {wpRectangle = rect'}+  in  place' : packLeft (x' + fi (rect_width rect)) places++alignRight :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]+alignRight engine dd widgets = do+    places <- mapM (calcWidgetPlace engine dd) widgets+    return $ packRight (rect_width $ ddDecoRect dd) $ map ignoreX places++packRight :: Dimension -> [WidgetPlace] -> [WidgetPlace]+packRight x0 places = reverse $ go x0 places+  where+    go _ [] = []+    go x (place : rest) = +      let rect = wpRectangle place+          x' = x - rect_width rect+          rect' = rect {rect_x = fi x'}+          place' = place {wpRectangle = rect'}+      in  place' : go x' rest++alignCenter :: forall engine widget a. DecorationEngine engine widget a => engine widget a -> DrawData engine widget -> [widget] -> X [WidgetPlace]+alignCenter engine dd widgets = do+    places <- alignLeft engine dd widgets+    let totalWidth = sum $ map (rect_width . wpRectangle) places+        availableWidth = fi (rect_width (ddDecoRect dd)) :: Position+        x0 = max 0 $ (availableWidth - fi totalWidth) `div` 2+        places' = map (shift x0) places+    return $ pack (fi availableWidth) places'+  where+    shift x0 place =+      let rect = wpRectangle place+          rect' = rect {rect_x = rect_x rect + fi x0}+      in  place {wpRectangle = rect'}+    +    pack _ [] = []+    pack available (place : places) =+      let rect = wpRectangle place+          placeWidth = rect_width rect+          widthToUse = min available placeWidth+          remaining = available - widthToUse+          rect' = rect {rect_width = widthToUse}+          place' = place {wpRectangle = rect'}+      in  place' : pack remaining places++-- | Build an instance of 'DrawData' type.+mkDrawData :: (DecorationEngine engine widget a, ThemeAttributes (Theme engine widget), HasWidgets (Theme engine) widget)+           => engine widget a+           -> Theme engine widget            -- ^ Decoration theme+           -> DecorationEngineState engine   -- ^ State of decoration engine+           -> Window                         -- ^ Original window (to be decorated)+           -> Rectangle                      -- ^ Decoration rectangle+           -> X (DrawData engine widget)+mkDrawData _ theme decoState origWindow decoRect = do+    -- xmonad-contrib #809+    -- qutebrowser will happily shovel a 389K multiline string into @_NET_WM_NAME@+    -- and the 'defaultShrinker' (a) doesn't handle multiline strings well (b) is+    -- quadratic due to using 'init'+    name  <- fmap (take 2048 . takeWhile (/= '\n') . show) (getName origWindow)+    style <- selectWindowStyle theme origWindow+    return $ DrawData {+                   ddEngineState = decoState,+                   ddStyle = style,+                   ddOrigWindow = origWindow,+                   ddWindowTitle = name,+                   ddDecoRect = decoRect,+                   ddWidgets = themeWidgets theme,+                   ddWidgetPlaces = WidgetLayout [] [] []+                  }++-- | Mouse focus and mouse drag are handled by the same function, this+-- way we can start dragging unfocused windows too.+handleMouseFocusDrag :: (DecorationEngine engine widget a, Shrinker shrinker) => engine widget a -> Theme engine widget -> DecorationLayoutState engine -> shrinker -> Event -> X ()+handleMouseFocusDrag ds theme (DecorationLayoutState {dsDecorations}) _ (ButtonEvent {ev_window, ev_x_root, ev_y_root, ev_event_type, ev_button})+    | ev_event_type == buttonPress+    , Just (WindowDecoration {..}) <- findDecoDataByDecoWindow ev_window dsDecorations = do+        let decoRect@(Rectangle dx dy _ _) = fromJust wdDecoRect+            x = fi $ ev_x_root - fi dx+            y = fi $ ev_y_root - fi dy+            button = fi ev_button+        dealtWith <- handleDecorationClick ds theme decoRect (map wpRectangle wdWidgets) wdOrigWindow x y button+        unless dealtWith $ when (isDraggingEnabled theme button) $+            mouseDrag (\dragX dragY -> focus wdOrigWindow >> decorationWhileDraggingHook ds ev_x_root ev_y_root (wdOrigWindow, wdOrigWinRect) dragX dragY)+                      (decorationAfterDraggingHook ds (wdOrigWindow, wdOrigWinRect) ev_window)+handleMouseFocusDrag _ _ _ _ _ = return ()++-- | Given a window and the state, if a matching decoration is in the+-- state return it with its ('Maybe') 'Rectangle'.+findDecoDataByDecoWindow :: Window -> [WindowDecoration] -> Maybe WindowDecoration+findDecoDataByDecoWindow decoWin = find (\dd -> wdDecoWindow dd == Just decoWin)++decorationHandler :: forall engine widget a.+                     (DecorationEngine engine widget a,+                      ClickHandler (Theme engine) widget)+                  => engine widget a+                  -> Theme engine widget+                  -> Rectangle+                  -> [Rectangle]+                  -> Window+                  -> Int+                  -> Int+                  -> Int+                  -> X Bool+decorationHandler _ theme _ widgetPlaces window x y button = do+    widgetDone <- go $ zip (widgetLayout $ themeWidgets theme) widgetPlaces+    if widgetDone+      then return True+      else case onDecorationClick theme button of+             Just cmd -> do+               executeWindowCommand cmd window+             Nothing -> return False+  where+    go :: [(widget, Rectangle)] -> X Bool+    go [] = return False+    go ((w, rect) : rest) = do+      if pointWithin (fi x) (fi y) rect+        then do+          executeWindowCommand (widgetCommand w button) window+        else go rest++-- | Simple implementation of @paintDecoration@ method.+-- This is used by @TextEngine@ and can be re-used by other decoration+-- engines.+paintDecorationSimple :: forall engine shrinker widget.+                          (DecorationEngine engine widget Window,+                           DecorationPaintingContext engine ~ XPaintingContext,+                           Shrinker shrinker,+                           Style (Theme engine widget) ~ SimpleStyle)+                       => engine widget Window+                       -> Window+                       -> Dimension+                       -> Dimension+                       -> shrinker+                       -> DrawData engine widget+                       -> Bool+                       -> X ()+paintDecorationSimple deco win windowWidth windowHeight shrinker dd isExpose = do+    dpy <- asks display+    let widgets = widgetLayout $ ddWidgets dd+        style = ddStyle dd+    pixmap  <- io $ createPixmap dpy win windowWidth windowHeight (defaultDepthOfScreen $ defaultScreenOfDisplay dpy)+    gc <- io $ createGC dpy pixmap+    -- draw+    io $ setGraphicsExposures dpy gc False+    bgColor <- stringToPixel dpy (sBgColor style)+    -- we start with the border+    let borderWidth = sDecoBorderWidth style+        borderColors = sDecorationBorders style+    when (borderWidth > 0) $ do+      drawLineWith dpy pixmap gc 0 0 windowWidth borderWidth (bxTop borderColors)+      drawLineWith dpy pixmap gc 0 0 borderWidth windowHeight (bxLeft borderColors)+      drawLineWith dpy pixmap gc 0 (fi (windowHeight - borderWidth)) windowWidth borderWidth (bxBottom borderColors)+      drawLineWith dpy pixmap gc (fi (windowWidth - borderWidth)) 0 borderWidth windowHeight (bxRight borderColors)++    -- and now again+    io $ setForeground dpy gc bgColor+    io $ fillRectangle dpy pixmap gc (fi borderWidth) (fi borderWidth) (windowWidth - (borderWidth * 2)) (windowHeight - (borderWidth * 2))++    -- paint strings+    forM_ (zip widgets $ widgetLayout $ ddWidgetPlaces dd) $ \(widget, place) ->+        paintWidget deco (dpy, pixmap, gc) place shrinker dd widget isExpose++    -- debug+    -- black <- stringToPixel dpy "black"+    -- io $ setForeground dpy gc black+    -- forM_ (ddWidgetPlaces dd) $ \(WidgetPlace {wpRectangle = Rectangle x y w h}) ->+    --   io $ drawRectangle dpy pixmap gc x y w h++    -- copy the pixmap over the window+    io $ copyArea      dpy pixmap win gc 0 0 windowWidth windowHeight 0 0+    -- free the pixmap and GC+    io $ freePixmap    dpy pixmap+    io $ freeGC        dpy gc+  where+    drawLineWith dpy pixmap gc x y w h colorName = do+      color <- stringToPixel dpy colorName+      io $ setForeground dpy gc color+      io $ fillRectangle dpy pixmap gc x y w h+
+ XMonad/Layout/DecorationEx/Geometry.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.Geometry+-- Description :  Type class which is responsible for defining the placement+--                of window decorations+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module defines @DecorationGeometry@ type class, and default implementation for it.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.Geometry (+    DecorationGeometry (..),+    DefaultGeometry (..)+  ) where++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W+import qualified XMonad.Layout.Decoration as D++-- | Decoration geometry class.+-- Decoration geometry is responsible for placement of window decorations: whether+-- they should be on the top of the window or on the bottom, should they go for +-- full window width or only be of certain width, etc.+-- This does not know what will be drawn inside decorations.+class (Read (geom a), Show (geom a),+       Eq a)+    => DecorationGeometry geom a where++    -- | Give a name to decoration geometry implementation.+    describeGeometry :: geom a -> String++    -- | Reduce original window size to make space for decoration, if necessary.+    shrinkWindow :: geom a -> Rectangle -> Rectangle -> Rectangle+    shrinkWindow _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh)++    -- | The pure version of the main method, 'decorate'.+    -- The method should return a rectangle where to place window decoration,+    -- or 'Nothing' if this window is not to be decorated.+    pureDecoration :: geom a          -- ^ Decoration geometry instance+                   -> Rectangle       -- ^ Screen rectangle+                   -> W.Stack a       -- ^ Current stack of windows being displayed+                   -> [(a,Rectangle)] -- ^ Set of all windows with their corresponding rectangle+                   -> (a,Rectangle)   -- ^ Window being decorated and its rectangle+                   -> Maybe Rectangle++    -- | The method should return a rectangle where to place window decoration,+    -- or 'Nothing' if this window is not to be decorated.+    decorateWindow :: geom a           -- ^ Decoration geometry instance+                   -> Rectangle        -- ^ Screen rectangle+                   -> W.Stack a        -- ^ Current stack of windows being displayed+                   -> [(a, Rectangle)] -- ^ Set of all windows with their corresponding rectangle+                   -> (a, Rectangle)   -- ^ Window being decorated and its rectangle+                   -> X (Maybe Rectangle)+    decorateWindow geom r s wrs wr = return $ pureDecoration geom r s wrs wr++-- | Data type for default implementation of 'DecorationGeometry'.+-- This defines simple decorations: a horizontal bar at the top of each window,+-- running for full width of the window.+newtype DefaultGeometry a = DefaultGeometry {+    gDecorationHeight :: Dimension+  }+  deriving (Read, Show)++instance Eq a => DecorationGeometry DefaultGeometry a where+  describeGeometry _ = "Default"++  pureDecoration (DefaultGeometry {..}) _ s _ (w, Rectangle x y windowWidth windowHeight) =+      if D.isInStack s w && (gDecorationHeight < windowHeight)+        then Just $ Rectangle x y windowWidth gDecorationHeight+        else Nothing++instance Default (DefaultGeometry a) where+  def = DefaultGeometry 20+
+ XMonad/Layout/DecorationEx/LayoutModifier.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.LayoutModifier+-- Description :  Layout modifier which adds decorations to windows.+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- Layout modifier, which is responsible for creation of decoration rectangles+-- (windows), updating and removing them when needed. It is parameterized by+-- @DecorationGeometry@, which says where decorations should be placed, and by+-- @DecorationEngine@, which says how decorations should look.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.LayoutModifier (+    -- * Usage+    --+    -- $usage+    decorationEx,+    DecorationEx+  ) where++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W+import XMonad.Layout.LayoutModifier+import XMonad.Layout.WindowArranger (diff, listFromList)+import XMonad.Util.Invisible+import XMonad.Util.XUtils hiding (paintTextAndIcons)++import XMonad.Layout.DecorationEx.Common+import XMonad.Layout.DecorationEx.Engine+import XMonad.Layout.DecorationEx.Geometry++-- $usage+--+-- This module exports @decorationEx@ function, which is a generic function for+-- adding decorations to your layouts. It can be used to use different+-- decoration geometries and engines in any combination.+-- For most used combinations, there are convenience functions in+-- "XMonad.Layout.DecorationEx.TextEngine", "XMonad.Layout.DecorationEx.TabbedGeometry",+-- and "XMonad.Layout.DecorationEx.DwmGeometry".+--+-- You can use this module with the following in your+-- @xmonad.hs@:+--+-- > import XMonad.Layout.DecorationEx.LayoutModifier+-- Then edit your @layoutHook@ by adding the DwmStyle decoration to+-- your layout:+--+-- > myL = decorationEx shrinkText myTheme myEngine myGeometry (layoutHook def)+-- >         where+-- >           myGeometry = DefaultGeometry -- or another geometry type+-- >           myEngine = TextDecoration    -- or another decoration engine+-- >           myTheme = GenericTheme {...} -- theme type should correspond to selected engine type+-- >+-- > main = xmonad def { layoutHook = myL }+--+-- For more detailed instructions on editing the layoutHook see:+--+-- "XMonad.Doc.Extending#Editing_the_layout_hook"+++-- | The 'DecorationEx' 'LayoutModifier'. This data type is an instance+-- of the 'LayoutModifier' class. This data type will be passed,+-- together with a layout, to the 'ModifiedLayout' type constructor+-- to modify the layout by adding decorations according to a+-- 'DecorationEngine'.+data DecorationEx engine widget geom shrinker a =+    DecorationEx (Invisible Maybe (DecorationLayoutState engine)) shrinker (Theme engine widget) (engine widget a) (geom a)++deriving instance (Show (Theme engine widget), Show shrinker, Show (engine widget a), Show (geom a)) => Show (DecorationEx engine widget geom shrinker a)+deriving instance (Read (Theme engine widget), Read shrinker, Read (engine widget a), Read (geom a)) => Read (DecorationEx engine widget geom shrinker a)++-- | The long 'LayoutModifier' instance for the 'DecorationEx' type.+--+-- In 'redoLayout' we check the state: if there is no state we+-- initialize it.+--+-- The state is @diff@ed against the list of windows produced by the+-- underlying layout: removed windows get deleted and new ones+-- decorated by 'createDecos', which will call 'decorate' to decide if+-- a window must be given a 'Rectangle', in which case a decoration+-- window will be created.+--+-- After that we resync the updated state with the windows' list and+-- then we process the resynced stated (as we do with a new state).+--+-- First we map the decoration windows, we update each decoration to+-- reflect any decorated window's change, and we insert, in the list+-- of windows and rectangles returned by the underlying layout, the+-- decoration for each window. This way xmonad will restack the+-- decorations and their windows accordingly. At the end we remove+-- invisible\/stacked windows.+--+-- Message handling is quite simple: when needed we release the state+-- component of the 'DecorationEx' 'LayoutModifier'. Otherwise we call+-- 'handleEvent', which will call the appropriate 'DecorationEngine'+-- methods to perform its tasks.+instance (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker) => LayoutModifier (DecorationEx engine widget geom shrinker) Window where+    redoLayout (DecorationEx (I (Just decoState)) shrinker theme engine geom) _ Nothing _ = do+        releaseResources engine decoState+        return ([], Just $ DecorationEx (I Nothing) shrinker theme engine geom)+    redoLayout _ _ Nothing _  = return ([], Nothing)++    redoLayout (DecorationEx invState shrinker theme engine geom) screenRect (Just stack) srcPairs+        | I Nothing  <- invState = initState theme engine geom shrinker screenRect stack srcPairs >>= processState+        | I (Just s) <- invState = do+            let decorations  = dsDecorations s+                (d,a) = curry diff (getOrigWindows decorations) srcWindows+                toDel = todel d decorations+                toAdd = toadd a srcPairs+            deleteDecos toDel+            let decosToBeAdded = [WindowDecoration win rect Nothing Nothing [] | (win, rect) <- toAdd]+            newDecorations <- resync (dsStyleState s) (decosToBeAdded ++ del_dwrs d decorations) srcPairs+            processState (s {dsDecorations = newDecorations})++        where+          srcWindows = map fst srcPairs++          getOrigWindows :: [WindowDecoration] -> [Window]+          getOrigWindows = map wdOrigWindow++          del_dwrs :: [Window] -> [WindowDecoration] -> [WindowDecoration]+          del_dwrs = listFromList wdOrigWindow notElem++          findDecoWindow :: Int -> [WindowDecoration] -> Maybe Window+          findDecoWindow i d = wdDecoWindow $ d !! i++          todel :: [Window] -> [WindowDecoration] -> [WindowDecoration]+          todel d = filter (\dd -> wdOrigWindow dd `elem` d)++          toadd :: [Window] -> [(Window, Rectangle)] -> [(Window, Rectangle)]+          toadd a = filter (\p -> fst p `elem` a)++          createDecoWindowIfNeeded :: Maybe Window -> Maybe Rectangle -> X (Maybe Window)+          createDecoWindowIfNeeded mbDecoWindow mbDecoRect =+            case (mbDecoWindow, mbDecoRect) of+              (Nothing, Just decoRect) -> do+                decoWindow <- createDecoWindow engine theme decoRect+                return $ Just decoWindow+              _ -> return mbDecoWindow++          resync :: DecorationEngineState engine -> [WindowDecoration] -> [(Window,Rectangle)] -> X [WindowDecoration]+          resync _ _ [] = return []+          resync decoState dd ((window,rect):xs) =+            case  window `elemIndex` getOrigWindows dd of+              Just i  -> do+                mbDecoRect <- decorateWindow geom screenRect stack srcPairs (window,rect)+                widgetPlaces <- case mbDecoRect of+                                  Nothing -> return $ WidgetLayout [] [] []+                                  Just decoRect -> placeWidgets engine theme shrinker decoState decoRect window (themeWidgets theme)+                mbDecoWindow  <- createDecoWindowIfNeeded (findDecoWindow i dd) mbDecoRect+                let newDd = WindowDecoration window rect mbDecoWindow mbDecoRect (widgetLayout widgetPlaces)+                restDd <- resync decoState dd xs+                return $ newDd : restDd+              Nothing -> resync decoState dd xs++          -- We drop any windows that are *precisely* stacked underneath+          -- another window: these must be intended to be tabbed!+          removeTabbed :: [Rectangle] -> [(Window, Rectangle)] -> [(Window, Rectangle)]+          removeTabbed _ [] = []+          removeTabbed rs ((w,r):xs)+              | r `elem` rs = removeTabbed rs xs+              | otherwise   = (w,r) : removeTabbed (r:rs) xs++          insertDwr :: WindowDecoration -> [(Window, Rectangle)] -> [(Window, Rectangle)]+          insertDwr dd wrs =+            case (wdDecoWindow dd, wdDecoRect dd) of+              (Just decoWindow, Just decoRect) -> (decoWindow, decoRect) : (wdOrigWindow dd, shrinkWindow geom decoRect (wdOrigWinRect dd)) : wrs+              _ -> (wdOrigWindow dd, wdOrigWinRect dd) : wrs++          dwrs_to_wrs :: [WindowDecoration] -> [(Window, Rectangle)]+          dwrs_to_wrs = removeTabbed [] . foldr insertDwr []++          processState :: DecorationLayoutState engine -> X ([(Window, Rectangle)], Maybe (DecorationEx engine widget geom shrinker Window))+          processState st = do+            let decorations = dsDecorations st+            showDecos decorations+            updateDecos engine shrinker theme (dsStyleState st) decorations+            return (dwrs_to_wrs decorations, Just (DecorationEx (I (Just (st {dsDecorations = decorations}))) shrinker theme engine geom))++    handleMess (DecorationEx (I (Just st)) shrinker theme engine geom) m+        | Just Hide <- fromMessage m = do+            hideDecos $ dsDecorations st+            return Nothing+--         | Just (SetTheme nt) <- fromMessage m = do+--             releaseResources engine st+--             let t' = themeEx nt+--             return $ Just $ DecorationEx (I Nothing) shrinker t' engine+        | Just ReleaseResources <- fromMessage m = do+            releaseResources engine st+            return $ Just $ DecorationEx (I Nothing) shrinker theme  engine geom+        | Just e <- fromMessage m = do+            decorationEventHookEx engine theme st shrinker e+            handleEvent engine shrinker theme st e+            return Nothing+    handleMess _ _ = return Nothing++    modifierDescription (DecorationEx _ _ _ engine geom) = describeEngine engine ++ describeGeometry geom++-- | By default 'DecorationEx' handles 'PropertyEvent' and 'ExposeEvent'+-- only.+handleEvent :: (Shrinker shrinker, DecorationEngine engine widget Window) => engine widget Window -> shrinker -> Theme engine widget -> DecorationLayoutState engine -> Event -> X ()+handleEvent engine shrinker theme (DecorationLayoutState {..}) e+    | PropertyEvent {ev_window = w, ev_atom = atom} <- e+    , Just i <- w `elemIndex` map wdOrigWindow dsDecorations = do+        supportedAtoms <- propsToRepaintDecoration engine+        when (atom `elem` supportedAtoms) $ do+          -- io $ putStrLn $ "property event on " ++ show w -- ++ ": " ++ fromMaybe "<?>" atomName+          updateDeco engine shrinker theme dsStyleState (dsDecorations !! i) False+    | ExposeEvent   {ev_window = w} <- e+    , Just i <- w `elemIndex` mapMaybe wdDecoWindow dsDecorations = do+        -- io $ putStrLn $ "expose event on " ++ show w+        updateDeco engine shrinker theme dsStyleState (dsDecorations !! i) True+handleEvent _ _ _ _ _ = return ()++-- | Initialize the 'DecorationState' by initializing the font+-- structure and by creating the needed decorations.+initState :: (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker)+          => Theme engine widget+          -> engine widget Window+          -> geom Window+          -> shrinker+          -> Rectangle+          -> W.Stack Window+          -> [(Window,Rectangle)] -> X (DecorationLayoutState engine)+initState theme engine geom shrinker screenRect stack wrs = do+  styleState <- initializeState engine geom theme+  decorations <- createDecos theme engine geom shrinker styleState screenRect stack wrs wrs+  return $ DecorationLayoutState styleState decorations++-- | Delete windows stored in the state and release the font structure.+releaseResources :: DecorationEngine engine widget Window => engine widget Window -> DecorationLayoutState engine -> X ()+releaseResources engine st = do+  deleteDecos (dsDecorations st)+  releaseStateResources engine (dsStyleState st)++-- | Create the decoration windows of a list of windows and their+-- rectangles, by calling the 'decorate' method of the+-- 'DecorationStyle' received.+createDecos :: (DecorationEngine engine widget Window, DecorationGeometry geom Window, Shrinker shrinker)+            => Theme engine widget+            -> engine widget Window+            -> geom Window+            -> shrinker+            -> DecorationEngineState engine+            -> Rectangle+            -> W.Stack Window+            -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [WindowDecoration]+createDecos theme engine geom shrinker decoState screenRect stack wrs ((w,r):xs) = do+  mbDecoRect <- decorateWindow geom screenRect stack wrs (w,r)+  case mbDecoRect of+    Just decoRect -> do+      decoWindow <- createDecoWindow engine theme decoRect+      widgetPlaces <- placeWidgets engine theme shrinker decoState decoRect w (themeWidgets theme)+      restDd <- createDecos theme engine geom shrinker decoState screenRect stack wrs xs+      let newDd = WindowDecoration w r (Just decoWindow) (Just decoRect) $ widgetLayout widgetPlaces+      return $ newDd : restDd+    Nothing -> do+      restDd <- createDecos theme engine geom shrinker decoState screenRect stack wrs xs+      let newDd = WindowDecoration w r Nothing Nothing []+      return $ newDd : restDd+createDecos _ _ _ _ _ _ _ _ [] = return []++createDecoWindow :: (DecorationEngine engine widget Window) => engine widget Window -> Theme engine widget -> Rectangle -> X Window+createDecoWindow engine theme rect = do+  let mask = Just $ decorationXEventMask engine+  w <- createNewWindow rect mask (defaultBgColor theme) True+  d <- asks display+  io $ setClassHint d w (ClassHint "xmonad-decoration" "xmonad")+  return w++showDecos :: [WindowDecoration] -> X ()+showDecos dd =+  showWindows $ mapMaybe wdDecoWindow $ filter (isJust . wdDecoRect) dd++hideDecos :: [WindowDecoration] -> X ()+hideDecos = hideWindows . mapMaybe wdDecoWindow++deleteDecos :: [WindowDecoration] -> X ()+deleteDecos = deleteWindows . mapMaybe wdDecoWindow++updateDecos :: (Shrinker shrinker, DecorationEngine engine widget Window)+            => engine widget Window -> shrinker -> Theme engine widget -> DecorationEngineState engine -> [WindowDecoration] -> X ()+updateDecos engine shrinker theme decoState = mapM_ (\wd -> updateDeco engine shrinker theme decoState wd False)++-- | Update a decoration window given a shrinker, a theme, the font+-- structure and the needed 'Rectangle's+updateDeco :: (Shrinker shrinker, DecorationEngine engine widget Window) => engine widget Window -> shrinker -> Theme engine widget -> DecorationEngineState engine -> WindowDecoration -> Bool -> X ()+updateDeco engine shrinker theme decoState wd isExpose =+  case (wdDecoWindow wd, wdDecoRect wd) of+    (Just decoWindow, Just decoRect@(Rectangle _ _ wh ht)) -> do+      let origWin = wdOrigWindow wd+      drawData <- mkDrawData engine theme decoState origWin decoRect+      widgetPlaces <- placeWidgets engine theme shrinker decoState decoRect (wdOrigWindow wd) (themeWidgets theme)+      -- io $ print widgetPlaces+      paintDecoration engine decoWindow wh ht shrinker (drawData {ddWidgetPlaces = widgetPlaces}) isExpose+    (Just decoWindow, Nothing) -> hideWindow decoWindow+    _ -> return ()++-- | Apply a DecorationEx modifier to an underlying layout+decorationEx :: (DecorationEngine engine widget a, DecorationGeometry geom a, Shrinker shrinker)+             => shrinker             -- ^ Strings shrinker, for example @shrinkText@+             -> Theme engine widget  -- ^ Decoration theme+             -> engine widget a      -- ^ Decoration engine instance+             -> geom a               -- ^ Decoration geometry instance+             -> l a                  -- ^ Underlying layout to be decorated+             -> ModifiedLayout (DecorationEx engine widget geom shrinker) l a+decorationEx shrinker theme engine geom = ModifiedLayout (DecorationEx (I Nothing) shrinker theme engine geom)+
+ XMonad/Layout/DecorationEx/TabbedGeometry.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.TabbedGeometry+-- Description :  Tab-based window decoration geometry+-- Copyright   :  (c) 2007 Andrea Rossato, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module defines window decoration geometry based on tabs.+-- The tabs can follow horizontally and be placed above or below windows;+-- in such case, tabs can occupy full width of the window or be aligned to+-- left or right. Or tabs can go vertically near left or right side of+-- the window.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.TabbedGeometry (+    textTabbed,+    TabbedGeometry (..),+    HorizontalTabPlacement (..),+    VerticalTabPlacement (..),+    HorizontalTabWidth (..),+    HorizontalTabsAlignment (..),+    SingleTabMode (..)+  ) where ++import XMonad+import qualified XMonad.StackSet as W+import XMonad.Prelude+import XMonad.Layout.Decoration (ModifiedLayout, Shrinker (..))++import XMonad.Layout.DecorationEx.LayoutModifier+import XMonad.Layout.DecorationEx.Common+import XMonad.Layout.DecorationEx.Geometry+import XMonad.Layout.DecorationEx.Widgets+import XMonad.Layout.DecorationEx.TextEngine++-- | Placement of tabs when they go horizontally:+-- should they be placed above or below the window.+data HorizontalTabPlacement = Top | Bottom+  deriving (Eq, Read, Show)++-- | Placement of tabs when they go vertically:+-- should they appear at left or at right side of the window.+data VerticalTabPlacement = TabsAtLeft | TabsAtRight+  deriving (Eq, Read, Show)++-- | Width of tabs when they go horizontally.+data HorizontalTabWidth =+      AutoWidth             -- ^ Define the width automatically by evenly dividing windows' width+    | FixedWidth !Dimension -- ^ Use fixed width of the tab+  deriving (Eq, Read, Show)++-- | Alignment of tabs when they go horizontally.+data HorizontalTabsAlignment = AlignTabsLeft | AlignTabsCenter | AlignTabsRight+  deriving (Eq, Read, Show)++-- | What to do if there is only one tab.+data SingleTabMode = ShowTab | HideTab+  deriving (Eq, Read, Show)++data TabbedGeometry a =+      HorizontalTabs {+          showIfSingleWindow :: !SingleTabMode      -- ^ What to do if there is only one tab+        , hTabPlacement :: !HorizontalTabPlacement  -- ^ Where to place horizontal tabs+        , hTabAlignment :: !HorizontalTabsAlignment -- ^ How to align horizontal tabs (makes sense with fixed width of tabs).+        , hTabWidth :: !HorizontalTabWidth          -- ^ Width of horizontal tabs+        , hTabHeight :: !Dimension                  -- ^ Height of horizontal tabs+      }+    | VerticalTabs {+          showIfSingleWindow :: !SingleTabMode      -- ^ What to do if there is only one tab+        , vTabPlacement :: !VerticalTabPlacement    -- ^ Where to place vertical tabs+        , vTabWidth :: !Dimension                   -- ^ Width of vertical tabs+        , vTabHeight :: !Dimension                  -- ^ Height of vertical tabs+      }+  deriving (Show, Read)++instance Default (TabbedGeometry a) where+  def = HorizontalTabs ShowTab Top AlignTabsLeft AutoWidth 20 ++instance DecorationGeometry TabbedGeometry Window where++  describeGeometry _ = "Tabbed"++  pureDecoration tabs _ stack wrs (window, windowRect) =+    let Rectangle windowX windowY windowWidth windowHeight = windowRect+        -- windows that are mapped onto the same rectangle as current one are considered to+        -- be in one tabs group+        tabbedWindows = filter (`elem` map fst (filter ((==windowRect) . snd) wrs)) (W.integrate stack)+        mbWindowIndex = window `elemIndex` tabbedWindows+        numWindows = length tabbedWindows+    in  if numWindows > 1 || (showIfSingleWindow tabs == ShowTab && numWindows > 0)+          then+            case tabs of+              HorizontalTabs {..} ->+                  Just $ case hTabPlacement of+                            Top    -> Rectangle decoX windowY effectiveTabWidth hTabHeight+                            Bottom -> Rectangle decoX (windowY + fi (windowHeight - hTabHeight)) effectiveTabWidth hTabHeight+                where+                  decoX = maybe windowX tabX mbWindowIndex++                  -- If there are too many windows or configured tab width+                  -- is too big, then we have to switch to 'auto' mode.+                  hTabWidth' =+                    case hTabWidth of+                      AutoWidth -> AutoWidth+                      FixedWidth tabWidth+                        | tabWidth * fi numWindows > windowWidth -> AutoWidth+                        | otherwise -> FixedWidth tabWidth++                  effectiveTabWidth =+                    case hTabWidth' of+                      AutoWidth -> fi $ maybe windowX (\i -> tabX (i+1) - tabX i) mbWindowIndex+                      FixedWidth tabWidth -> tabWidth++                  allTabsWidth =+                    case hTabWidth' of+                      AutoWidth -> fi windowWidth+                      FixedWidth _ -> fi $ min windowWidth $ effectiveTabWidth * max 1 (fi numWindows)++                  tabsStartX =+                    case hTabAlignment of+                      AlignTabsLeft -> windowX+                      AlignTabsRight -> windowX + fi windowWidth - allTabsWidth+                      AlignTabsCenter -> windowX + (fi windowWidth - allTabsWidth) `div` 2++                  -- X coordinate of i'th window in horizontal tabs layout+                  tabX i = tabsStartX ++                        case hTabWidth' of+                          AutoWidth -> fi ((windowWidth * fi i) `div` max 1 (fi numWindows))+                          FixedWidth _ -> fi effectiveTabWidth * fi i++              VerticalTabs {..} ->+                  Just $ case vTabPlacement of+                            TabsAtLeft  -> fixHeightTab windowX+                            TabsAtRight -> fixHeightTab (windowX + fi (windowWidth - vTabWidth))+                where+                  fixHeightLoc i = windowY + fi vTabHeight * fi i+                  fixHeightTab x = Rectangle x+                        (maybe windowY fixHeightLoc mbWindowIndex) vTabWidth vTabHeight+          else Nothing++  shrinkWindow tabs (Rectangle _ _ dw dh) (Rectangle x y w h) =+    case tabs of+      HorizontalTabs {..} ->+        case hTabPlacement of+            Top -> Rectangle x (y + fi dh) w (h - dh)+            Bottom -> Rectangle x y w (h - dh)+      VerticalTabs {..} ->+        case vTabPlacement of+            TabsAtLeft  -> Rectangle (x + fi dw) y (w - dw) h+            TabsAtRight -> Rectangle x y (w - dw) h++-- | Add tabbed decorations (with default settings) with text-based widgets to a layout.+textTabbed :: (Shrinker shrinker)+           => shrinker               -- ^ Strings shrinker, e.g. @shrinkText@+           -> ThemeEx StandardWidget -- ^ Decoration theme+           -> l Window               -- ^ Layout to be decorated+           -> ModifiedLayout (DecorationEx TextDecoration StandardWidget TabbedGeometry shrinker) l Window+textTabbed shrinker theme = decorationEx shrinker theme TextDecoration def+
+ XMonad/Layout/DecorationEx/TextEngine.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.TextEngine+-- Description :  Text-based window decoration engine+-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- Window decoration engine, that uses text fragments (like @"[X]"@) to indicate+-- widgets (window buttons).+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.TextEngine (+    textDecoration,+    TextDecoration (..)+  ) where ++import XMonad+import XMonad.Prelude+import XMonad.Layout.LayoutModifier+import XMonad.Util.Font++import XMonad.Layout.DecorationEx.LayoutModifier+import XMonad.Layout.DecorationEx.Common+import XMonad.Layout.DecorationEx.Engine+import XMonad.Layout.DecorationEx.Geometry+import XMonad.Layout.DecorationEx.Widgets++-- | Decoration engine data type+data TextDecoration widget a = TextDecoration+  deriving (Show, Read)++instance (TextWidget widget, ClickHandler (GenericTheme SimpleStyle) widget)+  => DecorationEngine TextDecoration widget Window where+  type Theme TextDecoration = GenericTheme SimpleStyle+  type DecorationPaintingContext TextDecoration = XPaintingContext+  type DecorationEngineState TextDecoration = XMonadFont++  describeEngine _ = "TextDecoration"++  calcWidgetPlace = calcTextWidgetPlace++  paintWidget = paintTextWidget++  paintDecoration = paintDecorationSimple++  initializeState _ _ theme = initXMF (themeFontName theme)+  releaseStateResources _ = releaseXMF++-- | Implementation of @paintWidget@ for decoration engines based on @TextDecoration@.+paintTextWidget :: (TextWidget widget,+                    Style (Theme engine widget) ~ SimpleStyle,+                    DecorationPaintingContext engine ~ XPaintingContext,+                    DecorationEngineState engine ~ XMonadFont,+                    Shrinker shrinker,+                    DecorationEngine engine widget Window)+                => engine widget Window+                -> DecorationPaintingContext engine+                -> WidgetPlace+                -> shrinker+                -> DrawData engine widget+                -> widget+                -> Bool+                -> X ()+paintTextWidget engine (dpy, pixmap, gc) place shrinker dd widget _ = do+    let style = ddStyle dd+        rect = wpRectangle place+        x = rect_x rect+        y = wpTextYPosition place+    str <- widgetString dd widget+    str' <- if isShrinkable widget+              then getShrinkedWindowName engine shrinker (ddEngineState dd) str (rect_width rect) (rect_height rect)+              else return str+    printStringXMF dpy pixmap (ddEngineState dd) gc (sTextColor style) (sTextBgColor style) x y str'++-- | Implementation of @calcWidgetPlace@ for decoration engines based on @TextDecoration@.+calcTextWidgetPlace :: (TextWidget widget,+                        DecorationEngineState engine ~ XMonadFont,+                        DecorationEngine engine widget Window)+                    => engine widget Window+                    -> DrawData engine widget+                    -> widget+                    -> X WidgetPlace+calcTextWidgetPlace _ dd widget = do+    str <- widgetString dd widget+    let h = rect_height (ddDecoRect dd)+        font = ddEngineState dd+    withDisplay $ \dpy -> do+      width <- fi <$> textWidthXMF dpy (ddEngineState dd) str+      (a, d) <- textExtentsXMF font str+      let height = a + d+          y = fi $ (h - fi height) `div` 2+          y0 = y + fi a+          rect = Rectangle 0 y width (fi height)+      return $ WidgetPlace y0 rect++-- | Add decoration to existing layout. Widgets are indicated by text fragments, like @"[+]"@.+-- Geometry is simple: a horizontal panel at the top of each window, going for the full width+-- of the window.+textDecoration :: (Shrinker shrinker)+               => shrinker                -- ^ String shrinker, for example @shrinkText@+               -> Theme TextDecoration StandardWidget  -- ^ Decoration theme (font, colors, widgets, etc)+               -> l Window                -- ^ Layout to be decorated+             -> ModifiedLayout (DecorationEx TextDecoration StandardWidget DefaultGeometry shrinker) l Window+textDecoration shrinker theme = decorationEx shrinker theme TextDecoration def+
+ XMonad/Layout/DecorationEx/Widgets.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.DecorationEx.Widgets+-- Description :  Definitions for decoration widgets (window buttons etc)+-- Copyright   :  2023 Ilya Portnov+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  portnov84@rambler.ru+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module contains data types and utilities to deal with decoration+-- widgets. A widget is anything that is displayed on window decoration,+-- and, optionally, can react on clicks. Examples of widgets are usual+-- window buttons (minimize, maximize, close), window icon and window title.+-----------------------------------------------------------------------------++module XMonad.Layout.DecorationEx.Widgets (+    -- * Data types+    StandardCommand (..),+    TextWidget (..),+    GenericWidget (..),+    StandardWidget,+    -- * Utility functions+    isWidgetChecked,+    -- * Presets for standard widgets+    titleW, toggleStickyW, minimizeW,+    maximizeW, closeW, dwmpromoteW,+    moveToNextGroupW,moveToPrevGroupW+  ) where ++import XMonad+import qualified XMonad.StackSet as W+import XMonad.Actions.DwmPromote+import qualified XMonad.Actions.CopyWindow as CW+import qualified XMonad.Layout.Groups.Examples as Ex+import XMonad.Layout.Maximize+import XMonad.Actions.Minimize+import XMonad.Actions.WindowMenu++import XMonad.Layout.DecorationEx.Common+import XMonad.Layout.DecorationEx.Engine++-- | Standard window commands.+--+-- One can extend this list by simply doing+--+-- > data MyWindowCommand =+-- >     Std StandardCommand+-- >   | SomeFancyCommand+--+-- > instance WindowCommand MyWindowCommand where ...+--+-- > type MyWidget = GenericWidget MyWindowCommand+--+data StandardCommand =+      FocusWindow      -- ^ Focus the window+    | FocusUp          -- ^ Move focus to previous window+    | FocusDown        -- ^ Move focus to following window+    | MoveToNextGroup  -- ^ Move the window to the next group (see "XMonad.Layout.Groups")+    | MoveToPrevGroup  -- ^ Move the window to the previous group+    | DwmPromote       -- ^ Execute @dwmpromote@ (see "XMonad.Actions.DwmPromote")+    | ToggleSticky     -- ^ Make window sticky or unstick it (see "XMonad.Actions.CopyWindow")+    | ToggleMaximize   -- ^ Maximize or restore window (see "XMonad.Layout.Maximize")+    | Minimize         -- ^ Minimize window (see "XMonad.Actions.Minimize")+    | CloseWindow      -- ^ Close the window+    | GridWindowMenu   -- ^ Show window menu via "XMonad.Actions.GridSelect" (see "XMonad.Actions.WindowMenu")+  deriving (Eq, Show, Read)++instance Default StandardCommand where+  def = FocusWindow++instance WindowCommand StandardCommand where+  executeWindowCommand FocusWindow w = do+    focus w+    return False+  executeWindowCommand FocusUp _ = do+    windows W.focusUp+    withFocused maximizeWindowAndFocus+    return True+  executeWindowCommand FocusDown _ = do+    windows W.focusDown+    withFocused maximizeWindowAndFocus+    return True+  executeWindowCommand MoveToNextGroup w = do+    focus w+    Ex.moveToGroupDown False+    return True+  executeWindowCommand MoveToPrevGroup w = do+    focus w+    Ex.moveToGroupUp False+    return True+  executeWindowCommand CloseWindow w = do+    killWindow w+    return True+  executeWindowCommand DwmPromote w = do+    focus w+    dwmpromote+    return True+  executeWindowCommand ToggleSticky w = do+    focus w+    copies <- CW.wsContainingCopies+    if null copies+      then windows CW.copyToAll+      else CW.killAllOtherCopies+    return True+  executeWindowCommand ToggleMaximize w = do+    sendMessage $ maximizeRestore w+    focus w+    return True+  executeWindowCommand Minimize w = do+    minimizeWindow w+    return True+  executeWindowCommand GridWindowMenu w = do+    focus w+    windowMenu+    return True++  isCommandChecked FocusWindow _ = return False+  isCommandChecked DwmPromote w = do+      withWindowSet $ \ws -> return $ Just w == master ws+    where+      master ws =+        case W.integrate' $ W.stack $ W.workspace $ W.current ws of+          [] -> Nothing+          (x:_) -> Just x+  isCommandChecked ToggleSticky w = do+    ws <- gets windowset+    let copies = CW.copiesOfOn (Just w) (CW.taggedWindows $ W.hidden ws)+    return $ not $ null copies+  isCommandChecked _ _ = return False++-- | Generic data type for decoration widgets.+data GenericWidget cmd =+      TitleWidget                      -- ^ Window title (just text label)+    | WindowIcon { swCommand :: !cmd } -- ^ Window icon with some associated command+    -- | Other widgets+    | GenericWidget {+        swCheckedText :: !String       -- ^ Text for checked widget state+      , swUncheckedText :: !String     -- ^ Text for unchecked widget state+      , swCommand :: !cmd              -- ^ Window command+    }+    deriving (Show, Read)++-- | Generic widget type specialized for 'StandardCommand'+type StandardWidget = GenericWidget StandardCommand++instance (Default cmd, Read cmd, Show cmd, WindowCommand cmd) => DecorationWidget (GenericWidget cmd) where++  type WidgetCommand (GenericWidget cmd) = cmd++  widgetCommand TitleWidget _ = def+  widgetCommand w 1 = swCommand w+  widgetCommand _ _ = def++  isShrinkable TitleWidget = True+  isShrinkable _ = False++-- | Check if the widget should be displayed in `checked' state.+isWidgetChecked :: DecorationWidget widget => widget -> Window -> X Bool+isWidgetChecked wdt = isCommandChecked (widgetCommand wdt 1)++-- | Type class for widgets that can be displayed as+-- text fragments by 'TextDecoration' engine.+class DecorationWidget widget => TextWidget widget where+  widgetString :: DrawData engine widget -> widget -> X String++instance TextWidget StandardWidget where+    widgetString dd TitleWidget = return $ ddWindowTitle dd+    widgetString _ (WindowIcon {}) = return "[*]"+    widgetString dd w = do+      checked <- isWidgetChecked w (ddOrigWindow dd)+      if checked+        then return $ swCheckedText w+        else return $ swUncheckedText w++-- | Widget for window title+titleW :: StandardWidget+titleW = TitleWidget++-- | Widget for ToggleSticky command.+toggleStickyW :: StandardWidget+toggleStickyW = GenericWidget "[S]" "[s]" ToggleSticky++-- | Widget for Minimize command+minimizeW :: StandardWidget+minimizeW = GenericWidget "" "[_]" Minimize++-- | Widget for ToggleMaximize command+maximizeW :: StandardWidget+maximizeW = GenericWidget "" "[O]" ToggleMaximize++-- | Widget for CloseWindow command+closeW :: StandardWidget+closeW = GenericWidget "" "[X]" CloseWindow++dwmpromoteW :: StandardWidget+dwmpromoteW = GenericWidget "[M]" "[m]" DwmPromote++moveToNextGroupW :: StandardWidget+moveToNextGroupW = GenericWidget "" "[>]" MoveToNextGroup++moveToPrevGroupW :: StandardWidget+moveToPrevGroupW = GenericWidget "" "[<]" MoveToPrevGroup+
XMonad/Layout/DecorationMadness.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.DecorationMadness+-- Description :  A collection of decorated layouts. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -16,7 +17,7 @@     ( -- * Usage       -- $usage -      -- * Decorated layouts based on Circle+      -- * Decorated layouts based on CircleEx       -- $circle       circleSimpleDefault     , circleDefault@@ -82,7 +83,7 @@     , floatDwmStyle     , floatSimpleTabbed     , floatTabbed-    , defaultTheme, shrinkText+    , def, shrinkText     ) where  import XMonad@@ -93,27 +94,27 @@ import XMonad.Layout.TabBarDecoration  import XMonad.Layout.Accordion-import XMonad.Layout.Circle+import XMonad.Layout.CircleEx import XMonad.Layout.WindowArranger import XMonad.Layout.SimpleFloat  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.DecorationMadness -- -- Then edit your @layoutHook@ by adding the layout you want: ----- > main = xmonad defaultConfig { layoutHook = someMadLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = someMadLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You can also edit the default theme: ----- > myTheme = defaultTheme { inactiveBorderColor = "#FF0000"+-- > myTheme = def { inactiveBorderColor = "#FF0000" -- >                        , activeTextColor     = "#00FF00" } -- -- and@@ -131,39 +132,39 @@ -- "XMonad.Util.Themes"  -- $circle--- Here you will find 'Circle' based decorated layouts.+-- Here you will find 'CircleEx' based decorated layouts. --- | A 'Circle' layout with the xmonad default decoration, default+-- | A 'CircleEx' layout with the xmonad default decoration, default -- theme and default shrinker. -- -- Here you can find a screen shot: -- -- <http://code.haskell.org/~arossato/xmonadShots/circleSimpleDefault.png>-circleSimpleDefault :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker) Circle Window-circleSimpleDefault = decoration shrinkText defaultTheme DefaultDecoration Circle+circleSimpleDefault :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker) CircleEx Window+circleSimpleDefault = decoration shrinkText def DefaultDecoration circle  -- | Similar to 'circleSimpleDefault' but with the possibility of -- setting a custom shrinker and a custom theme. circleDefault :: Shrinker s => s -> Theme-              -> ModifiedLayout (Decoration DefaultDecoration s) Circle Window-circleDefault s t = decoration s t DefaultDecoration Circle+              -> ModifiedLayout (Decoration DefaultDecoration s) CircleEx Window+circleDefault s t = decoration s t DefaultDecoration circle --- | A 'Circle' layout with the xmonad simple decoration, default+-- | A 'CircleEx' layout with the xmonad simple decoration, default -- theme and default shrinker. -- -- Here you can find a screen shot: -- -- <http://code.haskell.org/~arossato/xmonadShots/circleSimpleDeco.png>-circleSimpleDeco :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker) Circle Window-circleSimpleDeco = decoration shrinkText defaultTheme (Simple True) Circle+circleSimpleDeco :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker) CircleEx Window+circleSimpleDeco = decoration shrinkText def (Simple True) circle  -- | Similar to 'circleSimpleDece' but with the possibility of -- setting a custom shrinker and a custom theme. circleDeco :: Shrinker s => s -> Theme-           -> ModifiedLayout (Decoration SimpleDecoration s) Circle Window-circleDeco s t = decoration s t (Simple True) Circle+           -> ModifiedLayout (Decoration SimpleDecoration s) CircleEx Window+circleDeco s t = decoration s t (Simple True) circle --- | A 'Circle' layout with the xmonad default decoration, default+-- | A 'CircleEx' layout with the xmonad default decoration, default -- theme and default shrinker, but with the possibility of moving -- windows with the mouse, and resize\/move them with the keyboard. --@@ -171,17 +172,17 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/circleSimpleDefaultResizable.png> circleSimpleDefaultResizable :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker)-                                (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Circle)) Window-circleSimpleDefaultResizable = decoration shrinkText defaultTheme DefaultDecoration (mouseResize $ windowArrange Circle)+                                (ModifiedLayout MouseResize (ModifiedLayout WindowArranger CircleEx)) Window+circleSimpleDefaultResizable = decoration shrinkText def DefaultDecoration (mouseResize $ windowArrange circle)  -- | Similar to 'circleSimpleDefaultResizable' but with the -- possibility of setting a custom shrinker and a custom theme. circleDefaultResizable :: Shrinker s => s -> Theme                        -> ModifiedLayout (Decoration DefaultDecoration s)-                          (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Circle)) Window-circleDefaultResizable s t = decoration s t DefaultDecoration (mouseResize $ windowArrange Circle)+                          (ModifiedLayout MouseResize (ModifiedLayout WindowArranger CircleEx)) Window+circleDefaultResizable s t = decoration s t DefaultDecoration (mouseResize $ windowArrange circle) --- | A 'Circle' layout with the xmonad simple decoration, default+-- | A 'CircleEx' layout with the xmonad simple decoration, default -- theme and default shrinker, but with the possibility of moving -- windows with the mouse, and resize\/move them with the keyboard. --@@ -189,45 +190,45 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/circleSimpleDecoResizable.png> circleSimpleDecoResizable :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker)-                             (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Circle)) Window-circleSimpleDecoResizable = decoration shrinkText defaultTheme (Simple True) (mouseResize $ windowArrange Circle)+                             (ModifiedLayout MouseResize (ModifiedLayout WindowArranger CircleEx)) Window+circleSimpleDecoResizable = decoration shrinkText def (Simple True) (mouseResize $ windowArrange circle)  -- | Similar to 'circleSimpleDecoResizable' but with the -- possibility of setting a custom shrinker and a custom theme. circleDecoResizable :: Shrinker s => s -> Theme                     -> ModifiedLayout (Decoration SimpleDecoration s)-                       (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Circle)) Window-circleDecoResizable s t = decoration s t (Simple True) (mouseResize $ windowArrange Circle)+                       (ModifiedLayout MouseResize (ModifiedLayout WindowArranger CircleEx)) Window+circleDecoResizable s t = decoration s t (Simple True) (mouseResize $ windowArrange circle) --- | A 'Circle' layout with the xmonad DwmStyle decoration, default+-- | A 'CircleEx' layout with the xmonad DwmStyle decoration, default -- theme and default shrinker. -- -- Here you can find a screen shot: -- -- <http://code.haskell.org/~arossato/xmonadShots/circleSimpleDwmStyle.png>-circleSimpleDwmStyle :: ModifiedLayout (Decoration DwmStyle DefaultShrinker) Circle Window-circleSimpleDwmStyle = decoration shrinkText defaultTheme Dwm Circle+circleSimpleDwmStyle :: ModifiedLayout (Decoration DwmStyle DefaultShrinker) CircleEx Window+circleSimpleDwmStyle = decoration shrinkText def Dwm circle  -- | Similar to 'circleSimpleDwmStyle' but with the -- possibility of setting a custom shrinker and a custom theme. circleDwmStyle :: Shrinker s => s -> Theme-               -> ModifiedLayout (Decoration DwmStyle s) Circle Window-circleDwmStyle s t = decoration s t Dwm Circle+               -> ModifiedLayout (Decoration DwmStyle s) CircleEx Window+circleDwmStyle s t = decoration s t Dwm circle --- | A 'Circle' layout with the xmonad tabbed decoration, default+-- | A 'CircleEx' layout with the xmonad tabbed decoration, default -- theme and default shrinker. -- -- Here you can find a screen shot: -- -- <http://code.haskell.org/~arossato/xmonadShots/circleSimpleTabbed.png>-circleSimpleTabbed :: ModifiedLayout (Decoration TabBarDecoration DefaultShrinker) (ModifiedLayout ResizeScreen Circle) Window-circleSimpleTabbed = simpleTabBar Circle+circleSimpleTabbed :: ModifiedLayout (Decoration TabBarDecoration DefaultShrinker) (ModifiedLayout ResizeScreen CircleEx) Window+circleSimpleTabbed = simpleTabBar circle  -- | Similar to 'circleSimpleTabbed' but with the -- possibility of setting a custom shrinker and a custom theme. circleTabbed :: Shrinker s => s -> Theme-             -> ModifiedLayout (Decoration TabBarDecoration s) (ModifiedLayout ResizeScreen Circle) Window-circleTabbed s t = tabBar s t Top (resizeVertical (fi $ decoHeight t) Circle)+             -> ModifiedLayout (Decoration TabBarDecoration s) (ModifiedLayout ResizeScreen CircleEx) Window+circleTabbed s t = tabBar s t Top (resizeVertical (fi $ decoHeight t) circle)   -- $accordion@@ -241,7 +242,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/accordionSimpleDefault.png> accordionSimpleDefault :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker) Accordion Window-accordionSimpleDefault = decoration shrinkText defaultTheme DefaultDecoration Accordion+accordionSimpleDefault = decoration shrinkText def DefaultDecoration Accordion  -- | Similar to 'accordionSimpleDefault' but with the possibility of -- setting a custom shrinker and a custom theme.@@ -256,7 +257,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/accordionSimpleDeco.png> accordionSimpleDeco :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker) Accordion Window-accordionSimpleDeco = decoration shrinkText defaultTheme (Simple True) Accordion+accordionSimpleDeco = decoration shrinkText def (Simple True) Accordion  -- | Similar to 'accordionSimpleDece' but with the possibility of -- setting a custom shrinker and a custom theme.@@ -269,7 +270,7 @@ -- windows with the mouse, and resize\/move them with the keyboard. accordionSimpleDefaultResizable :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker)                                    (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Accordion)) Window-accordionSimpleDefaultResizable = decoration shrinkText defaultTheme DefaultDecoration (mouseResize $ windowArrange Accordion)+accordionSimpleDefaultResizable = decoration shrinkText def DefaultDecoration (mouseResize $ windowArrange Accordion)  -- | Similar to 'accordionSimpleDefaultResizable' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -283,7 +284,7 @@ -- windows with the mouse, and resize\/move them with the keyboard. accordionSimpleDecoResizable :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker)                                 (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Accordion)) Window-accordionSimpleDecoResizable = decoration shrinkText defaultTheme (Simple True) (mouseResize $ windowArrange Accordion)+accordionSimpleDecoResizable = decoration shrinkText def (Simple True) (mouseResize $ windowArrange Accordion)  -- | Similar to 'accordionSimpleDecoResizable' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -299,7 +300,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/accordionSimpleDwmStyle.png> accordionSimpleDwmStyle :: ModifiedLayout (Decoration DwmStyle DefaultShrinker) Accordion Window-accordionSimpleDwmStyle = decoration shrinkText defaultTheme Dwm Accordion+accordionSimpleDwmStyle = decoration shrinkText def Dwm Accordion  -- | Similar to 'accordionSimpleDwmStyle' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -337,7 +338,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/tallSimpleDefault.png> tallSimpleDefault :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker) Tall Window-tallSimpleDefault = decoration shrinkText defaultTheme DefaultDecoration tall+tallSimpleDefault = decoration shrinkText def DefaultDecoration tall  -- | Similar to 'tallSimpleDefault' but with the possibility of -- setting a custom shrinker and a custom theme.@@ -352,7 +353,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/tallSimpleDeco.png> tallSimpleDeco :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker) Tall Window-tallSimpleDeco = decoration shrinkText defaultTheme (Simple True) tall+tallSimpleDeco = decoration shrinkText def (Simple True) tall  -- | Similar to 'tallSimpleDece' but with the possibility of -- setting a custom shrinker and a custom theme.@@ -369,7 +370,7 @@ -- <http://code.haskell.org/~arossato/xmonadShots/tallSimpleDefaultResizable.png> tallSimpleDefaultResizable :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker)                               (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Tall)) Window-tallSimpleDefaultResizable = decoration shrinkText defaultTheme DefaultDecoration (mouseResize $ windowArrange tall)+tallSimpleDefaultResizable = decoration shrinkText def DefaultDecoration (mouseResize $ windowArrange tall)  -- | Similar to 'tallSimpleDefaultResizable' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -387,7 +388,7 @@ -- <http://code.haskell.org/~arossato/xmonadShots/tallSimpleDecoResizable.png> tallSimpleDecoResizable :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker)                            (ModifiedLayout MouseResize (ModifiedLayout WindowArranger Tall)) Window-tallSimpleDecoResizable = decoration shrinkText defaultTheme (Simple True) (mouseResize $ windowArrange tall)+tallSimpleDecoResizable = decoration shrinkText def (Simple True) (mouseResize $ windowArrange tall)  -- | Similar to 'tallSimpleDecoResizable' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -403,7 +404,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/tallSimpleDwmStyle.png> tallSimpleDwmStyle :: ModifiedLayout (Decoration DwmStyle DefaultShrinker) Tall Window-tallSimpleDwmStyle = decoration shrinkText defaultTheme Dwm tall+tallSimpleDwmStyle = decoration shrinkText def Dwm tall  -- | Similar to 'tallSimpleDwmStyle' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -440,7 +441,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/mirrorTallSimpleDefault.png> mirrorTallSimpleDefault :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker) (Mirror Tall) Window-mirrorTallSimpleDefault = decoration shrinkText defaultTheme DefaultDecoration mirrorTall+mirrorTallSimpleDefault = decoration shrinkText def DefaultDecoration mirrorTall  -- | Similar to 'mirrorTallSimpleDefault' but with the possibility of -- setting a custom shrinker and a custom theme.@@ -455,7 +456,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/mirrorTallSimpleDeco.png> mirrorTallSimpleDeco :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker) (Mirror Tall) Window-mirrorTallSimpleDeco = decoration shrinkText defaultTheme (Simple True) mirrorTall+mirrorTallSimpleDeco = decoration shrinkText def (Simple True) mirrorTall  -- | Similar to 'mirrorTallSimpleDece' but with the possibility of -- setting a custom shrinker and a custom theme.@@ -472,7 +473,7 @@ -- <http://code.haskell.org/~arossato/xmonadShots/mirrorTallSimpleDefaultResizable.png> mirrorTallSimpleDefaultResizable :: ModifiedLayout (Decoration DefaultDecoration DefaultShrinker)                                     (ModifiedLayout MouseResize (ModifiedLayout WindowArranger (Mirror Tall))) Window-mirrorTallSimpleDefaultResizable = decoration shrinkText defaultTheme DefaultDecoration (mouseResize $ windowArrange mirrorTall)+mirrorTallSimpleDefaultResizable = decoration shrinkText def DefaultDecoration (mouseResize $ windowArrange mirrorTall)  -- | Similar to 'mirrorTallSimpleDefaultResizable' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -490,7 +491,7 @@ -- <http://code.haskell.org/~arossato/xmonadShots/mirrorTallSimpleDecoResizable.png> mirrorTallSimpleDecoResizable :: ModifiedLayout (Decoration SimpleDecoration DefaultShrinker)                                  (ModifiedLayout MouseResize (ModifiedLayout WindowArranger (Mirror Tall))) Window-mirrorTallSimpleDecoResizable = decoration shrinkText defaultTheme (Simple True) (mouseResize $ windowArrange mirrorTall)+mirrorTallSimpleDecoResizable = decoration shrinkText def (Simple True) (mouseResize $ windowArrange mirrorTall)  -- | Similar to 'mirrorTallSimpleDecoResizable' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -506,7 +507,7 @@ -- -- <http://code.haskell.org/~arossato/xmonadShots/mirrorTallSimpleDwmStyle.png> mirrorTallSimpleDwmStyle :: ModifiedLayout (Decoration DwmStyle DefaultShrinker) (Mirror Tall) Window-mirrorTallSimpleDwmStyle = decoration shrinkText defaultTheme Dwm mirrorTall+mirrorTallSimpleDwmStyle = decoration shrinkText def Dwm mirrorTall  -- | Similar to 'mirrorTallSimpleDwmStyle' but with the -- possibility of setting a custom shrinker and a custom theme.@@ -555,7 +556,7 @@ -- <http://code.haskell.org/~arossato/xmonadShots/floatSimpleDefault.png> floatSimpleDefault :: (Show a, Eq a) => ModifiedLayout (Decoration DefaultDecoration DefaultShrinker)                   (ModifiedLayout MouseResize (ModifiedLayout WindowArranger SimpleFloat)) a-floatSimpleDefault = decoration shrinkText defaultTheme DefaultDecoration (mouseResize $ windowArrangeAll $ SF 20)+floatSimpleDefault = decoration shrinkText def DefaultDecoration (mouseResize $ windowArrangeAll $ SF 20)  -- | Same as 'floatSimpleDefault', but with the possibility of setting a -- custom shrinker and a custom theme.@@ -572,7 +573,7 @@ -- <http://code.haskell.org/~arossato/xmonadShots/floatSimpleDwmStyle.png> floatSimpleDwmStyle :: (Show a, Eq a) => ModifiedLayout (Decoration DwmStyle DefaultShrinker)                    (ModifiedLayout MouseResize (ModifiedLayout WindowArranger SimpleFloat)) a-floatSimpleDwmStyle = decoration shrinkText defaultTheme Dwm (mouseResize $ windowArrangeAll $ SF 20)+floatSimpleDwmStyle = decoration shrinkText def Dwm (mouseResize $ windowArrangeAll $ SF 20)  -- | Same as 'floatSimpleDwmStyle', but with the possibility of setting a -- custom shrinker and a custom theme.@@ -589,7 +590,7 @@ -- <http://code.haskell.org/~arossato/xmonadShots/floatSimpleTabbed.png> floatSimpleTabbed :: (Show a, Eq a) => ModifiedLayout (Decoration TabBarDecoration DefaultShrinker)                  (ModifiedLayout MouseResize (ModifiedLayout WindowArranger SimpleFloat)) a-floatSimpleTabbed = tabBar shrinkText defaultTheme Top (mouseResize $ windowArrangeAll $ SF 20)+floatSimpleTabbed = tabBar shrinkText def Top (mouseResize $ windowArrangeAll $ SF 20)  -- | Same as 'floatSimpleTabbed', but with the possibility of setting a -- custom shrinker and a custom theme.
XMonad/Layout/Dishes.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Dishes+-- Description :  A layout that stacks extra windows underneath the master windows. -- Copyright   :  (c) Jeremy Apthorp -- License     :  BSD-style (see LICENSE) --@@ -23,26 +24,26 @@  import XMonad import XMonad.StackSet (integrate)-import Control.Monad (ap)+import XMonad.Prelude (ap)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Dishes -- -- Then edit your @layoutHook@ by adding the Dishes layout: -- -- > myLayout = Dishes 2 (1/6) ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  data Dishes a = Dishes Int Rational deriving (Show, Read) instance LayoutClass Dishes a where     doLayout (Dishes nmaster h) r =-        return . (\x->(x,Nothing)) .+        return . (, Nothing) .         ap zip (dishes h r nmaster . length) . integrate     pureMessage (Dishes nmaster h) m = fmap incmastern (fromMessage m)         where incmastern (IncMasterN d) = Dishes (max 0 (nmaster+d)) h@@ -52,5 +53,5 @@                         then splitHorizontally n s                         else ws  where-    (m,rest) = splitVerticallyBy (1 - (fromIntegral $ n - nmaster) * h) s+    (m,rest) = splitVerticallyBy (1 - fromIntegral (n - nmaster) * h) s     ws = splitHorizontally nmaster m ++ splitVertically (n - nmaster) rest
XMonad/Layout/DragPane.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.DragPane+-- Description :  Split the screen either horizontally or vertically and show two windows. -- Copyright   :  (c) Spencer Janssen <spencerjanssen@gmail.com> --                    David Roundy <droundy@darcs.net>, --                    Andrea Rossato <andrea.rossato@unibz.it>@@ -34,18 +35,18 @@ import XMonad.Util.XUtils  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.DragPane -- -- Then edit your @layoutHook@ by adding the DragPane layout: -- -- > myLayout = dragPane Horizontal 0.1 0.5 ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  halfHandleWidth :: Integral a => a halfHandleWidth = 1@@ -54,7 +55,7 @@ handleColor = "#000000"  dragPane :: DragType -> Double -> Double -> DragPane a-dragPane t x y = DragPane (I Nothing) t x y+dragPane = DragPane (I Nothing)  data DragPane a =     DragPane (Invisible Maybe (Window,Rectangle,Int)) DragType Double Double@@ -67,7 +68,7 @@     doLayout d@(DragPane _ Horizontal _ _) = doLay mirrorRect d     handleMessage = handleMess -data SetFrac = SetFrac Int Double deriving ( Show, Read, Eq, Typeable )+data SetFrac = SetFrac Int Double deriving ( Show, Read, Eq) instance Message SetFrac  handleMess :: DragPane a -> SomeMessage -> X (Maybe (DragPane a))@@ -81,18 +82,18 @@     -- layout specific messages     | Just Shrink <- fromMessage x = return $ Just (DragPane mb ty delta (split - delta))     | Just Expand <- fromMessage x = return $ Just (DragPane mb ty delta (split + delta))-    | Just (SetFrac ident' frac) <- fromMessage x, ident' == ident = do+    | Just (SetFrac ident' frac) <- fromMessage x, ident' == ident =                                      return $ Just (DragPane mb ty delta frac) handleMess _ _ = return Nothing  handleEvent :: DragPane a -> Event -> X () handleEvent (DragPane (I (Just (win,r,ident))) ty _ _)-            (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t })-    | t == buttonPress && thisw == win || thisbw == win  = do+            ButtonEvent{ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t }+    | t == buttonPress && thisw == win || thisbw == win  =   mouseDrag (\ex ey -> do              let frac = case ty of-                        Vertical   -> (fromIntegral ex - (fromIntegral $ rect_x r))/(fromIntegral $ rect_width  r)-                        Horizontal -> (fromIntegral ey - (fromIntegral $ rect_x r))/(fromIntegral $ rect_width r)+                        Vertical   -> (fromIntegral ex - fromIntegral (rect_x r))/fromIntegral (rect_width  r)+                        Horizontal -> (fromIntegral ey - fromIntegral (rect_x r))/fromIntegral (rect_width r)              sendMessage (SetFrac ident frac))             (return ()) handleEvent _ _  = return ()@@ -121,7 +122,7 @@                     return (wrs, Just $ DragPane (I $ Just (w',r',ident)) ty delta split)             I Nothing -> do                     w <- newDragWin handr-                    i <- io $ newUnique+                    i <- io newUnique                     return (wrs, Just $ DragPane (I $ Just (w,r',hashUnique i)) ty delta split)      else return (wrs, Nothing)
XMonad/Layout/DraggingVisualizer.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-} ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.DraggingVisualizer+-- Description :  Visualize the process of dragging a window. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -24,19 +25,19 @@ import XMonad import XMonad.Layout.LayoutModifier -data DraggingVisualizer a = DraggingVisualizer (Maybe (Window, Rectangle)) deriving ( Read, Show )+newtype DraggingVisualizer a = DraggingVisualizer (Maybe (Window, Rectangle)) deriving ( Read, Show ) draggingVisualizer :: LayoutClass l Window => l Window -> ModifiedLayout DraggingVisualizer l Window draggingVisualizer = ModifiedLayout $ DraggingVisualizer Nothing  data DraggingVisualizerMsg = DraggingWindow Window Rectangle                                 | DraggingStopped-                                deriving ( Typeable, Eq )+                                deriving Eq instance Message DraggingVisualizerMsg  instance LayoutModifier DraggingVisualizer Window where     modifierDescription (DraggingVisualizer _) = "DraggingVisualizer"     pureModifier (DraggingVisualizer (Just dragged@(draggedWin, _))) _ _ wrs =-            if draggedWin `elem` (map fst wrs)+            if draggedWin `elem` map fst wrs                 then (dragged : rest, Nothing)                 else (wrs, Just $ DraggingVisualizer Nothing)         where@@ -45,5 +46,5 @@      pureMess (DraggingVisualizer _) m = case fromMessage m of         Just (DraggingWindow w rect) -> Just $ DraggingVisualizer $ Just (w, rect)-        Just (DraggingStopped) -> Just $ DraggingVisualizer Nothing+        Just DraggingStopped -> Just $ DraggingVisualizer Nothing         _ -> Nothing
XMonad/Layout/Drawer.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Drawer+-- Description :  A layout modifier to put windows in a "drawer". -- Copyright   :  (c) 2009 Max Rabkin -- License     :  BSD-style (see xmonad/LICENSE) --@@ -40,7 +41,7 @@ import XMonad.Layout.Reflect  -- $usage--- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@:+-- To use this module, add the following import to @xmonad.hs@: -- -- > import XMonad.Layout.Drawer --@@ -48,7 +49,7 @@ -- >     where -- >         drawer = simpleDrawer 0.01 0.3 (ClassName "Rhythmbox" `Or` ClassName "Xchat") -- >--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- This will place the Rhythmbox and Xchat windows in at the top of the screen -- only when using the 'Tall' layout.  See "XMonad.Util.WindowProperties" for@@ -71,7 +72,7 @@     modifyLayout (Drawer rs rb p l) ws rect =         case stack ws of             Nothing -> runLayout ws rect-            Just stk@(Stack { up=up_, down=down_, S.focus=w }) -> do+            Just stk@Stack{ up=up_, down=down_, S.focus=w } -> do                     (upD, upM) <- partitionM (hasProperty p) up_                     (downD, downM) <- partitionM (hasProperty p) down_                     b <- hasProperty p w@@ -94,7 +95,7 @@         mkStack (x:xs) ys = Just (Stack { up=xs, S.focus=x, down=ys })          rectB = rect { rect_width=round $ fromIntegral (rect_width rect) * rb }-        rectS = rectB { rect_x=rect_x rectB - (round $ (rb - rs) * fromIntegral (rect_width rect)) }+        rectS = rectB { rect_x=rect_x rectB - round ((rb - rs) * fromIntegral (rect_width rect)) }         rectM = rect { rect_x=rect_x rect + round (fromIntegral (rect_width rect) * rs)                      , rect_width=rect_width rect - round (fromIntegral (rect_width rect) * rs) } @@ -114,7 +115,7 @@ drawer ::    Rational   -- ^ The portion of the screen taken up by the drawer when closed           -> Rational   -- ^ The portion of the screen taken up by the drawer when open           -> Property   -- ^ Which windows to put in the drawer-          -> (l a)      -- ^ The layout of windows in the drawer+          -> l a        -- ^ The layout of windows in the drawer           -> Drawer l a drawer = Drawer
+ XMonad/Layout/Dwindle.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.Dwindle+-- Description :  Various spirally layouts.+-- Copyright   :  (c) Norbert Zeh <norbert.zeh@gmail.com>+-- License     :  BSD3+--+-- Maintainer  :  Norbert Zeh <norbert.zeh@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Three layouts: The first, 'Spiral', is a reimplementation of+-- 'XMonad.Layout.Spiral.spiral' with, at least to me, more intuitive semantics.+-- The second, 'Dwindle', is inspired by a similar layout in awesome and+-- produces the same sequence of decreasing window sizes as Spiral but pushes+-- the smallest windows into a screen corner rather than the centre.  The third,+-- 'Squeeze' arranges all windows in one row or in one column, with+-- geometrically decreasing sizes.+--+-----------------------------------------------------------------------------++module XMonad.Layout.Dwindle ( -- * Usage+                               -- $usage+                               Dwindle(..)+                             , Direction2D(..)+                             , Chirality(..)+                             ) where++import XMonad.Prelude ( unfoldr )+import XMonad+import XMonad.StackSet ( integrate, Stack )+import XMonad.Util.Types ( Direction2D(..) )++-- $usage+-- This module can be used as follows:+--+-- > import XMonad.Layout.Dwindle+--+-- Then add something like this to your layouts:+--+-- > Dwindle R CW 1.5 1.1+--+-- or+--+-- > Spiral L CW 1.5 1.1+--+-- or+--+-- ^ Squeeze D 1.5 1.1+--+-- The first produces a layout that places the second window to the right of+-- the first, the third below the second, the fourth to the right of the third,+-- and so on.  The first window is 1.5 times as wide as the second one, the+-- second is 1.5 times as tall as the third one, and so on.  Thus, the further+-- down the window stack a window is, the smaller it is and the more it is+-- pushed into the bottom-right corner.+--+-- The second produces a layout with the same window sizes but places the second+-- window to the left of the first one, the third above the second one, the+-- fourth to the right of the third one, and so on.+--+-- The third produces a layout that stacks windows vertically top-down with each+-- window being 1.5 times as tall as the next.+--+-- In all three cases, the fourth (third, in the case of 'Squeeze') parameter,+-- 1.1, is the factor by which the third parameter increases or decreases in+-- response to Expand or Shrink messages.+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".++-- | Layouts with geometrically decreasing window sizes.  'Spiral' and 'Dwindle'+-- split the screen into a rectangle for the first window and a rectangle for+-- the remaining windows, which is split recursively to lay out these windows.+-- Both layouts alternate between horizontal and vertical splits.+--+-- In each recursive step, the split 'Direction2D' determines the placement of the+-- remaining windows relative to the current window: to the left, to the right,+-- above or below.  The split direction of the first split is determined by the+-- first layout parameter.  The split direction of the second step is rotated 90+-- degrees relative to the first split direction according to the second layout+-- parameter of type 'Chirality'.  So, if the first split is 'R' and the second+-- layout parameter is 'CW', then the second split is 'D'.+--+-- For the 'Spiral' layout, the same 'Chirality' is used for computing the split+-- direction of each step from the split direction of the previous step.  For+-- example, parameters 'R' and 'CW' produces the direction sequence 'R', 'D',+-- 'L', 'U', 'R', 'D', 'L', 'U', ...+--+-- For the 'Dwindle' layout, the 'Chirality' alternates between 'CW' and 'CCW' in+-- each step.  For example, parameters 'U' and 'CCW' produce the direction+-- sequence 'U', 'L', 'U', 'L', ... because 'L' is the 'CCW' rotation of 'U' and+-- 'U' is the 'CW' rotation of 'L'.+--+-- In each split, the current rectangle is split so that the ratio between the+-- size of the rectangle allocated to the current window and the size of the+-- rectangle allocated to the remaining windows is the third layout parameter.+-- This ratio can be altered using 'Expand' and 'Shrink' messages.  The former+-- multiplies the ratio by the fourth layout parameter.  The latter divides the+-- ratio by this parameter.+--+-- 'Squeeze' does not alternate between horizontal and vertical splits and+-- simply splits in the direction given as its first argument.+--+-- Parameters for both 'Dwindle' and 'Spiral':+--+-- * First split direction+--+-- * First split chirality+--+-- * Size ratio between rectangle allocated to current window and rectangle+-- allocated to remaining windows+--+-- * Factor by which the size ratio is changed in response to 'Expand' or 'Shrink'+-- messages+--+-- The parameters for 'Squeeze' are the same, except that there is no 'Chirality'+-- parameter.+data Dwindle a = Dwindle !Direction2D !Chirality !Rational !Rational+               | Spiral  !Direction2D !Chirality !Rational !Rational+               | Squeeze !Direction2D !Rational !Rational+               deriving (Read, Show)++-- | Rotation between consecutive split directions+data Chirality = CW | CCW+               deriving (Read, Show)++instance LayoutClass Dwindle a where+    pureLayout (Dwindle dir rot ratio _) = dwindle alternate dir rot ratio+    pureLayout (Spiral  dir rot ratio _) = dwindle rotate    dir rot ratio+    pureLayout (Squeeze dir     ratio _) = squeeze           dir     ratio+    pureMessage (Dwindle dir rot ratio delta) =+      fmap (\ratio' -> Dwindle dir rot ratio' delta) . changeRatio ratio delta+    pureMessage (Spiral dir rot ratio delta) =+      fmap (\ratio' -> Spiral dir rot ratio' delta) . changeRatio ratio delta+    pureMessage (Squeeze dir ratio delta) =+      fmap (\ratio' -> Squeeze dir ratio' delta) . changeRatio ratio delta++changeRatio :: Rational -> Rational -> SomeMessage -> Maybe Rational+changeRatio ratio delta = fmap f . fromMessage+  where f Expand = ratio * delta+        f Shrink = ratio / delta++dwindle :: AxesGenerator -> Direction2D -> Chirality -> Rational -> Rectangle -> Stack a ->+           [(a, Rectangle)]+dwindle trans dir rot ratio rect st = unfoldr genRects (integrate st, rect, dirAxes dir, rot)+  where genRects ([],   _, _, _ ) = Nothing+        genRects ([w],  r, a, rt) = Just ((w, r),  ([], r,   a,  rt))+        genRects (w:ws, r, a, rt) = Just ((w, r'), (ws, r'', a', rt'))+          where (r', r'') = splitRect r ratio a+                (a', rt') = trans a rt++squeeze :: Direction2D -> Rational -> Rectangle -> Stack a -> [(a, Rectangle)]+squeeze dir ratio rect st = zip wins rects+  where wins    = integrate st+        nwins   = length wins+        sizes   = take nwins $ unfoldr (\r -> Just (r * ratio, r * ratio)) 1+        totals' = 0 : zipWith (+) sizes totals'+        totals  = drop 1 totals'+        splits  = zip (drop 1 sizes) totals+        ratios  = reverse $ map (uncurry (/)) splits+        rects   = genRects rect ratios+        genRects r []     = [r]+        genRects r (x:xs) = r' : genRects r'' xs+          where (r', r'') = splitRect r x (dirAxes dir)++splitRect :: Rectangle -> Rational -> Axes -> (Rectangle, Rectangle)+splitRect (Rectangle x y w h) ratio (ax, ay) = (Rectangle x' y' w' h', Rectangle x'' y'' w'' h'')+  where portion = ratio / (ratio + 1)+        w1  = (round $ fi w * portion) :: Int+        w2  = fi w - w1+        h1  = (round $ fi h * portion) :: Int+        h2  = fi h - h1+        x'  = x + fi (negate ax * (1 - ax) * w2 `div` 2)+        y'  = y + fi (negate ay * (1 - ay) * h2 `div` 2)+        w'  = fi $ w1 + (1 - abs ax) * w2+        h'  = fi $ h1 + (1 - abs ay) * h2+        x'' = x + fi (ax * (1 + ax) * w1 `div` 2)+        y'' = y + fi (ay * (1 + ay) * h1 `div` 2)+        w'' = fi $ w2 + (1 - abs ax) * w1+        h'' = fi $ h2 + (1 - abs ay) * h1+        fi :: (Num b, Integral a) => a -> b+        fi  = fromIntegral++type Axes          = (Int, Int)+type AxesGenerator = Axes -> Chirality -> (Axes, Chirality)++dirAxes :: Direction2D -> Axes+dirAxes L = (-1,  0)+dirAxes R = ( 1,  0)+dirAxes U = ( 0, -1)+dirAxes D = ( 0,  1)++alternate :: AxesGenerator+alternate = chDir alt++rotate :: AxesGenerator+rotate = chDir id++chDir :: (Chirality -> Chirality) -> AxesGenerator+chDir f (x, y) r = (a' r, r')+  where a' CW  = (-y,  x)+        a' CCW = ( y, -x)+        r' = f r++alt :: Chirality -> Chirality+alt CW  = CCW+alt CCW = CW
XMonad/Layout/DwmStyle.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.DwmStyle+-- Description :  A layout modifier for decorating windows in a dwm like style. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -17,7 +18,7 @@       -- $usage       dwmStyle     , Theme (..)-    , defaultTheme+    , def     , DwmStyle (..)     , shrinkText, CustomShrink(CustomShrink)     , Shrinker(..)@@ -29,39 +30,37 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.DwmStyle -- -- Then edit your @layoutHook@ by adding the DwmStyle decoration to -- your layout: ----- > myL = dwmStyle shrinkText defaultTheme (layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }------ For more detailed instructions on editing the layoutHook see:+-- > myL = dwmStyle shrinkText def (layoutHook def)+-- > main = xmonad def { layoutHook = myL } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You can also edit the default configuration options. ----- > myDWConfig = defaultTheme { inactiveBorderColor = "red"--- >                           , inactiveTextColor   = "red"}+-- > myDWConfig = def { inactiveBorderColor = "red"+-- >                  , inactiveTextColor   = "red"} -- -- and ----- > myL = dwmStyle shrinkText myDWConfig (layoutHook defaultConfig)+-- > myL = dwmStyle shrinkText myDWConfig (layoutHook def) -- -- A complete xmonad.hs file for this would therefore be: -- -- > import XMonad -- > import XMonad.Layout.DwmStyle -- >--- > main = xmonad defaultConfig {--- >                    layoutHook =--- >                        dwmStyle shrinkText defaultTheme--- >                            (layoutHook defaultConfig)--- >              }+-- > main = xmonad def {+-- >     layoutHook = dwmStyle shrinkText def (layoutHook def)+-- >     } --
+ XMonad/Layout/FixedAspectRatio.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE PatternGuards #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.FixedAspectRatio+-- Description :  A layout modifier for user provided per-window aspect ratios.+-- Copyright   :  (c) Yecine Megdiche <yecine.megdiche@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Yecine Megdiche <yecine.megdiche@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Layout modifier for user provided per-window aspect ratios.+--+-----------------------------------------------------------------------------++module XMonad.Layout.FixedAspectRatio+  (+    -- * Usage+    -- $usage+    fixedAspectRatio+  , FixedAspectRatio+  , ManageAspectRatio(..)+  , doFixAspect+  ) where+++import           Control.Arrow+import qualified Data.Map                      as M+import           Data.Ratio++import           XMonad+import           XMonad.Actions.MessageFeedback+import           XMonad.Layout.Decoration+import           XMonad.Layout.LayoutHints++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Layout.FixedAspectRatio+-- Then add it to your layout:+--+-- > myLayout = fixedAspectRatio (0.5, 0.5) $ Tall 1 (3/100) (1/2)  ||| Full ||| etc..+-- > main = xmonad def { layoutHook = myLayout }+--+-- Which will center the (eventually) shrinked windows in their assigned+-- rectangle.+--+-- For a layout modifier that automatically sets the aspect ratio+-- depending on the size hints (for example for programs like mpv),+-- see "XMonad.Layout.LayoutHints"+--+-- See <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook" for more info on the 'layoutHook'.+--+-- You also want to add keybindings to set and clear the aspect ratio:+--+-- >      -- Set the aspect ratio of the focused window to 16:9+-- >   ,((modm, xK_a), withFocused $ sendMessage . FixRatio (16 / 9))+-- >+-- >      -- Clear the aspect ratio from the focused window+-- >   ,((modm .|. shiftMask, xK_a), withFocused $ sendMessage . ResetRatio)+--+-- There's one caveat: to keep the usage of the modifier simple, it+-- doesn't remove a window from its cache automatically. Which means+-- that if you close a program window that has some fixed aspect ratios+-- and relaunch it, sometimes it'll still have the fixed aspect ratio.+-- You can try to avoid this by changing they keybinding used to kill+-- the window:+--+-- >  , ((modMask .|. shiftMask, xK_c), withFocused (sendMessage . ResetRatio) >> kill)+--+-- See <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> for more info+-- on customizing the keybindings.+--+-- This layout also comes with a 'ManageHook' 'doFixAspect' to+-- automatically fix the aspect ratio:+--+-- > myManageHook = composeOne [+-- >   title =? "Netflix" <||> className =? "vlc" --> doFixAspect (16 / 9)+-- >   ...+-- > ]+--+-- Check <https://xmonad.org/TUTORIAL.html#final-touches the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_manage_hook" for more information on+-- customizing the manage hook.++-- | Similar to 'layoutHintsWithReplacement', but relies on the user to+-- provide the ratio for each window. @aspectRatio (rx, ry) layout@ will+-- adapt the sizes of a layout's windows according to the provided aspect+-- ratio, and position them inside their originally assigned area+-- according to the @rx@ and @ry@ parameters.+-- (0, 0) places the window at the top left, (1, 0) at the top right,+-- (0.5, 0.5) at the center, etc.+fixedAspectRatio+  :: (Double, Double) -> l a -> ModifiedLayout FixedAspectRatio l a+fixedAspectRatio = ModifiedLayout . FixedAspectRatio mempty++data FixedAspectRatio a = FixedAspectRatio (M.Map Window Rational)+                                           (Double, Double)+  deriving (Read, Show)++instance LayoutModifier FixedAspectRatio Window where+  -- | Note: this resembles redoLayout from "XMonad.Layout.LayoutHints".+  -- The only difference is relying on user defined aspect ratios, and+  -- using the 'adj' function defined below instead of 'mkAdjust'+  pureModifier (FixedAspectRatio ratios placement) _ (Just s) xs =+    (xs', Nothing)+   where+    xs' =+      map (\x@(_, r) -> second (placeRectangle placement r) $ applyHint x) xs+    applyHint (win, r@(Rectangle x y w h)) =+      let ar       = M.lookup win ratios+          (w', h') = maybe (w, h) (adj (w, h)) ar+      in  (win, if isInStack s win then Rectangle x y w' h' else r)++  pureModifier _ _ _ xs = (xs, Nothing)++  handleMess (FixedAspectRatio ratios placement) mess+    | Just DestroyWindowEvent { ev_window = w } <- fromMessage mess+    = return . Just $ FixedAspectRatio (deleted w) placement+    | otherwise+    = case fromMessage mess of+      Just (FixRatio r w) ->+        return . Just $ FixedAspectRatio (inserted w r) placement+      Just (ResetRatio w) ->+        return . Just $ FixedAspectRatio (deleted w) placement+      Just (ToggleRatio r w) ->+        return+          . Just+          . flip FixedAspectRatio placement+          . maybe (inserted w r) (const $ deleted w)+          $ M.lookup w ratios+      _ -> return Nothing+   where+    inserted w r = M.insert w r ratios+    deleted w = M.delete w ratios++-- | A 'ManageHook' to set the aspect ratio for newly spawned windows+doFixAspect+  :: Rational -- ^ The aspect ratio+  -> ManageHook+doFixAspect r = ask+  >>= \w -> liftX (sendMessageWithNoRefreshToCurrent (FixRatio r w)) >> mempty++-- | Calculates the new width and height so they respect the+-- aspect ratio.+adj :: (Dimension, Dimension) -> Rational -> (Dimension, Dimension)+adj (w, h) ar | ar' > ar  = (ceiling $ fi h * ar, h)+              | otherwise = (w, ceiling $ fi w / ar)+  where ar' = fi w % fi h++--- Message handling+data ManageAspectRatio =+    FixRatio Rational Window    -- ^ Set the aspect ratio for the window+  | ResetRatio Window           -- ^ Remove the aspect ratio for the window+  | ToggleRatio Rational Window -- ^ Toggle the reatio++instance Message ManageAspectRatio
XMonad/Layout/FixedColumn.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.FixedColumn+-- Description :  Like Tall, but split at a fixed column (or a window's smallest resize amount). -- Copyright   :  (c) 2008 Justin Bogner <mail@justinbogner.com> -- License     :  BSD3-style (as xmonad) --@@ -22,32 +23,23 @@         FixedColumn(..) ) where -import Control.Monad (msum)-import Data.Maybe (fromMaybe)-import Graphics.X11.Xlib (Window, rect_width)-import Graphics.X11.Xlib.Extras ( getWMNormalHints-                                , getWindowAttributes-                                , sh_base_size-                                , sh_resize_inc-                                , wa_border_width)--import XMonad.Core (X, LayoutClass(..), fromMessage, io, withDisplay)-import XMonad.Layout (Resize(..), IncMasterN(..), tile)-import XMonad.StackSet as W+import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.FixedColumn -- -- Then edit your @layoutHook@ by adding the FixedColumn layout: -- -- > myLayout = FixedColumn 1 20 80 10 ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | A tiling mode based on preserving a nice fixed width --   window. Supports 'Shrink', 'Expand' and 'IncMasterN'.@@ -62,7 +54,7 @@             fws <- mapM (widthCols fallback ncol) ws             let frac = maximum (take nmaster fws) // rect_width r                 rs   = tile frac r nmaster (length ws)-            return $ (zip ws rs, Nothing)+            return (zip ws rs, Nothing)         where ws     = W.integrate s               x // y = fromIntegral x / fromIntegral y @@ -82,10 +74,11 @@ --   columns wide, using @inc@ as a resize increment for windows that --   don't have one widthCols :: Int -> Int -> Window -> X Int-widthCols inc n w = withDisplay $ \d -> io $ do-    sh <- getWMNormalHints d w-    bw <- fmap (fromIntegral . wa_border_width) $ getWindowAttributes d w-    let widthHint f = f sh >>= return . fromIntegral . fst+widthCols inc n w = do+    d  <- asks display+    bw <- asks $ fi . borderWidth . config+    sh <- io $ getWMNormalHints d w+    let widthHint f = f sh <&> fromIntegral . fst         oneCol      = fromMaybe inc $ widthHint sh_resize_inc         base        = fromMaybe 0 $ widthHint sh_base_size     return $ 2 * bw + base + n * oneCol
+ XMonad/Layout/FocusTracking.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}+{- |++Module      :  XMonad.Layout.FocusTracking+Description :  Track focus in the tiled layer.+Copyright   :  (c) 2010 & 2013 Adam Vogt+                   2011 Willem Vanlint+                   2018 & 2022 L.S.Leary+License     :  BSD-style (see xmonad/LICENSE)++Maintainer  :  @LSLeary (on github)+Stability   :  unstable+Portability :  unportable++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, or equivalently, that of the layout itself when a float has+focus.++Relevant issues:++  * <http://code.google.com/p/xmonad/issues/detail?id=4>+  * <http://code.google.com/p/xmonad/issues/detail?id=306>++--------------------------------------------------------------------------------+-}+module XMonad.Layout.FocusTracking+    ( -- * Usage+      -- $usage+      FocusTracking(..)+    , focusTracking+    ) where++import XMonad.Prelude+import XMonad+import XMonad.Layout.LayoutModifier+import XMonad.Util.Stack (findZ)+import qualified XMonad.StackSet as W++-- $usage+--+-- To use the module, first import it:+--+-- > import XMonad.Layout.FocusTracking+--+-- Then, a focus-dependent layout can be made to fall back on the last focus it+-- saw, for example:+--+-- > main = xmonad def+-- >  { layoutHook = someParentLayoutWith aChild (focusTracking anotherChild)+-- >  , ...+-- >  }+--+-- Or in a simpler case:+--+-- > main = xmonad def+-- >  { layoutHook = myTiledLayout ||| focusTracking Full+-- >  , ...+-- >  }+--++-- | A 'LayoutModifier' that remembers the last focus it saw.+newtype FocusTracking a = FocusTracking (Maybe Window)+    deriving (Read, Show)++instance LayoutModifier FocusTracking Window where+    modifyLayoutWithUpdate (FocusTracking mw) ws@W.Workspace{ W.stack = ms } r+      = do+        xCur <- gets (W.peek . W.view (W.tag ws) . windowset)+        let isF = xCur /= (W.focus <$> ms)+            -- use the remembered focus point when true focus differs from+            -- what this (sub)layout is given, which happens e.g. when true+            -- focus is in floating layer or when another sublayout has focus+            newStack | isF = (mw >>= \w -> findZ (w==) ms) <|> ms+                     | otherwise = ms+            newState | isF = mw+                     | otherwise = xCur+        ran <- runLayout ws{ W.stack = newStack } r+        return (ran, guard (newState /= mw) $> FocusTracking newState)++-- | Transform a layout into one that remembers and uses the last focus it saw.+focusTracking ::  l a -> ModifiedLayout FocusTracking l a+focusTracking = ModifiedLayout (FocusTracking Nothing)+
XMonad/Layout/Fullscreen.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- FIXME: fullscreenStartup temporarily silenced ----------------------------------------------------------------------------- -- |--- Module      :  XMonad.Layout.Decoration+-- Module      :  XMonad.Layout.Fullscreen+-- Description :  Send messages about fullscreen windows to layouts. -- Copyright   :  (c) 2010 Audun Skaugen -- License     :  BSD-style (see xmonad/LICENSE) --@@ -15,7 +17,9 @@ module XMonad.Layout.Fullscreen     ( -- * Usage:       -- $usage-     fullscreenFull+     fullscreenSupport+    ,fullscreenSupportBorder+    ,fullscreenFull     ,fullscreenFocus     ,fullscreenFullRect     ,fullscreenFocusRect@@ -29,18 +33,19 @@     ,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.Prelude+import           XMonad.Layout.LayoutModifier+import           XMonad.Layout.NoBorders        (SmartBorder, smartBorders)+import           XMonad.Hooks.EwmhDesktops      (fullscreenStartup)+import           XMonad.Hooks.ManageHelpers     (isFullscreen)+import           XMonad.Util.WindowProperties+import qualified XMonad.Util.Rectangle          as R+import qualified XMonad.StackSet                as W +import qualified Data.Map                       as M+import           Control.Arrow                  (second)+ -- $usage -- Provides a ManageHook and an EventHook that sends layout messages -- with information about fullscreening windows. This allows layouts@@ -53,9 +58,9 @@ -- To use this module, add 'fullscreenEventHook' and 'fullscreenManageHook' -- to your config, i.e. ----- > xmonad defaultconfig { handleEventHook = fullscreenEventHook,--- >                        manageHook = fullscreenManageHook,--- >                        layoutHook = myLayouts }+-- > xmonad def { handleEventHook = fullscreenEventHook,+-- >              manageHook = fullscreenManageHook,+-- >              layoutHook = myLayouts } -- -- Now you can use layouts that respect fullscreen, for example the -- provided 'fullscreenFull':@@ -63,6 +68,36 @@ -- > myLayouts = fullscreenFull someLayout -- +-- | Modifies your config to apply basic fullscreen support -- fullscreen+-- windows when they request it. Example usage:+--+-- > main = xmonad+-- >      $ fullscreenSupport+-- >      $ def { ... }+fullscreenSupport :: LayoutClass l Window =>+  XConfig l -> XConfig (ModifiedLayout FullscreenFull l)+fullscreenSupport c = c {+    layoutHook = fullscreenFull $ layoutHook c,+    handleEventHook = handleEventHook c <> fullscreenEventHook,+    manageHook = manageHook c <> fullscreenManageHook,+    startupHook = startupHook c <> fullscreenStartup+  }++-- | fullscreenSupport with smartBorders support so the border doesn't+-- show when the window is fullscreen+--+-- > main = xmonad+-- >      $ fullscreenSupportBorder+-- >      $ def { ... }+fullscreenSupportBorder :: LayoutClass l Window =>+    XConfig l -> XConfig (ModifiedLayout FullscreenFull+    (ModifiedLayout SmartBorder (ModifiedLayout FullscreenFull l)))+fullscreenSupportBorder c =+    fullscreenSupport c { layoutHook = smartBorders+                                       $ fullscreenFull+                                       $ layoutHook c+                        }+ -- | Messages that control the fullscreen state of the window. -- AddFullscreen and RemoveFullscreen are sent to all layouts -- when a window wants or no longer wants to be fullscreen.@@ -71,7 +106,6 @@ data FullscreenMessage = AddFullscreen Window                        | RemoveFullscreen Window                        | FullscreenChanged-     deriving (Typeable)  instance Message FullscreenMessage @@ -87,34 +121,37 @@ instance LayoutModifier FullscreenFull Window where   pureMess ff@(FullscreenFull frect fulls) m = case fromMessage m of     Just (AddFullscreen win) -> Just $ FullscreenFull frect $ nub $ win:fulls-    Just (RemoveFullscreen win) -> Just $ FullscreenFull frect $ delete win $ fulls+    Just (RemoveFullscreen win) -> Just $ FullscreenFull frect $ delete win fulls     Just FullscreenChanged -> Just ff     _ -> 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   pureMess ff@(FullscreenFocus frect fulls) m = case fromMessage m of     Just (AddFullscreen win) -> Just $ FullscreenFocus frect $ nub $ win:fulls-    Just (RemoveFullscreen win) -> Just $ FullscreenFocus frect $ delete win $ fulls+    Just (RemoveFullscreen win) -> Just $ FullscreenFocus frect $ delete win fulls     Just FullscreenChanged -> Just ff     _ -> Nothing -  pureModifier (FullscreenFocus frect fulls) rect (Just (W.Stack {W.focus = f})) list+  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)  instance LayoutModifier FullscreenFloat Window where   handleMess (FullscreenFloat frect fulls) m = case fromMessage m of     Just (AddFullscreen win) -> do-      mrect <- (M.lookup win . W.floating) `fmap` gets windowset+      mrect <- M.lookup win . W.floating <$> gets windowset       return $ case mrect of         Just rect -> Just $ FullscreenFloat frect $ M.insert win (rect,True) fulls         Nothing -> Nothing@@ -176,15 +213,12 @@ fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do   wmstate <- getAtom "_NET_WM_STATE"   fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN"-  wstate <- fromMaybe [] `fmap` getProp32 wmstate win-  let fi :: (Integral i, Num n) => i -> n-      fi = fromIntegral-      isFull = fi fullsc `elem` wstate+  wstate <- fromMaybe [] <$> getProp32 wmstate win+  let isFull = fi fullsc `elem` wstate       remove = 0       add = 1       toggle = 2-      ptype = 4-      chWState f = io $ changeProperty32 dpy win wmstate ptype propModeReplace (f wstate)+      chWState f = io $ changeProperty32 dpy win wmstate aTOM propModeReplace (f wstate)   when (typ == wmstate && fi fullsc `elem` dats) $ do     when (action == add || (action == toggle && not isFull)) $ do       chWState (fi fullsc:)@@ -196,11 +230,11 @@       sendMessage FullscreenChanged   return $ All True -fullscreenEventHook (DestroyWindowEvent {ev_window = w}) = do+fullscreenEventHook DestroyWindowEvent{ev_window = w} = do   -- When a window is destroyed, the layouts should remove that window   -- from their states.   broadcastMessage $ RemoveFullscreen w-  cw <- (W.workspace . W.current) `fmap` gets windowset+  cw <- W.workspace . W.current <$> gets windowset   sendMessageWithNoRefresh FullscreenChanged cw   return $ All True @@ -221,7 +255,10 @@   w <- ask   liftX $ do     broadcastMessage $ AddFullscreen w-    cw <- (W.workspace . W.current) `fmap` gets windowset+    cw <- W.workspace . W.current <$> gets windowset     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
XMonad/Layout/Gaps.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, PatternGuards #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Gaps+-- Description :  Create manually-sized gaps along edges of the screen. -- Copyright   :  (c) 2008 Brent Yorgey -- License     :  BSD3 --@@ -14,7 +15,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,21 +32,19 @@                                -- * Usage                                -- $usage                           Direction2D(..), Gaps,-                          GapSpec, gaps, GapMessage(..)-+                          GapSpec, gaps, gaps', GapMessage(..),+                          weakModifyGaps, modifyGap, setGaps, setGap                           ) where +import XMonad.Prelude (delete, fi) import XMonad.Core import Graphics.X11 (Rectangle(..))  import XMonad.Layout.LayoutModifier import XMonad.Util.Types (Direction2D(..))-import XMonad.Util.XUtils (fi) -import Data.List (delete)- -- $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.hs@ file: -- -- > import XMonad.Layout.Gaps --@@ -55,10 +56,23 @@ -- 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@@ -77,6 +91,10 @@ -- -- To configure gaps differently per-screen, use -- "XMonad.Layout.PerScreen" (coming soon).+--+-- __Warning__: If you also use the 'avoidStruts' layout modifier, it+-- must come /before/ any of these modifiers. See the documentation of+-- 'avoidStruts' for details.  -- | A manual gap configuration.  Each side of the screen on which a --   gap is enabled is paired with a size in pixels.@@ -93,7 +111,7 @@                 | ToggleGap  !Direction2D    -- ^ Toggle a single gap.                 | IncGap !Int !Direction2D    -- ^ Increase a gap by a certain number of pixels.                 | DecGap !Int !Direction2D    -- ^ Decrease a gap.-  deriving (Typeable)+                | ModifyGaps (GapSpec -> GapSpec) -- ^ Modify arbitrarily.  instance Message GapMessage @@ -106,11 +124,46 @@       | 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@@ -128,15 +181,17 @@  toggleGap :: GapSpec -> [Direction2D] -> Direction2D -> [Direction2D] toggleGap conf cur d | d `elem` cur            = delete d cur-                     | d `elem` (map fst conf) = 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.      -> ModifiedLayout Gaps l a gaps g = ModifiedLayout (Gaps g (map fst g)) +-- | Add togglable manual gaps to a layout, explicitly specifying the initial states.+gaps' :: [((Direction2D,Int),Bool)] -- ^ The gaps to allow and their initial states.+      -> l a                        -- ^ The layout to modify.+      -> ModifiedLayout Gaps l a+gaps' g = ModifiedLayout (Gaps (map fst g) [d | ((d,_),v) <- g, v])
XMonad/Layout/Grid.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Grid+-- Description :  A simple layout that attempts to put all windows in a square grid. -- Copyright   :  (c) Lukas Mai -- License     :  BSD-style (see LICENSE) --@@ -24,14 +25,14 @@ import XMonad.StackSet  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Grid -- -- Then edit your @layoutHook@ by adding the Grid layout: -- -- > myLayout = Grid ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- You can also specify an aspect ratio for Grid to strive for with the -- GridRatio constructor.  For example, if you want Grid to try to make a grid@@ -39,9 +40,9 @@ -- -- > myLayout = GridRatio (4/3) ||| etc. ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  data Grid a = Grid | GridRatio Double deriving (Read, Show) @@ -56,11 +57,11 @@ 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)]-    chop n m = ((0, m - k * fromIntegral (pred n)) :) . map (flip (,) k) . tail . reverse . take n . tail . iterate (subtract k') $ m'+    chop n m = ((0, m - k * fromIntegral (pred n)) :) . map (, k) . drop 1 . reverse . take n . drop 1 . iterate (subtract k') $ m'         where         k :: Dimension         k = m `div` fromIntegral n
XMonad/Layout/GridVariants.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}  ---------------------------------------------------------------------- -- | -- Module      : XMonad.Layout.GridVariants+-- Description : Two grid layouts. -- Copyright   : (c) Norbert Zeh -- License     : BSD-style (see LICENSE) --@@ -27,7 +28,7 @@                                   , Orientation(..)                                   ) where -import Control.Monad+import XMonad.Prelude import XMonad import qualified XMonad.StackSet as W @@ -58,7 +59,7 @@ -- > ((modm .|. controlMask,  xK_minus), sendMessage $ IncMasterRows (-1))  -- | Grid layout.  The parameter is the desired x:y aspect ratio of windows-data Grid a = Grid !Rational+newtype Grid a = Grid Rational               deriving (Read, Show)  instance LayoutClass Grid a where@@ -82,7 +83,6 @@ data ChangeGridGeom     = SetGridAspect !Rational     | ChangeGridAspect !Rational-      deriving Typeable  instance Message ChangeGridGeom @@ -125,7 +125,6 @@     | SetMasterRows     !Int      -- ^Set the number of master rows to absolute value     | SetMasterCols     !Int      -- ^Set the number of master columns to absolute value     | SetMasterFraction !Rational -- ^Set the fraction of the screen used by the master grid-    deriving Typeable  instance Message ChangeMasterGridGeom @@ -133,8 +132,8 @@ arrangeSplitGrid rect@(Rectangle rx ry rw rh) o nwins mrows mcols mfrac saspect     | nwins <= mwins = arrangeMasterGrid rect nwins mcols     | mwins == 0     = arrangeAspectGrid rect nwins saspect-    | otherwise      = (arrangeMasterGrid mrect mwins mcols) ++-                       (arrangeAspectGrid srect swins saspect)+    | otherwise      = arrangeMasterGrid mrect mwins mcols +++                       arrangeAspectGrid srect swins saspect     where       mwins            = mrows * mcols       swins            = nwins - mwins@@ -179,7 +178,7 @@       y_slabs       = [splitIntoSlabs (fromIntegral rh) nrows | nrows <- nrows_in_cols]       rects_in_cols = [[(x, y, w, h) | (y, h) <- lst]                        | ((x, w), lst) <- zip x_slabs y_slabs]-      rects         = foldr (++) [] rects_in_cols+      rects         = concat rects_in_cols  splitIntoSlabs :: Int -> Int -> [(Int, Int)] splitIntoSlabs width nslabs = zip (0:xs) widths@@ -196,7 +195,7 @@       size    = ceiling ( (fromIntegral n / fromIntegral parts) :: Double )       extra   = size*parts - n       sizes   = [i*size | i <- [1..parts]]-      offsets = (take (fromIntegral extra) [1..]) ++ [extra,extra..]+      offsets = take (fromIntegral extra) [1..] ++ [extra,extra..]  resizeMaster :: SplitGrid a -> Resize -> SplitGrid a resizeMaster (SplitGrid o mrows mcols mfrac saspect delta) Shrink =@@ -244,8 +243,8 @@           rects = arrangeSplitGrid rect L nwins mrows mcols mfrac saspect      pureMessage layout msg =-        msum [ fmap ((tallGridAdapter resizeMaster) layout) (fromMessage msg)-             , fmap ((tallGridAdapter changeMasterGrid) layout) (fromMessage msg) ]+        msum [ fmap (tallGridAdapter resizeMaster layout) (fromMessage msg)+             , fmap (tallGridAdapter changeMasterGrid layout) (fromMessage msg) ]      description _ = "TallGrid"
XMonad/Layout/Groups.hs view
@@ -1,11 +1,10 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}-{-# LANGUAGE StandaloneDeriving, FlexibleContexts, DeriveDataTypeable-  , UndecidableInstances, FlexibleInstances, MultiParamTypeClasses-  , PatternGuards, Rank2Types, TypeSynonymInstances #-}+{-# LANGUAGE StandaloneDeriving, FlexibleContexts, UndecidableInstances, FlexibleInstances, MultiParamTypeClasses, PatternGuards, Rank2Types #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Groups+-- Description :  Split windows in layout groups that are managed by another layout. -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -25,6 +24,7 @@                               -- * Messages                             , GroupsMessage(..)                             , ModifySpec+                            , ModifySpecX                               -- ** Useful 'ModifySpec's                             , swapUp                             , swapDown@@ -53,15 +53,12 @@                             ) where  import XMonad+import XMonad.Prelude hiding (group) import qualified XMonad.StackSet as W  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)  -- $usage -- This module provides a layout combinator that allows you@@ -99,7 +96,6 @@ 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@@ -109,8 +105,8 @@ -- seed. All keys generated with this method will be different -- provided you don't use 'gen' again with a key from the list. -- (if you need to do that, see 'split' instead)-gen :: Uniq -> (Uniq, [Uniq])-gen (U i1 i2) = (U (i1+1) i2, zipWith U (repeat i1) [i2..])+gen :: Uniq -> (Uniq, Stream Uniq)+gen (U i1 i2) = (U (i1+1) i2, fmap (U i1) (fromList [i2..]))  -- | Split an infinite list into two. I ended up not -- needing this, but let's keep it just in case.@@ -122,7 +118,7 @@ -- | Add a unique identity to a layout so we can -- follow it around. data WithID l a = ID { getID :: Uniq-                     , unID :: (l a)}+                     , unID :: l a}   deriving (Show, Read)  -- | Compare the ids of two 'WithID' values@@ -134,8 +130,7 @@  instance LayoutClass l a => LayoutClass (WithID l) a where     runLayout ws@W.Workspace { W.layout = ID id l } r-        = do (placements, ml') <- flip runLayout r-                                     ws { W.layout = l}+        = do (placements, ml') <- runLayout ws{ W.layout = l} r              return (placements, ID id <$> ml')     handleMessage (ID id l) sm = do ml' <- handleMessage l sm                                     return $ ID id <$> ml'@@ -187,7 +182,7 @@                              -- to the layout.                    | Modify ModifySpec -- ^ Modify the ordering\/grouping\/focusing                                        -- of windows according to a 'ModifySpec'-                     deriving Typeable+                   | ModifyX ModifySpecX -- ^ Same as 'Modify', but within the 'X' monad  instance Show GroupsMessage where     show (ToEnclosing _) = "ToEnclosing {...}"@@ -196,16 +191,24 @@     show (ToAll _) = "ToAll {...}"     show Refocus = "Refocus"     show (Modify _) = "Modify {...}"+    show (ModifyX _) = "ModifyX {...}"  instance Message GroupsMessage  modifyGroups :: (Zipper (Group l a) -> Zipper (Group l a))              -> Groups l l2 a -> Groups l l2 a-modifyGroups f g = let (seed', id:_) = gen (seed g)-                       defaultGroups = fromJust $ singletonZ $ G (ID id $ baseLayout g) emptyZ+modifyGroups f g = let (seed', ident :~ _) = gen (seed g)+                       defaultGroups = fromJust $ singletonZ $ G (ID ident $ baseLayout g) emptyZ                    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', ident :~ _) = gen (seed g)+      defaultGroups = fromJust $ singletonZ $ G (ID ident $ baseLayout g) emptyZ+  g' <- f . Just $ groups g+  return g { groups = fromMaybe defaultGroups g', seed = seed' }  -- ** Readaptation @@ -215,28 +218,28 @@ -- other stack changes as gracefully as possible. readapt :: Eq a => Zipper a -> Groups l l2 a -> Groups l l2 a readapt z g = let mf = getFocusZ z-                  (seed', id:_) = gen $ seed g+                  (seed', ident :~ _) = gen $ seed g                   g' = g { seed = seed' }               in flip modifyGroups g' $ mapZ_ (onZipper $ removeDeleted z)                                         >>> filterKeepLast (isJust . gZipper)                                         >>> findNewWindows (W.integrate' z)-                                        >>> addWindows (ID id $ baseLayout g)+                                        >>> addWindows (ID ident $ baseLayout g)                                         >>> focusGroup mf                                         >>> onFocusedZ (onZipper $ focusWindow mf)     where filterKeepLast _ Nothing = Nothing-          filterKeepLast f z@(Just s) = maybe (singletonZ $ W.focus s) Just-                                            $ filterZ_ f z+          filterKeepLast f z@(Just s) =  filterZ_ f z+                                     <|> singletonZ (W.focus s)  -- | Remove the windows from a group which are no longer present in -- the stack. removeDeleted :: Eq a => Zipper a -> Zipper a -> Zipper a-removeDeleted z = filterZ_ (flip elemZ z)+removeDeleted z = filterZ_ (`elemZ` z)  -- | Identify the windows not already in a group. findNewWindows :: Eq a => [a] -> Zipper (Group l a)                -> (Zipper (Group l a), [a]) findNewWindows as gs = (gs, foldrZ_ removePresent as gs)-    where removePresent g as' = filter (not . flip elemZ (gZipper g)) as'+    where removePresent g = filter (not . flip elemZ (gZipper g))  -- | Add windows to the focused group. If you need to create one, -- use the given layout and an id from the given list.@@ -274,13 +277,13 @@                results <- forM areas $ \(g, r') -> runLayout ws { W.layout = gLayout g                                                                 , W.stack = gZipper g } r' -               let hidden = map gLayout (W.integrate $ groups l) \\ map (gLayout . fst) areas+               let hidden = map gLayout (W.integrate $ groups _l) \\ map (gLayout . fst) areas                hidden' <- mapM (flip handleMessage $ SomeMessage Hide) hidden                 let placements = concatMap fst results                    newL = justMakeNew l mpart' (map snd results ++ hidden') -               return $ (placements, newL)+               return (placements, newL)          handleMessage l@(Groups _ p _ _) sm | Just (ToEnclosing sm') <- fromMessage sm             = do mp' <- handleMessage p sm'@@ -303,16 +306,19 @@               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                       where step True (G l _) = handleMessage l sm                             step False _ = return Nothing                   handleOnIndex i sm z = mapM step $ zip [0..] $ W.integrate z-                      where step (j, (G l _)) | i == j = handleMessage l sm+                      where step (j, G l _) | i == j = handleMessage l sm                             step _ = return Nothing  @@ -332,10 +338,10 @@ 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,35 +367,55 @@                 -> Zipper (Group l Window)                 -> 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+-- ** 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', ident :~ ids) =  gen $ seed g -- gen generates an infinite list+        g' = flip modifyGroups g $ f (ID ident $ baseLayout g)+                                   >>> toTags+                                   >>> foldr (reID g) ((ids, []), [])+                                   >>> snd+                                   >>> fromTags+    in if groups g == groups g'+       then Nothing+       else Just g' { seed = seed' } +applySpecX :: ModifySpecX -> Groups l l2 Window -> X (Maybe (Groups l l2 Window))+applySpecX f g = do+    let (seed', ident :~ ids) = gen $ seed g -- gen generates an infinite list+    g' <- flip modifyGroupsX g $ f (ID ident $ baseLayout g)+                                >>> fmap toTags+                                >>> fmap (foldr (reID g) ((ids, []), []))+                                >>> fmap snd+                                >>> fmap fromTags+    return $ if groups g == groups g'+             then Nothing+             else Just g' { seed = seed' } +reID :: Groups l l2 Window+     -> Either (Group l Window) (Group l Window)+     -> ((Stream Uniq, [Uniq]), [Either (Group l Window) (Group l Window)])+     -> ((Stream Uniq, [Uniq]), [Either (Group l Window) (Group l Window)])+reID g eg ((ident :~ ids, seen), egs)+    | myID `elem` seen = ((ids, seen), mapE_ (setID ident) eg:egs)+    | otherwise = ((ident :~ ids, myID:seen), eg:egs)+  where myID = getID $ gLayout $ fromE eg+        setID id (G (ID _ _) z) = G (ID id $ baseLayout g) z  -- ** Misc. ModifySpecs  -- | helper onFocused :: (Zipper Window -> Zipper Window) -> ModifySpec-onFocused f _ gs = onFocusedZ (onZipper f) gs+onFocused f _ = onFocusedZ (onZipper f)  -- | Swap the focused window with the previous one. swapUp :: ModifySpec
XMonad/Layout/Groups/Examples.hs view
@@ -1,9 +1,13 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE MultiParamTypeClasses, Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Groups.Examples+-- Description :  Example layouts for "XMonad.Layout.Groups". -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -36,7 +40,7 @@                                      , mirrorTallTabs                                      , fullTabs                                      , TiledTabsConfig(..)-                                     , defaultTiledTabsConfig+                                     , def                                      , increaseNMasterGroups                                      , decreaseNMasterGroups                                      , shrinkMasterGroups@@ -47,21 +51,18 @@                                        -- * Useful re-exports and utils                                      , module XMonad.Layout.Groups.Helpers                                      , shrinkText-                                     , defaultTheme                                      , GroupEQ(..)                                      , zoomRowG                                      ) where -import XMonad hiding ((|||))+import XMonad  import qualified XMonad.Layout.Groups as G import XMonad.Layout.Groups.Helpers  import XMonad.Layout.ZoomRow import XMonad.Layout.Tabbed-import XMonad.Layout.Named import XMonad.Layout.Renamed-import XMonad.Layout.LayoutCombinators import XMonad.Layout.Decoration import XMonad.Layout.Simplest @@ -75,7 +76,7 @@ -- -- > import XMonad.Layout.Groups.Examples ----- to the top of your @.\/.xmonad\/xmonad.hs@.+-- to the top of your @xmonad.hs@. -- -- For more information on using any of the layouts, jump directly --   to its \"Example\" section.@@ -86,8 +87,8 @@ --   the "XMonad.Layout.Groups.Helpers" module, which are all --   re-exported by this module. ----- For more information on how to extend your layour hook and key bindings, see---   "XMonad.Doc.Extending".+-- For more information on how to extend your layoutHook and key bindings, see+-- <https://xmonad.org/TUTORIAL.html the tutorial> and "XMonad.Doc.Extending".   -- * Helper: ZoomRow of Group elements@@ -134,20 +135,20 @@  -- | Increase the width of the focused column zoomColumnIn :: X ()-zoomColumnIn = sendMessage $ G.ToEnclosing $ SomeMessage $ zoomIn+zoomColumnIn = sendMessage $ G.ToEnclosing $ SomeMessage zoomIn  -- | Decrease the width of the focused column zoomColumnOut :: X ()-zoomColumnOut = sendMessage $ G.ToEnclosing $ SomeMessage $ zoomOut+zoomColumnOut = sendMessage $ G.ToEnclosing $ SomeMessage zoomOut  -- | Reset the width of the focused column zoomColumnReset :: X ()-zoomColumnReset = sendMessage $ G.ToEnclosing $ SomeMessage $ zoomReset+zoomColumnReset = sendMessage $ G.ToEnclosing $ SomeMessage zoomReset  -- | Toggle whether the currently focused column should -- take up all available space whenever it has focus toggleColumnFull :: X ()-toggleColumnFull = sendMessage $ G.ToEnclosing $ SomeMessage $ ZoomFullToggle+toggleColumnFull = sendMessage $ G.ToEnclosing $ SomeMessage ZoomFullToggle  -- | Increase the heigth of the focused window zoomWindowIn :: X ()@@ -180,9 +181,9 @@ -- You can use any of these three layouts by including it in your layout hook. -- You will need to provide it with a 'TiledTabsConfig' containing the size -- parameters for 'Tall' and 'Mirror' 'Tall', and the shrinker and decoration theme--- for the tabs. If you're happy with defaults, you can use 'defaultTiledTabsConfig':+-- for the tabs. If you're happy with defaults, you can use 'def': ----- > myLayout = tallTabs defaultTiledTabsConfig+-- > myLayout = tallTabs def -- -- To be able to increase\/decrease the number of master groups and shrink\/expand -- the master area, you can create key bindings for the relevant actions:@@ -201,8 +202,8 @@                              , tabsShrinker :: s                              , tabsTheme :: Theme } -defaultTiledTabsConfig :: TiledTabsConfig DefaultShrinker-defaultTiledTabsConfig = TTC 1 0.5 (3/100) 1 0.5 (3/100) shrinkText defaultTheme+instance s ~ DefaultShrinker => Default (TiledTabsConfig s) where+    def = TTC 1 0.5 (3/100) 1 0.5 (3/100) shrinkText def  fullTabs c = _tab c $ G.group _tabs $ Full ||| _vert c ||| _horiz c @@ -210,13 +211,13 @@  mirrorTallTabs c = _tab c $ G.group _tabs $ _horiz c ||| Full ||| _vert c -_tabs = named "Tabs" Simplest+_tabs = renamed [Replace "Tabs"] Simplest  _tab c l = renamed [CutWordsLeft 1] $ addTabs (tabsShrinker c) (tabsTheme c) l -_vert c = named "Vertical" $ Tall (vNMaster c) (vIncrement c) (vRatio c)+_vert c = renamed [Replace "Vertical"] $ Tall (vNMaster c) (vIncrement c) (vRatio c) -_horiz c = named "Horizontal" $ Mirror $ Tall (hNMaster c) (hIncrement c) (hRatio c)+_horiz c = renamed [Replace "Horizontal"] $ Mirror $ Tall (hNMaster c) (hIncrement c) (hRatio c)  -- | Increase the number of master groups by one increaseNMasterGroups :: X ()@@ -228,13 +229,12 @@  -- | Shrink the master area shrinkMasterGroups :: X ()-shrinkMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage $ Shrink+shrinkMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage Shrink  -- | Expand the master area expandMasterGroups :: X ()-expandMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage $ Expand+expandMasterGroups = sendMessage $ G.ToEnclosing $ SomeMessage Expand  -- | Rotate the available outer layout algorithms nextOuterLayout :: X ()-nextOuterLayout = sendMessage $ G.ToEnclosing $ SomeMessage $ NextLayout-+nextOuterLayout = sendMessage $ G.ToEnclosing $ SomeMessage NextLayout
XMonad/Layout/Groups/Helpers.hs view
@@ -1,9 +1,10 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE MultiParamTypeClasses, Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses, Rank2Types, ViewPatterns #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Groups.Helpers+-- Description :  Utility functions for "XMonad.Layout.Groups". -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -45,9 +46,9 @@  import qualified XMonad.Layout.Groups as G -import XMonad.Actions.MessageFeedback+import XMonad.Actions.MessageFeedback (sendMessageB) -import Control.Monad (unless)+import XMonad.Prelude (unless) import qualified Data.Map as M  -- $usage@@ -57,7 +58,7 @@ -- -- > import XMonad.Layout.Groups.Helpers ----- to the top of your @.\/.xmonad\/xmonad.hs@.+-- to the top of your @xmonad.hs@. -- -- "XMonad.Layout.Groups"-based layouts do not have the same notion -- of window ordering as the rest of XMonad. For this reason, the usual@@ -82,8 +83,8 @@ -- -- > import qualified XMonad.Layout.Groups as G ----- For more information on how to extend your layour hook and key bindings, see--- "XMonad.Doc.Extending".+-- For more information on how to extend your layoutHook and key bindings, see+-- <https://xmonad.org/TUTORIAL.html the tutorial> and "XMonad.Doc.Extending".  -- ** Layout-generic actions -- #Layout-generic actions#@@ -92,7 +93,7 @@ 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@@ -135,7 +136,7 @@  ifFloat :: X () -> X () -> X () ifFloat x1 x2 = withFocused $ \w -> do floats <- getFloats-                                       if elem w floats then x1 else x2+                                       if w `elem` floats then x1 else x2  focusNonFloat :: X () focusNonFloat = alt2 G.Refocus helper@@ -143,7 +144,7 @@                      ws <- getWindows                      floats <- getFloats                      let (before,  after) = span (/=w) ws-                     case filter (flip notElem floats) $ after ++ before of+                     case filter (`notElem` floats) $ after ++ before of                        [] -> return ()                        w':_ -> focus w' @@ -154,7 +155,7 @@             -> X () focusHelper f g = withFocused $ \w -> do                  ws <- getWindows-                 let (before, _:after) = span (/=w) ws+                 let (before, drop 1 -> after) = span (/=w) ws                  let toFocus = g $ after ++ before                  floats <- getFloats                  case filter (f . flip elem floats) toFocus of@@ -178,7 +179,7 @@ -- ** Groups-specific actions  wrap :: G.ModifySpec -> X ()-wrap = sendMessage . G.Modify+wrap x = sendMessage (G.Modify x)  -- | Swap the focused group with the previous one swapGroupUp :: X ()
XMonad/Layout/Groups/Wmii.hs view
@@ -4,6 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Groups.Wmii+-- Description :  A wmii-like layout algorithm. -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -30,19 +31,17 @@                                     -- * Useful re-exports                                  , shrinkText-                                 , defaultTheme+                                 , def                                  , module XMonad.Layout.Groups.Helpers ) where -import XMonad hiding ((|||))+import XMonad  import qualified XMonad.Layout.Groups as G import XMonad.Layout.Groups.Examples import XMonad.Layout.Groups.Helpers  import XMonad.Layout.Tabbed-import XMonad.Layout.Named import XMonad.Layout.Renamed-import XMonad.Layout.LayoutCombinators import XMonad.Layout.MessageControl import XMonad.Layout.Simplest @@ -67,11 +66,11 @@ -- -- > import XMonad.Layout.Groups.Wmii ----- to the top of your @.\/.xmonad\/xmonad.hs@, and adding 'wmii'+-- to the top of your @xmonad.hs@, and adding 'wmii' -- (with a 'Shrinker' and decoration 'Theme' as -- parameters) to your layout hook, for example: ----- > myLayout = wmii shrinkText defaultTheme+-- > myLayout = wmii shrinkText def -- -- To be able to zoom in and out of groups, change their inner layout, etc., -- create key bindings for the relevant actions:@@ -80,8 +79,8 @@ -- -- and so on. ----- For more information on how to extend your layout hook and key bindings, see--- "XMonad.Doc.Extending".+-- For more information on how to extend your layoutHook and key bindings, see+-- <https://xmonad.org/TUTORIAL.html the tutorial> and "XMonad.Doc.Extending". -- -- Finally, you will probably want to be able to move focus and windows -- between groups in a consistent fashion. For this, you should take a look@@ -90,8 +89,8 @@  -- | A layout inspired by wmii wmii s t = G.group innerLayout zoomRowG-    where column = named "Column" $ Tall 0 (3/100) (1/2)-          tabs = named "Tabs" $ Simplest+    where column = renamed [Replace "Column"] $ Tall 0 (3/100) (1/2)+          tabs = renamed [Replace "Tabs"] Simplest           innerLayout = renamed [CutWordsLeft 3]                         $ addTabs s t                         $ ignore NextLayout@@ -113,7 +112,7 @@ -- | Toggle whether the currently focused group should be maximized -- whenever it has focus. toggleGroupFull :: X ()-toggleGroupFull = toggleGroupFull+toggleGroupFull = toggleColumnFull  -- | Rotate the layouts in the focused group. groupToNextLayout :: X ()@@ -130,4 +129,3 @@ -- | Switch the focused group to the \"column\" layout. groupToVerticalLayout :: X () groupToVerticalLayout = sendMessage $ escape $ JumpToLayout "Column"-
+ XMonad/Layout/Hidden.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards #-}++----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.Hidden+-- Description :  Hide windows from layouts.+-- Copyright   :  (c) Peter Jones 2015+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  pjones@devalot.com+-- Stability   :  unstable+-- Portability :  not portable+--+-- Similar to "XMonad.Layout.Minimize" but completely removes windows+-- from the window set so "XMonad.Layout.BoringWindows" isn't+-- necessary.  Perfect companion to+-- "XMonad.Layout.BinarySpacePartition" since it can be used to move+-- windows to another part of the BSP tree.+--+-----------------------------------------------------------------------------+module XMonad.Layout.Hidden+       ( -- * Usage+         -- $usage+         HiddenWindows+       , HiddenMsg (..)+       , hiddenWindows+       , hideWindow+       , popOldestHiddenWindow+       , popNewestHiddenWindow+       , popHiddenWindow+       ) where++--------------------------------------------------------------------------------+import XMonad+import XMonad.Layout.LayoutModifier+import qualified XMonad.StackSet as W++--------------------------------------------------------------------------------+-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Layout.Hidden+--+-- Then edit your @layoutHook@ by adding the @HiddenWindows@ layout modifier:+--+-- > myLayout = hiddenWindows (Tall 1 (3/100) (1/2)) ||| Full ||| etc..+-- > main = xmonad def { layoutHook = myLayout }+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".+--+-- In the key bindings, do something like:+--+-- >        , ((modMask, xK_backslash), withFocused hideWindow)+-- >        , ((modMask .|. shiftMask, xK_backslash), popOldestHiddenWindow)+-- >        ...+--+-- For detailed instruction on editing the key bindings see:+--+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.++--------------------------------------------------------------------------------+newtype HiddenWindows a = HiddenWindows [Window] deriving (Show, Read)++--------------------------------------------------------------------------------+-- | Messages for the @HiddenWindows@ layout modifier.+data HiddenMsg = HideWindow Window                -- ^ Hide a window.+               | PopNewestHiddenWindow            -- ^ Restore window (FILO).+               | PopOldestHiddenWindow            -- ^ Restore window (FIFO).+               | PopSpecificHiddenWindow Window   -- ^ Restore specific window.+               deriving (Eq)++instance Message HiddenMsg++--------------------------------------------------------------------------------+instance LayoutModifier HiddenWindows Window where+  handleMess h@(HiddenWindows hidden) mess+    | Just (HideWindow win)              <- fromMessage mess = hideWindowMsg h win+    | Just PopNewestHiddenWindow         <- fromMessage mess = popNewestMsg h+    | Just PopOldestHiddenWindow         <- fromMessage mess = popOldestMsg h+    | Just (PopSpecificHiddenWindow win) <- fromMessage mess = popSpecificMsg win h+    | Just ReleaseResources              <- fromMessage mess = doUnhook+    | otherwise                                        = return Nothing+    where doUnhook = do mapM_ restoreWindow hidden+                        return Nothing++  modifierDescription _ = "Hidden"++--------------------------------------------------------------------------------+-- | Apply the @HiddenWindows@ layout modifier.+hiddenWindows :: LayoutClass l Window => l Window -> ModifiedLayout HiddenWindows l Window+hiddenWindows = ModifiedLayout $ HiddenWindows []++--------------------------------------------------------------------------------+-- | Remove the given window from the current layout.  It is placed in+-- list of hidden windows so it can be restored later.+hideWindow :: Window -> X ()+hideWindow = sendMessage . HideWindow++--------------------------------------------------------------------------------+-- | Restore a previously hidden window.  Using this function will+-- treat the list of hidden windows as a FIFO queue.  That is, the+-- first window hidden will be restored.+popOldestHiddenWindow :: X ()+popOldestHiddenWindow = sendMessage PopOldestHiddenWindow++--------------------------------------------------------------------------------+-- | Restore a previously hidden window.  Using this function will+-- treat the list of hidden windows as a FILO queue.  That is, the+-- most recently hidden window will be restored.+popNewestHiddenWindow :: X ()+popNewestHiddenWindow = sendMessage PopNewestHiddenWindow++popHiddenWindow :: Window -> X ()+popHiddenWindow = sendMessage . PopSpecificHiddenWindow++--------------------------------------------------------------------------------+hideWindowMsg :: HiddenWindows a -> Window -> X (Maybe (HiddenWindows a))+hideWindowMsg (HiddenWindows hidden) win = do+  modifyWindowSet $ W.delete' win+  return . Just . HiddenWindows $ hidden ++ [win]++--------------------------------------------------------------------------------+popNewestMsg :: HiddenWindows a -> X (Maybe (HiddenWindows a))+popNewestMsg (HiddenWindows [])     = return Nothing+popNewestMsg (HiddenWindows hidden) = do+  let (win, rest) = (last hidden, init hidden)+  restoreWindow win+  return . Just . HiddenWindows $ rest++--------------------------------------------------------------------------------+popOldestMsg :: HiddenWindows a -> X (Maybe (HiddenWindows a))+popOldestMsg (HiddenWindows [])         = return Nothing+popOldestMsg (HiddenWindows (win:rest)) = do+  restoreWindow win+  return . Just . HiddenWindows $ rest++--------------------------------------------------------------------------------+popSpecificMsg :: Window -> HiddenWindows a -> X (Maybe (HiddenWindows a))+popSpecificMsg _   (HiddenWindows []) = return Nothing+popSpecificMsg win (HiddenWindows hiddenWins) = if win `elem` hiddenWins+  then do+    restoreWindow win+    return . Just . HiddenWindows $ filter (/= win) hiddenWins+  else+    return . Just . HiddenWindows $ hiddenWins++--------------------------------------------------------------------------------+restoreWindow :: Window -> X ()+restoreWindow = windows . W.insertUp
XMonad/Layout/HintedGrid.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.HintedGrid+-- Description :  A layout that puts all windows in a square grid while obeying their size hints. -- Copyright   :  (c) Lukas Mai -- License     :  BSD-style (see LICENSE) --@@ -24,10 +25,10 @@ import Prelude hiding ((.))  import XMonad+import XMonad.Prelude (replicateM, sortBy, sortOn) import XMonad.StackSet -import Control.Monad.State-import Data.List+import Control.Monad.State (runState) import Data.Ord  infixr 9 .@@ -35,14 +36,14 @@ (.) = fmap  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.HintedGrid -- -- Then edit your @layoutHook@ by adding the 'Grid' layout: -- -- > myLayout = Grid False ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- You can also specify an aspect ratio for Grid to strive for with the -- GridRatio constructor:@@ -50,6 +51,7 @@ -- > myLayout = GridRatio (4/3) False ||| etc. -- -- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and -- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | Automatic mirroring of hinted layouts doesn't work very well, so this@@ -62,15 +64,15 @@  instance LayoutClass Grid Window where     doLayout (Grid m)        r w = doLayout (GridRatio defaultRatio m) r w-    doLayout (GridRatio d m) r w = flip (,) Nothing . arrange d m r (integrate w)+    doLayout (GridRatio d m) r w = (, Nothing) . arrange d m r (integrate w)  replicateS :: Int -> (a -> (b, a)) -> a -> ([b], a) replicateS n f = runState . replicateM n $ do (a,s) <- gets f; put s; return a -doColumn :: Dimension -> Dimension -> Dimension -> [(D -> D)] -> [D]+doColumn :: Dimension -> Dimension -> Dimension -> [D -> D] -> [D] doColumn width height k adjs =     let-        (ind, fs) = unzip . sortBy (comparing $ snd . ($ (width, height)) . snd) . zip [0 :: Int ..] $ adjs+        (ind, fs) = unzip . sortOn (snd . ($ (width, height)) . snd) . zip [0 :: Int ..] $ adjs         (_, ds) = doC height k fs     in     map snd . sortBy (comparing fst) . zip ind $ ds@@ -96,7 +98,7 @@             hoffset = hsingle `div` 2             width' = width - maxw             ys = map ((height -) . subtract hoffset) . scanl1 (+) . map (hsingle +) $ hs-            xs = map ((width' +) . (`div` 2) . (maxw -)) $ ws+            xs = map ((width' +) . (`div` 2) . (maxw -)) ws         in         zipWith3 (\x y (w, h) -> Rectangle (fromIntegral x) (fromIntegral y) w h) xs ys c' ++ doR width' (n - 1) cs
XMonad/Layout/HintedTile.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.HintedTile+-- Description :  A gapless tiled layout that obeys window size hints. -- Copyright   :  (c) Peter De Wachter <pdewacht@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -23,10 +24,10 @@  import XMonad hiding (Tall(..)) import qualified XMonad.StackSet as W-import Control.Monad+import XMonad.Prelude  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.HintedTile --@@ -38,16 +39,16 @@ -- >      nmaster    = 1 -- >      ratio      = 1/2 -- >      delta      = 3/100--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- Because both Xmonad and Xmonad.Layout.HintedTile define Tall, -- you need to disambiguate Tall. If you are replacing the -- built-in Tall with HintedTile, change @import Xmonad@ to -- @import Xmonad hiding (Tall)@. ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  data HintedTile a = HintedTile     { nmaster     :: !Int         -- ^ number of windows in the master pane@@ -67,7 +68,7 @@     deriving ( Show, Read, Eq, Ord )  instance LayoutClass HintedTile Window where-    doLayout (HintedTile { orientation = o, nmaster = nm, frac = f, alignment = al }) r w' = do+    doLayout HintedTile{ orientation = o, nmaster = nm, frac = f, alignment = al } r w' = do         bhs <- mapM mkAdjust w         let (masters, slaves) = splitAt nm bhs         return (zip w (tiler masters slaves), Nothing)@@ -98,15 +99,15 @@     where     (w, h) = bh (sw, sh) -divide al Tall (bh:bhs) (Rectangle sx sy sw sh) = (Rectangle (align al sx sw w) sy w h) :-      (divide al Tall bhs (Rectangle sx (sy + fromIntegral h) sw (sh - h)))+divide al Tall (bh:bhs) (Rectangle sx sy sw sh) = Rectangle (align al sx sw w) sy w h :+      divide al Tall bhs (Rectangle sx (sy + fromIntegral h) sw (sh - h))  where-    (w, h) = bh (sw, sh `div` fromIntegral (1 + (length bhs)))+    (w, h) = bh (sw, sh `div` fromIntegral (1 + length bhs)) -divide al Wide (bh:bhs) (Rectangle sx sy sw sh) = (Rectangle sx (align al sy sh h) w h) :-      (divide al Wide bhs (Rectangle (sx + fromIntegral w) sy (sw - w) sh))+divide al Wide (bh:bhs) (Rectangle sx sy sw sh) = Rectangle sx (align al sy sh h) w h :+      divide al Wide bhs (Rectangle (sx + fromIntegral w) sy (sw - w) sh)  where-    (w, h) = bh (sw `div` fromIntegral (1 + (length bhs)), sh)+    (w, h) = bh (sw `div` fromIntegral (1 + length bhs), sh)  -- Split the screen into two rectangles, using a rational to specify the ratio split :: Orientation -> Rational -> Rectangle -> (Rectangle -> [Rectangle])
XMonad/Layout/IM.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.IM+-- Description :  Layout modfier for multi-windowed instant messengers like Psi or Tkabber. -- Copyright   :  (c) Roman Cheplyaka, Ivan N. Veselov <veselov@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -29,13 +30,16 @@ ) where  import XMonad-import qualified XMonad.StackSet as S import XMonad.Layout.Grid import XMonad.Layout.LayoutModifier+import XMonad.Prelude import XMonad.Util.WindowProperties+import qualified XMonad.StackSet as S +import Control.Arrow (first)+ -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.IM -- > import Data.Ratio ((%))@@ -45,16 +49,16 @@ -- to consider is Tabbed layout). -- -- > myLayout = withIM (1%7) (ClassName "Tkabber") Grid ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- Here @1%7@ is the part of the screen which your roster will occupy, -- @ClassName \"Tkabber\"@ tells xmonad which window is actually your roster. -- -- Screenshot: <http://haskell.org/haskellwiki/Image:Xmonad-layout-im.png> ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- $hints --@@ -97,20 +101,15 @@             -> X ([(Window, Rectangle)], Maybe (l Window)) applyIM ratio prop wksp rect = do     let stack = S.stack wksp-    let ws = S.integrate' $ stack+    let ws = S.integrate' stack     let (masterRect, slaveRect) = splitHorizontallyBy ratio rect     master <- findM (hasProperty prop) ws     case master of         Just w -> do             let filteredStack = stack >>= S.filter (w /=)             wrs <- runLayout (wksp {S.stack = filteredStack}) slaveRect-            return ((w, masterRect) : fst wrs, snd wrs)+            return (first ((w, masterRect) :) wrs)         Nothing -> runLayout wksp rect---- | Like find, but works with monadic computation instead of pure function.-findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-findM _ [] = return Nothing-findM f (x:xs) = do { b <- f x; if b then return (Just x) else findM f xs }  -- | This is for compatibility with old configs only and will be removed in future versions! data IM a = IM Rational Property deriving (Read, Show)
+ XMonad/Layout/IfMax.hs view
@@ -0,0 +1,94 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.IfMax+-- Description :  Decide upon a layout depending on the number of windows.+-- Copyright   :  (c) 2013 Ilya Portnov+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Ilya Portnov <portnov84@rambler.ru>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides IfMax layout, which will run one layout if there are maximum N+-- windows on workspace, and another layout, when number of windows is greater+-- than N.+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, PatternGuards #-}++module XMonad.Layout.IfMax+    ( -- * Usage+      -- $usage+      IfMax (..)+    , ifMax+    ) where++import Control.Arrow ((&&&))+import qualified Data.List as L+import qualified Data.Map  as M++import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W++-- $usage+-- IfMax layout will run one layout if number of windows on workspace is as+-- maximum N, and else will run another layout.+--+-- You can use this module by adding following in your @xmonad.hs@:+--+-- > import XMonad.Layout.IfMax+--+-- Then add layouts to your layoutHook:+--+-- > myLayoutHook = IfMax 2 Full (Tall ...) ||| ...+--+-- In this example, if there are 1 or 2 windows, Full layout will be used;+-- otherwise, Tall layout will be used.+--++data IfMax l1 l2 w = IfMax Int (l1 w) (l2 w)+  deriving (Read, Show)++instance (LayoutClass l1 Window, LayoutClass l2 Window) => LayoutClass (IfMax l1 l2) Window where++  runLayout (W.Workspace wname (IfMax n l1 l2) s) rect = withWindowSet $ \ws -> arrange (W.integrate' s) (M.keys . W.floating $ ws)+    where+      arrange ws fw | length (ws L.\\ fw) <= n = do+                                    (wrs, ml1') <- runLayout (W.Workspace wname l1 s) rect+                                    let l1' = fromMaybe l1 ml1'+                                    l2' <- fromMaybe l2 <$> handleMessage l2 (SomeMessage Hide)+                                    return (wrs, Just $ IfMax n l1' l2')+                    | otherwise      = do+                                    (wrs, ml2') <- runLayout (W.Workspace wname l2 s) rect+                                    l1' <- fromMaybe l1 <$> handleMessage l1 (SomeMessage Hide)+                                    let l2' = fromMaybe l2 ml2'+                                    return (wrs, Just $ IfMax n l1' l2')++  handleMessage (IfMax n l1 l2) m | Just ReleaseResources <- fromMessage m = do+      l1' <- handleMessage l1 (SomeMessage ReleaseResources)+      l2' <- handleMessage l2 (SomeMessage ReleaseResources)+      if isNothing l1' && isNothing l2'+         then return Nothing+         else return $ Just $ IfMax n (fromMaybe l1 l1') (fromMaybe l2 l2')+  handleMessage (IfMax n l1 l2) m = do+      (allWindows, floatingWindows) <- gets ((W.integrate' . W.stack . W.workspace . W.current &&& M.keys . W.floating) . windowset)+      if length (allWindows L.\\ floatingWindows) <= n+        then do+          l1' <- handleMessage l1 m+          return $ flip (IfMax n) l2 <$> l1'+        else do+          l2' <- handleMessage l2 m+          return $ IfMax n l1 <$> l2'++  description (IfMax n l1 l2) = "If number of windows is <= " ++ show n ++ ", then " +++                                description l1 ++ ", else " ++ description l2++-- | Layout itself+ifMax :: (LayoutClass l1 w, LayoutClass l2 w)+      => Int            -- ^ Maximum number of windows for the first layout+      -> l1 w           -- ^ First layout+      -> l2 w           -- ^ Second layout+      -> IfMax l1 l2 w+ifMax = IfMax
XMonad/Layout/ImageButtonDecoration.hs view
@@ -2,6 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ImageButtonDecoration+-- Description :  Decoration that includes image buttons, executing actions when clicked on. -- Copyright   :  (c) Jan Vornberger 2009 --                    Alejandro Serrano 2010 -- License     :  BSD3-style (see LICENSE)@@ -28,6 +29,9 @@       -- $usage       imageButtonDeco     , defaultThemeWithImageButtons+    , shrinkText+    , CustomShrink(CustomShrink)+    , Shrinker     , imageTitleBarButtonHandler     , ImageButtonDecoration     ) where@@ -38,20 +42,20 @@ import XMonad.Util.Image  import XMonad.Actions.WindowMenu-import XMonad.Layout.Minimize+import XMonad.Actions.Minimize import XMonad.Layout.Maximize  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.ImageButtonDecoration -- -- Then edit your @layoutHook@ by adding the ImageButtonDecoration to -- your layout: ----- > myL = imageButtonDeco shrinkText defaultThemeWithImageButtons (layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }+-- > myL = imageButtonDeco shrinkText defaultThemeWithImageButtons (layoutHook def)+-- > main = xmonad def { layoutHook = myL } --  -- The buttons' dimension and placements@@ -76,7 +80,7 @@ -- it easier to visualize  convertToBool' :: [Int] -> [Bool]-convertToBool' = map (\x -> x == 1)+convertToBool' = map (== 1)  convertToBool :: [[Int]] -> [[Bool]] convertToBool = map convertToBool'@@ -148,23 +152,20 @@ -- See 'defaultThemeWithImageButtons' below. imageTitleBarButtonHandler :: Window -> Int -> Int -> X Bool imageTitleBarButtonHandler mainw distFromLeft distFromRight = do-    let action = if (fi distFromLeft >= menuButtonOffset &&-                      fi distFromLeft <= menuButtonOffset + buttonSize)-                        then focus mainw >> windowMenu >> return True-                  else if (fi distFromRight >= closeButtonOffset &&-                           fi distFromRight <= closeButtonOffset + buttonSize)-                              then focus mainw >> kill >> return True-                  else if (fi distFromRight >= maximizeButtonOffset &&-                           fi distFromRight <= maximizeButtonOffset + buttonSize)-                             then focus mainw >> sendMessage (maximizeRestore mainw) >> return True-                  else if (fi distFromRight >= minimizeButtonOffset &&-                           fi distFromRight <= minimizeButtonOffset + buttonSize)-                             then focus mainw >> minimizeWindow mainw >> return True-                  else return False+    let action+          | fi distFromLeft >= menuButtonOffset &&+             fi distFromLeft <= menuButtonOffset + buttonSize = focus mainw >> windowMenu >> return True+          | fi distFromRight >= closeButtonOffset &&+            fi distFromRight <= closeButtonOffset + buttonSize = focus mainw >> kill >> return True+          | fi distFromRight >= maximizeButtonOffset &&+            fi distFromRight <= maximizeButtonOffset + buttonSize = focus mainw >> sendMessage (maximizeRestore mainw) >> return True+          | fi distFromRight >= minimizeButtonOffset &&+            fi distFromRight <= minimizeButtonOffset + buttonSize = focus mainw >> minimizeWindow mainw >> return True+          | otherwise = return False     action  defaultThemeWithImageButtons :: Theme-defaultThemeWithImageButtons = defaultTheme {+defaultThemeWithImageButtons = def {                                 windowTitleIcons = [ (menuButton, CenterLeft 3),                                                      (closeButton, CenterRight 3),                                                      (maxiButton, CenterRight 18),@@ -175,9 +176,9 @@                    -> l a -> ModifiedLayout (Decoration ImageButtonDecoration s) l a imageButtonDeco s c = decoration s c $ NFD True -data ImageButtonDecoration a = NFD Bool deriving (Show, Read)+newtype ImageButtonDecoration a = NFD Bool deriving (Show, Read)  instance Eq a => DecorationStyle ImageButtonDecoration a where     describeDeco _ = "ImageButtonDeco"-    decorationCatchClicksHook _ mainw dFL dFR = imageTitleBarButtonHandler mainw dFL dFR+    decorationCatchClicksHook _ = imageTitleBarButtonHandler     decorationAfterDraggingHook _ (mainw, _) decoWin = focus mainw >> handleScreenCrossing mainw decoWin >> return ()
XMonad/Layout/IndependentScreens.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.IndependentScreens+-- Description :  Simulate independent sets of workspaces on each screen (dwm-like). -- Copyright   :  (c) 2009 Daniel Wagner -- License     :  BSD3 --@@ -17,34 +19,37 @@     -- * Usage     -- $usage     VirtualWorkspace, PhysicalWorkspace,+    VirtualWindowSpace, PhysicalWindowSpace,     workspaces',-    withScreens, onCurrentScreen,+    withScreen, withScreens,+    onCurrentScreen,     marshallPP,+    whenCurrentOn,     countScreens,+    workspacesOn, screenOnMonitor,+    workspaceOnScreen, focusWindow', doFocus', focusScreen, focusWorkspace, nthWorkspace, withWspOnScreen,     -- * Converting between virtual and physical workspaces     -- $converting     marshall, unmarshall, unmarshallS, unmarshallW,-    marshallWindowSpace, unmarshallWindowSpace+    marshallWindowSpace, unmarshallWindowSpace, marshallSort, ) where --- for the screen stuff-import Control.Applicative((<*), liftA2)-import Control.Arrow hiding ((|||))-import Control.Monad-import Data.List+import Control.Arrow ((***)) import Graphics.X11.Xinerama import XMonad-import XMonad.StackSet hiding (filter, workspaces)-import XMonad.Hooks.DynamicLog+import XMonad.Hooks.StatusBar.PP+import XMonad.Prelude+import qualified XMonad.StackSet as W+import XMonad.Actions.OnScreen (viewOnScreen)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.IndependentScreens -- -- You can define your workspaces by calling @withScreens@: ----- > myConfig = defaultConfig { workspaces = withScreens 2 ["web", "email", "irc"] }+-- > myConfig = def { workspaces = withScreens 2 ["web", "email", "irc"] } -- -- This will create \"physical\" workspaces with distinct internal names for -- each (screen, virtual workspace) pair.@@ -53,7 +58,7 @@ -- to specific workspace names.  In the default configuration, only -- the keybindings for changing workspace do this: ----- > keyBindings conf = let m = modMask conf in fromList $+-- > keyBindings conf = let modm = modMask conf in fromList $ -- >     {- lots of other keybindings -} -- >     [((m .|. modm, k), windows $ f i) -- >         | (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9]@@ -61,7 +66,7 @@ -- -- This should change to ----- > keyBindings conf = let m = modMask conf in fromList $+-- > keyBindings conf = let modm = modMask conf in fromList $ -- >     {- lots of other keybindings -} -- >     [((m .|. modm, k), windows $ onCurrentScreen f i) -- >         | (i, k) <- zip (workspaces' conf) [xK_1 .. xK_9]@@ -72,10 +77,18 @@ -- of virtual workspaces to functions of physical workspaces, which work -- by marshalling the virtual workspace name and the currently focused -- screen into a physical workspace name.+--+-- A complete example abusing many of the functions below is available in the+-- <https://xmonad.org/configurations.html XMonad.Config.Dmwit> configuration.  type VirtualWorkspace  = WorkspaceId type PhysicalWorkspace = WorkspaceId +-- | A 'WindowSpace' whose tags are 'PhysicalWorkspace's.+type PhysicalWindowSpace = WindowSpace+-- | A 'WindowSpace' whose tags are 'VirtualWorkspace's.+type VirtualWindowSpace = WindowSpace+ -- $converting -- You shouldn't need to use the functions below very much. They are used -- internally. However, in some cases, they may be useful, and so are exported@@ -95,55 +108,168 @@ unmarshallS = fst . unmarshall unmarshallW = snd . unmarshall +-- | Get a list of all the virtual workspace names. workspaces' :: XConfig l -> [VirtualWorkspace]-workspaces' = nub . map (snd . unmarshall) . workspaces+workspaces' = nub . map unmarshallW . workspaces +-- | Specify workspace names for each screen+withScreen :: ScreenId            -- ^ The screen to make workspaces for+           -> [VirtualWorkspace]  -- ^ The desired virtual workspace names+           -> [PhysicalWorkspace] -- ^ A list of all internal physical workspace names+withScreen n = map (marshall n)++-- | Make all workspaces across the monitors bear the same names withScreens :: ScreenId            -- ^ The number of screens to make workspaces for             -> [VirtualWorkspace]  -- ^ The desired virtual workspace names             -> [PhysicalWorkspace] -- ^ A list of all internal physical workspace names-withScreens n vws = [marshall sc pws | pws <- vws, sc <- [0..n-1]]+withScreens n vws = concatMap (`withScreen` vws) [0..n-1] -onCurrentScreen :: (VirtualWorkspace -> WindowSet -> a) -> (PhysicalWorkspace -> WindowSet -> a)-onCurrentScreen f vws = screen . current >>= f . flip marshall vws+-- | Transform a function over physical workspaces into a function over virtual workspaces.+-- This is useful as it allows you to write code without caring about the current screen, i.e. to say "switch to workspace 3"+-- rather than saying "switch to workspace 3 on monitor 3".+onCurrentScreen :: (PhysicalWorkspace -> WindowSet -> a) -> (VirtualWorkspace -> WindowSet -> a)+onCurrentScreen f vws ws =+  let currentScreenId = W.screen $ W.current ws+   in f (marshall currentScreenId vws) ws +-- | Get the workspace currently active on a given screen+workspaceOnScreen :: ScreenId -> WindowSet -> Maybe PhysicalWorkspace+workspaceOnScreen screenId ws = W.tag . W.workspace <$> screenOnMonitor screenId ws++-- | Generate WindowSet transformation by providing a given function with the workspace active on a given screen.+-- This may for example be used to shift a window to another screen as follows:+--+-- > windows $ withWspOnScreen 1 W.shift+--+withWspOnScreen :: ScreenId                               -- ^ The screen to run on+         -> (PhysicalWorkspace -> WindowSet -> WindowSet) -- ^ The transformation that will be passed the workspace currently active on there+         -> WindowSet -> WindowSet+withWspOnScreen screenId operation ws = case workspaceOnScreen screenId ws of+    Just wsp -> operation wsp ws+    Nothing -> ws++-- | Get the screen that is active on a given monitor.+screenOnMonitor :: ScreenId -> WindowSet -> Maybe WindowScreen+screenOnMonitor screenId ws = find ((screenId ==) . W.screen) (W.current ws : W.visible ws)++-- | Focus a window, switching workspace on the correct Xinerama screen if neccessary.+focusWindow' :: Window -> WindowSet -> WindowSet+focusWindow' window ws+  | Just window == W.peek ws = ws+  | otherwise = case W.findTag window ws of+      Just tag -> W.focusWindow window $ focusScreen (unmarshallS tag) ws+      Nothing -> ws++-- | ManageHook to focus a window, switching workspace on the correct Xinerama screen if neccessary.+-- Useful in 'XMonad.Hooks.EwmhDesktops.setActivateHook' when using this module.+doFocus' :: ManageHook+doFocus' = doF . focusWindow' =<< ask++-- | Focus a given screen.+focusScreen :: ScreenId -> WindowSet -> WindowSet+focusScreen screenId = withWspOnScreen screenId W.view++-- | Focus the given workspace on the correct Xinerama screen.+-- An example usage can be found at `XMonad.Hooks.EwmhDesktops.setEwmhSwitchDesktopHook`+focusWorkspace :: WorkspaceId -> WindowSet -> WindowSet+focusWorkspace workspaceId = viewOnScreen (unmarshallS workspaceId) workspaceId++-- | Get the nth virtual workspace+nthWorkspace :: Int -> X (Maybe VirtualWorkspace)+nthWorkspace n = (!? n) . workspaces' <$> asks config+ -- | In case you don't know statically how many screens there will be, you can call this in main before starting xmonad.  For example, part of my config reads -- -- > main = do -- >   nScreens <- countScreens--- >   xmonad $ defaultConfig {+-- >   xmonad $ def { -- >     ...--- >     workspaces = withScreens nScreens (workspaces defaultConfig),+-- >     workspaces = withScreens nScreens (workspaces def), -- >     ... -- >     } -- countScreens :: (MonadIO m, Integral i) => m i-countScreens = liftM genericLength . liftIO $ openDisplay "" >>= liftA2 (<*) getScreenInfo closeDisplay+countScreens = fmap genericLength . liftIO $ openDisplay "" >>= liftA2 (<*) getScreenInfo closeDisplay --- | This turns a naive pretty-printer into one that is aware of the--- independent screens. That is, you can write your pretty printer to behave--- the way you want on virtual workspaces; this function will convert that--- pretty-printer into one that first filters out physical workspaces on other--- screens, then converts all the physical workspaces on this screen to their--- virtual names.+-- | This turns a pretty-printer into one that is aware of the independent screens. The+-- converted pretty-printer first filters out physical workspaces on other screens, then+-- converts all the physical workspaces on this screen to their virtual names.+-- Note that 'ppSort' still operates on physical (marshalled) workspace names,+-- otherwise functions from "XMonad.Util.WorkspaceCompare" wouldn't work.+-- If you need to sort on virtual names, see 'marshallSort'. ----- For example, if you have handles @hLeft@ and @hRight@ for bars on the left and right screens, respectively, and @pp@ is a pretty-printer function that takes a handle, you could write+-- For example, if you have have two bars on the left and right screens, respectively, and @pp@ is+-- a pretty-printer, you could apply 'marshallPP' when creating a @StatusBarConfig@ from "XMonad.Hooks.StatusBar". ----- > logHook = let log screen handle = dynamicLogWithPP . marshallPP screen . pp $ handle--- >           in log 0 hLeft >> log 1 hRight+-- A sample config looks like this:+--+-- > mySBL = statusBarProp "xmobar" $ pure (marshallPP (S 0) pp)+-- > mySBR = statusBarProp "xmobar" $ pure (marshallPP (S 1) pp)+-- > main = xmonad $ withEasySB (mySBL <> mySBR) defToggleStrutsKey def+-- marshallPP :: ScreenId -> PP -> PP-marshallPP s pp = pp {-    ppCurrent           = ppCurrent         pp . snd . unmarshall,-    ppVisible           = ppVisible         pp . snd . unmarshall,-    ppHidden            = ppHidden          pp . snd . unmarshall,-    ppHiddenNoWindows   = ppHiddenNoWindows pp . snd . unmarshall,-    ppUrgent            = ppUrgent          pp . snd . unmarshall,-    ppSort              = fmap (marshallSort s) (ppSort pp)+marshallPP s pp = pp { ppRename = ppRename pp . unmarshallW+                     , ppSort = (. workspacesOn s) <$> ppSort pp }++-- | Take a pretty-printer and turn it into one that only runs when the current+-- workspace is one associated with the given screen. The way this works is a+-- bit hacky, so beware: the 'ppOutput' field of the input will not be invoked+-- if either of the following conditions is met:+--+-- 1. The 'ppSort' of the input returns an empty list (when not given one).+--+-- 2. The 'ppOrder' of the input returns the exact string @\"\\0\"@.+--+-- For example, you can use this to create a pipe which tracks the title of the+-- window currently focused on a given screen (even if the screen is not+-- current) by doing something like this:+--+-- > ppFocus s = whenCurrentOn s def+-- >     { ppOrder  = \(_:_:title:_) -> [title]+-- >     , ppOutput = appendFile ("focus" ++ show s) . (++ "\n")+-- >     }+--+-- Sequence a few of these pretty-printers to get a log hook that keeps each+-- screen's title up-to-date.+whenCurrentOn :: ScreenId -> PP -> PP+whenCurrentOn s pp = pp+    { ppSort = do+        sorter <- ppSort pp+        pure $ \case xs@(x:_) | unmarshallS (W.tag x) == s -> sorter xs+                     _ -> []++    , ppOrder  = \case ("":_) -> ["\0"] -- we got passed no workspaces; this is the signal from ppSort that this is a boring case+                       list   -> ppOrder pp list++    , ppOutput = \case "\0"   -> pure () -- we got passed the signal from ppOrder that this is a boring case+                       output -> ppOutput pp output     } -marshallSort :: ScreenId -> ([WindowSpace] -> [WindowSpace]) -> ([WindowSpace] -> [WindowSpace])+-- | Filter workspaces that are on a given screen.+workspacesOn :: ScreenId -> [PhysicalWindowSpace] -> [PhysicalWindowSpace]+workspacesOn s = filter (\ws -> unmarshallS (W.tag ws) == s)++-- | @vSort@ is a function that sorts 'VirtualWindowSpace's with virtual names.+-- @marshallSort s vSort@ is a function which sorts 'PhysicalWindowSpace's with virtual names,+-- but keeps only the 'WindowSpace'\'s on screen @s@.+--+-- NOTE: @vSort@ operating on virtual names comes with some caveats, see+-- <https://github.com/xmonad/xmonad-contrib/issues/420 this issue> for+-- more information. You can use 'marshallSort' like in the following example:+--+-- === __Example__+--+-- > pp' :: ScreenId -> PP -> PP+-- > pp' s pp = (marshallPP s pp) { ppSort = fmap (marshallSort s) (ppSort pp) }+-- >+-- > mySBL = statusBarProp "xmobar" $ pure (pp' (S 0) pp)+-- > mySBR = statusBarProp "xmobar" $ pure (pp' (S 1) pp)+-- > main = xmonad $ withEasySB (mySBL <> mySBR) defToggleStrutsKey def+--+-- In this way, you have a custom virtual names sort on top of 'marshallPP'.+marshallSort :: ScreenId -> ([VirtualWindowSpace] -> [VirtualWindowSpace]) -> ([PhysicalWindowSpace] -> [PhysicalWindowSpace]) marshallSort s vSort = pScreens . vSort . vScreens where-    onScreen ws = unmarshallS (tag ws) == s-    vScreens    = map unmarshallWindowSpace . filter onScreen+    vScreens    = map unmarshallWindowSpace . workspacesOn s     pScreens    = map (marshallWindowSpace s)  -- | Convert the tag of the 'WindowSpace' from a 'VirtualWorkspace' to a 'PhysicalWorkspace'.@@ -151,5 +277,5 @@ -- | Convert the tag of the 'WindowSpace' from a 'PhysicalWorkspace' to a 'VirtualWorkspace'. unmarshallWindowSpace :: WindowSpace -> WindowSpace -marshallWindowSpace s ws = ws { tag = marshall s  (tag ws) }-unmarshallWindowSpace ws = ws { tag = unmarshallW (tag ws) }+marshallWindowSpace s ws = ws { W.tag = marshall s  (W.tag ws) }+unmarshallWindowSpace ws = ws { W.tag = unmarshallW (W.tag ws) }
XMonad/Layout/LayoutBuilder.hs view
@@ -1,39 +1,72 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ScopedTypeVariables   #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.LayoutBuilder--- Copyright   :  (c) 2009 Anders Engstrom <ankaan@gmail.com>+-- Description :  Send a number of windows to one rectangle and the rest to another.+--+-- Copyright   :  (c) 2009 Anders Engstrom <ankaan@gmail.com>,+--                    2011 Ilya Portnov <portnov84@rambler.ru>,+--                    2015 Peter Jones <pjones@devalot.com>+-- -- License     :  BSD3-style (see LICENSE) ----- Maintainer  :  Anders Engstrom <ankaan@gmail.com>+-- Maintainer  :  Anders Engstrom <ankaan@gmail.com>,+--                Ilya Portnov <portnov84@rambler.ru>,+--                Peter Jones <pjones@devalot.com>+-- -- Stability   :  unstable -- Portability :  unportable -- -- A layout combinator that sends a specified number of windows to one rectangle--- and the rest to another.+-- and the rest to another. Each of these rectangles are given a layout that+-- is used within them. This can be chained to provide an arbitrary number of+-- rectangles. The layout combinator allows overlapping rectangles, but such+-- layouts does not work well together with hinting+-- ("XMonad.Layout.LayoutHints", "XMonad.Layout.HintedGrid" etc.) -- ------------------------------------------------------------------------------ module XMonad.Layout.LayoutBuilder (   -- * Usage   -- $usage   layoutN,   layoutR,+  layoutP,   layoutAll,++  -- * Selecting Windows+  -- $selectWin+  Predicate (..),+  Proxy(..),++  -- * Messages   IncLayoutN (..),++  -- * Utilities   SubMeasure (..),   SubBox (..),   absBox,   relBox,+  LayoutB,   LayoutN, ) where +import Data.Maybe (maybeToList) import XMonad+import XMonad.Prelude (foldM, (<|>), isJust, fromMaybe, isNothing, listToMaybe) import qualified XMonad.StackSet as W-import Data.Maybe (isJust)+import XMonad.Util.Stack (zipperFocusedAtFirstOf)+import XMonad.Util.WindowProperties +-------------------------------------------------------------------------------- -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.LayoutBuilder --@@ -49,22 +82,32 @@ -- >             ( (layoutN 1 (absBox (-512-200) 0 512        0) (Just $ relBox 0 0 1 1) $ simpleTabbed) -- >             $ (layoutN 1 (absBox (-200)     0 0          0) Nothing                 $ simpleTabbed) -- >             $ (layoutAll (absBox 0          0 (-512-200) 0)                         $ simpleTabbed)+-- >             ) |||+-- >             ( (layoutN 1 (absBox 10 0 0 (-10)) Nothing $ Tall 0 0.01 0.5)+-- >             $ (layoutN 1 (absBox 0 0 200 0) Nothing $ Tall 0 0.01 0.5)+-- >             $ (layoutAll (absBox 10 10 0 0) $ Tall 2 0.01 0.5) -- >             ) ||| Full ||| etc...--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- This will produce a layout similar to DragPane, but with the possibility to have multiple windows in the left half -- and tabs that show the available windows. It will also produce a layout similar to ThreeColMid and a special layout -- created for use with a 80 columns wide Emacs window, its sidebar and a tabbed area for all other windows. --+-- The final layout is for applications that use a toolbar in a separate window, shown on a low resolution screen. It has+-- a master area that cover almost the whole screen. It leaves 10 px to the left and 10 px at the bottom. To the left+-- the toolbar is located and can be accessed by focusing this area. It is actually 200 px wide, but usually below the+-- other windows. Similarly all other windows are tiled, but behind the master window and can be accessed by moving the+-- mouse to the bottom of the screen. Everything can also be accessed by the standard focus changing key bindings.+-- -- This module can be used to create many different custom layouts, but there are limitations. The primary limitation -- can be observed in the second and third example when there are only two columns with windows in them. The leftmost -- area is left blank. These blank areas can be avoided by placing the rectangles appropriately. -- -- These examples require "XMonad.Layout.Tabbed". ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You may wish to add the following keybindings: --@@ -73,58 +116,128 @@ -- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -type WindowNum = Either Int (Rational,Rational)+--------------------------------------------------------------------------------+-- $selectWin+--+-- 'Predicate' exists because layouts are required to be serializable, and+-- "XMonad.Util.WindowProperties" is not sufficient (for example it does not+-- allow using regular expressions).+--+-- compare "XMonad.Util.Invisible" --- | Use one layout in the specified area for a number of windows and possibly let another layout handle the rest.-data LayoutN l1 l2 a =-    LayoutN (Maybe a) (Maybe a) WindowNum SubBox (Maybe SubBox) (l1 a) (Maybe (l2 a))-    deriving (Show,Read)+-- | Type class for predicates. This enables us to manage not only Windows,+-- but any objects, for which instance Predicate is defined.+--+-- Another instance exists in XMonad.Util.WindowPropertiesRE in xmonad-extras+class Predicate p w where+  alwaysTrue     :: Proxy w -> p     -- ^ A predicate that is always True.+  checkPredicate :: p -> w -> X Bool -- ^ Check if given object (window or smth else) matches that predicate --- | Use the specified layout in the described area for N windows and send the rest of the windows to the next layout in the chain.---   It is possible to supply an alternative area that will then be used instead, if there are no windows to send to the next layout.+instance Predicate () a where+  alwaysTrue _       = ()+  checkPredicate _ _ = return True++instance Predicate Property Window where+  alwaysTrue _   = Const True+  checkPredicate = hasProperty++--------------------------------------------------------------------------------+-- | Contains no actual data, but is needed to help select the correct instance+-- of 'Predicate'+data Proxy a = Proxy++--------------------------------------------------------------------------------+-- | Information about how to split windows between layouts.+data Limit p = LimitN Int                  -- ^ See: 'layoutN'.+             | LimitR (Rational, Rational) -- ^ See: 'layoutR'.+             | LimitP p                    -- ^ See: 'layoutP'.+             deriving (Show, Read)++--------------------------------------------------------------------------------+-- | Use one layout in the specified area for a number of windows and+-- possibly let another layout handle the rest.+data LayoutB l1 l2 p a = LayoutB+    { subFocus  :: Maybe a      -- ^ The focused window in this layout.+    , nextFocus :: Maybe a      -- ^ The focused window in the next layout.+    , limit     :: Limit p      -- ^ How to split windows between layouts.+    , box       :: SubBox       -- ^ Normal size of layout.+    , mbox      :: Maybe SubBox -- ^ Size of layout when handling all windows.+    , sub       :: l1 a         -- ^ The layout to use in this box.+    , next      :: Maybe (l2 a) -- ^ The next layout in the chain.+    } deriving (Show, Read)++--------------------------------------------------------------------------------+-- | A variant of 'LayoutB' that can't use 'layoutP'.  For backwards+-- compatibility with previous versions of LayoutBuilder.+type LayoutN l1 l2 a = LayoutB l1 l2 () a++--------------------------------------------------------------------------------+-- | Use the specified layout in the described area for N windows and+-- send the rest of the windows to the next layout in the chain.  It+-- is possible to supply an alternative area that will then be used+-- instead, if there are no windows to send to the next layout. layoutN :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a, LayoutClass l3 a) =>-       Int                          -- ^ The number of windows to handle-    -> SubBox                       -- ^ The box to place the windows in-    -> Maybe SubBox                 -- ^ Possibly an alternative box that is used when this layout handles all windows that are left-    -> l1 a                         -- ^ The layout to use in the specified area-    -> LayoutN l2 l3 a              -- ^ Where to send the remaining windows-    -> LayoutN l1 (LayoutN l2 l3) a -- ^ The resulting layout-layoutN num box mbox sub next = LayoutN Nothing Nothing (Left num) box mbox sub (Just next)+       Int                               -- ^ The number of windows to handle+    -> SubBox                            -- ^ The box to place the windows in+    -> Maybe SubBox                      -- ^ Possibly an alternative box that is used when this layout handles all windows that are left+    -> l1 a                              -- ^ The layout to use in the specified area+    -> LayoutB l2 l3 p a                 -- ^ Where to send the remaining windows+    -> LayoutB l1 (LayoutB l2 l3 p) () a -- ^ The resulting layout+layoutN num box mbox sub next = LayoutB Nothing Nothing (LimitN num) box mbox sub (Just next)  -- | As layoutN, but the number of windows is given relative to the total number of windows remaining to be handled. The first --   argument is how much to change the ratio when using IncLayoutN, and the second is the initial ratio. layoutR :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a, LayoutClass l3 a) =>-       Rational                     -- ^ How much to change the ratio with each IncLayoutN-    -> Rational                     -- ^ The ratio of the remaining windows to handle-    -> SubBox                       -- ^ The box to place the windows in-    -> Maybe SubBox                 -- ^ Possibly an alternative box that is used when this layout handles all windows that are left-    -> l1 a                         -- ^ The layout to use in the specified area-    -> LayoutN l2 l3 a              -- ^ Where to send the remaining windows-    -> LayoutN l1 (LayoutN l2 l3) a -- ^ The resulting layout-layoutR numdiff num box mbox sub next = LayoutN Nothing Nothing (Right (numdiff,num)) box mbox sub (Just next)+       Rational                         -- ^ How much to change the ratio with each IncLayoutN+    -> Rational                         -- ^ The ratio of the remaining windows to handle+    -> SubBox                           -- ^ The box to place the windows in+    -> Maybe SubBox                     -- ^ Possibly an alternative box that is used when this layout handles all windows that are left+    -> l1 a                             -- ^ The layout to use in the specified area+    -> LayoutB l2 l3 p a                -- ^ Where to send the remaining windows+    -> LayoutB l1 (LayoutB l2 l3 p) p a -- ^ The resulting layout+layoutR numdiff num box mbox sub next = LayoutB Nothing Nothing (LimitR (numdiff,num)) box mbox sub (Just next) +--------------------------------------------------------------------------------+-- | Use the specified layout in the described area windows that match+-- given predicate and send the rest of the windows to the next layout+-- in the chain.  It is possible to supply an alternative area that+-- will then be used instead, if there are no windows to send to the+-- next layout.+layoutP :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a, LayoutClass l3 a, Predicate p a, Predicate p' a) =>+       p                                 -- ^ The predicate to use+    -> SubBox                            -- ^ The box to place the windows in+    -> Maybe SubBox                      -- ^ Possibly an alternative box that is used when this layout handles all windows that are left+    -> l1 a                              -- ^ The layout to use in the specified area+    -> LayoutB l2 l3 p' a                -- ^ Where to send the remaining windows+    -> LayoutB l1 (LayoutB l2 l3 p') p a -- ^ The resulting layout+layoutP prop box mbox sub next = LayoutB Nothing Nothing (LimitP prop) box mbox sub (Just next)++-------------------------------------------------------------------------------- -- | Use the specified layout in the described area for all remaining windows. layoutAll :: (Read a, Eq a, LayoutClass l1 a) =>-       SubBox             -- ^ The box to place the windows in-    -> l1 a               -- ^ The layout to use in the specified area-    -> LayoutN l1 Full a  -- ^ The resulting layout-layoutAll box sub = LayoutN Nothing Nothing (Right (0,1)) box Nothing sub Nothing+       SubBox                -- ^ The box to place the windows in+    -> l1 a                  -- ^ The layout to use in the specified area+    -> LayoutB l1 Full () a  -- ^ The resulting layout+layoutAll box sub = LayoutB Nothing Nothing (LimitR (0,1)) box Nothing sub Nothing +-------------------------------------------------------------------------------- -- | Change the number of windows handled by the focused layout.-data IncLayoutN = IncLayoutN Int deriving Typeable+newtype IncLayoutN = IncLayoutN Int instance Message IncLayoutN +-------------------------------------------------------------------------------- -- | The absolute or relative measures used to describe the area a layout should be placed in. For negative absolute values --   the total remaining space will be added. For sizes, the remaining space will also be added for zeroes. Relative values --   are applied on the remaining space after the top-left corner of the box have been removed. data SubMeasure = Abs Int | Rel Rational deriving (Show,Read) +-------------------------------------------------------------------------------- -- | A box to place a layout in. The stored values are xpos, ypos, width and height. data SubBox = SubBox SubMeasure SubMeasure SubMeasure SubMeasure deriving (Show,Read) -+-------------------------------------------------------------------------------- -- | Create a box with only absolute measurements. If the values are negative, the total remaining space will be added. For --   sizes it will also be added for zeroes. absBox :: Int     -- ^ Absolute X-Position@@ -134,7 +247,7 @@        -> SubBox  -- ^ The resulting 'SubBox' describing the area absBox x y w h = SubBox (Abs x) (Abs y) (Abs w) (Abs h) -+-------------------------------------------------------------------------------- -- | Create a box with only relative measurements. relBox :: Rational  -- ^ Relative X-Position with respect to the surrounding area        -> Rational  -- ^ Relative Y-Position with respect to the surrounding area@@ -143,133 +256,202 @@        -> SubBox    -- ^ The resulting 'SubBox' describing the area relBox x y w h = SubBox (Rel x) (Rel y) (Rel w) (Rel h) +--------------------------------------------------------------------------------+instance ( LayoutClass l1 a, LayoutClass l2 a+         , Read a, Show a, Show p, Typeable p, Eq a, Typeable a, Predicate p a+         ) => LayoutClass (LayoutB l1 l2 p) a where -instance (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) =>-    LayoutClass (LayoutN l1 l2) a where+    -- | Update window locations.+    runLayout (W.Workspace _ LayoutB {..} s) rect = do+        (subs, nexts, subFocus', nextFocus') <- splitStack s limit subFocus nextFocus -        -- | Update window locations.-        runLayout (W.Workspace _ (LayoutN subf nextf num box mbox sub next) s) rect-            = do let (subs,nexts,subf',nextf') = splitStack s num subf nextf-                     selBox = if isJust nextf'-                              then box-                              else maybe box id mbox+        let selBox = if isJust nextFocus' then box else fromMaybe box mbox -                 (sublist,sub') <- handle sub subs $ calcArea selBox rect+        (sublist, sub', schange) <- handle sub subs (calcArea selBox rect) -                 (nextlist,next') <- case next of Nothing -> return ([],Nothing)-                                                  Just n -> do (res,l) <- handle n nexts rect-                                                               return (res,Just l)+        (nextlist, next', nchange) <- case next of+          Nothing -> return ([], Nothing, False)+          Just n  -> do (res, l, ch) <- handle n nexts rect+                        return (res, Just l, ch) -                 return (sublist++nextlist, Just $ LayoutN subf' nextf' num box mbox sub' next' )-              where-                  handle l s' r = do (res,ml) <- runLayout (W.Workspace "" l s') r-                                     l' <- return $ maybe l id ml-                                     return (res,l')+        let newlist =  if length (maybe [] W.up s) < length (W.integrate' subs)+                         then sublist++nextlist+                         else nextlist++sublist -        -- |  Propagate messages.-        handleMessage l m-            | Just (IncLayoutN _) <- fromMessage m = windowNum l m-            | Just (IncMasterN _) <- fromMessage m = sendFocus l m-            | Just (Shrink) <- fromMessage m = sendFocus l m-            | Just (Expand) <- fromMessage m = sendFocus l m-            | otherwise = sendBoth l m+            newstate = if subFocus' /= subFocus || nextFocus' /= nextFocus || schange || nchange+                         then Just $ LayoutB subFocus' nextFocus' limit box mbox sub' next'+                         else Nothing -        -- |  Descriptive name for layout.-        description (LayoutN _ _ _ _ _ sub Nothing) = "layoutAll "++ description sub-        description (LayoutN _ _ (Left _) _ _ sub (Just next)) = "layoutN "++ description sub ++" "++ description next-        description (LayoutN _ _ (Right _) _ _ sub (Just next)) = "layoutR "++ description sub ++" "++ description next+        return (newlist, newstate)+      where+          handle l s' r = do (res,ml) <- runLayout (W.Workspace "" l s') r+                             return (res, fromMaybe l ml, isNothing ml) +    -- |  Propagate messages.+    handleMessage l m+        | Just (IncLayoutN n) <- fromMessage m = incLayoutN l m n+        | Just (IncMasterN _) <- fromMessage m = sendFocus  l m+        | Just Shrink         <- fromMessage m = sendFocus  l m+        | Just Expand         <- fromMessage m = sendFocus  l m+        | otherwise                            = sendBoth   l m -windowNum :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutN l1 l2 a -> SomeMessage -> X (Maybe (LayoutN l1 l2 a))-windowNum l@(LayoutN subf nextf num box mbox subl nextl) m | (Just (IncLayoutN n)) <- fromMessage m =-    do foc <- isFocus subf-       if foc then do let newnum = case num of-                                       (Left oldnum) -> Left $ max 1 $ oldnum + n-                                       (Right (diff,oldnum)) -> Right (diff, min 1 $ max 0 $ oldnum + (fromIntegral n)*diff)-                      return $ Just $ LayoutN subf nextf newnum box mbox subl nextl-              else sendNext l m-windowNum l m = sendNext l m+    -- | Descriptive name for layout.+    description layout = case layout of+        (LayoutB _ _ _ _ _ sub Nothing) ->+          "layoutAll " ++ description sub -sendSub :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutN l1 l2 a -> SomeMessage -> X (Maybe (LayoutN l1 l2 a))-sendSub (LayoutN subf nextf num box mbox sub next) m =+        (LayoutB _ _ (LimitN _) _ _ sub (Just next)) ->+          "layoutN " ++ description sub ++ " " ++ description next++        (LayoutB _ _ (LimitR _) _ _ sub (Just next)) ->+          "layoutR " ++ description sub ++ " " ++ description next++        (LayoutB _ _ (LimitP _) _ _ sub (Just next)) ->+          "layoutP " ++ description sub ++ " " ++ description next++--------------------------------------------------------------------------------+-- | Increase the number of windows allowed in the focused layout.+incLayoutN :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a)+           => LayoutB l1 l2 p a+           -> SomeMessage+           -> Int+           -> X (Maybe (LayoutB l1 l2 p a))+incLayoutN layout@LayoutB {..} message n = do+    incThis <- isFocus subFocus++    if incThis+       then return $ Just layout { limit = newLimit }+       else sendNext layout message++  where+    newLimit = case limit of+      LimitN oldnum         -> LimitN (max 1 $ oldnum + n)+      LimitR (diff, oldnum) -> LimitR (diff, min 1 $ max 0 $ oldnum + fromIntegral n * diff)+      LimitP _              -> limit++--------------------------------------------------------------------------------+sendSub :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutB l1 l2 p a -> SomeMessage -> X (Maybe (LayoutB l1 l2 p a))+sendSub (LayoutB subFocus nextFocus num box mbox sub next) m =     do sub' <- handleMessage sub m        return $ if isJust sub'-                then Just $ LayoutN subf nextf num box mbox (maybe sub id sub') next+                then Just $ LayoutB subFocus nextFocus num box mbox (fromMaybe sub sub') next                 else Nothing -sendBoth :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutN l1 l2 a -> SomeMessage -> X (Maybe (LayoutN l1 l2 a))-sendBoth l@(LayoutN _ _ _ _ _ _ Nothing) m = sendSub l m-sendBoth (LayoutN subf nextf num box mbox sub (Just next)) m =+--------------------------------------------------------------------------------+sendBoth :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutB l1 l2 p a -> SomeMessage -> X (Maybe (LayoutB l1 l2 p a))+sendBoth l@(LayoutB _ _ _ _ _ _ Nothing) m = sendSub l m+sendBoth (LayoutB subFocus nextFocus num box mbox sub (Just next)) m =     do sub' <- handleMessage sub m        next' <- handleMessage next m        return $ if isJust sub' || isJust next'-                then Just $ LayoutN subf nextf num box mbox (maybe sub id sub') (Just $ maybe next id next')+                then Just $ LayoutB subFocus nextFocus num box mbox (fromMaybe sub sub') (next' <|> Just next)                 else Nothing -sendNext :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutN l1 l2 a -> SomeMessage -> X (Maybe (LayoutN l1 l2 a))-sendNext (LayoutN _ _ _ _ _ _ Nothing) _ = return Nothing-sendNext (LayoutN subf nextf num box mbox sub (Just next)) m =+--------------------------------------------------------------------------------+sendNext :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutB l1 l2 p a -> SomeMessage -> X (Maybe (LayoutB l1 l2 p a))+sendNext (LayoutB _ _ _ _ _ _ Nothing) _ = return Nothing+sendNext (LayoutB subFocus nextFocus num box mbox sub (Just next)) m =     do next' <- handleMessage next m        return $ if isJust next'-                then Just $ LayoutN subf nextf num box mbox sub next'+                then Just $ LayoutB subFocus nextFocus num box mbox sub next'                 else Nothing -sendFocus :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutN l1 l2 a -> SomeMessage -> X (Maybe (LayoutN l1 l2 a))-sendFocus l@(LayoutN subf _ _ _ _ _ _) m = do foc <- isFocus subf-                                              if foc then sendSub l m-                                                     else sendNext l m+--------------------------------------------------------------------------------+sendFocus :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) => LayoutB l1 l2 p a -> SomeMessage -> X (Maybe (LayoutB l1 l2 p a))+sendFocus l@(LayoutB subFocus _ _ _ _ _ _) m = do+  foc <- isFocus subFocus +  if foc+    then sendSub  l m+    else sendNext l m++--------------------------------------------------------------------------------+-- | Check to see if the given window is currently focused. isFocus :: (Show a) => Maybe a -> X Bool isFocus Nothing = return False-isFocus (Just w) = do ms <- (W.stack . W.workspace . W.current) `fmap` gets windowset-                      return $ maybe False (\s -> show w == (show $ W.focus s)) ms+isFocus (Just w) = do ms <- W.stack . W.workspace . W.current <$> gets windowset+                      return $ maybe False (\s -> show w == show (W.focus s)) ms +--------------------------------------------------------------------------------+calcNum :: Int -> Limit p -> Int+calcNum tot num = max 1 $ case num of LimitN i     -> i+                                      LimitR (_,r) -> ceiling $ r * fromIntegral tot+                                      LimitP _     -> 1 -calcNum :: Int -> WindowNum -> Int-calcNum tot num = max 1 $ case num of Left i -> i-                                      Right (_,r) -> ceiling $ r * fromIntegral tot+--------------------------------------------------------------------------------+-- | Split given list of objects (i.e. windows) using predicate.+splitBy :: (Predicate p a) => p -> [a] -> X ([a], [a])+splitBy prop = foldM step ([], [])+  where+    step (good, bad) w = do+      ok <- checkPredicate prop w+      return $ if ok+                then (w:good, bad)+                else (good,   w:bad) -splitStack :: Eq a => Maybe (W.Stack a) -> WindowNum -> Maybe a -> Maybe a -> (Maybe (W.Stack a),Maybe (W.Stack a),Maybe a,Maybe a)-splitStack Nothing _ _ _ = (Nothing,Nothing,Nothing,Nothing)-splitStack (Just s) num subf nextf = ( differentiate' subf' subl-                                     , differentiate' nextf' nextl-                                     , subf'-                                     , nextf'-                                     )-    where-        ws = W.integrate s-        n = calcNum (length ws) num-        subl = take n ws-        nextl = drop n ws-        subf' = foc subl subf-        nextf' = foc nextl nextf-        foc [] _ = Nothing-        foc l f = if W.focus s `elem` l-                  then Just $ W.focus s-                  else if maybe False (`elem` l) f-                       then f-                       else Just $ head l+--------------------------------------------------------------------------------+splitStack :: forall a p. (Eq a, Predicate p a)+           => Maybe (W.Stack a) -- ^ Window set.+           -> Limit p           -- ^ How to split the stack.+           -> Maybe a           -- ^ The window that was focused in this layout.+           -> Maybe a           -- ^ The window that was focused in the next layout.+           -> X (Maybe (W.Stack a), Maybe (W.Stack a), Maybe a, Maybe a)+splitStack Nothing _ _ _ = return (Nothing, Nothing, Nothing, Nothing)+splitStack (Just s) limit subFocus nextFocus =+  case limit of+    LimitN _    -> splitN+    LimitR _    -> splitN+    LimitP prop -> splitP prop +  where+    ws        = W.integrate s+    n         = calcNum (length ws) limit+    subl      = take n ws+    nextl     = drop n ws+    subFocus' xs  = foc xs subFocus+    nextFocus' xs = foc xs nextFocus++    -- Pick a new focused window if necessary.+    foc :: [a] -> Maybe a -> Maybe a+    foc [] _                           = Nothing+    foc l f | W.focus s `elem` l       = Just (W.focus s)+            | maybe False (`elem` l) f = f+            | otherwise                = listToMaybe l++    -- Split based on max number of windows.+    splitN = return ( differentiate' (subFocus' subl)   subl+                    , differentiate' (nextFocus' nextl) nextl+                    , subFocus'  subl+                    , nextFocus' nextl+                    )++    -- Split based on a predicate.+    splitP prop = do+      (this, other) <- splitBy prop ws+      return ( differentiate' (subFocus' this)   this+             , differentiate' (nextFocus' other) other+             , subFocus' this+             , nextFocus' other+             )++-------------------------------------------------------------------------------- calcArea :: SubBox -> Rectangle -> Rectangle-calcArea (SubBox xpos ypos width height) rect = Rectangle (rect_x rect + fromIntegral xpos') (rect_y rect + fromIntegral ypos') width' height'-    where-        xpos' = calc False xpos $ rect_width rect-        ypos' = calc False ypos $ rect_height rect-        width' = calc True width $ rect_width rect - xpos'-        height' = calc True height $ rect_height rect - ypos'+calcArea (SubBox xpos ypos width height) rect =+    Rectangle (rect_x rect + fromIntegral xpos')+              (rect_y rect + fromIntegral ypos')+              width' height'+  where+    xpos' = calc False xpos $ rect_width rect+    ypos' = calc False ypos $ rect_height rect+    width' = calc True width $ rect_width rect - xpos'+    height' = calc True height $ rect_height rect - ypos' -        calc zneg val tot = fromIntegral $ min (fromIntegral tot) $ max 0 $-            case val of Rel v -> floor $ v * fromIntegral tot-                        Abs v -> if v<0 || (zneg && v==0)-                                 then (fromIntegral tot)+v-                                 else v+    calc zneg val tot = fromIntegral $ min (fromIntegral tot) $ max 0 $+        case val of Rel v -> floor $ v * fromIntegral tot+                    Abs v -> if v<0 || (zneg && v==0)+                               then fromIntegral tot + v+                               else v +-------------------------------------------------------------------------------- differentiate' :: Eq q => Maybe q -> [q] -> Maybe (W.Stack q)-differentiate' _ [] = Nothing-differentiate' Nothing w = W.differentiate w-differentiate' (Just f) w-    | f `elem` w = Just $ W.Stack { W.focus = f-                                  , W.up    = reverse $ takeWhile (/=f) w-                                  , W.down  = tail $ dropWhile (/=f) w-                                  }-    | otherwise = W.differentiate w+differentiate' = zipperFocusedAtFirstOf . maybeToList
− XMonad/Layout/LayoutBuilderP.hs 
@@ -1,210 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, PatternGuards, DeriveDataTypeable, ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module      :  XMonad.Layout.LayoutBuilderP--- Copyright   :  (c) 2009 Anders Engstrom <ankaan@gmail.com>, 2011 Ilya Portnov <portnov84@rambler.ru>--- License     :  BSD3-style (see LICENSE)------ Maintainer  :  Ilya Portnov <portnov84@rambler.ru>--- Stability   :  unstable--- Portability :  unportable------ A layout combinator that sends windows matching given predicate to one rectangle--- and the rest to another.-----------------------------------------------------------------------------------module XMonad.Layout.LayoutBuilderP (-  LayoutP (..),-  layoutP, layoutAll,-  B.relBox, B.absBox,-  -- * Overloading ways to select windows-  -- $selectWin-  Predicate (..), Proxy(..),-  ) where--import Control.Monad-import Data.Maybe (isJust)--import XMonad-import qualified XMonad.StackSet as W-import XMonad.Util.WindowProperties--import qualified XMonad.Layout.LayoutBuilder as B---- $selectWin------ 'Predicate' exists because layouts are required to be serializable, and--- "XMonad.Util.WindowProperties" is not sufficient (for example it does not--- allow using regular expressions).------ compare "XMonad.Util.Invisible"---- | Type class for predicates. This enables us to manage not only Windows,--- but any objects, for which instance Predicate is defined.------ Another instance exists in XMonad.Util.WindowPropertiesRE in xmonad-extras-class Predicate p w where-  alwaysTrue :: Proxy w -> p         -- ^ A predicate that is always True.-  checkPredicate :: p -> w -> X Bool -- ^ Check if given object (window or smth else) matches that predicate---- | Contains no actual data, but is needed to help select the correct instance--- of 'Predicate'-data Proxy a = Proxy---- | Data type for our layout.-data LayoutP p l1 l2 a =-    LayoutP (Maybe a) (Maybe a) p B.SubBox (Maybe B.SubBox) (l1 a) (Maybe (l2 a))-    deriving (Show,Read)---- | Use the specified layout in the described area windows that match given predicate and send the rest of the windows to the next layout in the chain.---   It is possible to supply an alternative area that will then be used instead, if there are no windows to send to the next layout.-layoutP :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a, LayoutClass l3 a, Predicate p a) =>-       p-    -> B.SubBox                       -- ^ The box to place the windows in-    -> Maybe B.SubBox                 -- ^ Possibly an alternative box that is used when this layout handles all windows that are left-    -> l1 a                         -- ^ The layout to use in the specified area-    -> LayoutP p l2 l3 a              -- ^ Where to send the remaining windows-    -> LayoutP p l1 (LayoutP p l2 l3) a -- ^ The resulting layout-layoutP prop box mbox sub next = LayoutP Nothing Nothing prop box mbox sub (Just next)---- | Use the specified layout in the described area for all remaining windows.-layoutAll :: forall l1 p a. (Read a, Eq a, LayoutClass l1 a, Predicate p a) =>-       B.SubBox             -- ^ The box to place the windows in-    -> l1 a               -- ^ The layout to use in the specified area-    -> LayoutP p l1 Full a  -- ^ The resulting layout-layoutAll box sub =-  let a = alwaysTrue (Proxy :: Proxy a)-  in  LayoutP Nothing Nothing a box Nothing sub Nothing--instance (LayoutClass l1 w, LayoutClass l2 w, Predicate p w, Show w, Read w, Eq w, Typeable w, Show p) =>-    LayoutClass (LayoutP p l1 l2) w where--        -- | Update window locations.-        runLayout (W.Workspace _ (LayoutP subf nextf prop box mbox sub next) s) rect-            = do (subs,nexts,subf',nextf') <- splitStack s prop subf nextf-                 let selBox = if isJust nextf'-                                then box-                                else maybe box id mbox--                 (sublist,sub') <- handle sub subs $ calcArea selBox rect--                 (nextlist,next') <- case next of Nothing -> return ([],Nothing)-                                                  Just n -> do (res,l) <- handle n nexts rect-                                                               return (res,Just l)--                 return (sublist++nextlist, Just $ LayoutP subf' nextf' prop box mbox sub' next' )-              where-                  handle l s' r = do (res,ml) <- runLayout (W.Workspace "" l s') r-                                     l' <- return $ maybe l id ml-                                     return (res,l')--        -- |  Propagate messages.-        handleMessage l m-            | Just (IncMasterN _) <- fromMessage m = sendFocus l m-            | Just (Shrink) <- fromMessage m = sendFocus l m-            | Just (Expand) <- fromMessage m = sendFocus l m-            | otherwise = sendBoth l m--        -- |  Descriptive name for layout.-        description (LayoutP _ _ _ _ _ sub (Just next)) = "layoutP "++ description sub ++" "++ description next-        description (LayoutP _ _ _ _ _ sub Nothing)     = "layoutP "++ description sub---sendSub :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a)-        => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a))-sendSub (LayoutP subf nextf prop box mbox sub next) m =-    do sub' <- handleMessage sub m-       return $ if isJust sub'-                then Just $ LayoutP subf nextf prop box mbox (maybe sub id sub') next-                else Nothing--sendBoth :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a)-         => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a))-sendBoth l@(LayoutP _ _ _ _ _ _ Nothing) m = sendSub l m-sendBoth (LayoutP subf nextf prop box mbox sub (Just next)) m =-    do sub' <- handleMessage sub m-       next' <- handleMessage next m-       return $ if isJust sub' || isJust next'-                then Just $ LayoutP subf nextf prop box mbox (maybe sub id sub') (Just $ maybe next id next')-                else Nothing--sendNext :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a)-         => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a))-sendNext (LayoutP _ _ _ _ _ _ Nothing) _ = return Nothing-sendNext (LayoutP subf nextf prop box mbox sub (Just next)) m =-    do next' <- handleMessage next m-       return $ if isJust next'-                then Just $ LayoutP subf nextf prop box mbox sub next'-                else Nothing--sendFocus :: (LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a, Predicate p a)-          => LayoutP p l1 l2 a -> SomeMessage -> X (Maybe (LayoutP p l1 l2 a))-sendFocus l@(LayoutP subf _ _ _ _ _ _) m = do foc <- isFocus subf-                                              if foc then sendSub l m-                                                     else sendNext l m--isFocus :: (Show a) => Maybe a -> X Bool-isFocus Nothing = return False-isFocus (Just w) = do ms <- (W.stack . W.workspace . W.current) `fmap` gets windowset-                      return $ maybe False (\s -> show w == (show $ W.focus s)) ms----- | Split given list of objects (i.e. windows) using predicate.-splitBy :: (Predicate p w) => p -> [w] -> X ([w], [w])-splitBy prop ws = foldM step ([], []) ws-  where-    step (good, bad) w = do-      ok <- checkPredicate prop w-      return $ if ok-                then (w:good, bad)-                else (good,   w:bad)--splitStack :: (Predicate p w, Eq w) => Maybe (W.Stack w) -> p -> Maybe w -> Maybe w -> X (Maybe (W.Stack w),Maybe (W.Stack w),Maybe w,Maybe w)-splitStack Nothing _ _ _ = return (Nothing,Nothing,Nothing,Nothing)-splitStack (Just s) prop subf nextf = do-    let ws = W.integrate s-    (good, other) <- splitBy prop ws-    let subf'  = foc good subf-        nextf' = foc other nextf-    return ( differentiate' subf' good-           , differentiate' nextf' other-           , subf'-           , nextf'-           )-  where-    foc [] _ = Nothing-    foc l f = if W.focus s `elem` l-              then Just $ W.focus s-              else if maybe False (`elem` l) f-                   then f-                   else Just $ head l--calcArea :: B.SubBox -> Rectangle -> Rectangle-calcArea (B.SubBox xpos ypos width height) rect = Rectangle (rect_x rect + fromIntegral xpos') (rect_y rect + fromIntegral ypos') width' height'-    where-        xpos' = calc False xpos $ rect_width rect-        ypos' = calc False ypos $ rect_height rect-        width' = calc True width $ rect_width rect - xpos'-        height' = calc True height $ rect_height rect - ypos'--        calc zneg val tot = fromIntegral $ min (fromIntegral tot) $ max 0 $-            case val of B.Rel v -> floor $ v * fromIntegral tot-                        B.Abs v -> if v<0 || (zneg && v==0)-                                 then (fromIntegral tot)+v-                                 else v--differentiate' :: Eq q => Maybe q -> [q] -> Maybe (W.Stack q)-differentiate' _ [] = Nothing-differentiate' Nothing w = W.differentiate w-differentiate' (Just f) w-    | f `elem` w = Just $ W.Stack { W.focus = f-                                  , W.up    = reverse $ takeWhile (/=f) w-                                  , W.down  = tail $ dropWhile (/=f) w-                                  }-    | otherwise = W.differentiate w--instance Predicate Property Window where-  alwaysTrue _ = Const True-  checkPredicate = hasProperty-
XMonad/Layout/LayoutCombinators.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Layout.LayoutCombinators+-- Description :  Easily combine multiple layouts into one composite layout. -- Copyright    : (c) David Roundy <droundy@darcs.net> -- License      : BSD --@@ -10,10 +10,7 @@ -- Portability  : portable -- -- The "XMonad.Layout.LayoutCombinators" module provides combinators--- for easily combining multiple layouts into one composite layout, as--- well as a way to jump directly to any particular layout (say, with--- a keybinding) without having to cycle through other layouts to get--- to it.+-- for easily combining multiple layouts into one composite layout. -----------------------------------------------------------------------------  module XMonad.Layout.LayoutCombinators@@ -43,48 +40,31 @@     , (*/*), (**/*),(***/*),(****/*),(***/**),(****/***)     , (***/****),(*/****),(**/***),(*/***),(*/**) -      -- * New layout choice combinator and 'JumpToLayout'-      -- $jtl+      -- * Re-exports for backwards compatibility     , (|||)     , JumpToLayout(..)--      -- * Types     , NewSelect     ) where -import Data.Maybe ( isJust, isNothing )--import XMonad hiding ((|||))-import XMonad.StackSet (Workspace (..))+import XMonad import XMonad.Layout.Combo import XMonad.Layout.DragPane  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: ----- > import XMonad.Layout.LayoutCombinators hiding ( (|||) )+-- > import XMonad.Layout.LayoutCombinators -- -- Then edit your @layoutHook@ to use the new layout combinators. For -- example: -- -- > myLayout = (Tall 1 (3/100) (1/2) *//* Full)  ||| (Tall 1 (3/100) (1/2) ***||** Full) ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the @layoutHook@ see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"------ To use the 'JumpToLayout' message, hide the normal @|||@ operator instead:------ > import XMonad hiding ( (|||) )--- > import XMonad.Layout.LayoutCombinators------ If you import XMonad.Layout, you will need to hide it from there as well.--- Then bind some keys to a 'JumpToLayout' message:+-- > main = xmonad def { layoutHook = myLayout } ----- >   , ((modm .|. controlMask, xK_f), sendMessage $ JumpToLayout "Full")  -- jump directly to the Full layout+-- For more detailed instructions on editing the @layoutHook@ see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". ----- See below for more detailed documentation.  -- $combine -- Each of the following combinators combines two layouts into a@@ -100,7 +80,7 @@          */* , **/* , ***/* , ****/* , ***/** , ****/*** , ***/**** , */**** , **/*** , */*** , */**  -- $dpv--- These combinators combine two layouts using "XMonad.DragPane" in+-- These combinators combine two layouts using "XMonad.Layout.DragPane" in -- vertical mode.  (*||*),(**||*),(***||*),(****||*), (***||**),(****||***),@@ -120,7 +100,7 @@ (*||**)     = combineTwo (dragPane Vertical 0.1 (1/3))  -- $dph--- These combinators combine two layouts using "XMonad.DragPane" in+-- These combinators combine two layouts using "XMonad.Layout.DragPane" in -- horizontal mode.  (*//*),(**//*),(***//*),(****//*), (***//**),(****//***),@@ -177,114 +157,5 @@ (*/***)    = combineTwo (Mirror $ Tall 1 0.1 (1/4)) (*/**)     = combineTwo (Mirror $ Tall 1 0.1 (1/3)) -infixr 5 |||---- $jtl--- The standard xmonad core exports a layout combinator @|||@ which--- represents layout choice.  This is a reimplementation which also--- provides the capability to support 'JumpToLayout' messages.  To use--- it, be sure to hide the import of @|||@ from the xmonad core; if either of--- these two lines appear in your configuration:------ > import XMonad--- > import XMonad.Layout------ replace them with these instead, respectively:------ > import XMonad hiding ( (|||) )--- > import XMonad.Layout hiding ( (|||) )------ The argument given to a 'JumpToLayout' message should be the--- @description@ of the layout to be selected.  If you use--- "XMonad.Hooks.DynamicLog", this is the name of the layout displayed--- in your status bar.  Alternatively, you can use GHCi to determine--- the proper name to use.  For example:------ > $ ghci--- > GHCi, version 6.8.2: http://www.haskell.org/ghc/  :? for help--- > Loading package base ... linking ... done.--- > :set prompt "> "    -- don't show loaded module names--- > > :m +XMonad.Core   -- load the xmonad core--- > > :m +XMonad.Layout.Grid  -- load whatever module you want to use--- > > description Grid  -- find out what it's called--- > "Grid"------ As yet another (possibly easier) alternative, you can use the--- "XMonad.Layout.Named" modifier to give custom names to your--- layouts, and use those.------ For the ability to select a layout from a prompt, see--- "Xmonad.Prompt.Layout".---- | A reimplementation of the combinator of the same name from the---   xmonad core, providing layout choice, and the ability to support---   'JumpToLayout' messages.-(|||) :: (LayoutClass l1 a, LayoutClass l2 a) => l1 a -> l2 a -> NewSelect l1 l2 a-(|||) = NewSelect True--data NewSelect l1 l2 a = NewSelect Bool (l1 a) (l2 a) deriving ( Read, Show )---- |-data JumpToLayout = JumpToLayout String -- ^ A message to jump to a particular layout-                                        -- , specified by its description string..-                  | NextLayoutNoWrap-                  | Wrap-                    deriving ( Read, Show, Typeable )-instance Message JumpToLayout--instance (LayoutClass l1 a, LayoutClass l2 a) => LayoutClass (NewSelect l1 l2) a where-    runLayout (Workspace i (NewSelect True l1 l2) ms) r = do (wrs, ml1') <- runLayout (Workspace i l1 ms) r-                                                             return (wrs, (\l1' -> NewSelect True l1' l2) `fmap` ml1')--    runLayout (Workspace i (NewSelect False l1 l2) ms) r = do (wrs, ml2') <- runLayout (Workspace i l2 ms) r-                                                              return (wrs, (\l2' -> NewSelect False l1 l2') `fmap` ml2')-    description (NewSelect True l1 _) = description l1-    description (NewSelect False _ l2) = description l2-    handleMessage l@(NewSelect False _ _) m-        | Just Wrap <- fromMessage m = fmap Just $ swap l >>= passOn m-    handleMessage l@(NewSelect amfirst _ _) m-        | Just NextLayoutNoWrap <- fromMessage m =-                  if amfirst then when' isNothing (passOnM m l) $-                                  fmap Just $ swap l >>= passOn (SomeMessage Wrap)-                             else passOnM m l-    handleMessage l m-        | Just NextLayout <- fromMessage m = when' isNothing (passOnM (SomeMessage NextLayoutNoWrap) l) $-                                             fmap Just $ swap l >>= passOn (SomeMessage Wrap)-    handleMessage l@(NewSelect True _ l2) m-        | Just (JumpToLayout d) <- fromMessage m, d == description l2 = Just `fmap` swap l-    handleMessage l@(NewSelect False l1 _) m-        | Just (JumpToLayout d) <- fromMessage m, d == description l1 = Just `fmap` swap l-    handleMessage l m-        | Just (JumpToLayout _) <- fromMessage m = when' isNothing (passOnM m l) $-                                                   do ml' <- passOnM m $ sw l-                                                      case ml' of-                                                        Nothing -> return Nothing-                                                        Just l' -> Just `fmap` swap (sw l')-    handleMessage (NewSelect b l1 l2) m-        | Just ReleaseResources  <- fromMessage m =-        do ml1' <- handleMessage l1 m-           ml2' <- handleMessage l2 m-           return $ if isJust ml1' || isJust ml2'-                    then Just $ NewSelect b (maybe l1 id ml1') (maybe l2 id ml2')-                    else Nothing-    handleMessage l m = passOnM m l--swap :: (LayoutClass l1 a, LayoutClass l2 a) => NewSelect l1 l2 a -> X (NewSelect l1 l2 a)-swap l = sw `fmap` passOn (SomeMessage Hide) l--sw :: NewSelect l1 l2 a -> NewSelect l1 l2 a-sw (NewSelect b lt lf) = NewSelect (not b) lt lf--passOn :: (LayoutClass l1 a, LayoutClass l2 a) =>-          SomeMessage -> NewSelect l1 l2 a -> X (NewSelect l1 l2 a)-passOn m l = maybe l id `fmap` passOnM m l--passOnM :: (LayoutClass l1 a, LayoutClass l2 a) =>-           SomeMessage -> NewSelect l1 l2 a -> X (Maybe (NewSelect l1 l2 a))-passOnM m (NewSelect True lt lf) = do mlt' <- handleMessage lt m-                                      return $ (\lt' -> NewSelect True lt' lf) `fmap` mlt'-passOnM m (NewSelect False lt lf) = do mlf' <- handleMessage lf m-                                       return $ (\lf' -> NewSelect False lt lf') `fmap` mlf'--when' :: Monad m => (a -> Bool) -> m a -> m a -> m a-when' f a b = do a1 <- a; if f a1 then b else return a1+type NewSelect = Choose+{-# DEPRECATED NewSelect "Use 'Choose' instead." #-}
XMonad/Layout/LayoutHints.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ParallelListComp, PatternGuards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Layout.LayoutHints+-- Description :  Make layouts respect size hints. -- Copyright    : (c) David Roundy <droundy@darcs.net> -- License      : BSD --@@ -22,31 +25,29 @@     , LayoutHints     , LayoutHintsToCenter     , hintsEventHook+    -- * For developers+    , placeRectangle     )  where  import XMonad(LayoutClass(runLayout), mkAdjust, Window,               Dimension, Position, Rectangle(Rectangle), D,               X, refresh, Event(..), propertyNotify, wM_NORMAL_HINTS,               (<&&>), io, applySizeHints, whenX, isClient, withDisplay,-              getWindowAttributes, getWMNormalHints, WindowAttributes(..))+              getWMNormalHints, WindowAttributes(..))+import XMonad.Prelude import qualified XMonad.StackSet as W  import XMonad.Layout.Decoration(isInStack) import XMonad.Layout.LayoutModifier(ModifiedLayout(..),                                     LayoutModifier(modifyLayout, redoLayout, modifierDescription)) import XMonad.Util.Types(Direction2D(..))-import Control.Applicative((<$>)) import Control.Arrow(Arrow((***), first, second))-import Control.Monad(join)-import Data.Function(on)-import Data.List(sortBy)-import Data.Monoid(All(..))  import Data.Set (Set) import qualified Data.Set as Set  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.LayoutHints --@@ -54,7 +55,7 @@ -- to some layout: -- -- > myLayout = layoutHints (Tall 1 (3/100) (1/2))  ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- Or, to center the adapted window in its available area: --@@ -65,17 +66,17 @@ -- -- > myLayout = layoutHintsToCenter (Tall 1 (3/100) (1/2)) ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- To make XMonad reflect changes in window hints immediately, add -- 'hintsEventHook' to your 'handleEventHook'. ----- > myHandleEventHook = hintsEventHook <+> ...+-- > myHandleEventHook = hintsEventHook <> ... -- >--- > main = xmonad defaultConfig { handleEventHook = myHandleEventHook--- >                             , ... }+-- > main = xmonad def { handleEventHook = myHandleEventHook+-- >                   , ... }  layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a layoutHints = ModifiedLayout (LayoutHints (0, 0))@@ -100,7 +101,7 @@ layoutHintsToCenter :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHintsToCenter l a layoutHintsToCenter = ModifiedLayout LayoutHintsToCenter -data LayoutHints a = LayoutHints (Double, Double)+newtype LayoutHints a = LayoutHints (Double, Double)                      deriving (Read, Show)  instance LayoutModifier LayoutHints Window where@@ -146,13 +147,17 @@     modifyLayout _ ws@(W.Workspace _ _ Nothing) r = runLayout ws r     modifyLayout _ ws@(W.Workspace _ _ (Just st)) r = do         (arrs,ol) <- runLayout ws r-        flip (,) ol-            . head . reverse . sortBy (compare `on` (fitting . map snd))-            . map (applyHints st r) . applyOrder r-            <$> mapM (\x -> fmap ((,) x) $ mkAdjust (fst x)) arrs+        (, ol) . changeOrder (W.focus st : filter (/= W.focus st) (map fst arrs))+               . maximumBy (compare `on` (fitting . map snd))+               . map (applyHints st r) . applyOrder r+             <$> mapM (\x -> (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 :: W.Stack Window -> Rectangle -> [((Window, Rectangle),D -> D)] -> [(Window, Rectangle)] applyHints _ _ [] = [] applyHints s root (((w,lrect@(Rectangle a b c d)),adj):xs) =         let (c',d') = adj (c,d)@@ -160,7 +165,7 @@                     $ if isInStack s w then Rectangle a b c' d' else lrect              ds = (fromIntegral c - fromIntegral c',fromIntegral d - fromIntegral d')-            growOther' r = growOther ds lrect (freeDirs root lrect) r+            growOther' = growOther ds lrect (freeDirs root lrect)             mapSnd f = map (first $ second f)             next = applyHints s root $ mapSnd growOther' xs         in (w,redr):next@@ -169,7 +174,7 @@ growOther ds lrect fds r     | dirs <- flipDir <$> Set.toList (Set.intersection adj fds)     , not $ any (uncurry opposite) $ cross dirs =-        foldr (flip grow ds) r dirs+        foldr (`grow` ds) r dirs     | otherwise = r     where         adj = adjacent lrect  r@@ -189,7 +194,7 @@ grow D (_ ,py) (Rectangle x y w h) = Rectangle x y w (h+fromIntegral py)  comparingEdges :: ([Position] -> [Position] -> Bool) -> Rectangle -> Rectangle -> Set Direction2D-comparingEdges surrounds r1 r2 = Set.fromList $ map fst $ filter snd [ (\k -> (dir,k)) $+comparingEdges surrounds r1 r2 = Set.fromList $ map fst $ filter snd [ (dir,) $             any and [[dir `elem` [R,L], allEq [a,c,w,y], [b,d] `surrounds` [x,z]]                     ,[dir `elem` [U,D], allEq [b,d,x,z], [a,c] `surrounds` [w,y]]]     | ((a,b),(c,d)) <- edge $ corners r1@@ -252,16 +257,17 @@  -- | Event hook that refreshes the layout whenever a window changes its hints. hintsEventHook :: Event -> X All-hintsEventHook (PropertyEvent { ev_event_type = t, ev_atom = a, ev_window = w })+hintsEventHook PropertyEvent{ ev_event_type = t, ev_atom = a, ev_window = w }     | t == propertyNotify && a == wM_NORMAL_HINTS = do-        whenX (isClient w <&&> hintsMismatch w) $ refresh+        whenX (isClient w <&&> hintsMismatch w) refresh         return (All True) hintsEventHook _ = return (All True)  -- | True if the window's current size does not satisfy its size hints. hintsMismatch :: Window -> X Bool-hintsMismatch w = withDisplay $ \d -> io $ do-    wa <- getWindowAttributes d w-    sh <- getWMNormalHints d w-    let dim = (fromIntegral $ wa_width wa, fromIntegral $ wa_height wa)-    return $ dim /= applySizeHints 0 sh dim+hintsMismatch w = safeGetWindowAttributes w >>= \case+    Nothing -> pure False+    Just wa -> do+        sh <- withDisplay $ \d -> io (getWMNormalHints d w)+        let dim = (fromIntegral $ wa_width wa, fromIntegral $ wa_height wa)+        return $ dim /= applySizeHints 0 sh dim
XMonad/Layout/LayoutModifier.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Layout.LayoutModifier+-- Description :  A module for writing layout modifiers. -- Copyright    : (c) David Roundy <droundy@darcs.net> -- License      : BSD --@@ -29,7 +30,7 @@     LayoutModifier(..), ModifiedLayout(..)     ) where -import Control.Monad+import XMonad.Prelude  import XMonad import XMonad.StackSet ( Stack, Workspace (..) )@@ -72,7 +73,7 @@ -- -- * "XMonad.Layout.Reflect" ----- * "XMonad.Layout.Named"+-- * "XMonad.Layout.Renamed" -- -- * "XMonad.Layout.WindowNavigation" --@@ -106,7 +107,7 @@                  -> Workspace WorkspaceId (l a) a   -- ^ current workspace                  -> Rectangle                       -- ^ screen rectangle                  -> X ([(a, Rectangle)], Maybe (l a))-    modifyLayout _ w r = runLayout w r+    modifyLayout _ = runLayout      -- | Similar to 'modifyLayout', but this function also allows you     -- update the state of your layout modifier(the second value in the@@ -122,7 +123,7 @@                            -> Workspace WorkspaceId (l a) a                            -> Rectangle                            -> X (([(a,Rectangle)], Maybe (l a)), Maybe (m a))-    modifyLayoutWithUpdate m w r = flip (,) Nothing `fmap` modifyLayout m w r+    modifyLayoutWithUpdate m w r = (, Nothing) <$> modifyLayout m w r      -- | 'handleMess' allows you to spy on messages to the underlying     --   layout, in order to have an effect in the X monad, or alter@@ -156,7 +157,7 @@     --   simply passes on the message to 'handleMess'.     handleMessOrMaybeModifyIt :: m a -> SomeMessage -> X (Maybe (Either (m a) SomeMessage))     handleMessOrMaybeModifyIt m mess = do mm' <- handleMess m mess-                                          return (Left `fmap` mm')+                                          return (Left <$> mm')      -- | 'pureMess' allows you to spy on messages sent to the     --   underlying layout, in order to possibly change the layout@@ -233,7 +234,7 @@     --   should only override this if it is important that the     --   presence of the layout modifier be displayed in text     --   representations of the layout (for example, in the status bar-    --   of a "XMonad.Hooks.DynamicLog" user).+    --   of a "XMonad.Hooks.StatusBar" user).     modifierDescription :: m a -> String     modifierDescription = const "" @@ -244,19 +245,19 @@     --   \"smart space\" in between (the space is not included if the     --   'modifierDescription' is empty).     modifyDescription :: (LayoutClass l a) => m a -> l a -> String-    modifyDescription m l = modifierDescription m <> description l-        where "" <> x = x-              x <> y = x ++ " " ++ y+    modifyDescription m l = modifierDescription m `add` description l+        where "" `add` x = x+              x `add` y = x ++ " " ++ y  -- | The 'LayoutClass' instance for a 'ModifiedLayout' defines the --   semantics of a 'LayoutModifier' applied to an underlying layout.-instance (LayoutModifier m a, LayoutClass l a) => LayoutClass (ModifiedLayout m l) a where+instance (LayoutModifier m a, LayoutClass l a, Typeable m) => LayoutClass (ModifiedLayout m l) a where     runLayout (Workspace i (ModifiedLayout m l) ms) r =         do ((ws, ml'),mm')  <- modifyLayoutWithUpdate m (Workspace i l ms) r-           (ws', mm'') <- redoLayout (maybe m id mm') r ms ws+           (ws', mm'') <- redoLayout (fromMaybe m mm') r ms ws            let ml'' = case mm'' `mplus` mm' of-                        Just m' -> Just $ (ModifiedLayout m') $ maybe l id ml'-                        Nothing -> ModifiedLayout m `fmap` ml'+                        Just m' -> Just $ ModifiedLayout m' $ fromMaybe l ml'+                        Nothing -> ModifiedLayout m <$> ml'            return (ws', ml'')      handleMessage (ModifiedLayout m l) mess =@@ -265,16 +266,11 @@                   Just (Right mess') -> handleMessage l mess'                   _ -> handleMessage l mess            return $ case mm' of-                    Just (Left m') -> Just $ (ModifiedLayout m') $ maybe l id ml'-                    _ -> (ModifiedLayout m) `fmap` ml'+                    Just (Left m') -> Just $ ModifiedLayout m' $ fromMaybe l ml'+                    _ -> ModifiedLayout m <$> ml'     description (ModifiedLayout m l) = modifyDescription m l  -- | A 'ModifiedLayout' is simply a container for a layout modifier --   combined with an underlying layout.  It is, of course, itself a --   layout (i.e. an instance of 'LayoutClass'). data ModifiedLayout m l a = ModifiedLayout (m a) (l a) deriving ( Read, Show )---- N.B. I think there is a Haddock bug here; the Haddock output for--- the above does not parenthesize (m a) and (l a), which is obviously--- incorrect.-
XMonad/Layout/LayoutScreens.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.LayoutScreens+-- Description :  A layout to divide a single screen into multiple screens. -- Copyright   :  (c) David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -21,6 +23,7 @@                                    ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W  -- $usage@@ -33,7 +36,7 @@ -- email window at all times, a crude mimic of sticky windows). -- -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@ file:+-- @xmonad.hs@ file: -- -- > import XMonad.Layout.LayoutScreens -- > import XMonad.Layout.TwoPane@@ -54,17 +57,19 @@ -- >   , ((modm .|. controlMask .|. shiftMask, xK_space), rescreen) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | Modify all screens. layoutScreens :: LayoutClass l Int => Int -> l Int -> X () layoutScreens nscr _ | nscr < 1 = trace $ "Can't layoutScreens with only " ++ show nscr ++ " screens."-layoutScreens nscr l =-    do rtrect <- asks theRoot >>= getWindowRectangle+layoutScreens nscr l = asks theRoot >>= \w -> withDisplay $ \d ->+  withWindowAttributes d w $ \attrs ->+    do let rtrect = windowRectangle attrs        (wss, _) <- runLayout (W.Workspace "" l (Just $ W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] })) rtrect-       windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) ->-           let (x:xs, ys) = splitAt nscr $ map W.workspace (v:vs) ++ hs-               s:ss = map snd wss+       windows $ \ws@W.StackSet{ W.current = v, W.visible = vs, W.hidden = hs } ->+           let x = W.workspace v+               (xs, ys) = splitAt (nscr - 1) $ map W.workspace vs ++ hs+               (notEmpty -> s :| ss) = map snd wss            in  ws { W.current = W.Screen x 0 (SD s)                   , W.visible = zipWith3 W.Screen xs [1 ..] $ map SD ss                   , W.hidden  = ys }@@ -75,21 +80,20 @@ layoutSplitScreen nscr l =     do rect <- gets $ screenRect . W.screenDetail . W.current . windowset        (wss, _) <- runLayout (W.Workspace "" l (Just $ W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] })) rect-       windows $ \ws@(W.StackSet { W.current = c, W.visible = vs, W.hidden = hs }) ->-           let (x:xs, ys) = splitAt nscr $ W.workspace c : hs-               s:ss = map snd wss+       windows $ \ws@W.StackSet{ W.current = c, W.visible = vs, W.hidden = hs } ->+           let x = W.workspace c+               (xs, ys) = splitAt (nscr - 1) hs+               (notEmpty -> s :| ss) = map snd wss            in  ws { W.current = W.Screen x (W.screen c) (SD s)-                  , W.visible = (zipWith3 W.Screen xs [(W.screen c+1) ..] $ map SD ss) +++                  , W.visible = zipWith3 W.Screen xs [(W.screen c+1) ..] (map SD ss) ++                                 map (\v -> if W.screen v>W.screen c then v{W.screen = W.screen v + fromIntegral (nscr-1)} else v) vs                   , W.hidden  = ys } -getWindowRectangle :: Window -> X Rectangle-getWindowRectangle w = withDisplay $ \d ->-    do a <- io $ getWindowAttributes d w-       return $ Rectangle (fromIntegral $ wa_x a)     (fromIntegral $ wa_y a)-                          (fromIntegral $ wa_width a) (fromIntegral $ wa_height a)+windowRectangle :: WindowAttributes -> Rectangle+windowRectangle a = Rectangle (fromIntegral $ wa_x a)     (fromIntegral $ wa_y a)+                              (fromIntegral $ wa_width a) (fromIntegral $ wa_height a) -data FixedLayout a = FixedLayout [Rectangle] deriving (Read,Show)+newtype FixedLayout a = FixedLayout [Rectangle] deriving (Read,Show)  instance LayoutClass FixedLayout a where     doLayout (FixedLayout rs) _ s = return (zip (W.integrate s) rs, Nothing)
XMonad/Layout/LimitWindows.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, PatternGuards #-}+{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}+#ifdef TESTING+{-# OPTIONS_GHC -Wno-duplicate-exports #-}+#endif ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.LimitWindows+-- Description :  A layout modifier that limits the number of windows that can be shown. -- Copyright   :  (c) 2009 Adam Vogt --                (c) 2009 Max Rabkin -- wrote limitSelect -- License     :  BSD-style (see xmonad/LICENSE)@@ -34,27 +38,25 @@     LimitWindows, Selection,     ) where -import XMonad.Layout.LayoutModifier import XMonad+import XMonad.Layout.LayoutModifier+import XMonad.Prelude (fromJust, guard, (<=<)) import qualified XMonad.StackSet as W-import Control.Monad((<=<),guard)-import Control.Applicative((<$>))-import Data.Maybe(fromJust)  -- $usage--- To use this module, add the following import to @~\/.xmonad\/xmonad.hs@:+-- To use this module, add the following import to @xmonad.hs@: -- -- > import XMonad.Layout.LimitWindows -- -- > myLayout = limitWindows 6 $ Tall 1 0.03 0.5 ||| Full ||| RandomOtherLayout...--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- You may also be interested in dynamically changing the number dynamically, -- by binding keys to the 'increaseLimit', 'decreaseLimit', or 'setLimit' -- actions. -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -- -- See also 'XMonad.Layout.BoringWindows.boringAuto' for keybindings that skip -- the hidden windows.@@ -73,7 +75,7 @@ limitWindows n = ModifiedLayout (LimitWindows FirstN n)  -- | Only display @n@ windows around the focused window. This makes sense with--- layouts that arrange windows linearily, like 'XMonad.Layout.Layout.Accordion'.+-- layouts that arrange windows linearily, like "XMonad.Layout.Accordion". limitSlice :: Int -> l a -> ModifiedLayout LimitWindows l a limitSlice n = ModifiedLayout (LimitWindows Slice n) @@ -87,7 +89,7 @@  data SliceStyle = FirstN | Slice deriving (Read,Show) -data LimitChange = LimitChange { unLC :: (Int -> Int) } deriving (Typeable)+newtype LimitChange = LimitChange { unLC :: Int -> Int }  instance Message LimitChange @@ -97,8 +99,8 @@       where pos x   = guard (x>=1)     >> return x             app f x = guard (f x /= x) >>  return (f x) -     modifyLayout (LimitWindows style n) ws r =-        runLayout ws { W.stack = f n <$> W.stack ws } r+     modifyLayout (LimitWindows style n) ws =+        runLayout ws { W.stack = f n <$> W.stack ws }       where f = case style of                     FirstN -> firstN                     Slice -> slice@@ -121,8 +123,8 @@     deriving (Read, Show, Eq)  instance LayoutModifier Selection a where-    modifyLayout s w r =-        runLayout (w { W.stack = updateAndSelect s <$> W.stack w }) r+    modifyLayout s w =+        runLayout (w { W.stack = updateAndSelect s <$> W.stack w })      pureModifier sel _ stk wins = (wins, update sel <$> stk) @@ -141,7 +143,7 @@                     (take (nRest s) . drop (start s - lups - 1) $ downs) }     | otherwise         = stk { W.up=reverse (take (nMaster s) ups ++ drop (start s) ups),-                W.down=take ((nRest s) - (lups - start s) - 1) downs }+                W.down=take (nRest s - (lups - start s) - 1) downs }     where         downs = W.down stk         ups = reverse $ W.up stk@@ -150,11 +152,11 @@ updateStart :: Selection l -> W.Stack a -> Int updateStart s stk     | lups < nMaster s  -- the focussed window is in the master pane-        = start s `min` (lups + ldown - (nRest s) + 1) `max` nMaster s+        = start s `min` (lups + ldown - nRest s + 1) `max` nMaster s     | otherwise         = start s `min` lups-                  `max` (lups - (nRest s) + 1)-                  `min` (lups + ldown - (nRest s) + 1)+                  `max` (lups - nRest s + 1)+                  `min` (lups + ldown - nRest s + 1)                   `max` nMaster s     where         lups = length $ W.up stk
XMonad/Layout/MagicFocus.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Layout.MagicFocus+-- Description :  Automagically put the focused window in the master area. -- Copyright    : (c) Peter De Wachter <pdewacht@gmail.com> -- License      : BSD --@@ -28,12 +29,12 @@ import qualified XMonad.StackSet as W import XMonad.Layout.LayoutModifier -import XMonad.Actions.UpdatePointer(updatePointer, PointerPosition(TowardsCentre))-import Data.Monoid(All(..))+import XMonad.Actions.UpdatePointer (updatePointer)+import XMonad.Prelude(All(..)) import qualified Data.Map as M  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.MagicFocus --@@ -41,12 +42,12 @@ -- modifier: -- -- > myLayout = magicFocus (Tall 1 (3/100) (1/2)) ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout,--- >                               handleEventHook = promoteWarp }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout,+-- >                     handleEventHook = promoteWarp } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | Create a new layout which automagically puts the focused window --   in the master area.@@ -56,14 +57,11 @@ data MagicFocus a = MagicFocus deriving (Show, Read)  instance LayoutModifier MagicFocus Window where-  modifyLayout MagicFocus (W.Workspace i l s) r =-    withWindowSet $ \wset ->-      runLayout (W.Workspace i l (s >>= \st -> Just $ swap st (W.peek wset))) r+  modifyLayout MagicFocus (W.Workspace i l s) =+    runLayout (W.Workspace i l (s >>= Just . shift)) -swap :: (Eq a) => W.Stack a -> Maybe a -> W.Stack a-swap (W.Stack f u d) focused-    | Just f == focused = W.Stack f [] (reverse u ++ d)-    | otherwise         = W.Stack f u d+shift :: (Eq a) => W.Stack a -> W.Stack a+shift (W.Stack f u d) = W.Stack f [] (reverse u ++ d)  -- | An eventHook that overrides the normal focusFollowsMouse. When the mouse -- it moved to another window, that window is replaced as the master, and the@@ -75,12 +73,12 @@ -- This eventHook does nothing when there are floating windows on the current -- workspace. promoteWarp :: Event -> X All-promoteWarp = promoteWarp' (TowardsCentre 0.15 0.15)+promoteWarp = promoteWarp' (0.5, 0.5) (0.85, 0.85) --- | promoteWarp' allows you to specify an arbitrary PointerPosition to apply--- when the mouse enters another window.-promoteWarp' :: PointerPosition -> Event -> X All-promoteWarp' pos e@(CrossingEvent {ev_window = w, ev_event_type = t})+-- | promoteWarp' allows you to specify an arbitrary pair of arguments to+-- pass to 'updatePointer' when the mouse enters another window.+promoteWarp' :: (Rational, Rational) -> (Rational, Rational) -> Event -> X All+promoteWarp' refPos ratio e@CrossingEvent{ev_window = w, ev_event_type = t}     | t == enterNotify && ev_mode   e == notifyNormal = do         ws <- gets windowset         let foc = W.peek ws@@ -88,21 +86,21 @@             wsFloats = M.filterWithKey (\k _ -> k `elem` st) $ W.floating ws         if Just w /= foc && M.null wsFloats then do             windows (W.swapMaster . W.focusWindow w)-            updatePointer pos+            updatePointer refPos ratio             return $ All False           else return $ All True-promoteWarp' _ _ = return $ All True+promoteWarp' _ _ _ = return $ All True  -- | Another event hook to override the focusFollowsMouse and make the pointer -- only follow if a given condition is satisfied. This could be used to disable -- focusFollowsMouse only for given workspaces or layouts. -- Beware that your focusFollowsMouse setting is ignored if you use this event hook. followOnlyIf :: X Bool -> Event -> X All-followOnlyIf cond e@(CrossingEvent {ev_window = w, ev_event_type = t})+followOnlyIf cond e@CrossingEvent{ev_window = w, ev_event_type = t}     | t == enterNotify && ev_mode e == notifyNormal     = whenX cond (focus w) >> return (All False) followOnlyIf _ _ = return $ All True  -- | Disables focusFollow on the given workspaces: disableFollowOnWS :: [WorkspaceId] -> X Bool-disableFollowOnWS wses = (`notElem` wses) `fmap` gets (W.currentTag . windowset)+disableFollowOnWS wses = (`notElem` wses) <$> gets (W.currentTag . windowset)
XMonad/Layout/Magnifier.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PatternGuards              #-}+{-# LANGUAGE TypeSynonymInstances       #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Magnifier+-- Description :  Increase the size of the window that has focus. -- Copyright   :  (c) Peter De Wachter and Andrea Rossato 2007 -- License     :  BSD-style (see xmonad/LICENSE) --@@ -9,10 +12,10 @@ -- Stability   :  unstable -- Portability :  unportable ----- Screenshot  :  <http://caladan.rave.org/magnifier.png>+-- This is a layout modifier that will make a layout change the size of+-- the window that has focus. ----- This is a layout modifier that will make a layout increase the size--- of the window that has focus.+-- [Example screenshot using @magnifiercz' 1.3@ with one of the two stack windows focused.](https://user-images.githubusercontent.com/50166980/108524842-c5f69380-72cf-11eb-9fd6-b0bf67b13ed6.png) -- ----------------------------------------------------------------------------- @@ -20,46 +23,70 @@ module XMonad.Layout.Magnifier     ( -- * Usage       -- $usage++      -- * General combinators+      magnify,+      magnifyxy,++      -- * Magnify Everything       magnifier,-      magnifier',       magnifierOff,       magnifiercz,-      magnifiercz',+      magnifierczOff,+      magnifierxy,+      magnifierxyOff,+      maxMagnifierOff,       maximizeVertical,++      -- * Don't Magnify the Master Window+      magnifier',+      magnifiercz',+      magnifierczOff',+      magnifierxy',+      magnifierxyOff',++      -- * Messages and Types       MagnifyMsg (..),+      MagnifyThis(..),       Magnifier,     ) where +import Numeric.Natural (Natural)+ import XMonad-import XMonad.StackSet+import XMonad.Prelude (bool, fi) import XMonad.Layout.LayoutModifier-import XMonad.Util.XUtils+import XMonad.StackSet  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Magnifier ----- Then edit your @layoutHook@ by adding the 'magnifier' layout modifier--- to some layout:+-- Then edit your @layoutHook@ by e.g. adding the 'magnifier' layout+-- modifier to some layout: -- -- > myLayout = magnifier (Tall 1 (3/100) (1/2))  ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ By default magnifier increases the focused window's size by 1.5.--- You can also use:+-- > main = xmonad def { layoutHook = myLayout } ----- > magnifiercz 1.2+-- By default 'magnifier' increases the focused window's size by @1.5@. ----- to use a custom level of magnification.  You can even make the focused--- window smaller for a pop in effect.+-- You can also use @'magnifiercz' 1.2@ or @'magnifierxy' 1 1000@ to use+-- a custom level of magnification. You can even make the focused window+-- smaller for a pop in effect. There's also the possibility of starting+-- out not magnifying anything at all ('magnifierOff'); see below for+-- ways to toggle this on while in use. ----- For more detailed instructions on editing the layoutHook see:+-- The most general combinator available is 'magnify'—all of the other+-- functions in this module are essentially just creative applications+-- of it. ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". ----- Magnifier supports some commands. To use them add something like--- this to your key bindings:+-- Magnifier supports some commands, see 'MagnifyMsg'.  To use them add+-- something like this to your key bindings: -- -- >    , ((modm .|. controlMask              , xK_plus ), sendMessage MagnifyMore) -- >    , ((modm .|. controlMask              , xK_minus), sendMessage MagnifyLess)@@ -79,77 +106,170 @@ -- like @Mag.Toggle@, @Mag.magnifier@, and so on. -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. +-- | Add magnification capabilities to a certain layout.+--+-- For example, to re-create 'magnifiercz' 1.3', you would do+--+-- >>> magnify 1.3 (NoMaster 1) True+--+magnify+    :: Rational     -- ^ Amount to magnify both directions+    -> MagnifyThis  -- ^ What to magnify+    -> Bool         -- ^ Whether magnification should start out on+                    --   (@True@) or off (@False@)+    -> l a          -- ^ Input layout+    -> ModifiedLayout Magnifier l a+magnify cz = magnifyxy cz cz++-- | Like 'magnify', but with the ability to specify different amounts+-- of horizontal and vertical magnification.+--+-- >>> magnifyxy 1.3 1.6 (NoMaster 1) True+magnifyxy+    :: Rational      -- ^ Amount to magnify horizontally+    -> Rational      -- ^ Amount to magnify vertically+    -> MagnifyThis   -- ^ What to magnify+    -> Bool          -- ^ Whether magnification should start out on+                     --   (@True@) or off (@False@)+    -> l a           -- ^ Input layout+    -> ModifiedLayout Magnifier l a+magnifyxy cx cy mt start = ModifiedLayout $+    Mag 1 (fromRational cx, fromRational cy) (bool Off On start) mt+ -- | Increase the size of the window that has focus magnifier :: l a -> ModifiedLayout Magnifier l a-magnifier = ModifiedLayout (Mag (1.5,1.5) On All)+magnifier = magnifiercz 1.5  -- | Change the size of the window that has focus by a custom zoom magnifiercz :: Rational -> l a -> ModifiedLayout Magnifier l a-magnifiercz cz = ModifiedLayout (Mag (fromRational cz, fromRational cz) On All)+magnifiercz cz = magnify cz (AllWins 1) True --- | Increase the size of the window that has focus, unless if it is the--- master window.+-- | Increase the size of the window that has focus, unless if it is one of the+-- master windows. magnifier' :: l a -> ModifiedLayout Magnifier l a-magnifier' = ModifiedLayout (Mag (1.5,1.5) On NoMaster)+magnifier' = magnifiercz' 1.5 +-- | Increase the size of the window that has focus by a custom zoom,+-- unless if it is one of the the master windows.+magnifiercz' :: Rational -> l a -> ModifiedLayout Magnifier l a+magnifiercz' cz = magnify cz (NoMaster 1) True++-- | Increase the size of the window that has focus by a custom zoom in+-- both directions.+magnifierxy :: Rational -> Rational -> l a -> ModifiedLayout Magnifier l a+magnifierxy cx cy = magnifyxy cx cy (AllWins 1) True++-- | Like 'magnifierxy', but default to @Off@.+magnifierxyOff :: Rational -> Rational -> l a -> ModifiedLayout Magnifier l a+magnifierxyOff cx cy = magnifyxy cx cy (AllWins 1) False++-- | Increase the size of the window that has focus by a custom zoom in+-- both directions, unless it is one of the master windows.+magnifierxy' :: Rational -> Rational -> l a -> ModifiedLayout Magnifier l a+magnifierxy' cx cy = magnifyxy cx cy (NoMaster 1) True++-- | Like 'magnifierxy'', but defaults to @Off@.+magnifierxyOff' :: Rational -> Rational -> l a -> ModifiedLayout Magnifier l a+magnifierxyOff' cx cy = magnifyxy cx cy (NoMaster 1) False+ -- | Magnifier that defaults to Off magnifierOff :: l a -> ModifiedLayout Magnifier l a-magnifierOff = ModifiedLayout (Mag (1.5,1.5) Off All)+magnifierOff = magnifierczOff 1.5 --- | Increase the size of the window that has focus by a custom zoom,--- unless if it is the master window.-magnifiercz' :: Rational -> l a -> ModifiedLayout Magnifier l a-magnifiercz' cz = ModifiedLayout (Mag (fromRational cz, fromRational cz) On NoMaster)+-- | A magnifier that greatly magnifies the focused window; defaults to+-- @Off@.+maxMagnifierOff :: l a -> ModifiedLayout Magnifier l a+maxMagnifierOff = magnifierczOff 1000 --- | A magnifier that greatly magnifies just the vertical direction+-- | Like 'magnifiercz', but default to @Off@.+magnifierczOff :: Rational -> l a -> ModifiedLayout Magnifier l a+magnifierczOff cz = magnify cz (AllWins 1) False++-- | Like 'magnifiercz'', but default to @Off@.+magnifierczOff' :: Rational -> l a -> ModifiedLayout Magnifier l a+magnifierczOff' cz = magnify cz (NoMaster 1) False++-- | A magnifier that greatly magnifies just the vertical direction;+-- defaults to @Off@. maximizeVertical :: l a -> ModifiedLayout Magnifier l a-maximizeVertical = ModifiedLayout (Mag (1,1000) Off All)+maximizeVertical = ModifiedLayout (Mag 1 (1, 1000) Off (AllWins 1)) -data MagnifyMsg = MagnifyMore | MagnifyLess | ToggleOn | ToggleOff | Toggle deriving ( Typeable )+data MagnifyMsg = MagnifyMore | MagnifyLess | ToggleOn | ToggleOff | Toggle instance Message MagnifyMsg -data Magnifier a = Mag (Double,Double) Toggle MagnifyMaster deriving (Read, Show)+-- | The type for magnifying a given type; do note that the given type+-- @a@ is a phantom type.+data Magnifier a = Mag+    { masterWins :: !Int+      -- ^ How many windows there are in the master pane.+    , zoomFactor :: !(Double, Double)+      -- ^ Zoom-factor in the @x@ and @y@ direction; the window's width and+      --   height will be multiplied by these amounts when magnifying.+    , toggle :: !Toggle+      -- ^ Whether to magnify windows at all.+    , magWhen :: !MagnifyThis+      -- ^ Conditions when to magnify a given window+    }+    deriving (Read, Show) -data Toggle        = On  | Off      deriving  (Read, Show)-data MagnifyMaster = All | NoMaster deriving  (Read, Show)+-- | Whether magnification is currently enabled.+data Toggle = On | Off deriving (Read, Show) +-- | Which windows to magnify and when to start doing so.  Note that+-- magnifying will start /at/ the cut-off, so @AllWins 3@ will start+-- magnifying when there are at least three windows present in the stack+-- set.+data MagnifyThis+    = AllWins  !Natural  -- ^ Every window+    | NoMaster !Natural  -- ^ Only stack windows+    deriving (Read, Show)+ instance LayoutModifier Magnifier Window where-    redoLayout  (Mag z On All     ) r (Just s) wrs = applyMagnifier z r s wrs-    redoLayout  (Mag z On NoMaster) r (Just s) wrs = unlessMaster (applyMagnifier z) r s wrs-    redoLayout  _                   _ _        wrs = return (wrs, Nothing)+    redoLayout _   _ Nothing  wrs = pure (wrs, Nothing)+    redoLayout mag r (Just s) wrs = case mag of+        Mag _ z On (AllWins  k) -> magnifyAt k (applyMagnifier z r s wrs)+        Mag n z On (NoMaster k) ->+            magnifyAt k (unlessMaster n (applyMagnifier z) r s wrs)+        _ -> pure (wrs, Nothing)+      where+        magnifyAt cutoff magnifyFun+            | fromIntegral cutoff <= length (integrate s) = magnifyFun+            | otherwise                                   = pure (wrs, Nothing) -    handleMess (Mag z On  t) m-                    | Just MagnifyMore <- fromMessage m = return . Just $ (Mag (z `addto`   0.1 ) On  t)-                    | Just MagnifyLess <- fromMessage m = return . Just $ (Mag (z `addto` (-0.1)) On  t)-                    | Just ToggleOff   <- fromMessage m = return . Just $ (Mag (z      ) Off t)-                    | Just Toggle      <- fromMessage m = return . Just $ (Mag (z      ) Off t)-                    where addto (x,y) i = (x+i,y+i)-    handleMess (Mag z Off t) m-                    | Just ToggleOn    <- fromMessage m = return . Just $ (Mag z         On  t)-                    | Just Toggle      <- fromMessage m = return . Just $ (Mag z         On  t)+    handleMess (Mag n z On  t) m+        | Just MagnifyMore    <- fromMessage m = return . Just $ Mag n             (z `addto`   0.1 ) On  t+        | Just MagnifyLess    <- fromMessage m = return . Just $ Mag n             (z `addto` (-0.1)) On  t+        | Just ToggleOff      <- fromMessage m = return . Just $ Mag n             z                  Off t+        | Just Toggle         <- fromMessage m = return . Just $ Mag n             z                  Off t+        | Just (IncMasterN d) <- fromMessage m = return . Just $ Mag (max 0 (n+d)) z                  On  t+      where addto (x, y) i = (x + i, y + i)+    handleMess (Mag n z Off t) m+        | Just ToggleOn       <- fromMessage m = return . Just $ Mag n             z                  On  t+        | Just Toggle         <- fromMessage m = return . Just $ Mag n             z                  On  t+        | Just (IncMasterN d) <- fromMessage m = return . Just $ Mag (max 0 (n+d)) z                  Off t     handleMess _ _ = return Nothing -    modifierDescription (Mag _ On  All     ) = "Magnifier"-    modifierDescription (Mag _ On  NoMaster) = "Magnifier NoMaster"-    modifierDescription (Mag _ Off _       ) = "Magnifier (off)"+    modifierDescription (Mag _ _ On  AllWins{} ) = "Magnifier"+    modifierDescription (Mag _ _ On  NoMaster{}) = "Magnifier NoMaster"+    modifierDescription (Mag _ _ Off _         ) = "Magnifier (off)"  type NewLayout a = Rectangle -> Stack a -> [(Window, Rectangle)] -> X ([(Window, Rectangle)], Maybe (Magnifier a)) -unlessMaster :: NewLayout a -> NewLayout a-unlessMaster mainmod r s wrs = if null (up s) then return (wrs, Nothing)-                                              else mainmod r s wrs+unlessMaster :: Int -> NewLayout a -> NewLayout a+unlessMaster n mainmod r s wrs = if null (drop (n-1) (up s)) then return (wrs, Nothing)+                                                             else mainmod r s wrs  applyMagnifier :: (Double,Double) -> Rectangle -> t -> [(Window, Rectangle)]                -> X ([(Window, Rectangle)], Maybe a) applyMagnifier z r _ wrs = do focused <- withWindowSet (return . peek)-                              let mag (w,wr) ws | focused == Just w = ws ++ [(w, fit r $ magnify z wr)]+                              let mag (w,wr) ws | focused == Just w = ws ++ [(w, fit r $ magnify' z wr)]                                                 | otherwise         = (w,wr) : ws                               return (reverse $ foldr mag [] wrs, Nothing) -magnify :: (Double, Double) -> Rectangle -> Rectangle-magnify (zoomx,zoomy) (Rectangle x y w h) = Rectangle x' y' w' h'+magnify' :: (Double, Double) -> Rectangle -> Rectangle+magnify' (zoomx,zoomy) (Rectangle x y w h) = Rectangle x' y' w' h'     where x' = x - fromIntegral (w' - w) `div` 2           y' = y - fromIntegral (h' - h) `div` 2           w' = round $ fromIntegral w * zoomx@@ -157,7 +277,7 @@  fit :: Rectangle -> Rectangle -> Rectangle fit (Rectangle sx sy sw sh) (Rectangle x y w h) = Rectangle x' y' w' h'-    where x' = max sx (x - (max 0 (x + fi w - sx - fi sw)))-          y' = max sy (y - (max 0 (y + fi h - sy - fi sh)))+    where x' = max sx (x - max 0 (x + fi w - sx - fi sw))+          y' = max sy (y - max 0 (y + fi h - sy - fi sh))           w' = min sw w           h' = min sh h
XMonad/Layout/Master.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, PatternGuards #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Master+-- Description :  Layout modfier that adds a master window to another layout. -- Copyright   :  (c) Ismael Carnales, Lukas Mai -- License     :  BSD-style (see LICENSE) --@@ -18,6 +19,7 @@     -- $usage      mastered,+    fixMastered,     multimastered,     AddMaster, ) where@@ -26,8 +28,10 @@ import qualified XMonad.StackSet as S import XMonad.Layout.LayoutModifier +import Control.Arrow (first)+ -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Master --@@ -36,6 +40,10 @@ -- -- > mastered (1/100) (1/2) $ Grid --+-- Or if you prefer to have a master with fixed width:+--+-- > fixMastered (1/100) (1/2) $ Grid+-- -- Or if you want multiple (here two) master windows from the beginning: -- -- > multimastered 2 (1/100) (1/2) $ Grid@@ -44,6 +52,7 @@ -- Grid manage the right half. -- -- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and -- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- Like 'XMonad.Layout.Tall', 'withMaster' supports the@@ -53,7 +62,6 @@ -- layout data AddMaster a = AddMaster Int Rational Rational deriving (Show, Read) --- | Modifier which converts given layout to a mastered one multimastered :: (LayoutClass l a) =>        Int -- ^ @k@, number of master windows     -> Rational -- ^ @delta@, the ratio of the screen to resize by@@ -67,10 +75,10 @@     -> Rational -- ^ @frac@, what portion of the screen to use for the master window     -> l a      -- ^ the layout to be modified     -> ModifiedLayout AddMaster l a-mastered delta frac = multimastered 1 delta frac+mastered = multimastered 1  instance LayoutModifier AddMaster Window where-    modifyLayout (AddMaster k delta frac) = applyMaster k delta frac+    modifyLayout (AddMaster k delta frac) = applyMaster False k delta frac     modifierDescription _               = "Mastered"      pureMess (AddMaster k delta frac) m@@ -80,28 +88,43 @@      pureMess _ _ = Nothing +newtype FixMaster a = FixMaster (AddMaster a) deriving (Show, Read)++instance LayoutModifier FixMaster Window where+    modifyLayout (FixMaster (AddMaster k d f)) = applyMaster True k d f+    modifierDescription (FixMaster a) = "Fix" ++ modifierDescription a+    pureMess (FixMaster a) m = fmap FixMaster (pureMess a m)++fixMastered :: (LayoutClass l a) =>+       Rational -- ^ @delta@, the ratio of the screen to resize by+    -> Rational -- ^ @frac@, what portion of the screen to use for the master window+    -> l a      -- ^ the layout to be modified+    -> ModifiedLayout FixMaster l a+fixMastered delta frac = ModifiedLayout . FixMaster $ AddMaster 1 delta frac+ -- | Internal function for adding a master window and let the modified -- layout handle the rest of the windows applyMaster :: (LayoutClass l Window) =>-                  Int+                  Bool+               -> Int                -> Rational                -> Rational                -> S.Workspace WorkspaceId (l Window) Window                -> Rectangle                -> X ([(Window, Rectangle)], Maybe (l Window))-applyMaster k _ frac wksp rect = do+applyMaster f k _ frac wksp rect = do     let st= S.stack wksp-    let ws = S.integrate' $ st-    let n = length ws-    if n > 1 then do-        if(n<=k) then-             return ((divideCol rect ws), Nothing)+    let ws = S.integrate' st+    let n = length ws + fromEnum f+    if n > 1 then+        if n<=k then+             return (divideCol rect ws, Nothing)              else do              let m = take k ws              let (mr, sr) = splitHorizontallyBy frac rect-             let nst = st>>= S.filter (\w -> not (w `elem` m))+             let nst = st>>= S.filter (`notElem` m)              wrs <- runLayout (wksp {S.stack = nst}) sr-             return ((divideCol mr m) ++ (fst wrs), snd wrs)+             return (first (divideCol mr m ++) wrs)         else runLayout wksp rect  -- | Shift rectangle down@@ -115,4 +138,3 @@           oneH = fromIntegral h `div` n           oneRect = Rectangle x y w (fromIntegral oneH)           rects = take n $ iterate (shiftD (fromIntegral oneH)) oneRect-
XMonad/Layout/Maximize.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Maximize+-- Description :  Temporarily yank the focused window out of the layout to mostly fill the screen. -- Copyright   :  (c) 2007 James Webb -- License     :  BSD3-style (see LICENSE) --@@ -19,6 +20,7 @@         -- * Usage         -- $usage         maximize,+        maximizeWithPadding,         maximizeRestore,         Maximize, MaximizeRestore,     ) where@@ -26,22 +28,28 @@ import XMonad import qualified XMonad.StackSet as S import XMonad.Layout.LayoutModifier-import Data.List ( partition )+import XMonad.Prelude ( partition )  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Maximize -- -- Then edit your @layoutHook@ by adding the Maximize layout modifier: ----- > myLayout = maximize (Tall 1 (3/100) (1/2)) ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > myLayout = maximize (Tall 1 (3/100) (1/2)) ||| Full ||| etc..)+-- > main = xmonad def { layoutHook = myLayout } ----- For more detailed instructions on editing the layoutHook see:+-- Or, if you want to control the amount of padding placed around the+-- maximized window: ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- > myLayout = maximizeWithPadding 10 (Tall 1 (3/100) (1/2)) ||| Full ||| etc..)+-- > main = xmonad def { layoutHook = myLayout } --+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".+-- -- In the key-bindings, do something like: -- -- >        , ((modm, xK_backslash), withFocused (sendMessage . maximizeRestore))@@ -49,38 +57,45 @@ -- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data Maximize a = Maximize (Maybe Window) deriving ( Read, Show )+data Maximize a = Maximize Dimension (Maybe Window) deriving ( Read, Show ) maximize :: LayoutClass l Window => l Window -> ModifiedLayout Maximize l Window-maximize = ModifiedLayout $ Maximize Nothing+maximize = ModifiedLayout $ Maximize 25 Nothing -data MaximizeRestore = MaximizeRestore Window deriving ( Typeable, Eq )+-- | Like 'maximize', but allows you to specify the amount of padding+-- placed around the maximized window.+maximizeWithPadding :: LayoutClass l Window => Dimension -> l Window -> ModifiedLayout Maximize l Window+maximizeWithPadding padding = ModifiedLayout $ Maximize padding Nothing++newtype MaximizeRestore = MaximizeRestore Window deriving ( Eq ) instance Message MaximizeRestore maximizeRestore :: Window -> MaximizeRestore maximizeRestore = MaximizeRestore  instance LayoutModifier Maximize Window where-    modifierDescription (Maximize _) = "Maximize"-    pureModifier (Maximize (Just target)) rect (Just (S.Stack focused _ _)) wrs =+    modifierDescription (Maximize _ _) = "Maximize"+    pureModifier (Maximize padding (Just target)) rect (Just (S.Stack focused _ _)) wrs =             if focused == target                 then (maxed ++ rest, Nothing)                 else (rest ++ maxed, lay)         where             (toMax, rest) = partition (\(w, _) -> w == target) wrs             maxed = map (\(w, _) -> (w, maxRect)) toMax-            maxRect = Rectangle (rect_x rect + 25) (rect_y rect + 25)-                (rect_width rect - 50) (rect_height rect - 50)-            lay | null maxed = Just (Maximize Nothing)+            maxRect = Rectangle (rect_x rect + fromIntegral padding)+                                (rect_y rect + fromIntegral padding)+                                (rect_width rect  - padding * 2)+                                (rect_height rect - padding * 2)+            lay | null maxed = Just (Maximize padding Nothing)                 | otherwise  = Nothing     pureModifier _ _ _ wrs = (wrs, Nothing) -    pureMess (Maximize mw) m = case fromMessage m of+    pureMess (Maximize padding mw) m = case fromMessage m of         Just (MaximizeRestore w) -> case mw of-            Just w' -> if (w == w')-                        then Just $ Maximize Nothing   -- restore window-                        else Just $ Maximize $ Just w  -- maximize different window-            Nothing -> Just $ Maximize $ Just w        -- maximize window+            Just w' -> if w == w'+                        then Just $ Maximize padding Nothing   -- restore window+                        else Just $ Maximize padding $ Just w  -- maximize different window+            Nothing -> Just $ Maximize padding $ Just w        -- maximize window         _ -> Nothing  -- vim: sw=4:et
XMonad/Layout/MessageControl.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.MessageControl+-- Description :  Message escaping and filtering facilities. -- Copyright   :  (c) 2008 Quentin Moser -- License     :  BSD3 --@@ -31,12 +32,10 @@  import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..)) -import Data.Typeable (Typeable)-import Control.Applicative ((<$>)) import Control.Arrow (second)  -- $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.hs@ file: -- -- > import XMonad.Layout.MessageEscape --@@ -46,7 +45,6 @@ -- -- > import XMonad.Layout.Master (mastered) -- > import XMonad.Layout.Tabbed (simpleTabbed)--- > import XMonad.Layout.LayoutCombinators ((|||)) -- > -- > myLayout = Tall ||| unEscape (mastered 0.01 0.5 $ Full ||| simpleTabbed) --@@ -63,20 +61,17 @@ -- >                       unEscape $ mastered 0.01 0.5 -- >                         $ Full ||| simpleTabbed) ----- /IMPORTANT NOTE:/ The standard '(|||)' operator from "XMonad.Layout"--- does not behave correctly with 'ignore'. Make sure you use the one--- from "XMonad.Layout.LayoutCombinators".  -- | the Ignore layout modifier. Prevents its inner layout from receiving -- messages of a certain type. -data Ignore m l w = I (l w)+newtype Ignore m l w = I (l w)                     deriving (Show, Read)  instance (Message m, LayoutClass l w) => LayoutClass (Ignore m l) w where     runLayout ws r = second (I <$>) <$> runLayout (unILayout ws) r         where  unILayout :: Workspace i (Ignore m l w) w -> Workspace i (l w) w-               unILayout w@(Workspace { layout = (I l) }) = w { layout = l }+               unILayout w@Workspace{ layout = (I l) } = w { layout = l }     handleMessage l@(I l') sm         = case fromMessageAs sm l of             Just _ -> return Nothing@@ -101,8 +96,6 @@ -- | Data type for an escaped message. Send with 'escape'.  newtype EscapedMessage = Escape SomeMessage-    deriving Typeable- instance Message EscapedMessage  @@ -115,12 +108,12 @@ -- | Applies the UnEscape layout modifier to a layout.  unEscape :: LayoutClass l w => l w -> ModifiedLayout UnEscape l w-unEscape l = ModifiedLayout UE l+unEscape = ModifiedLayout UE   -- | Applies the Ignore layout modifier to a layout, blocking -- all messages of the same type as the one passed as its first argument.  ignore :: (Message m, LayoutClass l w)-          => m -> l w -> (Ignore m l w)-ignore _ l = I l+          => m -> l w -> Ignore m l w+ignore _ = I
XMonad/Layout/Minimize.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleContexts, PatternGuards #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts, PatternGuards #-} ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Minimize+-- Description :  Minimize windows, temporarily removing them from the layout. -- Copyright   :  (c) Jan Vornberger 2009, Alejandro Serrano 2010 -- License     :  BSD3-style (see LICENSE) --@@ -17,127 +18,58 @@ module XMonad.Layout.Minimize (         -- * Usage         -- $usage-        minimize,-        minimizeWindow,-        MinimizeMsg(RestoreMinimizedWin,RestoreNextMinimizedWin),         Minimize,+        minimize,     ) where  import XMonad import qualified XMonad.StackSet as W+import XMonad.Util.Minimize (Minimized(..)) import XMonad.Layout.LayoutModifier import XMonad.Layout.BoringWindows as BW-import XMonad.Util.WindowProperties (getProp32)-import Data.List-import qualified Data.Map as M-import Data.Maybe-import Foreign.C.Types (CLong)+import qualified XMonad.Util.ExtensibleState as XS  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Minimize -- -- Then edit your @layoutHook@ by adding the Minimize layout modifier: -- -- > myLayout = minimize (Tall 1 (3/100) (1/2)) ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"------ In the key-bindings, do something like:------ >        , ((modm,               xK_m     ), withFocused minimizeWindow)--- >        , ((modm .|. shiftMask, xK_m     ), sendMessage RestoreNextMinimizedWin)------ The first action will minimize the focused window, while the second one will restore--- the next minimized window.------ For detailed instruction on editing the key binding see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- The module is designed to work together with "XMonad.Layout.BoringWindows" so -- that minimized windows will be skipped over when switching the focused window with -- the keyboard. Include 'BW.boringWindows' in your layout hook and see the -- documentation of "XMonad.Layout.BoringWindows" on how to modify your keybindings. --+-- See "XMonad.Actions.Minimize" for possible actions for minimizing/restoring windows+-- -- Also see "XMonad.Hooks.Minimize" if you want to be able to minimize -- and restore windows from your taskbar. -data Minimize a = Minimize [Window] (M.Map Window W.RationalRect) deriving ( Read, Show )-minimize :: LayoutClass l Window => l Window -> ModifiedLayout Minimize l Window-minimize = ModifiedLayout $ Minimize [] M.empty+data Minimize a = Minimize deriving ( Read, Show )+minimize :: l Window -> ModifiedLayout Minimize l Window+minimize = ModifiedLayout Minimize -data MinimizeMsg = MinimizeWin Window-                    | RestoreMinimizedWin Window-                    | RestoreNextMinimizedWin-                    deriving (Typeable, Eq)-instance Message MinimizeMsg -minimizeWindow :: Window -> X ()-minimizeWindow w = sendMessage (MinimizeWin w) >> BW.focusDown--setMinimizedState :: Window -> Int -> (CLong -> [CLong] -> [CLong]) -> X ()-setMinimizedState win st f = do-    setWMState win st-    withDisplay $ \dpy -> do-        wm_state <- getAtom "_NET_WM_STATE"-        mini <- getAtom "_NET_WM_STATE_HIDDEN"-        wstate <- fromMaybe [] `fmap` getProp32 wm_state win-        let ptype = 4 -- The atom property type for changeProperty-            fi_mini = fromIntegral mini-        io $ changeProperty32 dpy win wm_state ptype propModeReplace (f fi_mini wstate)--setMinimized :: Window -> X ()-setMinimized win = setMinimizedState win iconicState (:)--setNotMinimized :: Window -> X ()-setNotMinimized win = setMinimizedState win normalState delete- instance LayoutModifier Minimize Window where     modifierDescription _ = "Minimize" -    modifyLayout (Minimize minimized _) wksp rect = do+    modifyLayout Minimize wksp rect = do+        minimized <- XS.gets minimizedStack         let stack = W.stack wksp-            filtStack = stack >>=W.filter (\w -> not (w `elem` minimized))+            filtStack = stack >>= W.filter (`notElem` minimized)         runLayout (wksp {W.stack = filtStack}) rect -    handleMess (Minimize minimized unfloated) m-        | Just (MinimizeWin w) <- fromMessage m, not (w `elem` minimized) = do-                setMinimized w-                ws <- gets windowset-                case M.lookup w (W.floating ws) of-                  Nothing -> return $ Just $ Minimize (w:minimized) unfloated-                  Just r -> do-                    modify (\s -> s { windowset = W.sink w ws})-                    return $ Just $ Minimize (w:minimized) (M.insert w r unfloated)-        | Just (RestoreMinimizedWin w) <- fromMessage m = do-            setNotMinimized w-            case M.lookup w unfloated of-              Nothing -> return $ Just $ Minimize (minimized \\ [w]) unfloated-              Just r -> do-                ws <- gets windowset-                modify (\s -> s { windowset = W.float w r ws})-                return $ Just $ Minimize (minimized \\ [w]) (M.delete w unfloated)-        | Just RestoreNextMinimizedWin <- fromMessage m = do-          ws <- gets windowset-          if not (null minimized)-            then case M.lookup (head minimized) unfloated of-              Nothing -> do-                let w = head minimized-                setNotMinimized w-                modify (\s -> s { windowset = W.focusWindow w ws})-                return $ Just $ Minimize (tail minimized) unfloated-              Just r -> do-                let w = head minimized-                setNotMinimized w-                modify (\s -> s { windowset = (W.focusWindow w . W.float w r) ws})-                return $ Just $ Minimize (tail minimized) (M.delete w unfloated)-            else return Nothing+    handleMess Minimize m         | Just BW.UpdateBoring <- fromMessage m = do+            minimized <- XS.gets minimizedStack             ws <- gets (W.workspace . W.current . windowset)             flip sendMessageWithNoRefresh ws $ BW.Replace "Minimize" minimized             return Nothing
XMonad/Layout/Monitor.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, DeriveDataTypeable, PatternGuards #-}+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Monitor+-- Description :  Layout modfier for displaying some window (monitor) above other windows. -- Copyright   :  (c) Roman Cheplyaka -- License     :  BSD-style (see LICENSE) --@@ -10,7 +11,7 @@ -- Stability   :  unstable -- Portability :  unportable ----- Layout modfier for displaying some window (monitor) above other windows+-- Layout modifier for displaying some window (monitor) above other windows. -- ----------------------------------------------------------------------------- module XMonad.Layout.Monitor (@@ -32,14 +33,14 @@     ) where  import XMonad+import XMonad.Prelude (unless) import XMonad.Layout.LayoutModifier import XMonad.Util.WindowProperties import XMonad.Hooks.ManageHelpers (doHideIgnore) import XMonad.Hooks.FadeInactive (setOpacity)-import Control.Monad  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Monitor --@@ -72,7 +73,7 @@ -- -- Add ManageHook to de-manage monitor windows and apply opacity settings. ----- > manageHook = myManageHook <+> manageMonitor clock+-- > manageHook = myManageHook <> manageMonitor clock -- -- Apply layout modifier. --@@ -115,7 +116,7 @@                     | ToggleMonitorNamed String                     | ShowMonitorNamed String                     | HideMonitorNamed String-    deriving (Read,Show,Eq,Typeable)+    deriving (Read,Show,Eq) instance Message MonitorMessage  withMonitor :: Property -> a -> (Window -> X a) -> X a
XMonad/Layout/Mosaic.hs view
@@ -1,7 +1,12 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, PatternGuards #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Mosaic+-- Description :  Give each window a specified amount of screen space relative to the others. -- Copyright   :  (c) 2009 Adam Vogt, 2007 James Webb -- License     :  BSD-style (see xmonad/LICENSE) --@@ -28,28 +33,22 @@  import Prelude hiding (sum) -import XMonad(Typeable,-              LayoutClass(doLayout, handleMessage, pureMessage, description),+import XMonad(LayoutClass(doLayout, handleMessage, pureMessage, description),               Message, X, fromMessage, withWindowSet, Resize(..),               splitHorizontallyBy, splitVerticallyBy, sendMessage, Rectangle)+import XMonad.Prelude (mplus, on, sortBy, sum) import qualified XMonad.StackSet as W import Control.Arrow(second, first)-import Control.Monad(mplus)-import Data.Foldable(Foldable,foldMap, sum)-import Data.Function(on)-import Data.List(sortBy)-import Data.Monoid(Monoid,mempty, mappend) - -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Mosaic -- -- Then edit your @layoutHook@ by adding the Mosaic layout: -- -- > myLayout = mosaic 2 [3,2] ||| Full ||| etc..--- > main = xmonad $ defaultConfig { layoutHook = myLayout }+-- > main = xmonad $ def { layoutHook = myLayout } -- -- Unfortunately, infinite lists break serialization, so don't use them. And if -- the list is too short, it is extended with @++ repeat 1@, which covers the@@ -63,16 +62,15 @@ -- --  > , ((modm, xK_r), sendMessage Reset) ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  data Aspect     = Taller     | Wider     | Reset     | SlopeMod ([Rational] -> [Rational])-    deriving (Typeable)  instance Message Aspect @@ -117,7 +115,7 @@         nextIx (ov,ix,mix)                 | mix <= 0 || ov = fromIntegral $ nls `div` 2                 | otherwise = max 0 $ (*fi (pred nls)) $ min 1 $ ix / fi mix-        rect = rects !! maybe (nls `div` 2) round (nextIx `fmap` state)+        rect = rects !! maybe (nls `div` 2) (round . nextIx) state         state' = fmap (\x@(ov,_,_) -> (ov,nextIx x,pred nls)) state                     `mplus` Just (True,fromIntegral nls / 2,pred nls)         ss' = maybe ss (const ss `either` const ssExt) $ zipRemain ss ssExt@@ -185,22 +183,15 @@ normalize x = let s = sum x in map (/s) x  data Tree a = Branch (Tree a) (Tree a) | Leaf a | Empty--instance Foldable Tree where-   foldMap _f Empty = mempty-   foldMap f (Leaf x) = f x-   foldMap f (Branch l r) = foldMap f l `mappend` foldMap f r+  deriving (Functor, Show, Foldable) -instance Functor Tree where-   fmap f (Leaf x) = Leaf $ f x-   fmap f (Branch l r) = Branch (fmap f l) (fmap f r)-   fmap _ Empty = Empty+instance Semigroup (Tree a) where+    Empty <> x = x+    x <> Empty = x+    x <> y = Branch x y  instance Monoid (Tree a) where     mempty = Empty-    mappend Empty x = x-    mappend x Empty = x-    mappend x y = Branch x y  makeTree ::  (Num a1, Ord a1) => (a -> a1) -> [a] -> Tree a makeTree _ [] = Empty
XMonad/Layout/MosaicAlt.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.MosaicAlt+-- Description :  An alternative version of "XMonad.Layout.Mosaic". -- Copyright   :  (c) 2007 James Webb -- License     :  BSD-style (see xmonad/LICENSE) --@@ -33,11 +34,11 @@ import XMonad import qualified XMonad.StackSet as W import qualified Data.Map as M-import Data.List ( sortBy )+import XMonad.Prelude ( sortBy ) import Data.Ratio  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.MosaicAlt -- > import qualified Data.Map as M@@ -45,11 +46,11 @@ -- Then edit your @layoutHook@ by adding the MosaicAlt layout: -- -- > myLayout = MosaicAlt M.empty ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- In the key-bindings, do something like: --@@ -62,7 +63,7 @@ -- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  data HandleWindowAlt =     ShrinkWindowAlt Window@@ -70,7 +71,7 @@     | TallWindowAlt Window     | WideWindowAlt Window     | ResetAlt-    deriving ( Typeable, Eq )+    deriving ( Eq ) instance Message HandleWindowAlt shrinkWindowAlt, expandWindowAlt :: Window -> HandleWindowAlt tallWindowAlt, wideWindowAlt :: Window -> HandleWindowAlt@@ -83,7 +84,7 @@  data Param = Param { area, aspect :: Rational } deriving ( Show, Read ) type Params = M.Map Window Param-data MosaicAlt a = MosaicAlt Params deriving ( Show, Read )+newtype MosaicAlt a = MosaicAlt Params deriving ( Show, Read )  instance LayoutClass MosaicAlt Window where     description _ = "MosaicAlt"@@ -91,7 +92,7 @@             return (arrange rect stack params', Just $ MosaicAlt params')         where             params' = ins (W.up stack) $ ins (W.down stack) $ ins [W.focus stack] params-            ins wins as = foldl M.union as $ map (`M.singleton` (Param 1 1.5)) wins+            ins wins as = foldl M.union as $ map (`M.singleton` Param 1 1.5) wins      handleMessage (MosaicAlt params) msg = return $ case fromMessage msg of         Just (ShrinkWindowAlt w) -> Just $ MosaicAlt $ alter params w (4 % 5) 1@@ -129,7 +130,7 @@  -- Split a list of windows in half by area. areaSplit :: Params -> [Window] -> (([Window], Rational), ([Window], Rational))-areaSplit params wins = gather [] 0 [] 0 wins+areaSplit params = gather [] 0 [] 0     where         gather a aa b ba (r : rs) =             if aa <= ba@@ -161,8 +162,8 @@ aspectBadness rect win params =         (if a < 1 then tall else wide) * sqrt(w * h)     where-        tall = if w < 700 then ((1 / a) * (700 / w)) else 1 / a-        wide = if w < 700 then a else (a * w / 700)+        tall = if w < 700 then (1 / a) * (700 / w) else 1 / a+        wide = if w < 700 then a else a * w / 700         a = (w / h) / fromRational (maybe 1.5 aspect $ M.lookup win params)         w = fromIntegral $ rect_width rect         h = fromIntegral $ rect_height rect
XMonad/Layout/MouseResizableTile.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.MouseResizableTile+-- Description :  Like "XMonad.Layout.ResizableTile", but use the mouse to adjust the layout. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -19,7 +20,7 @@                                     -- $usage                                     mouseResizableTile,                                     mouseResizableTileMirrored,-                                    MRTMessage (ShrinkSlave, ExpandSlave),+                                    MRTMessage (ShrinkSlave, ExpandSlave, SetMasterFraction, SetLeftSlaveFraction, SetRightSlaveFraction),                                      -- * Parameters                                     -- $mrtParameters@@ -34,12 +35,13 @@                                    ) where  import XMonad hiding (tile, splitVertically, splitHorizontallyBy)+import XMonad.Prelude import qualified XMonad.StackSet as W import XMonad.Util.XUtils-import Control.Applicative((<$>))+import Graphics.X11 as X  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.MouseResizableTile --@@ -48,12 +50,12 @@ -- will not work correctly here because of the use of the mouse.) -- -- > myLayout = mouseResizableTile ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You may also want to add the following key bindings: --@@ -62,7 +64,7 @@ -- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- $mrtParameters -- The following functions are also labels for updating the @data@ (whose@@ -80,7 +82,6 @@                     | SetRightSlaveFraction Int Rational                     | ShrinkSlave                     | ExpandSlave-                    deriving Typeable instance Message MRTMessage  data DraggerInfo = MasterDragger Position Rational@@ -146,14 +147,14 @@                                             (rightFracs st ++ repeat (slaveFrac st)) sr' num drg             rects' = map (mirrorAdjust id mirrorRect . sanitizeRectangle sr') rects         mapM_ deleteDragger $ draggers st-        (draggerWrs, newDraggers) <- unzip <$> mapM+        (draggerWrs, newDraggers) <- mapAndUnzipM                                         (createDragger sr . adjustForMirror (isMirrored st))                                         preparedDraggers         return (draggerWrs ++ zip wins rects', Just $ st { draggers = newDraggers,                                                               focusPos = length l,                                                               numWindows = length wins })         where-            mirrorAdjust a b = if (isMirrored st)+            mirrorAdjust a b = if isMirrored st                                 then b                                 else a @@ -190,15 +191,24 @@ draggerGeometry (FixedDragger g d) =     return (fromIntegral $ g `div` 2, g, fromIntegral $ d `div` 2, d) draggerGeometry BordersDragger = do-    w <- asks (borderWidth . config)+    wins <- gets windowset+    w <- case W.peek wins of+          Just win -> getBorderWidth win+          _        -> asks (borderWidth . config)     return (0, 0, fromIntegral w, 2*w) +getBorderWidth :: Window -> X Dimension+getBorderWidth win = do+    d <- asks display+    (_,_,_,_,_,w,_) <- io $ X.getGeometry d win+    return w+ adjustForMirror :: Bool -> DraggerWithRect -> DraggerWithRect adjustForMirror False dragger = dragger adjustForMirror True (draggerRect, draggerCursor, draggerInfo) =         (mirrorRect draggerRect, draggerCursor', draggerInfo)     where-        draggerCursor' = if (draggerCursor == xC_sb_h_double_arrow)+        draggerCursor' = if draggerCursor == xC_sb_h_double_arrow                             then xC_sb_v_double_arrow                             else xC_sb_h_double_arrow @@ -234,8 +244,8 @@  sanitizeRectangle :: Rectangle -> Rectangle -> Rectangle sanitizeRectangle (Rectangle sx sy swh sht) (Rectangle x y wh ht) =-    (Rectangle (within 0 (sx + fromIntegral swh) x) (within 0 (sy + fromIntegral sht) y)-                (within 1 swh wh) (within 1 sht ht))+    Rectangle (within 0 (sx + fromIntegral swh) x) (within 0 (sy + fromIntegral sht) y)+                (within 1 swh wh) (within 1 sht ht)  within :: (Ord a) => a -> a -> a -> a within low high a = max low $ min high a
XMonad/Layout/MultiColumns.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.MultiColumns+-- Description :  A layout that tiles windows in a growing number of columns. -- Copyright   :  (c) Anders Engstrom <ankaan@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -25,22 +26,22 @@ import XMonad import qualified XMonad.StackSet as W -import Control.Monad+import XMonad.Prelude  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.MultiColumns -- -- Then edit your @layoutHook@ by adding the multiCol layout: -- -- > myLayouts = multiCol [1] 4 0.01 0.5 ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayouts }+-- > main = xmonad def { layoutHook = myLayouts } -- -- Or alternatively: -- -- > myLayouts = Mirror (multiCol [1] 2 0.01 (-0.25)) ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayouts }+-- > main = xmonad def { layoutHook = myLayouts } -- -- The maximum number of windows in a column can be controlled using the -- IncMasterN messages and the column containing the focused window will be@@ -55,9 +56,9 @@ -- columns, the screen is instead split equally among all columns. Therefore, -- if equal size among all columns are desired, set the size to -0.5. ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | Layout constructor. multiCol@@ -77,10 +78,9 @@   } 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,13 +90,14 @@               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)]             where resize Shrink = l { multiColSize = max (-0.5) $ s-ds }                   resize Expand = l { multiColSize = min 1 $ s+ds }-                  incmastern (IncMasterN x) = l { multiColNWin = take a n ++ [newval] ++ tail r }-                      where newval =  max 0 $ head r + x+                  incmastern (IncMasterN x) = l { multiColNWin = take a n ++ [newval] ++ drop 1 r }+                      where newval = max 0 $ maybe 0 (x +) (listToMaybe r)                             r = drop a n                   n = multiColNWin l                   ds = multiColDeltaSize l@@ -104,6 +105,10 @@                   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@@ -124,17 +129,14 @@           -- Compute number of windows in last column and add it to the others           col = c ++ [n-sum c]           -- Compute width of columns-          width = if s>0-                  then if ncol==1-                       -- Only one window-                       then [fromIntegral $ rect_width r]-                       -- Give the master it's space and split the rest equally for the other columns-                       else size:replicate (ncol-1) ((fromIntegral (rect_width r) - size) `div` (ncol-1))-                  else if fromIntegral ncol * abs s >= 1-                       -- Split equally-                       then replicate ncol $ fromIntegral (rect_width r) `div` ncol-                       -- Let the master cover what is left...-                       else (fromIntegral (rect_width r) - (ncol-1)*size):replicate (ncol-1) size+          width+            | s>0 = if ncol==1+                    -- Only one window+                    then [fromIntegral $ rect_width r]+                    -- Give the master it's space and split the rest equally for the other columns+                    else size:replicate (ncol-1) ((fromIntegral (rect_width r) - size) `div` (ncol-1))+            | fromIntegral ncol * abs s >= 1 = replicate ncol $ fromIntegral (rect_width r) `div` ncol+            | otherwise = (fromIntegral (rect_width r) - (ncol-1)*size):replicate (ncol-1) size           -- Compute the horizontal position of columns           xpos = accumEx (fromIntegral $ rect_x r) width           -- Exclusive accumulation@@ -143,4 +145,4 @@           -- Create a rectangle for each column           cr = zipWith (\x w -> r { rect_x=fromIntegral x, rect_width=fromIntegral w }) xpos width           -- Split the columns into the windows-          rlist = concat $ zipWith (\num rect -> splitVertically num rect) col cr+          rlist = concat $ zipWith splitVertically col cr
+ XMonad/Layout/MultiDishes.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.MultiDishes+-- Description :  A layout stacking groups of extra windows underneath the master windows.+-- Copyright   :  (c) Jeremy Apthorp, Nathan Fairhurst+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Nathan Fairhurst <nathan.p3pictures@gmail.com>+-- Stability   :  unstable+-- Portability :  portable+--+-- MultiDishes is a layout that stacks groups of extra windows underneath+-- the master windows.+--+-----------------------------------------------------------------------------++module XMonad.Layout.MultiDishes (+                              -- * Usage+                              -- $usage+                              MultiDishes (..)+                            ) where++import XMonad+import XMonad.StackSet (integrate)+import XMonad.Prelude (ap)++-- $usage+-- You can use this module with the following in your @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+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "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
XMonad/Layout/MultiToggle.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards #-}+{-# LANGUAGE ExistentialQuantification, Rank2Types, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards, ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.MultiToggle+-- Description :  Dynamically apply and unapply transformers to your window layout. -- Copyright   :  (c) Lukas Mai -- License     :  BSD-style (see LICENSE) --@@ -25,6 +26,7 @@     single,     mkToggle,     mkToggle1,+    isToggleActive,      HList,     HCons,@@ -32,12 +34,13 @@ ) where  import XMonad+import XMonad.Prelude hiding (find)  import XMonad.StackSet (Workspace(..))  import Control.Arrow+import Data.IORef import Data.Typeable-import Data.Maybe  -- $usage -- The basic idea is to have a base layout and a set of layout transformers,@@ -86,11 +89,12 @@ -- which is an instance of the 'Transformer' class.  For example, here -- is the definition of @MIRROR@: ----- > data MIRROR = MIRROR deriving (Read, Show, Eq, Typeable)+-- > data MIRROR = MIRROR deriving (Read, Show, Eq) -- > 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+-- TypeSynonymInstances, MultiParamTypeClasses \#-}@ at the -- beginning of your file.  -- | A class to identify custom transformers (and look up transforming@@ -99,7 +103,7 @@     transform :: (LayoutClass l a) => t -> l a ->         (forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b -data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)+data  EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)  unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b unEL (EL x _) k = k x@@ -112,7 +116,6 @@  -- | Toggle the specified layout transformer. data Toggle a = forall t. (Transformer t a) => Toggle t-    deriving (Typeable)  instance (Typeable a) => Message (Toggle a) @@ -187,11 +190,11 @@ geq :: (Typeable a, Eq a, Typeable b) => a -> b -> Bool geq a b = Just a == cast b -instance (Typeable a, Show ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where+instance (Typeable a, Show ts, Typeable ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where     description mt = currLayout mt `unEL` \l -> description l      runLayout (Workspace i mt s) r = case currLayout mt of-        EL l det -> fmap (fmap . fmap $ (\x -> mt { currLayout = EL x det })) $+        EL l det -> (fmap . fmap $ (\x -> mt { currLayout = EL x det })) <$>             runLayout (Workspace i l s) r      handleMessage mt m@@ -199,14 +202,33 @@         , i@(Just _) <- find (transformers mt) t             = case currLayout mt of                 EL l det -> do-                    l' <- fromMaybe l `fmap` handleMessage l (SomeMessage ReleaseResources)+                    l' <- fromMaybe l <$> handleMessage l (SomeMessage ReleaseResources)                     return . Just $                         mt {                             currLayout = (if cur then id else transform' t) (EL (det l') id),                             currIndex = if cur then Nothing else i                         }-                    where cur = (i == currIndex mt)+                    where cur = i == currIndex mt+        | Just (MultiToggleActiveQueryMessage t ref :: MultiToggleActiveQueryMessage a) <- fromMessage m+        , i@(Just _) <- find (transformers mt) t+            = Nothing <$ io (writeIORef ref (Just (i == currIndex mt)))         | otherwise             = case currLayout mt of-                EL l det -> fmap (fmap (\x -> mt { currLayout = EL x det })) $+                EL l det -> fmap (\x -> mt { currLayout = EL x det }) <$>                     handleMessage l m++data MultiToggleActiveQueryMessage a = forall t. (Transformer t a) =>+    MultiToggleActiveQueryMessage t (IORef (Maybe Bool))++instance (Typeable a) => Message (MultiToggleActiveQueryMessage a)++-- | Query the state of a 'Transformer' on a given workspace.+--+-- To query the current workspace, use something like this:+--+-- > withWindowSet (isToggleActive t . W.workspace . W.current)+isToggleActive :: Transformer t Window => t -> WindowSpace -> X (Maybe Bool)+isToggleActive t w = do+    ref <- io $ newIORef Nothing+    sendMessageWithNoRefresh (MultiToggleActiveQueryMessage t ref) w+    io $ readIORef ref
XMonad/Layout/MultiToggle/Instances.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.MultiToggle.Instances+-- Description :  Common instances for "XMonad.Layout.MultiToggle". -- Copyright   :  (c) 2008  Brent Yorgey -- License     :  BSD-style (see LICENSE) --@@ -29,7 +30,7 @@                      | MIRROR        -- ^ Mirror the current layout.                      | NOBORDERS     -- ^ Remove borders.                      | SMARTBORDERS  -- ^ Apply smart borders.-  deriving (Read, Show, Eq, Typeable)+  deriving (Read, Show, Eq)  instance Transformer StdTransformers Window where     transform FULL         x k = k Full (const x)
+ XMonad/Layout/MultiToggle/TabBarDecoration.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.MultiToggle.TabBarDecoration+-- Copyright   :  (c) 2018  Lucian Poston+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  <lucianposton@pm.me>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides a simple transformer for use with "XMonad.Layout.MultiToggle" to+-- dynamically toggle "XMonad.Layout.TabBarDecoration".+-----------------------------------------------------------------------------++module XMonad.Layout.MultiToggle.TabBarDecoration (+    SimpleTabBar(..)+) where++import XMonad.Layout.MultiToggle++import XMonad+import XMonad.Layout.LayoutModifier+import XMonad.Layout.TabBarDecoration++-- $usage+-- To use this module with "XMonad.Layout.MultiToggle", add the @SIMPLETABBAR@+-- to your layout For example, from a basic layout like+--+-- > layout = tiled ||| Full+--+-- Add @SIMPLETABBAR@ by changing it this to+--+-- > layout = mkToggle (single SIMPLETABBAR) (tiled ||| Full)+--+-- You can now dynamically toggle the 'XMonad.Layout.TabBarDecoration'+-- transformation by adding a key binding such as @mod-x@ as follows.+--+-- > ...+-- >   , ((modm,               xK_x     ), sendMessage $ Toggle SIMPLETABBAR)+-- > ...++-- | Transformer for "XMonad.Layout.TabBarDecoration".+data SimpleTabBar = SIMPLETABBAR deriving (Read, Show, Eq)+instance Transformer SimpleTabBar Window where+    transform _ x k = k (simpleTabBar x) (\(ModifiedLayout _ (ModifiedLayout _ x')) -> x')
XMonad/Layout/Named.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Named+-- Description :  Assign a name to a given layout. -- Copyright   :  (c) David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -15,7 +16,7 @@ -- ----------------------------------------------------------------------------- -module XMonad.Layout.Named+module XMonad.Layout.Named {-# DEPRECATED "Use XMonad.Layout.Renamed instead" #-}     ( -- * Usage       -- $usage       named,@@ -26,7 +27,7 @@ import XMonad.Layout.Renamed  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Named --@@ -34,18 +35,14 @@ -- to some layout: -- -- > myLayout = named "real big" Full ||| (nameTail $ named "real big" $ Full) ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- Note that this module has been deprecated and may be removed in a future -- release, please use "XMonad.Layout.Renamed" instead.---- | (Deprecated) Rename a layout.-named :: String -> l a -> ModifiedLayout Rename l a-named s = renamed [Replace s]  -- | (Deprecated) Remove the first word of the name. nameTail :: l a -> ModifiedLayout Rename l a
XMonad/Layout/NoBorders.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- singleton in Data.List since base 4.15  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.NoBorders--- Copyright   :  (c) David Roundy <droundy@darcs.net>+-- Description :  Make a given layout display without borders.+-- Copyright   :  (c) --    David Roundy <droundy@darcs.net>+--                    2018  Yclept Nemo -- License     :  BSD3-style (see LICENSE) -- -- Maintainer  :  Spencer Janssen <spencerjanssen@gmail.com>@@ -18,28 +21,31 @@ -- ----------------------------------------------------------------------------- -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.Prelude hiding (singleton)+import           XMonad.Layout.LayoutModifier+import qualified XMonad.StackSet                as W+import qualified XMonad.Util.Rectangle          as R +import qualified Data.Map                       as M++ -- $usage--- You can use this module with the following in your ~\/.xmonad\/xmonad.hs file:+-- You can use this module with the following in your xmonad.hs file: -- -- > import XMonad.Layout.NoBorders --@@ -48,9 +54,9 @@ -- -- > layoutHook = ... ||| noBorders Full ||| ... ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- todo, use an InvisibleList. data WithBorder a = WithBorder Dimension [a] deriving ( Read, Show )@@ -100,34 +106,94 @@ -- 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.++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.+{-# DEPRECATED borderEventHook "No longer needed." #-}+borderEventHook :: Event -> X All+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 = resetBorder w+        | Just DestroyWindowEvent { ev_window = w } <- fromMessage m = resetBorder w+        | otherwise = Nothing+      where+        resetBorder w =+            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+ -- | 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 +202,98 @@ -- 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,-                      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]+            screens = [ scr | scr <- W.screens wset+                            , case amb of+                                    Never -> True+                                    _     -> not $ null $ integrate scr+                            , not . R.empty . screenRect+                                $ W.screenDetail scr+                            ]++            -- Find the screen containing the workspace being layouted.+            -- (This is a list only to avoid the need to specialcase when it+            -- can't be found or when several contain @lr@. When that happens,+            -- the result will probably be incorrect.)+            thisScreen = [ scr | scr <- W.screens wset+                               , screenRect (W.screenDetail scr) `R.supersetOf` lr ]++            -- This originally considered all floating windows across all+            -- workspaces. It seems more efficient to have each screen manage+            -- its own floating windows - and necessary to support the+            -- additional OnlyLayoutFloat* variants correctly in multihead+            -- setups. In some cases the previous code would redundantly add+            -- then remove borders from already-borderless windows.+            floating = do+                scr <- thisScreen+                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.integrate' . W.stack . W.workspace $ scr+                        Just wr <- [M.lookup w (W.floating wset)]+                        return (w,scaleRationalRect sr wr)+                    sr = screenRect . W.screenDetail $ scr+                (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+                    OnlyFloat ->+                        True+                    _ ->+                        wr1 `R.supersetOf` sr+                return w1+             ms = filter (`elem` W.integrate' mst) $ map fst wrs             tiled [w]               | Screen <- amb = [w]+              | OnlyScreenFloat <- amb = []+              | OnlyLayoutFloat <- amb = []               | OnlyFloat <- amb = []+              | OnlyLayoutFloatBelow <- amb = []               | OtherIndicated <- amb               , let nonF = map integrate $ W.current wset : W.visible wset               , length (concat nonF) > length wrs@@ -174,23 +306,37 @@ -- 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.+    | 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.+    | OnlyScreenFloat+        -- ^ Only remove borders on floating windows that cover the whole+        -- screen.+    | Never+        -- ^ Like 'OnlyScreenFloat', and also remove borders of tiled windows+        -- when not 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.+    | OnlyFloat+        -- ^ Remove borders on all floating windows; tiling windows of+        -- any kinds are not affected.+    | 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
XMonad/Layout/NoFrillsDecoration.hs view
@@ -2,6 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.NoFrillsDecoration+-- Description :  Most basic version of decoration for windows. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -30,15 +31,15 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.NoFrillsDecoration -- -- Then edit your @layoutHook@ by adding the NoFrillsDecoration to -- your layout: ----- > myL = noFrillsDeco shrinkText defaultTheme (layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }+-- > myL = noFrillsDeco shrinkText def (layoutHook def)+-- > main = xmonad def { layoutHook = myL } --  -- | Add very simple decorations to windows of a layout.@@ -46,7 +47,7 @@              -> l a -> ModifiedLayout (Decoration NoFrillsDecoration s) l a noFrillsDeco s c = decoration s c $ NFD True -data NoFrillsDecoration a = NFD Bool deriving (Show, Read)+newtype NoFrillsDecoration a = NFD Bool deriving (Show, Read)  instance Eq a => DecorationStyle NoFrillsDecoration a where     describeDeco _ = "NoFrillsDeco"
XMonad/Layout/OnHost.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}-+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.OnHost+-- Description :  Use layouts and apply layout modifiers selectively, depending on the host. -- Copyright   :  (c) Brandon S Allbery, Brent Yorgey -- License     :  BSD-style (see LICENSE) --@@ -26,14 +28,16 @@  import           XMonad import qualified XMonad.StackSet              as W+import           XMonad.Prelude  import           XMonad.Layout.LayoutModifier -import           Data.Maybe                        (fromMaybe)+import           Foreign                           (allocaArray0)+import           Foreign.C import           System.Posix.Env                  (getEnv)  -- $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.hs@ file: -- -- > import XMonad.Layout.OnHost --@@ -46,7 +50,7 @@ -- -- Note that @l1@, @l2@, and @l3@ can be arbitrarily complicated -- layouts, e.g. @(Full ||| smartBorders $ tabbed shrinkText--- defaultTConf ||| ...)@, and @m1@ can be any layout modifier, i.e. a+-- def ||| ...)@, and @m1@ can be any layout modifier, i.e. a -- function of type @(l a -> ModifiedLayout lm l a)@. -- -- In another scenario, suppose you wanted to have layouts A, B, and C@@ -55,11 +59,13 @@ -- -- > layoutHook = A ||| B ||| onHost "foo" D C ----- Note that we rely on '$HOST' being set in the environment, as is true on most--- modern systems; if it's not, you may want to use a wrapper around xmonad or--- perhaps use 'System.Posix.Env.setEnv' (or 'putEnv') to set it in 'main'.--- This is to avoid dragging in the network package as an xmonad dependency.--- If '$HOST' is not defined, it will behave as if the host name never matches.+-- Note that we rely on either @$HOST@ being set in the environment, or+-- <https://linux.die.net/man/2/gethostname gethostname> returning something+-- useful, as is true on most modern systems; if this is not the case for you,+-- you may want to use a wrapper around xmonad or perhaps use+-- 'System.Posix.Env.setEnv' (or 'putEnv') to set @$HOST@ in 'main'. If+-- neither of the two methods work, the module will behave as if the host name+-- never matches. -- -- Also note that '$HOST' is usually a fully qualified domain name, not a short name. -- If you use a short name, this code will try to truncate $HOST to match; this may@@ -70,8 +76,8 @@ --   'onHost', and so on. onHost :: (LayoutClass l1 a, LayoutClass l2 a)        => String -- ^ the name of the host to match-       -> (l1 a) -- ^ layout to use on the matched host-       -> (l2 a) -- ^ layout to use everywhere else+       -> l1 a   -- ^ layout to use on the matched host+       -> l2 a   -- ^ layout to use everywhere else        -> OnHost l1 l2 a onHost host = onHosts [host] @@ -79,10 +85,10 @@ --   another to use on all other hosts. onHosts :: (LayoutClass l1 a, LayoutClass l2 a)         => [String] -- ^ names of hosts to match-        -> (l1 a)   -- ^ layout to use on matched hosts-        -> (l2 a)   -- ^ layout to use everywhere else+        -> l1 a     -- ^ layout to use on matched hosts+        -> l2 a     -- ^ layout to use everywhere else         -> OnHost l1 l2 a-onHosts hosts l1 l2 = OnHost hosts False l1 l2+onHosts hosts = OnHost hosts False  -- | Specify a layout modifier to apply on a particular host; layouts --   on all other hosts will remain unmodified.@@ -115,16 +121,16 @@  instance (LayoutClass l1 a, LayoutClass l2 a, Show a) => LayoutClass (OnHost l1 l2) a where     runLayout (W.Workspace i p@(OnHost hosts _ lt lf) ms) r = do-      h <- io $ getEnv "HOST"+      h <- io $ getEnv "HOST" <|> getHostName       if maybe False (`elemFQDN` hosts) h         then do (wrs, mlt') <- runLayout (W.Workspace i lt ms) r                 return (wrs, Just $ mkNewOnHostT p mlt')         else do (wrs, mlt') <- runLayout (W.Workspace i lf ms) r                 return (wrs, Just $ mkNewOnHostF p mlt') -    handleMessage (OnHost hosts bool lt lf) m-        | bool      = handleMessage lt m >>= maybe (return Nothing) (\nt -> return . Just $ OnHost hosts bool nt lf)-        | otherwise = handleMessage lf m >>= maybe (return Nothing) (\nf -> return . Just $ OnHost hosts bool lt nf)+    handleMessage (OnHost hosts choice lt lf) m+        | choice    = handleMessage lt m >>= maybe (return Nothing) (\nt -> return . Just $ OnHost hosts choice nt lf)+        | otherwise = handleMessage lf m >>= maybe (return Nothing) (return . Just . OnHost hosts choice lt)      description (OnHost _ True  l1 _) = description l1     description (OnHost _ _     _ l2) = description l2@@ -136,7 +142,7 @@  mkNewOnHostF :: OnHost l1 l2 a -> Maybe (l2 a) -> OnHost l1 l2 a mkNewOnHostF (OnHost hosts _ lt lf) mlf' =-  (\lf' -> OnHost hosts False lt lf') $ fromMaybe lf mlf'+  OnHost hosts False lt $ fromMaybe lf mlf'  -- | 'Data.List.elem' except that if one side has a dot and the other doesn't, we truncate --   the one that does at the dot.@@ -153,3 +159,17 @@   | '.' `elem` a                 = takeWhile (/= '.') a ==                    b   |                 '.' `elem` b =                    a == takeWhile (/= '.') b   | otherwise                    =                    a ==                    b++-----------------------------------------------------------------------+-- cbits++foreign import ccall "gethostname" gethostname :: CString -> CSize -> IO CInt++getHostName :: IO (Maybe String)+getHostName = allocaArray0 size $ \cstr -> do+  throwErrnoIfMinus1_ "getHostName" $ gethostname cstr (fromIntegral size)+  peekCString cstr <&> \case+    "" -> Nothing+    s  -> Just s+ where+  size = 256
XMonad/Layout/OneBig.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.OneBig+-- Description :  Place one window at top left corner, and other windows at the top. -- Copyright   :  (c) 2009 Ilya Portnov -- License     :  BSD3-style (see LICENSE) --@@ -54,23 +55,25 @@  -- | Main layout function oneBigLayout :: OneBig a -> Rectangle -> W.Stack a -> [(a, Rectangle)]-oneBigLayout (OneBig cx cy) rect stack = [(master,masterRect)]-                                      ++ (divideBottom bottomRect bottomWs)-                                      ++ (divideRight rightRect rightWs)-      where ws = W.integrate stack-            n = length ws-            ht (Rectangle _ _ _ hh) = hh-            wd (Rectangle _ _ ww _) = ww-            h' = round (fromIntegral (ht rect)*cy)-            w = wd rect-            m = calcBottomWs n w h'-            master = head ws-            other  = tail ws-            bottomWs = take m other-            rightWs = drop m other-            masterRect = cmaster n m cx cy rect-            bottomRect = cbottom cy rect-            rightRect  = cright cx cy rect+oneBigLayout (OneBig cx cy) rect stack =+  let ws = W.integrate stack+      n  = length ws+   in case ws of+    []               -> []+    (master : other) -> [(master,masterRect)]+                     ++ divideBottom bottomRect bottomWs+                     ++ divideRight rightRect rightWs+     where+      ht (Rectangle _ _ _ hh) = hh+      wd (Rectangle _ _ ww _) = ww+      h' = round (fromIntegral (ht rect)*cy)+      w = wd rect+      m = calcBottomWs n w h'+      bottomWs = take m other+      rightWs = drop m other+      masterRect = cmaster n m cx cy rect+      bottomRect = cbottom cy rect+      rightRect  = cright cx cy rect  -- | Calculate how many windows must be placed at bottom calcBottomWs :: Int -> Dimension -> Dimension -> Int@@ -79,16 +82,16 @@                         2 -> 1                         3 -> 2                         4 -> 2-                        _ -> (fromIntegral w)*(n-1) `div` fromIntegral (h'+(fromIntegral w))+                        _ -> fromIntegral w*(n-1) `div` fromIntegral (h'+fromIntegral w)  -- | Calculate rectangle for master window cmaster:: Int -> Int -> Float -> Float -> Rectangle -> Rectangle cmaster n m cx cy (Rectangle x y sw sh) = Rectangle x y w h-    where w = if (n > m+1) then+    where w = if n > m+1 then                 round (fromIntegral sw*cx)               else                 sw-          h = if (n > 1) then+          h = if n > 1 then                 round (fromIntegral sh*cy)               else                 sh@@ -97,13 +100,13 @@ cbottom:: Float -> Rectangle -> Rectangle cbottom cy (Rectangle sx sy sw sh) = Rectangle sx y sw h     where h = round (fromIntegral sh*(1-cy))-          y = round (fromIntegral sh*cy+(fromIntegral sy))+          y = round (fromIntegral sh*cy+fromIntegral sy)  -- | Calculate rectangle for right windows cright:: Float -> Float -> Rectangle -> Rectangle cright cx cy (Rectangle sx sy sw sh) = Rectangle x sy w h     where w = round (fromIntegral sw*(1-cx))-          x = round (fromIntegral sw*cx+(fromIntegral sx))+          x = round (fromIntegral sw*cx+fromIntegral sx)           h = round (fromIntegral sh*cy)  -- | Divide bottom rectangle between windows@@ -116,7 +119,7 @@  -- | Divide right rectangle between windows divideRight :: Rectangle -> [a] -> [(a, Rectangle)]-divideRight (Rectangle x y w h) ws = if (n==0) then [] else zip ws rects+divideRight (Rectangle x y w h) ws = if n==0 then [] else zip ws rects     where n = length ws           oneH = fromIntegral h `div` n           oneRect = Rectangle x y w (fromIntegral oneH)@@ -129,5 +132,3 @@ -- | Shift rectangle bottom shiftB :: Position -> Rectangle -> Rectangle shiftB s (Rectangle x y w h) = Rectangle x (y+s) w h--
+ XMonad/Layout/PerScreen.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.PerScreen+-- Description :  Configure layouts based on the width of your screen.+-- Copyright   :  (c) Edward Z. Yang+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  <ezyang@cs.stanford.edu>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Configure layouts based on the width of your screen; use your+-- favorite multi-column layout for wide screens and a full-screen+-- layout for small ones.+-----------------------------------------------------------------------------++module XMonad.Layout.PerScreen+    ( -- * Usage+      -- $usage+      PerScreen,+      ifWider+    ) where++import XMonad+import qualified XMonad.StackSet as W++import XMonad.Prelude (fromMaybe)++-- $usage+-- You can use this module by importing it into your @xmonad.hs@ file:+--+-- > import XMonad.Layout.PerScreen+--+-- and modifying your layoutHook as follows (for example):+--+-- > layoutHook = ifWider 1280 (Tall 1 (3/100) (1/2) ||| Full) Full+--+-- Replace any of the layouts with any arbitrarily complicated layout.+-- ifWider can also be used inside other layout combinators.++ifWider :: (LayoutClass l1 a, LayoutClass l2 a)+               => Dimension   -- ^ target screen width+               -> l1 a        -- ^ layout to use when the screen is wide enough+               -> l2 a        -- ^ layout to use otherwise+               -> PerScreen l1 l2 a+ifWider w = PerScreen w False++data PerScreen l1 l2 a = PerScreen Dimension Bool (l1 a) (l2 a) deriving (Read, Show)++-- | Construct new PerScreen values with possibly modified layouts.+mkNewPerScreenT :: PerScreen l1 l2 a -> Maybe (l1 a) ->+                      PerScreen l1 l2 a+mkNewPerScreenT (PerScreen w _ lt lf) mlt' =+    (\lt' -> PerScreen w True lt' lf) $ fromMaybe lt mlt'++mkNewPerScreenF :: PerScreen l1 l2 a -> Maybe (l2 a) ->+                      PerScreen l1 l2 a+mkNewPerScreenF (PerScreen w _ lt lf) mlf' =+    PerScreen w False lt $ fromMaybe lf mlf'++instance (LayoutClass l1 a, LayoutClass l2 a, Show a) => LayoutClass (PerScreen l1 l2) a where+    runLayout (W.Workspace i p@(PerScreen w _ lt lf) ms) r+        | rect_width r > w    = do (wrs, mlt') <- runLayout (W.Workspace i lt ms) r+                                   return (wrs, Just $ mkNewPerScreenT p mlt')+        | otherwise           = do (wrs, mlt') <- runLayout (W.Workspace i lf ms) r+                                   return (wrs, Just $ mkNewPerScreenF p mlt')++    handleMessage (PerScreen w bool lt lf) m+        | bool      = handleMessage lt m >>= maybe (return Nothing) (\nt -> return . Just $ PerScreen w bool nt lf)+        | otherwise = handleMessage lf m >>= maybe (return Nothing) (return . Just . PerScreen w bool lt)++    description (PerScreen _ True  l1 _) = description l1+    description (PerScreen _ _     _ l2) = description l2
XMonad/Layout/PerWorkspace.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.PerWorkspace+-- Description :  Use layouts and apply layout modifiers selectively. -- Copyright   :  (c) Brent Yorgey -- License     :  BSD-style (see LICENSE) --@@ -25,12 +26,10 @@ import XMonad import qualified XMonad.StackSet as W -import XMonad.Layout.LayoutModifier--import Data.Maybe (fromMaybe)+import XMonad.Prelude (fromMaybe)  -- $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.hs@ file: -- -- > import XMonad.Layout.PerWorkspace --@@ -43,8 +42,9 @@ -- -- Note that @l1@, @l2@, and @l3@ can be arbitrarily complicated -- layouts, e.g. @(Full ||| smartBorders $ tabbed shrinkText--- defaultTConf ||| ...)@, and @m1@ can be any layout modifier, i.e. a--- function of type @(l a -> ModifiedLayout lm l a)@.+-- def ||| ...)@, and @m1@ can be any layout modifier, i.e. a+-- function of type @(l a -> ModifiedLayout lm l a)@. (In fact, @m1@ can be any+-- function @(LayoutClass l a, LayoutClass l' a) => l a -> l' a@.) -- -- In another scenario, suppose you wanted to have layouts A, B, and C -- available on all workspaces, except that on workspace foo you want@@ -57,8 +57,8 @@ --   'onWorkspace', and so on. onWorkspace :: (LayoutClass l1 a, LayoutClass l2 a)                => WorkspaceId -- ^ the tag of the workspace to match-               -> (l1 a)      -- ^ layout to use on the matched workspace-               -> (l2 a)      -- ^ layout to use everywhere else+               -> l1 a        -- ^ layout to use on the matched workspace+               -> l2 a        -- ^ layout to use everywhere else                -> PerWorkspace l1 l2 a onWorkspace wsId = onWorkspaces [wsId] @@ -66,28 +66,28 @@ --   another to use on all other workspaces. onWorkspaces :: (LayoutClass l1 a, LayoutClass l2 a)                 => [WorkspaceId]  -- ^ tags of workspaces to match-                -> (l1 a)         -- ^ layout to use on matched workspaces-                -> (l2 a)         -- ^ layout to use everywhere else+                -> l1 a           -- ^ layout to use on matched workspaces+                -> l2 a           -- ^ layout to use everywhere else                 -> PerWorkspace l1 l2 a-onWorkspaces wsIds l1 l2 = PerWorkspace wsIds False l1 l2+onWorkspaces wsIds = modWorkspaces wsIds . const  -- | Specify a layout modifier to apply to a particular workspace; layouts --   on all other workspaces will remain unmodified.-modWorkspace :: (LayoutClass l a)-             => WorkspaceId                     -- ^ tag of the workspace to match-             -> (l a -> ModifiedLayout lm l a)  -- ^ the modifier to apply on the matching workspace-             -> l a                             -- ^ the base layout-             -> PerWorkspace (ModifiedLayout lm l) l a+modWorkspace :: (LayoutClass l1 a, LayoutClass l2 a)+             => WorkspaceId    -- ^ tag of the workspace to match+             -> (l2 a -> l1 a)  -- ^ the modifier to apply on the matching workspace+             -> l2 a           -- ^ the base layout+             -> PerWorkspace l1 l2 a modWorkspace wsId = modWorkspaces [wsId]  -- | Specify a layout modifier to apply to a particular set of --   workspaces; layouts on all other workspaces will remain --   unmodified.-modWorkspaces :: (LayoutClass l a)-              => [WorkspaceId]                   -- ^ tags of the workspaces to match-              -> (l a -> ModifiedLayout lm l a)  -- ^ the modifier to apply on the matching workspaces-              -> l a                             -- ^ the base layout-              -> PerWorkspace (ModifiedLayout lm l) l a+modWorkspaces :: (LayoutClass l1 a, LayoutClass l2 a)+              => [WorkspaceId] -- ^ tags of the workspaces to match+              -> (l2 a -> l1 a) -- ^ the modifier to apply on the matching workspaces+              -> l2 a          -- ^ the base layout+              -> PerWorkspace l1 l2 a modWorkspaces wsIds f l = PerWorkspace wsIds False (f l) l  -- | Structure for representing a workspace-specific layout along with@@ -109,7 +109,7 @@      handleMessage (PerWorkspace wsIds bool lt lf) m         | bool      = handleMessage lt m >>= maybe (return Nothing) (\nt -> return . Just $ PerWorkspace wsIds bool nt lf)-        | otherwise = handleMessage lf m >>= maybe (return Nothing) (\nf -> return . Just $ PerWorkspace wsIds bool lt nf)+        | otherwise = handleMessage lf m >>= maybe (return Nothing) (return . Just . PerWorkspace wsIds bool lt)      description (PerWorkspace _ True  l1 _) = description l1     description (PerWorkspace _ _     _ l2) = description l2@@ -123,5 +123,4 @@ mkNewPerWorkspaceF :: PerWorkspace l1 l2 a -> Maybe (l2 a) ->                       PerWorkspace l1 l2 a mkNewPerWorkspaceF (PerWorkspace wsIds _ lt lf) mlf' =-    (\lf' -> PerWorkspace wsIds False lt lf') $ fromMaybe lf mlf'-+    PerWorkspace wsIds False lt $ fromMaybe lf mlf'
XMonad/Layout/PositionStoreFloat.hs view
@@ -2,6 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.PositionStoreFloat+-- Description :  A floating layout; designed with a dual-head setup in mind. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -29,12 +30,10 @@ import XMonad.Util.PositionStore import qualified XMonad.StackSet as S import XMonad.Layout.WindowArranger-import Control.Monad(when)-import Data.Maybe(isJust)-import Data.List(nub)+import XMonad.Prelude (fromMaybe, isJust, nub, when)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.PositionStoreFloat -- > import XMonad.Layout.NoFrillsDecoration@@ -45,8 +44,8 @@ -- BorderResize: -- -- > myLayouts = floatingDeco $ borderResize $ positionStoreFloat ||| etc..--- >               where floatingDeco l = noFrillsDeco shrinkText defaultTheme l--- > main = xmonad defaultConfig { layoutHook = myLayouts }+-- >               where floatingDeco l = noFrillsDeco shrinkText def l+-- > main = xmonad def { layoutHook = myLayouts } -- -- See the documentation of "XMonad.Hooks.PositionStoreHooks" on how -- to add the support hooks.@@ -54,7 +53,7 @@ positionStoreFloat :: PositionStoreFloat a positionStoreFloat = PSF (Nothing, []) -data PositionStoreFloat a = PSF (Maybe Rectangle, [a]) deriving (Show, Read)+newtype PositionStoreFloat a = PSF (Maybe Rectangle, [a]) deriving (Show, Read) instance LayoutClass PositionStoreFloat Window where     description _ = "PSF"     doLayout (PSF (maybeChange, paintOrder)) sr (S.Stack w l r) = do@@ -65,13 +64,12 @@                             Just changedRect -> (w, changedRect)             let wrs' = focused : wrs             let paintOrder' = nub (w : paintOrder)-            when (isJust maybeChange) $ do+            when (isJust maybeChange) $                 updatePositionStore focused sr             return (reorder wrs' paintOrder', Just $ PSF (Nothing, paintOrder'))         where-            pSQ posStore w' sr' = case (posStoreQuery posStore w' sr') of-                                    Just rect   -> rect-                                    Nothing     -> (Rectangle 50 50 200 200)  -- should usually not happen+            pSQ posStore w' sr' = fromMaybe (Rectangle 50 50 200 200)       -- should usually not happen+                                            (posStoreQuery posStore w' sr')     pureMessage (PSF (_, paintOrder)) m         | Just (SetGeometry rect) <- fromMessage m =             Just $ PSF (Just rect, paintOrder)@@ -83,10 +81,10 @@  reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)] reorder wrs order =-    let ordered = concat $ map (pickElem wrs) order-        rest = filter (\(w, _) -> not (w `elem` order)) wrs+    let ordered = concatMap (pickElem wrs) order+        rest = filter (\(w, _) -> w `notElem` order) wrs     in ordered ++ rest     where-        pickElem list e = case (lookup e list) of+        pickElem list e = case lookup e list of                                 Just result -> [(e, result)]                                 Nothing -> []
XMonad/Layout/Reflect.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Reflect+-- Description :  Reflect a layout horizontally or vertically. -- Copyright   :  (c) Brent Yorgey -- License     :  BSD-style (see LICENSE) --@@ -23,16 +24,15 @@                               ) where -import XMonad.Core+import XMonad.Prelude (fi) import Graphics.X11 (Rectangle(..), Window) import Control.Arrow (second)  import XMonad.Layout.LayoutModifier import XMonad.Layout.MultiToggle-import XMonad.Util.XUtils (fi)  -- $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.hs@ file: -- -- > import XMonad.Layout.Reflect --@@ -88,7 +88,7 @@   -data Reflect a = Reflect ReflectDir deriving (Show, Read)+newtype Reflect a = Reflect ReflectDir deriving (Show, Read)  instance LayoutModifier Reflect a where @@ -101,8 +101,8 @@  -------- instances for MultiToggle ------------------ -data REFLECTX = REFLECTX deriving (Read, Show, Eq, Typeable)-data REFLECTY = REFLECTY deriving (Read, Show, Eq, Typeable)+data REFLECTX = REFLECTX deriving (Read, Show, Eq)+data REFLECTY = REFLECTY deriving (Read, Show, Eq)  instance Transformer REFLECTX Window where     transform REFLECTX x k = k (reflectHoriz x) (\(ModifiedLayout _ x') -> x')
XMonad/Layout/Renamed.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Groups+-- Description :  Modify the description of a layout in a flexible way. -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -18,6 +19,7 @@ module XMonad.Layout.Renamed ( -- * Usage                                -- $usage                                renamed+                             , named                              , Rename(..) ) where  import XMonad@@ -28,7 +30,7 @@ -- -- > import XMonad.Layout.Renamed ----- to your @~\/.xmonad\/xmonad.hs@.+-- to your @xmonad.hs@. -- -- You can then use 'renamed' to modify the description of your -- layouts. For example:@@ -39,6 +41,10 @@ renamed :: [Rename a] -> l a -> ModifiedLayout Rename l a renamed = ModifiedLayout . Chain +-- | Rename a layout. (Convenience alias for @renamed [Replace s]@.)+named :: String -> l a -> ModifiedLayout Rename l a+named s = renamed [Replace s]+ -- | The available renaming operations data Rename a = CutLeft Int -- ^ Remove a number of characters from the left               | CutRight Int -- ^ Remove a number of characters from the right@@ -46,11 +52,13 @@               | Prepend String -- ^ Add a string on the left               | CutWordsLeft Int -- ^ Remove a number of words from the left               | CutWordsRight Int -- ^ Remove a number of words from the right+              | KeepWordsLeft Int -- ^ Keep a number of words from the left+              | KeepWordsRight Int -- ^ Keep a number of words from the right               | AppendWords String -- ^ Add a string to the right, prepending a space to it                                    -- if necessary               | PrependWords String -- ^ Add a string to the left, appending a space to it if                                     -- necessary-              | Replace String -- ^ Repace with another wtring+              | Replace String -- ^ Replace with another string               | Chain [Rename a] -- ^ Apply a list of modifications in left-to-right order   deriving (Show, Read, Eq) @@ -60,12 +68,15 @@ apply (CutWordsLeft i) s = unwords $ drop i $ words s apply (CutWordsRight i) s = let ws = words s                            in unwords $ take (length ws - i) ws+apply (KeepWordsLeft i) s = unwords $ take i $ words s+apply (KeepWordsRight i) s = let ws = words s+                           in unwords $ drop (length ws - i) ws apply (Replace s) _ = s apply (Append s') s = s ++ s' apply (Prepend s') s = s' ++ s apply (AppendWords s') s = unwords $ words s ++ [s'] apply (PrependWords s') s = unwords $ s' : words s-apply (Chain rs) s = ($s) $ foldr (flip (.)) id $ map apply rs+apply (Chain rs) s = ($ s) $ foldr (flip (.) . apply) id rs  instance LayoutModifier Rename a where     modifyDescription r l = apply r (description l)
+ XMonad/Layout/ResizableThreeColumns.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.ResizableThreeColumns+-- Description :  Like "XMonad.Layout.ThreeColumns", but allows resizing.+-- Copyright   :  (c) Sam Tay <sam.chong.tay@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  ?+-- Stability   :  unstable+-- Portability :  unportable+--+-- A layout similar to tall but with three columns. With 2560x1600 pixels this+-- layout can be used for a huge main window and up to six reasonable sized+-- resizable stack windows.+-----------------------------------------------------------------------------++module XMonad.Layout.ResizableThreeColumns (+                              -- * Usage+                              -- $usage+                              ResizableThreeCol(..), MirrorResize(..)+                             ) where++import XMonad hiding (splitVertically)+import XMonad.Prelude+import XMonad.Layout.ResizableTile(MirrorResize(..))+import qualified XMonad.StackSet as W++import qualified Data.Map as M+import Data.Ratio++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Layout.ResizableThreeColumns+--+-- Then edit your @layoutHook@ by adding the ResizableThreeCol layout:+--+-- > myLayout = ResizableThreeCol 1 (3/100) (1/2) [] ||| ResizableThreeColMid 1 (3/100) (1/2) [] ||| etc..+-- > main = xmonad def { layoutHook = myLayout }+--+-- The first argument specifies how many windows initially appear in the main+-- window. The second argument argument specifies the amount to resize while+-- resizing and the third argument specifies the initial size of the columns.+-- A positive size designates the fraction of the screen that the main window+-- should occupy, but if the size is negative the absolute value designates the+-- fraction a stack column should occupy. If both stack columns are visible,+-- they always occupy the same amount of space.+--+-- You may also want to add the following key bindings:+--+-- > , ((modm,               xK_a), sendMessage MirrorShrink)+-- > , ((modm,               xK_z), sendMessage MirrorExpand)+--+-- The ResizableThreeColMid variant places the main window between the stack columns.+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".+++-- | Arguments are nmaster, delta, fraction+data ResizableThreeCol a+  = ResizableThreeColMid+    { threeColNMaster :: !Int+    , threeColDelta :: !Rational+    , threeColFrac :: !Rational+    , threeColSlaves :: [Rational]+    }+  | ResizableThreeCol+    { threeColNMaster :: !Int+    , threeColDelta :: !Rational+    , threeColFrac :: !Rational+    , threeColSlaves :: [Rational]+    } deriving (Show,Read)++instance LayoutClass ResizableThreeCol a where+  doLayout (ResizableThreeCol n _ f mf) r    = doL False n f mf r+  doLayout (ResizableThreeColMid n _ f mf) r = doL True  n f mf r+  handleMessage l m = do+    ms <- W.stack . W.workspace . W.current <$> gets windowset+    fs <- M.keys . W.floating <$> gets windowset+    return $ do+      s <- ms+      -- make sure current stack isn't floating+      guard (W.focus s `notElem` fs)+      -- remove floating windows from stack+      let s' = s { W.up = W.up s \\ fs, W.down = W.down s \\ fs }+      -- handle messages+      msum [ fmap resize       (fromMessage m)+           , fmap (mresize s') (fromMessage m)+           , fmap incmastern   (fromMessage m)+           ]+    where+      resize Shrink = l { threeColFrac = max (-0.5) $ frac-delta }+      resize Expand = l { threeColFrac = min 1 $ frac+delta }+      mresize s MirrorShrink = mresize' s delta+      mresize s MirrorExpand = mresize' s (negate delta)+      mresize' s delt =+        let up = length $ W.up s+            down = length $ W.down s+            total = up + down + 1+            pos = if up == nmaster - 1           -- upper right+                  || up == total - 1             -- upper left+                  || up `elem` [down, down + 1]  -- lower right+                  then up - 1+                  else up+            mfrac' = modifymfrac (mfrac ++ repeat 1) delt pos+        in l { threeColSlaves = take total mfrac'}+      modifymfrac [] _ _ = []+      modifymfrac (f:fx) d n+        | n == 0    = f+d : fx+        | otherwise = f : modifymfrac fx d (n-1)+      incmastern (IncMasterN x) = l { threeColNMaster = max 0 (nmaster+x) }+      nmaster = threeColNMaster l+      delta = threeColDelta l+      frac = threeColFrac l+      mfrac = threeColSlaves l+  description _ = "ResizableThreeCol"++doL :: Bool -> Int -> Rational -> [Rational] -> Rectangle+    -> W.Stack a -> X ([(a, Rectangle)], Maybe (layout a))+doL middle nmaster f mf r =+  return+  . (, Nothing)+  . ap zip (tile3 middle f (mf ++ repeat 1) r nmaster . length) . W.integrate++-- | tile3.  Compute window positions using 3 panes+tile3 :: Bool -> Rational -> [Rational] -> Rectangle -> Int -> Int -> [Rectangle]+tile3 middle f mf r nmaster n+  | n <= nmaster || nmaster == 0 = splitVertically mf n r+  | n <= nmaster+1 = splitVertically mf nmaster s1+                  ++ splitVertically (drop nmaster mf) (n-nmaster) s2+  | otherwise = concat [ splitVertically mf nmaster r1+                       , splitVertically (drop nmaster mf) nstack1 r2+                       , splitVertically (drop (nmaster + nstack1) mf) nstack2 r3+                       ]+  where+    (r1, r2, r3) = split3HorizontallyBy middle (if f<0 then 1+2*f else f) r+    (s1, s2)     = splitHorizontallyBy (if f<0 then 1+f else f) r+    nstack       = n - nmaster+    nstack1      = ceiling (nstack % 2)+    nstack2      = nstack - nstack1++splitVertically :: RealFrac r => [r] -> Int -> Rectangle -> [Rectangle]+splitVertically [] _ r = [r]+splitVertically _ n r | n < 2 = [r]+splitVertically (f:fx) n (Rectangle sx sy sw sh) =+  let smallh = min sh (floor $ fi (sh `div` fi n) * f)+  in Rectangle sx sy sw smallh :+       splitVertically fx (n-1) (Rectangle sx (sy+fi smallh) sw (sh-smallh))++split3HorizontallyBy :: Bool -> Rational -> Rectangle -> (Rectangle, Rectangle, Rectangle)+split3HorizontallyBy middle f (Rectangle sx sy sw sh) =+  if middle+  then ( Rectangle (sx + fromIntegral r3w) sy r1w sh+       , Rectangle (sx + fromIntegral r3w + fromIntegral r1w) sy r2w sh+       , Rectangle sx sy r3w sh )+  else ( Rectangle sx sy r1w sh+       , Rectangle (sx + fromIntegral r1w) sy r2w sh+       , Rectangle (sx + fromIntegral r1w + fromIntegral r2w) sy r3w sh )+  where+    r1w = ceiling $ fromIntegral sw * f+    r2w = ceiling $ (sw - r1w) % 2+    r3w = sw - r1w - r2w
XMonad/Layout/ResizableTile.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ResizableTile+-- Description :  More useful tiled layout that allows you to change a width\/height of window. -- Copyright   :  (c) MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -21,24 +22,23 @@                                    ) where  import XMonad hiding (tile, splitVertically, splitHorizontallyBy)+import XMonad.Prelude import qualified XMonad.StackSet as W-import Control.Monad import qualified Data.Map as M-import Data.List ((\\))  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.ResizableTile -- -- Then edit your @layoutHook@ by adding the ResizableTile layout: -- -- > myLayout =  ResizableTall 1 (3/100) (1/2) [] ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You may also want to add the following key bindings: --@@ -47,9 +47,9 @@ -- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data MirrorResize = MirrorShrink | MirrorExpand deriving Typeable+data MirrorResize = MirrorShrink | MirrorExpand instance Message MirrorResize  data ResizableTall a = ResizableTall@@ -68,25 +68,25 @@  instance LayoutClass ResizableTall a where     doLayout (ResizableTall nmaster _ frac mfrac) r =-        return . (\x->(x,Nothing)) .+        return . (, Nothing) .         ap zip (tile frac (mfrac ++ repeat 1) r nmaster . length) . W.integrate     handleMessage (ResizableTall nmaster delta frac mfrac) m =-        do ms <- (W.stack . W.workspace . W.current) `fmap` gets windowset-           fs <- (M.keys . W.floating) `fmap` gets windowset+        do ms <- W.stack . W.workspace . W.current <$> gets windowset+           fs <- M.keys . W.floating <$> gets windowset            return $ ms >>= unfloat fs >>= handleMesg         where handleMesg s = msum [fmap resize (fromMessage m)-                                  ,fmap (\x -> mresize x s) (fromMessage m)+                                  ,fmap (`mresize` s) (fromMessage m)                                   ,fmap incmastern (fromMessage m)]               unfloat fs s = if W.focus s `elem` fs                                then Nothing-                               else Just (s { W.up = (W.up s) \\ fs-                                            , W.down = (W.down s) \\ fs })+                               else Just (s { W.up = W.up s \\ fs+                                            , W.down = W.down s \\ fs })               resize Shrink = ResizableTall nmaster delta (max 0 $ frac-delta) mfrac               resize Expand = ResizableTall nmaster delta (min 1 $ frac+delta) mfrac               mresize MirrorShrink s = mresize' s delta-              mresize MirrorExpand s = mresize' s (0-delta)+              mresize MirrorExpand s = mresize' s (negate delta)               mresize' s d = let n = length $ W.up s-                                 total = n + (length $ W.down s) + 1+                                 total = n + length (W.down s) + 1                                  pos = if n == (nmaster-1) || n == (total-1) then n-1 else n                                  mfrac' = modifymfrac (mfrac ++ repeat 1) d pos                              in ResizableTall nmaster delta frac $ take total mfrac'
XMonad/Layout/ResizeScreen.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ResizeScreen+-- Description :  A layout transformer to have a layout respect a given screen geometry. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -10,9 +11,9 @@ -- Portability :  unportable -- -- A layout transformer to have a layout respect a given screen--- geometry. Mostly used with "Decoration" (the Horizontal and the--- Vertical version will react to SetTheme and change their dimension--- accordingly.+-- geometry. Mostly used with "XMonad.Layout.Decoration" (the+-- Horizontal and the Vertical version will react to SetTheme and+-- change their dimension accordingly. -----------------------------------------------------------------------------  module XMonad.Layout.ResizeScreen@@ -30,7 +31,7 @@  -- $usage -- You can use this module by importing it into your--- @~\/.xmonad\/xmonad.hs@ file:+-- @xmonad.hs@ file: -- -- > import XMonad.Layout.ResizeScreen --@@ -38,9 +39,9 @@ -- -- > layoutHook = resizeHorizontal 40 Full ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  resizeHorizontal :: Int -> l a -> ModifiedLayout ResizeScreen l a resizeHorizontal i = ModifiedLayout (ResizeScreen L i)@@ -64,14 +65,13 @@ data ResizeMode = T | B | L | R deriving (Read, Show)  instance LayoutModifier ResizeScreen a where-    modifyLayout m ws rect@(Rectangle x y w h)+    modifyLayout m ws (Rectangle x y w h)         | ResizeScreen L i <- m = resize $ Rectangle (x + fi i) y (w - fi i) h         | ResizeScreen R i <- m = resize $ Rectangle x          y (w - fi i) h         | ResizeScreen T i <- m = resize $ Rectangle x (y + fi i) w (h - fi i)         | ResizeScreen B i <- m = resize $ Rectangle x  y         w (h - fi i)         | WithNewScreen  r <- m = resize r-        | otherwise             = resize rect-       where resize nr = runLayout ws nr+       where resize = runLayout ws      pureMess (ResizeScreen d _) m         | Just (SetTheme t) <- fromMessage m = Just $ ResizeScreen d (fi $ decoHeight t)
XMonad/Layout/Roledex.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Roledex+-- Description :  A completely pointless layout which acts like Microsoft's Flip 3D. -- Copyright   :  (c) tim.thelion@gmail.com -- License     :  BSD --@@ -26,18 +27,18 @@ import Data.Ratio  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Roledex -- -- Then edit your @layoutHook@ by adding the Roledex layout: -- -- > myLayout =  Roledex ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- $screenshot -- <<http://www.timthelion.com/rolodex.png>>@@ -49,8 +50,8 @@  roledexLayout :: Eq a => Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (Roledex a)) roledexLayout sc ws = return ([(W.focus ws, mainPane)] ++-                              (zip ups tops) ++-                              (reverse (zip dns bottoms))+                              zip ups tops +++                              reverse (zip dns bottoms)                                ,Nothing)  where ups    = W.up ws        dns    = W.down ws@@ -65,12 +66,12 @@             (Rectangle _ _ _ h) = sc             (Rectangle _ _ _ rh) = rect        mainPane = mrect (gw * fromIntegral c) (gh * fromIntegral c) rect-       mrect  mx my (Rectangle x y w h) = Rectangle (x + (fromIntegral mx)) (y + (fromIntegral my)) w h+       mrect  mx my (Rectangle x y w h) = Rectangle (x + fromIntegral mx) (y + fromIntegral my) w h        tops    = map f $ cd c (length dns)-       bottoms = map f $ [0..(length dns)]-       f n = mrect (gw * (fromIntegral n)) (gh * (fromIntegral n)) rect+       bottoms = map f [0..(length dns)]+       f n = mrect (gw * fromIntegral n) (gh * fromIntegral n) rect        cd n m = if n > m-                then (n - 1) : (cd (n-1) m)+                then (n - 1) : cd (n-1) m                 else []  div' :: Integral a => a -> a -> a
XMonad/Layout/ShowWName.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE CPP                   #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ShowWName+-- Description :  A layout modifier that will show the workspace name. -- Copyright   :  (c) Andrea Rossato 2007 -- License     :  BSD-style (see xmonad/LICENSE) --@@ -17,7 +21,7 @@       -- $usage       showWName     , showWName'-    , defaultSWNConfig+    , def     , SWNConfig(..)     , ShowWName     ) where@@ -31,19 +35,19 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.ShowWName--- > myLayout = layoutHook defaultConfig--- > main = xmonad defaultConfig { layoutHook = showWName myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > myLayout = layoutHook def+-- > main = xmonad def { layoutHook = showWName myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | A layout modifier to show the workspace name when switching showWName :: l a -> ModifiedLayout ShowWName l a-showWName = ModifiedLayout (SWN True defaultSWNConfig Nothing)+showWName = ModifiedLayout (SWN True def Nothing)  -- | A layout modifier to show the workspace name when switching. It -- is possible to provide a custom configuration.@@ -60,16 +64,20 @@          , swn_fade    :: Rational -- ^ Time in seconds of the name visibility     } deriving (Read, Show) -defaultSWNConfig :: SWNConfig-defaultSWNConfig =+instance Default SWNConfig where+  def =+#ifdef XFT+    SWNC { swn_font    = "xft:monospace-20"+#else     SWNC { swn_font    = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"+#endif          , swn_bgcolor = "black"          , swn_color   = "white"          , swn_fade    = 1          }  instance LayoutModifier ShowWName a where-    redoLayout      sn r _ wrs = doShow sn r wrs+    redoLayout      sn r _ = doShow sn r      handleMess (SWN _ c (Just (i,w))) m         | Just e    <- fromMessage m = handleTimer i e (deleteWindow w >> return Nothing)@@ -90,7 +98,7 @@   d <- asks display   n <- withWindowSet (return . S.currentTag)   f <- initXMF (swn_font c)-  width <- fmap (\w -> w + w `div` length n) $ textWidthXMF d f n+  width <- (\w -> w + w `div` length n) <$> textWidthXMF d f n   (as,ds) <- textExtentsXMF f n   let hight = as + ds       y     = fi sy + (fi ht - hight + 2) `div` 2@@ -99,6 +107,5 @@   showWindow w   paintAndWrite w f (fi width) (fi hight) 0 (swn_bgcolor c) "" (swn_color c) (swn_bgcolor c) [AlignCenter] [n]   releaseXMF f-  io $ sync d False   i <- startTimer (swn_fade c)   return (wrs, Just $ SWN False c $ Just (i,w))
+ XMonad/Layout/SideBorderDecoration.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+--------------------------------------------------------------------+-- |+-- Module      : XMonad.Layout.SideBorderDecoration+-- Description : Configure the border position around windows.+-- Copyright   : (c) 2018  L. S. Leary+--                   2022  Tony Zorman+-- License     : BSD3+-- Maintainer  : Tony Zorman <soliditsallgood@mailbox.org>+--+-- This module allows for having a configurable border position around+-- windows; i.e., it can move the border to any cardinal direction.+--+--------------------------------------------------------------------+module XMonad.Layout.SideBorderDecoration (+  -- * Usage+  -- $usage+  sideBorder,++  -- * Border configuration+  SideBorderConfig (..),+  def,++  -- * Re-exports+  Direction2D (..),++  -- * Lower-level hooks+  sideBorderLayout,+) where++import qualified XMonad.StackSet as W++import XMonad+import XMonad.Layout.Decoration+import XMonad.StackSet (Stack)+import XMonad.Util.Types++{- $usage++To use this module, first import it into your configuration file:++> import XMonad.Layout.SideBorderDecoration++You can now add the 'sideBorder' combinator to your configuration:++> main :: IO ()+> main = xmonad+>      $ …+>      $ sideBorder mySideBorderConfig+>      $ def { … }+>  where+>   mySideBorderConfig :: SideBorderConfig+>   mySideBorderConfig = def+>     { sbSide          = D+>     , sbActiveColor   = "#ff0000"+>     , sbInactiveColor = "#ffaaaa"+>     , sbSize          = 5+>     }++or, alternatively,++> main :: IO ()+> main = xmonad+>      $ …+>      $ sideBorder def{ sbSide = D, sbActiveColor = "#ff000", … }+>      $ def { … }++See 'SideBorderConfig' for the different size and colour options.++The following is a fully-functional, minimal configuration example:++> import XMonad+> import XMonad.Layout.SideBorderDecoration+>+> main :: IO ()+> main = xmonad $ sideBorder def $ def++This would result in the following border being displayed:++<<https://user-images.githubusercontent.com/50166980/184537672-136f85a3-dfe7-42e2-b4c8-356d934d1bff.png>>++-}++-----------------------------------------------------------------------+-- Configuration++-- | Configuring how the border looks like.+data SideBorderConfig = SideBorderConfig+  { sbSide          :: !Direction2D  -- ^ Which side to have the border on.+  , sbActiveColor   :: !String       -- ^ Active border colour.+  , sbInactiveColor :: !String       -- ^ Inactive border colour.+  , sbSize          :: !Dimension+    -- ^ Size of the border.  This will be the height if 'sbSide' is 'U'+    --   or 'D' and the width if it is 'L' or 'R'.+  }++instance Default SideBorderConfig where+  def :: SideBorderConfig+  def = SideBorderConfig+    { sbSide          = D+    , sbActiveColor   = "#ff0000"+    , sbInactiveColor = "#ffaaaa"+    , sbSize          = 5+    }++-----------------------------------------------------------------------+-- User-facing++-- | Move the default XMonad border to any of the four cardinal+-- directions.+--+-- Note that this function should only be applied once to your+-- configuration and should /not/ be combined with 'sideBorderLayout'.+sideBorder :: SideBorderConfig -> XConfig l -> XConfig (SideBorder l)+sideBorder sbc cfg =+  cfg{ layoutHook  = sideBorderLayout sbc (layoutHook cfg)+     , borderWidth = 0+     }++-- | Layout hook to only enable the side border for some layouts.  For+-- example:+--+-- > myLayout = Full ||| sideBorderLayout def tall ||| somethingElse+--+-- Note that, unlike 'sideBorder', this does /not/ disable the normal+-- border in XMonad, you will have to do this yourself.  Remove this+-- function from your layout hook and use 'sideBorder' if you want a+-- side border in every layout (do not use the two functions together).+sideBorderLayout :: Eq a => SideBorderConfig -> l a -> SideBorder l a+sideBorderLayout SideBorderConfig{ sbSide, sbActiveColor, sbInactiveColor, sbSize } =+  decoration BorderShrinker theme (SideBorderDecoration sbSide)+ where+  theme :: Theme+  theme = deco+    { activeColor   = sbActiveColor+    , inactiveColor = sbInactiveColor+    }+   where+    deco | sbSide `elem` [U, D] = def{ decoHeight = sbSize }+         | otherwise            = def{ decoWidth  = sbSize }++-----------------------------------------------------------------------+-- Decoration++newtype SideBorderDecoration a = SideBorderDecoration Direction2D+  deriving (Show, Read)++type SideBorder = ModifiedLayout (Decoration SideBorderDecoration BorderShrinker)++instance Eq a => DecorationStyle SideBorderDecoration a where+  shrink :: SideBorderDecoration a -> Rectangle -> Rectangle -> Rectangle+  shrink dec (Rectangle _ _ dw dh) (Rectangle x y w h) = case dec of+    SideBorderDecoration U -> Rectangle x           (y + fi dh) w        (h - dh)+    SideBorderDecoration R -> Rectangle x           y           (w - dw) h+    SideBorderDecoration D -> Rectangle x           y           w        (h - dh)+    SideBorderDecoration L -> Rectangle (x + fi dw) y           (w - dw) h++  pureDecoration+    :: SideBorderDecoration a+    -> Dimension -> Dimension+    -> Rectangle+    -> Stack a+    -> [(a, Rectangle)]+    -> (a, Rectangle)+    -> Maybe Rectangle+  pureDecoration dec dw dh _ st _ (win, Rectangle x y w h)+    | win `elem` W.integrate st && dw < w && dh < h = Just $ case dec of+      SideBorderDecoration U -> Rectangle x                 y                 w  dh+      SideBorderDecoration R -> Rectangle (x + fi (w - dw)) y                 dw h+      SideBorderDecoration D -> Rectangle x                 (y + fi (h - dh)) w  dh+      SideBorderDecoration L -> Rectangle x                 y                 dw h+    | otherwise = Nothing++-----------------------------------------------------------------------+-- Shrinker++-- | Kill all text.+data BorderShrinker = BorderShrinker++instance Show BorderShrinker where+  show :: BorderShrinker -> String+  show _ = ""++instance Read BorderShrinker where+  readsPrec :: Int -> ReadS BorderShrinker+  readsPrec _ s = [(BorderShrinker, s)]++instance Shrinker BorderShrinker where+  shrinkIt :: BorderShrinker -> String -> [String]+  shrinkIt _ _ = [""]
XMonad/Layout/SimpleDecoration.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.SimpleDecoration+-- Description :  Add simple decorations to the windows of a given layout. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -20,7 +21,7 @@       -- $usage       simpleDeco     , Theme (..)-    , defaultTheme+    , def     , SimpleDecoration (..)     , shrinkText, CustomShrink(CustomShrink)     , Shrinker(..)@@ -31,35 +32,35 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.SimpleDecoration -- -- Then edit your @layoutHook@ by adding the SimpleDecoration decoration to -- your layout: ----- > myL = simpleDeco shrinkText defaultTheme (layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }------ For more detailed instructions on editing the layoutHook see:+-- > myL = simpleDeco shrinkText def (layoutHook def)+-- > main = xmonad def { layoutHook = myL } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You can also edit the default configuration options. ----- > mySDConfig = defaultTheme { inactiveBorderColor = "red"--- >                                  , inactiveTextColor   = "red"}+-- > mySDConfig = def { inactiveBorderColor = "red"+-- >                  , inactiveTextColor   = "red"} -- -- and ----- > myL = dwmStyle shrinkText mySDConfig (layoutHook defaultTheme)+-- > myL = simpleDeco shrinkText mySDConfig (layoutHook def)  -- | Add simple decorations to windows of a layout. simpleDeco :: (Eq a, Shrinker s) => s -> Theme            -> l a -> ModifiedLayout (Decoration SimpleDecoration s) l a simpleDeco s c = decoration s c $ Simple True -data SimpleDecoration a = Simple Bool deriving (Show, Read)+newtype SimpleDecoration a = Simple Bool deriving (Show, Read)  instance Eq a => DecorationStyle SimpleDecoration a where     describeDeco _ = "Simple"
XMonad/Layout/SimpleFloat.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.SimpleFloat+-- Description :  A basic floating layout. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -32,18 +33,18 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.SimpleFloat -- -- Then edit your @layoutHook@ by adding the SimpleFloat layout: -- -- > myLayout = simpleFloat ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | A simple floating layout where every window is placed according -- to the window's initial attributes.@@ -51,7 +52,7 @@ -- This version is decorated with the 'SimpleDecoration' style. simpleFloat :: Eq a => ModifiedLayout (Decoration SimpleDecoration DefaultShrinker)                (ModifiedLayout MouseResize (ModifiedLayout WindowArranger SimpleFloat)) a-simpleFloat = decoration shrinkText defaultTheme (Simple False) (mouseResize $ windowArrangeAll $ SF 20)+simpleFloat = decoration shrinkText def (Simple False) (mouseResize $ windowArrangeAll $ SF 20)  -- | Same as 'simpleFloat', but with the possibility of setting a -- custom shrinker and a custom theme.@@ -60,7 +61,7 @@                (ModifiedLayout MouseResize (ModifiedLayout WindowArranger SimpleFloat)) a simpleFloat' s c = decoration s c (Simple False) (mouseResize $ windowArrangeAll $ SF (decoHeight c)) -data SimpleFloat a = SF Dimension deriving (Show, Read)+newtype SimpleFloat a = SF Dimension deriving (Show, Read) instance LayoutClass SimpleFloat Window where     description _ = "Float"     doLayout (SF i) sc (S.Stack w l r) = do@@ -75,6 +76,6 @@   let ny = ry + fi i       x  =  max rx $ fi $ wa_x wa       y  =  max ny $ fi $ wa_y wa-      wh = (fi $ wa_width  wa) + (bw * 2)-      ht = (fi $ wa_height wa) + (bw * 2)+      wh = fi (wa_width  wa) + (bw * 2)+      ht = fi (wa_height wa) + (bw * 2)   return (w, Rectangle x y wh ht)
XMonad/Layout/Simplest.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Simplest+-- Description :  A very simple layout. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -23,19 +26,19 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.Simplest -- -- Then edit your @layoutHook@ by adding the Simplest layout: -- -- > myLayout = Simplest ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  data Simplest a = Simplest deriving (Show, Read) instance LayoutClass Simplest a where-    pureLayout Simplest rec (S.Stack w l r) = zip (w : reverse l ++ r) (repeat rec)+    pureLayout Simplest rec (S.Stack w l r) = map (, rec) (w : reverse l ++ r)
XMonad/Layout/SimplestFloat.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.SimplestFloat+-- Description :  Like "XMonad.Layout.SimpleFloat" but without the decoration. -- Copyright   :  (c) 2008 Jussi Mäki -- License     :  BSD-style (see xmonad/LICENSE) --@@ -19,26 +20,26 @@     , SimplestFloat     ) where +import XMonad.Prelude (fi) import XMonad import qualified XMonad.StackSet as S import XMonad.Layout.WindowArranger import XMonad.Layout.LayoutModifier-import XMonad.Util.XUtils (fi)  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.SimplestFloat -- -- Then edit your @layoutHook@ by adding the SimplestFloat layout: -- -- > myLayout = simplestFloat ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | A simple floating layout where every window is placed according -- to the window's initial attributes.@@ -47,8 +48,8 @@  data SimplestFloat a = SF deriving (Show, Read) instance LayoutClass SimplestFloat Window where-    doLayout SF sc (S.Stack w l r) = fmap (flip (,) Nothing)-                                   $ mapM (getSize sc) (w : reverse l ++ r)+    doLayout SF sc (S.Stack w l r) =  (, Nothing)+                                  <$> mapM (getSize sc) (w : reverse l ++ r)     description _ = "SimplestFloat"  getSize :: Rectangle -> Window -> X (Window,Rectangle)@@ -58,6 +59,6 @@   wa <- io $ getWindowAttributes d w   let x  =  max rx $ fi $ wa_x wa       y  =  max ry $ fi $ wa_y wa-      wh = (fi $ wa_width  wa) + (bw * 2)-      ht = (fi $ wa_height wa) + (bw * 2)+      wh = fi (wa_width  wa) + (bw * 2)+      ht = fi (wa_height wa) + (bw * 2)   return (w, Rectangle x y wh ht)
+ XMonad/Layout/SortedLayout.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.SortedLayout+-- Description :  A layout modifier that sorts a given layout by a list of properties.+-- Copyright   :  (c) 2016 Kurt Dietrich+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  kurto@mac.com+-- Stability   :  unstable+-- Portability :  unportable+--+-- A 'LayoutModifier' that sorts the windows in another layout, given a+-- list of properties. The order of properties in the list determines+-- the order of windows in the final layout. Any unmatched windows+-- go to the end of the order.+-----------------------------------------------------------------------------++module XMonad.Layout.SortedLayout+  ( -- *Usage:+    -- $usage+  sorted+  , Property(..)+  ) where++import           XMonad+import           XMonad.Prelude hiding (Const)+import           XMonad.Layout.LayoutModifier+import           XMonad.StackSet              as W+import           XMonad.Util.WindowProperties++-- $usage+-- You can use this module with the following in your+-- @xmonad.hs@:+--+-- > import XMonad.Layout.SortedLayout+--+-- Then edit your @layoutHook@ to sort another layout (in this case, 'XMonad.Layout.Grid.Grid'):+--+-- > myLayout = sorted [ClassName "Firefox", ClassName "URxvt"] Grid+-- > main = xmonad def { layoutHook = myLayout }+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".+++-- | Modify a layout using a list of properties to sort its windows.+sorted :: [Property]+       -> l a+       -> ModifiedLayout SortedLayout l a+sorted props = ModifiedLayout . SortedLayout $ props ++ [Const True]++data WindowDescriptor = WindowDescriptor { wdSeqn :: !Integer+                                         , wdProp :: !Property+                                         , wdId   :: !Window+                                         } deriving (Show, Read)++instance Eq WindowDescriptor where+  (==) a b = wdId a == wdId b++instance Ord WindowDescriptor where+  compare a b = compare (wdSeqn a) (wdSeqn b)++newtype SortedLayout a = SortedLayout [Property] deriving (Show, Read)++instance LayoutModifier SortedLayout Window where+    modifyLayout (SortedLayout props) = sortLayout props+    modifierDescription _             = "Sorted"++findMatchingWindows :: Integer -> Property -> [Window] -> X [WindowDescriptor]+findMatchingWindows seqn prop wids =  fmap (fmap (WindowDescriptor seqn prop)) matching  where+  matching = filterM (hasProperty prop) wids++sortLayout :: (LayoutClass l Window)+           => [Property]+           -> W.Workspace WorkspaceId (l Window) Window+           -> Rectangle+           -> X ([(Window, Rectangle)], Maybe (l Window))+sortLayout props (W.Workspace w l r) rect = do+  let wids = W.integrate' r+  sortedWids <- map wdId . nub . sort . concat <$> zipWithM (\s p -> findMatchingWindows s p wids) [0..] props+  let sr = W.differentiate sortedWids+  runLayout (W.Workspace w l sr) rect
XMonad/Layout/Spacing.hs view
@@ -1,69 +1,384 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Spacing--- Copyright   :  (c) Brent Yorgey+-- Description :  Add a configurable amount of space around windows.+-- Copyright   :  (C) --   Brent Yorgey+--                    2018 Yclept Nemo -- License     :  BSD-style (see LICENSE) -- -- Maintainer  :  <byorgey@gmail.com> -- Stability   :  unstable--- Portability :  portable+-- Portability :  unportable -- -- Add a configurable amount of space around windows.+--+-- Note: For space\/gaps along edges of the /screen/ see "XMonad.Layout.Gaps". ----------------------------------------------------------------------------- -module XMonad.Layout.Spacing (-                               -- * Usage-                               -- $usage+module XMonad.Layout.Spacing+    ( -- * Usage+      -- $usage+      Spacing (..)+    , spacingRaw+    , spacing, spacingWithEdge+    , smartSpacing, smartSpacingWithEdge -                               spacing, Spacing,-                               smartSpacing, SmartSpacing,+      -- * Modify Spacing+    , SpacingModifier (..)+    , setSmartSpacing+    , setScreenSpacing, setScreenSpacingEnabled+    , setWindowSpacing, setWindowSpacingEnabled+    , toggleSmartSpacing+    , toggleScreenSpacingEnabled+    , toggleWindowSpacingEnabled+    , setScreenWindowSpacing+    , incWindowSpacing, incScreenSpacing+    , decWindowSpacing, decScreenSpacing+    , incScreenWindowSpacing, decScreenWindowSpacing -                             ) where+      -- * Modify Borders+    , Border (..)+    , borderMap, borderIncrementBy+    ) where -import Graphics.X11 (Rectangle(..))-import Control.Arrow (second)-import XMonad.Util.Font (fi)+import           XMonad+import           XMonad.StackSet                    as W+import qualified XMonad.Util.Rectangle              as R+import           XMonad.Layout.LayoutModifier+import           XMonad.Actions.MessageFeedback -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.hs@+-- file: -- -- > import XMonad.Layout.Spacing ----- and modifying your layoutHook as follows (for example):+-- and, for example, modifying your @layoutHook@ as follows: ----- > layoutHook = spacing 2 $ Tall 1 (3/100) (1/2)--- >                      -- put a 2px space around every window+-- > main :: IO ()+-- > main = xmonad $ def+-- >   { layoutHook = spacingWithEdge 10 $ myLayoutHook+-- >   }+-- >+-- > myLayoutHook = Full ||| ... --+-- The above would add a 10 pixel gap around windows on all sides, as+-- well as add the same amount of spacing around the edges of the+-- screen.  If you only want to add spacing around windows, you can use+-- 'spacing' instead.+--+-- There is also the 'spacingRaw' command, for more fine-grained+-- control.  For example:+--+-- > layoutHook = spacingRaw True (Border 0 10 10 10) True (Border 10 10 10 10) True+-- >            $ myLayoutHook+--+-- Breaking this down, the above would do the following:+--+--   - @True@: Enable the 'smartBorder' to not apply borders when there+--     is only one window.+--+--   - @(Border 0 10 10 10)@: Add a 'screenBorder' of 10 pixels in every+--     direction but the top.+--+--   - @True@: Enable the 'screenBorder'.+--+--   - @(Border 10 10 10 10)@: Add a 'windowBorder' of 10 pixels in+--     every direction.+--+--   - @True@: Enable the 'windowBorder'.+--+-- __Warning__: If you also use the 'avoidStruts' layout modifier, it+-- must come /before/ any of these modifiers. See the documentation of+-- 'avoidStruts' for details. --- | 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) -instance LayoutModifier Spacing a where+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 } -    pureModifier (Spacing p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)+    -- 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) -    modifierDescription (Spacing p) = "Spacing " ++ show p+    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 }+        | otherwise+        = Nothing -shrinkRect :: Int -> Rectangle -> Rectangle-shrinkRect p (Rectangle x y w h) = Rectangle (x+fi p) (y+fi p) (w-2*fi p) (h-2*fi p)+    modifierDescription Spacing {} =+        "Spacing" --- | 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) -data SmartSpacing a = SmartSpacing Int deriving (Show, Read)+-- | 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) -instance LayoutModifier SmartSpacing a where+-- | 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) -    pureModifier _ _ _ [x] = ([x], Nothing)-    pureModifier (SmartSpacing p) _ _ wrs = (map (second $ shrinkRect p) wrs, Nothing)+instance Message SpacingModifier -    modifierDescription (SmartSpacing p) = "SmartSpacing " ++ show p+-- | 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+    in  Border (t + o') (b + o') (r + o') (l + o')++-- | 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:+-----------------------------------------------------------------------------++-- | 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.+-- 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. See 'spacingRaw'.+smartSpacing :: Int -> l a -> ModifiedLayout Spacing l a+smartSpacing i = spacingRaw True (uniformBorder 0) False (uniformBorder i') True+    where i' = fromIntegral i++-- | 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
XMonad/Layout/Spiral.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Spiral+-- Description :  A spiral tiling layout. -- Copyright   :  (c) Joe Thornber <joe.thornber@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -30,21 +31,21 @@ import XMonad.StackSet ( integrate )  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Spiral -- -- Then edit your @layoutHook@ by adding the Spiral layout: -- -- > myLayout =  spiral (6/7) ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  fibs :: [Integer]-fibs = 1 : 1 : zipWith (+) fibs (tail fibs)+fibs = 1 : 1 : zipWith (+) fibs (drop 1 fibs)  mkRatios :: [Integer] -> [Rational] mkRatios (x1:x2:xs) = (x1 % x2) : mkRatios (x2:xs)@@ -57,7 +58,7 @@ blend scale ratios = zipWith (+) ratios scaleFactors     where       len = length ratios-      step = (scale - (1 % 1)) / (fromIntegral len)+      step = (scale - (1 % 1)) / fromIntegral len       scaleFactors = map (* step) . reverse . take len $ [0..]  -- | A spiral layout.  The parameter controls the size ratio between@@ -81,7 +82,7 @@ instance LayoutClass SpiralWithDir a where     pureLayout (SpiralWithDir dir rot scale) sc stack = zip ws rects         where ws = integrate stack-              ratios = blend scale . reverse . take (length ws - 1) . mkRatios $ tail fibs+              ratios = blend scale . reverse . take (length ws - 1) . mkRatios $ drop 1 fibs               rects = divideRects (zip ratios dirs) sc               dirs  = dropWhile (/= dir) $ case rot of                                            CW  -> cycle [East .. North]@@ -95,7 +96,7 @@ divideRects :: [(Rational, Direction)] -> Rectangle -> [Rectangle] divideRects [] r = [r] divideRects ((r,d):xs) rect = case divideRect r d rect of-                                (r1, r2) -> r1 : (divideRects xs r2)+                                (r1, r2) -> r1 : divideRects xs r2  -- It's much simpler if we work with all Integers and convert to -- Rectangle at the end.@@ -120,5 +121,5 @@       North -> let (h1, h2) = chop (1 - ratio) h in (Rect x (y + h1) w h2, Rect x y w h1)  chop :: Rational -> Integer -> (Integer, Integer)-chop rat n = let f = ((fromIntegral n) * (numerator rat)) `div` (denominator rat) in+chop rat n = let f = (fromIntegral n * numerator rat) `div` denominator rat in              (f, n - f)
XMonad/Layout/Square.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Square+-- Description :  A layout that splits the screen into a square area and the rest of the screen. -- Copyright   :  (c) David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -28,7 +29,7 @@ import XMonad.StackSet ( integrate )  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:+-- You can use this module with the following in your @xmonad.hs@ file: -- -- >   import XMonad.Layout.Square --@@ -40,13 +41,13 @@ -- >         [(tabbed,3),(tabbed,30),(tabbed,1),(tabbed,1)]  -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  data Square a = Square deriving ( Read, Show )  instance LayoutClass Square a where     pureLayout Square r s = arrange (integrate s)-        where arrange ws@(_:_) = map (\w->(w,rest)) (init ws) ++ [(last ws,sq)]+        where arrange ws@(_:_) = map (, rest) (init ws) ++ [(last ws,sq)]               arrange [] = [] -- actually, this is an impossible case               (rest, sq) = splitSquare r
XMonad/Layout/StackTile.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.StackTile+-- Description :  Like "XMonad.Layout.Dishes" but with the ability to resize the master pane. -- Copyright   :  (c) Rickard Gustafsson <acura@allyourbase.se> -- License     :  BSD-style (see LICENSE) --@@ -23,21 +24,21 @@  import XMonad hiding (tile) import qualified XMonad.StackSet as W-import Control.Monad+import XMonad.Prelude  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.StackTile -- -- Then edit your @layoutHook@ by adding the StackTile layout: -- -- > myLayout =  StackTile 1 (3/100) (1/2) ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- data StackTile a = StackTile !Int !Rational !Rational deriving (Show, Read)
+ XMonad/Layout/StateFull.hs view
@@ -0,0 +1,62 @@+{-# 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 {-# DEPRECATED "Use X.L.TrackFloating." #-} (+  -- * Usage+  -- $Usage+  pattern StateFull,+  StateFull,+  FocusTracking,+  F.focusTracking+) where++import XMonad+import XMonad.Layout.LayoutModifier+import qualified XMonad.Layout.FocusTracking as F++-- $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@ type for which the @LayoutClass@ instance is provided.+type FocusTracking = ModifiedLayout F.FocusTracking++-- | 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 :: StateFull a+pattern StateFull = ModifiedLayout (F.FocusTracking Nothing) Full+
+ XMonad/Layout/Stoppable.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.Stoppable+-- Description :  A layout modifier to stop all non-visible processes.+-- Copyright   :  (c) Anton Vorontsov <anton@enomsg.org> 2014+-- License     :  BSD-style (as xmonad)+--+-- Maintainer  :  Anton Vorontsov <anton@enomsg.org>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module implements a special kind of layout modifier, which when+-- applied to a layout, causes xmonad to stop all non-visible processes.+-- In a way, this is a sledge-hammer for applications that drain power.+-- For example, given a web browser on a stoppable workspace, once the+-- workspace is hidden the web browser will be stopped.+--+-- Note that the stopped application won't be able to communicate with X11+-- clipboard. For this, the module actually stops applications after a+-- certain delay, giving a chance for a user to complete copy-paste+-- sequence. By default, the delay equals to 15 seconds, it is+-- configurable via 'Stoppable' constructor.+--+-- The stoppable modifier prepends a mark (by default equals to+-- \"Stoppable\") to the layout description (alternatively, you can choose+-- your own mark and use it with 'Stoppable' constructor). The stoppable+-- layout (identified by a mark) spans to multiple workspaces, letting you+-- to create groups of stoppable workspaces that only stop processes when+-- none of the workspaces are visible, and conversely, unfreezing all+-- processes even if one of the stoppable workspaces are visible.+--+-- To stop the process we use signals, which works for most cases. For+-- processes that tinker with signal handling (debuggers), another+-- (Linux-centric) approach may be used. See+-- <https://www.kernel.org/doc/Documentation/cgroups/freezer-subsystem.txt>+--+-- * Note+-- This module doesn't work on programs that do fancy things with processes+-- (such as Chromium) and programs that do not set _NET_WM_PID.+-----------------------------------------------------------------------------++module XMonad.Layout.Stoppable+    ( -- $usage+      Stoppable(..)+    , stoppable+    ) where++import XMonad+import XMonad.Prelude+import XMonad.Actions.WithAll+import XMonad.Util.WindowProperties+import XMonad.Util.RemoteWindows+import XMonad.Util.Timer+import XMonad.StackSet hiding (filter)+import XMonad.Layout.LayoutModifier+import System.Posix.Signals++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad+-- > import XMonad.Layout.Stoppable+-- >+-- > main = xmonad def+-- >    { layoutHook = layoutHook def ||| stoppable (layoutHook def) }+--+-- Note that the module has to distinguish between local and remote+-- proccesses, which means that it needs to know the hostname, so it looks+-- for environment variables (e.g. HOST).+--+-- Environment variables will work for most cases, but won't work if the+-- hostname changes. To cover dynamic hostnames case, in addition to+-- layoutHook you have to provide manageHook from+-- "XMonad.Util.RemoteWindows" module.+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".++signalWindow :: Signal -> Window -> X ()+signalWindow s w = do+    pid <- getProp32s "_NET_WM_PID" w+    io $ (signalProcess s . fromIntegral) `mapM_` fromMaybe [] pid++signalLocalWindow :: Signal -> Window -> X ()+signalLocalWindow s w  = isLocalWindow w >>= flip when (signalWindow s w)++withAllOn :: (a -> X ()) -> Workspace i l a -> X ()+withAllOn f wspc = f `mapM_` integrate' (stack wspc)++withAllFiltered :: (Workspace i l a -> Bool)+                -> [Workspace i l a]+                -> (a -> X ()) -> X ()+withAllFiltered p wspcs f = withAllOn f `mapM_` filter p wspcs++sigStoppableWorkspacesHook :: String -> X ()+sigStoppableWorkspacesHook k = do+    ws <- gets windowset+    withAllFiltered isStoppable (hidden ws) (signalLocalWindow sigSTOP)+  where+    isStoppable ws = k `elem` words (description $ layout ws)++-- | Data type for ModifiedLayout. The constructor lets you to specify a+-- custom mark/description modifier and a delay. You can also use+-- 'stoppable' helper function.+data Stoppable a = Stoppable+    { mark :: String+    , delay :: Rational+    , timer :: Maybe TimerId+    } deriving (Show,Read)++instance LayoutModifier Stoppable Window where+    modifierDescription = mark++    hook _   = withAll $ signalLocalWindow sigCONT++    handleMess (Stoppable m _ (Just tid)) msg+        | Just ev <- fromMessage msg = handleTimer tid ev run+          where run = sigStoppableWorkspacesHook m >> return Nothing+    handleMess (Stoppable m d _) msg+        | Just Hide <- fromMessage msg =+            Just . Stoppable m d . Just <$> startTimer d+        | otherwise = return Nothing++-- | Convert a layout to a stoppable layout using the default mark+-- (\"Stoppable\") and a delay of 15 seconds.+stoppable :: l a -> ModifiedLayout Stoppable l a+stoppable = ModifiedLayout (Stoppable "Stoppable" 15 Nothing)
XMonad/Layout/SubLayouts.hs view
@@ -1,7 +1,16 @@-{-# LANGUAGE PatternGuards, ParallelListComp, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.SubLayouts+-- Description :  A layout combinator that allows layouts to be nested. -- Copyright   :  (c) 2009 Adam Vogt -- License     :  BSD-style (see xmonad/LICENSE) --@@ -38,31 +47,26 @@     )     where -import XMonad.Layout.Circle () -- so haddock can find the link- import XMonad.Layout.Decoration(Decoration, DefaultShrinker) import XMonad.Layout.LayoutModifier(LayoutModifier(handleMess, modifyLayout,                                     redoLayout),                                     ModifiedLayout(..)) import XMonad.Layout.Simplest(Simplest(..))-import XMonad.Layout.Tabbed(defaultTheme, shrinkText,+import XMonad.Layout.Tabbed(shrinkText,                             TabbedDecoration, addTabs) import XMonad.Layout.WindowNavigation(Navigate(Apply)) import XMonad.Util.Invisible(Invisible(..)) import XMonad.Util.Types(Direction2D(..))-import XMonad-import Control.Applicative((<$>),(<*))+import XMonad hiding (def)+import XMonad.Prelude import Control.Arrow(Arrow(second, (&&&)))-import Control.Monad(MonadPlus(mplus), foldM, guard, when, join)-import Data.Function(on)-import Data.List(nubBy, (\\), find)-import Data.Maybe(isNothing, fromMaybe, listToMaybe, mapMaybe)-import Data.Traversable(sequenceA) +import qualified XMonad as X import qualified XMonad.Layout.BoringWindows as B import qualified XMonad.StackSet as W import qualified Data.Map as M import Data.Map(Map)+import qualified Data.Set as S  -- $screenshots --@@ -109,7 +113,7 @@ --  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.SubLayouts -- > import XMonad.Layout.WindowNavigation@@ -123,7 +127,7 @@ -- -- > myLayout = windowNavigation $ subTabbed $ boringWindows $ -- >                        Tall 1 (3/100) (1/2) ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- "XMonad.Layout.WindowNavigation" is used to specify which windows to merge, -- and it is not integrated into the modifier because it can be configured, and@@ -158,10 +162,9 @@ --  could not be used in the keybinding instead? It avoids having to explicitly --  pass the conf. ----- For more detailed instructions, see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"--- "XMonad.Doc.Extending#Adding_key_bindings"+-- For more detailed instructions, see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>+-- and "XMonad.Doc.Extending#Editing_the_layout_hook".  -- | The main layout modifier arguments: --@@ -179,26 +182,26 @@ --  [@outerLayout@] The layout that determines the rectangles given to each --  group. -----  Ex. The second group is 'Tall', the third is 'Circle', all others are tabbed---  with:+--  Ex. The second group is 'Tall', the third is 'XMonad.Layout.CircleEx.circle',+--  all others are tabbed with: -----  > myLayout = addTabs shrinkText defaultTheme---  >          $ subLayout [0,1,2] (Simplest ||| Tall 1 0.2 0.5 ||| Circle)+--  > myLayout = addTabs shrinkText def+--  >          $ subLayout [0,1,2] (Simplest ||| Tall 1 0.2 0.5 ||| circle) --  >          $ Tall 1 0.2 0.5 ||| Full subLayout :: [Int] -> subl a -> l a -> ModifiedLayout (Sublayout subl) l a-subLayout nextLayout sl x = ModifiedLayout (Sublayout (I []) (nextLayout,sl) []) x+subLayout nextLayout sl = ModifiedLayout (Sublayout (I []) (nextLayout,sl) [])  -- | @subTabbed@ is a use of 'subLayout' with 'addTabs' to show decorations. subTabbed :: (Eq a, LayoutModifier (Sublayout Simplest) a, LayoutClass l a) =>     l a -> ModifiedLayout (Decoration TabbedDecoration DefaultShrinker)                           (ModifiedLayout (Sublayout Simplest) l) a-subTabbed  x = addTabs shrinkText defaultTheme $ subLayout [] Simplest x+subTabbed  x = addTabs shrinkText X.def $ subLayout [] Simplest x  -- | @defaultSublMap@ is an attempt to create a set of keybindings like the -- defaults ones but to be used as a 'submap' for sending messages to the -- sublayout. defaultSublMap :: XConfig l -> Map (KeyMask, KeySym) (X ())-defaultSublMap (XConfig { modMask = modm }) = M.fromList+defaultSublMap XConfig{ modMask = modm } = M.fromList          [((modm, xK_space), toSubl NextLayout),           ((modm, xK_j), onGroup W.focusDown'),           ((modm, xK_k), onGroup W.focusUp'),@@ -213,7 +216,7 @@          ]         where          -- should these go into XMonad.StackSet?-         focusMaster' st = let (f:fs) = W.integrate st+         focusMaster' st = let (notEmpty -> f :| fs) = W.integrate st             in W.Stack f [] fs          swapMaster' (W.Stack f u d) = W.Stack f [] $ reverse u ++ d @@ -239,6 +242,9 @@ -- This representation probably simplifies the internals of the modifier. type Groups a = Map a (W.Stack a) +-- | Stack of stacks, a simple representation of groups for purposes of focus.+type GroupStack a = W.Stack (W.Stack a)+ -- | GroupMsg take window parameters to determine which group the action should -- be applied to data GroupMsg a@@ -255,22 +261,21 @@     | WithGroup (W.Stack a -> X (W.Stack a)) a     | SubMessage SomeMessage  a                 -- ^ the sublayout with the given window will get the message-    deriving (Typeable)  -- | merge the window that would be focused by the function when applied to the -- W.Stack of all windows, with the current group removed. The given window -- should be focused by a sublayout. Example usage: @withFocused (sendMessage . -- mergeDir W.focusDown')@ mergeDir :: (W.Stack Window -> W.Stack Window) -> Window -> GroupMsg Window-mergeDir f w = WithGroup g w+mergeDir f = WithGroup g  where g cs = do         let onlyOthers = W.filter (`notElem` W.integrate cs)-        flip whenJust (sendMessage . Merge (W.focus cs) . W.focus . f)-            =<< fmap (onlyOthers =<<) currentStack+        (`whenJust` sendMessage . Merge (W.focus cs) . W.focus . f)+            . (onlyOthers =<<)+          =<< currentStack         return cs -data Broadcast = Broadcast SomeMessage -- ^ send a message to all sublayouts-    deriving (Typeable)+newtype Broadcast = Broadcast SomeMessage -- ^ send a message to all sublayouts  instance Message Broadcast instance Typeable a => Message (GroupMsg a)@@ -287,7 +292,7 @@ pushWindow = mergeNav (\o c -> sendMessage $ Migrate c o)  mergeNav :: (Window -> Window -> X ()) -> Direction2D -> Navigate-mergeNav f = Apply (\o -> withFocused (f o))+mergeNav f = Apply (withFocused . f)  -- | Apply a function on the stack belonging to the currently focused group. It -- works for rearranging windows and for changing focus.@@ -298,22 +303,22 @@ toSubl :: (Message a) => a -> X () toSubl m = withFocused (sendMessage . SubMessage (SomeMessage m)) -instance (Read (l Window), Show (l Window), LayoutClass l Window) => LayoutModifier (Sublayout l) Window where-    modifyLayout (Sublayout { subls = osls }) (W.Workspace i la st) r = do+instance forall l. (Read (l Window), Show (l Window), LayoutClass l Window) => LayoutModifier (Sublayout l) Window where+    modifyLayout Sublayout{ subls = osls } (W.Workspace i la st) r = do             let gs' = updateGroup st $ toGroups osls                 st' = W.filter (`elem` M.keys gs') =<< st             updateWs gs'-            oldStack <- gets $ W.stack . W.workspace . W.current . windowset+            oldStack <- currentStack             setStack st'             runLayout (W.Workspace i la st') r <* setStack oldStack             -- FIXME: merge back reordering, deletions? -    redoLayout (Sublayout { delayMess = I ms, def = defl, subls = osls }) _r st arrs = do+    redoLayout Sublayout{ delayMess = I ms, def = defl, subls = osls } _r st arrs = do         let gs' = updateGroup st $ toGroups osls         sls <- fromGroups defl st gs' osls -        let newL :: LayoutClass l Window => Rectangle -> WorkspaceId -> (l Window) -> Bool-                    -> (Maybe (W.Stack Window)) -> X ([(Window, Rectangle)], l Window)+        let newL :: LayoutClass l Window => Rectangle -> WorkspaceId -> l Window -> Bool+                    -> Maybe (W.Stack Window) -> X ([(Window, Rectangle)], l Window)             newL rect n ol isNew sst = do                 orgStack <- currentStack                 let handle l (y,_)@@ -341,7 +346,7 @@             return $ Just $ Sublayout (I ((sm,w):ms)) defl sls          | Just (Broadcast sm) <- fromMessage m = do-            ms' <- fmap (zip (repeat sm) . W.integrate') currentStack+            ms' <- fmap (map (sm,) . W.integrate') currentStack             return $ if null ms' then Nothing                 else Just $ Sublayout (I $ ms' ++ ms) defl sls @@ -390,7 +395,7 @@             in fgs $ nxsAdd $ M.insert x zs $ M.delete yf gs  -        | otherwise = fmap join $ sequenceA $ catchLayoutMess <$> fromMessage m+        | otherwise = join <$> traverse catchLayoutMess (fromMessage m)      where gs = toGroups sls            fgs gs' = do                 st <- currentStack@@ -398,13 +403,11 @@             findGroup z = mplus (M.lookup z gs) $ listToMaybe                     $ M.elems $ M.filter ((z `elem`) . W.integrate) gs-           -- catchLayoutMess :: LayoutMessages -> X (Maybe (Sublayout l Window))-           --  This l must be the same as from the instance head,-           --  -XScopedTypeVariables should bring it into scope, but we are-           --  trying to avoid warnings with ghc-6.8.2 and avoid CPP++           catchLayoutMess :: LayoutMessages -> X (Maybe (Sublayout l Window))            catchLayoutMess x = do             let m' = x `asTypeOf` (undefined :: LayoutMessages)-            ms' <- zip (repeat $ SomeMessage m') . W.integrate'+            ms' <- map (SomeMessage m',) . W.integrate'                     <$> currentStack             return $ do guard $ not $ null ms'                         Just $ Sublayout (I $ ms' ++ ms) defl sls@@ -414,48 +417,64 @@  -- | update Group to follow changes in the workspace updateGroup :: Ord a => Maybe (W.Stack a) -> Groups a -> Groups a-updateGroup mst gs =-        let flatten = concatMap W.integrate . M.elems-            news = W.integrate' mst \\ flatten gs-            deads = flatten gs \\ W.integrate' mst--            uniNew = M.union (M.fromList $ map (\n -> (n,single n)) news)-            single x = W.Stack x [] []--            -- pass through a list to update/remove keys-            remDead = M.fromList . map (\w -> (W.focus w,w))-                        . mapMaybe (W.filter (`notElem` deads)) . M.elems--            -- update the current tab group's order and focus-            followFocus hs = fromMaybe hs $ do-                f' <- W.focus `fmap` mst-                xs <- find (elem f' . W.integrate) $ M.elems hs-                xs' <- W.filter (`elem` W.integrate xs) =<< mst-                return $ M.insert f' xs' $ M.delete (W.focus xs) hs--        in remDead $ uniNew $ followFocus gs+updateGroup Nothing _ = mempty+updateGroup (Just st) gs = fromGroupStack (toGroupStack gs st) --- | rearrange the windowset to put the groups of tabs next to eachother, so+-- | rearrange the windowset to put the groups of tabs next to each other, so -- that the stack of tabs stays put. updateWs :: Groups Window -> X () updateWs = windowsMaybe . updateWs'  updateWs' :: Groups Window -> WindowSet -> Maybe WindowSet updateWs' gs ws = do-    f <- W.peek ws-    let w = W.index ws-        nes = concatMap W.integrate $ mapMaybe (flip M.lookup gs) w-        ws' = W.focusWindow f $ foldr W.insertUp (foldr W.delete' ws nes) nes-    guard $ W.index ws' /= W.index ws-    return ws'+    w <- W.stack . W.workspace . W.current $ ws+    let w' = flattenGroupStack . toGroupStack gs $ w+    guard $ w /= w'+    pure $ W.modify' (const w') ws +-- | Flatten a stack of stacks.+flattenGroupStack :: GroupStack a -> W.Stack a+flattenGroupStack (W.Stack (W.Stack f lf rf) ls rs) =+    let l = lf ++ concatMap (reverse . W.integrate) ls+        r = rf ++ concatMap W.integrate rs+    in W.Stack f l r++-- | Extract Groups from a stack of stacks.+fromGroupStack :: (Ord a) => GroupStack a -> Groups a+fromGroupStack = M.fromList . map (W.focus &&& id) . W.integrate++-- | Arrange a stack of windows into a stack of stacks, according to (possibly+-- outdated) Groups.+--+-- Assumes that the groups are disjoint and there are no duplicates in the+-- stack; will result in additional duplicates otherwise. This is a reasonable+-- assumption—the rest of xmonad will mishave too—but it isn't checked+-- anywhere and there had been bugs breaking this assumption in the past.+toGroupStack :: (Ord a) => Groups a -> W.Stack a -> GroupStack a+toGroupStack gs st@(W.Stack f ls rs) =+    W.Stack (fromJust (lu f)) (mapMaybe lu ls) (mapMaybe lu rs)+  where+    wset = S.fromList (W.integrate st)+    dead = W.filter (`S.member` wset) -- drop dead windows or entire groups+    refocus s | f `elem` W.integrate s -- sync focus/order of current group+                                       = W.filter (`elem` W.integrate s) st+              | otherwise = pure s+    gs' = mapGroups (refocus <=< dead) gs+    gset = S.fromList . concatMap W.integrate . M.elems $ gs'+    -- after refocus, f is either the focused window of some group, or not in+    -- gs' at all, so `lu f` is never Nothing+    lu w | w `S.member` gset = w `M.lookup` gs'+         | otherwise = Just (W.Stack w [] []) -- singleton groups for new wins++mapGroups :: (Ord a) => (W.Stack a -> Maybe (W.Stack a)) -> Groups a -> Groups a+mapGroups f = M.fromList . map (W.focus &&& id) . mapMaybe f . M.elems+ -- | focusWindow'. focus an element of a stack, is Nothing if that element is -- absent. See also 'W.focusWindow' focusWindow' :: (Eq a) => a -> W.Stack a -> Maybe (W.Stack a) focusWindow' w st = do-    guard $ not $ null $ filter (w==) $ W.integrate st-    if W.focus st == w then Just st-        else focusWindow' w $ W.focusDown' st+    guard $ w `elem` W.integrate st+    return $ until ((w ==) . W.focus) W.focusDown' st  -- update only when Just windowsMaybe :: (WindowSet -> Maybe WindowSet) -> X ()
XMonad/Layout/TabBarDecoration.hs view
@@ -2,6 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.TabBarDecoration+-- Description :  A layout modifier to add a bar of tabs to your layouts. -- Copyright   :  (c) 2007 Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -16,12 +17,12 @@     ( -- * Usage       -- $usage       simpleTabBar, tabBar-    , defaultTheme, shrinkText+    , def, shrinkText     , TabBarDecoration (..), XPPosition (..)     , module XMonad.Layout.ResizeScreen     ) where -import Data.List+import XMonad.Prelude import XMonad import qualified XMonad.StackSet as S import XMonad.Layout.Decoration@@ -30,30 +31,30 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.TabBarDecoration -- -- Then edit your @layoutHook@ by adding the layout you want: ----- > main = xmonad defaultConfig { layoutHook = simpleTabBar $ layoutHook defaultConfig}------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = simpleTabBar $ layoutHook def} ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- 'tabBar' will give you the possibility of setting a custom shrinker -- and a custom theme. ----- The deafult theme can be dynamically change with the xmonad theme--- selector. See "XMonad.Prompt.Theme". For more themse, look at+-- The default theme can be dynamically changed with the xmonad theme+-- selector. See "XMonad.Prompt.Theme". For more themes, look at -- "XMonad.Util.Themes"  -- | Add, on the top of the screen, a simple bar of tabs to a given -- | layout, with the default theme and the default shrinker. simpleTabBar :: Eq a => l a -> ModifiedLayout (Decoration TabBarDecoration DefaultShrinker)                 (ModifiedLayout ResizeScreen l) a-simpleTabBar = decoration shrinkText defaultTheme (TabBar Top) . resizeVertical 20+simpleTabBar = decoration shrinkText def (TabBar Top) . resizeVertical 20  -- | Same of 'simpleTabBar', but with the possibility of setting a -- custom shrinker, a custom theme and the position: 'Top' or@@ -61,7 +62,7 @@ tabBar :: (Eq a, Shrinker s) => s -> Theme -> XPPosition -> l a -> ModifiedLayout (Decoration TabBarDecoration s) l a tabBar s t p = decoration s t (TabBar p) -data TabBarDecoration a = TabBar XPPosition deriving (Read, Show)+newtype TabBarDecoration a = TabBar XPPosition deriving (Read, Show)  instance Eq a => DecorationStyle TabBarDecoration a where     describeDeco  _ = "TabBar"@@ -75,4 +76,5 @@               ny  = case p of                      Top    -> y                      Bottom -> y + fi ht - fi dht+                     _      -> error "Position must be 'Top' or 'Bottom'"               nx  = (x +) $ maybe 0 (fi . loc) $ w `elemIndex` wrs
XMonad/Layout/Tabbed.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.Tabbed+-- Description :  A tabbed layout. -- Copyright   :  (c) 2007 David Roundy, Andrea Rossato -- License     :  BSD-style (see xmonad/LICENSE) --@@ -20,24 +21,29 @@       simpleTabbed, tabbed, addTabs     , simpleTabbedAlways, tabbedAlways, addTabsAlways     , simpleTabbedBottom, tabbedBottom, addTabsBottom+    , simpleTabbedLeft, tabbedLeft, addTabsLeft+    , simpleTabbedRight, tabbedRight, addTabsRight     , simpleTabbedBottomAlways, tabbedBottomAlways, addTabsBottomAlways+    , simpleTabbedLeftAlways, tabbedLeftAlways, addTabsLeftAlways+    , simpleTabbedRightAlways, tabbedRightAlways, addTabsRightAlways     , Theme (..)-    , defaultTheme+    , def     , TabbedDecoration (..)     , shrinkText, CustomShrink(CustomShrink)     , Shrinker(..)-    , TabbarShown, TabbarLocation+    , TabbarShown, Direction2D(..)     ) where -import Data.List+import XMonad.Prelude  import XMonad import qualified XMonad.StackSet as S import XMonad.Layout.Decoration import XMonad.Layout.Simplest ( Simplest(Simplest) )+import XMonad.Util.Types (Direction2D(..))  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.Tabbed --@@ -47,11 +53,11 @@ -- -- or, if you want a specific theme for you tabbed layout: ----- > myLayout = tabbed shrinkText defaultTheme ||| Full ||| etc..+-- > myLayout = tabbed shrinkText def ||| Full ||| etc.. -- -- and then: ----- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- This layout has hardcoded behaviour for mouse clicks on tab decorations: -- Left click on the tab switches focus to that window.@@ -61,14 +67,14 @@ -- on the workspace.  To have it always shown, use one of the layouts or -- modifiers ending in @Always@. ----- For more detailed instructions on editing the layoutHook see:------ "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You can also edit the default configuration options. ----- > myTabConfig = defaultTheme { inactiveBorderColor = "#FF0000"--- >                                   , activeTextColor = "#00FF00"}+-- > myTabConfig = def { inactiveBorderColor = "#FF0000"+-- >                   , activeTextColor = "#00FF00"} -- -- and --@@ -82,21 +88,33 @@ -- -- > import XMonad -- > import XMonad.Layout.Tabbed--- > main = xmonad defaultConfig { layoutHook = simpleTabbed }+-- > main = xmonad def { layoutHook = simpleTabbed } simpleTabbed :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker) Simplest Window-simpleTabbed = tabbed shrinkText defaultTheme+simpleTabbed = tabbed shrinkText def  simpleTabbedAlways :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker) Simplest Window-simpleTabbedAlways = tabbedAlways shrinkText defaultTheme+simpleTabbedAlways = tabbedAlways shrinkText def  -- | A bottom-tabbed layout with the default xmonad Theme. simpleTabbedBottom :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker) Simplest Window-simpleTabbedBottom = tabbedBottom shrinkText defaultTheme+simpleTabbedBottom = tabbedBottom shrinkText def  -- | A bottom-tabbed layout with the default xmonad Theme. simpleTabbedBottomAlways :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker) Simplest Window-simpleTabbedBottomAlways = tabbedBottomAlways shrinkText defaultTheme+simpleTabbedBottomAlways = tabbedBottomAlways shrinkText def +-- | A side-tabbed layout with the default xmonad Theme.+simpleTabbedLeft, simpleTabbedRight :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker)+                                        Simplest Window+simpleTabbedLeft = tabbedLeft shrinkText def+simpleTabbedRight = tabbedRight shrinkText def++-- | A side-tabbed layout with the default xmonad Theme.+simpleTabbedLeftAlways, simpleTabbedRightAlways :: ModifiedLayout (Decoration TabbedDecoration DefaultShrinker)+                                                  Simplest Window+simpleTabbedLeftAlways = tabbedLeftAlways shrinkText def+simpleTabbedRightAlways = tabbedRightAlways shrinkText def+ -- | A layout decorated with tabs and the possibility to set a custom -- shrinker and theme. tabbed     :: (Eq a, Shrinker s) => s -> Theme@@ -117,68 +135,105 @@                        -> ModifiedLayout (Decoration TabbedDecoration s) Simplest a tabbedBottomAlways s c = addTabsBottomAlways s c Simplest +-- | A layout decorated with tabs and the possibility to set a custom+-- shrinker and theme.+tabbedLeft, tabbedRight :: (Eq a, Shrinker s) => s -> Theme+                        -> ModifiedLayout (Decoration TabbedDecoration s) Simplest a+tabbedLeft s c = addTabsLeft s c Simplest+tabbedRight s c = addTabsRight s c Simplest++-- | A layout decorated with tabs and the possibility to set a custom+-- shrinker and theme.+tabbedLeftAlways, tabbedRightAlways :: (Eq a, Shrinker s) => s -> Theme+                                    -> ModifiedLayout (Decoration TabbedDecoration s) Simplest a+tabbedLeftAlways s c = addTabsLeftAlways s c Simplest+tabbedRightAlways s c = addTabsRightAlways s c Simplest+ -- Layout Modifiers  -- | A layout modifier that uses the provided shrinker and theme to add tabs to any layout. addTabs :: (Eq a, LayoutClass l a, Shrinker s) => s -> Theme -> l a         -> ModifiedLayout (Decoration TabbedDecoration s) l a-addTabs = createTabs WhenPlural Top+addTabs = createTabs WhenPlural U  addTabsAlways :: (Eq a, LayoutClass l a, Shrinker s) => s -> Theme -> l a               -> ModifiedLayout (Decoration TabbedDecoration s) l a-addTabsAlways = createTabs Always Top+addTabsAlways = createTabs Always U  -- | A layout modifier that uses the provided shrinker and theme to add tabs to the bottom of any layout. addTabsBottom :: (Eq a, LayoutClass l a, Shrinker s) => s -> Theme -> l a               -> ModifiedLayout (Decoration TabbedDecoration s) l a-addTabsBottom = createTabs WhenPlural Bottom+addTabsBottom = createTabs WhenPlural D  addTabsBottomAlways :: (Eq a, LayoutClass l a, Shrinker s) => s -> Theme -> l a                     -> ModifiedLayout (Decoration TabbedDecoration s) l a-addTabsBottomAlways = createTabs Always Bottom+addTabsBottomAlways = createTabs Always D +-- | A layout modifier that uses the provided shrinker and theme to add tabs to the side of any layout.+addTabsRight, addTabsLeft :: (Eq a, LayoutClass l a, Shrinker s) => s -> Theme -> l a+                            -> ModifiedLayout (Decoration TabbedDecoration s) l a+addTabsRight = createTabs WhenPlural R+addTabsLeft = createTabs WhenPlural L +addTabsRightAlways, addTabsLeftAlways :: (Eq a, LayoutClass l a, Shrinker s) => s -> Theme -> l a+                                      -> ModifiedLayout (Decoration TabbedDecoration s) l a+addTabsRightAlways = createTabs Always R+addTabsLeftAlways = createTabs Always L+ -- Tab creation abstractions.  Internal use only.  -- Create tabbar when required at the given location with the given -- shrinker and theme to the supplied layout.-createTabs                ::(Eq a, LayoutClass l a, Shrinker s) => TabbarShown -> TabbarLocation -> s+createTabs                ::(Eq a, LayoutClass l a, Shrinker s) => TabbarShown -> Direction2D -> s                           -> Theme -> l a -> ModifiedLayout (Decoration TabbedDecoration s) l a-createTabs sh loc tx th l = decoration tx th (Tabbed loc sh) l -data TabbarLocation = Top | Bottom deriving (Read,Show)+createTabs sh loc tx th = decoration tx th (Tabbed loc sh)  data TabbarShown = Always | WhenPlural deriving (Read, Show, Eq) -data TabbedDecoration a = Tabbed TabbarLocation TabbarShown deriving (Read, Show)+data TabbedDecoration a = Tabbed Direction2D TabbarShown deriving (Read, Show)  instance Eq a => DecorationStyle TabbedDecoration a where-    describeDeco (Tabbed Top _ ) = "Tabbed"-    describeDeco (Tabbed Bottom _ ) = "Tabbed Bottom"+    describeDeco (Tabbed U _ ) = "Tabbed"+    describeDeco (Tabbed D _ ) = "Tabbed Bottom"+    describeDeco (Tabbed L _ ) = "Tabbed Left"+    describeDeco (Tabbed R _ ) = "Tabbed Right"     decorationEventHook _ ds ButtonEvent { ev_window     = ew                                          , ev_event_type = et                                          , ev_button     = eb }         | et == buttonPress-        , Just ((w,_),_) <-findWindowByDecoration ew ds =+        , Just ((w,_),_) <- findWindowByDecoration ew ds =            if eb == button2                then killWindow w                else focus w     decorationEventHook _ _ _ = return () -    pureDecoration (Tabbed lc sh) _ ht _ s wrs (w,r@(Rectangle x y wh hh))-        = if ((sh == Always && numWindows > 0) || numWindows > 1)+    pureDecoration (Tabbed lc sh) wt ht _ s wrs (w,r@(Rectangle x y wh hh))+        = if (sh == Always && numWindows > 0) || numWindows > 1           then Just $ case lc of-                        Top -> upperTab-                        Bottom -> lowerTab+                        U -> upperTab+                        D -> lowerTab+                        L -> leftTab+                        R -> rightTab           else Nothing         where ws = filter (`elem` map fst (filter ((==r) . snd) wrs)) (S.integrate s)-              loc i = x + fi ((wh * fi i) `div` max 1 (fi $ length ws))-              wid = fi $ maybe x (\i -> loc (i+1) - loc i) $ w `elemIndex` ws-              nx  = maybe x loc $ w `elemIndex` ws-              upperTab = Rectangle nx y wid (fi ht)-              lowerTab = Rectangle nx (y+fi(hh-ht)) wid (fi ht)+              loc k h i = k + fi ((h * fi i) `div` max 1 (fi $ length ws))+              esize k h = fi $ maybe k (\i -> loc k h (i+1) - loc k h i) $ w `elemIndex` ws+              wid = esize x wh+              n k h = maybe k (loc k h) $ w `elemIndex` ws+              nx = n x wh+              upperTab = Rectangle nx  y wid (fi ht)+              lowerTab = Rectangle nx (y + fi (hh - ht)) wid (fi ht)+              fixHeightLoc i = y + fi ht * fi i+              fixHeightTab k = Rectangle k+                (maybe y fixHeightLoc+                 $ w `elemIndex` ws) (fi wt) (fi ht)+              rightTab = fixHeightTab (x + fi (wh - wt))+              leftTab = fixHeightTab x               numWindows = length ws-    shrink (Tabbed loc _ ) (Rectangle _ _ _ dh) (Rectangle x y w h)+    shrink (Tabbed loc _ ) (Rectangle _ _ dw dh) (Rectangle x y w h)         = case loc of-            Top -> Rectangle x (y + fi dh) w (h - dh)-            Bottom -> Rectangle x y w (h - dh)+            U -> Rectangle x (y + fi dh) w (h - dh)+            D -> Rectangle x y w (h - dh)+            L -> Rectangle (x + fi dw) y (w - dw) h+            R -> Rectangle x y (w - dw) h
+ XMonad/Layout/TallMastersCombo.hs view
@@ -0,0 +1,520 @@+-- {-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}++---------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.TallMastersCombo+-- Description :  A version of @Tall@ with two permanent master windows.+-- Copyright   :  (c) 2019 Ningji Wei+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Ningji Wei <tidues@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- A layout combinator that support Shrink, Expand, and IncMasterN just as the+-- 'Tall' layout, and also support operations of two master windows:+-- a main master, which is the original master window;+-- a sub master, the first window of the second pane.+-- This combinator can be nested, and has a good support for using+-- "XMonad.Layout.Tabbed" as a sublayout.+--+-----------------------------------------------------------------------------++module XMonad.Layout.TallMastersCombo (+  -- * Usage+  -- $usage+  tmsCombineTwoDefault,+  tmsCombineTwo,+  TMSCombineTwo (..),+  RowsOrColumns (..),+  (|||),++  -- * Messages+  SwitchOrientation (..),+  SwapSubMaster (..),+  FocusSubMaster (..), FocusedNextLayout (..), ChangeFocus (..),++  -- * Utilities+  ChooseWrapper (..),+  swapWindow,+  focusWindow,+  handleMessages+) where++import XMonad hiding (focus, (|||))+import qualified XMonad.Layout as LL+import XMonad.Layout.Decoration+import XMonad.Layout.Simplest (Simplest (..))+import XMonad.Prelude (delete, find, foldM, fromMaybe, isJust, listToMaybe)+import XMonad.StackSet (Stack (..), Workspace (..), integrate')+import qualified XMonad.StackSet as W+import XMonad.Util.Stack (zipperFocusedAtFirstOf)++---------------------------------------------------------------------------------+-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Layout.TallMastersCombo+--+-- and make sure the Choose layout operator (|||) is hidden by adding the followings:+--+-- > import XMonad hiding ((|||))+-- > import XMonad.Layout hiding ((|||))+--+-- then, add something like+--+-- > tmsCombineTwoDefault (Tall 0 (3/100) 0) simpleTabbed+--+-- This will make the 'Tall' layout as the master pane, and 'simpleTabbed' layout as the second pane.+-- You can shrink, expand, and increase more windows to the master pane just like using the+-- 'Tall' layout.+--+-- To swap and/or focus the sub master window (the first window in the second pane), you can add+-- the following key bindings+--+-- >      , ((modm .|. shiftMask, m),         sendMessage $ FocusSubMaster)+-- >      , ((modm .|. shiftMask, xK_Return), sendMessage $ SwapSubMaster)+--+-- In each pane, you can use multiple layouts with the '(|||)' combinator provided by this module,+-- and switch between them with the 'FocusedNextLayout' message. Below is one example+--+-- > layout1 = Simplest ||| Tabbed+-- > layout2 = Full ||| Tabbed ||| (RowsOrColumns True)+-- > myLayout = tmsCombineTwoDefault layout1 layout2+--+-- then add the following key binding,+--+-- >      , ((modm, w), sendMessage $ FocusedNextLayout)+--+-- Now, pressing this key will toggle the multiple layouts in the currently focused pane.+--+-- You can mirror this layout with the default 'Mirror' key binding. But to have a more natural+-- behaviors, you can use the 'SwitchOrientation' message:+--+-- >      , ((modm, xK_space), sendMessage $ SwitchOrientation)+--+-- This will not mirror the tabbed decoration, and will keep sub-layouts that made by TallMastersCombo+-- and RowsOrColumns display in natural orientations.+--+-- To merge layouts more flexibly, you can use 'tmsCombineTwo' instead.+--+-- > tmsCombineTwo False 1 (3/100) (1/3) Simplest simpleTabbed+--+-- This creates a vertical merged layout with 1 window in the master pane, and the master pane shrinks+-- and expands with a step of (3\/100), and occupies (1\/3) of the screen.+--+-- Each sub-layout have a focused window. To rotate between the focused windows across all the+-- sub-layouts, using the following messages:+--+-- >      , ((modm .|. mod1, j), sendMessage $ NextFocus)+-- >      , ((modm .|. mod1, k), sendMessage $ PrevFocus)+--+-- this let you jump to the focused window in the next/previous sub-layout.+--+--+-- Finally, this combinator can be nested. Here is one example,+--+-- @+-- subLayout  = tmsCombineTwo False 1 (3\/100) (1\/2) Simplest simpleTabbed+-- layout1    = simpleTabbed ||| subLayout+-- layout2    = subLayout ||| simpleTabbed ||| (RowsOrColumns True)+-- baseLayout = tmsCombineTwoDefault layout1 layout2+--+-- mylayouts = smartBorders $+--             avoidStruts $+--             mkToggle (FULL ?? EOT) $+--             baseLayout+-- @+--+-- this is a realization of the cool idea from+--+-- <https://www.reddit.com/r/xmonad/comments/3vkrc3/does_this_layout_exist_if_not_can_anyone_suggest/>+--+-- and is more flexible.+--++-- | A simple layout that arranges windows in a row or a column with equal sizes.+-- It can switch between row mode and column mode by listening to the message 'SwitchOrientation'.+newtype RowsOrColumns a = RowsOrColumns { rowMode :: Bool -- ^ arrange windows in rows or columns+                                        } deriving (Show, Read)++instance LayoutClass RowsOrColumns a where+  description (RowsOrColumns rows) =+    if rows then "Rows" else "Columns"++  pureLayout (RowsOrColumns rows) r s = zip ws rs+    where ws = W.integrate s+          len = length ws+          rs = if rows+               then splitVertically len r+               else splitHorizontally len r++  pureMessage RowsOrColumns{} m+    | Just Row <- fromMessage m = Just $ RowsOrColumns True+    | Just Col <- fromMessage m = Just $ RowsOrColumns False+    | otherwise = Nothing+++data TMSCombineTwo l1 l2 a =+  TMSCombineTwo { focusLst :: [a]+                , ws1 :: [a]+                , ws2 :: [a]+                , rowMod :: Bool  -- ^ merge two layouts in a column or a row+                , nMaster :: !Int     -- ^ number of windows in the master pane+                , rationInc :: !Rational -- ^ percent of screen to increment by when resizing panes+                , tallComboRatio :: !Rational -- ^ default proportion of screen occupied by master pane+                , layoutFst :: l1 a  -- ^ layout for the master pane+                , layoutSnd :: l2 a  -- ^ layout for the second pane+                }+        deriving (Show, Read)++-- | Combine two layouts l1 l2 with default behaviors.+tmsCombineTwoDefault :: (LayoutClass l1 Window, LayoutClass l2 Window) =>+                          l1 Window -> l2 Window -> TMSCombineTwo l1 l2 Window+tmsCombineTwoDefault = TMSCombineTwo [] [] [] True 1 (3/100) (1/2)++-- | A more flexible way of merging two layouts. User can specify if merge them vertical or horizontal,+-- the number of windows in the first pane (master pane), the shink and expand increment, and the proportion+-- occupied by the master pane.+tmsCombineTwo :: (LayoutClass l1 Window, LayoutClass l2 Window) =>+                  Bool -> Int -> Rational -> Rational -> l1 Window -> l2 Window -> TMSCombineTwo l1 l2 Window+tmsCombineTwo = TMSCombineTwo [] [] []++data Orientation = Row | Col deriving (Read, Show)+instance Message Orientation++-- | A message that switches the orientation of TallMasterCombo layout and the RowsOrColumns layout.+-- This is similar to the 'Mirror' message, but 'Mirror' cannot apply to hidden layouts, and when 'Mirror'+-- applies to the 'XMonad.Layout.Tabbed' decoration, it will also mirror the tabs, which may lead to unintended+-- visualizations. The 'SwitchOrientation' message refreshes layouts according to the orientation of the parent layout,+-- and will not affect the 'XMonad.Layout.Tabbed' decoration.+data SwitchOrientation = SwitchOrientation deriving (Read, Show)+instance Message SwitchOrientation++-- | This message swaps the current focused window with the sub master window (first window in the second pane).+data SwapSubMaster = SwapSubMaster deriving (Read, Show)+instance Message SwapSubMaster++-- | This message changes the focus to the sub master window (first window in the second pane).+data FocusSubMaster = FocusSubMaster deriving (Read, Show)+instance Message FocusSubMaster++-- | This message triggers the 'NextLayout' message in the pane that contains the focused window.+data FocusedNextLayout = FocusedNextLayout deriving (Read, Show)+instance Message FocusedNextLayout++-- | This is a message for changing to the previous or next focused window across all the sub-layouts.+data ChangeFocus = NextFocus | PrevFocus deriving (Read, Show)+instance Message ChangeFocus++-- instance (Typeable l1, Typeable l2, LayoutClass l1 Window, LayoutClass l2 Window) => LayoutClass (TMSCombineTwo l1 l2) Window where+instance (GetFocused l1 Window, GetFocused l2 Window) => LayoutClass (TMSCombineTwo l1 l2) Window where+  description _ = "TallMasters"++  runLayout (Workspace wid (TMSCombineTwo f _ _ vsp nmaster delta frac layout1 layout2) s) r =+      let (s1,s2,frac',slst1,slst2) = splitStack f nmaster frac s+          (r1, r2) = if vsp+                     then splitHorizontallyBy frac' r+                     else splitVerticallyBy frac' r+      in+      do+         (ws , ml ) <- runLayout (Workspace wid layout1 s1) r1+         (ws', ml') <- runLayout (Workspace wid layout2 s2) r2+         let newlayout1 = fromMaybe layout1 ml+             newlayout2 = fromMaybe layout2 ml'+             (f1, _) = getFocused newlayout1 s1+             (f2, _) = getFocused newlayout2 s2+             fnew = f1 ++ f2+         return (ws++ws', Just $ TMSCombineTwo fnew slst1 slst2 vsp nmaster delta frac newlayout1 newlayout2)+++  handleMessage i@(TMSCombineTwo f w1 w2 vsp nmaster delta frac layout1 layout2) m+    -- messages that only traverse one level+    | Just Shrink <- fromMessage m = return . Just $ TMSCombineTwo f w1 w2 vsp nmaster delta (max 0 $ frac-delta) layout1 layout2+    | Just Expand <- fromMessage m = return . Just $ TMSCombineTwo f w1 w2 vsp nmaster delta (min 1 $ frac+delta) layout1 layout2+    | Just (IncMasterN d) <- fromMessage m =+        let w = w1++w2+            nmasterNew = min (max 0 (nmaster+d)) (length w)+            (w1',w2')  = splitAt nmasterNew w+        in return . Just $ TMSCombineTwo f w1' w2' vsp nmasterNew delta frac layout1 layout2+    | Just SwitchOrientation <- fromMessage m =+            let m1 = if vsp then SomeMessage Col else SomeMessage Row+            in+            do mlayout1 <- handleMessage layout1 m1+               mlayout2 <- handleMessage layout2 m1+               return $ mergeSubLayouts  mlayout1 mlayout2 (TMSCombineTwo f w1 w2 (not vsp) nmaster delta frac layout1 layout2) True+    | Just SwapSubMaster <- fromMessage m =+        -- first get the submaster window+        let subMaster = listToMaybe w2+        in case subMaster of+            Just mw -> do windows $ W.modify' $ swapWindow mw+                          return Nothing+            Nothing -> return Nothing+    | Just FocusSubMaster <- fromMessage m =+        -- first get the submaster window+        let subMaster = listToMaybe w2+        in case subMaster of+            Just mw -> do windows $ W.modify' $ focusWindow mw+                          return Nothing+            Nothing -> return Nothing+    | Just NextFocus <- fromMessage m =+        do+          -- All toggle message is passed to the sublayout with focused window+          mst <- gets (W.stack . W.workspace . W.current . windowset)+          let nextw = adjFocus f mst True+          case nextw of Nothing -> return Nothing+                        Just w  -> do windows $ W.modify' $ focusWindow w+                                      return Nothing+    | Just PrevFocus <- fromMessage m =+        do+          -- All toggle message is passed to the sublayout with focused window+          mst <- gets (W.stack . W.workspace . W.current . windowset)+          let prevw = adjFocus f mst False+          case prevw of Nothing -> return Nothing+                        Just w  -> do windows $ W.modify' $ focusWindow w+                                      return Nothing+    -- messages that traverse recursively+    | Just Row <- fromMessage m =+        do mlayout1 <- handleMessage layout1 (SomeMessage Col)+           mlayout2 <- handleMessage layout2 (SomeMessage Col)+           return $ mergeSubLayouts mlayout1 mlayout2 (TMSCombineTwo f w1 w2 False nmaster delta frac layout1 layout2) True+    | Just Col <- fromMessage m =+        do mlayout1 <- handleMessage layout1 (SomeMessage Row)+           mlayout2 <- handleMessage layout2 (SomeMessage Row)+           return $ mergeSubLayouts mlayout1 mlayout2 (TMSCombineTwo f w1 w2 True nmaster delta frac layout1 layout2) True+    | Just FocusedNextLayout <- fromMessage m =+       do+       -- All toggle message is passed to the sublayout with focused window+         mst <- gets (W.stack . W.workspace . W.current . windowset)+         let focId = findFocused mst w1 w2+             m1 = if vsp then SomeMessage Row else SomeMessage Col+         if focId == 1+           then do+                 mlay1 <- handleMessages layout1 [SomeMessage NextLayout, m1]+                 let mlay2 = Nothing+                 return $ mergeSubLayouts mlay1 mlay2 i True+           else do+                 let mlay1 = Nothing+                 mlay2 <- handleMessages layout2 [SomeMessage NextLayout, m1]+                 return $ mergeSubLayouts mlay1 mlay2 i True+    | otherwise =+            do+              mlayout1 <- handleMessage layout1 m+              mlayout2 <- handleMessage layout2 m+              return $ mergeSubLayouts mlayout1 mlayout2 i False++-- | Swap a given window with the focused window.+swapWindow :: (Eq a) => a -> Stack a -> Stack a+swapWindow w (Stack foc upLst downLst)+    | (us, d:ds) <- break (== w) downLst = Stack foc (reverse us ++ d : upLst) ds+    | (ds, u:us) <- break (== w)   upLst = Stack foc us (reverse ds ++ u : downLst)+    | otherwise = Stack foc upLst downLst+++-- | Focus a given window.+focusWindow :: (Eq a) => a -> Stack a -> Stack a+focusWindow w s =+  if w `elem` up s+  then focusSubMasterU w s+  else focusSubMasterD w s+  where+      focusSubMasterU win i@(Stack foc (l:ls) rs)+        | foc == win = i+        | l == win = news+        | otherwise = focusSubMasterU win news+        where+            news = Stack l ls (foc : rs)+      focusSubMasterU _ (Stack foc [] rs) =+          Stack foc [] rs+      focusSubMasterD win i@(Stack foc ls (r:rs))+        | foc == win = i+        | r == win = news+        | otherwise = focusSubMasterD win news+        where+            news = Stack r (foc : ls) rs+      focusSubMasterD _ (Stack foc ls []) =+          Stack foc ls []++-- | Merge two Maybe sublayouts.+mergeSubLayouts+  :: Maybe (l1 a)           -- ^ Left  layout+  -> Maybe (l2 a)           -- ^ Right layout+  -> TMSCombineTwo l1 l2 a  -- ^ How to combine the layouts+  -> Bool                   -- ^ Return a 'Just' no matter what+  -> Maybe (TMSCombineTwo l1 l2 a)+mergeSubLayouts ml1 ml2 (TMSCombineTwo f w1 w2 vsp nmaster delta frac l1 l2) alwaysReturn+  | alwaysReturn = Just $ TMSCombineTwo f w1 w2 vsp nmaster delta frac (fromMaybe l1 ml1) (fromMaybe l2 ml2)+  | isJust ml1 || isJust ml2 = Just $ TMSCombineTwo f w1 w2 vsp nmaster delta frac (fromMaybe l1 ml1) (fromMaybe l2 ml2)+  | otherwise = Nothing++findFocused :: (Eq a) => Maybe (Stack a) -> [a] -> [a] -> Int+findFocused mst w1 w2 =+        case mst of+          Nothing -> 1+          Just st -> if foc `elem` w1+                     then 1+                     else if foc `elem` w2+                          then 2+                          else 1+                     where foc = W.focus st++-- | Handle a list of messages one by one, then return the last refreshed layout.+handleMessages :: (LayoutClass l a) => l a -> [SomeMessage] -> X (Maybe (l a))+handleMessages l = foldM  handleMaybeMsg (Just l)++handleMaybeMsg :: (LayoutClass l a) => Maybe (l a) -> SomeMessage -> X (Maybe (l a))+handleMaybeMsg ml m = case ml of Just l  -> do+                                              res <- handleMessage l m+                                              return $ elseOr (Just l) res+                                 Nothing -> return Nothing++-- function for splitting given stack for TallMastersCombo Layouts+splitStack :: (Eq a) => [a] -> Int -> Rational -> Maybe (Stack a) -> (Maybe (Stack a), Maybe (Stack a), Rational, [a], [a])+splitStack f nmaster frac s =+    let slst = integrate' s+        f' = case s of (Just s') -> focus s':delete (focus s') f+                       Nothing   -> f+        snum = length slst+        (slst1, slst2) = splitAt nmaster slst+        s0 = zipperFocusedAtFirstOf f' slst+        s1' = zipperFocusedAtFirstOf f' slst1+        s2' = zipperFocusedAtFirstOf f' slst2+        (s1,s2,frac') | nmaster == 0    = (Nothing,s0,0)+                      | nmaster >= snum = (s0,Nothing,1)+                      | otherwise       = (s1',s2',frac)+    in (s1,s2,frac',slst1,slst2)++-- find adjacent window of the current focus window+type Next = Bool+adjFocus :: (Eq a) => [a] -> Maybe (Stack a) -> Next -> Maybe a+adjFocus ws ms next =+  case ms of Nothing -> Nothing+             Just s  -> let searchLst = if next+                                        then down s ++ reverse (up s)+                                        else up s ++ reverse (down s)+                        in  find (`elem` ws) searchLst++-- right biased maybe merge+elseOr :: Maybe a -> Maybe a -> Maybe a+elseOr x y = case y of+              Just _  -> y+              Nothing -> x++----------------- All the rest are for changing focus functionality -------------------++-- | A wrapper for Choose, for monitoring the current active layout. This is because+-- the original Choose layout does not export the data constructor.+data LR = L | R deriving (Show, Read, Eq)+data ChooseWrapper l r a = ChooseWrapper LR (l a) (r a) (Choose l r a) deriving (Show, Read)++data NextNoWrap = NextNoWrap deriving (Eq, Show)+instance Message NextNoWrap++handle :: (LayoutClass l a, Message m) => l a -> m -> X (Maybe (l a))+handle l m = handleMessage l (SomeMessage m)++data End = End | NoEnd++instance (GetFocused l a, GetFocused r a) => LayoutClass (ChooseWrapper l r) a where+  description (ChooseWrapper _ _ _ lr) = description lr++  runLayout (Workspace wid (ChooseWrapper d l r lr) s) rec =+    do+      let (l', r') = case d of L -> (savFocused l s, r)+                               R -> (l, savFocused r s)+      (ws, ml0) <- runLayout (Workspace wid lr s) rec+      let l1 = case ml0 of Just l0 -> Just $ ChooseWrapper d l' r' l0+                           Nothing -> Nothing+      return (ws,l1)++  handleMessage c@(ChooseWrapper d l r lr) m+    | Just NextLayout <- fromMessage m = do+        mlr' <- handleMessage lr m+        mlrf <- handle c NextNoWrap+        fstf <- handle c FirstLayout+        let mlf = elseOr fstf mlrf+            (d',l',r') = case mlf of Just (ChooseWrapper d0 l0 r0 _) -> (d0,l0,r0)+                                     Nothing                     -> (d,l,r)+        case mlr' of Just lrt -> return $ Just $ ChooseWrapper d' l' r' lrt+                     Nothing  -> return Nothing+    | Just NextNoWrap <- fromMessage m = do+        mlr' <- handleMessage lr m+        (d',l',r', end) <-+              case d of+                L -> do+                       ml <- handle l NextNoWrap+                       case ml of+                           Just l0 -> return (L, l0, r, NoEnd)+                           Nothing -> do+                                  mr <- handle r FirstLayout+                                  case mr of+                                    Just r0 -> return (R, l, r0, NoEnd)+                                    Nothing -> return (R, l, r, NoEnd)+                R -> do+                       mr <- handle r NextNoWrap+                       case mr of+                         Just r0 -> return (R, l, r0, NoEnd)+                         Nothing -> return (d, l, r, End)+        case mlr' of Just lrt -> return $ Just $ ChooseWrapper d' l' r' lrt+                     Nothing  ->+                        case end of NoEnd -> return $ Just $ ChooseWrapper d' l' r' lr+                                    End   -> return Nothing+    | Just FirstLayout <- fromMessage m = do+        mlr' <- handleMessage lr m+        (d',l',r') <- do+                        ml <- handle l FirstLayout+                        case ml of+                          Just l0 -> return (L,l0,r)+                          Nothing -> return (L,l,r)+        case mlr' of Just lrt -> return $ Just $ ChooseWrapper d' l' r' lrt+                     Nothing  -> return $ Just $ ChooseWrapper d' l' r' lr+    | otherwise = do+        mlr' <- handleMessage lr m+        case mlr' of Just lrt -> return $ Just $ ChooseWrapper d l r lrt+                     Nothing  -> return Nothing++-- | This is same as the Choose combination operator.+(|||) :: l a -> r a -> ChooseWrapper l r a+(|||) l r = ChooseWrapper L l r (l LL.||| r)++-- a subclass of layout, which contain extra method to return focused window in sub-layouts+class (LayoutClass l a) => GetFocused l a where+  getFocused :: l a -> Maybe (Stack a) -> ([a], String)+  getFocused _ ms =+    case ms of (Just s) -> ([focus s], "Base")+               Nothing  -> ([], "Base")+  savFocused :: l a -> Maybe (Stack a) -> l a+  savFocused l _ = l++instance (GetFocused l Window, GetFocused r Window) => GetFocused (TMSCombineTwo l r) Window where+  getFocused (TMSCombineTwo f _ _ _ nmaster _ frac lay1 lay2) s =+    let (s1,s2,_,_,_) = splitStack f nmaster frac s+        (f1, str1) = getFocused lay1 s1+        (f2, str2) = getFocused lay2 s2+    in  (f1 ++ f2, "TMS: " ++ show f ++ "::" ++ str1 ++ "--" ++ str2)+  savFocused i@(TMSCombineTwo f _ _ _ nmaster _ frac lay1 lay2) s =+    let (s1,s2,_,_,_) = splitStack f nmaster frac s+        (f', _) = getFocused i s+        lay1' = savFocused lay1 s1+        lay2' = savFocused lay2 s2+    in i {focusLst = f', layoutFst=lay1', layoutSnd=lay2'}++instance (GetFocused l a, GetFocused r a) => GetFocused (ChooseWrapper l r) a where+  getFocused (ChooseWrapper d l r _) s =+    case d of L -> getFocused l s+              R -> getFocused r s+  savFocused (ChooseWrapper d l r lr) s =+    let (l', r') =+                  case d of L -> (savFocused l s, r)+                            R -> (l, savFocused r s)+    in ChooseWrapper d l' r' lr++instance (Typeable a) => GetFocused Simplest a+instance (Typeable a) => GetFocused RowsOrColumns a+instance (Typeable a) => GetFocused Full a+instance (Typeable a) => GetFocused Tall a+instance (Typeable l, Typeable a, Typeable m, LayoutModifier m a, LayoutClass l a) => GetFocused (ModifiedLayout m l) a
XMonad/Layout/ThreeColumns.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ThreeColumns+-- Description :  A layout similar to @Tall@, but with three columns. -- Copyright   :  (c) Kai Grossjohann <kai@emptydomain.de> -- License     :  BSD3-style (see LICENSE) --@@ -25,39 +26,38 @@                              ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as W  import Data.Ratio -import Control.Monad- -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.ThreeColumns -- -- Then edit your @layoutHook@ by adding the ThreeCol layout: -- -- > myLayout = ThreeCol 1 (3/100) (1/2) ||| ThreeColMid 1 (3/100) (1/2) ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }+-- > main = xmonad def { layoutHook = myLayout } -- -- The first argument specifies how many windows initially appear in the main -- window. The second argument argument specifies the amount to resize while -- resizing and the third argument specifies the initial size of the columns. -- A positive size designates the fraction of the screen that the main window -- should occupy, but if the size is negative the absolute value designates the--- fraction a slave column should occupy. If both slave columns are visible,+-- fraction a stack column should occupy. If both stack columns are visible, -- they always occupy the same amount of space. ----- The ThreeColMid variant places the main window between the slave columns.------ For more detailed instructions on editing the layoutHook see:+-- The ThreeColMid variant places the main window between the stack columns. ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".   -- $screenshot--- <<http://server.c-otto.de/xmonad/ThreeColumnsMiddle.png>>+-- <<https://user-images.githubusercontent.com/50166980/156938482-ac38fdd7-eb94-4371-801b-e191cdb9a4ba.png>>  -- | Arguments are nmaster, delta, fraction data ThreeCol a = ThreeColMid { threeColNMaster :: !Int, threeColDelta :: !Rational, threeColFrac :: !Rational}@@ -89,16 +89,16 @@     | otherwise = splitVertically nmaster r1 ++ splitVertically nslave1 r2 ++ splitVertically nslave2 r3         where (r1, r2, r3) = split3HorizontallyBy middle (if f<0 then 1+2*f else f) r               (s1, s2) = splitHorizontallyBy (if f<0 then 1+f else f) r-              nslave = (n - nmaster)+              nslave = n - nmaster               nslave1 = ceiling (nslave % 2)-              nslave2 = (n - nmaster - nslave1)+              nslave2 = n - nmaster - nslave1  split3HorizontallyBy :: Bool -> Rational -> Rectangle -> (Rectangle, Rectangle, Rectangle) split3HorizontallyBy middle f (Rectangle sx sy sw sh) =     if middle     then ( Rectangle (sx + fromIntegral r3w) sy r1w sh-         , Rectangle (sx + fromIntegral r3w + fromIntegral r1w) sy r2w sh-         , Rectangle sx sy r3w sh )+         , Rectangle sx sy r3w sh+         , Rectangle (sx + fromIntegral r3w + fromIntegral r1w) sy r2w sh )     else ( Rectangle sx sy r1w sh          , Rectangle (sx + fromIntegral r1w) sy r2w sh          , Rectangle (sx + fromIntegral r1w + fromIntegral r2w) sy r3w sh )
XMonad/Layout/ToggleLayouts.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module       : XMonad.Layout.ToggleLayouts+-- Description :  A module to toggle between two layouts. -- Copyright    : (c) David Roundy <droundy@darcs.net> -- License      : BSD --@@ -20,21 +21,22 @@     ) where  import XMonad+import XMonad.Prelude (fromMaybe) import XMonad.StackSet (Workspace (..))  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.ToggleLayouts -- -- Then edit your @layoutHook@ by adding the ToggleLayouts layout: -- -- > myLayout = toggleLayouts Full (Tall 1 (3/100) (1/2)) ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- To toggle between layouts add a key binding like --@@ -46,10 +48,10 @@ -- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  data ToggleLayouts lt lf a = ToggleLayouts Bool (lt a) (lf a) deriving (Read,Show)-data ToggleLayout = ToggleLayout | Toggle String deriving (Read,Show,Typeable)+data ToggleLayout = ToggleLayout | Toggle String deriving (Read,Show) instance Message ToggleLayout  toggleLayouts :: (LayoutClass lt a, LayoutClass lf a) => lt a -> lf a -> ToggleLayouts lt lf a@@ -60,7 +62,7 @@                                                                  return (ws,fmap (\lt' -> ToggleLayouts True lt' lf) mlt')      runLayout (Workspace i (ToggleLayouts False lt lf) ms) r = do (ws,mlf') <- runLayout (Workspace i lf ms) r-                                                                  return (ws,fmap (\lf' -> ToggleLayouts False lt lf') mlf')+                                                                  return (ws,fmap (ToggleLayouts False lt) mlf')     description (ToggleLayouts True lt _) = description lt     description (ToggleLayouts False _ lf) = description lf     handleMessage (ToggleLayouts bool lt lf) m@@ -74,23 +76,23 @@                                           (Just lt',Just lf') -> Just $ ToggleLayouts bool lt' lf'     handleMessage (ToggleLayouts True lt lf) m         | Just ToggleLayout <- fromMessage m = do mlt' <- handleMessage lt (SomeMessage Hide)-                                                  let lt' = maybe lt id mlt'+                                                  let lt' = fromMaybe lt mlt'                                                   return $ Just $ ToggleLayouts False lt' lf         | Just (Toggle d) <- fromMessage m,           d == description lt || d == description lf =               do mlt' <- handleMessage lt (SomeMessage Hide)-                 let lt' = maybe lt id mlt'+                 let lt' = fromMaybe lt mlt'                  return $ Just $ ToggleLayouts False lt' lf         | otherwise = do mlt' <- handleMessage lt m                          return $ fmap (\lt' -> ToggleLayouts True lt' lf) mlt'     handleMessage (ToggleLayouts False lt lf) m         | Just ToggleLayout <- fromMessage m = do mlf' <- handleMessage lf (SomeMessage Hide)-                                                  let lf' = maybe lf id mlf'+                                                  let lf' = fromMaybe lf mlf'                                                   return $ Just $ ToggleLayouts True lt lf'         | Just (Toggle d) <- fromMessage m,           d == description lt || d == description lf =               do mlf' <- handleMessage lf (SomeMessage Hide)-                 let lf' = maybe lf id mlf'+                 let lf' = fromMaybe lf mlf'                  return $ Just $ ToggleLayouts True lt lf'         | otherwise = do mlf' <- handleMessage lf m-                         return $ fmap (\lf' -> ToggleLayouts False lt lf') mlf'+                         return $ fmap (ToggleLayouts False lt) mlf'
XMonad/Layout/TrackFloating.hs view
@@ -1,20 +1,19 @@-{-# LANGUAGE MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} {- |  Module      :  XMonad.Layout.TrackFloating-Copyright   :  (c) 2010 Adam Vogt+Description :  Let focused tiles track focused floats+Copyright   :  (c) 2010 & 2013 Adam Vogt+               2011 Willem Vanlint License     :  BSD-style (see xmonad/LICENSE)  Maintainer  :  vogt.adam@gmail.com Stability   :  unstable Portability :  unportable -Layout modifier that tracks focus in the tiled layer while the floating layer-is in use. This is particularly helpful for tiled layouts where the focus-determines what is visible.+Provides layout modifier 'UseTransientFor': when a float has focus and is+@WM_TRANSIENT_FOR@ a tile, run the underlying layout as if that tile had focus. -The relevant bug is Issue 4-<http://code.google.com/p/xmonad/issues/detail?id=4>. -} module XMonad.Layout.TrackFloating     (-- * Usage@@ -23,68 +22,80 @@      -- ** For other layout modifiers      -- $layoutModifier      trackFloating,+     useTransientFor,++     -- ** Exported types      TrackFloating,+     UseTransientFor,     ) where -import Control.Monad-import Data.Function-import Data.List-import Data.Maybe-import qualified Data.Map as M-import qualified Data.Set as S-+import XMonad.Prelude import XMonad import XMonad.Layout.LayoutModifier+import XMonad.Layout.FocusTracking+import XMonad.Util.Stack (findZ) import qualified XMonad.StackSet as W +import qualified Data.Traversable as T -data TrackFloating a = TrackFloating-    { _wasFloating :: Bool,-      _tiledFocus :: Maybe Window }-    deriving (Read,Show,Eq) +{-# DEPRECATED TrackFloating "Use X.L.FocusTracking.FocusTracking." #-}+type TrackFloating = FocusTracking -instance LayoutModifier TrackFloating Window where-    modifyLayoutWithUpdate os@(TrackFloating _wasF mw) ws@(W.Workspace{ W.stack = ms }) r-      = do-        winset <- gets windowset-        let xCur = fmap W.focus xStack-            xStack = W.stack $ W.workspace $ W.current winset-            isF = fmap (\x -> x `M.member` W.floating winset ||-                            (let (\\\) = (S.\\) `on` (S.fromList . W.integrate')-                             in x `S.member` (xStack \\\ ms)))-                        xCur-            newStack-              -- focus is floating, so use the remembered focus point-              | Just isF' <- isF,-                isF',-                Just w <- mw,-                Just s <- ms,-                Just ns <- find ((==) w . W.focus)-                    $ zipWith const (iterate W.focusDown' s) (W.integrate s)-                = Just ns-              | otherwise-                = ms-            newState = case isF of-              Just True -> mw-              Just False | Just f <- xCur -> Just f-              _ -> Nothing-        ran <- runLayout ws{ W.stack = newStack } r-        return (ran,-                let n = TrackFloating (fromMaybe False isF) newState-                in guard (n /= os) >> Just n) +{- | When focus is on the tiled layer, the underlying layout is run with focus+on the window named by the WM_TRANSIENT_FOR property on the floating window.+-}+useTransientFor :: l a -> ModifiedLayout UseTransientFor l a+useTransientFor = ModifiedLayout UseTransientFor +data UseTransientFor a = UseTransientFor deriving (Read,Show,Eq)++instance LayoutModifier UseTransientFor Window where+    modifyLayout _ ws@W.Workspace{ W.stack = ms } r = do+        m <- gets (W.peek . W.view (W.tag ws) . windowset)+        d <- asks display+        parent <- join <$> T.traverse (io . getTransientForHint d) m++        s0 <- get+        whenJust parent $ \p -> put s0{ windowset = W.focusWindow p (windowset s0) }+        result <- runLayout ws{ W.stack = (parent >>= \p -> findZ (p==) ms) <|> ms } r++        m' <- gets (W.peek . windowset)++        when (m' == parent) $+            -- layout changed the windowset, so don't clobber it+            whenJust m $ \p -> put s0{ windowset = W.focusWindow p (windowset s0) }++        return result+++ {- $usage  Apply to your layout in a config like: -> main = xmonad (defaultConfig{->                   layoutHook = trackFloating->                       (noBorders Full ||| Tall 1 0.3 0.5),+> main = xmonad (def{+>                   layoutHook = trackFloating (useTransientFor+>                       (noBorders Full ||| Tall 1 0.3 0.5)), >                   ... >               }) ++'useTransientFor' and 'trackFloating' can be enabled independently.  For+example when the floating window sets @WM_TRANSIENT_FOR@, such as libreoffice's+file->preferences window, @optionA@ will have the last-focused window magnified+while @optionB@ will result magnify the window that opened the preferences+window regardless of which tiled window was focused before.++> import XMonad.Layout.Magnifier+> import XMonad.Layout.TrackFloating+>+> underlyingLayout = magnifier (Tall 1 0.3 0.5)+>+> optionA = trackFloating underlyingLayout+> optionB = trackFloating (useTransientFor underlyingLayout)+ -}  {- | Runs another layout with a remembered focus, provided:@@ -96,8 +107,9 @@ * the remembered focus hasn't since been killed  -}+{-# DEPRECATED trackFloating "Use X.L.FocusTracking.focusTracking." #-} trackFloating ::  l a -> ModifiedLayout TrackFloating l a-trackFloating layout = ModifiedLayout (TrackFloating False Nothing) layout+trackFloating = focusTracking  {- $layoutModifier It also corrects focus issues for full-like layouts inside other layout
XMonad/Layout/TwoPane.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.TwoPane+-- Description :  A layout that splits the screen horizontally and shows two windows. -- Copyright   :  (c) Spencer Janssen <spencerjanssen@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -26,18 +27,18 @@ import XMonad.StackSet ( focus, up, down)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.TwoPane -- -- Then edit your @layoutHook@ by adding the TwoPane layout: -- -- > myLayout = TwoPane (3/100) (1/2)  ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".  data TwoPane a =     TwoPane Rational Rational@@ -55,8 +56,8 @@      handleMessage (TwoPane delta split) x =         return $ case fromMessage x of-                   Just Shrink -> Just (TwoPane delta (split - delta))-                   Just Expand -> Just (TwoPane delta (split + delta))+                   Just Shrink -> Just (TwoPane delta (max 0 (split - delta)))+                   Just Expand -> Just (TwoPane delta (min 1 (split + delta)))                    _           -> Nothing      description _ = "TwoPane"
+ XMonad/Layout/TwoPanePersistent.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.TwoPanePersistent+-- Description :  "XMonad.Layout.TwoPane" with a persistent stack window.+-- Copyright   :  (c) Chayanon Wichitrnithed+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Chayanon Wichitrnithed <namowi@gatech.edu>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This layout is the same as "XMonad.Layout.TwoPane" except that it keeps track of the slave window+-- that is alongside the master pane. In other words, it prevents the slave pane+-- from changing after the focus goes back to the master pane.++-----------------------------------------------------------------------------+++module XMonad.Layout.TwoPanePersistent+  (+    -- * Usage+    -- $usage+  TwoPanePersistent(..)+  ) where++import XMonad.StackSet (focus, up, down, Stack, Stack(..))+import XMonad hiding (focus)++-- $usage+-- Import the module in @xmonad.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 (max 0 (split - delta)))+      Just Expand -> Just (TwoPanePersistent w delta (min 1 (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
+ XMonad/Layout/VoidBorders.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Layout.VoidBorders+-- Description :  Set borders to 0 for all windows in the workspace.+-- Copyright   :  Wilson Sales <spoonm@spoonm.org>+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  <spoonm@spoonm.org>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Modifies a layout to set borders to 0 for all windows in the workspace.+--+-- Unlike "XMonad.Layout.NoBorders", the 'voidBorders' modifier will not+-- restore the window border if the windows are moved to a different workspace+-- or the layout is changed. There is, however, a companion 'normalBorders'+-- modifier which explicitly restores the border.+--+-- This modifier's primary use is to eliminate the "border flash" you get+-- while switching workspaces with the "XMonad.Layout.NoBorders" modifier.+--+-----------------------------------------------------------------------------++module XMonad.Layout.VoidBorders ( -- * Usage+                                   -- $usage+                                   voidBorders+                                 , normalBorders+                                 ) where++import XMonad+import XMonad.Layout.LayoutModifier+import XMonad.StackSet (integrate)++-- $usage+-- You can use this module with the following in your @xmonad.hs@+-- file:+--+-- > import XMonad.Layout.VoidBorders+--+-- and modify the layouts to call 'voidBorders' on the layouts you want to+-- remove borders from windows, and 'normalBorders' on the layouts you want+-- to keep borders for:+--+-- > layoutHook = ... ||| voidBorders Full ||| normalBorders Tall ...+--+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook".++data VoidBorders a = VoidBorders deriving (Read, Show)++instance LayoutModifier VoidBorders Window where+  modifierDescription = const "VoidBorders"++  redoLayout VoidBorders _ Nothing wrs = return (wrs, Nothing)+  redoLayout VoidBorders _ (Just s) wrs = do+    mapM_ setZeroBorder $ integrate s+    return (wrs, Nothing)++voidBorders :: l Window -> ModifiedLayout VoidBorders l Window+voidBorders = ModifiedLayout VoidBorders++data NormalBorders a = NormalBorders deriving (Read, Show)++instance LayoutModifier NormalBorders Window where+  modifierDescription = const "NormalBorders"++  redoLayout NormalBorders _ Nothing wrs = return (wrs, Nothing)+  redoLayout NormalBorders _ (Just s) wrs = do+    mapM_ resetBorders $ integrate s+    return (wrs, Nothing)++normalBorders :: l Window -> ModifiedLayout NormalBorders l Window+normalBorders = ModifiedLayout NormalBorders++-- | Sets border width to 0 for every window from the specified layout.+setZeroBorder :: Window -> X ()+setZeroBorder w = setBorders w 0++-- | Resets the border to the value read from the current configuration.+resetBorders :: Window -> X ()+resetBorders w = asks (borderWidth . config) >>= setBorders w++setBorders :: Window -> Dimension -> X ()+setBorders w bw = withDisplay $ \d -> io $ setWindowBorderWidth d w bw
XMonad/Layout/WindowArranger.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances    #-}+{-# LANGUAGE PatternGuards, FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.WindowArranger+-- Description :  A layout modifier to move and resize windows with the keyboard. -- Copyright   :  (c) Andrea Rossato 2007 -- License     :  BSD-style (see xmonad/LICENSE) --@@ -26,28 +27,27 @@     ) where  import XMonad+import XMonad.Prelude import qualified XMonad.StackSet as S import XMonad.Layout.LayoutModifier-import XMonad.Util.XUtils (fi) -import Control.Arrow-import Data.List+import Control.Arrow ((***), (>>>), (&&&), first)  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.WindowArranger--- > myLayout = layoutHook defaultConfig--- > main = xmonad defaultConfig { layoutHook = windowArrange myLayout }+-- > myLayout = layoutHook def+-- > main = xmonad def { layoutHook = windowArrange myLayout } -- -- or ----- > main = xmonad defaultConfig { layoutHook = windowArrangeAll myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = windowArrangeAll myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- You may also want to define some key binding to move or resize -- windows. These are good defaults:@@ -68,7 +68,7 @@ -- >        , ((modm .|. controlMask .|. shiftMask, xK_Up   ), sendMessage (DecreaseUp    1)) -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -- | A layout modifier to float the windows in a workspace windowArrange :: l a -> ModifiedLayout WindowArranger l a@@ -93,7 +93,6 @@                        | MoveUp        Int                        | MoveDown      Int                        | SetGeometry   Rectangle-                         deriving ( Typeable ) instance Message WindowArrangerMsg  data ArrangedWindow a = WR   (a, Rectangle)@@ -163,7 +162,7 @@ getWR = memberFromList fst (==)  mkNewAWRs :: Eq a => ArrangeAll -> [a] -> [(a,Rectangle)] -> [ArrangedWindow a]-mkNewAWRs b w wrs = map t . concatMap (flip getWR wrs) $ w+mkNewAWRs b w wrs = map t . concatMap (`getWR` wrs) $ w     where t = if b then AWR else WR  removeAWRs :: Eq a => [a] -> [ArrangedWindow a] -> [ArrangedWindow a]@@ -178,7 +177,7 @@ replaceWR wrs = foldr r []     where r x xs               | WR wr <- x = case fst wr `elemIndex` map fst wrs of-                               Just i  -> (WR $ wrs !! i):xs+                               Just i  -> WR (wrs !! i):xs                                Nothing -> x:xs               | otherwise  = x:xs
XMonad/Layout/WindowNavigation.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.WindowNavigation+-- Description :  A layout modifier to allow easy navigation of a workspace. -- Copyright   :  (c) 2007  David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -19,13 +20,13 @@                                    -- $usage                                    windowNavigation, configurableNavigation,                                    Navigate(..), Direction2D(..),-                                   MoveWindowToWindow(..),+                                   MoveWindowToWindow(..), WNConfig,                                    navigateColor, navigateBrightness,-                                   noNavigateBorders, defaultWNConfig,-                                   WNConfig, WindowNavigation,+                                   noNavigateBorders, def,+                                   WindowNavigation,                                   ) where -import Data.List ( nub, sortBy, (\\) )+import XMonad.Prelude ( nub, sortBy, (\\) ) import XMonad hiding (Point) import qualified XMonad.StackSet as W import XMonad.Layout.LayoutModifier@@ -34,19 +35,19 @@ import XMonad.Util.XUtils  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.WindowNavigation ----- Then edit your @layoutHook@ by adding the WindowNavigation layout modifier+-- Then edit your 'layoutHook' by adding the WindowNavigation layout modifier -- to some layout: ----- > myLayout = windowNavigation (Tall 1 (3/100) (1/2))  ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > myLayout = windowNavigation (Tall 1 (3/100) (1/2)) ||| Full ||| etc..+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the 'layoutHook' see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- In keybindings: --@@ -61,17 +62,24 @@ -- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  -data MoveWindowToWindow a = MoveWindowToWindow a a deriving ( Read, Show, Typeable )+data MoveWindowToWindow a = MoveWindowToWindow a a deriving ( Read, Show) instance Typeable a => Message (MoveWindowToWindow a)  data Navigate = Go Direction2D | Swap Direction2D | Move Direction2D               | Apply (Window -> X()) Direction2D -- ^ Apply action with destination window-        deriving ( Typeable ) instance Message Navigate +-- | Used with 'configurableNavigation' to specify how to show reachable windows'+-- borders. You cannot create 'WNConfig' values directly; use 'def' or one of the following+-- three functions to create one.+--+-- 'def', and 'windowNavigation', uses the focused border color at 40% brightness, as if+-- you had specified+--+-- > configurableNavigation (navigateBrightness 0.4) data WNConfig =     WNC { brightness    :: Maybe Double -- Indicates a fraction of the focus color.         , upColor       :: String@@ -80,26 +88,29 @@         , rightColor    :: String         } deriving (Show, Read) +-- | Don't use window borders for navigation. noNavigateBorders :: WNConfig noNavigateBorders =-    defaultWNConfig {brightness = Just 0}+    def {brightness = Just 0} +-- | Indicate reachable windows by drawing their borders in the specified color. navigateColor :: String -> WNConfig navigateColor c =     WNC Nothing c c c c +-- | Indicate reachable windows by drawing their borders in the active border color, with+-- the specified brightness. navigateBrightness :: Double -> WNConfig-navigateBrightness f = defaultWNConfig { brightness = Just $ max 0 $ min 1 f }+navigateBrightness f = def { brightness = Just $ max 0 $ min 1 f } -defaultWNConfig :: WNConfig-defaultWNConfig = WNC (Just 0.4) "#0000FF" "#00FFFF" "#FF0000" "#FF00FF"+instance Default WNConfig where def = WNC (Just 0.4) "#0000FF" "#00FFFF" "#FF0000" "#FF00FF"  data NavigationState a = NS Point [(a,Rectangle)]  data WindowNavigation a = WindowNavigation WNConfig (Invisible Maybe (NavigationState a)) deriving ( Read, Show )  windowNavigation :: LayoutClass l a => l a -> ModifiedLayout WindowNavigation l a-windowNavigation = ModifiedLayout (WindowNavigation defaultWNConfig (I Nothing))+windowNavigation = ModifiedLayout (WindowNavigation def (I Nothing))  configurableNavigation :: LayoutClass l a => WNConfig -> l a -> ModifiedLayout WindowNavigation l a configurableNavigation conf = ModifiedLayout (WindowNavigation conf (I Nothing))@@ -192,7 +203,9 @@ navigable d pt = sortby d . filter (inr d pt . snd)  sc :: Pixel -> Window -> X ()-sc c win = withDisplay $ \dpy -> io $ setWindowBorder dpy win c+sc c win = withDisplay $ \dpy -> do+    colorName <- io (pixelToString dpy c)+    setWindowBorderWithFallback dpy win colorName c  center :: Rectangle -> Point center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2)  (fromIntegral y + fromIntegral h/2)
XMonad/Layout/WindowSwitcherDecoration.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ViewPatterns #-} ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.WindowSwitcherDecoration+-- Description :  Switch the position of windows by dragging them onto each other. -- Copyright   :  (c) Jan Vornberger 2009 --                    Alejandro Serrano 2010 -- License     :  BSD3-style (see LICENSE)@@ -30,12 +31,12 @@ import XMonad.Layout.ImageButtonDecoration import XMonad.Layout.DraggingVisualizer import qualified XMonad.StackSet as S-import Control.Monad+import XMonad.Prelude import Foreign.C.Types(CInt)  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Layout.WindowSwitcherDecoration -- > import XMonad.Layout.DraggingVisualizer@@ -43,8 +44,8 @@ -- Then edit your @layoutHook@ by adding the WindowSwitcherDecoration to -- your layout: ----- > myL = windowSwitcherDecoration shrinkText defaultTheme (draggingVisualizer $ layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }+-- > myL = windowSwitcherDecoration shrinkText def (draggingVisualizer $ layoutHook def)+-- > main = xmonad def { layoutHook = myL } -- -- There is also a version of the decoration that contains buttons like -- "XMonad.Layout.ButtonDecoration". To use that version, you will need to@@ -53,8 +54,8 @@ -- -- > import XMonad.Layout.DecorationAddons -- >--- > myL = windowSwitcherDecorationWithButtons shrinkText defaultThemeWithButtons (draggingVisualizer $ layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }+-- > myL = windowSwitcherDecorationWithButtons shrinkText defaultThemeWithButtons (draggingVisualizer $ layoutHook def)+-- > main = xmonad def { layoutHook = myL } -- -- Additionaly, there is a version of the decoration that contains image buttons like -- "XMonad.Layout.ImageButtonDecoration". To use that version, you will need to@@ -63,8 +64,8 @@ -- -- > import XMonad.Layout.ImageButtonDecoration -- >--- > myL = windowSwitcherDecorationWithImageButtons shrinkText defaultThemeWithImageButtons (draggingVisualizer $ layoutHook defaultConfig)--- > main = xmonad defaultConfig { layoutHook = myL }+-- > myL = windowSwitcherDecorationWithImageButtons shrinkText defaultThemeWithImageButtons (draggingVisualizer $ layoutHook def)+-- > main = xmonad def { layoutHook = myL } --  windowSwitcherDecoration :: (Eq a, Shrinker s) => s -> Theme@@ -75,7 +76,7 @@            -> l a -> ModifiedLayout (Decoration WindowSwitcherDecoration s) l a windowSwitcherDecorationWithButtons s c = decoration s c $ WSD True -data WindowSwitcherDecoration a = WSD Bool deriving (Show, Read)+newtype WindowSwitcherDecoration a = WSD Bool deriving (Show, Read)  instance Eq a => DecorationStyle WindowSwitcherDecoration a where     describeDeco _ = "WindowSwitcherDeco"@@ -83,10 +84,10 @@     decorationCatchClicksHook (WSD withButtons) mainw dFL dFR = if withButtons                                                                     then titleBarButtonHandler mainw dFL dFR                                                                     else return False-    decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleTiledDraggingInProgress ex ey (mainw, r) x y+    decorationWhileDraggingHook _ = handleTiledDraggingInProgress     decorationAfterDraggingHook _ (mainw, _) decoWin = do focus mainw                                                           hasCrossed <- handleScreenCrossing mainw decoWin-                                                          unless hasCrossed $ do sendMessage $ DraggingStopped+                                                          unless hasCrossed $ do sendMessage DraggingStopped                                                                                  performWindowSwitching mainw  -- Note: the image button code is duplicated from the above@@ -96,7 +97,7 @@            -> l a -> ModifiedLayout (Decoration ImageWindowSwitcherDecoration s) l a windowSwitcherDecorationWithImageButtons s c = decoration s c $ IWSD True -data ImageWindowSwitcherDecoration a = IWSD Bool deriving (Show, Read)+newtype ImageWindowSwitcherDecoration a = IWSD Bool deriving (Show, Read)  instance Eq a => DecorationStyle ImageWindowSwitcherDecoration a where     describeDeco _ = "ImageWindowSwitcherDeco"@@ -104,10 +105,10 @@     decorationCatchClicksHook (IWSD withButtons) mainw dFL dFR = if withButtons                                                                     then imageTitleBarButtonHandler mainw dFL dFR                                                                     else return False-    decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleTiledDraggingInProgress ex ey (mainw, r) x y+    decorationWhileDraggingHook _ = handleTiledDraggingInProgress     decorationAfterDraggingHook _ (mainw, _) decoWin = do focus mainw                                                           hasCrossed <- handleScreenCrossing mainw decoWin-                                                          unless hasCrossed $ do sendMessage $ DraggingStopped+                                                          unless hasCrossed $ do sendMessage DraggingStopped                                                                                  performWindowSwitching mainw  handleTiledDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()@@ -126,13 +127,11 @@        ws <- gets windowset        let allWindows = S.index ws        -- do a little double check to be sure-       if (win `elem` allWindows) && (selWin `elem` allWindows)-            then do+       when ((win `elem` allWindows) && (selWin `elem` allWindows)) $ do                 let allWindowsSwitched = map (switchEntries win selWin) allWindows-                let (ls, t:rs) = break (win ==) allWindowsSwitched+                let (ls, notEmpty -> t :| rs) = break (win ==) allWindowsSwitched                 let newStack = S.Stack t (reverse ls) rs-                windows $ S.modify' $ \_ -> newStack-            else return ()+                windows $ S.modify' $ const newStack     where         switchEntries a b x             | x == a    = b
XMonad/Layout/WorkspaceDir.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.WorkspaceDir+-- Description :  A layout modifier to set the current directory in a workspace. -- Copyright   :  (c) 2007  David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -27,10 +28,11 @@                                    workspaceDir,                                    changeDir,                                    WorkspaceDir,+                                   Chdir(Chdir),                                   ) where  import System.Directory ( setCurrentDirectory, getCurrentDirectory )-import Control.Monad ( when )+import XMonad.Prelude ( when )  import XMonad hiding ( focus ) import XMonad.Prompt ( XPConfig )@@ -39,7 +41,7 @@ import XMonad.StackSet ( tag, currentTag )  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Layout.WorkspaceDir --@@ -47,25 +49,30 @@ -- to some layout: -- -- > myLayout = workspaceDir "~" (Tall 1 (3/100) (1/2))  ||| Full ||| etc..--- > main = xmonad defaultConfig { layoutHook = myLayout }------ For more detailed instructions on editing the layoutHook see:+-- > main = xmonad def { layoutHook = myLayout } ----- "XMonad.Doc.Extending#Editing_the_layout_hook"+-- For more detailed instructions on editing the layoutHook see+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and+-- "XMonad.Doc.Extending#Editing_the_layout_hook". -- -- WorkspaceDir provides also a prompt. To use it you need to import -- "XMonad.Prompt" and add something like this to your key bindings: ----- >  , ((modm .|. shiftMask, xK_x     ), changeDir defaultXPConfig)+-- >  , ((modm .|. shiftMask, xK_x     ), changeDir def) --+-- If you prefer a prompt with case-insensitive completion:+--+-- >  , ((modm .|. shiftMask, xK_x     ),+--       changeDir def {complCaseSensitivity = CaseInSensitive})+-- -- For detailed instruction on editing the key binding see: ----- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data Chdir = Chdir String deriving ( Typeable )+newtype Chdir = Chdir String instance Message Chdir -data WorkspaceDir a = WorkspaceDir String deriving ( Read, Show )+newtype WorkspaceDir a = WorkspaceDir String deriving ( Read, Show )  instance LayoutModifier WorkspaceDir Window where     modifyLayout (WorkspaceDir d) w r = do tc <- gets (currentTag.windowset)
XMonad/Layout/ZoomRow.hs view
@@ -1,11 +1,12 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses-  , PatternGuards, DeriveDataTypeable, ExistentialQuantification+  , PatternGuards, ExistentialQuantification   , FlexibleContexts #-}  ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Layout.ZoomRow+-- Description :  Row layout with individually resizable elements. -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -35,12 +36,11 @@                              ) where  import XMonad+import XMonad.Prelude (fromMaybe, fi) import qualified XMonad.StackSet as W  import XMonad.Util.Stack-import XMonad.Layout.Decoration (fi) -import Data.Maybe (fromMaybe) import Control.Arrow (second)  -- $usage@@ -49,7 +49,7 @@ -- and decreased, and a window can be set to use the whole available -- space whenever it has focus. ----- You can use this module by including  the following in your @~\/.xmonad/xmonad.hs@:+-- You can use this module by including  the following in your @xmonad.hs@: -- -- > import XMonad.Layout.ZoomRow --@@ -69,8 +69,9 @@ -- >   -- (Un)Maximize the focused window -- > , ((modMask             , xK_f    ), sendMessage ToggleZoomFull) ----- For more information on editing your layout hook and key bindings,--- see "XMonad.Doc.Extending".+-- For more information on editing your layoutHook and key bindings,+-- see <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>+-- and "XMonad.Doc.Extending".  -- * Creation functions @@ -106,7 +107,7 @@                           -- ^ Function to compare elements for                           -- equality, a real Eq instance might                           -- not be what you want in some cases-                      , zoomRatios :: (Zipper (Elt a))+                      , zoomRatios :: Zipper (Elt a)                           -- ^ Element specs. The zipper is so we                           -- know what the focus is when we handle                           --  a message@@ -163,7 +164,7 @@                  | ZoomFullToggle                  -- ^ Toggle whether the focused window should                  -- occupy all available space when it has focus-  deriving (Typeable, Show)+  deriving (Show)  instance Message ZoomMessage @@ -185,7 +186,7 @@  -- * LayoutClass instance -instance (EQF f a, Show a, Read a, Show (f a), Read (f a))+instance (EQF f a, Show a, Read a, Show (f a), Read (f a), Typeable f)     => LayoutClass (ZoomRow f) a where     description (ZC _ Nothing) = "ZoomRow"     description (ZC _ (Just s)) = "ZoomRow" ++ if full $ W.focus s@@ -237,7 +238,7 @@                         helper (Right a:as) (Right b:bs) = a `sameAs` b && as `helper` bs                         helper (Left a:as) (Left b:bs) = a `sameAs` b && as `helper` bs                         helper _ _ = False-                        E a1 r1 b1 `sameAs` E a2 r2 b2 = (eq f a1 a2) && (r1 == r2) && (b1 == b2)+                        E a1 r1 b1 `sameAs` E a2 r2 b2 = eq f a1 a2 && (r1 == r2) && (b1 == b2)      pureMessage (ZC f zelts) sm | Just (ZoomFull False) <- fromMessage sm                                 , Just (E a r True) <- getFocusZ zelts
+ XMonad/Prelude.hs view
@@ -0,0 +1,514 @@+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+--------------------------------------------------------------------+-- |+-- Module      :  XMonad.Prelude+-- Description :  Utility functions and re-exports.+-- Copyright   :  (c) 2021  Tony Zorman+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Tony Zorman <soliditsallgood@mailbox.org>+--+-- Utility functions and re-exports for a more ergonomic developing+-- experience.  Users themselves will not find much use here.+--+--------------------------------------------------------------------+module XMonad.Prelude (+    module Exports,+    fi,+    chunksOf,+    (.:),+    (!?),+    NonEmpty((:|)),+    notEmpty,+    safeGetWindowAttributes,+    mkAbsolutePath,+    findM,++    -- * Keys+    keyToString,+    keymaskToString,+    cleanKeyMask,+    regularKeys,+    allSpecialKeys,+    specialKeys,+    multimediaKeys,+    functionKeys,+    WindowScreen,++    -- * Infinite streams+    Stream(..),+    (+~),+    cycleS,+    takeS,+    toList,+    fromList,+) where++import Foreign (alloca, peek)+import XMonad++import Control.Applicative as Exports+import Control.Monad       as Exports+import Data.Bool           as Exports+import Data.Char           as Exports+import Data.Foldable       as Exports hiding (toList)+import Data.Function       as Exports+import Data.Functor        as Exports hiding (unzip)+import Data.List           as Exports hiding ((!?))+import Data.Maybe          as Exports+import Data.Monoid         as Exports+import Data.Traversable    as Exports++import qualified Data.Map.Strict as Map++import Control.Arrow ((&&&), first)+import Control.Exception (SomeException, handle)+import Data.Bifunctor (bimap)+import Data.Bits+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Tuple (swap)+import GHC.Exts (IsList(..))+import GHC.Stack+import System.Directory (getHomeDirectory)+import System.Environment (getEnv)+import qualified XMonad.StackSet as W++-- | Short for 'fromIntegral'.+fi :: (Integral a, Num b) => a -> b+fi = fromIntegral++-- | Given a maximum length, splits a list into sublists+--+-- >>> chunksOf 5 (take 30 $ repeat 'a')+-- ["aaaaa","aaaaa","aaaaa","aaaaa","aaaaa","aaaaa"]+chunksOf :: Int -> [a] -> [[a]]+chunksOf _ [] = []+chunksOf i xs = chunk : chunksOf i rest+  where !(chunk, rest) = splitAt i xs++-- | Safe version of '(!!)'.+(!?) :: [a] -> Int -> Maybe a+(!?) xs n | n < 0 = Nothing+          | otherwise = listToMaybe $ drop n xs++-- | Multivariable composition.+--+-- > f .: g ≡ (f .) . g ≡ \c d -> f (g c d)+(.:) :: (a -> b) -> (c -> d -> a) -> c -> d -> b+(.:) = (.) . (.)++-- | Like 'find', but takes a monadic function instead; retains the+-- short-circuiting behaviour of the non-monadic version.+--+-- For example,+--+-- > findM (\a -> putStr (show a <> " ") >> pure False) [1..10]+--+-- would print "1 2 3 4 5 6 7 8 9 10" and return @Nothing@, while+--+-- > findM (\a -> putStr (show a <> " ") >> pure True) [1..10]+--+-- would print @"1"@ and return @Just 1@.+findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)++-- | 'Data.List.NonEmpty.fromList' with a better error message. Useful to+-- silence GHC's Pattern match(es) are non-exhaustive warning in places where+-- the programmer knows it's always non-empty, but it's infeasible to express+-- that in the type system.+notEmpty :: HasCallStack => [a] -> NonEmpty a+notEmpty [] = error "unexpected empty list"+notEmpty (x:xs) = x :| xs++-- | A safe version of 'Graphics.X11.Xlib.Extras.getWindowAttributes'.+safeGetWindowAttributes :: Window -> X (Maybe WindowAttributes)+safeGetWindowAttributes w = withDisplay $ \dpy -> io . alloca $ \p ->+  xGetWindowAttributes dpy w p >>= \case+    0 -> pure Nothing+    _ -> Just <$> peek p++-- | (Naïvely) turn a relative path into an absolute one.+--+-- * If the path starts with @\/@, do nothing.+--+-- * If it starts with @~\/@, replace that with the actual home+-- * directory.+--+-- * If it starts with @$@, read the name of an environment+-- * variable and replace it with the contents of that.+--+-- * Otherwise, prepend the home directory and @\/@ to the path.+mkAbsolutePath :: MonadIO m => FilePath -> m FilePath+mkAbsolutePath ps = do+  home <- io getHomeDirectory+  case ps of+    '/'       : _ -> pure ps+    '~' : '/' : _ -> pure (home <> drop 1 ps)+    '$'       : _ -> let (v,ps') = span (`elem` ("_"<>['A'..'Z']<>['a'..'z']<>['0'..'9'])) (drop 1 ps)+                      in io ((\(_ :: SomeException) -> pure "") `handle` getEnv v) Exports.<&> (<> ps')+    _             -> pure (home <> ('/' : ps))+{-# SPECIALISE mkAbsolutePath :: FilePath -> IO FilePath #-}+{-# SPECIALISE mkAbsolutePath :: FilePath -> X  FilePath #-}++-----------------------------------------------------------------------+-- Keys++-- | Convert a modifier mask into a useful string.+keymaskToString :: KeyMask -- ^ Num lock mask+                -> KeyMask -- ^ Modifier mask+                -> String+keymaskToString numLockMask msk =+  concat . reverse . fst . foldr go ([], msk) $ masks+ where+  masks :: [(KeyMask, String)]+  masks = map (\m -> (m, show m))+              [0 .. toEnum (finiteBitSize msk - 1)]+       ++ [ (numLockMask, "num-" )+          , (lockMask,    "lock-")+          , (controlMask, "C-"   )+          , (shiftMask,   "S-"   )+          , (mod5Mask,    "M5-"  )+          , (mod4Mask,    "M4-"  )+          , (mod3Mask,    "M3-"  )+          , (mod2Mask,    "M2-"  )+          , (mod1Mask,    "M1-"  )+          ]++  go :: (KeyMask, String) -> ([String], KeyMask) -> ([String], KeyMask)+  go (m, s) a@(ss, v)+    | v == 0       = a+    | v .&. m == m = (s : ss, v .&. complement m)+    | otherwise    = a++-- | Convert a full key combination; i.e., a 'KeyMask' and 'KeySym'+-- pair, into a string.+keyToString :: (KeyMask, KeySym) -> String+keyToString = uncurry (++) . bimap (keymaskToString 0) ppKeysym+ where+  ppKeysym :: KeySym -> String+  ppKeysym x = case specialMap Map.!? x of+    Just s  -> "<" <> s <> ">"+    Nothing -> case regularMap Map.!? x of+      Nothing -> keysymToString x+      Just s  -> s++  regularMap = Map.fromList (map swap regularKeys)+  specialMap = Map.fromList (map swap allSpecialKeys)++-- | Strip numlock, capslock, mouse buttons and XKB group from a 'KeyMask',+-- leaving only modifier keys like Shift, Control, Super, Hyper in the mask+-- (hence the \"Key\" in \"cleanKeyMask\").+--+-- Core's 'cleanMask' only strips the first two because key events from+-- passive grabs (key bindings) are stripped of mouse buttons and XKB group by+-- the X server already for compatibility reasons. For more info, see:+-- <https://www.x.org/releases/X11R7.7/doc/kbproto/xkbproto.html#Delivering_a_Key_or_Button_Event_to_a_Client>+cleanKeyMask :: X (KeyMask -> KeyMask)+cleanKeyMask = cleanKeyMask' <$> gets numberlockMask++cleanKeyMask' :: KeyMask -> KeyMask -> KeyMask+cleanKeyMask' numLockMask mask =+    mask .&. complement (numLockMask .|. lockMask) .&. (button1Mask - 1)++-- | A list of "regular" (extended ASCII) keys.+regularKeys :: [(String, KeySym)]+regularKeys = map (first (:[]))+            $ zip ['!'             .. '~'          ] -- ASCII+                  [xK_exclam       .. xK_asciitilde]+           <> zip ['\xa0'          .. '\xff'       ] -- Latin1+                  [xK_nobreakspace .. xK_ydiaeresis]++-- | A list of all special key names and their associated KeySyms.+allSpecialKeys :: [(String, KeySym)]+allSpecialKeys = functionKeys <> specialKeys <> multimediaKeys++-- | A list pairing function key descriptor strings (e.g. @\"\<F2\>\"@)+-- with the associated KeySyms.+functionKeys :: [(String, KeySym)]+functionKeys = [ ('F' : show n, k)+               | (n,k) <- zip ([1..24] :: [Int]) [xK_F1..]+               ]++-- | A list of special key names and their corresponding KeySyms.+specialKeys :: [(String, KeySym)]+specialKeys =+  [ ("Backspace"  , xK_BackSpace)+  , ("Tab"        , xK_Tab)+  , ("Return"     , xK_Return)+  , ("Pause"      , xK_Pause)+  , ("Num_Lock"   , xK_Num_Lock)+  , ("Caps_Lock"  , xK_Caps_Lock)+  , ("Scroll_lock", xK_Scroll_Lock)+  , ("Sys_Req"    , xK_Sys_Req)+  , ("Print"      , xK_Print)+  , ("Escape"     , xK_Escape)+  , ("Esc"        , xK_Escape)+  , ("Delete"     , xK_Delete)+  , ("Home"       , xK_Home)+  , ("Left"       , xK_Left)+  , ("Up"         , xK_Up)+  , ("Right"      , xK_Right)+  , ("Down"       , xK_Down)+  , ("L"          , xK_Left)+  , ("U"          , xK_Up)+  , ("R"          , xK_Right)+  , ("D"          , xK_Down)+  , ("Page_Up"    , xK_Page_Up)+  , ("Page_Down"  , xK_Page_Down)+  , ("End"        , xK_End)+  , ("Insert"     , xK_Insert)+  , ("Break"      , xK_Break)+  , ("Space"      , xK_space)+  , ("Control_L"  , xK_Control_L)+  , ("Control_R"  , xK_Control_R)+  , ("Shift_L"    , xK_Shift_L)+  , ("Shift_R"    , xK_Shift_R)+  , ("Alt_L"      , xK_Alt_L)+  , ("Alt_R"      , xK_Alt_R)+  , ("Meta_L"     , xK_Meta_L)+  , ("Meta_R"     , xK_Meta_R)+  , ("Super_L"    , xK_Super_L)+  , ("Super_R"    , xK_Super_R)+  , ("Hyper_L"    , xK_Hyper_L)+  , ("Hyper_R"    , xK_Hyper_R)+  , ("KP_Space"   , xK_KP_Space)+  , ("KP_Tab"     , xK_KP_Tab)+  , ("KP_Enter"   , xK_KP_Enter)+  , ("KP_F1"      , xK_KP_F1)+  , ("KP_F2"      , xK_KP_F2)+  , ("KP_F3"      , xK_KP_F3)+  , ("KP_F4"      , xK_KP_F4)+  , ("KP_Home"    , xK_KP_Home)+  , ("KP_Left"    , xK_KP_Left)+  , ("KP_Up"      , xK_KP_Up)+  , ("KP_Right"   , xK_KP_Right)+  , ("KP_Down"    , xK_KP_Down)+  , ("KP_Prior"   , xK_KP_Prior)+  , ("KP_Page_Up" , xK_KP_Page_Up)+  , ("KP_Next"    , xK_KP_Next)+  , ("KP_Page_Down", xK_KP_Page_Down)+  , ("KP_End"     , xK_KP_End)+  , ("KP_Begin"   , xK_KP_Begin)+  , ("KP_Insert"  , xK_KP_Insert)+  , ("KP_Delete"  , xK_KP_Delete)+  , ("KP_Equal"   , xK_KP_Equal)+  , ("KP_Multiply", xK_KP_Multiply)+  , ("KP_Add"     , xK_KP_Add)+  , ("KP_Separator", xK_KP_Separator)+  , ("KP_Subtract", xK_KP_Subtract)+  , ("KP_Decimal" , xK_KP_Decimal)+  , ("KP_Divide"  , xK_KP_Divide)+  , ("KP_0"       , xK_KP_0)+  , ("KP_1"       , xK_KP_1)+  , ("KP_2"       , xK_KP_2)+  , ("KP_3"       , xK_KP_3)+  , ("KP_4"       , xK_KP_4)+  , ("KP_5"       , xK_KP_5)+  , ("KP_6"       , xK_KP_6)+  , ("KP_7"       , xK_KP_7)+  , ("KP_8"       , xK_KP_8)+  , ("KP_9"       , xK_KP_9)+  , ("Menu"       , xK_Menu)+  ]++-- | List of multimedia keys. If Xlib does not know about some keysym+-- it's omitted from the list ('stringToKeysym' returns 'noSymbol' in+-- this case).+multimediaKeys :: [(String, KeySym)]+multimediaKeys = filter ((/= noSymbol) . snd) . map (id &&& stringToKeysym) $+  [ "XF86ModeLock"+  , "XF86MonBrightnessUp"+  , "XF86MonBrightnessDown"+  , "XF86KbdLightOnOff"+  , "XF86KbdBrightnessUp"+  , "XF86KbdBrightnessDown"+  , "XF86Standby"+  , "XF86AudioLowerVolume"+  , "XF86AudioMute"+  , "XF86AudioRaiseVolume"+  , "XF86AudioPlay"+  , "XF86AudioStop"+  , "XF86AudioPrev"+  , "XF86AudioNext"+  , "XF86HomePage"+  , "XF86Mail"+  , "XF86Start"+  , "XF86Search"+  , "XF86AudioRecord"+  , "XF86Calculator"+  , "XF86Memo"+  , "XF86ToDoList"+  , "XF86Calendar"+  , "XF86PowerDown"+  , "XF86ContrastAdjust"+  , "XF86RockerUp"+  , "XF86RockerDown"+  , "XF86RockerEnter"+  , "XF86Back"+  , "XF86Forward"+  , "XF86Stop"+  , "XF86Refresh"+  , "XF86PowerOff"+  , "XF86WakeUp"+  , "XF86Eject"+  , "XF86ScreenSaver"+  , "XF86WWW"+  , "XF86Sleep"+  , "XF86Favorites"+  , "XF86AudioPause"+  , "XF86AudioMedia"+  , "XF86MyComputer"+  , "XF86VendorHome"+  , "XF86LightBulb"+  , "XF86Shop"+  , "XF86History"+  , "XF86OpenURL"+  , "XF86AddFavorite"+  , "XF86HotLinks"+  , "XF86BrightnessAdjust"+  , "XF86Finance"+  , "XF86Community"+  , "XF86AudioRewind"+  , "XF86BackForward"+  , "XF86Launch0"+  , "XF86Launch1"+  , "XF86Launch2"+  , "XF86Launch3"+  , "XF86Launch4"+  , "XF86Launch5"+  , "XF86Launch6"+  , "XF86Launch7"+  , "XF86Launch8"+  , "XF86Launch9"+  , "XF86LaunchA"+  , "XF86LaunchB"+  , "XF86LaunchC"+  , "XF86LaunchD"+  , "XF86LaunchE"+  , "XF86LaunchF"+  , "XF86ApplicationLeft"+  , "XF86ApplicationRight"+  , "XF86Book"+  , "XF86CD"+  , "XF86Calculater"+  , "XF86Clear"+  , "XF86Close"+  , "XF86Copy"+  , "XF86Cut"+  , "XF86Display"+  , "XF86DOS"+  , "XF86Documents"+  , "XF86Excel"+  , "XF86Explorer"+  , "XF86Game"+  , "XF86Go"+  , "XF86iTouch"+  , "XF86LogOff"+  , "XF86Market"+  , "XF86Meeting"+  , "XF86MenuKB"+  , "XF86MenuPB"+  , "XF86MySites"+  , "XF86New"+  , "XF86News"+  , "XF86OfficeHome"+  , "XF86Open"+  , "XF86Option"+  , "XF86Paste"+  , "XF86Phone"+  , "XF86Q"+  , "XF86Reply"+  , "XF86Reload"+  , "XF86RotateWindows"+  , "XF86RotationPB"+  , "XF86RotationKB"+  , "XF86Save"+  , "XF86ScrollUp"+  , "XF86ScrollDown"+  , "XF86ScrollClick"+  , "XF86Send"+  , "XF86Spell"+  , "XF86SplitScreen"+  , "XF86Support"+  , "XF86TaskPane"+  , "XF86Terminal"+  , "XF86Tools"+  , "XF86Travel"+  , "XF86UserPB"+  , "XF86User1KB"+  , "XF86User2KB"+  , "XF86Video"+  , "XF86WheelButton"+  , "XF86Word"+  , "XF86Xfer"+  , "XF86ZoomIn"+  , "XF86ZoomOut"+  , "XF86Away"+  , "XF86Messenger"+  , "XF86WebCam"+  , "XF86MailForward"+  , "XF86Pictures"+  , "XF86Music"+  , "XF86TouchpadToggle"+  , "XF86AudioMicMute"+  , "XF86_Switch_VT_1"+  , "XF86_Switch_VT_2"+  , "XF86_Switch_VT_3"+  , "XF86_Switch_VT_4"+  , "XF86_Switch_VT_5"+  , "XF86_Switch_VT_6"+  , "XF86_Switch_VT_7"+  , "XF86_Switch_VT_8"+  , "XF86_Switch_VT_9"+  , "XF86_Switch_VT_10"+  , "XF86_Switch_VT_11"+  , "XF86_Switch_VT_12"+  , "XF86_Ungrab"+  , "XF86_ClearGrab"+  , "XF86_Next_VMode"+  , "XF86_Prev_VMode"+  , "XF86Bluetooth"+  , "XF86WLAN"+  ]++-- | The specialized 'W.Screen' derived from 'WindowSet'.+type WindowScreen -- FIXME move to core+    = W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail++-- | An infinite stream type+data Stream a = !a :~ Stream a+infixr 5 :~++instance Functor Stream where+  fmap :: (a -> b) -> Stream a -> Stream b+  fmap f = go+   where go (x :~ xs) = f x :~ go xs++instance IsList (Stream a) where+  type (Item (Stream a)) = a++  fromList :: [a] -> Stream a+  fromList (x : xs) = x :~ fromList xs+  fromList []       = errorWithoutStackTrace "XMonad.Prelude.Stream.fromList: Can't create stream out of finite list."++  toList :: Stream a -> [a]+  toList (x :~ xs) = x : toList xs++-- | Absorb a list into an infinite stream.+(+~) :: [a] -> Stream a -> Stream a+xs +~ s = foldr (:~) s xs+infixr 5 +~++-- | Absorb a non-empty list into an infinite stream.+cycleS :: NonEmpty a -> Stream a+cycleS (x :| xs) = s where s = x :~ xs +~ s++-- | @takeS n stream@ returns the first @n@ elements of @stream@; if @n < 0@,+-- this returns the empty list.+takeS :: Int -> Stream a -> [a]+takeS n = take n . toList
XMonad/Prompt.hs view
@@ -1,1196 +1,1862 @@-{-# LANGUAGE ExistentialQuantification, FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module      :  XMonad.Prompt--- Copyright   :  (C) 2007 Andrea Rossato--- License     :  BSD3------ Maintainer  :  Spencer Janssen <spencerjanssen@gmail.com>--- Stability   :  unstable--- Portability :  unportable------ A module for writing graphical prompts for XMonad-----------------------------------------------------------------------------------module XMonad.Prompt-    ( -- * Usage-      -- $usage-      mkXPrompt-    , mkXPromptWithReturn-    , mkXPromptWithModes-    , amberXPConfig-    , defaultXPConfig-    , greenXPConfig-    , XPMode-    , XPType (..)-    , XPPosition (..)-    , XPConfig (..)-    , XPrompt (..)-    , XP-    , defaultXPKeymap, defaultXPKeymap'-    , emacsLikeXPKeymap, emacsLikeXPKeymap'-    , quit-    , killBefore, killAfter, startOfLine, endOfLine-    , pasteString, moveCursor-    , setInput, getInput-    , moveWord, moveWord', killWord, killWord', deleteString-    , moveHistory, setSuccess, setDone-    , Direction1D(..)-    , ComplFunction-    -- * X Utilities-    -- $xutils-    , mkUnmanagedWindow-    , fillDrawable-    -- * Other Utilities-    -- $utils-    , mkComplFunFromList-    , mkComplFunFromList'-    -- * @nextCompletion@ implementations-    , getNextOfLastWord-    , getNextCompletion-    -- * List utilities-    , getLastWord-    , skipLastWord-    , splitInSubListsAt-    , breakAtSpace-    , uniqSort-    , historyCompletion-    , historyCompletionP-    -- * History filters-    , deleteAllDuplicates-    , deleteConsecutive-    , HistoryMatches-    , initMatches-    , historyUpMatching-    , historyDownMatching-    -- * Types-    , XPState-    ) where--import           XMonad                       hiding (cleanMask, config)-import qualified XMonad                       as X (numberlockMask)-import qualified XMonad.StackSet              as W-import           XMonad.Util.Font-import           XMonad.Util.Types-import           XMonad.Util.XSelection       (getSelection)--import           Codec.Binary.UTF8.String     (decodeString,isUTF8Encoded)-import           Control.Applicative          ((<$>))-import           Control.Arrow                (first, (&&&), (***))-import           Control.Concurrent           (threadDelay)-import           Control.Exception.Extensible as E hiding (handle)-import           Control.Monad.State-import           Data.Bits-import           Data.Char                    (isSpace)-import           Data.IORef-import           Data.List-import qualified Data.Map                     as M-import           Data.Maybe                   (fromMaybe)-import           Data.Set                     (fromList, toList)-import           System.Directory             (getAppUserDataDirectory)-import           System.IO-import           System.Posix.Files---- $usage--- For usage examples see "XMonad.Prompt.Shell",--- "XMonad.Prompt.XMonad" or "XMonad.Prompt.Ssh"------ TODO:------ * scrolling the completions that don't fit in the window (?)--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-        }--data XPConfig =-    XPC { font              :: String     -- ^ Font-        , 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' or 'Bottom'-        , alwaysHighlight   :: !Bool      -- ^ Always highlight an item, overriden to True with multiple modes. This implies having *one* column of autocompletions only.-        , height            :: !Dimension -- ^ Window height-        , 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     :: 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,-        , showCompletionOnTab :: Bool     -- ^ Only show list of completions when Tab was pressed-                                          --   and delay by x microseconds-        , searchPredicate   :: String -> String -> Bool-                                          -- ^ Given the typed string and a possible-                                          --   completion, is the completion valid?-        }--data XPType = forall p . XPrompt p => XPT p-type ComplFunction = String -> IO [String]-type XPMode = XPType-data XPOperationMode = XPSingleMode ComplFunction XPType | XPMultipleModes (W.Stack XPType)--instance Show XPType where-    show (XPT p) = showXPrompt p--instance XPrompt XPType where-    showXPrompt                 = show-    nextCompletion      (XPT t) = nextCompletion      t-    commandToComplete   (XPT t) = commandToComplete   t-    completionToCommand (XPT t) = completionToCommand t-    completionFunction  (XPT t) = completionFunction  t-    modeAction          (XPT t) = modeAction          t---- | The class prompt types must be an instance of. In order to--- create a prompt you need to create a data type, without parameters,--- and make it an instance of this class, by implementing a simple--- method, 'showXPrompt', which will be used to print the string to be--- displayed in the command line window.------ This is an example of a XPrompt instance definition:------ >     instance XPrompt Shell where--- >          showXPrompt Shell = "Run: "-class XPrompt t where--    -- | This method is used to print the string to be-    -- displayed in the command line window.-    showXPrompt :: t -> String--    -- | This method is used to generate the next completion to be-    -- printed in the command line when tab is pressed, given the-    -- string presently in the command line and the list of-    -- completion.-    -- This function is not used when in multiple modes (because alwaysHighlight in XPConfig is True)-    nextCompletion :: t -> String -> [String] -> String-    nextCompletion = getNextOfLastWord--    -- | This method is used to generate the string to be passed to-    -- the completion function.-    -- This function is not used when in multiple modes (because alwaysHighlight in XPConfig is True)-    commandToComplete :: t -> String -> String-    commandToComplete _ = getLastWord--    -- | This method is used to process each completion in order to-    -- generate the string that will be compared with the command-    -- presently displayed in the command line. If the prompt is using-    -- 'getNextOfLastWord' for implementing 'nextCompletion' (the-    -- default implementation), this method is also used to generate,-    -- from the returned completion, the string that will form the-    -- next command line when tab is pressed.-    completionToCommand :: t -> String -> String-    completionToCommand _ c = c--    -- | When the prompt has multiple modes, this is the function-    -- used to generate the autocompletion list.-    -- The argument passed to this function is given by `commandToComplete`-    -- The default implementation shows an error message.-    completionFunction :: t -> ComplFunction-    completionFunction t = \_ -> return ["Completions for " ++ (showXPrompt t) ++ " could not be loaded"]--    -- | When the prompt has multiple modes (created with mkXPromptWithModes), this function is called-    -- when the user picks an item from the autocompletion list.-    -- The first argument is the prompt (or mode) on which the item was picked-    -- The first string argument is the autocompleted item's text.-    -- The second string argument is the query made by the user (written in the prompt's buffer).-    -- See XMonad/Actions/Launcher.hs for a usage example.-    modeAction :: t -> String -> String -> X ()-    modeAction _ _ _ = return ()--data XPPosition = Top-                | Bottom-                  deriving (Show,Read)--amberXPConfig, defaultXPConfig, greenXPConfig :: XPConfig--defaultXPConfig =-    XPC { font              = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*"-        , bgColor           = "grey22"-        , fgColor           = "grey80"-        , fgHLight          = "black"-        , bgHLight          = "grey"-        , borderColor       = "white"-        , promptBorderWidth = 1-        , promptKeymap      = defaultXPKeymap-        , completionKey     = xK_Tab-        , changeModeKey     = xK_grave-        , position          = Bottom-        , height            = 18-        , historySize       = 256-        , historyFilter     = id-        , defaultText       = []-        , autoComplete      = Nothing-        , showCompletionOnTab = False-        , searchPredicate   = isPrefixOf-        , alwaysHighlight   = False-        }-greenXPConfig = defaultXPConfig { fgColor = "green", bgColor = "black", promptBorderWidth = 0 }-amberXPConfig = defaultXPConfig { fgColor = "#ca8f2d", bgColor = "black", 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-        }---- Returns the current XPType-currentXPMode :: XPState -> XPType-currentXPMode st = case operationMode st of-  XPMultipleModes modes -> W.focus modes-  XPSingleMode _ xptype -> xptype---- When in multiple modes, this function sets the next mode--- in the list of modes as active-setNextMode :: XPState -> XPState-setNextMode st = case operationMode st of-  XPMultipleModes modes -> case W.down modes of-    [] -> st -- there is no next mode, return same state-    (m:ms) -> let-      currentMode = W.focus modes-      in st { operationMode = XPMultipleModes W.Stack { W.up = [], W.focus = m, W.down = ms ++ [currentMode]}} --set next and move previous current mode to the of the stack-  _ -> st --nothing to do, the prompt's operation has only one mode---- Returns the highlighted item-highlightedItem :: XPState -> [String] -> Maybe String-highlightedItem st' completions = case complWinDim st' of-  Nothing -> Nothing -- when there isn't any compl win, we can't say how many cols,rows there are-  Just winDim ->-    let-      (_,_,_,_,xx,yy) = winDim-      complMatrix = splitInSubListsAt (length yy) (take (length xx * length yy) completions)-      (col_index,row_index) = (complIndex st')-    in case completions of-      [] -> Nothing-      _ -> Just $ complMatrix !! col_index !! row_index---- this would be much easier with functional references-command :: XPState -> String-command = W.focus . commandHistory--setCommand :: String -> XPState -> XPState-setCommand xs s = s { commandHistory = (commandHistory s) { W.focus = xs }}--setHighlightedCompl :: Maybe String -> XPState -> XPState-setHighlightedCompl hc st = st { highlightedCompl = hc}---- | Sets the input string to the given value.-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.-getInput :: XP String-getInput = gets command---- | 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@---   is yielded if the user cancels the prompt (by e.g. hitting Esc or---   Ctrl-G).  For an example of use, see the 'XMonad.Prompt.Input'---   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 "" $ highlightedCompl st'-    Just <$> action selectedCompletion-    else return Nothing---- | Creates a prompt given:------ * a prompt type, instance of the 'XPrompt' class.------ * a prompt configuration ('defaultXPConfig' can be used as a--- starting point)------ * a completion function ('mkComplFunFromList' can be used to--- create a completions function given a list of possible completions)------ * an action to be run: the action must take a string and return 'XMonad.X' ()-mkXPrompt :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()-mkXPrompt t conf compl action = mkXPromptWithReturn t conf compl action >> return ()---- | Creates a prompt with multiple modes given:------ * A non-empty list of modes--- * A prompt configuration------ The created prompt allows to switch between modes with `changeModeKey` in `conf`. The modes are--- instances of XPrompt. See XMonad.Actions.Launcher for more details------ The argument supplied to the action to execute is always the current highlighted item,--- that means that this prompt overrides the value `alwaysHighlight` for its configuration to True.-mkXPromptWithModes :: [XPType] -> XPConfig -> X ()-mkXPromptWithModes modes conf = 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-    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--  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-      (\xs ys -> prune . historyFilter conf $ xs ++ ys)-      (showXPrompt defaultMode)-      (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)---- | Removes numlock and capslock from a keymask.--- Duplicate of cleanMask from core, but in the--- XP monad instead of X.-cleanMask :: KeyMask -> XP KeyMask-cleanMask msk = do-  numlock <- gets numlockMask-  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-  when (length c > 1) $ modify (\s -> s { showComplWin = True })-  if complKey == sym-     then completionHandle c ks e-     else if (sym == chgModeKey) then-           do-             modify setNextMode-             updateWindows-          else when (t == keyPress) $ keyPressHandle m ks-handle _ (ExposeEvent {ev_window = w}) = do-  st <- get-  when (win st == w) updateWindows-handle _  _ = return ()---- 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-  case () of-    () | t == keyPress && sym == complKey ->-          do-            st <- get-            let updateState l = case alwaysHlight of-                  -- modify the buffer's value-                  False -> let newCommand = nextCompletion (currentXPMode st) (command st) l-                           in modify $ \s -> setCommand newCommand $ s { offset = length newCommand, highlightedCompl = Just newCommand}-                  --TODO: Scroll or paginate results-                  True -> let complIndex' = nextComplIndex st (length l)-                              highlightedCompl' = highlightedItem st { complIndex = complIndex'} c-                          in modify $ \s -> setHighlightedCompl highlightedCompl' $ s { complIndex = complIndex' }-                updateWins l = redrawWindows l >> eventLoop (completionHandle l)-            case c of-              []  -> updateWindows   >> eventLoop handle-              [x] -> updateState [x] >> getCompletions >>= updateWins-              l   -> updateState l   >> updateWins l-      | t == keyRelease && sym == complKey -> eventLoop (completionHandle c)-      | otherwise -> keyPressHandle m ks -- some other key, handle it normally--- some other event: go back to main loop-completionHandle _ k e = handle k e----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)-    (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-           (currentcol, currentrow + 1)-         else-           (0,0)-       else if(currentrow + 1 < nrows) then --hlight not at the last row-              (currentcol, currentrow + 1)-            else-              (currentcol + 1, 0)--tryAutoComplete :: XP Bool-tryAutoComplete = do-    ac <- gets (autoComplete . config)-    case ac of-        Just d -> do cs <- getCompletions-                     case cs of-                         [c] -> runCompleted c d >> return True-                         _   -> return False-        Nothing    -> return False-  where runCompleted cmd delay = do-            st <- get-            let new_command = nextCompletion (currentXPMode st) (command st) [cmd]-            modify $ setCommand "autocompleting..."-            updateWindows-            io $ threadDelay delay-            modify $ setCommand new_command-            return True---- KeyPresses---- | Default key bindings for prompts.  Click on the \"Source\" link---   to the right to see the complete list.  See also 'defaultXPKeymap''.-defaultXPKeymap :: M.Map (KeyMask,KeySym) (XP ())-defaultXPKeymap = defaultXPKeymap' isSpace---- | A variant of 'defaultXPKeymap' which lets you specify a custom---   predicate for identifying non-word characters, which affects all---   the word-oriented commands (move\/kill word).  The default is---   'isSpace'.  For example, by default a path like @foo\/bar\/baz@---   would be considered as a single word.  You could use a predicate---   like @(\\c -> isSpace c || c == \'\/\')@ to move through or---   delete components of the path one at a time.-defaultXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ())-defaultXPKeymap' p = M.fromList $-  map (first $ (,) controlMask) -- control + <key>-  [ (xK_u, killBefore)-  , (xK_k, killAfter)-  , (xK_a, startOfLine)-  , (xK_e, endOfLine)-  , (xK_y, pasteString)-  , (xK_Right, moveWord' p Next)-  , (xK_Left, moveWord' p Prev)-  , (xK_Delete, killWord' p Next)-  , (xK_BackSpace, killWord' p Prev)-  , (xK_w, killWord' p Prev)-  , (xK_g, quit)-  , (xK_bracketleft, quit)-  ] ++-  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, quit)-  ]---- | A keymap with many emacs-like key bindings.  Click on the---   \"Source\" link to the right to see the complete list.---   See also 'emacsLikeXPKeymap''.-emacsLikeXPKeymap :: M.Map (KeyMask,KeySym) (XP ())-emacsLikeXPKeymap = emacsLikeXPKeymap' isSpace---- | A variant of 'emacsLikeXPKeymap' which lets you specify a custom---   predicate for identifying non-word characters, which affects all---   the word-oriented commands (move\/kill word).  The default is---   'isSpace'.  For example, by default a path like @foo\/bar\/baz@---   would be considered as a single word.  You could use a predicate---   like @(\\c -> isSpace c || c == \'\/\')@ to move through or---   delete components of the path one at a time.-emacsLikeXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ())-emacsLikeXPKeymap' p = M.fromList $-  map (first $ (,) controlMask) -- control + <key>-  [ (xK_z, killBefore) --kill line backwards-  , (xK_k, killAfter) -- kill line fowards-  , (xK_a, startOfLine) --move to the beginning of the line-  , (xK_e, endOfLine) -- move to the end of the line-  , (xK_d, deleteString Next) -- delete a character foward-  , (xK_b, moveCursor Prev) -- move cursor forward-  , (xK_f, moveCursor Next) -- move cursor backward-  , (xK_BackSpace, killWord' p Prev) -- kill the previous word-  , (xK_y, pasteString)-  , (xK_g, quit)-  , (xK_bracketleft, quit)-  ] ++-  map (first $ (,) mod1Mask) -- meta key + <key>-  [ (xK_BackSpace, killWord' p Prev)-  , (xK_f, moveWord' p Next) -- move a word forward-  , (xK_b, 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')-  ]-  ++-  map (first $ (,) 0) -- <key>-  [ (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, quit)-  ]--keyPressHandle :: KeyMask -> KeyStroke -> XP ()-keyPressHandle m (ks,str) = do-  km <- gets (promptKeymap . config)-  kmask <- cleanMask m -- mask is defined in ghc7-  case M.lookup (kmask,ks) km of-    Just action -> action >> updateWindows-    Nothing -> case str of-                 "" -> eventLoop handle-                 _ -> when (kmask .&. 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--setSuccess :: Bool -> XP ()-setSuccess b = modify $ \s -> s { successful = b }--setDone :: Bool -> XP ()-setDone b = modify $ \s -> s { done = b }---- KeyPress and State---- | Quit.-quit :: XP ()-quit = flushString >> setSuccess False >> setDone True---- | Kill the portion of the command before the cursor-killBefore :: XP ()-killBefore =-  modify $ \s -> setCommand (drop (offset s) (command s)) $ s { offset  = 0 }---- | Kill the portion of the command including and after the cursor-killAfter :: XP ()-killAfter =-  modify $ \s -> setCommand (take (offset s) (command s)) s---- | Kill the next\/previous word, using 'isSpace' as the default---   predicate for non-word characters.  See 'killWord''.-killWord :: Direction1D -> XP ()-killWord = killWord' isSpace---- | Kill the next\/previous word, given a predicate to identify---   non-word characters. First delete any consecutive non-word---   characters; then delete consecutive word characters, stopping---   just before the next non-word character.------   For example, by default (using 'killWord') a path like---   @foo\/bar\/baz@ would be deleted in its entirety.  Instead you can---   use something like @killWord' (\\c -> isSpace c || c == \'\/\')@ to---   delete the path one component at a time.-killWord' :: (Char -> Bool) -> Direction1D -> XP ()-killWord' p d = do-  o <- gets offset-  c <- gets command-  let (f,ss)        = splitAt o c-      delNextWord   = snd . break p . dropWhile p-      delPrevWord   = reverse . delNextWord . reverse-      (ncom,noff)   =-          case d of-            Next -> (f ++ delNextWord ss, o)-            Prev -> (delPrevWord f ++ ss, length $ delPrevWord f) -- laziness!!-  modify $ \s -> setCommand ncom $ s { offset = noff}---- | Put the cursor at the end of line-endOfLine :: XP ()-endOfLine  =-    modify $ \s -> s { offset = length (command s)}---- | Put the cursor at the start of line-startOfLine :: XP ()-startOfLine  =-    modify $ \s -> s { offset = 0 }---- |  Flush the command string and reset the offset-flushString :: XP ()-flushString = modify $ \s -> setCommand "" $ s { offset = 0}----reset index if config has `alwaysHighlight`. The inserted char could imply fewer autocompletions.---If the current index was column 2, row 1 and now there are only 4 autocompletion rows with 1 column, what should we highlight? Set it to the first and start navigation again-resetComplIndex :: XPState -> XPState-resetComplIndex st = if (alwaysHighlight $ config st) then st { complIndex = (0,0) } else st---- | Insert a character at the cursor position-insertString :: String -> XP ()-insertString str =-  modify $ \s -> let-    cmd = (c (command s) (offset s))-    st = resetComplIndex $ s { offset = o (offset s)}-    in setCommand cmd st-  where o oo = oo + length str-        c oc oo | oo >= length oc = oc ++ str-                | otherwise = f ++ str ++ ss-                where (f,ss) = splitAt oo oc---- | Insert the current X selection string at the cursor position.-pasteString :: XP ()-pasteString = join $ io $ liftM insertString getSelection---- | Remove a character at the cursor position-deleteString :: Direction1D -> XP ()-deleteString d =-  modify $ \s -> setCommand (c (command s) (offset s)) $ s { offset = o (offset s)}-  where o oo = if d == Prev then max 0 (oo - 1) else oo-        c oc oo-            | oo >= length oc && d == Prev = take (oo - 1) oc-            | oo <  length oc && d == Prev = take (oo - 1) f ++ ss-            | oo <  length oc && d == Next = f ++ tail ss-            | otherwise = oc-            where (f,ss) = splitAt oo oc---- | 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 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.-moveWord' :: (Char -> Bool) -> Direction1D -> XP ()-moveWord' p d = do-  c <- gets command-  o <- gets offset-  let (f,ss) = splitAt o c-      len = uncurry (+)-          . (length *** (length . fst . break p))-          . break (not . p)-      newoff = case d of-                 Prev -> o - len (reverse f)-                 Next -> o + len ss-  modify $ \s -> s { offset = newoff }--moveHistory :: (W.Stack String -> W.Stack String) -> XP ()-moveHistory f = modify $ \s -> let ch = f $ commandHistory s-                               in s { commandHistory = ch-                                    , offset         = length $ W.focus ch }--updateHighlightedCompl :: XP ()-updateHighlightedCompl = do-  st <- get-  cs <- getCompletions-  alwaysHighlight' <- gets $ alwaysHighlight . config-  when (alwaysHighlight') $ modify $ \s -> s {highlightedCompl = highlightedItem st cs}---- X Stuff--updateWindows :: XP ()-updateWindows = do-  d <- gets dpy-  drawWin-  c <- getCompletions-  case c  of-    [] -> destroyComplWin >> return ()-    l  -> redrawComplWin l-  io $ sync d False--redrawWindows :: [String] -> XP ()-redrawWindows c = do-  d <- gets dpy-  drawWin-  case c of-    [] -> return ()-    l  -> redrawComplWin l-  io $ sync d False--createWin :: Display -> Window -> XPConfig -> Rectangle -> IO Window-createWin d rw c s = do-  let (x,y) = case position c of-                Top -> (0,0)-                Bottom -> (0, rect_height s - height c)-  w <- mkUnmanagedWindow d (defaultScreenOfDisplay d) rw-                      (rect_x s + x) (rect_y s + fi y) (rect_width s) (height c)-  mapWindow d w-  return w--drawWin :: XP ()-drawWin = do-  st <- get-  let (c,(d,(w,gc))) = (config &&& dpy &&& win &&& gcon) st-      scr = defaultScreenOfDisplay d-      wh = widthOfScreen scr-      ht = height c-      bw = promptBorderWidth c-  Just bgcolor <- io $ initColor d (bgColor c)-  Just border  <- io $ initColor d (borderColor c)-  p <- io $ createPixmap d w wh ht-                         (defaultDepthOfScreen scr)-  io $ fillDrawable d p gc border bgcolor (fi bw) wh ht-  printPrompt p-  io $ copyArea d p w gc 0 0 wh ht 0 0-  io $ freePixmap d p--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-      str = prt ++ com-      -- break the string in 3 parts: till the cursor, the cursor and the rest-      (f,p,ss) = if off >= length com-                 then (str, " ","") -- add a space: it will be our cursor ;-)-                 else let (a,b) = (splitAt off com)-                      in (prt ++ a, [head b], tail b)-      ht = height c-  fsl <- io $ textWidthXMF (dpy st) fs f-  psl <- io $ textWidthXMF (dpy st) fs p-  (asc,desc) <- io $ textExtentsXMF fs str-  let y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc-      x = (asc + desc) `div` 2--  let draw = printStringXMF d drw fs gc-  -- print the first part-  draw (fgColor c) (bgColor c) x y f-  -- reverse the colors and print the "cursor" ;-)-  draw (bgColor c) (fgColor c) (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---- get the current completion function depending on the active mode-getCompletionFunction :: XPState -> ComplFunction-getCompletionFunction st = case operationMode st of-  XPSingleMode compl _ -> compl-  XPMultipleModes modes -> completionFunction $ W.focus modes---- Completions-getCompletions :: XP [String]-getCompletions = do-  s <- get-  io $ getCompletionFunction s (commandToComplete (currentXPMode s) (command s))-       `E.catch` \(SomeException _) -> return []--setComplWin :: Window -> ComplWindowDim -> XP ()-setComplWin w wi =-  modify (\s -> s { complWin = Just w, complWinDim = Just wi })--destroyComplWin :: XP ()-destroyComplWin = do-  d  <- gets dpy-  cw <- gets complWin-  case cw of-    Just w -> do io $ destroyWindow d w-                 modify (\s -> s { complWin = Nothing, complWinDim = Nothing })-    Nothing -> return ()--type ComplWindowDim = (Position,Position,Dimension,Dimension,Columns,Rows)-type Rows = [Position]-type Columns = [Position]--createComplWin :: ComplWindowDim -> XP Window-createComplWin wi@(x,y,wh,ht,_,_) = do-  st <- get-  let d = dpy st-      scr = defaultScreenOfDisplay d-  w <- io $ mkUnmanagedWindow d scr (rootw st)-                      x y wh ht-  io $ mapWindow d w-  setComplWin w wi-  return w--getComplWinDim :: [String] -> XP ComplWindowDim-getComplWinDim compl = do-  st <- get-  let (c,(scr,fs)) = (config &&& screen &&& fontS) st-      wh = rect_width scr-      ht = height c--  tws <- mapM (textWidthXMF (dpy st) fs) compl-  let max_compl_len =  fromIntegral ((fi ht `div` 2) + maximum tws)-      columns = max 1 $ wh `div` fi max_compl_len-      rem_height =  rect_height scr - ht-      (rows,r) = length compl `divMod` fi columns-      needed_rows = max 1 (rows + if r == 0 then 0 else 1)-      actual_max_number_of_rows = rem_height `div` ht-      actual_rows = min actual_max_number_of_rows (fi needed_rows)-      actual_height = actual_rows * ht-      (x,y) = case position c of-                Top -> (0,ht)-                Bottom -> (0, (0 + rem_height - actual_height))-  (asc,desc) <- io $ textExtentsXMF fs $ head compl-  let yp = fi $ (ht + fi (asc - desc)) `div` 2-      xp = (asc + desc) `div` 2-      yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..]-      xx = take (fi columns) [xp,(xp + max_compl_len)..]--  return (rect_x scr + x, rect_y scr + fi y, wh, actual_height, xx, yy)--drawComplWin :: Window -> [String] -> XP ()-drawComplWin w compl = do-  st <- get-  let c   = config 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)--  (_,_,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-  let ac = splitInSubListsAt (length yy) (take (length xx * length yy) compl)--  printComplList d p gc (fgColor c) (bgColor c) 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--redrawComplWin ::  [String] -> XP ()-redrawComplWin compl = do-  st <- get-  nwi <- getComplWinDim compl-  let recreate = do destroyComplWin-                    w <- createComplWin nwi-                    drawComplWin w compl-  if compl /= [] && showComplWin st-     then case complWin st of-            Just w -> case complWinDim st of-                        Just wi -> if nwi == wi -- complWinDim did not change-                                   then drawComplWin w compl -- so update-                                   else recreate-                        Nothing -> recreate-            Nothing -> recreate-     else destroyComplWin---- Finds the column and row indexes in which a string appears.--- if the string is not in the matrix, the indexes default to (0,0)-findComplIndex :: String -> [[String]] -> (Int,Int)-findComplIndex x xss = let-  colIndex = fromMaybe 0 $ findIndex (\cols -> x `elem` cols) xss-  rowIndex = fromMaybe 0 $ elemIndex x $ (!!) xss colIndex-  in (colIndex,rowIndex)--printComplList :: Display -> Drawable -> GC -> String -> String-               -> [Position] -> [Position] -> [[String]] -> XP ()-printComplList d drw gc fc bc xs ys sss =-    zipWithM_ (\x ss ->-        zipWithM_ (\y item -> do-            st <- get-            alwaysHlight <- gets $ alwaysHighlight . config-            let (f,b) = case alwaysHlight of-                  True -> -- default to the first item, the one in (0,0)-                    let-                      (colIndex,rowIndex) = findComplIndex item sss-                    in -- assign some colors-                     if ((complIndex st) == (colIndex,rowIndex)) then (fgHLight $ config st,bgHLight $ config 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)-                    else (fc,bc)-            printStringXMF d drw (fontS st) gc f b x y item)-        ys ss) xs sss---- History--type History = M.Map String [String]--emptyHistory :: History-emptyHistory = M.empty--getHistoryFile :: IO FilePath-getHistoryFile = fmap (++ "/history") $ getAppUserDataDirectory "xmonad"--readHistory :: IO History-readHistory = readHist `E.catch` \(SomeException _) -> return emptyHistory- where-    readHist = do-        path <- getHistoryFile-        xs <- bracket (openFile path ReadMode) hClose hGetLine-        readIO xs--writeHistory :: History -> IO ()-writeHistory hist = do-  path <- getHistoryFile-  let filtered = M.filter (not . null) hist-  writeFile path (show filtered) `E.catch` \(SomeException e) ->-                          hPutStrLn stderr ("error writing history: "++show e)-  setFileMode path mode-    where mode = ownerReadMode .|. ownerWriteMode---- $xutils---- | 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-  -- we start with the border-  setForeground d gc border-  fillRectangle d drw gc 0 0 wh ht-  -- here foreground means the background of the text-  setForeground d gc bgcolor-  fillRectangle d drw gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2))---- | Creates a window with the attribute override_redirect set to True.--- Windows Managers should not touch this kind of windows.-mkUnmanagedWindow :: Display -> Screen -> Window -> Position-                  -> Position -> Dimension -> Dimension -> IO Window-mkUnmanagedWindow d s rw x y w h = do-  let visual = defaultVisualOfScreen s-      attrmask = cWOverrideRedirect-  allocaSetWindowAttributes $-         \attributes -> do-           set_override_redirect attributes True-           createWindow d rw x y w h 0 (defaultDepthOfScreen s)-                        inputOutput visual attrmask attributes---- $utils---- | This function takes a list of possible completions and returns a--- completions function to be used with 'mkXPrompt'-mkComplFunFromList :: [String] -> String -> IO [String]-mkComplFunFromList _ [] = return []-mkComplFunFromList l s =-  return $ filter (\x -> take (length s) x == s) l---- | This function takes a list of possible completions and returns a--- completions function to be used with 'mkXPrompt'. If the string is--- null it will return all completions.-mkComplFunFromList' :: [String] -> String -> IO [String]-mkComplFunFromList' l [] = return l-mkComplFunFromList' l s =-  return $ filter (\x -> take (length s) x == s) l----- | Given the prompt type, the command line and the completion list,--- return the next completion in the list for the last word of the--- command line. This is the default 'nextCompletion' implementation.-getNextOfLastWord :: XPrompt t => t -> String -> [String] -> String-getNextOfLastWord t c l = skipLastWord c ++ completionToCommand t (l !! ni)-    where ni = case commandToComplete t c `elemIndex` map (completionToCommand t) l of-                 Just i -> if i >= length l - 1 then 0 else i + 1-                 Nothing -> 0---- | An alternative 'nextCompletion' implementation: given a command--- and a completion list, get the next completion in the list matching--- the whole command line.-getNextCompletion :: String -> [String] -> String-getNextCompletion c l = l !! idx-    where idx = case c `elemIndex` l of-                  Just i  -> if i >= length l - 1 then 0 else i + 1-                  Nothing -> 0---- | Given a maximum length, splits a list into sublists-splitInSubListsAt :: Int -> [a] -> [[a]]-splitInSubListsAt _ [] = []-splitInSubListsAt i x = f : splitInSubListsAt i rest-    where (f,rest) = splitAt i x---- | Gets the last word of a string or the whole string if formed by--- only one word-getLastWord :: String -> String-getLastWord = reverse . fst . breakAtSpace . reverse---- | Skips the last word of the string, if the string is composed by--- more then one word. Otherwise returns the string.-skipLastWord :: String -> String-skipLastWord = reverse . snd . breakAtSpace . reverse--breakAtSpace :: String -> (String, String)-breakAtSpace s-    | " \\" `isPrefixOf` s2 = (s1 ++ " " ++ s1', s2')-    | otherwise = (s1, s2)-      where (s1, s2 ) = break isSpace s-            (s1',s2') = breakAtSpace $ tail s2---- | 'historyCompletion' provides a canned completion function much like---   'getShellCompl'; you pass it to mkXPrompt, and it will make completions work---   from the query history stored in ~\/.xmonad\/history.-historyCompletion :: ComplFunction-historyCompletion = historyCompletionP (const True)---- | Like 'historyCompletion' but only uses history data from Prompts whose--- 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 (++) []---- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off---   laziness and stability for efficiency.-uniqSort :: Ord a => [a] -> [a]-uniqSort = toList . fromList---- | Functions to be used with the 'historyFilter' setting.--- 'deleteAllDuplicates' will remove all duplicate entries.--- 'deleteConsecutive' will only remove duplicate elements--- immediately next to each other.-deleteAllDuplicates, deleteConsecutive :: [String] -> [String]-deleteAllDuplicates = nub-deleteConsecutive = map head . group--newtype HistoryMatches = HistoryMatches (IORef ([String],Maybe (W.Stack String)))---- | Initializes a new HistoryMatches structure to be passed--- to historyUpMatching-initMatches :: (Functor m, MonadIO m) => m HistoryMatches-initMatches = HistoryMatches <$> liftIO (newIORef ([],Nothing))--historyNextMatching :: HistoryMatches -> (W.Stack String -> W.Stack String) -> XP ()-historyNextMatching hm@(HistoryMatches ref) next = do-  (completed,completions) <- io $ readIORef ref-  input <- getInput-  if input `elem` completed-     then case completions of-            Just cs -> do-                let cmd = W.focus cs-                modify $ setCommand cmd-                modify $ \s -> s { offset = length cmd }-                io $ writeIORef ref (cmd:completed,Just $ next cs)-            Nothing -> return ()-     else do -- the user typed something new, recompute completions-       io . writeIORef ref . ((,) [input]) . filterMatching input =<< gets commandHistory-       historyNextMatching hm next-    where filterMatching :: String -> W.Stack String -> Maybe (W.Stack String)-          filterMatching prefix = W.filter (prefix `isPrefixOf`) . next---- | Retrieve the next history element that starts with--- the current input. Pass it the result of initMatches--- when creating the prompt. Example:------ > ..--- > ((modMask,xK_p), shellPrompt . myPrompt =<< initMatches)--- > ..--- > myPrompt ref = defaultPrompt--- >   { promptKeymap = M.union [((0,xK_Up), historyUpMatching ref)--- >                            ,((0,xK_Down), historyDownMatching ref)]--- >                            (promptKeymap defaultPrompt)+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Prompt+-- Copyright   :  (C) 2007 Andrea Rossato, 2015 Evgeny Kurnevsky+--                    2015 Sibi Prabakaran, 2018 Yclept Nemo+-- License     :  BSD3+--+-- Maintainer  :  Spencer Janssen <spencerjanssen@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- A module for writing graphical prompts for XMonad+--+-----------------------------------------------------------------------------++-----------------------------------------------------------------------------+-- 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+      mkXPrompt+    , mkXPromptWithReturn+    , mkXPromptWithModes+    , def+    , amberXPConfig+    , greenXPConfig+    , XPMode+    , XPType (..)+    , XPColor (..)+    , XPPosition (..)+    , XPConfig (..)+    , XPrompt (..)+    , XP+    , defaultXPKeymap, defaultXPKeymap'+    , emacsLikeXPKeymap, emacsLikeXPKeymap'+    , vimLikeXPKeymap, vimLikeXPKeymap'+    , quit+    , promptSubmap, promptBuffer, toHeadChar, bufferOne+    , killBefore, killAfter, startOfLine, endOfLine+    , insertString, pasteString, pasteString'+    , clipCursor, moveCursor, moveCursorClip+    , setInput, getInput, getOffset+    , defaultColor, modifyColor, setColor+    , resetColor, setBorderColor+    , modifyPrompter, setPrompter, resetPrompter+    , selectedCompletion, setCurrentCompletions, getCurrentCompletions+    , moveWord, moveWord', killWord, killWord'+    , changeWord, deleteString+    , moveHistory, setSuccess, setDone, setModeDone+    , Direction1D(..)+    , ComplFunction+    , ComplCaseSensitivity(..)+    -- * X Utilities+    -- $xutils+    , mkUnmanagedWindow+    , fillDrawable+    -- * Other Utilities+    -- $utils+    , mkComplFunFromList+    , mkComplFunFromList'+    -- * @nextCompletion@ implementations+    , getNextOfLastWord+    , getNextCompletion+    -- * List utilities+    , getLastWord+    , skipLastWord+    , splitInSubListsAt+    , breakAtSpace+    , uniqSort+    , historyCompletion+    , historyCompletionP+    -- * History filters+    , deleteAllDuplicates+    , deleteConsecutive+    , HistoryMatches+    , initMatches+    , historyUpMatching+    , historyDownMatching+    -- * Types+    , XPState+    ) where++import           XMonad                       hiding (cleanMask, config)+import           XMonad.Prelude               hiding (toList, fromList)+import qualified XMonad.StackSet              as W+import           XMonad.Util.Font+import           XMonad.Util.Types+import           XMonad.Util.XSelection       (getSelection)++import           Codec.Binary.UTF8.String     (decodeString,isUTF8Encoded)+import           Control.Arrow                (first, (&&&), (***))+import           Control.Concurrent           (threadDelay)+import           Control.Exception            as E hiding (handle)+import           Control.Monad.State+import           Data.Bifunctor               (bimap)+import           Data.Bits+import           Data.IORef+import qualified Data.List.NonEmpty           as NE+import qualified Data.Map                     as M+import           Data.Set                     (fromList, toList)+import           System.IO+import           System.IO.Unsafe             (unsafePerformIO)+import           System.Posix.Files+import Data.List.NonEmpty (nonEmpty)++-- $usage+-- For usage examples see "XMonad.Prompt.Shell",+-- "XMonad.Prompt.XMonad" or "XMonad.Prompt.Ssh"+--+-- TODO:+--+-- * scrolling the completions that don't fit in the window (?)++type XP = StateT XPState IO++data XPState =+    XPS { dpy                   :: Display+        , rootw                 :: !Window+        , win                   :: !Window+        , screen                :: !Rectangle+        , winWidth              :: !Dimension -- ^ Width of the prompt window+        , complWinDim           :: Maybe ComplWindowDim+        , complIndex            :: !(Int,Int)+        , complWin              :: IORef (Maybe Window)+        -- ^ This is an 'IORef' to enable removal of the completion+        -- window if an exception occurs, since otherwise the most+        -- recent value of 'complWin' would not be available.+        , showComplWin          :: Bool+        , operationMode         :: XPOperationMode+        , highlightedCompl      :: Maybe String+        , gcon                  :: !GC+        , fontS                 :: !XMonadFont+        , commandHistory        :: W.Stack String+        , offset                :: !Int+        , config                :: XPConfig+        , successful            :: Bool+        , cleanMask             :: KeyMask -> 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+        , 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+        , height                :: !Dimension   -- ^ Window height+        , maxComplRows          :: Maybe Dimension+                                                -- ^ Just x: maximum number of rows to show in completion window+        , maxComplColumns       :: Maybe Dimension+                                                -- ^ Just x: maximum number of columns 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 to trigger forward completion+        , prevCompletionKey     :: (KeyMask, KeySym)     -- ^ Key to trigger backward 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+        , complCaseSensitivity  :: ComplCaseSensitivity+                                                -- ^ Perform completion in a case-sensitive manner+        , 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+type ComplFunction = String -> IO [String]+type XPMode = XPType+data XPOperationMode = XPSingleMode ComplFunction XPType | XPMultipleModes (W.Stack XPType)++data ComplCaseSensitivity = CaseSensitive | CaseInSensitive++instance Show XPType where+    show (XPT p) = showXPrompt p++instance XPrompt XPType where+    showXPrompt                 = show+    nextCompletion      (XPT t) = nextCompletion      t+    commandToComplete   (XPT t) = commandToComplete   t+    completionToCommand (XPT t) = completionToCommand t+    completionFunction  (XPT t) = completionFunction  t+    modeAction          (XPT t) = modeAction          t++-- | A class for an abstract prompt. In order for your data type to be a+-- valid prompt you _must_ make it an instance of this class.+--+-- The minimal complete definition is just 'showXPrompt', i.e. the name+-- of the prompt. This string will be displayed in the command line+-- window (before the cursor).+--+-- As an example of a complete 'XPrompt' instance definition, we can+-- look at the 'XMonad.Prompt.Shell.Shell' prompt from+-- "XMonad.Prompt.Shell":+--+-- >     data Shell = Shell+-- >+-- >     instance XPrompt Shell where+-- >          showXPrompt Shell = "Run: "+class XPrompt t where+    {-# MINIMAL showXPrompt #-}++    -- | This method is used to print the string to be+    -- displayed in the command line window.+    showXPrompt :: t -> String++    -- | This method is used to generate the next completion to be+    -- printed in the command line when tab is pressed, given the+    -- string presently in the command line and the list of+    -- completion.+    -- This function is not used when in multiple modes (because alwaysHighlight in XPConfig is True)+    nextCompletion :: t -> String -> [String] -> String+    nextCompletion = getNextOfLastWord++    -- | This method is used to generate the string to be passed to+    -- the completion function.+    commandToComplete :: t -> String -> String+    commandToComplete _ = getLastWord++    -- | This method is used to process each completion in order to+    -- generate the string that will be compared with the command+    -- presently displayed in the command line. If the prompt is using+    -- 'getNextOfLastWord' for implementing 'nextCompletion' (the+    -- default implementation), this method is also used to generate,+    -- from the returned completion, the string that will form the+    -- next command line when tab is pressed.+    completionToCommand :: t -> String -> String+    completionToCommand _ c = c++    -- | When the prompt has multiple modes, this is the function+    -- used to generate the autocompletion list.+    -- The argument passed to this function is given by `commandToComplete`+    -- The default implementation shows an error message.+    completionFunction :: t -> ComplFunction+    completionFunction t = const $ return ["Completions for " ++ showXPrompt t ++ " could not be loaded"]++    -- | When the prompt has multiple modes (created with mkXPromptWithModes), this function is called+    -- when the user picks an item from the autocompletion list.+    -- The first argument is the prompt (or mode) on which the item was picked+    -- The first string argument is the autocompleted item's text.+    -- The second string argument is the query made by the user (written in the prompt's buffer).+    -- See XMonad/Actions/Launcher.hs for a usage example.+    modeAction :: t -> String -> String -> X ()+    modeAction _ _ _ = return ()++data XPPosition = Top+                | Bottom+                -- | Prompt will be placed in the center horizontally and+                --   in the certain place of screen vertically. If it's in the upper+                --   part of the screen, completion window will be placed below (like+                --   in 'Top') and otherwise above (like in 'Bottom')+                | CenteredAt { xpCenterY :: Rational+                             -- ^ Rational between 0 and 1, giving+                             -- y coordinate of center of the prompt relative to the screen height.+                             , xpWidth  :: Rational+                             -- ^ Rational between 0 and 1, giving+                             -- width of the prompt relative to the screen width.+                             }+                  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, greenXPConfig :: XPConfig++instance Default XPColor where+    def =+        XPColor { bgNormal    = "grey22"+                , fgNormal    = "grey80"+                , bgHighlight = "grey"+                , fgHighlight = "black"+                , border      = "white"+                }++instance Default XPConfig where+  def =+#ifdef XFT+    XPC { font                  = "xft:monospace-12"+#else+    XPC { font                  = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*"+#endif+        , bgColor               = bgNormal def+        , fgColor               = fgNormal def+        , bgHLight              = bgHighlight def+        , fgHLight              = fgHighlight def+        , borderColor           = border def+        , promptBorderWidth     = 1+        , promptKeymap          = defaultXPKeymap+        , completionKey         = (0, xK_Tab)+        , prevCompletionKey     = (shiftMask, xK_Tab)+        , changeModeKey         = xK_grave+        , position              = Bottom+        , height                = 18+        , maxComplRows          = Nothing+        , maxComplColumns       = Nothing+        , historySize           = 256+        , historyFilter         = id+        , defaultText           = []+        , autoComplete          = Nothing+        , showCompletionOnTab   = False+        , complCaseSensitivity  = CaseSensitive+        , searchPredicate       = isPrefixOf+        , alwaysHighlight       = False+        , defaultPrompter       = id+        , sorter                = const id+        }+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 -> KeyMask)+          -> Dimension -> XPState+initState d rw w s opMode gc fonts h c cm width =+    XPS { dpy                   = d+        , rootw                 = rw+        , win                   = w+        , screen                = s+        , winWidth              = width+        , complWinDim           = Nothing+        , complWin              = 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+        , cleanMask             = cm+        , prompter              = defaultPrompter c+        , color                 = defaultColor c+        , eventBuffer           = []+        , inputBuffer           = ""+        , currentCompletions    = Nothing+        }++-- Returns the current XPType+currentXPMode :: XPState -> XPType+currentXPMode st = case operationMode st of+  XPMultipleModes modes -> W.focus modes+  XPSingleMode _ xptype -> xptype++-- When in multiple modes, this function sets the next mode+-- in the list of modes as active+setNextMode :: XPState -> XPState+setNextMode st = case operationMode st of+  XPMultipleModes modes -> case W.down modes of+    [] -> st -- there is no next mode, return same state+    (m:ms) -> let+      currentMode = W.focus modes+      in st { operationMode = XPMultipleModes W.Stack { W.up = [], W.focus = m, W.down = ms ++ [currentMode]}} --set next and move previous current mode to the of the stack+  _ -> st --nothing to do, the prompt's operation has only one mode++-- Returns the highlighted item+highlightedItem :: XPState -> [String] -> Maybe String+highlightedItem st' completions = case complWinDim st' of+  Nothing -> Nothing -- when there isn't any compl win, we can't say how many cols,rows there are+  Just winDim ->+    let+      ComplWindowDim{ cwCols, cwRows } = winDim+      complMatrix = chunksOf (length cwRows) (take (length cwCols * length cwRows) completions)+      (col_index,row_index) = complIndex st'+    in case completions of+      [] -> Nothing+      _  -> complMatrix !? col_index >>= (!? row_index)++-- | Return the selected completion, i.e. the 'String' we actually act+-- upon after the user confirmed their selection (by pressing @Enter@).+selectedCompletion :: XPState -> String+selectedCompletion st+    -- If 'alwaysHighlight' is used, look at the currently selected item (if any)+  | alwaysHighlight (config st) = fromMaybe (command st) $ highlightedCompl st+    -- Otherwise, look at what the user actually wrote so far+  | otherwise                   = command st++-- this would be much easier with functional references+command :: XPState -> String+command = W.focus . commandHistory++setCommand :: String -> XPState -> XPState+setCommand xs s = s { commandHistory = (commandHistory s) { W.focus = xs }}++-- | Sets the input string to the given value.+setInput :: String -> XP ()+setInput = modify . setCommand++-- | Returns the current input string. Intended for use in custom keymaps+-- 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@+--   is yielded if the user cancels the prompt (by e.g. hitting Esc or+--   Ctrl-G).  For an example of use, see the 'XMonad.Prompt.Input'+--   module.+mkXPromptWithReturn :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X a)  -> X (Maybe a)+mkXPromptWithReturn t conf compl action = do+  st' <- mkXPromptImplementation (showXPrompt t) conf (XPSingleMode compl (XPT t))+  if successful st'+    then Just <$> action (selectedCompletion st')+    else return Nothing++-- | Creates a prompt given:+--+-- * a prompt type, instance of the 'XPrompt' class.+--+-- * a prompt configuration ('def' can be used as a starting point)+--+-- * a completion function ('mkComplFunFromList' can be used to+-- create a completions function given a list of possible completions)+--+-- * an action to be run: the action must take a string and return 'XMonad.X' ()+mkXPrompt :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()+mkXPrompt t conf compl action = void $ mkXPromptWithReturn t conf compl action++-- | Creates a prompt with multiple modes given:+--+-- * A non-empty list of modes+-- * A prompt configuration+--+-- The created prompt allows to switch between modes with `changeModeKey` in `conf`. The modes are+-- instances of XPrompt. See XMonad.Actions.Launcher for more details+--+-- The argument supplied to the action to execute is always the current highlighted item,+-- that means that this prompt overrides the value `alwaysHighlight` for its configuration to True.+mkXPromptWithModes :: [XPType] -> XPConfig -> X ()+mkXPromptWithModes [] _ = pure ()+mkXPromptWithModes (defaultMode : modes) conf = do+  let modeStack = W.Stack { W.focus = defaultMode -- Current mode+                          , W.up = []+                          , W.down = modes -- Other modes+                          }+      om = XPMultipleModes modeStack+  st' <- mkXPromptImplementation (showXPrompt defaultMode) conf { alwaysHighlight = True } om+  when (successful st') $+    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++-- 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+  cleanMask <- cleanKeyMask+  cachedir <- asks (cacheDir . directories)+  hist <- io $ readHistory conf cachedir+  fs <- initXMF (font conf)+  let width = getWinWidth s (position conf)+  st' <- io $+    bracket+      (createPromptWin d rw conf s width)+      (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 cleanMask width+            runXP st))+  releaseXMF fs+  when (successful st') $ do+    let prune = take (historySize conf)+    io $ writeHistory conf cachedir $+      M.insertWith+      (\xs ys -> prune . historyFilter conf $ xs ++ ys)+      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 [selectedCompletion st'])+      hist+  return st'+ where+  -- | Based on the ultimate position of the prompt and the screen+  -- dimensions, calculate its width.+  getWinWidth :: Rectangle -> XPPosition -> Dimension+  getWinWidth scr = \case+    CenteredAt{ xpWidth } -> floor $ fi (rect_width scr) * xpWidth+    _                     -> rect_width scr++-- | 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++runXP :: XPState -> IO XPState+runXP st = do+  let d = dpy st+      w = win st+  bracket+    (grabKeyboard d w True grabModeAsync grabModeAsync currentTime)+    (\_ -> ungrabKeyboard d currentTime)+    (\status ->+      execStateT+        (when (status == grabSuccess) $ do+          ah <- gets (alwaysHighlight . config)+          when ah $ do+            compl <- listToMaybe <$> getCompletions+            modify' $ \xpst -> xpst{ highlightedCompl = compl }+          updateWindows+          eventLoop handleMain evDefaultStop)+        st+      `finally` (mapM_ (destroyWindow d) =<< readIORef (complWin st))+      `finally` sync d False)++type KeyStroke = (KeySym, String)++-- | Check whether the given key stroke is a modifier.+isModifier :: KeyStroke -> Bool+isModifier (_, keyString) = null keyString++-- | 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+                    -- Also capture @buttonPressMask@, see Note [Allow ButtonEvents]+                    maskEvent d (exposureMask .|. keyPressMask .|. buttonPressMask) e+                    ev <- getEvent e+                    if ev_event_type ev == keyPress+                        then do (_, s) <- lookupString $ asKeyEvent e+                                ks <- keycodeToKeysym d (ev_keycode ev) 0+                                return (ks, s, ev)+                        else return (noSymbol, "", ev)+        (l : ls) -> do+                modify $ \s -> s { eventBuffer = ls }+                return l+    handle (keysym,keystr) event+    stopAction >>= \stop -> unless stop (eventLoop handle stopAction)++-- | Default event loop stop condition.+evDefaultStop :: XP Bool+evDefaultStop = gets ((||) . modeDone) <*> gets done++-- | Common patterns shared by all event handlers.+handleOther :: KeyStroke -> Event -> XP ()+handleOther _ ExposeEvent{ev_window = w} = do+    -- Expose events can be triggered by switching virtual consoles.+    st <- get+    when (win st == w) updateWindows+handleOther _ ButtonEvent{ev_event_type = t} = do+    -- See Note [Allow ButtonEvents]+    when (t == buttonPress) $ do+        d <- gets dpy+        io $ allowEvents d replayPointer currentTime+handleOther _ _ = return ()++{- Note [Allow ButtonEvents]++Some settings (like @clickJustFocuses = False@) set up the passive+pointer grabs that xmonad makes to intercept clicks to unfocused windows+with @pointer_mode = grabModeSync@ and @keyboard_mode = grabModeSync@.+This means that any click in an unfocused window leads to a+pointer/keyboard grab that freezes both devices until 'allowEvents' is+called. But "XMonad.Prompt" has its own X event loop, so 'allowEvents'+is never called and everything remains frozen indefinitely.++This does not happen when the grabs are made with @grabModeAsync@, as+pointer events processing is not frozen and the grab only lasts as long+as the mouse button is pressed.++Hence, in this situation we call 'allowEvents' in the prompts event loop+whenever a button event is received, releasing the pointer grab. In this+case, 'replayPointer' takes care of the fact that these events are not+merely discarded, but passed to the respective application window.+-}++-- | Prompt event handler for the main loop. Dispatches to input, completion+-- and mode switching handlers.+handleMain :: KeyStroke -> Event -> XP ()+handleMain stroke@(keysym, keystr) = \case+    KeyEvent{ev_event_type = t, ev_state = m} -> do+      (prevCompKey, (compKey, modeKey)) <- gets $+          (prevCompletionKey &&& completionKey &&& changeModeKey) . config+      keymask <- gets cleanMask <*> pure m+      -- haven't subscribed to keyRelease, so just in case+      when (t == keyPress) $ if+          | (keymask, keysym) == compKey ->+               getCurrentCompletions >>= handleCompletionMain Next+          | (keymask, keysym) == prevCompKey ->+               getCurrentCompletions >>= handleCompletionMain Prev+          | otherwise -> do+               keymap <- gets (promptKeymap . config)+               let mbAction = M.lookup (keymask, keysym) keymap+               -- Either run when we can insert a valid character, or the+               -- pressed key has an action associated to it.+               unless (isModifier stroke && isNothing mbAction) $ do+                   setCurrentCompletions Nothing+                   if keysym == modeKey+                      then modify setNextMode >> updateWindows+                      else handleInput keymask mbAction+    event -> handleOther stroke event+  where+    -- Prompt input handler for the main loop.+    handleInput :: KeyMask -> Maybe (XP ()) -> XP ()+    handleInput keymask = \case+        Just action -> action >> updateWindows+        Nothing     -> when (keymask .&. controlMask == 0) $ do+            insertString $ utf8Decode keystr+            updateWindows+            updateHighlightedCompl+            complete <- tryAutoComplete+            when complete acceptSelection++-- 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 :: Direction1D -> Maybe [String] -> XP ()+handleCompletionMain dir compls = case compls of+   Just cs -> handleCompletion dir cs+   Nothing -> do+       cs <- getCompletions+       when (length cs > 1) $+           modify $ \s -> s { showComplWin = True }+       setCurrentCompletions $ Just cs+       handleCompletion dir cs++handleCompletion :: Direction1D -> [String] -> XP ()+handleCompletion dir cs = do+    alwaysHlight <- gets $ alwaysHighlight . config+    st <- get++    let updateWins    = redrawWindows (pure ())+        updateState l = if alwaysHlight+            then hlComplete (getLastWord $ command st) l st+            else simpleComplete                        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 the user wants the next+        -- completion, move to the next completion item and update the+        -- buffer to reflect that.+        --+        --TODO: Scroll or paginate results+        hlComplete :: String -> [String] -> XPState -> XP ()+        hlComplete prevCompl l st+          | -- The current suggestion matches the command and is a+            -- proper suffix of the last suggestion, so replace it.+            isSuffixOfCmd && isProperSuffixOfLast = replaceCompletion prevCompl++          | -- We only have one suggestion, so we need to be a little+            -- bit smart in order to avoid a loop.+            Just (ch :| []) <- nonEmpty cs =+              if command st == hlCompl+              then put st+              else replaceCompletion ch++            -- The current suggestion matches the command, so advance+            -- to the next completion and try again.+          | isSuffixOfCmd =+              hlComplete hlCompl l $ st{ complIndex = complIndex'+                                       , highlightedCompl = nextHlCompl+                                       }++            -- If nothing matches at all, delete the suggestion and+            -- highlight the next one.+          | otherwise = replaceCompletion prevCompl+         where+          hlCompl     :: String       = fromMaybe (command st) $ highlightedItem st l+          complIndex' :: (Int, Int)   = computeComplIndex dir st+          nextHlCompl :: Maybe String = highlightedItem st{ complIndex = complIndex' } cs++          isSuffixOfCmd        :: Bool = hlCompl `isSuffixOf` command st+          isProperSuffixOfLast :: Bool =      hlCompl   `isSuffixOf` prevCompl+                                      && not (prevCompl `isSuffixOf` hlCompl)++          replaceCompletion :: String -> XP () = \str -> do+              put st+              replicateM_ (length $ words str) $ killWord Prev+              insertString' hlCompl+              endOfLine++-- | 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 <- gets cleanMask <*> pure 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 stroke@(keysym, _) =+    case M.lookup (keymask,keysym) keymap of+        Just action -> action >> updateWindows+        Nothing     -> unless (isModifier stroke) $ 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 <- gets cleanMask <*> pure 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 stroke@(keysym, keystr) event =+    unless (isModifier stroke || 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)++-- | Return the @(column, row)@ of the desired highlight, or @(0, 0)@ if+-- there is no prompt window or a wrap-around occurs.+computeComplIndex :: Direction1D -> XPState -> (Int, Int)+computeComplIndex dir st = case complWinDim st of+  Nothing -> (0, 0)  -- no window dimensions (just destroyed or not created)+  Just ComplWindowDim{ cwCols, cwRows } ->+    if rowm == currentrow + direction+    then (currentcol, rowm)  -- We are not in the last row, so advance the row+    else (colm, rowm)        -- otherwise advance to the respective column+   where+    (currentcol, currentrow) = complIndex st+    (colm, rowm) =+      ( (currentcol + direction) `mod` length cwCols+      , (currentrow + direction) `mod` length cwRows+      )+    direction = case dir of+      Next ->  1+      Prev -> -1++tryAutoComplete :: XP Bool+tryAutoComplete = do+    ac <- gets (autoComplete . config)+    case ac of+        Just d -> do cs <- getCompletions+                     case cs of+                         [c] -> runCompleted c d >> return True+                         _   -> return False+        Nothing    -> return False+  where runCompleted cmd delay = do+            st <- get+            let new_command = nextCompletion (currentXPMode st) (command st) [cmd]+            modify $ setCommand "autocompleting..."+            updateWindows+            io $ threadDelay delay+            modify $ setCommand new_command+            return True++-- KeyPresses++-- | Default key bindings for prompts.  Click on the \"Source\" link+--   to the right to see the complete list.  See also 'defaultXPKeymap''.+defaultXPKeymap :: M.Map (KeyMask,KeySym) (XP ())+defaultXPKeymap = defaultXPKeymap' isSpace++-- | A variant of 'defaultXPKeymap' which lets you specify a custom+--   predicate for identifying non-word characters, which affects all+--   the word-oriented commands (move\/kill word).  The default is+--   'isSpace'.  For example, by default a path like @foo\/bar\/baz@+--   would be considered as a single word.  You could use a predicate+--   like @(\\c -> isSpace c || c == \'\/\')@ to move through or+--   delete components of the path one at a time.+defaultXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ())+defaultXPKeymap' p = M.fromList $+  map (first $ (,) controlMask) -- control + <key>+  [ (xK_u, killBefore)+  , (xK_k, killAfter)+  , (xK_a, startOfLine)+  , (xK_e, endOfLine)+  , (xK_y, pasteString)+  -- 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)+  , (xK_g, quit)+  , (xK_bracketleft, quit)+  ] +++  map (first $ (,) 0)+  [ (xK_Return, acceptSelection)+  , (xK_KP_Enter, acceptSelection)+  , (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, quit)+  ]++-- | A keymap with many emacs-like key bindings.  Click on the+--   \"Source\" link to the right to see the complete list.+--   See also 'emacsLikeXPKeymap''.+emacsLikeXPKeymap :: M.Map (KeyMask,KeySym) (XP ())+emacsLikeXPKeymap = emacsLikeXPKeymap' isSpace++-- | A variant of 'emacsLikeXPKeymap' which lets you specify a custom+--   predicate for identifying non-word characters, which affects all+--   the word-oriented commands (move\/kill word).  The default is+--   'isSpace'.  For example, by default a path like @foo\/bar\/baz@+--   would be considered as a single word.  You could use a predicate+--   like @(\\c -> isSpace c || c == \'\/\')@ to move through or+--   delete components of the path one at a time.+emacsLikeXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ())+emacsLikeXPKeymap' p = M.fromList $+  map (first $ (,) controlMask) -- control + <key>+  [ (xK_z, killBefore) --kill line backwards+  , (xK_k, killAfter) -- kill line fowards+  , (xK_a, startOfLine) --move to the beginning of the line+  , (xK_e, endOfLine) -- move to the end of the line+  , (xK_d, deleteString Next) -- delete a character foward+  , (xK_b, moveCursor Prev) -- move cursor forward+  , (xK_f, moveCursor Next) -- move cursor backward+  , (xK_BackSpace, killWord' p Prev) -- kill the previous word+  , (xK_y, pasteString)+  , (xK_g, quit)+  , (xK_bracketleft, quit)+  , (xK_t, transposeChars)+  , (xK_m, acceptSelection)+  ] +++  map (first $ (,) mod1Mask) -- meta key + <key>+  [ (xK_BackSpace, killWord' p Prev)+  -- 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')+  ]+  +++  map (first $ (,) 0) -- <key>+  [ (xK_Return, acceptSelection)+  , (xK_KP_Enter, acceptSelection)+  , (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, quit)+  ]++-- | 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 $ (,) controlMask) -- control + <key>+    [ (xK_m, acceptSelection)+    ] +++    map (first $ (,) 0)+    [ (xK_Return,       acceptSelection)+    , (xK_KP_Enter,     acceptSelection)+    , (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+          )+        , (xK_Return,       acceptSelection)+        , (xK_KP_Enter,     acceptSelection)+        ] +++        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 (bimap (0 ,) (>> 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 (bimap (shiftMask ,) (>> setModeDone True))+        [ (xK_dollar,       killAfter >> moveCursor Prev)+        ]+    changeVimXPKeymap = M.fromList $+        map (bimap (0 ,) (>> 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 (bimap (shiftMask, ) (>> 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++-- | Accept the current selection and exit.+acceptSelection :: StateT XPState IO ()+acceptSelection = setSuccess True >> setDone True++-- | Quit.+quit :: XP ()+quit = flushString >> setSuccess False >> setDone True >> setModeDone True++-- | Kill the portion of the command before the cursor+killBefore :: XP ()+killBefore =+  modify $ \s -> setCommand (drop (offset s) (command s)) $ s { offset  = 0 }++-- | Kill the portion of the command including and after the cursor+killAfter :: XP ()+killAfter =+  modify $ \s -> setCommand (take (offset s) (command s)) s++-- | Kill the next\/previous word, using 'isSpace' as the default+--   predicate for non-word characters.  See 'killWord''.+killWord :: Direction1D -> XP ()+killWord = killWord' isSpace++-- | Kill the next\/previous word, given a predicate to identify+--   non-word characters. First delete any consecutive non-word+--   characters; then delete consecutive word characters, stopping+--   just before the next non-word character.+--+--   For example, by default (using 'killWord') a path like+--   @foo\/bar\/baz@ would be deleted in its entirety.  Instead you can+--   use something like @killWord' (\\c -> isSpace c || c == \'\/\')@ to+--   delete the path one component at a time.+killWord' :: (Char -> Bool) -> Direction1D -> XP ()+killWord' p d = do+  o <- gets offset+  c <- gets command+  let (f,ss)        = splitAt o c+      delNextWord   = dropWhile (not . p) . dropWhile p+      delPrevWord   = reverse . delNextWord . reverse+      (ncom,noff)   =+          case d of+            Next -> (f ++ delNextWord ss, o)+            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 = join $ f <$> getInput <*> getOffset <*> pure p+    where+        f :: String -> Int -> (Char -> Bool) -> XP ()+        f str off _ | length str <= off ||+                      null str              = return ()+        f str off p'| p' $ str !! off       = killWord' (not . p') Next+                    | otherwise             = killWord' p' Next++-- | Interchange characters around point, moving forward one character+--   if not at the end of the input.+transposeChars :: XP ()+transposeChars = do+  off <- gets offset+  cmd <- gets command+  let (beforeCursor, afterCursor) = splitAt off cmd+      (ncom, noff) = fromMaybe (cmd, off) (go beforeCursor afterCursor off)+  modify $ \s -> setCommand ncom $ s{ offset = noff }+ where+  go :: [a] -> [a] -> Int -> Maybe ([a], Int)+  go (reverse -> (b1 : b2 : bs)) [] offset =  -- end of line+    Just (reverse $ b2 : b1 : bs, offset)+  go (reverse -> (b : bs)) (a : as) offset =  -- middle of line+    Just (reverse (a : bs) ++ b : as, offset + 1)+  go _ _ _ = Nothing++-- | Put the cursor at the end of line+endOfLine :: XP ()+endOfLine  =+    modify $ \s -> s { offset = length (command s)}++-- | Put the cursor at the start of line+startOfLine :: XP ()+startOfLine  =+    modify $ \s -> s { offset = 0 }++-- |  Flush the command string and reset the offset+flushString :: XP ()+flushString = modify $ \s -> setCommand "" $ s { offset = 0}++--reset index if config has `alwaysHighlight`. The inserted char could imply fewer autocompletions.+--If the current index was column 2, row 1 and now there are only 4 autocompletion rows with 1 column, what should we highlight? Set it to the first and start navigation again+resetComplIndex :: XPState -> XPState+resetComplIndex st = if alwaysHighlight (config st) then st { complIndex = (0,0) } else st++-- | Insert a character at the cursor position+insertString :: String -> XP ()+insertString str = do+  insertString' str+  modify resetComplIndex++insertString' :: String -> XP ()+insertString' str =+  modify $ \s -> let+    cmd = c (command s) (offset s)+    st = s { offset = o (offset s)}+    in setCommand cmd st+  where o oo = oo + length str+        c oc oo | oo >= length oc = oc ++ str+                | otherwise = f ++ str ++ ss+                where (f,ss) = splitAt oo oc++-- | Insert the current X selection string at the cursor position. The X+-- selection is not modified.+pasteString :: XP ()+pasteString = pasteString' id++-- | A variant of 'pasteString' which allows modifying the X selection before+-- pasting.+pasteString' :: (String -> String) -> XP ()+pasteString' f = insertString . f =<< getSelection++-- | Remove a character at the cursor position+deleteString :: Direction1D -> XP ()+deleteString d =+  modify $ \s -> setCommand (c (command s) (offset s)) $ s { offset = o (offset s)}+  where o oo = if d == Prev then max 0 (oo - 1) else oo+        c oc oo+            | oo >= length oc && d == Prev = take (oo - 1) oc+            | oo <  length oc && d == Prev = take (oo - 1) f ++ ss+            | oo <  length oc && d == Next = f ++ drop 1 ss+            | otherwise = oc+            where (f,ss) = splitAt oo oc++-- | 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++-- | 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) = 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 . takeWhile (not . p)))+          . span p+      newoff = case d of+                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+                 in s { commandHistory = ch+                      , offset         = length $ W.focus ch+                      , complIndex     = (0,0) }+  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 _ ""      = pure ()+toHeadChar d (c : _) = do+    cmd <- gets command+    off <- gets offset+    let off' = (if d == Prev then negate . fst else snd)+             . join (***) (maybe 0 (+1) . elemIndex c)+             . (reverse *** drop 1)+             $ splitAt off cmd+    modify $ \st -> st { offset = offset st + off' }++updateHighlightedCompl :: XP ()+updateHighlightedCompl = do+  st <- get+  cs <- getCompletions+  alwaysHighlight' <- gets $ alwaysHighlight . config+  when alwaysHighlight' $ modify $ \s -> s {highlightedCompl = highlightedItem st cs}++------------------------------------------------------------------------+-- X Stuff++-- | The completion windows in its entirety.+data ComplWindowDim = ComplWindowDim+  { cwX         :: !Position    -- ^ Starting x position+  , cwY         :: !Position    -- ^ Starting y position+  , cwWidth     :: !Dimension   -- ^ Width of the entire prompt+  , cwRowHeight :: !Dimension   -- ^ Height of a single row+  , cwCols      :: ![Position]  -- ^ Starting position of all columns+  , cwRows      :: ![Position]  -- ^ Starting positions of all rows+  }+  deriving (Eq)++-- | Create the prompt window.+createPromptWin :: Display -> Window -> XPConfig -> Rectangle -> Dimension -> IO Window+createPromptWin dpy rootw XPC{ position, height } scn width = do+  w <- mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw+                      (rect_x scn + x) (rect_y scn + y) width height+  setClassHint dpy w (ClassHint "xmonad-prompt" "xmonad")+  mapWindow dpy w+  return w+ where+  (x, y) :: (Position, Position) = fi <$> case position of+    Top             -> (0, 0)+    Bottom          -> (0, rect_height scn - height)+    CenteredAt py w ->+      ( floor $ fi (rect_width scn) * ((1 - w) / 2)+      , floor $ py * fi (rect_height scn) - (fi height / 2)+      )++-- | Update the state of the completion window.+updateComplWin :: Maybe Window -> Maybe ComplWindowDim -> XP ()+updateComplWin win winDim = do+  cwr <- gets complWin+  io $ writeIORef cwr win+  modify' (\s -> s { complWinDim = winDim })++--- | Update all prompt windows.+updateWindows :: XP ()+updateWindows = redrawWindows (void destroyComplWin) =<< getCompletions++-- | Draw the main prompt window and, if necessary, redraw the+-- completion window.+redrawWindows+  :: XP ()     -- ^ What to do if the completions are empty+  -> [String]  -- ^ Given completions+  -> XP ()+redrawWindows emptyAction compls = do+  d <- gets dpy+  drawWin+  maybe emptyAction redrawComplWin (nonEmpty compls)+  io $ sync d False+ where+  -- | Draw the main prompt window.+  drawWin :: XP () = do+    XPS{ color, dpy, win, gcon, winWidth } <- get+    XPC{ height, promptBorderWidth } <- gets config+    let scr = defaultScreenOfDisplay dpy+        ht  = height            -- height of a single row+        bw  = promptBorderWidth+    Just bgcolor <- io $ initColor dpy (bgNormal color)+    Just borderC <- io $ initColor dpy (border color)+    pm <- io $ createPixmap dpy win winWidth ht (defaultDepthOfScreen scr)+    io $ fillDrawable dpy pm gcon borderC bgcolor (fi bw) winWidth ht+    printPrompt pm+    io $ copyArea dpy pm win gcon 0 0 winWidth ht 0 0+    io $ freePixmap dpy pm++-- | Redraw the completion window, if necessary.+redrawComplWin ::  NonEmpty String -> XP ()+redrawComplWin compl = do+  XPS{ showComplWin, complWinDim, complWin } <- get+  nwi <- getComplWinDim compl+  let recreate = do destroyComplWin+                    w <- createComplWin nwi+                    drawComplWin w compl+  if showComplWin+     then io (readIORef complWin) >>= \case+            Just w -> case complWinDim of+                        Just wi -> if nwi == wi -- complWinDim did not change+                                   then drawComplWin w compl -- so update+                                   else recreate+                        Nothing -> recreate+            Nothing -> recreate+     else destroyComplWin+ where+  createComplWin :: ComplWindowDim -> XP Window+  createComplWin wi@ComplWindowDim{ cwX, cwY, cwWidth, cwRowHeight } = do+    XPS{ dpy, rootw } <- get+    let scr = defaultScreenOfDisplay dpy+    w <- io $ mkUnmanagedWindow dpy scr rootw cwX cwY cwWidth cwRowHeight+    io $ mapWindow dpy w+    updateComplWin (Just w) (Just wi)+    return w++-- | Print the main part of the prompt: the prompter, as well as the+-- command line (including the current input) and the cursor.+printPrompt :: Drawable -> XP ()+printPrompt drw = do+  st@XPS{ prompter, color, gcon, config, dpy, fontS, offset } <- get+  let -- (prompt-specific text before the command, the entered command)+      (prt, com) = (prompter . show . currentXPMode &&& command) st+      str = prt ++ com+      -- break the string in 3 parts: till the cursor, the cursor and the rest+      (preCursor, cursor, postCursor) = if offset >= length com+                 then (str, " ","") -- add a space: it will be our cursor ;-)+                 else let (a, b) = splitAt offset com+                      in (prt ++ a, take 1 b, drop 1 b)++  -- vertical and horizontal text alignment+  (asc, desc) <- io $ textExtentsXMF fontS str  -- font ascent and descent+  let y = fi ((height config - fi (asc + desc)) `div` 2) + asc+      x = (asc + desc) `div` 2++  pcFont <- io $ textWidthXMF dpy fontS preCursor+  cFont  <- io $ textWidthXMF dpy fontS cursor+  let draw = printStringXMF dpy drw fontS gcon+  -- print the first part+  draw (fgNormal color) (bgNormal color) x y preCursor+  -- reverse the colors and print the "cursor" ;-)+  draw (bgNormal color) (fgNormal color) (x + fi pcFont) y cursor+  -- flip back to the original colors and print the rest of the string+  draw (fgNormal color) (bgNormal color) (x + fi (pcFont + cFont)) y postCursor++-- | Get all available completions for the current input.+getCompletions :: XP [String]+getCompletions = do+  st@XPS{ config } <- get+  let cmd   = commandToComplete (currentXPMode st) (command st)+      compl = getCompletionFunction st+      srt   = sorter config+  io $ (srt cmd <$> compl cmd) `E.catch` \(SomeException _) -> return []+ where+  -- | Get the current completion function depending on the active mode.+  getCompletionFunction :: XPState -> ComplFunction+  getCompletionFunction st = case operationMode st of+    XPSingleMode compl _ -> compl+    XPMultipleModes modes -> completionFunction $ W.focus modes++-- | Destroy the currently drawn completion window, if there is one.+destroyComplWin :: XP ()+destroyComplWin = do+  XPS{ dpy, complWin } <- get+  io (readIORef complWin) >>= \case+    Just w -> do io $ destroyWindow dpy w+                 updateComplWin Nothing Nothing+    Nothing -> return ()++-- | Given the completions that we would like to show, calculate the+-- required dimensions for the completion windows.+getComplWinDim :: NonEmpty String -> XP ComplWindowDim+getComplWinDim compl = do+  XPS{ config = cfg, screen = scr, fontS = fs, dpy, winWidth } <- get+  let -- Height of a single completion row+      ht = height cfg+      bw = promptBorderWidth cfg++  tws <- mapM (textWidthXMF dpy fs) compl+  let -- Length of widest completion we will print+      maxComplLen = (fi ht `div` 2) + maximum tws+      -- Height of the screen rectangle _without_ the prompt window+      remHeight   = rect_height scr - ht++      maxColumns  = maybe id min (maxComplColumns cfg)+      columns     = max 1 . maxColumns $ winWidth `div` fi maxComplLen+      columnWidth = winWidth `div` columns++      (fullRows, lastRow) = length compl `divMod` fi columns+      allRows   = max 1 (fullRows + if lastRow == 0 then 0 else 1)+      -- Maximum number of rows allowed by the config and the screen dimensions+      maxRows   = maybe id min (maxComplRows cfg) (remHeight `div` ht)+      -- Actual number of rows to be drawn+      rows      = min maxRows (fi allRows)+      rowHeight = rows * ht++      -- Starting x and y position of the completion windows.+      (x, y) = bimap (rect_x scr +) ((rect_y scr +) . fi) $ case position cfg of+        Top    -> (0, ht - bw)+        Bottom -> (0, remHeight - rowHeight + bw)+        CenteredAt py w+          | py <= 1/2 ->+              ( floor $ fi (rect_width scr) * ((1 - w) / 2)+              , floor (py * fi (rect_height scr) + (fi ht / 2)) - bw+              )+          | otherwise ->+              ( floor $ fi (rect_width scr) * ((1 - w) / 2)+              , floor (py * fi (rect_height scr) - (fi ht / 2)) - rowHeight + bw+              )++  -- Get font ascent and descent.  Coherence condition: we will print+  -- everything using the same font.+  (asc, desc) <- io $ textExtentsXMF fs $ NE.head compl+  let yp    = fi $ (ht + fi (asc - desc)) `div` 2 -- y position of the first row+      yRows = take (fi rows) [yp, yp + fi ht ..]  -- y positions of all rows++      xp    = (asc + desc) `div` 2                           -- x position of the first column+      xCols = take (fi columns) [xp, xp + fi columnWidth ..] -- x positions of all columns++  pure $ ComplWindowDim x y winWidth rowHeight xCols yRows++-- | Draw the completion window.+drawComplWin :: Window -> NonEmpty String -> XP ()+drawComplWin w entries = do+  XPS{ config, color, dpy, gcon } <- get+  let scr = defaultScreenOfDisplay dpy+      bw  = promptBorderWidth config+  Just bgcolor <- io $ initColor dpy (bgNormal color)+  Just borderC <- io $ initColor dpy (border color)+  cwd@ComplWindowDim{ cwWidth, cwRowHeight } <- getComplWinDim entries++  p <- io $ createPixmap dpy w cwWidth cwRowHeight (defaultDepthOfScreen scr)+  io $ fillDrawable dpy p gcon borderC bgcolor (fi bw) cwWidth cwRowHeight+  printComplEntries dpy p gcon (fgNormal color) (bgNormal color) entries cwd+  --lift $ spawn $ "xmessage " ++ " ac: " ++ show ac  ++ " xx: " ++ show xx ++ " length xx: " ++ show (length xx) ++ " yy: " ++ show (length yy)+  io $ copyArea dpy p w gcon 0 0 cwWidth cwRowHeight 0 0+  io $ freePixmap dpy p++-- | Print all of the completion entries.+printComplEntries+  :: Display+  -> Drawable+  -> GC+  -> String         -- ^ Default foreground color+  -> String         -- ^ Default background color+  -> NonEmpty String -- ^ Entries to be printed...+  -> ComplWindowDim -- ^ ...into a window of this size+  -> XP ()+printComplEntries dpy drw gc fc bc entries ComplWindowDim{ cwCols, cwRows } = do+  st@XPS{ color, complIndex, config = XPC{ alwaysHighlight } } <- get+  let printItemAt :: Position -> Position -> String -> XP ()+      printItemAt x y item =+        printStringXMF dpy drw (fontS st) gc fgCol bgCol x y item+       where+        (fgCol, bgCol)+          | -- default to the first item, the one in (0, 0)+            alwaysHighlight, complIndex == findComplIndex item+          = (fgHighlight color, bgHighlight color)+          | -- compare item with buffer's value+            completionToCommand (currentXPMode st) item == commandToComplete (currentXPMode st) (command st)+          = (fgHighlight color, bgHighlight color)+          | -- if nothing matches, use default colors+            otherwise = (fc, bc)+  zipWithM_ (\x -> zipWithM_ (printItemAt x) cwRows) cwCols complMat+ where+  -- | Create the completion matrix to be printed.+  complMat :: [[String]]+    = chunksOf (length cwRows) (take (length cwCols * length cwRows) (NE.toList entries))++  -- | Find the column and row indexes in which a string appears.+  -- If the string is not in the matrix, the indices default to @(0, 0)@.+  findComplIndex :: String -> (Int, Int)+  findComplIndex item = (colIndex, rowIndex)+   where+    colIndex = fromMaybe 0 $ findIndex (\cols -> item `elem` cols) complMat+    rowIndex = fromMaybe 0 $ elemIndex item =<< complMat !? colIndex++-- History++type History = M.Map String [String]++emptyHistory :: History+emptyHistory = M.empty++getHistoryFile :: FilePath -> FilePath+getHistoryFile cachedir = cachedir ++ "/prompt-history"++readHistory :: XPConfig -> FilePath -> IO History+readHistory (XPC { historySize = 0 }) _ = return emptyHistory+readHistory _ cachedir = readHist `E.catch` \(SomeException _) -> return emptyHistory+ where+    readHist = do+        let path = getHistoryFile cachedir+        xs <- withFile path ReadMode hGetLine+        readIO xs++writeHistory :: XPConfig -> FilePath -> History -> IO ()+writeHistory (XPC { historySize = 0 }) _ _ = return ()+writeHistory _ cachedir hist = do+  let path = getHistoryFile cachedir+      filtered = M.filter (not . null) hist+  writeFile path (show filtered) `E.catch` \(SomeException e) ->+                          hPutStrLn stderr ("error writing history: "++show e)+  setFileMode path mode+    where mode = ownerReadMode .|. ownerWriteMode++-- $xutils++-- | Fills a 'Drawable' with a rectangle and a border+fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel+             -> Dimension -> Dimension -> Dimension -> IO ()+fillDrawable d drw gc borderC bgcolor bw wh ht = do+  -- we start with the 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+  fillRectangle d drw gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2))++-- | Creates a window with the attribute override_redirect set to True.+-- Windows Managers should not touch this kind of windows.+mkUnmanagedWindow :: Display -> Screen -> Window -> Position+                  -> Position -> Dimension -> Dimension -> IO Window+mkUnmanagedWindow d s rw x y w h = do+  let visual = defaultVisualOfScreen s+      attrmask = cWOverrideRedirect+  allocaSetWindowAttributes $+         \attributes -> do+           set_override_redirect attributes True+           createWindow d rw x y w h 0 (defaultDepthOfScreen s)+                        inputOutput visual attrmask attributes++-- $utils++-- | This function takes a list of possible completions and returns a+-- completions function to be used with 'mkXPrompt'+mkComplFunFromList :: XPConfig -> [String] -> String -> IO [String]+mkComplFunFromList _ _ [] = return []+mkComplFunFromList c l s =+  pure $ filter (searchPredicate c s) l++-- | This function takes a list of possible completions and returns a+-- completions function to be used with 'mkXPrompt'. If the string is+-- null it will return all completions.+mkComplFunFromList' :: XPConfig -> [String] -> String -> IO [String]+mkComplFunFromList' _ l [] = return l+mkComplFunFromList' c l s =+  pure $ filter (searchPredicate c s) l++-- | Given the prompt type, the command line and the completion list,+-- return the next completion in the list for the last word of the+-- command line. This is the default 'nextCompletion' implementation.+getNextOfLastWord :: XPrompt t => t -> String -> [String] -> String+getNextOfLastWord t c l = skipLastWord c ++ completionToCommand t (l !! ni)+    where ni = case commandToComplete t c `elemIndex` map (completionToCommand t) l of+                 Just i -> if i >= length l - 1 then 0 else i + 1+                 Nothing -> 0++-- | An alternative 'nextCompletion' implementation: given a command+-- and a completion list, get the next completion in the list matching+-- the whole command line.+getNextCompletion :: String -> [String] -> String+getNextCompletion c l = l !! idx+    where idx = case c `elemIndex` l of+                  Just i  -> if i >= length l - 1 then 0 else i + 1+                  Nothing -> 0++-- | Given a maximum length, splits a list into sublists+splitInSubListsAt :: Int -> [a] -> [[a]]+splitInSubListsAt = chunksOf+{-# DEPRECATED splitInSubListsAt "Use XMonad.Prelude.chunksOf instead." #-}++-- | Gets the last word of a string or the whole string if formed by+-- only one word+getLastWord :: String -> String+getLastWord = reverse . fst . breakAtSpace . reverse++-- | Skips the last word of the string, if the string is composed by+-- more then one word. Otherwise returns the string.+skipLastWord :: String -> String+skipLastWord = reverse . snd . breakAtSpace . reverse++breakAtSpace :: String -> (String, String)+breakAtSpace s+    | " \\" `isPrefixOf` s2 = (s1 ++ " " ++ s1', s2')+    | otherwise = (s1, s2)+      where (s1, s2 ) = break isSpace s+            (s1',s2') = breakAtSpace $ drop 1 s2++-- | 'historyCompletion' provides a canned completion function much like+--   'getShellCompl'; you pass it to mkXPrompt, and it will make completions work+--   from the query history stored in the XMonad cache directory.+historyCompletion :: XPConfig -> X ComplFunction+historyCompletion conf = historyCompletionP conf (const True)++-- | Like 'historyCompletion' but only uses history data from Prompts whose+-- name satisfies the given predicate.+historyCompletionP :: XPConfig -> (String -> Bool) -> X ComplFunction+historyCompletionP conf p = do+    cd <- asks (cacheDir . directories)+    pure $ \x ->+        let toComplList = deleteConsecutive . filter (isInfixOf x) . M.foldr (++) []+         in toComplList . M.filterWithKey (const . p) <$> readHistory conf cd++-- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off+--   laziness and stability for efficiency.+uniqSort :: Ord a => [a] -> [a]+uniqSort = toList . fromList++-- | Functions to be used with the 'historyFilter' setting.+-- 'deleteAllDuplicates' will remove all duplicate entries.+-- 'deleteConsecutive' will only remove duplicate elements+-- immediately next to each other.+deleteAllDuplicates, deleteConsecutive :: [String] -> [String]+deleteAllDuplicates = nub+deleteConsecutive = map (NE.head . notEmpty) . group+-- The elements of group will always have at least one element.++newtype HistoryMatches = HistoryMatches (IORef ([String],Maybe (W.Stack String)))++-- | Initializes a new HistoryMatches structure to be passed+-- to historyUpMatching+initMatches :: (Functor m, MonadIO m) => m HistoryMatches+initMatches = HistoryMatches <$> liftIO (newIORef ([],Nothing))++historyNextMatching :: HistoryMatches -> (W.Stack String -> W.Stack String) -> XP ()+historyNextMatching hm@(HistoryMatches ref) next = do+  (completed,completions) <- io $ readIORef ref+  input <- getInput+  if input `elem` completed+     then case completions of+            Just cs -> do+                let cmd = W.focus cs+                modify $ setCommand cmd+                modify $ \s -> s { offset = length cmd }+                io $ writeIORef ref (cmd:completed,Just $ next cs)+            Nothing -> return ()+     else do -- the user typed something new, recompute completions+       io . writeIORef ref . ([input] ,) . filterMatching input =<< gets commandHistory+       historyNextMatching hm next+    where filterMatching :: String -> W.Stack String -> Maybe (W.Stack String)+          filterMatching prefix = W.filter (prefix `isPrefixOf`) . next++-- | Retrieve the next history element that starts with+-- the current input. Pass it the result of initMatches+-- when creating the prompt. Example:+--+-- > ..+-- > ((modMask,xK_p), shellPrompt . myPrompt =<< initMatches)+-- > ..+-- > myPrompt ref = def+-- >   { promptKeymap = M.union [((0,xK_Up), historyUpMatching ref)+-- >                            ,((0,xK_Down), historyDownMatching ref)]+-- >                            (promptKeymap def) -- >   , .. } -- historyUpMatching, historyDownMatching :: HistoryMatches -> XP ()
XMonad/Prompt/AppLauncher.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.AppLauncher+-- Description :  A prompt for launch applications that receive command line parameters. -- Copyright   :  (C) 2008 Luis Cabellos -- License     :  BSD3 --@@ -25,7 +26,7 @@  import XMonad (X(),MonadIO) import XMonad.Core (spawn)-import XMonad.Prompt (XPrompt(showXPrompt), mkXPrompt, XPConfig())+import XMonad.Prompt (XPrompt(showXPrompt), mkXPrompt, XPConfig(searchPredicate)) import XMonad.Prompt.Shell (getShellCompl)  {- $usage@@ -50,14 +51,14 @@ Then you can add the bindings to the applications.  > ...-> , ((modm, xK_g), AL.launchApp defaultXPConfig "gimp" )-> , ((modm, xK_g), AL.launchApp defaultXPConfig "evince" )+> , ((modm, xK_g), AL.launchApp def "gimp" )+> , ((modm, xK_g), AL.launchApp def "evince" ) > ...   -}  -- A customized prompt-data AppPrompt = AppPrompt String+newtype AppPrompt = AppPrompt String instance XPrompt AppPrompt where     showXPrompt (AppPrompt n) = n ++ " " @@ -72,4 +73,4 @@ {- | Get the user's response to a prompt an launch an application using the    input as command parameters of the application.-} launchApp :: XPConfig -> Application -> X ()-launchApp config app = mkXPrompt (AppPrompt app) config (getShellCompl []) $ launch app+launchApp config app = mkXPrompt (AppPrompt app) config (getShellCompl [] $ searchPredicate config) $ launch app
XMonad/Prompt/AppendFile.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.AppendFile+-- Description :  A prompt for appending a single line of text to a file. -- Copyright   :  (c) 2007 Brent Yorgey -- License     :  BSD-style (see LICENSE) --@@ -23,26 +24,27 @@                                  -- $usage                                   appendFilePrompt,+                                 appendFilePrompt',                                  AppendFile,                                 ) where  import XMonad.Core import XMonad.Prompt+import XMonad.Prelude (mkAbsolutePath)  import System.IO-import Control.Exception.Extensible (bracket)  -- $usage -- -- You can use this module by importing it, along with--- "XMonad.Prompt", into your ~\/.xmonad\/xmonad.hs file:+-- "XMonad.Prompt", into your @xmonad.hs@ file: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.AppendFile -- -- and adding an appropriate keybinding, for example: ----- >  , ((modm .|. controlMask, xK_n), appendFilePrompt defaultXPConfig "/home/me/NOTES")+-- >  , ((modm .|. controlMask, xK_n), appendFilePrompt def "/home/me/NOTES") -- -- Additional notes can be added via regular Haskell or XMonad functions; for -- example, to preface notes with the time they were made, one could write a@@ -50,15 +52,26 @@ -- -- > ,  ((modm .|. controlMask, xK_n), do -- >            spawn ("date>>"++"/home/me/NOTES")--- >            appendFilePrompt defaultXPConfig "/home/me/NOTES"+-- >            appendFilePrompt def "/home/me/NOTES" -- >        ) -- -- (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 $ fmap (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".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data AppendFile = AppendFile FilePath+newtype AppendFile = AppendFile FilePath  instance XPrompt AppendFile where     showXPrompt (AppendFile fn) = "Add to " ++ fn ++ ": "@@ -66,11 +79,17 @@ -- | 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 = appendFilePrompt' c id++-- | 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 s = mkAbsolutePath fn >>= \f -> (io . withFile f AppendMode . flip hPutStrLn . trans) s
+ XMonad/Prompt/ConfirmPrompt.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Prompt.ConfirmPrompt+-- Description :  A prompt for setting up simple confirmation prompts for keybindings.+-- Copyright   :  (C) 2015 Antoine Beaupré+-- License     :  BSD3+--+-- Maintainer  :  Antoine Beaupré <anarcat@debian.org>+-- Stability   :  unstable+-- Portability :  unportable+--+-- A module for setting up simple confirmation prompts for keybindings.+--+-----------------------------------------------------------------------------+module XMonad.Prompt.ConfirmPrompt (confirmPrompt+                                    -- * Usage+                                    -- $usage+                                    , module XMonad.Prompt+                                    -- * Use case: confirming exit+                                    -- $tip+                                    , EnterPrompt+                                    ) where++import XMonad (X)+import XMonad.Prompt (XPConfig, XPrompt, showXPrompt, mkXPrompt, mkComplFunFromList)++{- $usage++This module makes it easy to add a confirmation prompt for specific+actions. Instead of just running the action, a simple confirmation+prompt will be created using 'XMonad.Prompt' primitives. The action+will then run normally if the user confirms.+-}++{- $tip+This should be used something like this:++> ...+> , ((modm , xK_l), confirmPrompt def "exit" $ io (exitWith ExitSuccess))+> ...+-}++{- | Customized 'XPrompt' prompt that will ask to confirm the given string -}+newtype EnterPrompt = EnterPrompt String+instance XPrompt EnterPrompt where+    showXPrompt (EnterPrompt n) = "Confirm " ++ n ++ " (esc/ENTER)"++{- | Prompt the user to confirm a given action. We offer no completion+     and simply ask to confirm (ENTER) or cancel (ESCAPE). The actual key+     handling is done by mkXPrompt.-}+confirmPrompt :: XPConfig -> String -> X() -> X()+confirmPrompt config app func = mkXPrompt (EnterPrompt app) config (mkComplFunFromList config []) $ const func
XMonad/Prompt/DirExec.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.DirExec+-- Description :  A directory file executables prompt for XMonad. -- Copyright   :  (C) 2008 Juraj Hercek -- License     :  BSD3 --@@ -26,32 +27,31 @@  import Control.Exception as E import System.Directory-import Control.Monad-import Data.List import XMonad+import XMonad.Prelude import XMonad.Prompt  econst :: Monad m => a -> IOException -> m a econst = const . return  -- $usage--- 1. In your @~\/.xmonad\/xmonad.hs@:+-- 1. In your @xmonad.hs@: -- -- > import XMonad.Prompt.DirExec -- -- 2. In your keybindings add something like: ----- >   , ("M-C-x", dirExecPrompt defaultXPConfig spawn "/home/joe/.scipts")+-- >   , ("M-C-x", dirExecPrompt def spawn "/home/joe/.scipts") -- -- or ----- >   , ("M-C-x", dirExecPromptNamed defaultXPConfig spawn+-- >   , ("M-C-x", dirExecPromptNamed def spawn -- >                                  "/home/joe/.scripts" "My Scripts: ") -- -- or add this after your default bindings: -- -- >   ++--- >   [ ("M-x " ++ key, dirExecPrompt defaultXPConfig fn "/home/joe/.scripts")+-- >   [ ("M-x " ++ key, dirExecPrompt def fn "/home/joe/.scripts") -- >     | (key, fn) <- [ ("x", spawn), ("M-x", runInTerm "-hold") ] -- >   ] -- >   ++@@ -63,9 +63,9 @@ -- terminal -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data DirExec = DirExec String+newtype DirExec = DirExec String  instance XPrompt DirExec where     showXPrompt (DirExec name) = name@@ -100,7 +100,7 @@ getDirectoryExecutables path =     (getDirectoryContents path >>=         filterM (\x -> let x' = path ++ x in-            liftM2 (&&)+            liftA2 (&&)                 (doesFileExist x')-                (liftM executable (getPermissions x'))))+                (fmap executable (getPermissions x'))))     `E.catch` econst []
XMonad/Prompt/Directory.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Directory+-- Description :  A directory prompt for XMonad. -- Copyright   :  (C) 2007 Andrea Rossato, David Roundy -- License     :  BSD3 --@@ -16,27 +17,48 @@                              -- * Usage                              -- $usage                              directoryPrompt,-                             Dir,+                             directoryMultipleModes,+                             directoryMultipleModes',+                             Dir                               ) where +import XMonad.Prelude ( sort )+ import XMonad import XMonad.Prompt-import XMonad.Util.Run ( runProcessWithInput )+import XMonad.Prompt.Shell ( compgenDirectories )  -- $usage -- For an example usage see "XMonad.Layout.WorkspaceDir" -data Dir = Dir String+data Dir = Dir String ComplCaseSensitivity (String -> X ())  instance XPrompt Dir where-    showXPrompt (Dir x) = x+    showXPrompt (Dir x _ _) = x+    completionFunction (Dir _ csn _) = getDirCompl csn+    modeAction (Dir _ _ f) buf auto =+      let dir = if null auto then buf else auto+      in f dir  directoryPrompt :: XPConfig -> String -> (String -> X ()) -> X ()-directoryPrompt c prom = mkXPrompt (Dir prom) c getDirCompl+directoryPrompt c prom f = mkXPrompt (Dir prom csn f) c (getDirCompl csn) f+    where csn = complCaseSensitivity c -getDirCompl :: String -> IO [String]-getDirCompl s = (filter notboring . lines) `fmap`-                runProcessWithInput "/bin/bash" [] ("compgen -A directory " ++ s ++ "\n")+-- | A @XPType@ entry suitable for using with @mkXPromptWithModes@.+directoryMultipleModes :: String            -- ^ Prompt.+                       -> (String -> X ())  -- ^ Action.+                       -> XPType+directoryMultipleModes = directoryMultipleModes' CaseSensitive++-- | Like @directoryMultipleModes@ with a parameter for completion case-sensitivity.+directoryMultipleModes' :: ComplCaseSensitivity -- ^ Completion case sensitivity.+                        -> String               -- ^ Prompt.+                        -> (String -> X ())     -- ^ Action.+                        -> XPType+directoryMultipleModes' csn p f = XPT (Dir p csn f)++getDirCompl :: ComplCaseSensitivity -> String -> IO [String]+getDirCompl csn s = sort . filter notboring . lines <$> compgenDirectories csn s  notboring :: String -> Bool notboring ('.':'.':_) = True
XMonad/Prompt/Email.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Email+-- Description :  A prompt for sending quick, one-line emails, via GNU \'mail\'. -- Copyright   :  (c) 2007 Brent Yorgey -- License     :  BSD-style (see LICENSE) --@@ -23,20 +24,21 @@  import XMonad.Core import XMonad.Util.Run+import XMonad.Prelude (void) import XMonad.Prompt import XMonad.Prompt.Input  -- $usage -- -- You can use this module by importing it, along with--- "XMonad.Prompt", into your ~\/.xmonad\/xmonad.hs file:+-- "XMonad.Prompt", into your @xmonad.hs@ file: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.Email -- -- and adding an appropriate keybinding, for example: ----- >  , ((modm .|. controlMask, xK_e), emailPrompt defaultXPConfig addresses)+-- >  , ((modm .|. controlMask, xK_e), emailPrompt def addresses) -- -- where @addresses@ is a list of email addresses that should -- autocomplete, for example:@@ -48,7 +50,7 @@ -- characters and then hit \'tab\'. -- -- For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.   -- | Prompt the user for a recipient, subject, and body, and send an@@ -56,8 +58,7 @@ --   of addresses for autocompletion. emailPrompt :: XPConfig -> [String] -> X () emailPrompt c addrs =-    inputPromptWithCompl c "To" (mkComplFunFromList addrs) ?+ \to ->+    inputPromptWithCompl c "To" (mkComplFunFromList c addrs) ?+ \to ->     inputPrompt c "Subject" ?+ \subj ->     inputPrompt c "Body" ?+ \body ->-    runProcessWithInput "mail" ["-s", subj, to] (body ++ "\n")-         >> return ()+    void (runProcessWithInput "mail" ["-s", subj, to] (body ++ "\n"))
+ XMonad/Prompt/FuzzyMatch.hs view
@@ -0,0 +1,102 @@+--------------------------------------------------------------------------------+-- |+-- Module      : XMonad.Prompt.FuzzyMatch+-- Description : A prompt for fuzzy completion matching in prompts akin to Emacs ido-mode.+-- Copyright   : (C) 2015 Norbert Zeh+-- License     : GPL+--+-- Maintainer  : Norbert Zeh <norbert.zeh@gmail.com>+-- Stability   : unstable+-- Portability : unportable+--+-- A module for fuzzy completion matching in prompts akin to emacs ido mode.+--+--------------------------------------------------------------------------------++module XMonad.Prompt.FuzzyMatch ( -- * Usage+                                  -- $usage+                                  fuzzyMatch+                                , fuzzySort+                                ) where++import XMonad.Prelude+import qualified Data.List.NonEmpty as NE++-- $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+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.++-- | 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 a b = isSubsequenceOf (map toLower a) (map toLower b)++-- | 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 . sort . map (rankMatch q)++rankMatch :: String -> String -> ((Int, Int), String)+rankMatch q s = (if null matches then (maxBound, maxBound) else minimum matches, s)+  where matches = rankMatches q s++rankMatches :: String -> String -> [(Int, Int)]+rankMatches [] _ = [(0, 0)]+rankMatches (q:qs) s = map (\(l, r) -> (r - l, l)) $ findShortestMatches (q :| qs) s++findShortestMatches :: NonEmpty Char -> String -> [(Int, Int)]+findShortestMatches q s = foldl' extendMatches spans oss+  where (os :| oss) = NE.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 = map last . groupBy ((==) `on` snd) . extendMatches' spans++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'
XMonad/Prompt/Input.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Input+-- Description :  Prompt the user for input and pass it along to some other action. -- Copyright   :  (c) 2007 Brent Yorgey -- License     :  BSD-style (see LICENSE) --@@ -49,13 +50,13 @@ -- @fireEmployee@ action, like so: -- -- > firingPrompt :: X ()--- > firingPrompt = inputPrompt defaultXPConfig \"Fire\" ?+ fireEmployee+-- > firingPrompt = inputPrompt def "Fire" ?+ fireEmployee -- -- If @employees@ contains a list of all his employees, he could also -- create an autocompleting version, like this: ----- > firingPrompt' = inputPromptWithCompl defaultXPConfig \"Fire\"--- >                     (mkComplFunFromList employees) ?+ fireEmployee+-- > firingPrompt' = inputPromptWithCompl def "Fire"+-- >                     (mkComplFunFromList def employees) ?+ fireEmployee -- -- Now all he has to do is add a keybinding to @firingPrompt@ (or -- @firingPrompt'@), such as@@ -69,7 +70,7 @@ -- invoked. -- -- (For detailed instructions on editing your key bindings, see--- "XMonad.Doc.Extending#Editing_key_bindings".)+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.) -- -- "XMonad.Prompt.Input" is also intended to ease the process of -- developing other modules which require user input. For an example@@ -77,7 +78,7 @@ -- "XMonad.Prompt.Email", which prompts the user for a recipient, -- subject, and one-line body, and sends a quick email. -data InputPrompt = InputPrompt String+newtype InputPrompt = InputPrompt String  instance XPrompt InputPrompt  where     showXPrompt (InputPrompt s) = s ++ ": "
XMonad/Prompt/Layout.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Layout+-- Description :  A layout-selection prompt. -- Copyright   :  (C) 2007 Andrea Rossato, David Roundy -- License     :  BSD3 --@@ -18,23 +19,22 @@                              layoutPrompt                             ) where -import Data.List ( sort, nub )+import XMonad.Prelude ( sort, nub ) import XMonad hiding ( workspaces ) import XMonad.Prompt import XMonad.Prompt.Workspace ( Wor(..) ) import XMonad.StackSet ( workspaces, layout )-import XMonad.Layout.LayoutCombinators ( JumpToLayout(..) )  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.Layout ----- >   , ((modm .|. shiftMask, xK_m     ), layoutPrompt defaultXPConfig)+-- >   , ((modm .|. shiftMask, xK_m     ), layoutPrompt def) -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -- -- WARNING: This prompt won't display all possible layouts, because the -- code to enable this was rejected from xmonad core.  It only displays@@ -46,4 +46,4 @@  layoutPrompt :: XPConfig -> X () layoutPrompt c = do ls <- gets (map (description . layout) . workspaces . windowset)-                    mkXPrompt (Wor "") c (mkComplFunFromList' $ sort $ nub ls) (sendMessage . JumpToLayout)+                    mkXPrompt (Wor "") c (mkComplFunFromList' c $ sort $ nub ls) (sendMessage . JumpToLayout)
XMonad/Prompt/Man.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Man+-- Description :  A manual page prompt. -- Copyright   :  (c) 2007 Valery V. Vorotyntsev -- License     :  BSD3-style (see LICENSE) --@@ -25,31 +26,30 @@   import XMonad+import XMonad.Prelude import XMonad.Prompt import XMonad.Util.Run import XMonad.Prompt.Shell (split)  import System.Directory-import System.Process+import System.FilePath (dropExtensions, (</>)) import System.IO+import System.Process -import qualified Control.Exception.Extensible as E-import Control.Monad-import Data.List-import Data.Maybe+import qualified Control.Exception as E  -- $usage--- 1. In your @~\/.xmonad\/xmonad.hs@:+-- 1. In your @xmonad.hs@: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.Man -- -- 2. In your keybindings add something like: ----- >     , ((modm, xK_F1), manPrompt defaultXPConfig)+-- >     , ((modm, xK_F1), manPrompt def) -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  data Man = Man @@ -60,32 +60,35 @@ manPrompt :: XPConfig -> X () manPrompt c = do   mans <- io getMans-  mkXPrompt Man c (manCompl mans) $ runInTerm "" . (++) "man "+  mkXPrompt Man c (manCompl c mans) $ runInTerm "" . (++) "man "  getMans :: IO [String] getMans = do-  paths <- getCommandOutput "manpath -g 2>/dev/null" `E.catch`-            \(E.SomeException _) -> return []+  paths <- do+    let getout cmd = getCommandOutput cmd `E.catch` \E.SomeException{} -> return ""+    -- one of these combinations should give some output+    p1 <- getout "manpath -g 2>/dev/null"+    p2 <- getout "manpath 2>/dev/null"+    return $ intercalate ":" $ lines $ p1 ++ p2   let sects    = ["man" ++ show n | n <- [1..9 :: Int]]-      dirs     = [d ++ "/" ++ s | d <- split ':' paths, s <- sects]-  mans <- forM dirs $ \d -> do+      dirs     = [d </> s | d <- split ':' paths, s <- sects]+  mans <- forM (nub dirs) $ \d -> do             exists <- doesDirectoryExist d             if exists-              then map (stripExt . stripSuffixes [".gz", ".bz2"]) `fmap`-                   getDirectoryContents d+              then map dropExtensions <$> getDirectoryContents d               else return []   return $ uniqSort $ concat mans -manCompl :: [String] -> String -> IO [String]-manCompl mans s | s == "" || last s == ' ' = return []-                | otherwise                = do+manCompl :: XPConfig -> [String] -> String -> IO [String]+manCompl c mans s | s == "" || last s == ' ' = return []+                  | otherwise                = do   -- XXX readline instead of bash's compgen?-  f <- lines `fmap` getCommandOutput ("bash -c 'compgen -A file " ++ s ++ "'")-  mkComplFunFromList (f ++ mans) s+  f <- lines <$> getCommandOutput ("bash -c 'compgen -A file " ++ s ++ "'")+  mkComplFunFromList c (f ++ mans) s  -- | Run a command using shell and return its output. ----- XXX Merge into 'XMonad.Util.Run'?+-- XXX Merge into "XMonad.Util.Run"? -- -- (Ask \"gurus\" whether @evaluate (length ...)@ approach is -- better\/more idiomatic.)@@ -98,15 +101,3 @@   E.evaluate (length output)   hClose perr   return output--stripExt :: String -> String-stripExt = reverse . drop 1 . dropWhile (/= '.') . reverse--stripSuffixes :: Eq a => [[a]] -> [a] -> [a]-stripSuffixes sufs fn =-    head . catMaybes $ map (flip rstrip fn) sufs ++ [Just fn]--rstrip :: Eq a => [a] -> [a] -> Maybe [a]-rstrip suf lst-    | suf `isSuffixOf` lst = Just $ take (length lst - length suf) lst-    | otherwise            = Nothing
+ XMonad/Prompt/OrgMode.hs view
@@ -0,0 +1,684 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData          #-}+{-# LANGUAGE ViewPatterns        #-}+--------------------------------------------------------------------+-- |+-- Module      :  XMonad.Prompt.OrgMode+-- Description :  A prompt for interacting with org-mode.+-- Copyright   :  (c) 2021  Tony Zorman+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Tony Zorman <soliditsallgood@mailbox.org>+-- Stability   :  experimental+-- Portability :  unknown+--+-- A prompt for interacting with <https:\/\/orgmode.org\/ org-mode>.+-- This can be seen as an org-specific version of+-- "XMonad.Prompt.AppendFile", allowing for more interesting+-- interactions with that particular file type.+--+-- It can be used to quickly save TODOs, NOTEs, and the like with the+-- additional capability to schedule/deadline a task, add a priority,+-- refile to some existing heading, and use the system's clipboard+-- (really: the primary selection) as the contents of the note.+--+-- A blog post highlighting some features of this module can be found+-- <https://tony-zorman.com/posts/orgmode-prompt/2022-08-27-xmonad-and-org-mode.html here>.+--+--------------------------------------------------------------------+module XMonad.Prompt.OrgMode (+    -- * Usage+    -- $usage++    -- * Prompts+    orgPrompt,              -- :: XPConfig -> String -> FilePath -> X ()+    orgPromptRefile,        -- :: XPConfig -> [String] -> String -> FilePath -> X ()+    orgPromptRefileTo,      -- :: XPConfig -> String -> String -> FilePath -> X ()+    orgPromptPrimary,       -- :: XPConfig -> String -> FilePath -> X ()++    -- * Types+    ClipboardSupport (..),+    OrgMode,                -- abstract++#ifdef TESTING+    pInput,+    Note (..),+    Priority (..),+    Date (..),+    Time (..),+    TimeOfDay (..),+    OrgTime (..),+    DayOfWeek (..),+#endif++) where++import XMonad.Prelude++import XMonad (X, io, whenJust)+import XMonad.Prompt (XPConfig, XPrompt (showXPrompt), mkXPromptWithReturn, mkComplFunFromList, ComplFunction)+import XMonad.Util.Parser+import XMonad.Util.XSelection (getSelection)+import XMonad.Util.Run++import Control.DeepSeq (deepseq)+import qualified Data.List.NonEmpty as NE (head)+import Data.Time (Day (ModifiedJulianDay), NominalDiffTime, UTCTime (utctDay), addUTCTime, fromGregorian, getCurrentTime, nominalDay, toGregorian)+#if MIN_VERSION_time(1, 9, 0)+import Data.Time.Format.ISO8601 (iso8601Show)+#else+import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat)+#endif+import GHC.Natural (Natural)+import System.IO (IOMode (AppendMode, ReadMode), hClose, hGetContents, openFile, withFile)++{- $usage++You can use this module by importing it, along with "XMonad.Prompt", in+your @xmonad.hs@++> import XMonad.Prompt+> import XMonad.Prompt.OrgMode (orgPrompt)++and adding an appropriate keybinding.  For example, using syntax from+"XMonad.Util.EZConfig":++> , ("M-C-o", orgPrompt def "TODO" "/home/me/org/todos.org")++This would create notes of the form @* TODO /my-message/@ in the+specified file.++You can also enter a relative path; in that case the file path will be+prepended with @$HOME@ or an equivalent directory.  I.e. instead of the+above you can write++> , ("M-C-o", orgPrompt def "TODO" "org/todos.org")+>                -- also possible: "~/org/todos.org"++There is also some scheduling and deadline functionality present.  This+may be initiated by entering @+s@ or @+d@—separated by at least one+whitespace character on either side—into the prompt, respectively.+Then, one may enter a date and (optionally) a time of day.  Any of the+following are valid dates, where brackets indicate optionality:++  - tod[ay]+  - tom[orrow]+  - /any weekday/+  - /any date of the form DD [MM] [YYYY]/++In the last case, the missing month and year will be filled out with the+current month and year.++For weekdays, we also disambiguate as early as possible; a simple @w@+will suffice to mean Wednesday, but @s@ will not be enough to say+Sunday.  You can, however, also write the full word without any+troubles.  Weekdays always schedule into the future; e.g., if today is+Monday and you schedule something for Monday, you will actually schedule+it for the /next/ Monday (the one in seven days).++The time is specified in the @HH:MM@ or @HHMM@ format.  The minutes may+be omitted, in which case we assume a full hour is specified.  It is also+possible to enter a time span using the syntax @HH:MM-HH:MM@ or @HH:MM+HH@.+In the former case, minutes may be omitted.++A few examples are probably in order.  Suppose we have bound the key+above, pressed it, and are now confronted with a prompt:++  - @hello +s today@ would create a TODO note with the header @hello@+    and would schedule that for today's date.++  - @hello +s today 12@ schedules the note for today at 12:00.++  - @hello +s today 12:30@ schedules it for today at 12:30.++  - @hello +d today 12:30@ works just like above, but creates a+    deadline.++  - @hello +d today 12:30-14:30@ works like the above, but gives the+    event a duration of two hours.  An alternative way to specify+    this would be @hello +d today 12:30+2@.++  - @hello +s thu@ would schedule the note for next thursday.++  - @hello +s 11@ would schedule it for the 11th of this month and this+    year.++  - @hello +s 11 jan 2013@ would schedule the note for the 11th of+    January 2013.++Note that, due to ambiguity concerns, years below @25@ result in+undefined parsing behaviour.  Otherwise, what should @message +s 11 jan+13@ resolve to—the 11th of january at 13:00 or the 11th of january in+the year 13?++There is basic support for alphabetic org-mode+<https:\/\/orgmode.org\/manual\/Priorities.html priorities>.+Simply append either @#A@, @#B@, or @#C@ (capitalisation is optional) to+the end of the note.  For example, one could write @"hello +s 11 jan+2013 #A"@ or @"hello #C"@.  Note that there has to be at least one+whitespace character between the end of the note and the chosen+priority.++There's also the possibility to take what's currently in the primary+selection and paste that as the content of the created note.  This is+especially useful when you want to quickly save a URL for later and+return to whatever you were doing before.  See the 'orgPromptPrimary'+prompt for that.++Finally, 'orgPromptRefile' and 'orgPromptRefileTo' provide support to+automatically+<https://orgmode.org/manual/Refile-and-Copy.html refile>+the generated item under a heading of choice.  For example, binding++> orgPromptRefile def "TODO" "todos.org"++to a key will first pop up an ordinary prompt that works exactly like+'orgPrompt', and then query the user for an already existing heading+(with completions) as provided by the @~/todos.org@ file.  If that+prompt is cancelled, the heading will appear in the org file as normal+(i.e., at the end of the file); otherwise, it gets refiled under the+selected heading.++-}++{- TODO++  - XMonad.Util.XSelection.getSelection is really, really horrible.  The+    plan would be to rewrite this in a way so it uses xmonad's+    connection to the X server.++  - Add option to explicitly use the system clipboard instead of the+    primary selection.++-}++------------------------------------------------------------------------+-- Prompt++data OrgMode = OrgMode+  { clpSupport :: ClipboardSupport+  , todoHeader :: String    -- ^ Will display like @* todoHeader @+  , orgFile    :: FilePath+  }++mkOrgCfg :: ClipboardSupport -> String -> FilePath -> X OrgMode+mkOrgCfg clp header fp = OrgMode clp header <$> mkAbsolutePath fp++-- | Whether we should use a clipboard and which one to use.+data ClipboardSupport+  = PrimarySelection+  | NoClpSupport++-- | How one should display the clipboard string.+data Clp+  = Header String  -- ^ In the header as a link: @* [[clp][message]]@+  | Body   String  -- ^ In the body as additional text: @* message \n clp@++instance XPrompt OrgMode where+  showXPrompt :: OrgMode -> String+  showXPrompt OrgMode{ todoHeader, orgFile, clpSupport } =+    mconcat ["Add ", todoHeader, clp, " to ", orgFile, ": "]+   where+    clp :: String = case clpSupport of+      NoClpSupport     -> ""+      PrimarySelection -> " + PS"++-- | Prompt for interacting with @org-mode@.+orgPrompt+  :: XPConfig  -- ^ Prompt configuration+  -> String    -- ^ What kind of note to create; will be displayed after+               --   a single @*@+  -> FilePath  -- ^ Path to @.org@ file, e.g. @home\/me\/todos.org@+  -> X ()+orgPrompt xpc = (void . mkOrgPrompt xpc =<<) .: mkOrgCfg NoClpSupport++-- | Like 'orgPrompt', but additionally make use of the primary+-- selection.  If it is a URL, then use an org-style link+-- @[[primary-selection][entered message]]@ as the heading.  Otherwise,+-- use the primary selection as the content of the note.+--+-- The prompt will display a little @+ PS@ in the window+-- after the type of note.+orgPromptPrimary :: XPConfig -> String -> FilePath -> X ()+orgPromptPrimary xpc = (void . mkOrgPrompt xpc =<<) .: mkOrgCfg PrimarySelection++-- | Internal type in order to generate a nice prompt in+-- 'orgPromptRefile' and 'orgPromptRefileTo'.+data RefilePrompt = Refile+instance XPrompt RefilePrompt where+  showXPrompt :: RefilePrompt -> String+  showXPrompt Refile = "Refile note to: "++-- | Like 'orgPrompt' (which see for the other arguments), but offer to+-- refile the entered note afterwards.+--+-- Note that refiling is done by shelling out to Emacs, hence an @emacs@+-- binary must be in @$PATH@.  One may customise this by following the+-- instructions in "XMonad.Util.Run#g:EDSL"; more specifically, by+-- changing the 'XMonad.Util.Run.emacs' field of+-- 'XMonad.Util.Run.ProcessConfig'.+orgPromptRefile :: XPConfig -> String -> FilePath -> X ()+orgPromptRefile xpc str fp = do+  orgCfg <- mkOrgCfg NoClpSupport str fp++  -- NOTE: Ideally we would just use System.IO.readFile' here+  -- (especially because it also reads everything strictly), but this is+  -- only available starting in base 4.15.x.+  fileContents <- io $ do+    handle   <- openFile (orgFile orgCfg) ReadMode+    contents <- hGetContents handle+    contents <$ (contents `deepseq` hClose handle)++  -- Save the entry as soon as possible.+  notCancelled <- mkOrgPrompt xpc orgCfg+  when notCancelled $+    -- If the user didn't cancel, try to parse the org file and offer to+    -- refile the entry if possible.+    whenJust (runParser pOrgFile fileContents) $ \headings ->+      mkXPromptWithReturn Refile xpc (completeHeadings headings) pure >>= \case+        Nothing     -> pure ()+        Just parent -> refile parent (orgFile orgCfg)+ where+  completeHeadings :: [Heading] -> ComplFunction+  completeHeadings = mkComplFunFromList xpc . map headingText++-- | Like 'orgPromptRefile', but with a fixed heading for refiling; no+-- prompt will appear to query for a target.+--+-- Heading names may omit tags, but generally need to be prefixed by the+-- correct todo keywords; e.g.,+--+-- > orgPromptRefileTo def "PROJECT Work" "TODO" "~/todos.org"+--+-- Will refile the created note @"TODO <text>"@ to the @"PROJECT Work"@+-- heading, even with the actual name is @"PROJECT Work+-- :work:other_tags:"@.  Just entering @"Work"@ will not work, as Emacs+-- doesn't recognise @"PROJECT"@ as an Org keyword by default (i.e. when+-- started in batch-mode).+orgPromptRefileTo+  :: XPConfig+  -> String     -- ^ Heading to refile the entry under.+  -> String+  -> FilePath+  -> X ()+orgPromptRefileTo xpc refileHeading str fp = do+  orgCfg       <- mkOrgCfg NoClpSupport str fp+  notCancelled <- mkOrgPrompt xpc orgCfg+  when notCancelled $ refile refileHeading (orgFile orgCfg)++-- | Create the actual prompt.  Returns 'False' when the input was+-- cancelled by the user (by, for example, pressing @Esc@ or @C-g@) and+-- 'True' otherwise.+mkOrgPrompt :: XPConfig -> OrgMode -> X Bool+mkOrgPrompt xpc oc@OrgMode{ todoHeader, orgFile, clpSupport } =+  isJust <$> mkXPromptWithReturn oc xpc (const (pure [])) appendNote+ where+  -- | Parse the user input, create an @org-mode@ note out of that and+  -- try to append it to the given file.+  appendNote :: String -> X ()+  appendNote input = io $ do+    clpStr <- case clpSupport of+      NoClpSupport     -> pure $ Body ""+      PrimarySelection -> do+        sel <- getSelection+        pure $ if   any (`isPrefixOf` sel) ["http://", "https://"]+               then Header sel+               else Body   $ "\n " <> sel++    withFile orgFile AppendMode . flip hPutStrLn+      <=< maybe (pure "") (ppNote clpStr todoHeader) . pInput+        $ input++------------------------------------------------------------------------+-- Refiling++-- | Let Emacs do the refiling, as this seems—and I know how this+-- sounds—more robust than trying to do it ad-hoc in this module.+refile :: String -> FilePath -> X ()+refile (asString -> parent) (asString -> fp) =+  proc $ inEmacs+     >-> asBatch+     >-> eval (progn [ "find-file" <> fp+                     , "end-of-buffer"+                     , "org-refile nil nil"+                         <> list [ parent+                                 , fp+                                 , "nil"+                                 , saveExcursion ["org-find-exact-headline-in-buffer"+                                                    <> parent]+                                 ]+                     , "save-buffer"+                     ])++------------------------------------------------------------------------+-- Time++-- | A 'Time' is a 'Date' with the possibility of having a specified+-- @HH:MM@ time.+data Time = Time+  { date :: Date+  , tod  :: Maybe OrgTime+  }+  deriving (Eq, Show)++-- | The time in HH:MM.+data TimeOfDay = HHMM Int Int+  deriving (Eq)++instance Show TimeOfDay where+  show :: TimeOfDay -> String+  show (HHMM h m) = pad h <> ":" <> pad m+   where+    pad :: Int -> String+    pad n = (if n <= 9 then "0" else "") <> show n++-- | The time—possibly as a span—in HH:MM format.+data OrgTime = MomentInTime TimeOfDay | TimeSpan TimeOfDay TimeOfDay+  deriving (Eq)++instance Show OrgTime where+  show :: OrgTime -> String+  show (MomentInTime tod)  = show tod+  show (TimeSpan tod tod') = show tod <> "-" <> show tod'++-- | Type for specifying exactly which day one wants.+data Date+  = Today+  | Tomorrow+  | Next DayOfWeek+    -- ^ This will __always__ show the next 'DayOfWeek' (e.g. calling+    -- 'Next Monday' on a Monday will result in getting the menu for the+    -- following Monday)+  | Date (Int, Maybe Int, Maybe Integer)+    -- ^ Manual date entry in the format DD [MM] [YYYY]+  deriving (Eq, Ord, Show)++toOrgFmt :: Maybe OrgTime -> Day -> String+toOrgFmt tod day =+  mconcat ["<", isoDay, " ", take 3 $ show (dayOfWeek day), time, ">"]+ where+  time   :: String = maybe "" ((' ' :) . show) tod+#if MIN_VERSION_time(1, 9, 0)+  isoDay :: String = iso8601Show day+#else+  isoDay :: String = formatTime defaultTimeLocale (iso8601DateFormat Nothing) day+#endif++-- | Pretty print a 'Date' and an optional time to reflect the actual+-- date.+ppDate :: Time -> IO String+ppDate Time{ date, tod } = do+  curTime <- getCurrentTime+  let curDay      = utctDay curTime+      (y, m, _)   = toGregorian curDay+      diffToDay d = diffBetween d (dayOfWeek curDay)++  pure . toOrgFmt tod $ case date of+    Today              -> curDay+    Tomorrow           -> utctDay $ addDays 1 curTime+    Next wday          -> utctDay $ addDays (diffToDay wday) curTime+    Date (d, mbM, mbY) -> fromGregorian (fromMaybe y mbY) (fromMaybe m mbM) d+ where+  -- | Add a specified number of days to a 'UTCTime'.+  addDays :: NominalDiffTime -> UTCTime -> UTCTime+    = addUTCTime . (* nominalDay)++  -- | Evil enum hackery.+  diffBetween :: DayOfWeek -> DayOfWeek -> NominalDiffTime+  diffBetween d cur  -- we want to jump to @d@+    | d == cur  = 7+    | otherwise = fromIntegral . abs $ (fromEnum d - fromEnum cur) `mod` 7++-- Old GHC versions don't have a @time@ library new enough to have+-- this, so replicate it here for the moment.++dayOfWeek :: Day -> DayOfWeek+dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3++data DayOfWeek+  = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday+  deriving (Eq, Ord, Show)++-- | \"Circular\", so for example @[Tuesday ..]@ gives an endless+-- sequence.  Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday],+-- and 'toEnum' performs mod 7 to give a cycle of days.+instance Enum DayOfWeek where+  toEnum :: Int -> DayOfWeek+  toEnum i = case mod i 7 of+    0 -> Sunday+    1 -> Monday+    2 -> Tuesday+    3 -> Wednesday+    4 -> Thursday+    5 -> Friday+    _ -> Saturday++  fromEnum :: DayOfWeek -> Int+  fromEnum = \case+    Monday    -> 1+    Tuesday   -> 2+    Wednesday -> 3+    Thursday  -> 4+    Friday    -> 5+    Saturday  -> 6+    Sunday    -> 7++------------------------------------------------------------------------+-- Note++-- | An @org-mode@ style note.+data Note+  = Scheduled String Time Priority+  | Deadline  String Time Priority+  | NormalMsg String      Priority+  deriving (Eq, Show)++-- | An @org-mode@ style priority symbol[1]; e.g., something like+-- @[#A]@.  Note that this uses the standard org conventions: supported+-- priorities are @A@, @B@, and @C@, with @A@ being the highest.+-- Numerical priorities are not supported.+--+-- [1]: https://orgmode.org/manual/Priorities.html+data Priority = A | B | C | NoPriority+  deriving (Eq, Show)++-- | Pretty print a given 'Note'.+ppNote :: Clp -> String -> Note -> IO String+ppNote clp todo = \case+  Scheduled str time prio -> mkLine str "SCHEDULED: " (Just time) prio+  Deadline  str time prio -> mkLine str "DEADLINE: "  (Just time) prio+  NormalMsg str      prio -> mkLine str ""            Nothing     prio+ where+  mkLine :: String -> String -> Maybe Time -> Priority -> IO String+  mkLine str sched time prio = do+    t <- case time of+      Nothing -> pure ""+      Just ti -> (("\n  " <> sched) <>) <$> ppDate ti+    pure $ "* " <> todo <> priority <> case clp of+      Body   c -> mconcat [str, t, c]+      Header c -> mconcat ["[[", c, "][", str,"]]", t]+   where+    priority = case prio of+      NoPriority -> " "+      otherPrio  -> " [#" <> show otherPrio <> "] "++------------------------------------------------------------------------+-- Note parsing++-- | Parse the given string into a 'Note'.+pInput :: String -> Maybe Note+pInput inp = (`runParser` inp) . choice $+  [ Scheduled <$> (getLast "+s" <* " ") <*> join (fixTime <$> pDate <*> pOrgTime) <*> pPriority+  , Deadline  <$> (getLast "+d" <* " ") <*> join (fixTime <$> pDate <*> pOrgTime) <*> pPriority+  , do s <- munch1 (pure True)+       let (s', p) = splitAt (length s - 3) s+       pure $ case tryPrio p of+         Just prio -> NormalMsg (dropStripEnd 0 s') prio+         Nothing   -> NormalMsg s                   NoPriority+  ]+ where+  fixTime :: Maybe Date -> Maybe OrgTime -> Parser Time+  fixTime d tod = case (d, tod) of+    (Nothing, Nothing) -> mempty                -- no day and no time+    (Nothing, Just{})  -> pure (Time Today tod) -- no day, but a time+    (Just d', _)       -> pure (Time d'    tod) -- day given++  tryPrio :: String -> Maybe Priority+  tryPrio [' ', '#', x]+    | x `elem` ("Aa" :: String) = Just A+    | x `elem` ("Bb" :: String) = Just B+    | x `elem` ("Cc" :: String) = Just C+  tryPrio _ = Nothing++  -- Trim whitespace at the end of a string after dropping some number+  -- of characters from it.+  dropStripEnd :: Int -> String -> String+  dropStripEnd n = reverse . dropWhile (== ' ') . drop n . reverse++  getLast :: String -> Parser String+  getLast ptn =  dropStripEnd (length ptn) -- drop only the last pattern before stripping+              .  concat+             <$> endBy1 (go "") (pure ptn)+   where+    go :: String -> Parser String+    go consumed = do+      str  <- munch  (/= NE.head (notEmpty ptn))+      word <- munch1 (/= ' ')+      bool go pure (word == ptn) $ consumed <> str <> word++-- | Parse a 'Priority'.+pPriority :: Parser Priority+pPriority = option NoPriority $+  skipSpaces *> choice+    [ "#" *> foldCase "a" $> A+    , "#" *> foldCase "b" $> B+    , "#" *> foldCase "c" $> C+    ]++-- | Try to parse a 'Time'.+pOrgTime :: Parser (Maybe OrgTime)+pOrgTime = option Nothing $+  between skipSpaces (void " " <|> eof) $+    Just <$> choice+      [ TimeSpan <$> (pTimeOfDay <* ("--" <|> "-" <|> "–")) <*> pTimeOfDay+      -- Org is not super smart around times with this syntax, so+      -- we pretend not to be as well.+      , do from@(HHMM h m) <- pTimeOfDay <* "+"+           off <- pHour+           pure $ TimeSpan from (HHMM (h + off) m)+      , MomentInTime <$> pTimeOfDay+      ]+ where+  pTimeOfDay :: Parser TimeOfDay+  pTimeOfDay = choice+    [ HHMM <$> pHour <* ":" <*> pMinute -- HH:MM+    , pHHMM                             -- HHMM+    , HHMM <$> pHour        <*> pure 0  -- HH+    ]++  pHHMM :: Parser TimeOfDay+  pHHMM = do+    let getTwo = count 2 (satisfy isDigit)+    hh <- read <$> getTwo+    guard (hh >= 0 && hh <= 23)+    mm <- read <$> getTwo+    guard (mm >= 0 && mm <= 59)+    pure $ HHMM hh mm++  pHour   :: Parser Int = pNumBetween 0 23+  pMinute :: Parser Int = pNumBetween 0 59++-- | Try to parse a 'Date'.+pDate :: Parser (Maybe Date)+pDate = skipSpaces *> optional (choice+  [ pPrefix "tod" "ay"    Today+  , pPrefix "tom" "orrow" Tomorrow+  , Next <$> pNext+  , Date <$> pDate'+  ])+ where+  pNext :: Parser DayOfWeek = choice+    [ pPrefix "m"  "onday"    Monday   , pPrefix "tu" "esday"  Tuesday+    , pPrefix "w"  "ednesday" Wednesday, pPrefix "th" "ursday" Thursday+    , pPrefix "f"  "riday"    Friday   , pPrefix "sa" "turday" Saturday+    , pPrefix "su" "nday"     Sunday+    ]++  numWithoutColon :: Parser Int+  numWithoutColon = do+    str <- pNumBetween 1 12 -- month+    c <- get+    if c == ':'+    then pfail+    else pure str++  pDate' :: Parser (Int, Maybe Int, Maybe Integer)+  pDate' =+    (,,) <$> (pNumBetween 1 31 <* (void " " <|> eof))  -- day+         <*> optional (skipSpaces *> choice+               [ pPrefix "ja"  "nuary"    1 , pPrefix "f"   "ebruary" 2+               , pPrefix "mar" "ch"       3 , pPrefix "ap"  "ril"     4+               , pPrefix "may" ""         5 , pPrefix "jun" "e"       6+               , pPrefix "jul" "y"        7 , pPrefix "au"  "gust"    8+               , pPrefix "s"   "eptember" 9 , pPrefix "o"   "ctober"  10+               , pPrefix "n"   "ovember"  11, pPrefix "d"   "ecember" 12+               , numWithoutColon+               ])+         <*> optional (skipSpaces *> num >>= \i -> guard (i >= 25) $> i)++  -- Parse a prefix and drop a potential suffix up to the next (space+  -- separated) word.  If successful, return @ret@.+  pPrefix :: String -> String -> a -> Parser a+  pPrefix start (map toLower -> leftover) ret = do+    void (foldCase start)+    l <- map toLower <$> munch (/= ' ')+    guard (l `isPrefixOf` leftover)+    pure ret++-- | Parse a number between @lo@ (inclusive) and @hi@ (inclusive).+pNumBetween :: Int -> Int -> Parser Int+pNumBetween lo hi = do+  n <- num+  n <$ guard (n >= lo && n <= hi)++-- Parse the given string case insensitively.+foldCase :: String -> Parser String+foldCase = traverse (\c -> char (toLower c) <|> char (toUpper c))++------------------------------------------------------------------------+-- File parsing++data Heading = Heading+  { level       :: Natural+    -- ^ Level of the Org heading; i.e., the number of leading stars.+  , headingText :: String+    -- ^ The heading text without its level.+  }++-- | Naïvely parse an Org file.  At this point, only the headings are+-- parsed into a non-nested list (ignoring parent-child relations); no+-- further analysis is done on the individual lines themselves.+pOrgFile :: Parser [Heading]+pOrgFile = many pHeading++pHeading :: Parser Heading+pHeading = skipSpaces *> do+  level       <- genericLength <$> munch1 (== '*') <* " "+  headingText <- pLine+  void $ many (pLine >>= \line -> guard (isNotHeading line) $> line) -- skip body+  pure Heading{..}++pLine :: Parser String+pLine = munch (/= '\n') <* "\n"++isNotHeading :: String -> Bool+isNotHeading str = case break (/= '*') str of+  ("", _)       -> True+  (_ , ' ' : _) -> False+  _             -> True
+ XMonad/Prompt/Pass.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Prompt.Pass+-- Description :  A prompt for interacting with @pass(1)@.+-- Copyright   :  (c) 2014 Igor Babuschkin, Antoine R. Dumont+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Antoine R. Dumont <eniotna.t@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- A thin wrapper around the standard @pass(1)@ UNIX utility.+--+-- This module provides several prompts to ease password manipulation+-- (generate, read, edit, remove); all of them benefit from the+-- completion system provided by "XMonad.Prompt".  Specifically, we+-- provide+--+-- - various functions to lookup passwords in the password-store:+--+--     + 'passPrompt' copies the password directly to the clipboard.+--+--     + 'passOTPPrompt' copies a one-time-password to the clipboard+--        (this uses <https://github.com/tadfisher/pass-otp pass-otp>).+--+--     + 'passTypePrompt' and 'passOTPTypePrompt' work like the above,+--       respectively, but use @xdotool@ to type out the password.+--+-- - 'passGeneratePrompt' generates a password for a given password+--   label that the user inputs.+--+-- - 'passEditPrompt' edits a password for a given password label that+--   the user inputs.+--+-- - 'passRemovePrompt' deletes a stored password for a given password+--   label that the user inputs.+--+-- 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 <https://www.passwordstore.org/ password store>+--   implementation is <http://git.zx2c4.com/password-store here>.+--+-- - Inspired by <http://babushk.in/posts/combining-xmonad-and-pass.html>+--+-----------------------------------------------------------------------------++module XMonad.Prompt.Pass+    ( -- * Usage+      -- $usage++      -- * Retrieving passwords+      passPrompt+    , passPrompt'+    , passTypePrompt++      -- * Editing passwords+    , passEditPrompt+    , passEditPrompt'+    , passRemovePrompt+    , passRemovePrompt'+    , passGeneratePrompt+    , passGeneratePrompt'+    , passGenerateAndCopyPrompt+    , passGenerateAndCopyPrompt'++      -- * One-time-passwords+    , passOTPPrompt+    , passOTPTypePrompt+    ) where++import System.Directory (getHomeDirectory)+import System.FilePath (dropExtension, (</>))+import System.Posix.Env (getEnv)+import XMonad+import XMonad.Prelude+import XMonad.Prompt+  ( XPConfig,+    XPrompt,+    commandToComplete,+    getNextCompletion,+    mkXPrompt,+    nextCompletion,+    searchPredicate,+    showXPrompt,+  )+import XMonad.Util.Run (runProcessWithInput)++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Prompt.Pass+--+-- Then add a keybinding for 'passPrompt', 'passGeneratePrompt',+-- 'passRemovePrompt', 'passEditPrompt' or 'passTypePrompt':+--+-- >   , ((modMask , xK_p)                              , passPrompt def)+-- >   , ((modMask .|. controlMask, xK_p)               , passGeneratePrompt def)+-- >   , ((modMask .|. shiftMask, xK_p)                 , passEditPrompt def)+-- >   , ((modMask .|. controlMask  .|. shiftMask, xK_p), passRemovePrompt def)+--+-- You can also use the versions that let you specify a custom prompt:+--+-- >   , ((modMask , xK_p)                              , passPrompt' "Ask 'pass' for" def)+--+-- Note that, by default, we do not use fuzzy matching in this module.+-- To enable this feature, import the "XMonad.Prompt.FuzzyMatch" module+-- and add the relevant functions to your prompt configuration:+--+-- > myXPConfig :: XPConfig+-- > myXPConfig = def+-- >   { searchPredicate = fuzzyMatch+-- >   , sorter          = fuzzySort+-- >   }+-- >+-- > , ((modMask , xK_p), passPrompt myXPConfig)+--+-- For detailed instructions on:+--+-- - editing your key bindings, see <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.+--+-- - how to setup the password store, see <http://git.zx2c4.com/password-store/about/>+--   or @man 1 pass@.+--++---------------------------------------------------------------------------------+-- Prompt++type PromptLabel = String++newtype Pass = Pass PromptLabel++instance XPrompt Pass where+  showXPrompt       (Pass prompt) = prompt ++ ": "+  commandToComplete _ c           = c+  nextCompletion      _           = getNextCompletion++-- | A prompt to retrieve a password from a given entry.+--+passPrompt :: XPConfig -> X ()+passPrompt = passPrompt' "Select password"++-- | The same as 'passPrompt' but with a user-specified prompt.+passPrompt' :: String -> XPConfig -> X ()+passPrompt' s = mkPassPrompt s selectPassword++-- | A prompt to retrieve a OTP from a given entry.  Note that you will+-- need to use the <https://github.com/tadfisher/pass-otp pass-otp>+-- extension for this to work.+--+passOTPPrompt :: XPConfig -> X ()+passOTPPrompt = mkPassPrompt "Select OTP" selectOTP++-- | A prompt to retrieve a OTP from a given entry.  Note that you will+-- need to use the <https://github.com/tadfisher/pass-otp pass-otp>+-- extension for this to work.+--+passOTPTypePrompt :: XPConfig -> X ()+passOTPTypePrompt = mkPassPrompt "Select OTP" selectOTPType++-- | A prompt to generate a password for a given entry.+-- This can be used to override an already stored entry.+-- (Beware that no confirmation is asked)+--+passGeneratePrompt :: XPConfig -> X ()+passGeneratePrompt = passGeneratePrompt' "Generate password"++-- | The same as 'passGeneratePrompt' but with a user-specified prompt.+passGeneratePrompt' :: String -> XPConfig -> X ()+passGeneratePrompt' s = mkPassPrompt s generatePassword++-- | A prompt to generate a password for a given entry and immediately copy it+-- to the clipboard.  This can be used to override an already stored entry.+-- (Beware that no confirmation is asked)+--+passGenerateAndCopyPrompt :: XPConfig -> X ()+passGenerateAndCopyPrompt = passGenerateAndCopyPrompt' "Generate and copy password"++-- | The same as 'passGenerateAndCopyPrompt' but with a user-specified prompt.+passGenerateAndCopyPrompt' :: String -> XPConfig -> X ()+passGenerateAndCopyPrompt' s = mkPassPrompt s generateAndCopyPassword++-- | A prompt to remove a password for a given entry.+-- (Beware that no confirmation is asked)+--+passRemovePrompt :: XPConfig -> X ()+passRemovePrompt = passRemovePrompt' "Remove password"++-- | The same as 'passRemovePrompt' but with a user-specified prompt.+passRemovePrompt' :: String -> XPConfig -> X ()+passRemovePrompt' s = mkPassPrompt s 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 = passEditPrompt' "Edit password"++-- | The same as 'passEditPrompt' but with a user-specified prompt.+passEditPrompt' :: String -> XPConfig -> X ()+passEditPrompt' s = mkPassPrompt s editPassword++-- | A pass prompt factory.+--+mkPassPrompt :: PromptLabel -> (String -> X ()) -> XPConfig -> X ()+mkPassPrompt promptLabel passwordFunction xpconfig = do+  passwords <- io (passwordStoreFolder >>= getPasswords)+  mkXPrompt (Pass promptLabel)+            xpconfig+            (getPassCompl passwords $ searchPredicate xpconfig)+            passwordFunction+ where+  getPassCompl :: [String] -> (String -> String -> Bool) -> String -> IO [String]+  getPassCompl compls p s = return $ filter (p s) compls++  -- Compute the password store's location. Use the @$PASSWORD_STORE_DIR@+  -- environment variable to set the password store. If empty, return the+  -- password store located in user's home.+  passwordStoreFolder :: IO String+  passwordStoreFolder =+    getEnv "PASSWORD_STORE_DIR" >>= computePasswordStoreDir+   where+    -- Default password store folder in @$HOME/.password-store@.+    computePasswordStoreDir :: Maybe String -> IO String+    computePasswordStoreDir = \case+      Nothing       -> getHomeDirectory <&> (</> ".password-store")+      Just storeDir -> return storeDir++  -- Retrieve the list of passwords from the password store @passwordStoreDir@.+  getPasswords :: FilePath -> IO [String]+  getPasswords passwordStoreDir = do+    files <- runProcessWithInput "find" [+      "-L", -- Traverse symlinks+      passwordStoreDir,+      "-type", "f",+      "-name", "*.gpg",+      "-printf", "%P\n"] []+    return . map dropExtension $ lines files++---------------------------------------------------------------------------------+-- Selecting a password++-- | Select a password.+--+selectPassword :: String -> X ()+selectPassword = spawn . pass "--clip"++-- | Select a one-time-password and copy it to the clipboard.+--+selectOTP :: String -> X ()+selectOTP = spawn . pass "otp --clip"++-- | Select a one-time-password and type it out.+--+selectOTPType :: String -> X ()+selectOTPType = spawn . typeString . pass "otp"++-- | 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"++-- | Generate a 30 characters password for a given entry.+-- If the entry already exists, it is updated with a new password.+-- After generating the password, it is copied to the clipboard.+--+generateAndCopyPassword :: String -> X ()+generateAndCopyPassword passLabel = spawn $ pass "generate --force -c" passLabel ++ " 30"++-- | Remove a password stored for a given entry.+--+removePassword :: String -> X ()+removePassword = spawn . pass "rm --force"++-- | Edit a password stored for a given entry.+--+editPassword :: String -> X ()+editPassword = spawn . pass "edit"++-- | Type a password stored for a given entry using xdotool.+--+typePassword :: String -> X ()+typePassword = spawn . typeString . pass ""++-- | Type the given string with @xdotool@.+--+-- >>> typeString (pass "" "arXiv")+-- "pass  \"arXiv\" | head -n1 | tr -d '\n' | xdotool type --clearmodifiers --file -"+typeString :: String -> String+typeString cmd = cmd ++ " | head -n1 | tr -d '\n' | xdotool type --clearmodifiers --file -"++-- | Generate a pass prompt.+--+-- >>> pass "otp" "\\n'git'\"hub\""+-- "pass otp \"\\\\n'git'\\\"hub\\\"\""+pass :: String -> String -> String+pass cmd label = concat ["pass ", cmd, " \"", concatMap escape label, "\""]+ where+  escape :: Char -> String+  escape '"'  = "\\\""+  escape '\\' = "\\\\"+  escape x    = [x]
XMonad/Prompt/RunOrRaise.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.RunOrRaise+-- Description :  A prompt to run a program, open a file, or raise a running program. -- Copyright   :  (C) 2008 Justin Bogner -- License     :  BSD3 --@@ -21,30 +22,31 @@     ) where  import XMonad hiding (config)+import XMonad.Prelude import XMonad.Prompt import XMonad.Prompt.Shell import XMonad.Actions.WindowGo (runOrRaise) import XMonad.Util.Run (runProcessWithInput)  import Control.Exception as E-import Control.Monad (liftM, liftM2)-import System.Directory (doesDirectoryExist, doesFileExist, executable, getPermissions)+import System.Directory (doesDirectoryExist, doesFileExist, executable, findExecutable, getPermissions)  econst :: Monad m => a -> IOException -> m a econst = const . return  {- $usage-1. In your @~\/.xmonad\/xmonad.hs@:+1. In your @xmonad.hs@:  > import XMonad.Prompt > import XMonad.Prompt.RunOrRaise  2. In your keybindings add something like: ->   , ((modm .|. controlMask, xK_x), runOrRaisePrompt defaultXPConfig)+>   , ((modm .|. controlMask, xK_x), runOrRaisePrompt def)  For detailed instruction on editing the key binding see-"XMonad.Doc.Extending#Editing_key_bindings". -}+<https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.+-}  data RunOrRaisePrompt = RRP instance XPrompt RunOrRaisePrompt where@@ -52,22 +54,27 @@  runOrRaisePrompt :: XPConfig -> X () runOrRaisePrompt c = do cmds <- io getCommands-                        mkXPrompt RRP c (getShellCompl cmds) open+                        mkXPrompt RRP c (getShellCompl cmds $ searchPredicate c) open open :: String -> X () open path = io (isNormalFile path) >>= \b ->             if b             then spawn $ "xdg-open \"" ++ path ++ "\""             else uncurry runOrRaise . getTarget $ path     where-      isNormalFile f = exists f >>= \e -> if e then notExecutable f else return False-      exists f = fmap or $ sequence [doesFileExist f,doesDirectoryExist f]+      isNormalFile f = do+          notCommand <- isNothing <$> findExecutable f -- not a command (executable in $PATH)+          exists <- or <$> sequence [doesDirExist f, doesFileExist f]+          case (notCommand, exists) of+              (True, True) -> notExecutable f -- not executable as a file in current dir+              _            -> pure False       notExecutable = fmap (not . executable) . getPermissions+      doesDirExist f = ("/" `isSuffixOf` f &&) <$> doesDirectoryExist f       getTarget x = (x,isApp x)  isApp :: String -> Query Bool isApp "firefox"     = className =? "Firefox-bin"     <||> className =? "Firefox" isApp "thunderbird" = className =? "Thunderbird-bin" <||> className =? "Thunderbird"-isApp x = liftM2 (==) pid $ pidof x+isApp x = liftA2 (==) pid $ pidof x  pidof :: String -> Query Int pidof x = io $ (runProcessWithInput "pidof" [x] [] >>= readIO) `E.catch` econst 0@@ -75,7 +82,7 @@ pid :: Query Int pid = ask >>= (\w -> liftX $ withDisplay $ \d -> getPID d w)     where getPID d w = getAtom "_NET_WM_PID" >>= \a -> io $-                       liftM getPID' (getWindowProperty32 d a w)+                       fmap getPID' (getWindowProperty32 d a w)           getPID' (Just (x:_)) = fromIntegral x-          getPID' (Just [])     = -1-          getPID' (Nothing)     = -1+          getPID' (Just [])    = -1+          getPID' Nothing      = -1
XMonad/Prompt/Shell.hs view
@@ -1,5 +1,8 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns      #-} {- | Module      :  XMonad.Prompt.Shell+Description :  A shell prompt. Copyright   :  (C) 2007 Andrea Rossato License     :  BSD3 @@ -17,27 +20,31 @@     , shellPrompt     -- ** Variations on shellPrompt     -- $spawns-    , prompt     , safePrompt+    , safeDirPrompt     , unsafePrompt+    , prompt      -- * Utility functions+    , compgenDirectories+    , compgenFiles     , getCommands     , getBrowser     , getEditor     , getShellCompl+    , getShellCompl'     , split     ) where  import           Codec.Binary.UTF8.String (encodeString) import           Control.Exception        as E-import           Control.Monad            (forM)-import           Data.List                (isPrefixOf)-import           System.Directory         (doesDirectoryExist, getDirectoryContents)+import           Data.Bifunctor           (bimap)+import           System.Directory         (getDirectoryContents) import           System.Environment       (getEnv) import           System.Posix.Files       (getFileStatus, isDirectory)  import           XMonad                   hiding (config)+import           XMonad.Prelude import           XMonad.Prompt import           XMonad.Util.Run @@ -45,19 +52,21 @@ econst = const . return  {- $usage-1. In your @~\/.xmonad\/xmonad.hs@:+1. In your @xmonad.hs@:  > import XMonad.Prompt > import XMonad.Prompt.Shell  2. In your keybindings add something like: ->   , ((modm .|. controlMask, xK_x), shellPrompt defaultXPConfig)+>   , ((modm .|. controlMask, xK_x), shellPrompt def)  For detailed instruction on editing the key binding see-"XMonad.Doc.Extending#Editing_key_bindings". -}+<https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.+-}  data Shell = Shell+type Predicate = String -> String -> Bool  instance XPrompt Shell where     showXPrompt Shell     = "Run: "@@ -66,11 +75,11 @@ shellPrompt :: XPConfig -> X () shellPrompt c = do     cmds <- io getCommands-    mkXPrompt Shell c (getShellCompl cmds) spawn+    mkXPrompt Shell c (getShellCompl cmds $ searchPredicate c) spawn  {- $spawns     See safe and unsafeSpawn in "XMonad.Util.Run".-    prompt is an alias for safePrompt;+    prompt is an alias for unsafePrompt;     safePrompt and unsafePrompt work on the same principles, but will use     XPrompt to interactively query the user for input; the appearance is     set by passing an XPConfig as the second argument. The first argument@@ -87,46 +96,115 @@  prompt, unsafePrompt, safePrompt :: FilePath -> XPConfig -> X () prompt = unsafePrompt-safePrompt c config = mkXPrompt Shell config (getShellCompl [c]) run+safePrompt c config = mkXPrompt Shell config (getShellCompl [c] $ searchPredicate config) run     where run = safeSpawn c . return-unsafePrompt c config = mkXPrompt Shell config (getShellCompl [c]) run+unsafePrompt c config = mkXPrompt Shell config (getShellCompl [c] $ searchPredicate config) run     where run a = unsafeSpawn $ c ++ " " ++ a -getShellCompl :: [String] -> String -> IO [String]-getShellCompl cmds s | s == "" || last s == ' ' = return []-                     | otherwise                = do-    f     <- fmap lines $ runProcessWithInput "bash" [] ("compgen -A file -- "-                                                        ++ s ++ "\n")-    files <- case f of-               [x] -> do fs <- getFileStatus (encodeString x)-                         if isDirectory fs then return [x ++ "/"]-                                           else return [x]-               _   -> return f-    return . uniqSort $ files ++ commandCompletionFunction cmds s+{- | Like 'safePrompt', but optimized for the use-case of a program that+needs a file as an argument. -commandCompletionFunction :: [String] -> String -> [String]-commandCompletionFunction cmds str | '/' `elem` str = []-                                   | otherwise      = filter (isPrefixOf str) cmds+For example, a prompt for <https://github.com/mwh/dragon dragon> that+always starts searching in your home directory would look like +> safeDirPrompt "dragon" def "~/"++This is especially useful when using something like+'XMonad.Prompt.FuzzyMatch.fuzzyMatch' from "XMonad.Prompt.FuzzyMatch" as+your prompt's @searchPredicate@.+-}+safeDirPrompt+    :: FilePath  -- ^ The command to execute+    -> XPConfig  -- ^ The prompt configuration+    -> String    -- ^ Which string to start @compgen@ with+    -> X ()+safeDirPrompt cmd cfg@XPC{ searchPredicate } compgenStr =+    mkXPrompt Shell cfg mkCompl (safeSpawn cmd . pure)+  where+    mkCompl :: String -> IO [String]+    mkCompl input =+        shellComplImpl+            CaseSensitive+            (filter (searchPredicate ext))+            (commandCompletionFunction [cmd] searchPredicate input)+            (if "/" `isInfixOf` input then dir else compgenStr)+            input+      where+        -- "/path/to/some/file" ⇒ ("file", "/path/to/some/")+        (ext, dir) :: (String, String)+            = bimap reverse reverse . break (== '/') . reverse $ input++getShellCompl :: [String] -> Predicate -> String -> IO [String]+getShellCompl = getShellCompl' CaseSensitive++getShellCompl' :: ComplCaseSensitivity -> [String] -> Predicate -> String -> IO [String]+getShellCompl' csn cmds p input =+    shellComplImpl csn id (commandCompletionFunction cmds p input) input input++-- | Based in the user input and the given filtering function, create+-- the completion string to show in the prompt.+shellComplImpl+    :: ComplCaseSensitivity    -- ^ Whether the @compgen@ query should be case sensitive+    -> ([String] -> [String])  -- ^ How to filter the files we get back+    -> [String]                -- ^ The available commands to suggest+    -> String                  -- ^ Which string to give to @compgen@+    -> String                  -- ^ The input string+    -> IO [String]+shellComplImpl csn filterFiles cmds cmpgenStr input+    | input == "" || last input == ' ' = pure []+    | otherwise = do+        choices <- filterFiles . lines <$> compgenFiles csn cmpgenStr+        files   <- case choices of+            [x] -> do fs <- getFileStatus (encodeString x)+                      pure $ if isDirectory fs then [x ++ "/"] else [x]+            _   -> pure choices+        pure . sortBy typedFirst . uniqSort $ files ++ cmds+  where+    typedFirst :: String -> String -> Ordering+    typedFirst x y+        | x `startsWith` input && not (y `startsWith` input) = LT+        | y `startsWith` input && not (x `startsWith` input) = GT+        | otherwise = x `compare` y++    startsWith :: String -> String -> Bool+    startsWith str ps = map toLower ps `isPrefixOf` map toLower str++compgenFiles :: ComplCaseSensitivity -> String -> IO String+compgenFiles csn = compgen csn "file"++compgenDirectories :: ComplCaseSensitivity -> String -> IO String+compgenDirectories csn = compgen csn "directory"++compgen :: ComplCaseSensitivity -> String -> String -> IO String+compgen csn actionOpt s = runProcessWithInput "bash" [] $+    complCaseSensitivityCmd csn ++ " ; " ++ compgenCmd actionOpt s++complCaseSensitivityCmd :: ComplCaseSensitivity -> String+complCaseSensitivityCmd CaseSensitive =+    "bind 'set completion-ignore-case off'"+complCaseSensitivityCmd CaseInSensitive =+    "bind 'set completion-ignore-case on'"++compgenCmd :: String -> String -> String+compgenCmd actionOpt s = "compgen -A " ++ actionOpt ++ " -- " ++ s ++ "\n"++commandCompletionFunction :: [String] -> Predicate -> String -> [String]+commandCompletionFunction cmds p str | '/' `elem` str = []+                                     | otherwise      = filter (p str) cmds+ getCommands :: IO [String] getCommands = do     p  <- getEnv "PATH" `E.catch` econst []     let ds = filter (/= "") $ split ':' p-    es <- forM ds $ \d -> do-        exists <- doesDirectoryExist d-        if exists-            then getDirectoryContents d-            else return []-    return . uniqSort . filter ((/= '.') . head) . concat $ es+    es <- forM ds $ \d -> getDirectoryContents d `E.catch` econst []+    return . uniqSort . filter (not . ("." `isPrefixOf`)) . concat $ es  split :: Eq a => a -> [a] -> [[a]] split _ [] = [] split e l =-    f : split e (rest ls)+    f : split e (drop 1 ls)         where           (f,ls) = span (/=e) l-          rest s | s == []   = []-                 | otherwise = tail s  escape :: String -> String escape []       = ""
XMonad/Prompt/Ssh.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Ssh+-- Description :  An ssh prompt. -- Copyright   :  (C) 2007 Andrea Rossato -- License     :  BSD3 --@@ -20,6 +21,7 @@     ) where  import XMonad+import XMonad.Prelude import XMonad.Util.Run import XMonad.Prompt @@ -27,45 +29,45 @@ import System.Environment import Control.Exception as E -import Control.Monad-import Data.Maybe- econst :: Monad m => a -> IOException -> m a econst = const . return  -- $usage--- 1. In your @~\/.xmonad\/xmonad.hs@:+-- 1. In your @xmonad.hs@: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.Ssh -- -- 2. In your keybindings add something like: ----- >   , ((modm .|. controlMask, xK_s), sshPrompt defaultXPConfig)+-- >   , ((modm .|. controlMask, xK_s), sshPrompt def) -- -- Keep in mind, that if you want to use the completion you have to--- disable the "HashKnownHosts" option in your ssh_config+-- disable the \"HashKnownHosts\" option in your ssh_config -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  data Ssh = Ssh  instance XPrompt Ssh where     showXPrompt       Ssh = "SSH to: "-    commandToComplete _ c = c-    nextCompletion      _ = getNextCompletion+    commandToComplete _ c = maybe c snd (parseHost c)+    nextCompletion _t c l = maybe next (\(u,_h) -> u ++ "@" ++ next) hostPared+                            where+                              hostPared = parseHost c+                              next = getNextCompletion (maybe c snd hostPared) l  sshPrompt :: XPConfig -> X () sshPrompt c = do   sc <- io sshComplList-  mkXPrompt Ssh c (mkComplFunFromList sc) ssh+  mkXPrompt Ssh c (mkComplFunFromList c sc) ssh  ssh :: String -> X () ssh = runInTerm "" . ("ssh " ++ )  sshComplList :: IO [String]-sshComplList = uniqSort `fmap` liftM2 (++) sshComplListLocal sshComplListGlobal+sshComplList = uniqSort <$> liftA2 (++) sshComplListLocal sshComplListGlobal  sshComplListLocal :: IO [String] sshComplListLocal = do@@ -135,3 +137,6 @@                    ']':':':x -> x                    _         -> "22" getWithPort  str = str++parseHost :: String -> Maybe (String, String)+parseHost a = elemIndex '@' a  >>= (\c-> Just ( take c a, drop (c+1) a ) )
XMonad/Prompt/Theme.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Theme+-- Description :  A prompt for changing the theme of the current workspace. -- Copyright   :  (C) 2007 Andrea Rossato -- License     :  BSD3 --@@ -20,7 +21,7 @@  import Control.Arrow ( (&&&) ) import qualified Data.Map as M-import Data.Maybe ( fromMaybe )+import XMonad.Prelude ( fromMaybe ) import XMonad import XMonad.Prompt import XMonad.Layout.Decoration@@ -28,17 +29,17 @@  -- $usage -- You can use this module with the following in your--- @~\/.xmonad\/xmonad.hs@:+-- @xmonad.hs@: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.Theme -- -- in your keybindings add: ----- >   , ((modm .|. controlMask, xK_t), themePrompt defaultXPConfig)+-- >   , ((modm .|. controlMask, xK_t), themePrompt def) -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.  data ThemePrompt = ThemePrompt @@ -48,8 +49,8 @@     nextCompletion      _ = getNextCompletion  themePrompt :: XPConfig -> X ()-themePrompt c = mkXPrompt ThemePrompt c (mkComplFunFromList' . map ppThemeInfo $ listOfThemes) changeTheme-    where changeTheme t = sendMessage . SetTheme . fromMaybe defaultTheme $ M.lookup t mapOfThemes+themePrompt c = mkXPrompt ThemePrompt c (mkComplFunFromList' c . map ppThemeInfo $ listOfThemes) changeTheme+    where changeTheme t = sendMessage . SetTheme . fromMaybe def $ M.lookup t mapOfThemes  mapOfThemes :: M.Map String Theme mapOfThemes = M.fromList . uncurry zip . (map ppThemeInfo &&& map theme) $ listOfThemes
+ XMonad/Prompt/Unicode.hs view
@@ -0,0 +1,134 @@+{- |+Module      :  XMonad.Prompt.Unicode+Description :  A prompt for inputting Unicode characters.+Copyright   :  (c) 2016 Joachim Breitner+                   2017 Nick Hu+License     :  BSD-style (see LICENSE)++Maintainer  :  <mail@joachim-breitner.de>+Stability   :  stable++A prompt for searching unicode characters by name and inserting them into+the clipboard.++The provided @unicodePrompt@ and @typeUnicodePrompt@ use @xsel@ and @xdotool@+respectively.+-}++module XMonad.Prompt.Unicode (+ -- * Usage+ -- $usage+ unicodePrompt,+ typeUnicodePrompt,+ mkUnicodePrompt+ ) where++import Codec.Binary.UTF8.String (decodeString)+import qualified Data.ByteString.Char8 as BS+import Numeric+import System.IO+import System.IO.Error+import Text.Printf++import XMonad+import XMonad.Prelude+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, String)] }+  deriving (Read, Show)++instance ExtensionClass UnicodeData where+  initialValue = UnicodeData []+  extensionType = StateExtension++{- $usage++You can use this module by importing it, along with+"XMonad.Prompt", into your @xmonad.hs@ file:++> import XMonad.Prompt+> import XMonad.Prompt.Unicode++and adding an appropriate keybinding, for example:++>  , ((modm .|. controlMask, xK_u), unicodePrompt "/path/to/unicode-data" def)++A path to a @UnicodeData.txt@ file or equivalent must be provided.  This file+should be available through your package manager; search for @unicode-data@.+If no package is found, one may opt to download this file directly from+[unicode.org](http://www.unicode.org/Public/UNIDATA/UnicodeData.txt).++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.+-}++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 . sortOn (length . snd) $ parseUnicodeData dat+          return True+    else return True++parseUnicodeData :: BS.ByteString -> [(Char, String)]+parseUnicodeData = mapMaybe parseLine . BS.lines+  where parseLine l = do+          field1 : field2 : _ <- return $ BS.split ';' l+          [(c,"")] <- return . readHex $ BS.unpack field1+          desc <- return . decodeString $ BS.unpack field2+          return (chr c, desc)++type Predicate = String -> String -> Bool++searchUnicode :: [(Char, String)] -> Predicate -> String -> [(Char, String)]+searchUnicode entries p s = filter go entries+  where w = filter ((> 1) . length) . words $ map toUpper s+        go (_, d) = all (`p` d) w++mkUnicodePrompt :: String -> [String] -> String -> XPConfig -> X ()+mkUnicodePrompt prog args unicodeDataFilename xpCfg =+  whenX (populateEntries unicodeDataFilename) $ do+    entries <- fmap getUnicodeData (XS.get :: X UnicodeData)+    mkXPrompt+      Unicode+      (xpCfg {sorter = sorter xpCfg . map toUpper})+      (unicodeCompl entries $ searchPredicate xpCfg)+      paste+  where+    unicodeCompl :: [(Char, String)] -> Predicate -> String -> IO [String]+    unicodeCompl _ _ "" = return []+    unicodeCompl entries p s = do+      let m = searchUnicode entries p s+      return . map (\(c,d) -> printf "%s %s" [c] d) $ take 20 m+    paste [] = return ()+    paste (c:_) = liftIO $ do+      handle <- spawnPipe $ unwords $ prog : args+      hPutChar handle c+      hClose handle+      return ()++-- | 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", "-"]
XMonad/Prompt/Window.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Window+-- Description :  A prompt for bringing windows to you, and bring you to windows. -- Copyright   :  Devin Mullins <me@twifkak.com> --                Andrea Rossato <andrea.rossato@unibz.it> -- License     :  BSD-style (see LICENSE)@@ -18,12 +19,16 @@     (     -- * Usage     -- $usage-    windowPromptGoto,-    windowPromptBring,-    windowPromptBringCopy,-    WindowPrompt,+    WindowPrompt(..),+    windowPrompt,+    windowMultiPrompt,+    allWindows,+    allApplications,+    wsWindows,+    XWindowMap,     ) where +import XMonad.Prelude (forM) import qualified Data.Map as M  import qualified XMonad.StackSet as W@@ -31,66 +36,127 @@ import XMonad.Prompt import XMonad.Actions.CopyWindow import XMonad.Actions.WindowBringer+import XMonad.Util.NamedWindows  -- $usage--- WindowPrompt brings windows to you and you to windows.--- That is to say, it pops up a prompt with window names, in case you forgot--- where you left your XChat.+-- WindowPrompt brings windows to you and you to windows. That is to+-- say, it pops up a prompt with window names, in case you forgot+-- where you left your XChat. It also offers helpers to build the+-- subset of windows which is used for the prompt completion. ----- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.Window -- -- and in the keys definition: ----- > , ((modm .|. shiftMask, xK_g     ), windowPromptGoto  defaultXPConfig)--- > , ((modm .|. shiftMask, xK_b     ), windowPromptBring defaultXPConfig)+-- > , ((modm .|. shiftMask, xK_g     ), windowPrompt def Goto wsWindows)+-- > , ((modm .|. shiftMask, xK_b     ), windowPrompt def Bring allWindows) -- -- The autoComplete option is a handy complement here: ----- > , ((modm .|. shiftMask, xK_g     ), windowPromptGoto--- >                                            defaultXPConfig { autoComplete = Just 500000 } )+-- > , ((modm .|. shiftMask, xK_g     ), windowPrompt+-- >                                        def { autoComplete = Just 500000 }+-- >                                        Goto allWindows) -- -- The \'500000\' is the number of microseconds to pause before sending you to -- your new window. This is useful so that you don't accidentally send some -- keystrokes to the selected client. -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data WindowPrompt = Goto | Bring | BringCopy+-- Describe actions that can applied  on the selected window+data WindowPrompt = Goto | Bring | BringCopy | BringToMaster | WithWindow String (Window ->  X()) instance XPrompt WindowPrompt where     showXPrompt Goto      = "Go to window: "     showXPrompt Bring     = "Bring window: "+    showXPrompt BringToMaster+                          = "Bring window to master: "     showXPrompt BringCopy = "Bring a copy: "+    showXPrompt (WithWindow xs _) = xs     commandToComplete _ c = c     nextCompletion      _ = getNextCompletion -windowPromptGoto, windowPromptBring, windowPromptBringCopy :: XPConfig -> X ()-windowPromptGoto  = doPrompt Goto-windowPromptBring = doPrompt Bring-windowPromptBringCopy = doPrompt BringCopy+-- | Internal type used for the multiple mode prompt.+data WindowModePrompt =+  WindowModePrompt WindowPrompt (M.Map String Window) (String -> String -> Bool) --- | Pops open a prompt with window titles. Choose one, and you will be--- taken to the corresponding workspace.-doPrompt :: WindowPrompt -> XPConfig -> X ()-doPrompt t c = do-  a <- case t of-         Goto  -> fmap gotoAction  windowMap-         Bring -> fmap bringAction windowMap-         BringCopy -> fmap bringCopyAction windowMap-  wm <- windowMap-  mkXPrompt t c (compList wm) a+instance XPrompt WindowModePrompt where+    showXPrompt (WindowModePrompt action _ _) =+        showXPrompt action +    completionFunction (WindowModePrompt _ winmap predicate) s =+        return . filter (predicate s) . map fst . M.toList $ winmap++    modeAction (WindowModePrompt action winmap _) buf auto = do+        let name = if null auto then buf else auto+            a = case action of+                  Goto           -> gotoAction+                  Bring          -> bringAction+                  BringCopy      -> bringCopyAction+                  BringToMaster  -> bringToMaster+                  WithWindow _ f -> withWindow f+        a name+      where+        withWindow f     = flip whenJust f . flip M.lookup winmap+        winAction a      = withWindow (windows . a)+        gotoAction       = winAction W.focusWindow+        bringAction      = winAction bringWindow+        bringCopyAction  = winAction bringCopyWindow+        bringToMaster    = winAction (\w s -> W.shiftMaster . W.focusWindow w $ bringWindow w s)++-- | A helper to get the map of all windows.+allWindows :: XWindowMap+allWindows = windowMap++-- | A helper to get the map of all applications+allApplications :: XWindowMap+allApplications = windowAppMap++-- | A helper to get the map of windows of the current workspace.+wsWindows :: XWindowMap+wsWindows = withWindowSet (return . W.index) >>= winmap     where-      winAction a m    = flip whenJust (windows . a) . flip M.lookup m-      gotoAction       = winAction W.focusWindow-      bringAction      = winAction bringWindow-      bringCopyAction  = winAction bringCopyWindow+      winmap = fmap M.fromList . mapM pair+      pair w = do name <- show <$> getName w+                  return (name, w) -      compList m s = return . filter (searchPredicate c s) . map fst . M.toList $ m+-- | A Map where keys are pretty printable window names and values are+-- Xmonad windows identifier.+type XWindowMap = X (M.Map String Window) +-- | Pops open a prompt with window titles belonging to+-- winmap. Choose one, and an action is applied on the+-- selected window, according to WindowPrompt.+windowPrompt :: XPConfig -> WindowPrompt -> XWindowMap -> X ()+windowPrompt c t winmap = do+  wm <- winmap+  let mode     = WindowModePrompt t wm (searchPredicate c)+      action   = modeAction mode+      compList = completionFunction mode+  mkXPrompt t c compList (\s -> action s s)++-- | Like 'windowPrompt', but uses the multiple modes feature of+-- @Prompt@ (via 'mkXPromptWithModes').+--+-- Given a list of actions along with the windows they should work+-- with, display the appropriate prompt with the ability to switch+-- between them using the @changeModeKey@.+--+-- For example, to have a prompt that first shows you all windows, but+-- allows you to narrow the list down to just the windows on the+-- current workspace:+--+-- > windowMultiPrompt config [(Goto, allWindows), (Goto, wsWindows)]+windowMultiPrompt :: XPConfig -> [(WindowPrompt, XWindowMap)] -> X ()+windowMultiPrompt c modes = do+  modes' <- forM modes $ \(t, wm) -> do+    wm' <- wm+    return . XPT $ WindowModePrompt t wm' (searchPredicate c)++  mkXPromptWithModes modes' c  -- | Brings a copy of the specified window into the current workspace. bringCopyWindow :: Window -> WindowSet -> WindowSet
XMonad/Prompt/Workspace.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.Workspace+-- Description :  A workspace prompt. -- Copyright   :  (C) 2007 Andrea Rossato, David Roundy -- License     :  BSD3 --@@ -27,17 +28,17 @@ import XMonad.Util.WorkspaceCompare ( getSortByIndex )  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.Workspace ----- >   , ((modm .|. shiftMask, xK_m     ), workspacePrompt defaultXPConfig (windows . W.shift))+-- >   , ((modm .|. shiftMask, xK_m     ), workspacePrompt def (windows . W.shift)) -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data Wor = Wor String+newtype Wor = Wor String  instance XPrompt Wor where     showXPrompt (Wor x) = x@@ -46,4 +47,4 @@ workspacePrompt c job = do ws <- gets (workspaces . windowset)                            sort <- getSortByIndex                            let ts = map tag $ sort ws-                           mkXPrompt (Wor "") c (mkComplFunFromList' ts) job+                           mkXPrompt (Wor "") c (mkComplFunFromList' c ts) job
XMonad/Prompt/XMonad.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Prompt.XMonad+-- Description :  A prompt for running XMonad commands. -- Copyright   :  (C) 2007 Andrea Rossato -- License     :  BSD3 --@@ -17,31 +18,32 @@                              -- $usage                              xmonadPrompt,                              xmonadPromptC,+                             xmonadPromptCT,                              XMonad,                               ) where  import XMonad import XMonad.Prompt import XMonad.Actions.Commands (defaultCommands)-import Data.Maybe (fromMaybe)+import XMonad.Prelude (fromMaybe)  -- $usage--- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:+-- You can use this module with the following in your @xmonad.hs@: -- -- > import XMonad.Prompt -- > import XMonad.Prompt.XMonad -- -- in your keybindings add: ----- >   , ((modm .|. controlMask, xK_x), xmonadPrompt defaultXPConfig)+-- >   , ((modm .|. controlMask, xK_x), xmonadPrompt def) -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings".+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -data XMonad = XMonad+newtype XMonad = XMonad String  instance XPrompt XMonad where-    showXPrompt XMonad = "XMonad: "+    showXPrompt (XMonad str) = str <> ": "  xmonadPrompt :: XPConfig -> X () xmonadPrompt c = do@@ -50,6 +52,10 @@  -- | An xmonad prompt with a custom command list xmonadPromptC :: [(String, X ())] -> XPConfig -> X ()-xmonadPromptC commands c =-    mkXPrompt XMonad c (mkComplFunFromList' (map fst commands)) $+xmonadPromptC = xmonadPromptCT "XMonad"++-- | An xmonad prompt with a custom command list and a custom title+xmonadPromptCT :: String -> [(String, X ())] -> XPConfig -> X ()+xmonadPromptCT title' commands c =+    mkXPrompt (XMonad title') c (mkComplFunFromList' c (map fst commands)) $         fromMaybe (return ()) . (`lookup` commands)
+ XMonad/Prompt/Zsh.hs view
@@ -0,0 +1,64 @@+{- |+Module      :  XMonad.Prompt.Zsh+Description :  Zsh-specific version of "XMonad.Prompt.Shell".+Copyright   :  (C) 2020 Zubin Duggal+License     :  BSD3++Maintainer  :  zubin.duggal@gmail.com+Stability   :  unstable+Portability :  unportable++A version of "XMonad.Prompt.Shell" that lets you access the awesome power of Zsh+completions in your xmonad prompt+-}++module XMonad.Prompt.Zsh+    ( -- * Usage+      -- $usage+      Zsh (..)+    , zshPrompt+    -- * Utility functions+    , getZshCompl+    , stripZsh+    ) where++import XMonad+import XMonad.Prompt+import XMonad.Util.Run++{- $usage+1. Grab the @capture.zsh@ script to capture zsh completions from <https://github.com/Valodim/zsh-capture-completion>+2. In your @xmonad.hs@:++> import XMonad.Prompt+> import XMonad.Prompt.Zsh++3. In your keybindings add something like:++>   , ((modm .|. controlMask, xK_x), zshPrompt def "/path/to/capture.zsh")++For detailed instruction on editing the key binding see+<https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>. -}++data Zsh = Zsh++instance XPrompt Zsh where+    showXPrompt Zsh       = "Run: "+    completionToCommand _ = stripZsh+    commandToComplete _ s = s+    nextCompletion _ s cs = getNextCompletion s (map stripZsh cs)++zshPrompt :: XPConfig -> FilePath -> X ()+zshPrompt c capture = mkXPrompt Zsh c (getZshCompl capture) (\x -> safeSpawn "zsh" ["-c",x])++getZshCompl :: FilePath -> String -> IO [String]+getZshCompl capture s+  | s == ""   = return []+  | otherwise = processCompls <$> runProcessWithInput capture [s] ""+    where processCompls = map (\x -> skipLastWord s ++ filter (/= '\r') x) . lines++-- | Removes the argument description from the zsh completion+stripZsh :: String -> String+stripZsh "" = ""+stripZsh (' ':'-':'-':' ':_) = ""+stripZsh (x:xs) = x : stripZsh xs
+ XMonad/Util/ActionCycle.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.ActionCycle+-- Description :  Provides a way to implement cycling actions.+-- Copyright   :  (c) 2020 Leon Kowarschick+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Leon Kowarschick. <thereal.elkowar@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module provides a way to have "cycling" actions.+-- This means that you can define an @X ()@ action that cycles through a list of actions,+-- advancing every time it is executed.+-- This may for exapmle be useful for toggle-style keybindings.+--+-----------------------------------------------------------------------------++module XMonad.Util.ActionCycle+  ( -- * Usage+    -- $usage+    cycleAction+  , cycleActionWithResult+  )+where+import Prelude hiding ((!!))+import Data.Map.Strict as M+import XMonad+import qualified XMonad.Util.ExtensibleState as XS+import qualified Data.List.NonEmpty as NonEmpty+import Data.List.NonEmpty ((!!), NonEmpty((:|)))+++-- $usage+-- You can use this module to implement cycling key-bindings by importing "XMonad.Util.ActionCycle"+--+-- > import XMonad.Util.ActionCycle+--+-- and then creating a keybinding as follows:+--+-- > ((mod1Mask, xK_t), cycleAction "cycleActions" [ spawn "commmand1", spawn "command2", spawn "command3" ])+--+-- Note that the name given to cycleAction must be a unique action per cycle.+++-- | Generate an @X ()@ action that cycles through a list of actions,+-- advancing every time the action is called.+cycleAction+  :: String -- ^ Unique name for this action. May be any arbitrary, unique string.+  -> [X ()] -- ^ List of actions that will be cycled through.+  -> X ()+cycleAction _ [] = pure ()+cycleAction name (x:xs) = cycleActionWithResult name (x :| xs)++-- | Another version of 'cycleAction' that returns the result of the actions.+-- To allow for this, we must make sure that the list of actions is non-empty.+cycleActionWithResult+  :: String                   -- ^ Unique name for this action. May be any arbitrary, unique string.+  -> NonEmpty.NonEmpty (X a)  -- ^ Non-empty List of actions that will be cycled through.+  -> X a+cycleActionWithResult name actions = do+  cycleState <- XS.gets (getActionCycle name)+  idx <- case cycleState of+    Just x -> do+      XS.modify (nextActionCycle name (NonEmpty.length actions))+      pure x+    Nothing -> do+      XS.modify (setActionCycle name 1)+      pure 0+  actions !! idx+++newtype ActionCycleState = ActionCycleState (M.Map String Int)++instance ExtensionClass ActionCycleState where+  initialValue = ActionCycleState mempty++getActionCycle :: String -> ActionCycleState -> Maybe Int+getActionCycle name (ActionCycleState s) = M.lookup name s++nextActionCycle :: String -> Int -> ActionCycleState -> ActionCycleState+nextActionCycle name maxNum (ActionCycleState s) = ActionCycleState $ M.update (\n -> Just $ (n + 1) `mod` maxNum) name s++setActionCycle :: String -> Int -> ActionCycleState -> ActionCycleState+setActionCycle name n (ActionCycleState s) = ActionCycleState $ M.insert name n s
+ XMonad/Util/ActionQueue.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.ActionQueue+-- Description :  Queue of XMonad actions+-- Copyright   :  (c) 2021 Xiaokui Shu+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  subbyte@gmail.com+-- Stability   :  unstable+-- Portability :  unportable+--+-- Put XMonad actions in the queue to be executed in either the+-- @logHook@ or another hook of your choice.+-----------------------------------------------------------------------------++module XMonad.Util.ActionQueue ( -- * Usage+                                 -- $usage+                                 ActionQueue+                               , actionQueue+                               , enqueue+                               , exequeue+                               ) where++import XMonad+import qualified XMonad.Util.ExtensibleConf  as XC+import qualified XMonad.Util.ExtensibleState as XS++import Data.Sequence (Seq (..), ViewL (..), viewl, (|>))++-- $usage+--+-- This module provides a queue that, by default, gets executed every+-- time the @logHook@ runs.  To use this module+--+-- 1. Enqueue `X ()` actions at the place you need; e.g.:+--+-- > enqueue myAction+--+-- 2. Add the 'actionQueue' combinator to your configuration:+--+-- > main = xmonad $ actionQueue $ def+-- >     { ... }+--+-- This will execute all of the actions in the queue (if any) every time+-- the @logHook@ runs.  Developers of other extensions using this module+-- should re-export 'actionQueue'.+--+-- Alternatively, you can directly add 'exequeue' to a hook of your choice.+-- This is discouraged when writing user-facing modules, as (accidentally)+-- adding 'exequeue' to two different hooks might lead to undesirable+-- behaviour.  'actionQueue' uses the "XMonad.Util.ExtensibleConf" interface to+-- circumvent this.+--++newtype ActionQueue = ActionQueue (Seq (X ()))++instance ExtensionClass ActionQueue where+    initialValue = ActionQueue mempty++newtype ActionQueueHooked = ActionQueueHooked ()+  deriving newtype (Semigroup)++-- | Every time the @logHook@ runs, execute all actions in the queue.+actionQueue :: XConfig l -> XConfig l+actionQueue = XC.once (\cfg -> cfg{ logHook = logHook cfg <> exequeue })+                      ActionQueueHooked++-- | Enqueue an action.+enqueue :: X () -> X ()+enqueue = XS.modify . go+  where+    go :: X () -> ActionQueue -> ActionQueue+    go a (ActionQueue as) = ActionQueue $ as |> a++-- | Execute every action in the queue.+exequeue :: X ()+exequeue = do+    -- Note that we are executing all actions one by one.  Otherwise, we may+    -- not execute the actions in the right order.  Any of them may call+    -- 'refresh' or 'windows', which triggers the logHook, which may trigger+    -- 'exequeue' again if it is used in the logHook.+    ActionQueue aas <- XS.get+    case viewl aas of+      EmptyL  -> pure ()+      a :< as -> do XS.put (ActionQueue as)+                    a `catchX` pure ()+                    exequeue
+ XMonad/Util/ClickableWorkspaces.hs view
@@ -0,0 +1,83 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.ClickableWorkspaces+-- Description :  Make workspace tags clickable in XMobar (for switching focus).+-- Copyright   :  (c) Geoff deRosenroll <geoffderosenroll@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Geoff deRosenroll <geoffderosenroll@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides @clickablePP@, which when applied to the 'PP' pretty-printer used+-- by "XMonad.Hooks.StatusBar" will make the workspace tags clickable in+-- XMobar (for switching focus).+--+-----------------------------------------------------------------------------++module XMonad.Util.ClickableWorkspaces (+  -- * Usage+  -- $usage+  clickablePP,+  clickableWrap,+  ) where++import XMonad.Prelude ((<&>), (>=>))+import XMonad+import XMonad.Hooks.StatusBar.PP (xmobarAction, PP(..))+import XMonad.Util.WorkspaceCompare (getSortByIndex)+import qualified XMonad.StackSet as W+import Data.List (elemIndex)++-- $usage+-- If you're using the "XMonad.Hooks.StatusBar" interface, apply 'clickablePP'+-- to the 'PP' passed to 'XMonad.Hooks.StatusBar.statusBarProp':+--+-- > mySB <- statusBarProp "xmobar" (clickablePP xmobarPP)+--+-- Or if you're using the old "XMonad.Hooks.DynamicLog" interface:+--+-- > logHook = clickablePP xmobarPP { ... } >>= dynamicLogWithPP+--+-- Requirements:+--+--   * @xdotool@ on system (in path)+--   * "XMonad.Hooks.EwmhDesktops" for @xdotool@ support (see Hackage docs for setup)+--   * use of UnsafeStdinReader\/UnsafeXMonadLog in xmobarrc (rather than StdinReader\/XMonadLog)+--+-- Note that UnsafeStdinReader is potentially dangerous if your workspace+-- names are dynamically generated from untrusted input (like window titles).+-- You may need to add @xmobarRaw@ to 'ppRename' before applying+-- 'clickablePP' in such case.++-- | Wrap string with an xmobar action that uses @xdotool@ to switch to+-- workspace @i@.+clickableWrap :: Int -> String -> String+clickableWrap i = xmobarAction ("xdotool set_desktop " ++ show i) "1"++-- | 'XMonad.Util.WorkspaceCompare.getWsIndex' extended to handle workspaces+-- not in the static 'workspaces' config, such as those created by+-- "XMonad.Action.DynamicWorkspaces".+--+-- Uses 'getSortByIndex', as that's what "XMonad.Hooks.EwmhDesktops" uses to+-- export the information to tools like @xdotool@. (Note that EwmhDesktops can+-- be configured with a custom sort function, and we don't handle that here+-- yet.)+getWsIndex :: X (WorkspaceId -> Maybe Int)+getWsIndex = do+    wSort <- getSortByIndex+    spaces <- gets (map W.tag . wSort . W.workspaces . windowset)+    return $ flip elemIndex spaces++-- | Return a function that wraps workspace names in an xmobar action that+-- switches to that workspace.+--+-- This assumes that 'XMonad.Hooks.EwmhDesktops.ewmhDesktopsEventHook'+-- isn't configured to change the workspace order. We might need to add an+-- additional parameter if anyone needs that.+getClickable :: X (String -> WindowSpace -> String)+getClickable = getWsIndex <&> \idx s w -> maybe id clickableWrap (idx (W.tag w)) s++-- | Apply clickable wrapping to the given PP.+clickablePP :: PP -> X PP+clickablePP pp = getClickable <&> \ren -> pp{ ppRename = ppRename pp >=> ren }
XMonad/Util/Cursor.hs view
@@ -1,6 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Cursor+-- Description :  Set the default mouse cursor. -- Copyright   :  (c) 2009 Collabora Ltd -- License     :  BSD-style (see xmonad/LICENSE) --
XMonad/Util/CustomKeys.hs view
@@ -1,14 +1,13 @@ -------------------------------------------------------------------- -- |--- Module     : XMonad.Util.CustomKeys--- Copyright  : (c) 2007 Valery V. Vorotyntsev--- License    : BSD3-style (see LICENSE)------ Maintainer : Valery V. Vorotynsev <valery.vv@gmail.com>+-- Module      : XMonad.Util.CustomKeys+-- Description : Configure key bindings.+-- Copyright   : (c) 2007 Valery V. Vorotyntsev+-- License     : BSD3-style (see LICENSE) -- -- Customized key bindings. ----- (See also "XMonad.Util.EZConfig" in xmonad-contrib.)+-- See also "XMonad.Util.EZConfig" in xmonad-contrib. --------------------------------------------------------------------  module XMonad.Util.CustomKeys (@@ -19,51 +18,44 @@                               ) where  import XMonad+import XMonad.Prelude ((<&>)) import Control.Monad.Reader  import qualified Data.Map as M  -- $usage ----- 1. In @~\/.xmonad\/xmonad.hs@ add:+-- In @xmonad.hs@ add: -- -- > import XMonad.Util.CustomKeys ----- 2. Set key bindings with 'customKeys':+-- Set key bindings with 'customKeys': ----- > main = xmonad defaultConfig { keys = customKeys delkeys inskeys }+-- > main = xmonad def { keys = customKeys delkeys inskeys } -- >     where -- >       delkeys :: XConfig l -> [(KeyMask, KeySym)] -- >       delkeys XConfig {modMask = modm} =--- >           -- we're preferring Futurama to Xinerama here--- >           [ (modm .|. m, k) | (m, k) <- zip [0, shiftMask] [xK_w, xK_e, xK_r] ]+-- >           [ (modm .|. shiftMask, xK_Return) -- > terminal+-- >           , (modm .|. shiftMask, xK_c)      -- > close the focused window+-- >           ]+-- >           +++-- >           [ (modm .|. m, k) | m <- [0, shiftMask], k <- [xK_w, xK_e, xK_r] ] -- > -- >       inskeys :: XConfig l -> [((KeyMask, KeySym), X ())] -- >       inskeys conf@(XConfig {modMask = modm}) =--- >           [ ((mod1Mask,             xK_F2  ), spawn $ terminal conf)+-- >           [ ((mod1Mask,             xK_F2  ), spawn $ terminal conf) -- mod1-f2 %! Run a terminal emulator+-- >           , ((modm,                 xK_Delete), kill) -- %! Close the focused window -- >           , ((modm .|. controlMask, xK_F11 ), spawn "xscreensaver-command -lock") -- >           , ((mod1Mask,             xK_Down), spawn "amixer set Master 1-") -- >           , ((mod1Mask,             xK_Up  ), spawn "amixer set Master 1+") -- >           ]------ 0 (/hidden feature/). You can always replace bindings map---   entirely. No need to import "CustomKeys" this time:------ > import XMonad--- > import System.Exit--- > import qualified Data.Map as M--- >--- > main = xmonad defaultConfig {--- >          keys = \_ -> M.fromList [--- >                  -- Let me out of here! I want my KDE back! Help! Help!--- >                  ( (0, xK_Escape), io (exitWith ExitSuccess) ) ] } --- | Customize 'XMonad.Config.defaultConfig' -- delete needless+-- | Customize 'XMonad.Config.def' -- delete needless -- shortcuts and insert those you will use. customKeys :: (XConfig Layout -> [(KeyMask, KeySym)]) -- ^ shortcuts to delete            -> (XConfig Layout -> [((KeyMask, KeySym), X ())]) -- ^ key bindings to insert            -> XConfig Layout -> M.Map (KeyMask, KeySym) (X ())-customKeys = customKeysFrom defaultConfig+customKeys = customKeysFrom def  -- | General variant of 'customKeys': customize key bindings of -- third-party configuration.@@ -80,8 +72,8 @@ customize conf ds is = asks (keys conf) >>= delete ds >>= insert is  delete :: (MonadReader r m, Ord a) => (r -> [a]) -> M.Map a b -> m (M.Map a b)-delete dels kmap = asks dels >>= return . foldr M.delete kmap+delete dels kmap = asks dels <&> foldr M.delete kmap  insert :: (MonadReader r m, Ord a) =>           (r -> [(a, b)]) -> M.Map a b -> m (M.Map a b)-insert ins kmap = asks ins >>= return . foldr (uncurry M.insert) kmap+insert ins kmap = asks ins <&> foldr (uncurry M.insert) kmap
XMonad/Util/DebugWindow.hs view
@@ -1,14 +1,15 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.DebugWindow--- Copyright   :  (c) Brandon S Allbery KF8NH, 2012+-- Description :  Dump window information for diagnostic\/debugging purposes.+-- Copyright   :  (c) Brandon S Allbery KF8NH, 2014 -- License     :  BSD3-style (see LICENSE) -- -- Maintainer  :  allbery.b@gmail.com -- Stability   :  unstable -- Portability :  not portable ----- Module to dump window information for diagnostic/debugging purposes.  See +-- Module to dump window information for diagnostic/debugging purposes. See -- "XMonad.Hooks.DebugEvents" and "XMonad.Hooks.DebugStack" for practical uses. -- -----------------------------------------------------------------------------@@ -18,32 +19,37 @@ import           Prelude  import           XMonad+import           XMonad.Prelude  import           Codec.Binary.UTF8.String        (decodeString)-import           Control.Exception.Extensible as E-import           Control.Monad                   (when)-import           Data.List                       (unfoldr-                                                 ,intercalate-                                                 )-import           Foreign+import           Control.Exception                                     as E import           Foreign.C.String import           Numeric                         (showHex) import           System.Exit  -- | Output a window by ID in hex, decimal, its ICCCM resource name and class,---   and its title if available.  Also indicate override_redirect with an---   exclamation mark, and wrap in brackets if it is unmapped or withdrawn.+--   its title if available, and EWMH type and state if available.  Also+--   indicate override_redirect with an exclamation mark, and wrap in brackets+--   if it is unmapped or withdrawn. debugWindow   :: Window -> X String-debugWindow 0 =  return "None"+debugWindow 0 =  return "-no window-" debugWindow w =  do+  d <- asks display   let wx = pad 8 '0' $ showHex w ""-  w' <- withDisplay $ \d -> io (safeGetWindowAttributes d w)+  w' <- safeGetWindowAttributes w   case w' of     Nothing                                   ->       return $ "(deleted window " ++ wx ++ ")"-    Just (WindowAttributes x y wid ht bw m o) -> do-      c' <- withDisplay $ \d ->-            io (getWindowProperty8 d wM_CLASS w)+    Just WindowAttributes+      { wa_x                 = x+      , wa_y                 = y+      , wa_width             = wid+      , wa_height            = ht+      , wa_border_width      = bw+      , wa_map_state         = m+      , wa_override_redirect = o+      } -> do+      c' <- io (getWindowProperty8 d wM_CLASS w)       let c = case c' of                 Nothing -> ""                 Just c''  -> intercalate "/" $@@ -51,58 +57,77 @@                              \s -> if null s                                      then Nothing                                      else let (w'',s'') = break (== '\NUL') s-                                              s'      = if null s''-                                                          then s''-                                                          else tail s''+                                              s'        = drop 1 s''                                           in Just (w'',s')-      t <- catchX' (wrap `fmap` getEWMHTitle  "VISIBLE" w) $-           catchX' (wrap `fmap` getEWMHTitle  ""        w) $-           catchX' (wrap `fmap` getICCCMTitle           w) $+      t <- catchX' (wrap <$> getEWMHTitle  "VISIBLE" w) $+           catchX' (wrap <$> getEWMHTitle  ""        w) $+           catchX' (wrap <$> getICCCMTitle           w) $            return ""+      h' <- getMachine w+      let h = if null h' then "" else '@':h'+      -- if it has WM_COMMAND use it, else use the appName+      -- NB. modern stuff often does not set WM_COMMAND since it's only ICCCM required and not some+      -- horrible gnome/freedesktop session manager thing like Wayland intended. How helpful of them.+      p' <- safeGetCommand d w+      let p = if null p' then "" else wrap $ unwords p'+      nWP <- getAtom "_NET_WM_PID"+      pid' <- io $ getWindowProperty32 d nWP w+      let pid = case pid' of+                  Just [pid''] -> '(':show pid'' ++ ")"+                  _            -> ""+      let cmd = p ++ pid ++ h       let (lb,rb) = case () of                       () | m == waIsViewable -> ("","")                          | otherwise         -> ("[","]")           o'      = if o then "!" else ""+      wT <- getAtom "_NET_WM_WINDOW_TYPE"+      wt' <- io $ getWindowProperty32 d wT w+      ewmh <- case wt' of+                Just wt'' -> windowType d w (fmap fi wt'')+                _         -> return ""       return $ concat [lb                       ,o'-                      ,"window "                       ,wx                       ,t-                      ," ("+                      ," "                       ,show wid-                      ,',':show ht-                      ,')':if bw == 0 then "" else '+':show bw-                      ,"@("+                      ,'x':show ht+                      ,if bw == 0 then "" else '+':show bw+                      ,"@"                       ,show x                       ,',':show y-                      ,')':if null c then "" else ' ':c+                      ,if null c then "" else ' ':c+                      ,if null cmd then "" else ' ':cmd+                      ,ewmh                       ,rb                       ]  getEWMHTitle       :: String -> Window -> X String getEWMHTitle sub w =  do   a <- getAtom $ "_NET_WM_" ++ (if null sub then "" else '_':sub) ++ "_NAME"-  (Just t) <- withDisplay $ \d -> io $ getWindowProperty32 d a w-  return $ map (toEnum . fromEnum) t+  getDecodedStringProp w a -- should always be UTF8_STRING but rules are made to be broken  getICCCMTitle   :: Window -> X String-getICCCMTitle w =  do-  t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d w wM_NAME-  [s] <- catchX' (tryUTF8     t) $+getICCCMTitle w =  getDecodedStringProp w wM_NAME++getDecodedStringProp     :: Window -> Atom -> X String+getDecodedStringProp w a =  do+  t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d w a+  [s] <- catchX' (tryUTF8     t) $ -- shouldn't happen but some apps do it          catchX' (tryCompound t) $-         io ((:[]) `fmap` peekCString t')+         io ((:[]) <$> peekCString t')   return s  tryUTF8                          :: TextProperty -> X [String] tryUTF8 (TextProperty s enc _ _) =  do   uTF8_STRING <- getAtom "UTF8_STRING"-  when (enc == uTF8_STRING) $ error "String is not UTF8_STRING"-  (map decodeString . splitNul) `fmap` io (peekCString s)+  when (enc /= uTF8_STRING) $ error "String is not UTF8_STRING"+  map decodeString . splitNul <$> io (peekCAString s)  tryCompound                            :: TextProperty -> X [String] tryCompound t@(TextProperty _ enc _ _) =  do   cOMPOUND_TEXT <- getAtom "COMPOUND_TEXT"-  when (enc == cOMPOUND_TEXT) $ error "String is not COMPOUND_TEXT"+  when (enc /= cOMPOUND_TEXT) $ error "String is not COMPOUND_TEXT"   withDisplay $ \d -> io $ wcTextPropertyToTextList d t  splitNul    :: String -> [String]@@ -119,7 +144,7 @@   c <- ask   (a, s') <- io $ runX c st job `E.catch` \e -> case fromException e of     Just x -> throw e `const` (x `asTypeOf` ExitSuccess)-    _ -> runX c st errcase+    _      -> runX c st errcase   put s'   return a @@ -131,10 +156,66 @@                   | otherwise  =        s' : wrap' ss     wrap' ""                   =             "" --- Graphics.X11.Extras.getWindowAttributes is bugggggggy-safeGetWindowAttributes     :: Display -> Window -> IO (Maybe WindowAttributes)-safeGetWindowAttributes d w =  alloca $ \p -> do-  s <- xGetWindowAttributes d w p-  case s of-    0 -> return Nothing-    _ -> Just `fmap` peek p+-- and so is getCommand+safeGetCommand     :: Display -> Window -> X [String]+safeGetCommand d w =  do+  wC <- getAtom "WM_COMMAND"+  p <- io $ getWindowProperty8 d wC w+  case p of+    Nothing  -> return []+    Just cs' -> do+      let cs                    = map (toEnum . fromEnum) cs'+          go  (a,(s,"\NUL"))    = (s:a,("",""))+          go  (a,(s,'\NUL':ss)) = go (s:a,go' ss)+          go  r                 = r -- ???+          go'                   = break (== '\NUL')+       in return $ reverse $ fst $ go ([],go' cs)++getMachine   :: Window -> X String+getMachine w =  catchX' (getAtom "WM_CLIENT_MACHINE" >>= getDecodedStringProp w) (return "")++-- if it's one EWMH atom then we strip prefix and lowercase, otherwise we+-- return the whole thing. we also get the state here, with similar rules+-- (all EWMH = all prefixes removed and lowercased)+windowType        :: Display -> Window -> [Atom] -> X String+windowType d w ts =  do+  tstr <- decodeType ts+  wS <- getAtom "_NET_WM_STATE"+  ss' <- io $ getWindowProperty32 d wS w+  sstr <- case ss' of+            Just ss -> windowState (fmap fi ss)+            _       -> return ""+  return $ " (" ++ tstr ++ sstr ++ ")"+  where+    decodeType     :: [Atom] -> X String+    decodeType []  =  return ""+    decodeType [t] =  simplify "_NET_WM_WINDOW_TYPE_" t+    decodeType tys =  unAtoms tys " (" False++    unAtoms             :: [Atom] -> String -> Bool -> X String+    unAtoms []     t i  =  return $ if i then t else t ++ ")"+    unAtoms (a:as) t i  =  do+                            s' <- io $ getAtomName d a+                            let s = case s' of+                                      Just s'' -> s''+                                      _        -> '<':show a ++ ">"+                            unAtoms as (t ++ (if i then ' ':s else s)) True++    simplify       :: String -> Atom -> X String+    simplify pfx a =  do+                        s' <- io $ getAtomName d a+                        case s' of+                          Nothing -> return $ '<':show a ++ ">"+                          Just s  -> if pfx `isPrefixOf` s then+                                       return $ map toLower (drop (length pfx) s)+                                     else+                                       return s++    -- note that above it says this checks all of them before simplifying.+    -- I'll do that after I'm confident this works as intended.+    windowState     :: [Atom] -> X String+    windowState []  =  return ""+    windowState as' =  go as' ";"+      where+        go []     t = return t+        go (a:as) t = simplify "_NET_WM_STATE_" a >>= \t' -> go as (t ++ ' ':t')
XMonad/Util/Dmenu.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Dmenu+-- Description :  Convenient bindings to dmenu. -- Copyright   :  (c) Spencer Janssen <spencerjanssen@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -41,28 +42,32 @@ -- <http://www.jcreigh.com/dmenu/dmenu-3.2-xinerama.patch> dmenuXinerama :: [String] -> X String dmenuXinerama opts = do-    curscreen <- (fromIntegral . W.screen . W.current) `fmap` gets windowset :: X Int-    runProcessWithInput "dmenu" ["-xs", show (curscreen+1)] (unlines opts)+    curscreen <-+      fromIntegral . W.screen . W.current <$> 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 opts = menu "dmenu" opts+dmenu :: MonadIO m => [String] -> m String+dmenu = menu "dmenu"  -- | like 'dmenu' but also takes the command to run.-menu :: String -> [String] -> X String-menu menuCmd opts = menuArgs menuCmd [] opts+menu :: MonadIO m => String -> [String] -> m String+menu menuCmd = menuArgs menuCmd []  -- | 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 = 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 menuCmd selectionMap = menuMapArgs menuCmd [] selectionMap+menuMap :: MonadIO m => String -> M.Map String a -> m (Maybe a)+menuMap menuCmd = menuMapArgs menuCmd []  -- | 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 @@         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 selectionMap = menuMap "dmenu" selectionMap+dmenuMap :: MonadIO m => M.Map String a -> m (Maybe a)+dmenuMap = menuMap "dmenu"
+ XMonad/Util/DynamicScratchpads.hs view
@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.DynamicScratchpads+-- Description :  Dynamically declare any window as a scratchpad.+-- Copyright   :  (c) Robin Oberschweiber <mephory@mephory.com>+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Robin Obercshweiber <mephory@mephory.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- Dynamically declare any window as a scratchpad.+--+-----------------------------------------------------------------------------++module XMonad.Util.DynamicScratchpads {-# DEPRECATED "Use the dynamic scratchpad facility of XMonad.Util.NamedScratchpad instead." #-} (+  -- * Usage+  -- $usage+  makeDynamicSP,+  spawnDynamicSP+  ) where++import Graphics.X11.Types+import XMonad.Core+import XMonad.Operations+import qualified Data.Map as M+import qualified XMonad.StackSet as W+import qualified XMonad.Util.ExtensibleState as XS+++-- $usage+-- Allows you to dynamically declare windows as scratchpads. You can bind a key+-- to make a window start/stop being a scratchpad, and another key to+-- spawn/hide that scratchpad.+--+-- Like with XMonad.Util.NamedScratchpad, you have to have a workspace called+-- NSP, where hidden scratchpads will be moved to.+--+-- You can declare dynamic scratchpads in your xmonad.hs like so:+--+-- import XMonad.Util.DynamicScratchpads+--+-- , ((modm .|. shiftMask, xK_a), withFocused $ makeDynamicSP "dyn1")+-- , ((modm .|. shiftMask, xK_b), withFocused $ makeDynamicSP "dyn2")+-- , ((modm              , xK_a), spawnDynamicSP "dyn1")+-- , ((modm              , xK_b), spawnDynamicSP "dyn2")++-- | Stores dynamic scratchpads as a map of name to window+newtype SPStorage = SPStorage (M.Map String Window)+    deriving (Read,Show)++instance ExtensionClass SPStorage where+    initialValue = SPStorage M.empty+    extensionType = PersistentExtension++-- | Makes a window a dynamic scratchpad with the given name, or stop a window+-- | from being a dynamic scratchpad, if it already is.+makeDynamicSP :: String -- ^ Scratchpad name+              -> Window -- ^ Window to be made a scratchpad+              -> X ()+makeDynamicSP s w = do+    (SPStorage m) <- XS.get+    case M.lookup s m of+        Nothing -> addDynamicSP s w+        Just ow  -> if w == ow+                    then removeDynamicSP s+                    else showWindow ow >> addDynamicSP s w+{-# DEPRECATED makeDynamicSP "Use XMonad.Util.NamedScratchpad.toggleDynamicNSP instead" #-}++-- | Spawn the specified dynamic scratchpad+spawnDynamicSP :: String -- ^ Scratchpad name+               -> X ()+spawnDynamicSP s = do+    (SPStorage m) <- XS.get+    maybe mempty spawnDynamicSP' (M.lookup s m)+{-# DEPRECATED spawnDynamicSP "Use XMonad.Util.NamedScratchpad.dynamicNSPAction instead" #-}++spawnDynamicSP' :: Window -> X ()+spawnDynamicSP' w = withWindowSet $ \s -> do+    let matchingWindows = filter (== w) ((maybe [] W.integrate . W.stack . W.workspace . W.current) s)+    case matchingWindows of+        [] -> showWindow w+        _  -> hideWindow w++-- | Make a window a dynamic scratchpad+addDynamicSP :: String -> Window -> X ()+addDynamicSP s w = XS.modify $ alterSPStorage (\_ -> Just w) s++-- | Make a window stop being a dynamic scratchpad+removeDynamicSP :: String -> X ()+removeDynamicSP s = XS.modify $ alterSPStorage (const Nothing) s++-- | Moves window to the scratchpad workspace, effectively hiding it+hideWindow :: Window -> X ()+hideWindow = windows . W.shiftWin "NSP"++-- | Move window to current workspace and focus it+showWindow :: Window -> X ()+showWindow w = windows $ \ws ->+    W.focusWindow w . W.shiftWin (W.currentTag ws) w $ ws++alterSPStorage :: (Maybe Window -> Maybe Window) -> String -> SPStorage -> SPStorage+alterSPStorage f k (SPStorage m) = SPStorage $ M.alter f k m++-- vim:ts=4:shiftwidth=4:softtabstop=4:expandtab:
XMonad/Util/Dzen.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Dzen+-- Description :  Handy wrapper for dzen. -- Copyright   :  (c) glasser@mit.edu -- License     :  BSD --@@ -25,6 +26,11 @@     x,     y,     addArgs,+    fgColor,+    bgColor,+    align,+    slaveAlign,+    lineCount,      -- * Legacy interface     dzen,@@ -37,10 +43,11 @@     (>=>),   ) where -import Control.Monad+import XMonad.Prelude 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 +123,45 @@ 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@@ -159,6 +205,14 @@     v       = visible ws     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:
XMonad/Util/EZConfig.hs view
@@ -1,13 +1,17 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.EZConfig+-- Description :  Configure key bindings easily in Emacs style. -- Copyright   :  Devin Mullins <me@twifkak.com> --                Brent Yorgey <byorgey@gmail.com> (key parsing) -- License     :  BSD3-style (see LICENSE) -- -- Maintainer  :  Devin Mullins <me@twifkak.com> ----- Useful helper functions for amending the defaultConfig, and for+-- Useful helper functions for amending the default configuration, and for -- parsing keybindings specified in a special (emacs-like) format. -- -- (See also "XMonad.Util.CustomKeys" in xmonad-contrib.)@@ -21,6 +25,7 @@                              -- * Adding or removing keybindings                               additionalKeys, additionalKeysP,+                             remapKeysP,                              removeKeys, removeKeysP,                              additionalMouseBindings, removeMouseBindings, @@ -29,24 +34,31 @@                              mkKeymap, checkKeymap,                              mkNamedKeymap, -                             parseKey -- used by XMonad.Util.Paste+                             -- * Parsers++                             parseKey, -- used by XMonad.Util.Paste+                             parseKeyCombo,+                             parseKeySequence, readKeySequence,+#ifdef TESTING+                             parseModifier,+#endif                             ) where  import XMonad import XMonad.Actions.Submap+import XMonad.Prelude  import XMonad.Util.NamedActions+import XMonad.Util.Parser +import Control.Arrow (first, (&&&))+import qualified Data.List.NonEmpty as NE import qualified Data.Map as M-import Data.List (foldl', sortBy, groupBy, nub) import Data.Ord (comparing)-import Data.Maybe-import Control.Arrow (first, (&&&))--import Text.ParserCombinators.ReadP+import Data.List.NonEmpty (nonEmpty)  -- $usage--- To use this module, first import it into your @~\/.xmonad\/xmonad.hs@:+-- To use this module, first import it into your @xmonad.hs@: -- -- > import XMonad.Util.EZConfig --@@ -69,7 +81,7 @@ -- | -- Add or override keybindings from the existing set. Example use: ----- > main = xmonad $ defaultConfig { terminal = "urxvt" }+-- > main = xmonad $ def { terminal = "urxvt" } -- >                 `additionalKeys` -- >                 [ ((mod1Mask, xK_m        ), spawn "echo 'Hi, mom!' | dzen2 -p 4") -- >                 , ((mod1Mask, xK_BackSpace), withFocused hide) -- N.B. this is an absurd thing to do@@ -80,15 +92,16 @@ -- Note that, unlike in xmonad 0.4 and previous, you can't use modMask to refer -- to the modMask you configured earlier. You must specify mod1Mask (or -- whichever), or add your own @myModMask = mod1Mask@ line.-additionalKeys :: XConfig a -> [((ButtonMask, KeySym), X ())] -> XConfig a+additionalKeys :: XConfig a -> [((KeyMask, KeySym), X ())] -> XConfig a additionalKeys conf keyList =-    conf { keys = \cnf -> M.union (M.fromList keyList) (keys conf cnf) }+    conf { keys = M.union (M.fromList keyList) . keys conf }+infixl 4 `additionalKeys`  -- | Like 'additionalKeys', except using short @String@ key --   descriptors like @\"M-m\"@ instead of @(modMask, xK_m)@, as --   described in the documentation for 'mkKeymap'.  For example: ----- > main = xmonad $ defaultConfig { terminal = "urxvt" }+-- > main = xmonad $ def { terminal = "urxvt" } -- >                 `additionalKeysP` -- >                 [ ("M-m", spawn "echo 'Hi, mom!' | dzen2 -p 4") -- >                 , ("M-<Backspace>", withFocused hide) -- N.B. this is an absurd thing to do@@ -97,37 +110,76 @@ additionalKeysP :: XConfig l -> [(String, X ())] -> XConfig l additionalKeysP conf keyList =     conf { keys = \cnf -> M.union (mkKeymap cnf keyList) (keys conf cnf) }+infixl 4 `additionalKeysP`  -- |+-- Remap keybindings from one binding to another.  More precisely, the+-- input list contains pairs of the form @(TO, FROM)@, and maps the+-- action bound to @FROM@ to the key @TO@.  For example, the following+-- would bind @"M-m"@ to what's bound to @"M-c"@ (which is to close the+-- focused window, in this case):+--+-- > main :: IO ()+-- > main = xmonad $ def `remapKeysP` [("M-m", "M-c")]+--+-- NOTE: Submaps are not transparent, and thus these keys can't be+-- accessed in this way: more explicitly, the @FROM@ string may **not**+-- be a submap.  However, the @TO@ can be a submap without problems.+-- This means that+--+-- > xmonad $ def `remapKeysP` [("M-m", "M-c a")]+--+-- is illegal (and indeed will just disregard the binding altogether),+-- while+--+-- > xmonad $ def `remapKeysP` [("M-c a", "M-m")]+--+-- is totally fine.+remapKeysP :: XConfig l -> [(String, String)] -> XConfig l+remapKeysP conf keyList =+    conf { keys = \cnf -> mkKeymap cnf (keyList' cnf) <> keys conf cnf }+  where+   keyList' :: XConfig Layout -> [(String, X ())]+   keyList' cnf =+     mapMaybe (traverse (\s -> case readKeySequence cnf s of+                                 Just (ks :| []) -> keys conf cnf M.!? ks+                                 _               -> Nothing))+              keyList+infixl 4 `remapKeysP`++-- | -- Remove standard keybindings you're not using. Example use: ----- > main = xmonad $ defaultConfig { terminal = "urxvt" }+-- > main = xmonad $ def { terminal = "urxvt" } -- >                 `removeKeys` [(mod1Mask .|. shiftMask, n) | n <- [xK_1 .. xK_9]]-removeKeys :: XConfig a -> [(ButtonMask, KeySym)] -> XConfig a+removeKeys :: XConfig a -> [(KeyMask, KeySym)] -> XConfig a removeKeys conf keyList =-    conf { keys = \cnf -> keys conf cnf `M.difference` M.fromList (zip keyList $ repeat ()) }+    conf { keys = \cnf -> foldr M.delete (keys conf cnf) keyList }+infixl 4 `removeKeys`  -- | Like 'removeKeys', except using short @String@ key descriptors --   like @\"M-m\"@ instead of @(modMask, xK_m)@, as described in the --   documentation for 'mkKeymap'. For example: ----- > main = xmonad $ defaultConfig { terminal = "urxvt" }+-- > main = xmonad $ def { terminal = "urxvt" } -- >                 `removeKeysP` ["M-S-" ++ [n] | n <- ['1'..'9']]  removeKeysP :: XConfig l -> [String] -> XConfig l removeKeysP conf keyList =-    conf { keys = \cnf -> keys conf cnf `M.difference` mkKeymap cnf (zip keyList $ repeat (return ())) }+    conf { keys = \cnf -> keys conf cnf `M.difference` mkKeymap cnf (map (, return ()) keyList) }+infixl 4 `removeKeysP`  -- | Like 'additionalKeys', but for mouse bindings. additionalMouseBindings :: XConfig a -> [((ButtonMask, Button), Window -> X ())] -> XConfig a additionalMouseBindings conf mouseBindingsList =-    conf { mouseBindings = \cnf -> M.union (M.fromList mouseBindingsList) (mouseBindings conf cnf) }+    conf { mouseBindings = M.union (M.fromList mouseBindingsList) . mouseBindings conf }+infixl 4 `additionalMouseBindings`  -- | Like 'removeKeys', but for mouse bindings. removeMouseBindings :: XConfig a -> [(ButtonMask, Button)] -> XConfig a removeMouseBindings conf mouseBindingList =-    conf { mouseBindings = \cnf -> mouseBindings conf cnf `M.difference`-                                   M.fromList (zip mouseBindingList $ repeat ()) }+    conf { mouseBindings = \cnf -> foldr M.delete (mouseBindings conf cnf) mouseBindingList }+infixl 4 `removeMouseBindings`   --------------------------------------------------------------@@ -178,6 +230,8 @@ -- > <Tab> -- > <Return> -- > <Pause>+-- > <Num_Lock>+-- > <Caps_Lock> -- > <Scroll_lock> -- > <Sys_Req> -- > <Print>@@ -194,6 +248,18 @@ -- > <Insert> -- > <Break> -- > <Space>+-- > <Control_L>+-- > <Control_R>+-- > <Shift_L>+-- > <Shift_R>+-- > <Alt_L>+-- > <Alt_R>+-- > <Meta_L>+-- > <Meta_R>+-- > <Super_L>+-- > <Super_R>+-- > <Hyper_L>+-- > <Hyper_R> -- > <F1>-<F24> -- > <KP_Space> -- > <KP_Tab>@@ -346,11 +412,14 @@ -- > <XF86Pictures> -- > <XF86Music> -- > <XF86TouchpadToggle>+-- > <XF86AudioMicMute> -- > <XF86_Switch_VT_1>-<XF86_Switch_VT_12> -- > <XF86_Ungrab> -- > <XF86_ClearGrab> -- > <XF86_Next_VMode> -- > <XF86_Prev_VMode>+-- > <XF86Bluetooth>+-- > <XF86WLAN>  mkKeymap :: XConfig l -> [(String, X ())] -> M.Map (KeyMask, KeySym) (X ()) mkKeymap c = M.fromList . mkSubmaps . readKeymap c@@ -361,47 +430,48 @@ -- | Given a list of pairs of parsed key sequences and actions, --   group them into submaps in the appropriate way. -mkNamedSubmaps :: [([(KeyMask, KeySym)], NamedAction)] -> [((KeyMask, KeySym), NamedAction)]+mkNamedSubmaps :: [(NonEmpty (KeyMask, KeySym), NamedAction)] -> [((KeyMask, KeySym), NamedAction)] mkNamedSubmaps = mkSubmaps' submapName -mkSubmaps :: [ ([(KeyMask,KeySym)], X ()) ] -> [((KeyMask, KeySym), X ())]+mkSubmaps :: [ (NonEmpty (KeyMask, KeySym), X ()) ] -> [((KeyMask, KeySym), X ())] mkSubmaps = mkSubmaps' $ submap . M.fromList -mkSubmaps' ::  (Ord a) => ([(a, c)] -> c) -> [([a], c)] -> [(a, c)]+mkSubmaps' :: forall a b. (Ord a) => ([(a, b)] -> b) -> [(NonEmpty a, b)] -> [(a, b)] mkSubmaps' subm binds = map combine gathered-  where gathered = groupBy fstKey-                 . sortBy (comparing fst)-                 $ binds-        combine [([k],act)] = (k,act)-        combine ks = (head . fst . head $ ks,-                      subm . mkSubmaps' subm $ map (first tail) ks)-        fstKey = (==) `on` (head . fst)+  where+   gathered :: [[(NonEmpty a, b)]]+   gathered = groupBy fstKey . sortBy (comparing fst) $ binds -on :: (a -> a -> b) -> (c -> a) -> c -> c -> b-op `on` f = \x y -> f x `op` f y+   combine :: [(NonEmpty a, b)] -> (a, b)+   combine [(k :| [], act)] = (k, act)+   combine ks = ( NE.head . fst . NE.head . notEmpty $ ks+                , subm . mkSubmaps' subm $ map (first (notEmpty . NE.drop 1)) ks+                ) +   fstKey :: (NonEmpty a, b) -> (NonEmpty a, b) -> Bool+   fstKey = (==) `on` (NE.head . fst)+ -- | Given a configuration record and a list of (key sequence --   description, action) pairs, parse the key sequences into lists of --   @(KeyMask,KeySym)@ pairs.  Key sequences which fail to parse will --   be ignored.-readKeymap :: XConfig l -> [(String, t)] -> [([(KeyMask, KeySym)], t)]+readKeymap :: XConfig l -> [(String, t)] -> [(NonEmpty (KeyMask, KeySym), t)] readKeymap c = mapMaybe (maybeKeys . first (readKeySequence c))   where maybeKeys (Nothing,_) = Nothing         maybeKeys (Just k, act) = Just (k, act)  -- | Parse a sequence of keys, returning Nothing if there is --   a parse failure (no parse, or ambiguous parse).-readKeySequence :: XConfig l -> String -> Maybe [(KeyMask, KeySym)]-readKeySequence c = listToMaybe . parses-  where parses = map fst . filter (null.snd) . readP_to_S (parseKeySequence c)+readKeySequence :: XConfig l -> String -> Maybe (NonEmpty (KeyMask, KeySym))+readKeySequence c = nonEmpty <=< runParser (parseKeySequence c <* eof)  -- | Parse a sequence of key combinations separated by spaces, e.g. --   @\"M-c x C-S-2\"@ (mod+c, x, ctrl+shift+2).-parseKeySequence :: XConfig l -> ReadP [(KeyMask, KeySym)]-parseKeySequence c = sepBy1 (parseKeyCombo c) (many1 $ char ' ')+parseKeySequence :: XConfig l -> Parser [(KeyMask, KeySym)]+parseKeySequence c = parseKeyCombo c `sepBy1` many1 (char ' ')  -- | Parse a modifier-key combination such as "M-C-s" (mod+ctrl+s).-parseKeyCombo :: XConfig l -> ReadP (KeyMask, KeySym)+parseKeyCombo :: XConfig l -> Parser (KeyMask, KeySym) parseKeyCombo c = do mods <- many (parseModifier c)                      k <- parseKey                      return (foldl' (.|.) 0 mods, k)@@ -409,265 +479,30 @@ -- | Parse a modifier: either M- (user-defined mod-key), --   C- (control), S- (shift), or M#- where # is an integer --   from 1 to 5 (mod1Mask through mod5Mask).-parseModifier :: XConfig l -> ReadP KeyMask-parseModifier c =  (string "M-" >> return (modMask c))-               +++ (string "C-" >> return controlMask)-               +++ (string "S-" >> return shiftMask)-               +++ do _ <- char 'M'-                      n <- satisfy (`elem` ['1'..'5'])-                      _ <- char '-'-                      return $ indexMod (read [n] - 1)+parseModifier :: XConfig l -> Parser KeyMask+parseModifier c = (string "M-" $> modMask c)+               <> (string "C-" $> controlMask)+               <> (string "S-" $> shiftMask)+               <> do _ <- char 'M'+                     n <- satisfy (`elem` ['1'..'5'])+                     _ <- char '-'+                     return $ indexMod (read [n] - 1)     where indexMod = (!!) [mod1Mask,mod2Mask,mod3Mask,mod4Mask,mod5Mask] --- | Parse an unmodified basic key, like @\"x\"@, @\"<F1>\"@, etc.-parseKey :: ReadP KeySym-parseKey = parseRegular +++ parseSpecial+-- | Parse an unmodified basic key, like @\"x\"@, @\"\<F1\>\"@, etc.+parseKey :: Parser KeySym+parseKey = parseSpecial <> parseRegular  -- | Parse a regular key name (represented by itself).-parseRegular :: ReadP KeySym-parseRegular = choice [ char s >> return k-                      | (s,k) <- zip ['!'..'~'] [xK_exclam..xK_asciitilde]-                      ]+parseRegular :: Parser KeySym+parseRegular = choice [ string s $> k | (s, k) <- regularKeys ]  -- | Parse a special key name (one enclosed in angle brackets).-parseSpecial :: ReadP KeySym-parseSpecial = do _   <- char '<'-                  key <- choice [ string name >> return k-                                | (name,k) <- keyNames-                                ]-                  _   <- char '>'-                  return key---- | A list of all special key names and their associated KeySyms.-keyNames :: [(String, KeySym)]-keyNames = functionKeys ++ specialKeys ++ multimediaKeys---- | A list pairing function key descriptor strings (e.g. @\"<F2>\"@) with---   the associated KeySyms.-functionKeys :: [(String, KeySym)]-functionKeys = [ ('F' : show n, k)-               | (n,k) <- zip ([1..24] :: [Int]) [xK_F1..] ]---- | A list of special key names and their corresponding KeySyms.-specialKeys :: [(String, KeySym)]-specialKeys = [ ("Backspace"  , xK_BackSpace)-              , ("Tab"        , xK_Tab)-              , ("Return"     , xK_Return)-              , ("Pause"      , xK_Pause)-              , ("Scroll_lock", xK_Scroll_Lock)-              , ("Sys_Req"    , xK_Sys_Req)-              , ("Print"      , xK_Print)-              , ("Escape"     , xK_Escape)-              , ("Esc"        , xK_Escape)-              , ("Delete"     , xK_Delete)-              , ("Home"       , xK_Home)-              , ("Left"       , xK_Left)-              , ("Up"         , xK_Up)-              , ("Right"      , xK_Right)-              , ("Down"       , xK_Down)-              , ("L"          , xK_Left)-              , ("U"          , xK_Up)-              , ("R"          , xK_Right)-              , ("D"          , xK_Down)-              , ("Page_Up"    , xK_Page_Up)-              , ("Page_Down"  , xK_Page_Down)-              , ("End"        , xK_End)-              , ("Insert"     , xK_Insert)-              , ("Break"      , xK_Break)-              , ("Space"      , xK_space)-              , ("KP_Space"   , xK_KP_Space)-              , ("KP_Tab"     , xK_KP_Tab)-              , ("KP_Enter"   , xK_KP_Enter)-              , ("KP_F1"      , xK_KP_F1)-              , ("KP_F2"      , xK_KP_F2)-              , ("KP_F3"      , xK_KP_F3)-              , ("KP_F4"      , xK_KP_F4)-              , ("KP_Home"    , xK_KP_Home)-              , ("KP_Left"    , xK_KP_Left)-              , ("KP_Up"      , xK_KP_Up)-              , ("KP_Right"   , xK_KP_Right)-              , ("KP_Down"    , xK_KP_Down)-              , ("KP_Prior"   , xK_KP_Prior)-              , ("KP_Page_Up" , xK_KP_Page_Up)-              , ("KP_Next"    , xK_KP_Next)-              , ("KP_Page_Down", xK_KP_Page_Down)-              , ("KP_End"     , xK_KP_End)-              , ("KP_Begin"   , xK_KP_Begin)-              , ("KP_Insert"  , xK_KP_Insert)-              , ("KP_Delete"  , xK_KP_Delete)-              , ("KP_Equal"   , xK_KP_Equal)-              , ("KP_Multiply", xK_KP_Multiply)-              , ("KP_Add"     , xK_KP_Add)-              , ("KP_Separator", xK_KP_Separator)-              , ("KP_Subtract", xK_KP_Subtract)-              , ("KP_Decimal" , xK_KP_Decimal)-              , ("KP_Divide"  , xK_KP_Divide)-              , ("KP_0"       , xK_KP_0)-              , ("KP_1"       , xK_KP_1)-              , ("KP_2"       , xK_KP_2)-              , ("KP_3"       , xK_KP_3)-              , ("KP_4"       , xK_KP_4)-              , ("KP_5"       , xK_KP_5)-              , ("KP_6"       , xK_KP_6)-              , ("KP_7"       , xK_KP_7)-              , ("KP_8"       , xK_KP_8)-              , ("KP_9"       , xK_KP_9)-              ]---- | List of multimedia keys. If X server does not know about some--- | keysym it's omitted from list. (stringToKeysym returns noSymbol in this case)-multimediaKeys :: [(String, KeySym)]-multimediaKeys = filter ((/= noSymbol) . snd) . map (id &&& stringToKeysym) $-                 [ "XF86ModeLock"-                 , "XF86MonBrightnessUp"-                 , "XF86MonBrightnessDown"-                 , "XF86KbdLightOnOff"-                 , "XF86KbdBrightnessUp"-                 , "XF86KbdBrightnessDown"-                 , "XF86Standby"-                 , "XF86AudioLowerVolume"-                 , "XF86AudioMute"-                 , "XF86AudioRaiseVolume"-                 , "XF86AudioPlay"-                 , "XF86AudioStop"-                 , "XF86AudioPrev"-                 , "XF86AudioNext"-                 , "XF86HomePage"-                 , "XF86Mail"-                 , "XF86Start"-                 , "XF86Search"-                 , "XF86AudioRecord"-                 , "XF86Calculator"-                 , "XF86Memo"-                 , "XF86ToDoList"-                 , "XF86Calendar"-                 , "XF86PowerDown"-                 , "XF86ContrastAdjust"-                 , "XF86RockerUp"-                 , "XF86RockerDown"-                 , "XF86RockerEnter"-                 , "XF86Back"-                 , "XF86Forward"-                 , "XF86Stop"-                 , "XF86Refresh"-                 , "XF86PowerOff"-                 , "XF86WakeUp"-                 , "XF86Eject"-                 , "XF86ScreenSaver"-                 , "XF86WWW"-                 , "XF86Sleep"-                 , "XF86Favorites"-                 , "XF86AudioPause"-                 , "XF86AudioMedia"-                 , "XF86MyComputer"-                 , "XF86VendorHome"-                 , "XF86LightBulb"-                 , "XF86Shop"-                 , "XF86History"-                 , "XF86OpenURL"-                 , "XF86AddFavorite"-                 , "XF86HotLinks"-                 , "XF86BrightnessAdjust"-                 , "XF86Finance"-                 , "XF86Community"-                 , "XF86AudioRewind"-                 , "XF86BackForward"-                 , "XF86Launch0"-                 , "XF86Launch1"-                 , "XF86Launch2"-                 , "XF86Launch3"-                 , "XF86Launch4"-                 , "XF86Launch5"-                 , "XF86Launch6"-                 , "XF86Launch7"-                 , "XF86Launch8"-                 , "XF86Launch9"-                 , "XF86LaunchA"-                 , "XF86LaunchB"-                 , "XF86LaunchC"-                 , "XF86LaunchD"-                 , "XF86LaunchE"-                 , "XF86LaunchF"-                 , "XF86ApplicationLeft"-                 , "XF86ApplicationRight"-                 , "XF86Book"-                 , "XF86CD"-                 , "XF86Calculater"-                 , "XF86Clear"-                 , "XF86Close"-                 , "XF86Copy"-                 , "XF86Cut"-                 , "XF86Display"-                 , "XF86DOS"-                 , "XF86Documents"-                 , "XF86Excel"-                 , "XF86Explorer"-                 , "XF86Game"-                 , "XF86Go"-                 , "XF86iTouch"-                 , "XF86LogOff"-                 , "XF86Market"-                 , "XF86Meeting"-                 , "XF86MenuKB"-                 , "XF86MenuPB"-                 , "XF86MySites"-                 , "XF86New"-                 , "XF86News"-                 , "XF86OfficeHome"-                 , "XF86Open"-                 , "XF86Option"-                 , "XF86Paste"-                 , "XF86Phone"-                 , "XF86Q"-                 , "XF86Reply"-                 , "XF86Reload"-                 , "XF86RotateWindows"-                 , "XF86RotationPB"-                 , "XF86RotationKB"-                 , "XF86Save"-                 , "XF86ScrollUp"-                 , "XF86ScrollDown"-                 , "XF86ScrollClick"-                 , "XF86Send"-                 , "XF86Spell"-                 , "XF86SplitScreen"-                 , "XF86Support"-                 , "XF86TaskPane"-                 , "XF86Terminal"-                 , "XF86Tools"-                 , "XF86Travel"-                 , "XF86UserPB"-                 , "XF86User1KB"-                 , "XF86User2KB"-                 , "XF86Video"-                 , "XF86WheelButton"-                 , "XF86Word"-                 , "XF86Xfer"-                 , "XF86ZoomIn"-                 , "XF86ZoomOut"-                 , "XF86Away"-                 , "XF86Messenger"-                 , "XF86WebCam"-                 , "XF86MailForward"-                 , "XF86Pictures"-                 , "XF86Music"-                 , "XF86TouchpadToggle"-                 , "XF86_Switch_VT_1"-                 , "XF86_Switch_VT_2"-                 , "XF86_Switch_VT_3"-                 , "XF86_Switch_VT_4"-                 , "XF86_Switch_VT_5"-                 , "XF86_Switch_VT_6"-                 , "XF86_Switch_VT_7"-                 , "XF86_Switch_VT_8"-                 , "XF86_Switch_VT_9"-                 , "XF86_Switch_VT_10"-                 , "XF86_Switch_VT_11"-                 , "XF86_Switch_VT_12"-                 , "XF86_Ungrab"-                 , "XF86_ClearGrab"-                 , "XF86_Next_VMode"-                 , "XF86_Prev_VMode" ]+parseSpecial :: Parser KeySym+parseSpecial = do _ <- char '<'+                  choice [ k <$ string name <* char '>'+                         | (name, k) <- allSpecialKeys+                         ]  -- | Given a configuration record and a list of (key sequence --   description, action) pairs, check the key sequence descriptions@@ -682,7 +517,7 @@ -- > main = xmonad $ myConfig -- > -- > myKeymap = [("S-M-c", kill), ...]--- > myConfig = defaultConfig {+-- > myConfig = def { -- >     ... -- >     keys = \c -> mkKeymap c myKeymap -- >     startupHook = return () >> checkKeymap myConfig myKeymap@@ -703,9 +538,9 @@ checkKeymap :: XConfig l -> [(String, a)] -> X () checkKeymap conf km = warn (doKeymapCheck conf km)   where warn ([],[])   = return ()-        warn (bad,dup) = spawn $ "xmessage 'Warning:\n"+        warn (bad,dup) = xmessage $ "Warning:\n"                             ++ msg "bad" bad ++ "\n"-                            ++ msg "duplicate" dup ++ "'"+                            ++ msg "duplicate" dup         msg _ [] = ""         msg m xs = m ++ " keybindings detected: " ++ showBindings xs         showBindings = unwords . map (("\""++) . (++"\""))@@ -718,7 +553,7 @@ doKeymapCheck conf km = (bad,dups)   where ks = map ((readKeySequence conf &&& id) . fst) km         bad = nub . map snd . filter (isNothing . fst) $ ks-        dups = map (snd . head)+        dups = map (snd . NE.head . notEmpty)              . filter ((>1) . length)              . groupBy ((==) `on` fst)              . sortBy (comparing fst)
+ XMonad/Util/ExclusiveScratchpads.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.ExclusiveScratchpads+-- Description :  Named scratchpads that can be mutually exclusive.+-- Copyright   :  Bruce Forte (2017)+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Bruce Forte+-- Stability   :  unstable+-- Portability :  unportable+--+-- Named scratchpads that can be mutually exclusive.+--+-----------------------------------------------------------------------------++module XMonad.Util.ExclusiveScratchpads+  {-# DEPRECATED "Use the exclusive scratchpad functionality of \"XMonad.Util.NamedScratchpad\" insead." #-}+  (+  -- * Usage+  -- $usage+  mkXScratchpads,+  xScratchpadsManageHook,+  -- * Keyboard related+  scratchpadAction,+  hideAll,+  resetExclusiveSp,+  -- * Mouse related+  setNoexclusive,+  resizeNoexclusive,+  floatMoveNoexclusive,+  -- * Types+  ExclusiveScratchpad(..),+  ExclusiveScratchpads,+  -- * Hooks+  nonFloating,+  defaultFloating,+  customFloating+  ) where++import XMonad.Prelude+import XMonad+import XMonad.Actions.Minimize+import XMonad.Actions.TagWindows (addTag,delTag)+import XMonad.Hooks.ManageHelpers (doRectFloat,isInProperty)++import qualified XMonad.StackSet as W+import qualified Data.List.NonEmpty as NE++-- $usage+--+-- For this module to work properly, you need to use "XMonad.Layout.BoringWindows" and+-- "XMonad.Layout.Minimize", please refer to the documentation of these modules for more+-- information on how to configure them.+--+-- To use this module, put the following in your @xmonad.hs@:+--+-- > import XMonad.Utils.ExclusiveScratchpads+-- > import XMonad.ManageHook (title,appName)+-- > import qualified XMonad.StackSet as W+--+-- Add exclusive scratchpads, for example:+--+-- > exclusiveSps = mkXScratchpads [ ("htop",   "urxvt -name htop -e htop", title =? "htop")+-- >                               , ("xclock", "xclock", appName =? "xclock")+-- >                               ] $ customFloating $ W.RationalRect (1/4) (1/4) (1/2) (1/2)+--+-- The scratchpads don\'t have to be exclusive, you can create them like this (see 'ExclusiveScratchpad'):+--+-- > regularSps   = [ XSP "term" "urxvt -name scratchpad" (appName =? "scratchpad") defaultFloating [] ]+--+-- Create a list that contains all your scratchpads like this:+--+-- > scratchpads = exclusiveSps ++ regularSps+--+-- Add the hooks to your managehook (see "XMonad.Doc.Extending#Editing_the_manage_hook" or+-- <https://xmonad.org/TUTORIAL.html#final-touches the tutorial>); e.g.,+--+-- > manageHook = myManageHook <> xScratchpadsManageHook scratchpads+--+-- And finally add some keybindings (see <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>):+--+-- > , ((modMask, xK_h), scratchpadAction scratchpads "htop")+-- > , ((modMask, xK_c), scratchpadAction scratchpads "xclock")+-- > , ((modMask, xK_t), scratchpadAction scratchpads "term")+-- > , ((modMask, xK_h), hideAll scratchpads)+--+-- Now you can get your scratchpads by pressing the corresponding keys, if you+-- have the @htop@ scratchpad on your current screen and you fetch the @xclock@+-- scratchpad then @htop@ gets hidden.+--+-- If you move a scratchpad it still gets hidden when you fetch a scratchpad of+-- the same family, to change that behaviour and make windows not exclusive+-- anymore when they get resized or moved add these mouse bindings+-- (see "XMonad.Doc.Extending#Editing_mouse_bindings"):+--+-- >     , ((mod4Mask, button1), floatMoveNoexclusive scratchpads)+-- >     , ((mod4Mask, button3), resizeNoexclusive scratchpads)+--+-- To reset a moved scratchpad to the original position that you set with its hook,+-- call @resetExclusiveSp@ when it is in focus. For example if you want to extend+-- Mod-Return to reset the placement when a scratchpad is in focus but keep the+-- default behaviour for tiled windows, set these key bindings:+--+-- > , ((modMask, xK_Return), windows W.swapMaster >> resetExclusiveSp scratchpads)+--+-- __Note:__ This is just an example, in general you can add more than two+-- exclusive scratchpads and multiple families of such.++data ExclusiveScratchpad = XSP { name   :: String       -- ^ Name of the scratchpad+                               , cmd    :: String       -- ^ Command to spawn the scratchpad+                               , query  :: Query Bool   -- ^ Query to match the scratchpad+                               , hook   :: ManageHook   -- ^ Hook to specify the placement policy+                               , exclusive :: [String]  -- ^ Names of exclusive scratchpads+                               }++type ExclusiveScratchpads = [ExclusiveScratchpad]++-- -----------------------------------------------------------------------------------++-- | Create 'ExclusiveScratchpads' from @[(name,cmd,query)]@ with a common @hook@+mkXScratchpads :: [(String,String,Query Bool)]  -- ^ List of @(name,cmd,query)@ of the+                                                --   exclusive scratchpads+               -> ManageHook                    -- ^ The common @hook@ that they use+               -> ExclusiveScratchpads+mkXScratchpads xs h = foldl accumulate [] xs+  where+    accumulate a (n,c,q) = XSP n c q h (filter (n/=) names) : a+    names = map (\(n,_,_) -> n) xs++-- | Create 'ManageHook' from 'ExclusiveScratchpads'+xScratchpadsManageHook :: ExclusiveScratchpads  -- ^ List of exclusive scratchpads from+                                                --   which a 'ManageHook' should be generated+                       -> ManageHook+xScratchpadsManageHook = composeAll . fmap (\sp -> query sp --> hook sp)++-- | Pop up/hide the scratchpad by name and possibly hide its exclusive+scratchpadAction :: ExclusiveScratchpads  -- ^ List of exclusive scratchpads+                 -> String                -- ^ Name of the scratchpad to toggle+                 -> X ()+scratchpadAction xs n =+  let ys = filter ((n==).name) xs in++  case ys of []     -> return ()+             (sp:_) -> let q = query sp in withWindowSet $ \s -> do+                       ws <- filterM (runQuery q) $ W.allWindows s++                       case ws of []    -> do spawn (cmd sp)+                                              hideOthers xs n+                                              windows W.shiftMaster++                                  (w:_) -> do toggleWindow w+                                              whenX (runQuery isExclusive w) (hideOthers xs n)+  where+    toggleWindow w = liftA2 (&&) (runQuery isMaximized w) (onCurrentScreen w) >>= \case+      True  -> whenX (onCurrentScreen w) (minimizeWindow w)+      False -> do windows (flip W.shiftWin w =<< W.currentTag)+                  maximizeWindowAndFocus w+                  windows W.shiftMaster++    onCurrentScreen w = withWindowSet (return . elem w . currentWindows)++-- | Hide all 'ExclusiveScratchpads' on the current screen+hideAll :: ExclusiveScratchpads  -- ^ List of exclusive scratchpads+        -> X ()+hideAll xs = mapWithCurrentScreen q minimizeWindow+  where q = joinQueries (map query xs) <&&> isExclusive <&&> isMaximized++-- | If the focused window is a scratchpad, the scratchpad gets reset to the original+-- placement specified with the hook and becomes exclusive again+resetExclusiveSp :: ExclusiveScratchpads -- ^ List of exclusive scratchpads+                 -> X ()+resetExclusiveSp xs = withFocused $ \w -> whenX (isScratchpad xs w) $ do+  let ys = filterM (flip runQuery w . query) xs++  unlessX (null <$> ys) $ do+    mh <- NE.head . notEmpty . map hook <$> ys  -- ys /= [], so `head` is fine+    n  <- NE.head . notEmpty . map name <$> ys  -- same++    (windows . appEndo <=< runQuery mh) w+    hideOthers xs n+    delTag "_XSP_NOEXCLUSIVE" w++  where unlessX = whenX . fmap not++-- -----------------------------------------------------------------------------------++-- | Hide the scratchpad of the same family by name if it's on the focused workspace+hideOthers :: ExclusiveScratchpads -> String -> X ()+hideOthers xs n =+  let ys = concatMap exclusive $ filter ((n==).name) xs+      qs = map query $ filter ((`elem` ys).name) xs+      q  = joinQueries qs <&&> isExclusive <&&> isMaximized in++  mapWithCurrentScreen q minimizeWindow++-- | Conditionally map a function on all windows of the current screen+mapWithCurrentScreen :: Query Bool -> (Window -> X ()) -> X ()+mapWithCurrentScreen q f = withWindowSet $ \s -> do+  ws <- filterM (runQuery q) $ currentWindows s+  mapM_ f ws++-- | Extract all windows on the current screen from a StackSet+currentWindows :: W.StackSet i l a sid sd -> [a]+currentWindows = W.integrate' . W.stack . W.workspace . W.current++-- | Check if given window is a scratchpad+isScratchpad :: ExclusiveScratchpads -> Window -> X Bool+isScratchpad xs w = withWindowSet $ \s -> do+  let q = joinQueries $ map query xs++  ws <- filterM (runQuery q) $ W.allWindows s+  return $ elem w ws++-- | Build a disjunction from a list of clauses+joinQueries :: [Query Bool] -> Query Bool+joinQueries = foldl (<||>) (liftX $ return False)++-- | Useful queries+isExclusive, isMaximized :: Query Bool+isExclusive = notElem "_XSP_NOEXCLUSIVE" . words <$> stringProperty "_XMONAD_TAGS"+isMaximized = not <$> isInProperty "_NET_WM_STATE" "_NET_WM_STATE_HIDDEN"++-- -----------------------------------------------------------------------------------++-- | Make a window not exclusive anymore+setNoexclusive :: ExclusiveScratchpads  -- ^ List of exclusive scratchpads+               -> Window                -- ^ Window which should be made not+                                        --   exclusive anymore+               -> X ()+setNoexclusive xs w = whenX (isScratchpad xs w) $ addTag "_XSP_NOEXCLUSIVE" w++-- | Float and drag the window, make it not exclusive anymore+floatMoveNoexclusive :: ExclusiveScratchpads  -- ^ List of exclusive scratchpads+                     -> Window                -- ^ Window which should be moved+                     -> X ()+floatMoveNoexclusive xs w = setNoexclusive xs w+  >> focus w+  >> mouseMoveWindow w+  >> windows W.shiftMaster++-- | Resize window, make it not exclusive anymore+resizeNoexclusive :: ExclusiveScratchpads  -- ^ List of exclusive scratchpads+                  -> Window                -- ^ Window which should be resized+                  -> X ()+resizeNoexclusive xs w = setNoexclusive xs w+  >> focus w+  >> mouseResizeWindow w+  >> windows W.shiftMaster++-- -----------------------------------------------------------------------------------++-- | Manage hook that makes the window non-floating+nonFloating :: ManageHook+nonFloating = idHook++-- | Manage hook that makes the window floating with the default placement+defaultFloating :: ManageHook+defaultFloating = doFloat++-- | Manage hook that makes the window floating with custom placement+customFloating :: W.RationalRect  -- ^ @RationalRect x y w h@ that specifies relative position,+                                  --   height and width (see "XMonad.StackSet#RationalRect")+               -> ManageHook+customFloating = doRectFloat
+ XMonad/Util/ExtensibleConf.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      :  XMonad.Util.ExtensibleConf+-- Description :  Extensible and composable configuration for contrib modules.+-- Copyright   :  (c) 2021 Tomáš Janoušek <tomi@nomi.cz>+-- License     :  BSD3+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>+--+-- Extensible and composable configuration for contrib modules.+--+-- This is the configuration counterpart of "XMonad.Util.ExtensibleState". It+-- allows contrib modules to store custom configuration values inside+-- 'XConfig'. This lets them create custom hooks, ensure they hook into xmonad+-- core only once, and possibly more.+--++module XMonad.Util.ExtensibleConf (+    -- * Usage+    -- $usage++    -- * High-level idioms based on Semigroup+    with,+    add,+    once,+    onceM,++    -- * High-level idioms based on Default+    withDef,+    modifyDef,+    modifyDefM,++    -- * Low-level primitivies+    ask,+    lookup,+    alter,+    alterF,+    ) where++import Prelude hiding (lookup)+import XMonad hiding (ask, modify, trace)+import XMonad.Prelude ((<|>), (<&>), fromMaybe)++import Data.Typeable+import qualified Data.Map as M+++-- ---------------------------------------------------------------------+-- $usage+--+-- To utilize this feature in a contrib module, create a data type for the+-- configuration, then use the helper functions provided here to implement+-- a user-friendly composable interface for your contrib module.+--+-- Example:+--+-- > import qualified XMonad.Util.ExtensibleConf as XC+-- >+-- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- > newtype MyConf = MyConf{ fromMyConf :: [Int] } deriving Semigroup+-- >+-- > customLogger :: Int -> XConfig l -> XConfig l+-- > customLogger i = XC.once (\c -> c{ logHook = logHook c <> lh }) (MyConf [i])+-- >   where+-- >     lh :: X ()+-- >     lh = XC.with $ io . print . fromMyConf+--+-- The above defines an xmonad configuration combinator that can be applied+-- any number of times like so:+--+-- > main = xmonad $ … . customLogger 1 . ewmh . customLogger 2 . … $ def{…}+--+-- and will always result in just one 'print' invocation in 'logHook'.+++-- ---------------------------------------------------------------------+-- Low-level primitivies++-- | Run-time: Retrieve a configuration value of the requested type.+ask :: (MonadReader XConf m, Typeable a) => m (Maybe a)+ask = asks $ lookup . config++-- | Config-time: Retrieve a configuration value of the requested type.+lookup :: forall a l. Typeable a => XConfig l -> Maybe a+lookup c = fromConfExt =<< typeRep (Proxy @a) `M.lookup` extensibleConf c++-- | Config-time: Alter a configuration value, or absence thereof.+alter :: forall a l. Typeable a => (Maybe a -> Maybe a) -> XConfig l -> XConfig l+alter f = mapEC $ M.alter (mapConfExt f) (typeRep (Proxy @a))+  where+    mapEC g c = c{ extensibleConf = g (extensibleConf c) }++-- | Config-time: Functor variant of 'alter', useful if the configuration+-- modifications needs to do some 'IO'.+alterF :: forall a l f. (Typeable a, Functor f)+       => (Maybe a -> f (Maybe a)) -> XConfig l -> f (XConfig l)+alterF f = mapEC $ M.alterF (mapConfExtF f) (typeRep (Proxy @a))+  where+    mapEC g c = g (extensibleConf c) <&> \ec -> c{ extensibleConf = ec }+++fromConfExt :: Typeable a => ConfExtension -> Maybe a+fromConfExt (ConfExtension val) = cast val++mapConfExt :: Typeable a+           => (Maybe a -> Maybe a) -> Maybe ConfExtension -> Maybe ConfExtension+mapConfExt f = fmap ConfExtension . f . (>>= fromConfExt)++mapConfExtF :: (Typeable a, Functor f)+            => (Maybe a -> f (Maybe a)) -> Maybe ConfExtension -> f (Maybe ConfExtension)+mapConfExtF f = fmap (fmap ConfExtension) . f . (>>= fromConfExt)+++-- ---------------------------------------------------------------------+-- High-level idioms based on Semigroup++-- | Run-time: Run a monadic action with the value of the custom+-- configuration, if set.+with :: (MonadReader XConf m, Typeable a, Monoid b) => (a -> m b) -> m b+with a = ask >>= maybe (pure mempty) a++-- | Config-time: Add (append) a piece of custom configuration to an 'XConfig'+-- using the 'Semigroup' instance of the configuration type.+add :: (Semigroup a, Typeable a)+    => a -- ^ configuration to add+    -> XConfig l -> XConfig l+add x = alter (<> Just x)++-- | Config-time: 'add' a piece of custom configuration, and if it's the first+-- piece of this type, also modify the 'XConfig' using the provided function.+--+-- This can be used to implement a composable interface for modules that must+-- only hook into xmonad core once.+--+-- (The piece of custom configuration is the last argument as it's expected to+-- come from the user.)+once :: forall a l. (Semigroup a, Typeable a)+     => (XConfig l -> XConfig l) -- ^ 'XConfig' modification done only once+     -> a -- ^ configuration to add+     -> XConfig l -> XConfig l+once f x c = maybe f (const id) (lookup @a c) $ add x c++-- | Config-time: Applicative (monadic) variant of 'once', useful if the+-- 'XConfig' modification needs to do some 'IO' (e.g. create an+-- 'Data.IORef.IORef').+onceM :: forall a l m. (Applicative m, Semigroup a, Typeable a)+      => (XConfig l -> m (XConfig l)) -- ^ 'XConfig' modification done only once+      -> a -- ^ configuration to add+      -> XConfig l -> m (XConfig l)+onceM f x c = maybe f (const pure) (lookup @a c) $ add x c+++-- ---------------------------------------------------------------------+-- High-level idioms based on Default++-- | Run-time: Run a monadic action with the value of the custom+-- configuration, or the 'Default' value thereof, if absent.+withDef :: (MonadReader XConf m, Typeable a, Default a) => (a -> m b) -> m b+withDef a = ask >>= a . fromMaybe def++-- | Config-time: Modify a configuration value in 'XConfig', initializing it+-- to its 'Default' value first if absent. This is an alternative to 'add' for+-- when a 'Semigroup' instance is unavailable or unsuitable.+--+-- Note that this must /not/ be used together with any variant of 'once'!+modifyDef :: forall a l. (Default a, Typeable a)+          => (a -> a) -- ^ modification of configuration+          -> XConfig l -> XConfig l+modifyDef f = alter ((f <$>) . (<|> Just def))++-- | Config-time: Applicative (monadic) variant of 'modifyDef', useful if the+-- configuration value modification needs to do some 'IO' (e.g. create an+-- 'Data.IORef.IORef').+--+-- Note that this must /not/ be used together with any variant of 'once'!+modifyDefM :: forall a l m. (Applicative m, Default a, Typeable a)+           => (a -> m a) -- ^ modification of configuration+           -> XConfig l -> m (XConfig l)+modifyDefM f = alterF (traverse f . (<|> Just def))
XMonad/Util/ExtensibleState.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.ExtensibleState+-- Description :  Module for storing custom mutable state in xmonad. -- Copyright   :  (c) Daniel Schoepe 2009 -- License     :  BSD3-style (see LICENSE) --@@ -18,16 +20,22 @@                               -- $usage                               put                               , modify+                              , modify'+                              , modifyM+                              , modifyM'                               , remove                               , get                               , gets+                              , modified+                              , modifiedM                               ) where -import Data.Typeable (typeOf,Typeable,cast)+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)+import XMonad.Prelude (fromMaybe)  -- --------------------------------------------------------------------- -- $usage@@ -36,10 +44,9 @@ -- and make it an instance of ExtensionClass. You can then use -- the functions from this module for storing and retrieving your data: ----- > {-# LANGUAGE DeriveDataTypeable #-} -- > import qualified XMonad.Util.ExtensibleState as XS -- >--- > data ListStorage = ListStorage [Integer] deriving Typeable+-- > data ListStorage = ListStorage [Integer] -- > instance ExtensionClass ListStorage where -- >   initialValue = ListStorage [] -- >@@ -57,7 +64,7 @@ -- To make your data persistent between restarts, the data type needs to be -- an instance of Read and Show and the instance declaration has to be changed: ----- > data ListStorage = ListStorage [Integer] deriving (Typeable,Read,Show)+-- > data ListStorage = ListStorage [Integer] deriving (Read,Show) -- > -- > instance ExtensionClass ListStorage where -- >   initialValue = ListStorage []@@ -74,27 +81,42 @@ --  -- | 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 f = put . f =<< get+modify :: (ExtensionClass a, XLike m) => (a -> a) -> m ()+modify = modifyM . (pure .) +-- | Apply an action to a stored value of the matching type or the initial value if there+-- is none.+modifyM :: (ExtensionClass a, XLike m) => (a -> m a) -> m ()+modifyM f = put =<< f =<< get++-- | Like 'modify' but the result value is forced to WHNF before being stored.+modify' :: (ExtensionClass a, XLike m) => (a -> a) -> m ()+modify' = modifyM' . (pure .)++-- | Like 'modifyM' but the result value is forced to WHNF before being stored.+modifyM' :: (ExtensionClass a, XLike m) => (a -> m a) -> m ()+modifyM' 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+  where toValue val = fromMaybe initialValue $ cast val+        getState' :: (ExtensionClass a, XLike m) => a -> m a         getState' k = do           v <- State.gets $ M.lookup (show . typeOf $ k) . extensibleState           case v of@@ -104,14 +126,24 @@                 let val = fromMaybe initialValue $ cast =<< safeRead str `asTypeOf` Just x                 put (val `asTypeOf` k)                 return val-            _ -> return $ initialValue+            _ -> return initialValue         safeRead str = case reads str of                          [(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, XLike m) => (a -> a) -> m Bool+modified = modifiedM . (pure .)++modifiedM :: (ExtensionClass a, Eq a, XLike m) => (a -> m a) -> m Bool+modifiedM f = do+    v <- get+    f v >>= \case+        v' | v' == v   -> return False+           | otherwise -> put v' >> return True
XMonad/Util/Font.hs view
@@ -2,6 +2,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Font+-- Description :  A module for abstracting a font facility over Core fonts and Xft. -- Copyright   :  (c) 2007 Andrea Rossato and Spencer Janssen -- License     :  BSD-style (see xmonad/LICENSE) --@@ -29,26 +30,27 @@     , textExtentsXMF     , printStringXMF     , stringToPixel+    , pixelToString     , fi     ) where  import XMonad+import XMonad.Prelude import Foreign-import Control.Applicative import Control.Exception as E-import Data.Maybe+import Text.Printf (printf)  #ifdef XFT-import Data.List-import Graphics.X11.Xft+import qualified Data.List.NonEmpty as NE import Graphics.X11.Xrender+import Graphics.X11.Xft #endif  -- Hide the Core Font/Xft switching here data XMonadFont = Core FontStruct                 | Utf8 FontSet #ifdef XFT-                | Xft  XftFont+                | Xft  (NE.NonEmpty XftFont) #endif  -- $usage@@ -61,6 +63,26 @@     where getIt    = initColor d s           fallBack = blackPixel d (defaultScreen d) +-- | Convert a @Pixel@ into a @String@.+--+-- This function removes any alpha channel from the @Pixel@, because X11+-- mishandles alpha channels and produces black.+pixelToString :: (MonadIO m) => Display -> Pixel -> m String+pixelToString d p = do+    let cm = defaultColormap d (defaultScreen d)+    (Color _ r g b _) <- io (queryColor d cm $ Color (p .&. 0x00FFFFFF) 0 0 0 0)+    return ("#" ++ hex r ++ hex g ++ hex b)+  where+    -- NOTE: The @Color@ type has 16-bit values for red, green, and+    -- blue, even though the actual type in X is only 8 bits wide.  It+    -- seems that the upper and lower 8-bit sections of the @Word16@+    -- values are the same.  So, we just discard the lower 8 bits.+    --+    -- (Strictly, X11 supports 16-bit values but no visual supported+    -- by XOrg does. It is still correct to discard the lower bits, as+    -- they are not guaranteed to be meaningful in such visuals.)+    hex = printf "%02x" . (`shiftR` 8)+ econst :: a -> IOException -> a econst = const @@ -95,34 +117,47 @@ -- Example: 'xft: Sans-10' initXMF :: String -> X XMonadFont initXMF s =-#ifdef XFT+#ifndef XFT+  Utf8 <$> initUtf8Font s+#else   if xftPrefix `isPrefixOf` s then      do dpy <- asks display-        xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s)-        return (Xft xftdraw)-  else-#endif-      fmap Utf8 $ initUtf8Font s-#ifdef XFT-  where xftPrefix = "xft:"+        let fonts = case wordsBy (== ',') (drop (length xftPrefix) s) of+              []       -> fallback :| []  -- NE.singleton only in base 4.15+              (x : xs) -> x :| xs+        fb <- io $ openFont dpy fallback+        fmap Xft . io $ traverse (\f -> E.catch (openFont dpy f) (econst $ pure fb))+                                 fonts+  else Utf8 <$> initUtf8Font s+ where+  xftPrefix = "xft:"+  fallback  = "xft:monospace"+  openFont dpy str = xftFontOpen dpy (defaultScreenOfDisplay dpy) str+  wordsBy p str = case dropWhile p str of+    ""   -> []+    str' -> w : wordsBy p str''+     where (w, str'') = break p str' #endif  releaseXMF :: XMonadFont -> X () #ifdef XFT-releaseXMF (Xft xftfont) = do+releaseXMF (Xft xftfonts) = do   dpy <- asks display-  io $ xftFontClose dpy xftfont+  io $ mapM_ (xftFontClose dpy) xftfonts #endif releaseXMF (Utf8 fs) = releaseUtf8Font fs releaseXMF (Core fs) = releaseCoreFont fs - textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int textWidthXMF _   (Utf8 fs) s = return $ fi $ wcTextEscapement fs s textWidthXMF _   (Core fs) s = return $ fi $ textWidth fs s #ifdef XFT textWidthXMF dpy (Xft xftdraw) s = liftIO $ do-    gi <- xftTextExtents dpy xftdraw s+#if MIN_VERSION_X11_xft(0, 3, 4)+    gi <- xftTextAccumExtents dpy (toList xftdraw) s+#else+    gi <- xftTextExtents dpy (NE.head xftdraw) s+#endif     return $ xglyphinfo_xOff gi #endif @@ -130,15 +165,21 @@ textExtentsXMF (Utf8 fs) s = do   let (_,rl)  = wcTextExtents fs s       ascent  = fi $ - (rect_y rl)-      descent = fi $ rect_height rl + (fi $ rect_y rl)+      descent = fi $ rect_height rl + fi (rect_y rl)   return (ascent, descent) textExtentsXMF (Core fs) s = do   let (_,a,d,_) = textExtents fs s   return (a,d) #ifdef XFT-textExtentsXMF (Xft xftfont) _ = io $ do-  ascent  <- fi `fmap` xftfont_ascent  xftfont-  descent <- fi `fmap` xftfont_descent xftfont+#if MIN_VERSION_X11_xft(0, 3, 4)+textExtentsXMF (Xft xftfonts) _ = io $ do+  ascent  <- fi <$> xftfont_max_ascent  xftfonts+  descent <- fi <$> xftfont_max_descent xftfonts+#else+textExtentsXMF (Xft xftfonts) _ = io $ do+  ascent  <- fi <$> xftfont_ascent  (NE.head xftfonts)+  descent <- fi <$> xftfont_descent (NE.head xftfonts)+#endif   return (ascent, descent) #endif @@ -174,13 +215,17 @@     setBackground d gc bc'     io $ wcDrawImageString d p fs gc x y s #ifdef XFT-printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do+printStringXMF dpy drw fs@(Xft fonts) gc fc bc x y s = do   let screen   = defaultScreenOfDisplay dpy       colormap = defaultColormapOfScreen screen       visual   = defaultVisualOfScreen screen   bcolor <- stringToPixel dpy bc   (a,d)  <- textExtentsXMF fs s-  gi <- io $ xftTextExtents dpy font s+#if MIN_VERSION_X11_xft(0, 3, 4)+  gi <- io $ xftTextAccumExtents dpy (toList fonts) s+#else+  gi <- io $ xftTextExtents dpy (NE.head fonts) s+#endif   io $ setForeground dpy gc bcolor   io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))                                 (y - fi a)@@ -188,9 +233,9 @@                                 (fi $ a + d)   io $ withXftDraw dpy drw visual colormap $          \draw -> withXftColorName dpy visual colormap fc $-                   \color -> xftDrawString draw color font x y s+#if MIN_VERSION_X11_xft(0, 3, 4)+                   \color -> xftDrawStringFallback draw color (toList fonts) (fi x) (fi y) s+#else+                   \color -> xftDrawString draw color (NE.head fonts) x y s #endif---- | Short-hand for 'fromIntegral'-fi :: (Integral a, Num b) => a -> b-fi = fromIntegral+#endif
+ XMonad/Util/Grab.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE LambdaCase #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.Grab+-- Description :  Utilities for grabbing/ungrabbing keys.+-- Copyright   :  (c) 2018  L. S. Leary+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  L. S. Leary+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module should not be directly used by users. Its purpose is to+-- facilitate grabbing and ungrabbing keys.+--------------------------------------------------------------------------------++-- --< Imports & Exports >-- {{{++module XMonad.Util.Grab+  (+ -- * Usage+ -- $Usage+    grabKP+  , ungrabKP+  , grabUngrab+  , grab+  , customRegrabEvHook+  ) where++-- core+import           XMonad++import           Control.Monad                  ( when )+import           Data.Foldable                  ( traverse_ )+-- base+import           Data.Semigroup                 ( All(..) )++-- }}}++-- --< Usage >-- {{{++-- $Usage+--+-- This module should not be directly used by users. Its purpose is to+-- facilitate grabbing and ungrabbing keys.++-- }}}++-- --< Public Utils >-- {{{++-- | A more convenient version of 'grabKey'.+grabKP :: KeyMask -> KeyCode -> X ()+grabKP mdfr kc = do+  XConf { display = dpy, theRoot = rootw } <- ask+  io (grabKey dpy kc mdfr rootw True grabModeAsync grabModeAsync)++-- | A more convenient version of 'ungrabKey'.+ungrabKP :: KeyMask -> KeyCode -> X ()+ungrabKP mdfr kc = do+  XConf { display = dpy, theRoot = rootw } <- ask+  io (ungrabKey dpy kc mdfr rootw)++-- | A convenience function to grab and ungrab keys+grabUngrab+  :: [(KeyMask, KeySym)] -- ^  Keys to grab+  -> [(KeyMask, KeySym)] -- ^ Keys to ungrab+  -> X ()+grabUngrab gr ugr = do+  traverse_ (uncurry ungrabKP) =<< mkGrabs ugr+  traverse_ (uncurry grabKP)   =<< mkGrabs gr++-- | A convenience function to grab keys. This also ungrabs all+-- previously grabbed keys.+grab :: [(KeyMask, KeySym)] -> X ()+grab ks = do+  XConf { display = dpy, theRoot = rootw } <- ask+  io (ungrabKey dpy anyKey anyModifier rootw)+  grabUngrab ks []++-- | An event hook that runs a custom action to regrab the necessary keys.+customRegrabEvHook :: X () -> Event -> X All+customRegrabEvHook regr = \case+  e@MappingNotifyEvent{} -> do+    io (refreshKeyboardMapping e)+    when (ev_request e `elem` [mappingKeyboard, mappingModifier])+      $  cacheNumlockMask+      >> regr+    pure (All False)+  _ -> pure (All True)++-- }}}
+ XMonad/Util/Hacks.hs view
@@ -0,0 +1,216 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.Hacks+-- Description :  A collection of small fixes and utilities with possibly hacky implementations.+-- Copyright   :  (c) 2020 Leon Kowarschick+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Leon Kowarschick. <thereal.elkowar@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module is a collection of random fixes, workarounds and other functions+-- that rely on somewhat hacky implementations which may have unwanted side effects+-- and/or are small enough to not warrant a separate module.+--+-- Import this module as qualified like so:+--+-- > import qualified XMonad.Util.Hacks as Hacks+--+-- and then use the functions you want as described in their respective documentation.+--+-----------------------------------------------------------------------------++module XMonad.Util.Hacks (+  -- * Windowed fullscreen+  -- $windowedFullscreenFix+  windowedFullscreenFixEventHook,++  -- * Java Hack+  -- $java+  javaHack,++  -- * Stacking trays (trayer) above panels (xmobar)+  -- $raiseTrayer+  trayerAboveXmobarEventHook,+  trayAbovePanelEventHook,++  -- * Inform xmobar when trays (e.g. trayer) change width+  -- $padTrayer+  trayerPaddingXmobarEventHook,+  trayPaddingXmobarEventHook,+  trayPaddingEventHook,++  -- * Steam flickering fix+  fixSteamFlicker,+  ) where+++import XMonad+import XMonad.Hooks.FloatConfigureReq (fixSteamFlicker)+import XMonad.Hooks.StatusBar (xmonadPropLog')+import XMonad.Prelude (All (All), fi, filterM, when)+import System.Posix.Env (putEnv)+++-- $windowedFullscreenFix+-- Windowed fullscreen describes the behaviour in which XMonad,+-- by default, does not automatically put windows that request being fullscreened+-- into actual fullscreen, but keeps them constrained+-- to their normal window dimensions, still rendering them in fullscreen.+--+-- With chromium based applications like Chrome, Discord and others this+-- can cause issues, where the window does not correctly see the size of the window+-- when displaying the fullscreen content, thus cutting off the window content.+--+-- This function works around that issue by forcing the window to recalculate their+-- dimensions after initiating fullscreen, thus making chrome-based applications+-- behave properly when in windowed fullscreen.+--+-- The following gif shows the behaviour of chrome (left) without this fix+-- compared to firefox, which already behaves as expected by default:+-- <<https://user-images.githubusercontent.com/79924233/115355075-e61dd280-a1ec-11eb-81d3-927ca462945f.gif>>+--+-- Using this function, chrome will now behave as expected as well:+-- <<https://user-images.githubusercontent.com/5300871/99186115-4dbb8780-274e-11eb-9ed2-b7815ba9e597.gif>>+--+-- Usage:+-- add to handleEventHook as follows:+--+-- > handleEventHook = handleEventHook def <> Hacks.windowedFullscreenFixEventHook+--++-- | Fixes fullscreen behaviour of chromium based apps by quickly applying and undoing a resize.+-- This causes chromium to recalculate the fullscreen window+-- dimensions to match the actual "windowed fullscreen" dimensions.+windowedFullscreenFixEventHook :: Event -> X All+windowedFullscreenFixEventHook (ClientMessageEvent _ _ _ dpy win typ (_:dats)) = do+  wmstate <- getAtom "_NET_WM_STATE"+  fullscreen <- getAtom "_NET_WM_STATE_FULLSCREEN"+  when (typ == wmstate && fromIntegral fullscreen `elem` dats) $+    withWindowAttributes dpy win $ \attrs ->+      liftIO $ do+        resizeWindow dpy win (fromIntegral $ wa_width attrs - 1) (fromIntegral $ wa_height attrs)+        resizeWindow dpy win (fromIntegral $ wa_width attrs) (fromIntegral $ wa_height attrs)+  return $ All True+windowedFullscreenFixEventHook _ = return $ All True+++-- $java+-- Some java Applications might not work with xmonad. A common workaround would be to set the environment+-- variable @_JAVA_AWT_WM_NONREPARENTING@ to 1. The function 'javaHack' does exactly that.+-- Example usage:+--+-- > main = xmonad $ Hacks.javaHack (def {...})+--++-- | Fixes Java applications that don't work well with xmonad, by setting @_JAVA_AWT_WM_NONREPARENTING=1@+javaHack :: XConfig l -> XConfig l+javaHack conf = conf+  { startupHook = startupHook conf+                    *> io (putEnv "_JAVA_AWT_WM_NONREPARENTING=1")+  }+++-- $raiseTrayer+-- Placing @trayer@ on top of @xmobar@ is somewhat tricky:+--+-- - they both should be lowered to the bottom of the stacking order to avoid+--   overlapping fullscreen windows+--+-- - the tray needs to be stacked on top of the panel regardless of which+--   happens to start first+--+-- 'trayerAboveXmobarEventHook' (and the more generic+-- 'trayAbovePanelEventHook') is an event hook that ensures the latter:+-- whenever the tray lowers itself to the bottom of the stack, it checks+-- whether there are any panels above it and lowers these again.+--+-- To ensure the former, that is having both @trayer@ and @xmobar@ lower+-- themselves, which is a necessary prerequisite for this event hook to+-- trigger:+--+-- - set @lowerOnStart = True@ and @overrideRedirect = True@ in @~/.xmobarrc@+-- - pass @-l@ to @trayer@+--+-- Usage:+--+-- > handleEventHook = … <> Hacks.trayerAboveXmobarEventHook++-- | Like 'trayAbovePanelEventHook', but specialised for trayer/xmobar.+trayerAboveXmobarEventHook :: Event -> X All+trayerAboveXmobarEventHook = trayAbovePanelEventHook (className =? "trayer") (appName =? "xmobar")++-- | Whenever a tray window lowers itself to the bottom of the stack, look for+-- any panels above it and lower these.+trayAbovePanelEventHook+  :: Query Bool -- ^ tray+  -> Query Bool -- ^ panel+  -> (Event -> X All) -- ^ event hook+trayAbovePanelEventHook trayQ panelQ ConfigureEvent{ev_window = w, ev_above = a} | a == none = do+  whenX (runQuery trayQ w) $ withDisplay $ \dpy -> do+    rootw <- asks theRoot+    (_, _, ws) <- io $ queryTree dpy rootw+    let aboveTrayWs = dropWhile (w /=) ws+    panelWs <- filterM (runQuery panelQ) aboveTrayWs+    mapM_ (io . lowerWindow dpy) panelWs+  mempty+trayAbovePanelEventHook _ _ _ = mempty++-- $padTrayer+-- Communicating tray (e.g., trayer) resize events to xmobar so that+-- padding space may be reserved on xmobar for the tray.+--+-- Basic Usage with trayer:+--+-- First, add the padding hook to your @handleEventHook@ as follows:+--+-- > main = xmonad $ def+-- > { ...+-- > , handleEventHook = handleEventHook def+-- >                  <> Hacks.trayerPaddingXmobarEventHook+-- > }+--+-- Then, assuming the tray is placed on the right, update your+-- @xmobarrc@ as follows:+--+-- > Config { ...+-- >        , commands = [ ...+-- >                     , Run XPropertyLog "_XMONAD_TRAYPAD", ... ]+-- >        , template = " ... %_XMONAD_TRAYPAD%"+-- >        }+--+-- As an example of what happens in this basic usage, consider the+-- case where trayer updates to a width of 53 pixels.+-- The following property will appear on the root window:+--+-- > _XMONAD_TRAYPAD(UTF8_STRING) = "<hspace=53/>"++-- | A simple trayer/xmobar-specific event hook that watches for trayer window+-- resize changes and updates the _XMONAD_TRAYPAD property with xmobar markup+-- that leaves a gap for the trayer.+trayerPaddingXmobarEventHook :: Event -> X All -- ^ event hook+trayerPaddingXmobarEventHook = trayPaddingXmobarEventHook (className =? "trayer") "_XMONAD_TRAYPAD"++-- | A generic version of 'trayerPaddingXmobarEventHook' that+-- allows the user to specify how to identify a tray window and the property+-- to use with 'xmonadPropLog''. This is useful for other trays like+-- stalonetray and also when space for more than one tray-like window needs to+-- be reserved.+trayPaddingXmobarEventHook+  :: Query Bool     -- ^ query to identify the tray window+  -> String         -- ^ 'xmonadPropLog'' property to use+  -> Event -> X All -- ^ resulting event hook+trayPaddingXmobarEventHook trayQ prop = trayPaddingEventHook trayQ hspaceLog+  where hspaceLog width = xmonadPropLog' prop ("<hspace=" ++ show width ++ "/>")++-- | A fully generic tray resize hook that invokes a callback whenever a+-- tray-like window changes width.+trayPaddingEventHook+  :: Query Bool     -- ^ query to identify the tray window+  -> (Int -> X ())  -- ^ action to perform when tray width changes+  -> Event -> X All -- ^ resulting event hook+trayPaddingEventHook trayQ widthChanged ConfigureEvent{ ev_window = w, ev_width = wa } = do+  whenX (runQuery trayQ w) $ widthChanged (fi wa)+  mempty+trayPaddingEventHook _ _ _ = mempty
+ XMonad/Util/History.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE NamedFieldPuns, DeriveTraversable #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.History+-- Description :  Track history in /O(log n)/ time.+-- Copyright   :  (c) 2022 L. S. Leary+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  @LSLeary (on github)+-- Stability   :  unstable+-- Portability :  unportable+--+-- Provides 'History', a variation on a LIFO stack with a uniqueness property.+-- In order to achieve the desired asymptotics, the data type is implemented as+-- an ordered Map.+--+-----------------------------------------------------------------------------++module XMonad.Util.History (+  History,+  origin,+  event,+  erase,+  recall,+  ledger,+  transcribe,+  ) where++-- base+import Data.Function (on)+import Text.Read+  ( Read(readPrec, readListPrec), Lexeme(Ident)+  , parens, prec, lexP, step, readListPrecDefault+  )++-- containers+import Data.IntMap (IntMap)+import qualified Data.IntMap.Strict as I+import Data.Map (Map)+import qualified Data.Map.Strict as M+++-- | A history of unique @k@-events with @a@-annotations.+--+--   @History k a@ can be considered a (LIFO) stack of @(k, a)@ values with the+--   property that each @k@ is unique. From this point of view, 'event' pushes+--   and 'ledger' pops/peeks all.+--+--   The naive implementation has /O(n)/ 'event' and 'erase' due to the+--   uniqueness condition, but we can still use it as a denotation:+--+-- > mu :: History k a -> [(k, a)]+--+--   As an opaque data type with strict operations, @History k a@ values are all+--   finite expressions in the core interface: 'origin', 'erase' and 'event'.+--   Hence we define @mu@ by structural induction on these three cases.+--+data History k a = History+  { annals   :: !(IntMap (k, a))+  , recorded :: !(Map k Int)+  } deriving (Functor, Foldable, Traversable)++instance (Eq  k, Eq  a) => Eq  (History k a) where (==)    = (==)    `on` ledger+instance (Ord k, Ord a) => Ord (History k a) where compare = compare `on` ledger++instance (Show k, Show a) => Show (History k a) where+  showsPrec d h+    = showParen (d > app_prec)+    $ showString "transcribe "+    . showsPrec (app_prec+1) (ledger h)+    where app_prec = 10++instance (Read k, Read a, Ord k) => Read (History k a) where+  readPrec = parens . prec app_prec $ do+    Ident "transcribe" <- lexP+    l <- step readPrec+    pure (transcribe l)+    where app_prec = 10+  readListPrec = readListPrecDefault+++-- | /O(1)/. A history of nothing.+--+-- > mu origin := []+--+origin :: History k a+origin = History I.empty M.empty++-- | /O(log n)/. A new event makes history; its predecessor forgotten.+--+-- > mu (event k a h) := (k, a) : mu (erase k h)+--+event :: Ord k => k -> a -> History k a -> History k a+event k a History{annals,recorded} = History+  { annals   = I.insert ik (k, a) . maybe id I.delete mseen $ annals+  , recorded = recorded'+  }+  where+    ik = maybe 0 (\((i, _), _) -> pred i) (I.minViewWithKey annals)+    (mseen, recorded') = M.insertLookupWithKey (\_ x _ -> x) k ik recorded++-- | /O(log n)/. Erase an event from history.+--+-- > mu (erase k h) := filter ((k /=) . fst) (mu h)+--+erase :: Ord k => k -> History k a -> History k a+erase k History{annals,recorded} = History+  { annals   = maybe id I.delete mseen annals+  , recorded = recorded'+  }+  where (mseen, recorded') = M.updateLookupWithKey (\_ _ -> Nothing) k recorded+++-- | /O(log n)/. Recall an event.+recall :: Ord k => k -> History k a -> Maybe a+recall k History{annals,recorded} = do+  ik     <- M.lookup k recorded+  (_, a) <- I.lookup ik annals+  pure a++-- | /O(n)/. Read history, starting with the modern day. @ledger@ is @mu@.+ledger :: History k a -> [(k, a)]+ledger = I.elems . annals++-- | /O(n * log n)/. Transcribe a ledger.+transcribe :: Ord k => [(k, a)] -> History k a+transcribe = foldr (uncurry event) origin
XMonad/Util/Image.hs view
@@ -1,6 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Image+-- Description :  Utilities for manipulating @[[Bool]]@ as images. -- Copyright   :  (c) 2010 Alejandro Serrano -- License     :  BSD-style (see xmonad/LICENSE) --@@ -21,7 +22,8 @@     ) where  import XMonad-import XMonad.Util.Font (stringToPixel,fi)+import XMonad.Prelude+import XMonad.Util.Font (stringToPixel)  -- | Placement of the icon in the title bar data Placement = OffsetLeft Int Int   -- ^ An exact amount of pixels from the upper left corner@@ -37,16 +39,16 @@ -- In the module we suppose that those matrices are represented as [[Bool]], -- so the lengths of the inner lists must be the same. ----- See "Xmonad.Layout.Decoration" for usage examples+-- See "XMonad.Layout.Decoration" for usage examples  -- | Gets the ('width', 'height') of an image imageDims :: [[Bool]] -> (Int, Int)-imageDims img = (length (head img), length img)+imageDims img = (length (fromMaybe [] (listToMaybe img)), length img)  -- | Return the 'x' and 'y' positions inside a 'Rectangle' to start drawing --   the image given its 'Placement' iconPosition :: Rectangle -> Placement -> [[Bool]] -> (Position,Position)-iconPosition (Rectangle _ _ _ _) (OffsetLeft x y) _ = (fi x, fi y)+iconPosition Rectangle{} (OffsetLeft x y) _ = (fi x, fi y) iconPosition (Rectangle _ _ w _) (OffsetRight x y) icon =   let (icon_w, _) = imageDims icon   in (fi w - fi x - fi icon_w, fi y)@@ -72,7 +74,7 @@  -- | Displaces a list of points along a vector 'x', 'y' movePoints :: Position -> Position -> [Point] -> [Point]-movePoints x y points = map (movePoint x y) points+movePoints x y = map (movePoint x y)  -- | Draw an image into a X surface drawIcon :: (Functor m, MonadIO m) => Display -> Drawable -> GC -> String
XMonad/Util/Invisible.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Invisible+-- Description :  A data type to store the layout state. -- Copyright   :  (c) 2007 Andrea Rossato, David Roundy -- License     :  BSD-style (see xmonad/LICENSE) --@@ -22,16 +23,18 @@                             , fromIMaybe                             ) where +import Control.Monad.Fail+ -- $usage -- A wrapper data type to store layout state that shouldn't be persisted across -- restarts. A common wrapped type to use is @Maybe a@. -- Invisible derives trivial definitions for Read and Show, so the wrapped data -- type need not do so. -newtype Invisible m a = I (m a) deriving (Monad, Functor, Applicative)+newtype Invisible m a = I (m a) deriving (Monad, MonadFail, Applicative, Functor) -instance (Functor m, Monad m) => Read (Invisible m a) where-    readsPrec _ s = [(fail "Read Invisible", s)]+instance (Functor m, Monad m, MonadFail m) => Read (Invisible m a) where+    readsPrec _ s = [(Control.Monad.Fail.fail "Read Invisible", s)]  instance Monad m => Show (Invisible m a) where     show _ = ""
XMonad/Util/Loggers.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Loggers+-- Description :  A collection of simple logger functions and formatting utilities. -- Copyright   :  (c) Brent Yorgey, Wirt Wolff -- License     :  BSD-style (see LICENSE) --@@ -9,8 +11,8 @@ -- Portability :  unportable -- -- A collection of simple logger functions and formatting utilities--- which can be used in the 'XMonad.Hooks.DynamicLog.ppExtras' field of--- a pretty-printing status logger format. See "XMonad.Hooks.DynamicLog"+-- which can be used in the 'XMonad.Hooks.StatusBar.PP.ppExtras' field of+-- a pretty-printing status logger format. See "XMonad.Hooks.StatusBar.PP" -- for more information. ----------------------------------------------------------------------------- @@ -31,8 +33,18 @@      -- * XMonad Loggers     -- $xmonad-    , logCurrent, logLayout, logTitle-+    , logCurrent, logLayout+    , logTitle, logTitles, logTitles'+    , logClassname, logClassnames, logClassnames'+    , logConst, logDefault, (.|)+    -- * XMonad: Screen-specific Loggers+    -- $xmonad-screen+    , logCurrentOnScreen, logLayoutOnScreen+    , logTitleOnScreen, logClassnameOnScreen, logWhenActive+    , logTitlesOnScreen, logTitlesOnScreen'+    , logClassnamesOnScreen, logClassnamesOnScreen'+    , TitlesFormat(..)+    , ClassnamesFormat(..)     -- * Formatting Utilities     -- $format     , onLogger@@ -41,66 +53,60 @@     , shortenL     , dzenColorL, xmobarColorL -    , (<$>)-   ) where -import XMonad (liftIO)+import XMonad (Default, gets, liftIO, Window) import XMonad.Core import qualified XMonad.StackSet as W-import XMonad.Hooks.DynamicLog+import XMonad.Hooks.StatusBar.PP+import XMonad.Hooks.UrgencyHook (readUrgents) import XMonad.Util.Font (Align (..))-import XMonad.Util.NamedWindows (getName)+import XMonad.Util.NamedWindows (getName, getNameWMClass) -import Control.Applicative ((<$>)) import Control.Exception as E-import Data.List (isPrefixOf, isSuffixOf)-import Data.Maybe (fromMaybe)-import Data.Traversable (traverse)+import XMonad.Prelude (find, fromMaybe, isPrefixOf, isSuffixOf, WindowScreen)+import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) import System.Directory (getDirectoryContents)-import System.IO-import System.Locale+import System.IO (hGetLine) import System.Process (runInteractiveCommand)-import System.Time  econst :: Monad m => a -> IOException -> m a econst = const . return  -- $usage--- Use this module by importing it into your @~\/.xmonad\/xmonad.hs@:+-- Use this module by importing it into your @xmonad.hs@: -- -- > import XMonad.Util.Loggers -- -- Then, add one or more loggers to the--- 'XMonad.Hooks.DynamicLog.ppExtras' field of your--- 'XMonad.Hooks.DynamicLoc.PP', possibly with extra formatting .+-- 'XMonad.Hooks.StatusBar.PP.ppExtras' field of your+-- "XMonad.Hooks.StatusBar.PP", possibly with extra formatting . -- For example: ----- >   -- display load averages and a pithy quote along with xmonad status.--- >   , logHook = dynamicLogWithPP $ defaultPP {--- >                  ppExtras = [ padL loadAvg, logCmd "fortune -n 40 -s" ]--- >                }+-- > myPP = def {+-- >            ppExtras = [ padL loadAvg, logCmd "fortune -n 40 -s" ]+-- >         } -- >   -- gives something like " 3.27 3.52 3.26 Drive defensively.  Buy a tank." -- -- See the formatting section below for another example using -- a @where@ block to define some formatted loggers for a top-level--- @myLogHook@.+-- @myPP@. -- -- Loggers are named either for their function, as in 'battery', -- 'aumixVolume', and 'maildirNew', or are prefixed with \"log\" when -- making use of other functions or by analogy with the pp* functions.--- For example, the logger version of 'XMonad.Hooks.DynamicLog.ppTitle'+-- For example, the logger version of 'XMonad.Hooks.StatusBar.PP.ppTitle' -- is 'logTitle', and 'logFileCount' loggerizes the result of file -- counting code. -- -- Formatting utility names are generally as short as possible and -- carry the suffix \"L\". For example, the logger version of--- 'XMonad.Hooks.DynamicLog.shorten' is 'shortenL'.+-- 'XMonad.Hooks.StatusBar.PP.shorten' is 'shortenL'. -- -- Of course, there is nothing really special about these so-called -- \"loggers\": they are just @X (Maybe String)@ actions.  So you can -- use them anywhere you would use an @X (Maybe String)@, not just--- with DynamicLog.+-- with PP. -- -- Additional loggers welcome! @@ -118,9 +124,9 @@ -- | Get the battery status (percent charge and charging\/discharging --   status). This is an ugly hack and may not work for some people. --   At some point it would be nice to make this more general\/have---   fewer dependencies (assumes @\/usr\/bin\/acpi@ and @sed@ are installed.)+--   fewer dependencies (assumes @acpi@ and @sed@ are installed.) battery :: Logger-battery = logCmd "/usr/bin/acpi | sed -r 's/.*?: (.*%).*/\\1/; s/[dD]ischarging, ([0-9]+%)/\\1-/; s/[cC]harging, ([0-9]+%)/\\1+/; s/[cC]harged, //'"+battery = logCmd "acpi | sed -r 's/.*?: (.*%).*/\\1/; s/[dD]ischarging, ([0-9]+%)/\\1-/; s/[cC]harging, ([0-9]+%)/\\1+/; s/[cC]harged, //'"  -- | Get the current date and time, and format them via the --   given format string.  The format used is the same as that used@@ -129,15 +135,14 @@ --   For more information see something like --   <http://www.cplusplus.com/reference/clibrary/ctime/strftime.html>. date :: String -> Logger-date fmt = io $ do cal <- (getClockTime >>= toCalendarTime)-                   return . Just $ formatCalendarTime defaultTimeLocale fmt cal+date fmt = io $ Just . formatTime defaultTimeLocale fmt <$> getCurrentTime  -- | Get the load average.  This assumes that you have a---   utility called @\/usr\/bin\/uptime@ and that you have @sed@+--   utility called @uptime@ and that you have @sed@ --   installed; these are fairly common on GNU\/Linux systems but it --   would be nice to make this more general. loadAvg :: Logger-loadAvg = logCmd "/usr/bin/uptime | sed 's/.*: //; s/,//g'"+loadAvg = logCmd "uptime | sed 's/.*: //; s/,//g'"  -- | Create a 'Logger' from an arbitrary shell command. logCmd :: String -> Logger@@ -173,10 +178,172 @@ -- example you can loggerize the number of windows on each workspace, or -- titles on other workspaces, or the id of the previously focused workspace.... +-- | Internal function to get a wrapped title string from a window+fetchWindowTitle :: Window -> X String+fetchWindowTitle = fmap show . getName+ -- | Get the title (name) of the focused window. logTitle :: Logger-logTitle = withWindowSet $ traverse (fmap show . getName) . W.peek+logTitle = logWindowInfoFocusedWindow fetchWindowTitle +-- | Get the titles of all windows on the visible workspace of the given+-- screen and format them according to the given functions.+--+-- ==== __Example__+--+-- > myXmobarPP :: X PP+-- > myXmobarPP = pure $ def+-- >   { ppOrder  = [ws, l, _, wins] -> [ws, l, wins]+-- >   , ppExtras = [logTitles formatFocused formatUnfocused]+-- >   }+-- >  where+-- >   formatFocused   = wrap "[" "]" . xmobarColor "#ff79c6" "" . shorten 50 . xmobarStrip+-- >   formatUnfocused = wrap "(" ")" . xmobarColor "#bd93f9" "" . shorten 30 . xmobarStrip+--+logTitlesOnScreen+  :: ScreenId           -- ^ Screen to log the titles on+  -> (String -> String) -- ^ Formatting for the focused   window+  -> (String -> String) -- ^ Formatting for the unfocused window+  -> Logger+logTitlesOnScreen sid formatFoc formatUnfoc =+  logWindowInfoOnScreen fetchWindowTitle sid formatFoc formatUnfoc formatUnfoc++-- | Like 'logTitlesOnScreen' but with support for urgent windows.  To+-- be used with "XMonad.Hooks.UrgencyHook".+logTitlesOnScreen' :: ScreenId -> TitlesFormat -> Logger+logTitlesOnScreen' sid (TitlesFormat formatFoc formatUnfoc formatUrg) =+  logWindowInfoOnScreen fetchWindowTitle sid formatFoc formatUnfoc formatUrg++-- | Like 'logTitlesOnScreen', but directly use the "focused" screen+-- (the one with the currently focused workspace).+logTitles :: (String -> String) -> (String -> String) -> Logger+logTitles formatFoc formatUnfoc =+  logWindowInfoFocusedScreen fetchWindowTitle formatFoc formatUnfoc formatUnfoc++-- | Variant of 'logTitles', but with support for urgent windows.+logTitles' :: TitlesFormat -> Logger+logTitles' (TitlesFormat formatFoc formatUnfoc formatUrg) =+  logWindowInfoFocusedScreen fetchWindowTitle formatFoc formatUnfoc formatUrg++-- | Formatting applied to the titles of certain windows.+data TitlesFormat = TitlesFormat+  { focusedFormat   :: String -> String  -- ^ Focused formatting.+  , unfocusedFormat :: String -> String  -- ^ Unfocused formatting.+  , urgentFormat    :: String -> String  -- ^ Formatting when urgent.+  }++-- | How to format these titles by default when using 'logTitles'' and+-- 'logTitlesOnScreen''.+instance Default TitlesFormat where+  def = TitlesFormat+    { focusedFormat   = xmobarFocusedFormat+    , unfocusedFormat = xmobarWsFormat+    , urgentFormat    = xmobarUrgentFormat+    }++-- | Internal function to get a wrapped classname string from a window+fetchWindowClassname :: Window -> X String+fetchWindowClassname = fmap show . getNameWMClass++-- | Get the classname of the focused window.+logClassname :: Logger+logClassname = logWindowInfoFocusedWindow fetchWindowClassname++-- | Get the classnames of all windows on the visible workspace of the given+-- screen and format them according to the given functions.+logClassnamesOnScreen+  :: ScreenId           -- ^ Screen to log the classnames on+  -> (String -> String) -- ^ Formatting for the focused window+  -> (String -> String) -- ^ Formatting for the unfocused window+  -> Logger+logClassnamesOnScreen sid formatFoc formatUnfoc =+  logWindowInfoOnScreen fetchWindowClassname sid formatFoc formatUnfoc formatUnfoc++-- | Like 'logClassnamesOnScreen' but with support for urgent windows.  To+-- be used with "XMonad.Hooks.UrgencyHook".+logClassnamesOnScreen' :: ScreenId -> ClassnamesFormat -> Logger+logClassnamesOnScreen' sid (ClassnamesFormat formatFoc formatUnfoc formatUrg) =+  logWindowInfoOnScreen fetchWindowClassname sid formatFoc formatUnfoc formatUrg++-- | Like 'logClassnamesOnScreen', but directly use the "focused" screen+-- (the one with the currently focused workspace).+logClassnames :: (String -> String) -> (String -> String) -> Logger+logClassnames formatFoc formatUnfoc =+  logWindowInfoFocusedScreen fetchWindowClassname formatFoc formatUnfoc formatUnfoc++-- | Variant of 'logClassnames', but with support for urgent windows.+logClassnames' :: ClassnamesFormat -> Logger+logClassnames' (ClassnamesFormat formatFoc formatUnfoc formatUrg) =+  logWindowInfoFocusedScreen fetchWindowClassname formatFoc formatUnfoc formatUrg++-- | Formatting applied to the classnames of certain windows.+data ClassnamesFormat = ClassnamesFormat+  { focusedFormatClassname   :: String -> String  -- ^ Focused formatting.+  , unfocusedFormatClassname :: String -> String  -- ^ Unfocused formatting.+  , urgentFormatClassname    :: String -> String  -- ^ Formatting when urgent.+  }++-- | How to format these classnames by default when using 'logClassnames'' and+-- 'logClassnamesOnScreen''.+instance Default ClassnamesFormat where+  def = ClassnamesFormat+    { focusedFormatClassname   = xmobarFocusedFormat+    , unfocusedFormatClassname = xmobarWsFormat+    , urgentFormatClassname    = xmobarUrgentFormat+    }++-- | Internal function to get the specified window information for all windows on+-- the visible workspace of the given screen and format them according to the+-- given functions.+logWindowInfoOnScreen+  :: (Window -> X String)+  -> ScreenId+  -> (String -> String)+  -> (String -> String)+  -> (String -> String)+  -> Logger+logWindowInfoOnScreen getWindowInfo sid formatFoc formatUnfoc formatUrg =+  (`withScreen` sid) $ \screen -> do+    let focWin = fmap W.focus . W.stack . W.workspace $ screen+    urgWins <- readUrgents+    logWindowInfoOnScreenWorker getWindowInfo screen $ \win name ->+      if | Just win == focWin -> formatFoc   name+         | win `elem` urgWins -> formatUrg   name+         | otherwise          -> formatUnfoc name++-- | Internal helper function for 'logWindowInfoOnScreen'.+logWindowInfoOnScreenWorker+  :: (Window -> X String)+  -> WindowScreen+  -> (Window -> String -> String)+  -> Logger+logWindowInfoOnScreenWorker getWindowInfo screen logger = do+  let wins = maybe [] W.integrate . W.stack . W.workspace $ screen+  winNames <- traverse getWindowInfo wins+  pure . Just . unwords $ zipWith logger wins winNames++-- | Internal. Like 'logWindowInfoOnScreen', but directly use the "focused" screen+-- (the one with the currently focused workspace).+logWindowInfoFocusedScreen+  :: (Window -> X String)+  -> (String -> String)+  -> (String -> String)+  -> (String -> String)+  -> Logger+logWindowInfoFocusedScreen getWindowInfo formatFoc formatUnfoc formatUrg = do+  sid <- gets $ W.screen . W.current . windowset+  logWindowInfoOnScreen getWindowInfo sid formatFoc formatUnfoc formatUrg++-- | Internal function to get the specified information for the currently focused window+logWindowInfoFocusedWindow :: (Window -> X String) -> Logger+logWindowInfoFocusedWindow getWindowInfo = withWindowSet $ traverse getWindowInfo . W.peek++-- | Internal formatting helpers+xmobarWsFormat, xmobarFocusedFormat, xmobarUrgentFormat :: String -> String+xmobarWsFormat      = xmobarRaw . shorten 30 . xmobarStrip+xmobarFocusedFormat = wrap "[" "]" . xmobarWsFormat+xmobarUrgentFormat  = wrap "!" "!" . xmobarWsFormat+ -- | Get the name of the current layout. logLayout :: Logger logLayout = withWindowSet $ return . Just . ld@@ -186,17 +353,87 @@ logCurrent :: Logger logCurrent = withWindowSet $ return . Just . W.currentTag +-- | Log the given string, as is.+logConst :: String -> Logger+logConst = return . Just++-- | If the first logger returns @Nothing@, the default logger is used.+-- For example, to display a quote when no windows are on the screen,+-- you can do:+--+-- > logDefault logTitle (logConst "Hey, you, you're finally awake.")+logDefault :: Logger -> Logger -> Logger+logDefault l d = l >>= maybe d logConst++-- | An infix operator for 'logDefault', which can be more convenient to+-- combine multiple loggers.+--+-- > logTitle .| logWhenActive 0 (logConst "*") .| logConst "There's nothing here"+(.|) :: Logger -> Logger -> Logger+(.|) = logDefault++-- $xmonad-screen+-- It is also possible to bind loggers like 'logTitle' to a specific screen. For+-- example, using @logTitleOnScreen 1@ will log the title of the focused window+-- on screen 1, even if screen 1 is not currently active.++-- | Only display the 'Logger' if the screen with the given 'ScreenId' is+-- active.+-- For example, this can be used to create a marker that is only displayed+-- when the primary screen is active.+--+-- > logWhenActive 0 (logConst "*")+logWhenActive :: ScreenId -> Logger -> Logger+logWhenActive n l = do+  c <- withWindowSet $ return . W.screen . W.current+  if n == c then l else return Nothing++-- | Get the title (name) of the focused window, on the given screen.+logTitleOnScreen :: ScreenId -> Logger+logTitleOnScreen = logWindowInfoFocusedWindowOnScreen fetchWindowTitle++-- | Get the classname of the focused window, on the given screen.+logClassnameOnScreen :: ScreenId -> Logger+logClassnameOnScreen = logWindowInfoFocusedWindowOnScreen fetchWindowClassname++-- | Internal function to get the specified information for the focused window,+-- on the given screen.+logWindowInfoFocusedWindowOnScreen :: (Window -> X String) -> ScreenId -> Logger+logWindowInfoFocusedWindowOnScreen getWindowInfo =+  withScreen+    $ traverse getWindowInfo+    . (W.focus <$>)+    . W.stack+    . W.workspace++-- | Get the name of the visible workspace on the given screen.+logCurrentOnScreen :: ScreenId -> Logger+logCurrentOnScreen = withScreen $ logConst . W.tag . W.workspace++-- | Get the name of the current layout on the given screen.+logLayoutOnScreen :: ScreenId -> Logger+logLayoutOnScreen =+  withScreen $ logConst . description . W.layout . W.workspace++-- | A helper function to create screen-specific loggers.+withScreen :: (WindowScreen -> Logger) -> ScreenId -> Logger+withScreen f n = do+  ss <- withWindowSet $ return . W.screens+  case find ((== n) . W.screen) ss of+    Just s  -> f s+    Nothing -> pure Nothing+ -- $format -- Combine logger formatting functions to make your--- 'XMonad.Hooks.DynamicLog.ppExtras' more colorful and readable.--- (For convenience this module exports 'Control.Applicative.<$>' to--- use instead of \'.\' or \'$\' in hard to read formatting lines.+-- 'XMonad.Hooks.StatusBar.PP.ppExtras' more colorful and readable.+-- (For convenience, you can use '<$>' instead of \'.\' or \'$\' in hard to read+-- formatting lines. -- For example: ----- > myLogHook = dynamicLogWithPP defaultPP {+-- > myPP = def { -- >     -- skipped -- >     , ppExtras = [lLoad, lTitle, logSp 3, wrapL "[" "]" $ date "%a %d %b"]--- >     , ppOrder = \(ws,l,_,xs) -> [l,ws] ++ xs+-- >     , ppOrder = \(ws:l:_:xs) -> [l,ws] ++ xs -- >     } -- >   where -- >     -- lTitle = fixedWidthL AlignCenter "." 99 . dzenColorL "cornsilk3" "" . padL . shortenL 80 $ logTitle@@ -205,6 +442,9 @@ -- > -- >     lLoad = dzenColorL "#6A5ACD" "" . wrapL loadIcon "   " . padL $ loadAvg -- >     loadIcon = " ^i(/home/me/.dzen/icons/load.xbm)"+--+-- For more information on how to add the pretty-printer to your status bar, please+-- check "XMonad.Hooks.StatusBar". -- -- Note: When applying 'shortenL' or 'fixedWidthL' to logger strings -- containing colors or other formatting commands, apply the formatting
+ XMonad/Util/Loggers/NamedScratchpad.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.Loggers.NamedScratchpad+-- Description :  A collection of Loggers for "XMonad.Util.NamedScratchpad".+-- Copyright   :  (c) Brandon S Allbery <allbery.b@gmail.com>+-- License     :  BSD-style (see LICENSE)+--+-- Maintainer  :  Brandon S Allbery <allbery.b@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- "XMonad.Util.Loggers" for "XMonad.Util.NamedScratchpad"+--+-----------------------------------------------------------------------------++module XMonad.Util.Loggers.NamedScratchpad (-- * Usage+                                            -- $usage+                                            nspTrackStartup+                                           ,nspTrackHook+                                           ,nspActiveIcon+                                           ,nspActive+                                           ,nspActive') where++import XMonad.Core+import Graphics.X11.Xlib (Window)+import Graphics.X11.Xlib.Extras (Event(..))+import XMonad.Util.Loggers (Logger)+import XMonad.Util.NamedScratchpad (NamedScratchpad(..))+import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Prelude (All (..), chr, foldM, forM)+import qualified Data.IntMap as M+import qualified XMonad.StackSet as W (allWindows)++-- $usage+-- This is a set of 'Logger's for 'NamedScratchpad's.+-- It provides a 'startupHook' and 'handleEventHook' to keep track of+-- 'NamedScratchpad's, and several possible 'Logger's for use in+-- 'XMonad.Hooks.StatusBar.PP.ppExtras'.+--+-- You must add 'nspTrackStartup' to your 'startupHook' to initialize+-- 'NamedScratchpad' tracking and to detect any currently running+-- 'NamedScratchpad's on restart, and 'nspTrackHook' to your 'handleEventHook'+-- to track the coming and going of 'NamedScratchpad's.+--+-- Why would you want to do this? If you aren't using 'EwmhDesktops', this+-- gives you a way to see what 'NamedScratchpad's are running. If you are+-- using 'EwmhDesktops' then you can get that from a taskbar... but you may+-- have noticed that selecting the window from the taskbar moves you to+-- the 'NSP' workspace instead of moving the window to the current workspace.+-- (This is difficult to change; "minimizing" by moving it back to 'NSP'+-- is even harder.)+-- I hide the 'NamedScratchpad's from the taskbar and use this to track+-- them instead (see "XMonad.Util.NoTaskbar").++-- The extension data for tracking NSP windows+newtype NSPTrack = NSPTrack [Maybe Window]+instance ExtensionClass NSPTrack where+  initialValue = NSPTrack []++-- | 'startupHook' to initialize scratchpad activation tracking+--+-- > , startupHook = ... <> nspTrackStartup scratchpads+--+-- If you kickstart the 'logHook', do it /after/ 'nspTrackStartup'!+nspTrackStartup :: [NamedScratchpad] -> X ()+nspTrackStartup ns = do+  let ns'i = M.fromList $ zip [0..] $ map (const Nothing) ns+  ns' <- withWindowSet $ foldM (isSp ns) ns'i . W.allWindows+  XS.put (NSPTrack (map snd $ M.toAscList ns'))++isSp :: [NamedScratchpad] -> M.IntMap (Maybe Window) -> Window -> X (M.IntMap (Maybe Window))+isSp ns ws w = do+  n <- runQuery (scratchpadWindow ns) w+  return $ case n of+            Nothing -> ws+            Just n' -> M.insert n' (Just w) ws++scratchpadWindow :: [NamedScratchpad] -> Query (Maybe Int)+scratchpadWindow ns = foldM sp' Nothing (zip [0..] ns)+  where sp' :: Maybe Int -> (Int,NamedScratchpad) -> Query (Maybe Int)+        sp' r@(Just _) _              = return r+        sp' Nothing    (n,NS _ _ q _) = q >>= \p -> return $ if p then Just n else Nothing++-- | 'handleEventHook' to track scratchpad activation/deactivation+--+-- > , handleEventHook = ... <> nspTrackHook scratchpads+nspTrackHook :: [NamedScratchpad] -> Event -> X All+nspTrackHook _ DestroyWindowEvent{ev_window = w} = do+  XS.modify $ \(NSPTrack ws) -> NSPTrack $ map (\sw -> if sw == Just w then Nothing else sw) ws+  return (All True)+nspTrackHook ns ConfigureRequestEvent{ev_window = w} = do+  NSPTrack ws <- XS.get+  ws' <- forM (zip3 [0 :: Integer ..] ws ns) $ \(_,w',NS _ _ q _) -> do+    p <- runQuery q w+    return $ if p then Just w else w'+  XS.put $ NSPTrack ws'+  return (All True)+nspTrackHook _ _ = return (All True)++-- | 'Logger' for scratchpads' state, using Unicode characters as "icons".+--+-- > , ppExtras = [..., nspActive' iconChars showActive showInactive, ...]+nspActiveIcon :: [Char] -> (String -> String) -> (String -> String) -> Logger+nspActiveIcon icns act inact = do+  NSPTrack ws <- XS.get+  return $ if null ws+            then Nothing+            else let icon' n = if n < length icns then icns !! n else '\NUL'+                     icon  n = let c = icon' n+                                in [if c == '\NUL' then chr (0x2460 + n) else c]+                     ckact n w = let icn = icon n+                                  in case w of+                                      Nothing -> inact icn+                                      Just _  -> act   icn+                     s = unwords $ zipWith ckact [0..] ws+                  in Just s++-- | 'Logger' with String-s (and no defaults)+--+-- > , ppExtras = [..., nspActive iconStrs showActive showInactive, ...]+nspActive :: [String] -> (String -> String) -> (String -> String) -> Logger+nspActive icns act inact = do+  NSPTrack ws <- XS.get+  return $ if null ws+            then Nothing+            else let  ckact n w = let icn = icns !! n+                                    in case w of+                                        Nothing -> inact icn+                                        Just _  -> act   icn+                      s = unwords $ zipWith ckact [0..] ws+                  in Just s++-- | Variant of the above getting the String-s from the 'NamedScratchpad's+nspActive' :: [NamedScratchpad] -> (String -> String) -> (String -> String) -> Logger+nspActive' ns = nspActive (map name ns)
+ XMonad/Util/Minimize.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.Minimize+-- Description :  Common utilities for window minimizing\/maximizing.+-- Copyright   :  (c) Bogdan Sinitsyn (2016)+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  bogdan.sinitsyn@gmail.com+-- Stability   :  unstable+-- Portability :  not portable+--+-- Stores some common utilities for modules used for window minimizing/maximizing+--+-----------------------------------------------------------------------------+module XMonad.Util.Minimize+  ( RectMap+  , Minimized(..)+  ) where++import XMonad+import qualified XMonad.StackSet as W++import qualified Data.Map as M++type RectMap = M.Map Window (Maybe W.RationalRect)++data Minimized = Minimized+    { rectMap :: RectMap+    , minimizedStack :: [Window]+    }+    deriving (Eq, Read, Show)++instance ExtensionClass Minimized where+  initialValue = Minimized { rectMap = M.empty+                           , minimizedStack = []+                           }+  extensionType = PersistentExtension
XMonad/Util/NamedActions.hs view
@@ -1,8 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, StandaloneDeriving, TupleSections #-} -------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.NamedActions+-- Description :  A wrapper for keybinding configuration that can list the available keybindings. -- Copyright   :  2009 Adam Vogt <vogt.adam@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -12,6 +13,9 @@ -- -- A wrapper for keybinding configuration that can list the available -- keybindings.+--+-- Note that xmonad>=0.11 has by default a list of the default keybindings+-- bound to @M-S-/@ or @M-?@. --------------------------------------------------------------------  module XMonad.Util.NamedActions (@@ -21,6 +25,7 @@     spawn',     submapName,     addDescrKeys,+    addDescrKeys',     xMessage,      showKmSimple,@@ -42,14 +47,10 @@   import XMonad.Actions.Submap(submap)+import XMonad.Prelude (groupBy, keyToString) import XMonad-import System.Posix.Process(executeFile)-import Control.Arrow(Arrow((&&&), second, (***)))-import Data.Bits(Bits((.&.), complement))-import Data.List (groupBy)-import System.Exit(ExitCode(ExitSuccess), exitWith)--import Control.Applicative ((<*>))+import Control.Arrow(Arrow((&&&), second))+import System.Exit(exitSuccess)  import qualified Data.Map as M import qualified XMonad.StackSet as W@@ -63,7 +64,7 @@ -- > import XMonad.Util.EZConfig -- > -- > main = xmonad $ addDescrKeys ((mod4Mask, xK_F1), xMessage) myKeys--- >                    defaultConfig { modMask = mod4Mask }+-- >                    def { modMask = mod4Mask } -- > -- > myKeys c = (subtitle "Custom Keys":) $ mkNamedKeymap c $ -- >    [("M-x a", addName "useless message" $ spawn "xmessage foo"),@@ -110,13 +111,14 @@ -- | 'sendMessage' but add a description that is @show message@. Note that not -- all messages have show instances. sendMessage' :: (Message a, Show a) => a -> NamedAction-sendMessage' x = NamedAction $ (XMonad.sendMessage x,show x)+sendMessage' x = NamedAction (XMonad.sendMessage x,show x)  -- | 'spawn' but the description is the string passed spawn' :: String -> NamedAction spawn' x = addName x $ spawn x  class HasName a where+    {-# MINIMAL getAction #-}     showName :: a -> [String]     showName = const [""]     getAction :: a -> X ()@@ -163,22 +165,6 @@      [(d, b)] -> [(d, b1)] -> [(d, NamedAction)] a ^++^ b = map (second NamedAction) a ++ map (second NamedAction) b --- | Or allow another lookup table?-modToString :: KeyMask -> String-modToString mask = concatMap (++"-") $ filter (not . null)-                $ map (uncurry pick)-                [(mod1Mask, "M1")-                ,(mod2Mask, "M2")-                ,(mod3Mask, "M3")-                ,(mod4Mask, "M4")-                ,(mod5Mask, "M5")-                ,(controlMask, "C")-                ,(shiftMask,"Shift")]-    where pick m str = if m .&. complement mask == 0 then str else ""--keyToString :: (KeyMask, KeySym) -> [Char]-keyToString = uncurry (++) . (modToString *** keysymToString)- showKmSimple :: [((KeyMask, KeySym), NamedAction)] -> [[Char]] showKmSimple = concatMap (\(k,e) -> if snd k == 0 then "":showName e else map ((keyToString k ++) . smartSpace) $ showName e) @@ -187,12 +173,12 @@ smartSpace xs = ' ':xs  _test :: String-_test = unlines $ showKm $ defaultKeysDescr XMonad.defaultConfig { XMonad.layoutHook = XMonad.Layout $ XMonad.layoutHook XMonad.defaultConfig }+_test = unlines $ showKm $ defaultKeysDescr XMonad.def { XMonad.layoutHook = XMonad.Layout $ XMonad.layoutHook XMonad.def }  showKm :: [((KeyMask, KeySym), NamedAction)] -> [String] showKm keybindings = padding $ do     (k,e) <- keybindings-    if snd k == 0 then map ((,) "") $ showName e+    if snd k == 0 then map ("",) $ showName e         else map ((,) (keyToString k) . smartSpace) $ showName e     where padding = let pad n (k,e) = if null k then "\n>> "++e else take n (k++repeat ' ') ++ e                         expand xs n = map (pad n) xs@@ -201,9 +187,7 @@  -- | An action to send to 'addDescrKeys' for showing the keybindings. See also 'showKm' and 'showKmSimple' xMessage :: [((KeyMask, KeySym), NamedAction)] -> NamedAction-xMessage x = addName "Show Keybindings" $ io $ do-    xfork $ executeFile "xmessage" True ["-default", "okay", unlines $ showKm x] Nothing-    return ()+xMessage x = addName "Show Keybindings" $ xmessage $ unlines $ showKm x  -- | Merge the supplied keys with 'defaultKeysDescr', also adding a keybinding -- to run an action for showing the keybindings.@@ -221,12 +205,12 @@ addDescrKeys' (k,f) ks conf =     let shk l = f $ [(k,f $ ks l)] ^++^ ks l         keylist l = M.map getAction $ M.fromList $ ks l ^++^ [(k, shk l)]-    in conf { keys = keylist }+     in conf { keys = keylist <> keys conf } --- | A version of the default keys from 'XMonad.Config.defaultConfig', but with+-- | A version of the default keys from the default configuration, but with -- 'NamedAction'  instead of @X ()@ defaultKeysDescr :: XConfig Layout -> [((KeyMask, KeySym), NamedAction)]-defaultKeysDescr conf@(XConfig {XMonad.modMask = modm}) =+defaultKeysDescr conf@XConfig{XMonad.modMask = modm} =     [ subtitle "launching and killing programs"     , ((modm .|. shiftMask, xK_Return), addName "Launch Terminal" $ spawn $ XMonad.terminal conf) -- %! Launch terminal     , ((modm,               xK_p     ), addName "Launch dmenu" $ spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! Launch dmenu@@ -264,7 +248,7 @@     , ((modm              , xK_period), sendMessage' (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area      , subtitle "quit, or restart"-    , ((modm .|. shiftMask, xK_q     ), addName "Quit" $ io (exitWith ExitSuccess)) -- %! Quit xmonad+    , ((modm .|. shiftMask, xK_q     ), addName "Quit" $ io exitSuccess) -- %! Quit xmonad     , ((modm              , xK_q     ), addName "Restart" $ spawn "xmonad --recompile && xmonad --restart") -- %! Restart xmonad     ]
XMonad/Util/NamedScratchpad.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE InstanceSigs   #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns   #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.NamedScratchpad+-- Description :  Toggle arbitrary windows to and from the current workspace. -- Copyright   :  (c) Konstantin Sobolev <konstantin.sobolev@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -17,31 +20,59 @@   -- * Usage   -- $usage   NamedScratchpad(..),+  scratchpadWorkspaceTag,   nonFloating,   defaultFloating,   customFloating,   NamedScratchpads,   namedScratchpadAction,+  spawnHereNamedScratchpadAction,+  customRunNamedScratchpadAction,   allNamedScratchpadAction,   namedScratchpadManageHook,+  nsHideOnFocusLoss,+  nsSingleScratchpadPerWorkspace,++  -- * Dynamic Scratchpads+  -- $dynamic-scratchpads+  dynamicNSPAction,+  toggleDynamicNSP,++  -- * Exclusive Scratchpads+  -- $exclusive-scratchpads+  addExclusives,+  -- ** Keyboard related+  resetFocusedNSP,+  -- ** Mouse related+  setNoexclusive,+  resizeNoexclusive,+  floatMoveNoexclusive,++  -- * Deprecations   namedScratchpadFilterOutWorkspace,-  namedScratchpadFilterOutWorkspacePP+  namedScratchpadFilterOutWorkspacePP,+   ) where +import Data.Map.Strict (Map, (!?)) import XMonad-import XMonad.Hooks.ManageHelpers (doRectFloat) import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace)-import XMonad.Hooks.DynamicLog (PP, ppSort)--import Control.Monad (filterM)-import Data.Maybe (listToMaybe)+import XMonad.Actions.SpawnOn (spawnHere)+import XMonad.Actions.TagWindows (addTag, delTag)+import XMonad.Hooks.ManageHelpers (doRectFloat)+import XMonad.Hooks.RefocusLast (withRecentsIn)+import XMonad.Hooks.StatusBar.PP (PP, ppSort)+import XMonad.Prelude (appEndo, filterM, findM, foldl', for_, liftA2, unless, void, when, (<=<)) -import qualified XMonad.StackSet as W+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict    as Map +import qualified XMonad.StackSet             as W+import qualified XMonad.Util.ExtensibleState as XS  -- $usage -- Allows to have several floating scratchpads running different applications.--- Bind a key to 'namedScratchpadSpawnAction'.+-- Bind a key to 'namedScratchpadAction'. -- Pressing it will spawn configured application, or bring it to the current -- workspace if it already exists. -- Pressing the key with the application on the current workspace will@@ -82,8 +113,40 @@ -- >  , manageHook = namedScratchpadManageHook scratchpads -- -- For detailed instruction on editing the key binding see--- "XMonad.Doc.Extending#Editing_key_bindings"+-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> --+-- For some applications (like displaying your workspaces in a status bar) it+-- is convenient to filter out the @NSP@ workspace when looking at all+-- workspaces. For this, you can use 'XMonad.Hooks.StatusBar.PP.filterOutWsPP',+-- or 'XMonad.Util.WorkspaceCompare.filterOutWs' together with+-- 'XMonad.Hooks.EwmhDesktops.addEwmhWorkspaceSort' if your status bar gets+-- the list of workspaces from EWMH.  See the documentation of these functions+-- for examples.+--+-- If you want to explore this module further, scratchpads can come in+-- many forms and flavours:+--+--   + \"Regular\" scratchpads: they can be predefined and+--     summoned/banished with a key press.  These are the scratchpads+--     that you have seen above.+--+--   + [Dynamic scratchpads](#g:dynamic-scratchpads), which allow you to+--     dynamically declare existing windows as scratchpads.  These can+--     be treated as a separate type of scratchpad.+--+--   + [Exclusive](#g:exclusive-scratchpads) scratchpads, which can be+--     seen as a property of already existing scratchpads.  Marking+--     scratchpads as exclusive will not allow them to be shown on the+--     same workspace; the scratchpad being brought up will hide the+--     others.+--+-- See the relevant sections in the documentation for more information.+--+-- Further, there is also a @logHook@ that you can use to hide+-- scratchpads when they lose focus; this is functionality akin to what+-- some dropdown terminals provide.  See the documentation of+-- 'nsHideOnFocusLoss' for an example how to set this up.+--  -- | Single named scratchpad configuration data NamedScratchpad = NS { name   :: String      -- ^ Scratchpad name@@ -92,6 +155,52 @@                           , hook   :: ManageHook  -- ^ Manage hook called for application window, use it to define the placement. See @nonFloating@, @defaultFloating@ and @customFloating@                           } +-- | The NSP state.+data NSPState = NSPState+  { nspExclusives  :: !(Map String NamedScratchpads)+    -- ^ Associates the name of a scratchpad to some list of scratchpads+    -- that should be mutually exclusive to it.+  , nspScratchpads :: !(Map String NamedScratchpad)+    -- ^ Associates a name to an entire scratchpad.+  }++instance ExtensionClass NSPState where+  initialValue :: NSPState+  initialValue = NSPState mempty mempty++-- | Try to:+--+--    (i) Fill the 'nspScratchpads' portion of the 'NSPState' with the+--        given list of scratchpads.  In case that particular map of the+--        state is already non-empty, don't do anything and return that+--        state.+--+--   (ii) Replace possibly dummy scratchpads in @nspExclusives@ with+--        proper values.  For convenience, the user may specify+--        exclusive scratchpads by name in the startup hook.  However,+--        we don't necessarily have all information then to immediately+--        turn these into proper NamedScratchpads.  As such, we thinly+--        wrap the names into an NSP skeleton, to be filled in later.+--        This function, to be executed _before_+--        'someNamedScratchpadAction' is the (latest) point where that+--        happens.+fillNSPState :: NamedScratchpads -> X NSPState+fillNSPState nsps = do+    nsp@(NSPState exs scratches) <- XS.get+    if null scratches+      then let nspState = NSPState (fillOut exs) nspScratches+            in nspState <$ XS.put nspState+      else pure nsp+  where+    -- @fillNSPState@ only runs once, so the complexity here is probably+    -- not a big deal.+    nspScratches :: Map String NamedScratchpad+    nspScratches = Map.fromList $ zip (map name nsps) nsps+    fillOut :: Map String [NamedScratchpad] -> Map String [NamedScratchpad]+    fillOut exs = foldl' (\nspMap n -> Map.map (replaceWith n) nspMap) exs nsps+    replaceWith :: NamedScratchpad -> [NamedScratchpad] -> [NamedScratchpad]+    replaceWith n = map (\x -> if name x == name n then n else x)+ -- | Manage hook that makes the window non-floating nonFloating :: ManageHook nonFloating = idHook@@ -104,69 +213,406 @@ customFloating :: W.RationalRect -> ManageHook customFloating = doRectFloat +-- | @isNSP win nsps@ checks whether the window @win@ is any scratchpad+-- in @nsps@.+isNSP :: Window -> NamedScratchpads -> X Bool+isNSP w = fmap or . traverse ((`runQuery` w) . query)+ -- | Named scratchpads configuration type NamedScratchpads = [NamedScratchpad] --- | Finds named scratchpad configuration by name-findByName :: NamedScratchpads -> String -> Maybe NamedScratchpad-findByName c s = listToMaybe $ filter ((s==) . name) c- -- | Runs application which should appear in specified scratchpad runApplication :: NamedScratchpad -> X () runApplication = spawn . cmd +-- | Runs application which should appear in a specified scratchpad on the workspace it was launched on+runApplicationHere :: NamedScratchpad -> X ()+runApplicationHere = spawnHere . cmd+ -- | Action to pop up specified named scratchpad+--+-- Note [Ignored Arguments]: Most of the time, this function ignores its+-- first argument and uses 'NSPState' instead.  The only time when it+-- does not is when no other window has been opened before in the+-- running xmonad instance.  If this is not your use-case, you can+-- safely call this function with an empty list. namedScratchpadAction :: NamedScratchpads -- ^ Named scratchpads configuration                       -> String           -- ^ Scratchpad name                       -> X ()-namedScratchpadAction = someNamedScratchpadAction (\f ws -> f $ head ws)+namedScratchpadAction = customRunNamedScratchpadAction runApplication +-- | Action to pop up specified named scratchpad, initially starting it on the current workspace.+--+-- This function /almost always/ ignores its first argument; see Note+-- [Ignored Arguments] for 'namedScratchpadAction'.+spawnHereNamedScratchpadAction :: NamedScratchpads           -- ^ Named scratchpads configuration+                               -> String                     -- ^ Scratchpad name+                               -> X ()+spawnHereNamedScratchpadAction = customRunNamedScratchpadAction runApplicationHere++-- | Action to pop up specified named scratchpad, given a custom way to initially start the application.+--+-- This function /almost always/ ignores its second argument; see Note+-- [Ignored Arguments] for 'namedScratchpadAction'.+customRunNamedScratchpadAction :: (NamedScratchpad -> X ())  -- ^ Function initially running the application, given the configured @scratchpad@ cmd+                               -> NamedScratchpads           -- ^ Named scratchpads configuration+                               -> String                     -- ^ Scratchpad name+                               -> X ()+customRunNamedScratchpadAction = someNamedScratchpadAction (\f ws -> f $ NE.head ws)++-- | Like 'namedScratchpadAction', but execute the action for all+-- scratchpads that match the query.+--+-- This function /almost always/ ignores its first argument; see Note+-- [Ignored Arguments] for 'namedScratchpadAction'. allNamedScratchpadAction :: NamedScratchpads                          -> String                          -> X ()-allNamedScratchpadAction = someNamedScratchpadAction mapM_+allNamedScratchpadAction = someNamedScratchpadAction mapM_ runApplication -someNamedScratchpadAction :: ((Window -> X ()) -> [Window] -> X ())+-- | A @logHook@ to hide scratchpads when they lose focus.  This can be+-- useful for e.g. dropdown terminals.  Note that this also requires you+-- to use the 'XMonad.Hooks.RefocusLast.refocusLastLogHook'.+--+-- ==== __Example__+--+-- > import XMonad.Hooks.RefocusLast (refocusLastLogHook)+-- > import XMonad.Util.NamedScratchpad+-- >+-- > main = xmonad $ def+-- >   { logHook = refocusLastLogHook+-- >            >> nsHideOnFocusLoss myScratchpads+-- >               -- enable hiding for all of @myScratchpads@+-- >   }+nsHideOnFocusLoss :: NamedScratchpads -> X ()+nsHideOnFocusLoss scratches =+    nsHideOnCondition $ \ lastFocus _curFoc _ws hideScratch ->+        whenX (isNSP lastFocus scratches) $+            hideScratch lastFocus++-- | A @logHook@ to have only one active scratchpad on a workspace. This can+-- be useful when working with multiple floating scratchpads which would+-- otherwise be stacked. Note that this also requires you to use the+-- 'XMonad.Hooks.RefocusLast.refocusLastLogHook'.+--+-- ==== __Example__+--+-- > import XMonad.Hooks.RefocusLast (refocusLastLogHook)+-- > import XMonad.Util.NamedScratchpad+-- >+-- > main = xmonad $ def+-- >   { logHook = refocusLastLogHook+-- >            >> nsHideOnNewScratchpad myScratchpads+-- >               -- enable hiding for all of @myScratchpads@+-- >   }+nsSingleScratchpadPerWorkspace :: NamedScratchpads -> X ()+nsSingleScratchpadPerWorkspace scratches =+    nsHideOnCondition $ \ _lastFocus curFocus winSet hideScratch -> do+        allScratchesButCurrent <-+            filterM (liftA2 (<&&>) (pure . (/= curFocus)) (`isNSP` scratches))+                    (W.index winSet)+        whenX (isNSP curFocus scratches) $+            for_ allScratchesButCurrent hideScratch++-- | Hide scratchpads according to some condition. See 'nsHideOnFocusLoss' and+-- 'nsSingleScratchpadPerWorkspace' for usage examples.+nsHideOnCondition+    :: (  Window           -- Last focus.+       -> Window           -- Current focus.+       -> WindowSet        -- Current windowset.+       -> (Window -> X ()) -- A function to hide the named scratchpad.+       -> X ())+    -> X ()+nsHideOnCondition cond = withWindowSet $ \winSet -> do+    let cur = W.currentTag winSet+    withRecentsIn cur () $ \lastFocus curFocus -> do+        let hideScratch :: Window -> X ()+            hideScratch win = shiftToNSP (W.workspaces winSet) ($ win)+            isWorthy =+                -- Check for the window being on the current workspace; if there+                -- is no history (i.e., curFocus ≡ lastFocus), don't do anything+                -- because the potential scratchpad is definitely focused.+                lastFocus `elem` W.index winSet && lastFocus /= curFocus+                -- Don't do anything on the NSP workspace, lest the world explodes.+                && cur /= scratchpadWorkspaceTag+        when isWorthy $+            cond lastFocus curFocus winSet hideScratch++-- | Execute some action on a named scratchpad.+--+-- This function /almost always/ ignores its third argument; see Note+-- [Ignored Arguments] for 'namedScratchpadAction'.+someNamedScratchpadAction :: ((Window -> X ()) -> NE.NonEmpty Window -> X ())+                          -> (NamedScratchpad -> X ())                           -> NamedScratchpads                           -> String                           -> X ()-someNamedScratchpadAction f confs n-    | Just conf <- findByName confs n = withWindowSet $ \s -> do-                     filterCurrent <- filterM (runQuery (query conf))-                                        ((maybe [] W.integrate . W.stack . W.workspace . W.current) s)-                     filterAll <- filterM (runQuery (query conf)) (W.allWindows s)-                     case filterCurrent of-                       [] -> do-                         case filterAll of-                           [] -> runApplication conf-                           _  -> f (windows . W.shiftWin (W.currentTag s)) filterAll-                       _ -> do-                         if null (filter ((== scratchpadWorkspaceTag) . W.tag) (W.workspaces s))-                             then addHiddenWorkspace scratchpadWorkspaceTag-                             else return ()-                         f (windows . W.shiftWin scratchpadWorkspaceTag) filterAll-    | otherwise = return ()+someNamedScratchpadAction f runApp _ns scratchpadName = do+    NSPState{ nspScratchpads } <- fillNSPState _ns  -- See Note [Filling NSPState]+    case nspScratchpads !? scratchpadName of+        Just conf -> withWindowSet $ \winSet -> do+            let focusedWspWindows = W.index winSet+                allWindows        = W.allWindows winSet+            matchingOnCurrent <- filterM (runQuery (query conf)) focusedWspWindows+            matchingOnAll     <- filterM (runQuery (query conf)) allWindows +            case NE.nonEmpty matchingOnCurrent of+                -- no matching window on the current workspace -> scratchpad not running or in background+                Nothing -> do+                    -- summon the scratchpad+                    case NE.nonEmpty matchingOnAll of+                        Nothing   -> runApp conf+                        Just wins -> f (windows . W.shiftWin (W.currentTag winSet)) wins+                    -- check for exclusive scratchpads to hide+                    hideUnwanted (name conf) --- tag of the scratchpad workspace+                -- matching window running on current workspace -> window should be shifted to scratchpad workspace+                Just wins -> shiftToNSP (W.workspaces winSet) (`f` wins)+        Nothing -> return ()++{- Note [Filling NSPState]++We have to potentially populate the state with the given scratchpads+here, in case the manageHook didn't run yet and it's still empty.++For backwards compatibility, 3fc830aa09368dca04df24bf7ec4ac817f2de479+introduced an internal state that's filled in the+namedScratchpadManageHook.  A priori, this means that we would need some+kind of MapRequestEvent to happen before processing scratchpads, since+the manageHook doesn't run otherwise, leaving the extensible state empty+until then.  When trying to open a scratchpad right after starting+xmonad—i.e., before having opened a window—we thus have to populate the+NSPState before looking for scratchpads.++Related: https://github.com/xmonad/xmonad-contrib/issues/728+-}++-- | Tag of the scratchpad workspace scratchpadWorkspaceTag :: String scratchpadWorkspaceTag = "NSP"  -- | Manage hook to use with named scratchpads namedScratchpadManageHook :: NamedScratchpads -- ^ Named scratchpads configuration                           -> ManageHook-namedScratchpadManageHook = composeAll . fmap (\c -> query c --> hook c)+namedScratchpadManageHook nsps = do+    ns <- Map.elems . nspScratchpads <$> liftX (fillNSPState nsps)+    composeAll $ fmap (\c -> query c --> hook c) ns +-- | Shift some windows to the scratchpad workspace according to the+-- given function.  The workspace is created if necessary.+shiftToNSP :: [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()+shiftToNSP ws f = do+    unless (any ((scratchpadWorkspaceTag ==) . W.tag) ws) $+        addHiddenWorkspace scratchpadWorkspaceTag+    f (windows . W.shiftWin scratchpadWorkspaceTag)++------------------------------------------------------------------------+-- Dynamic scratchpad functionality++-- $dynamic-scratchpads+--+-- Dynamic scratchpads allow you to declare existing windows as+-- scratchpads.  You can bind a key to make a window start/stop being a+-- scratchpad, and another key to toggle its visibility.  Because+-- dynamic scratchpads are based on existing windows, they have some+-- caveats in comparison to "normal" scratchpads:+--+--   * @xmonad@ has no way of knowing /how/ windows were spawned and+--     thus one is not able to "start" dynamic scratchpads again after+--     the associated window has been closed.+--+--   * If you already have an active dynamic scratchpad @"dyn1"@ and you+--     call 'toggleDynamicNSP' with another window, that window will+--     henceforth occupy the @"dyn1"@ scratchpad.  If you still need the+--     old window, you might have to travel to your scratchpad workspace+--     ('scratchpadWorkspaceTag') in order to retrieve it.+--+-- As an example, the following snippet contains keybindings for two+-- dynamic scratchpads, called @"dyn1"@ and @"dyn2"@:+--+-- > import XMonad.Util.NamedScratchpads+-- >+-- > , ("M-s-a", withFocused $ toggleDynamicNSP "dyn1")+-- > , ("M-s-b", withFocused $ toggleDynamicNSP "dyn2")+-- > , ("M-a"  , dynamicNSPAction "dyn1")+-- > , ("M-b"  , dynamicNSPAction "dyn2")+--++-- | A 'NamedScratchpad' representing a "dynamic" scratchpad; i.e., a+-- scratchpad based on an already existing window.+mkDynamicNSP :: String -> Window -> NamedScratchpad+mkDynamicNSP s w =+    NS { name  = s+       , cmd   = ""               -- we are never going to spawn a dynamic scratchpad+       , query = (w ==) <$> ask+       , hook  = mempty           -- cmd is never called so this will never run+       }++-- | Make a window a dynamic scratchpad+addDynamicNSP :: String -> Window -> X ()+addDynamicNSP s w = XS.modify $ \(NSPState exs ws) ->+  NSPState exs (Map.insert s (mkDynamicNSP s w) ws)++-- | Make a window stop being a dynamic scratchpad+removeDynamicNSP :: String -> X ()+removeDynamicNSP s = XS.modify $ \(NSPState exs ws) -> NSPState exs (Map.delete s ws)++-- | Toggle the visibility of a dynamic scratchpad.+dynamicNSPAction :: String -> X ()+dynamicNSPAction = customRunNamedScratchpadAction (const $ pure ()) []++-- | Either create a dynamic scratchpad out of the given window, or stop+-- a window from being one if it already is.+toggleDynamicNSP :: String -> Window -> X ()+toggleDynamicNSP s w = do+    NSPState{ nspScratchpads } <- XS.get+    case nspScratchpads !? s of+        Nothing  -> addDynamicNSP s w+        Just nsp -> ifM (runQuery (query nsp) w)+                        (removeDynamicNSP s)+                        (addDynamicNSP s w)++-----------------------------------------------------------------------+-- Exclusive scratchpads++-- $exclusive-scratchpads+--+-- Exclusive scratchpads allow you to hide certain scratchpads in+-- relation to others.  There can be multiple groups of pairwise+-- exclusive scratchpads; whenever one such scratchpad gets called, it+-- will hide all other scratchpads on the focused workspace that are in+-- this group.+--+-- For example, having defined "Calc", "Mail", and "Term" scratchpads,+-- you can use 'addExclusives' to make some of them dislike each other:+--+-- > myExclusives = addExclusives+-- >   [ ["Calc", "Mail"]+-- >   , ["Mail", "Term"]+-- >   ]+--+-- You now have to add @myExclusives@ to you startupHook:+--+-- > main :: IO+-- > main = xmonad . … . $ def+-- >   { …+-- >   , startupHook = myStartupHook >> myExclusives+-- >   }+--+-- This will hide the "Mail" scratchpad whenever the "Calc" scratchpad+-- is brought up, and vice-versa.  Likewise, "Mail" and "Term" behave in+-- this way, but "Calc" and "Term" may peacefully coexist.+--+-- If you move a scratchpad it still gets hidden when you fetch a+-- scratchpad of the same family.  To change that behaviour—and make+-- windows not exclusive anymore when they get resized or moved—add+-- these mouse bindings (see+-- "XMonad.Doc.Extending#Editing_mouse_bindings"):+--+-- >     , ((mod4Mask, button1), floatMoveNoexclusive)+-- >     , ((mod4Mask, button3), resizeNoexclusive)+--+-- To reset a moved scratchpad to the original position that you set+-- with its hook, focus is and then call 'resetFocusedNSP'.  For+-- example, if you want to extend @M-\<Return\>@ to reset the placement+-- when a scratchpad is in focus but keep the default behaviour for+-- tiled windows, set these key bindings:+--+-- > , ((modMask, xK_Return), windows W.swapMaster >> resetFocusedNSP)++-- | Make some scratchpads exclusive.+addExclusives :: [[String]] -> X ()+addExclusives exs = do+    NSPState _ ws <- XS.get+    -- Re-initialise `ws' to nothing, so we can react to changes in case+    -- of a restart.  See 'fillNSPState' for more details on filling.+    XS.put (NSPState (foldl' (go []) mempty exs) mempty)+    unless (null ws) $+        void (fillNSPState (Map.elems ws))+  where+    -- Ignoring that this is specialised to NSPs, it works something like+    -- >>> foldl' (go []) mempty [[1, 2], [3, 4], [1, 3]]+    -- fromList [(1, [3, 2]), (2, [1]), (3, [1, 4]), (4, [3])]+    go _  m []       = m+    go ms m (n : ns) = go (n : ms) (Map.insertWith (<>) n (mkNSP (ms <> ns)) m) ns+    mkNSP = map (\n -> NS n mempty (pure False) mempty)++-- | @setNoexclusive w@ makes the window @w@ lose its exclusivity+-- features.+setNoexclusive :: Window -> X ()+setNoexclusive w = do+    NSPState _ ws <- XS.get+    whenX (isNSP w (Map.elems ws)) $+        addTag "_NSP_NOEXCLUSIVE" w++-- | If the focused window is a scratchpad, the scratchpad gets reset to+-- the original placement specified with the hook and becomes exclusive+-- again.+resetFocusedNSP :: X ()+resetFocusedNSP = do+    NSPState _ (Map.elems -> ws) <- XS.get+    withFocused $ \w -> do+        mbWin <- findM ((`runQuery` w) . query) ws+        whenJust mbWin $ \win -> do+            (windows . appEndo <=< runQuery (hook win)) w+            hideUnwanted (name win)+            delTag "_NSP_NOEXCLUSIVE" w++-- | @hideUnwanted nspWindow@ hides all windows that @nspWindow@ does+-- not like; i.e., windows that are in some kind of exclusivity contract+-- with it.+--+-- A consistency assumption for this is that @nspWindow@ must be the+-- currently focused window.  For this to take effect, @nspWindow@ must+-- not have set the @_NSP_NOEXCLUSIVE@ property, neither must any+-- exclusive window we'd like to hide.+hideUnwanted :: String -> X ()+hideUnwanted nspWindow = withWindowSet $ \winSet -> do+    NSPState{ nspExclusives } <- XS.get+    whenJust (nspExclusives !? nspWindow) $ \unwanted ->+        withFocused $ \w -> whenX (runQuery notIgnored w) $ do+            for_ (W.index winSet) $ \win ->+                whenX (runQuery (isUnwanted unwanted) win) $+                    shiftToNSP (W.workspaces winSet) ($ win)+  where+    notIgnored :: Query Bool+    notIgnored = notElem "_NSP_NOEXCLUSIVE" . words <$> stringProperty "_XMONAD_TAGS"++    isUnwanted :: [NamedScratchpad] -> Query Bool+    isUnwanted = (notIgnored <&&>) . foldr (\nsp qs -> qs <||> query nsp) (pure False)++-- | Float and drag the window; make it lose its exclusivity status in+-- the process.+floatMoveNoexclusive :: Window -- ^ Window which should be moved+                     -> X ()+floatMoveNoexclusive = mouseHelper mouseMoveWindow++-- | Resize window and make it lose its exclusivity status in the+-- process.+resizeNoexclusive :: Window -- ^ Window which should be resized+                  -> X ()+resizeNoexclusive = mouseHelper mouseResizeWindow++mouseHelper :: (Window -> X a) -> Window -> X ()+mouseHelper f w = setNoexclusive w+               >> focus w+               >> f w+               >> windows W.shiftMaster++------------------------------------------------------------------------+-- Deprecations+ -- | Transforms a workspace list containing the NSP workspace into one that -- doesn't contain it. Intended for use with logHooks. namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace] namedScratchpadFilterOutWorkspace = filter (\(W.Workspace tag _ _) -> tag /= scratchpadWorkspaceTag)+{-# DEPRECATED namedScratchpadFilterOutWorkspace "Use XMonad.Util.WorkspaceCompare.filterOutWs [scratchpadWorkspaceTag] instead" #-}  -- | Transforms a pretty-printer into one not displaying the NSP workspace. -- -- A simple use could be: ----- > logHook = dynamicLogWithPP . namedScratchpadFilterOutWorkspace $ defaultPP+-- > logHook = dynamicLogWithPP . namedScratchpadFilterOutWorkspace $ def -- -- Here is another example, when using "XMonad.Layout.IndependentScreens". -- If you have handles @hLeft@ and @hRight@ for bars on the left and right screens, respectively, and @pp@ is a pretty-printer function that takes a handle, you could write@@ -177,5 +623,4 @@ namedScratchpadFilterOutWorkspacePP pp = pp {   ppSort = fmap (. namedScratchpadFilterOutWorkspace) (ppSort pp)   }---- vim:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20:+{-# DEPRECATED namedScratchpadFilterOutWorkspacePP "Use XMonad.Hooks.StatusBar.PP.filterOutWsPP [scratchpadWorkspaceTag] instead" #-}
XMonad/Util/NamedWindows.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.NamedWindows+-- Description :  Associate the X titles of windows with them. -- Copyright   :  (c) David Roundy <droundy@darcs.net> -- License     :  BSD3-style (see LICENSE) --@@ -18,13 +19,13 @@                                    -- $usage                                    NamedWindow,                                    getName,+                                   getNameWMClass,                                    withNamedWindow,                                    unName                                   ) where -import Control.Applicative ( (<$>) )-import Control.Exception.Extensible as E-import Data.Maybe ( fromMaybe, listToMaybe )+import Control.Exception as E+import XMonad.Prelude ( fromMaybe, listToMaybe, (>=>) )  import qualified XMonad.StackSet as W ( peek ) @@ -53,11 +54,25 @@          copy prop = fromMaybe "" . listToMaybe <$> wcTextPropertyToTextList d prop -    io $ getIt `E.catch` \(SomeException _) ->  ((`NW` w) . resName) `fmap` getClassHint d w+    io $ getIt `E.catch` \(SomeException _) ->  (`NW` w) . resName <$> getClassHint d w +-- | Get 'NamedWindow' using 'wM_CLASS'+getNameWMClass :: Window -> X NamedWindow+getNameWMClass w =+  withDisplay $ \d+    -- TODO, this code is ugly and convoluted -- clean it up+   -> do+    let getIt = bracket getProp (xFree . tp_value) (fmap (`NW` w) . copy)+        getProp = getTextProperty d w wM_CLASS+        copy prop =+          fromMaybe "" . listToMaybe <$> wcTextPropertyToTextList d prop+    io $+      getIt `E.catch` \(SomeException _) ->+        (`NW` w) . resName <$> getClassHint d w+ unName :: NamedWindow -> Window unName (NW _ w) = w  withNamedWindow :: (NamedWindow -> X ()) -> X () withNamedWindow f = do ws <- gets windowset-                       whenJust (W.peek ws) $ \w -> getName w >>= f+                       whenJust (W.peek ws) (getName >=> f)
+ XMonad/Util/NoTaskbar.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      : XMonad.Util.NoTaskbar+-- Description : Mark a window to be ignored by EWMH taskbars and pagers.+-- Copyright   : (c) ???+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : ???+--+-- Function and manageHook to mark a window to be ignored by EWMH+-- taskbars and pagers.+--+-----------------------------------------------------------------------------++module XMonad.Util.NoTaskbar (-- * Usage+                              -- $usage+                              noTaskbar+                             ,markNoTaskbar) where++import XMonad.Core+import XMonad.Prelude (fi)+import XMonad.ManageHook+import Graphics.X11.Xlib (Window)+import Graphics.X11.Xlib.Atom (aTOM)+import Graphics.X11.Xlib.Extras (changeProperty32+                                ,propModePrepend)+import Control.Monad.Reader (ask)++-- $usage+-- Utility functions to hide windows from pagers and taskbars. Mostly useful+-- when EWMH doesn't do what you intend (e.g. for 'NamedScratchpad' windows you+-- probably don't want to be dumped into the 'NSP' workspace).++-- | A 'ManageHook' to mark a window to not be shown in pagers or taskbars.+noTaskbar :: ManageHook+noTaskbar = ask >>= (>> idHook) . liftX . markNoTaskbar++-- | An 'X' action to mark a window to not be shown in pagers or taskbars.+markNoTaskbar :: Window -> X ()+markNoTaskbar w = withDisplay $ \d -> do+                    ws <- getAtom "_NET_WM_STATE"+                    ntb <- getAtom "_NET_WM_STATE_SKIP_TASKBAR"+                    npg <- getAtom "_NET_WM_STATE_SKIP_PAGER"+                    io $ changeProperty32 d w ws aTOM propModePrepend [fi ntb,fi npg]
+ XMonad/Util/Parser.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+--------------------------------------------------------------------+-- |+-- Module      : XMonad.Util.Parser+-- Description : A parser combinator library for xmonad+-- Copyright   : (c) 2021  Tony Zorman+-- License     : BSD3+-- Maintainer  : Tony Zorman <soliditsallgood@mailbox.org>+-- Stability   : experimental+-- Portability : non-portable+--+-- A small wrapper around the 'ReadP' parser combinator in @base@,+-- providing a more intuitive behaviour.  While it's theoretically nice+-- that 'ReadP' is actually commutative, this makes a lot of parsing+-- operations rather awkward—more often than not, one only wants the+-- argument that's parsed "first".+--+-- Due to the left-biased nature of the chosen semigroup implementation,+-- using functions like 'many' or 'optional' from "Control.Applicative"+-- now yields more consistent behaviour with other parser combinator+-- libraries.+--+--------------------------------------------------------------------+module XMonad.Util.Parser (+  -- * Usage+  -- $usage++  -- * Running+  Parser,+  runParser,++  -- * Primitive Parsers+  pfail,+  eof,+  num,+  char,+  string,+  skipSpaces,+  get,+  look,+  gather,++  -- * Combining Parsers+  satisfy,+  choice,+  count,+  between,+  option,+  optionally,+  skipMany,+  skipMany1,+  many1,+  sepBy,+  sepBy1,+  endBy,+  endBy1,+  munch,+  munch1,+  chainr,+  chainr1,+  chainl,+  chainl1,+  manyTill,+) where++import XMonad.Prelude++import qualified Text.ParserCombinators.ReadP as ReadP++import Data.Coerce (coerce)+import Data.String (IsString (fromString))+import Text.ParserCombinators.ReadP (ReadP, (<++))++{- $usage++NOTE: This module is mostly intended for developing of other modules.+If you are a users, you probably won't find much use here—you have been+warned.++The high-level API tries to stay as close to 'ReadP' as possible.  If+you are familiar with that then no functions here should surprise you.++One notable usability difference when forcing left-biasedness is /when/+one wants to disambiguate a parse.  For normal 'ReadP' usage this+happens after the actual parsing stage by going through the list of+successful parses.  For 'Parser' it does when constructing the relevant+combinators, leading to only one successful parse.  As an example,+consider the 'ReadP'-based parser++> pLangle = ReadP.string "<"+> pLongerSequence = ReadP.char '<' *> ReadP.string "f" <* ReadP.char '>'+> pCombination = pLangle ReadP.+++ pLongerSequence++Parsing the string @"\<f\>"@ will return++>>> ReadP.readP_to_S pCombination "<f>"+[("<","f>"),("f","")]++One would now need to, for example, filter for the second (leftover)+string being empty and take the head of the resulting list (which may+still have more than one element).++With 'Parser', the same situation would look like the following++> pLangle' = string "<"+> pLongerSequence' = char '<' *> string "f" <* char '>'+> pCombination' = pLongerSequence' <> pLangle'++Notice how @pLangle'@ and @pLongerSequence'@ have traded places—since we+are not forcing @pLangle'@ to consume the entire string and @(<>)@ is+left-biased, @pLongerSequence'@ parses a superset of @pLangle'@!+Running @runParser pCombination'@ now yields the expected result:++>>> runParser pCombination' "<f>"+Just "f"++One might also define @pLangle'@ as @string "<" <* eof@, which would+enable a definition of @pCombination' = pLangle' <> pLongerSequence'@.++For example uses, see "XMonad.Util.EZConfig" or "XMonad.Prompt.OrgMode".+-}++-- Parser :: Type -> Type+newtype Parser a = Parser (ReadP a)+  deriving newtype (Functor, Applicative, Monad)++instance Semigroup (Parser a) where+  -- | Local, exclusive, left-biased choice: If left parser locally+  -- produces any result at all, then right parser is not used.+  (<>) :: Parser a -> Parser a -> Parser a+  (<>) = coerce ((<++) @a)+  {-# INLINE (<>) #-}++instance Monoid (Parser a) where+  -- | A parser that always fails.+  mempty :: Parser a+  mempty = Parser empty+  {-# INLINE mempty #-}++instance Alternative Parser where+  empty :: Parser a+  empty = mempty+  {-# INLINE empty #-}++  (<|>) :: Parser a -> Parser a -> Parser a+  (<|>) = (<>)+  {-# INLINE (<|>) #-}++-- | When @-XOverloadedStrings@ is on, treat a string @s@ as the parser+-- @'string' s@, when appropriate.  This allows one to write things like+-- @"a" *> otherParser@ instead of @'string' "a" *> otherParser@.+instance a ~ String => IsString (Parser a) where+  fromString :: String -> Parser a+  fromString = string+  {-# INLINE fromString #-}++-- | Run a parser on a given string.+runParser :: Parser a -> String -> Maybe a+runParser (Parser p) = fmap fst . listToMaybe . ReadP.readP_to_S p+{-# INLINE runParser #-}++-- | Always fails+pfail :: Parser a+pfail = empty+{-# INLINE pfail #-}++-- | Consume and return the next character.  Fails if there is no input+-- left.+get :: Parser Char+get = coerce ReadP.get+{-# INLINE get #-}++-- | Look-ahead: return the part of the input that is left, without+-- consuming it.+look :: Parser String+look = coerce ReadP.look+{-# INLINE look #-}++-- | Transform a parser into one that does the same, but in addition+-- returns the exact characters read.+--+-- >>> runParser (         string "* " $> True) "* hi"+-- Just True+-- >>> runParser (gather $ string "* " $> True) "* hi"+-- Just ("* ",True)+gather :: forall a. Parser a -> Parser (String, a)+gather = coerce (ReadP.gather @a)+{-# INLINE gather #-}++-- | Succeeds if and only if we are at the end of input.+eof :: Parser ()+eof = coerce ReadP.eof+{-# INLINE eof #-}++-- | Parse an integral number.+num :: (Read a, Integral a) => Parser a+num = read <$> munch1 isDigit+{-# INLINE num #-}++-- | Parse and return the specified character.+char :: Char -> Parser Char+char = coerce ReadP.char+{-# INLINE char #-}++-- | Parse and return the specified string.+string :: String -> Parser String+string = coerce ReadP.string+{-# INLINE string #-}++-- | Skip all whitespace.+skipSpaces :: Parser ()+skipSpaces = coerce ReadP.skipSpaces+{-# INLINE skipSpaces #-}++-- | Consume and return the next character if it satisfies the specified+-- predicate.+satisfy :: (Char -> Bool) -> Parser Char+satisfy = coerce ReadP.satisfy+{-# INLINE satisfy #-}++-- | Combine all parsers in the given list in a left-biased way.+choice :: [Parser a] -> Parser a+choice = foldl' (<>) mempty+{-# INLINE choice #-}++-- | @count n p@ parses @n@ occurrences of @p@ in sequence and returns a+-- list of results.+count :: Int -> Parser a -> Parser [a]+count = replicateM+{-# INLINE count #-}++-- | @between open close p@ parses @open@, followed by @p@ and finally+-- @close@.  Only the value of @p@ is returned.+between :: Parser open -> Parser close -> Parser a -> Parser a+between open close p = open *> p <* close+{-# INLINE between #-}++-- | @option def p@ will try to parse @p@ and, if it fails, simply+-- return @def@ without consuming any input.+option :: a -> Parser a -> Parser a+option def p = p <|> pure def+{-# INLINE option #-}++-- | @optionally p@ optionally parses @p@ and always returns @()@.+optionally :: Parser a -> Parser ()+optionally p = void p <|> pure ()+{-# INLINE optionally #-}++-- | Like 'many', but discard the result.+skipMany :: Parser a -> Parser ()+skipMany = void . many+{-# INLINE skipMany #-}++-- | Like 'many1', but discard the result.+skipMany1 :: Parser a -> Parser ()+skipMany1 p = p *> skipMany p+{-# INLINE skipMany1 #-}++-- | Parse the first zero or more characters satisfying the predicate.+-- Always succeeds; returns an empty string if the predicate returns+-- @False@ on the first character of input.+munch :: (Char -> Bool) -> Parser String+munch = coerce ReadP.munch+{-# INLINE munch #-}++-- | Parse the first one or more characters satisfying the predicate.+-- Fails if none, else succeeds exactly once having consumed all the+-- characters.+munch1 :: (Char -> Bool) -> Parser String+munch1 = coerce ReadP.munch1+{-# INLINE munch1 #-}++-- | @endBy p sep@ parses zero or more occurrences of @p@, separated and+-- ended by @sep@.+endBy :: Parser a -> Parser sep -> Parser [a]+endBy p sep = many (p <* sep)+{-# INLINE endBy #-}++-- | @endBy p sep@ parses one or more occurrences of @p@, separated and+-- ended by @sep@.+endBy1 :: Parser a -> Parser sep -> Parser [a]+endBy1 p sep = many1 (p <* sep)+{-# INLINE endBy1 #-}++-- | Parse one or more occurrences of the given parser.+many1 :: Parser a -> Parser [a]+many1 = some+{-# INLINE many1 #-}++-- | @sepBy p sep@ parses zero or more occurrences of @p@, separated by+-- @sep@.  Returns a list of values returned by @p@.+sepBy :: Parser a -> Parser sep -> Parser [a]+sepBy p sep = sepBy1 p sep <> pure []+{-# INLINE sepBy #-}++-- | @sepBy1 p sep@ parses one or more occurrences of @p@, separated by+-- @sep@.  Returns a list of values returned by @p@.+sepBy1 :: Parser a -> Parser sep -> Parser [a]+sepBy1 p sep = liftA2 (:) p (many (sep *> p))+{-# INLINE sepBy1 #-}++-- | @chainr p op x@ parses zero or more occurrences of @p@, separated+-- by @op@.  Returns a value produced by a /right/ associative+-- application of all functions returned by @op@.  If there are no+-- occurrences of @p@, @x@ is returned.+chainr :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainr p op x = option x (chainr1 p op)+{-# INLINE chainr #-}++-- | Like 'chainr', but parses one or more occurrences of @p@.+chainr1 :: forall a. Parser a -> Parser (a -> a -> a) -> Parser a+chainr1 p op = scan+ where+  scan :: Parser a+  scan = p >>= rest++  rest :: a -> Parser a+  rest x = option x $ do f <- op+                         f x <$> scan+{-# INLINE chainr1 #-}++-- | @chainl p op x@ parses zero or more occurrences of @p@, separated+-- by @op@.  Returns a value produced by a /left/ associative+-- application of all functions returned by @op@.  If there are no+-- occurrences of @p@, @x@ is returned.+chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a+chainl p op x = option x (chainl1 p op)+{-# INLINE chainl #-}++-- | Like 'chainl', but parses one or more occurrences of @p@.+chainl1 :: forall a. Parser a -> Parser (a -> a -> a) -> Parser a+chainl1 p op = scan+ where+  scan :: Parser a+  scan = p >>= rest++  rest :: a -> Parser a+  rest x = option x $ do f <- op+                         y <- p+                         rest (f x y)+{-# INLINE chainl1 #-}++-- | @manyTill p end@ parses zero or more occurrences of @p@, until+-- @end@ succeeds.  Returns a list of values returned by @p@.+manyTill :: forall a end. Parser a -> Parser end -> Parser [a]+manyTill p end = scan+ where+  scan :: Parser [a]+  scan = end $> [] <|> liftA2 (:) p scan+{-# INLINE manyTill #-}
XMonad/Util/Paste.hs view
@@ -1,5 +1,6 @@ {- | Module      :  XMonad.Util.Paste+Description :  A module for sending key presses to windows. Copyright   :  (C) 2008 Jérémy Bobbio, gwern License     :  BSD3 @@ -27,15 +28,14 @@ import Graphics.X11.Xlib.Extras (none, setEventType, setKeyEvent) import Control.Monad.Reader (asks) import XMonad.Operations (withFocused)-import Data.Char (isUpper)-import Data.Maybe (listToMaybe)+import XMonad.Prelude (isUpper, fromMaybe) import XMonad.Util.XSelection (getSelection) import XMonad.Util.EZConfig (parseKey)-import Text.ParserCombinators.ReadP (readP_to_S)+import XMonad.Util.Parser (runParser)  {- $usage -Import this module into your xmonad.hs as usual:+Import this module into your @xmonad.hs@ as usual:  > import XMonad.Util.Paste @@ -68,13 +68,14 @@     > pasteChar shiftMask 'F' -   Note that this function makes use of 'stringToKeysym', and so will probably-   have trouble with any 'Char' outside ASCII.+   Note that this function will probably have trouble with any 'Char'+   outside ASCII. -} pasteChar :: KeyMask -> Char -> X ()-pasteChar m c = sendKey m $ maybe (stringToKeysym [c]) fst-                $ listToMaybe $ readP_to_S parseKey [c]+pasteChar m c = sendKey m $ fromMaybe (unicodeToKeysym c)+                $ runParser parseKey [c] +-- | Send a key with a modifier to the currently focused window. sendKey :: KeyMask -> KeySym -> X () sendKey = (withFocused .) . sendKeyWindow @@ -89,3 +90,14 @@                   sendEvent d w True keyPressMask ev                   setEventType ev keyRelease                   sendEvent d w True keyReleaseMask ev++-- | Convert a unicode character to a 'KeySym'. Ideally, this should+-- work for any unicode character, but see here for details:+-- http://www.cl.cam.ac.uk/~mgk25/ucs/keysyms.txt+unicodeToKeysym :: Char -> KeySym+unicodeToKeysym c+  | (ucp >= 32)  && (ucp <= 126) = fromIntegral ucp+  | (ucp >= 160) && (ucp <= 255) = fromIntegral ucp+  | ucp >= 256                   = fromIntegral $ ucp + 0x1000000+  | otherwise                    = 0 -- this is supposed to be an error, but it's not ideal+  where ucp = fromEnum c -- codepoint
XMonad/Util/PositionStore.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-}- ---------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.PositionStore+-- Description :  A utility module to store information about position and size of a window. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -34,16 +33,16 @@ -- and windows sizes as well as positions as fractions of the screen size. -- This way windows can be easily relocated and scaled when switching screens. -data PositionStore = PS (M.Map Window PosStoreRectangle)-                            deriving (Read,Show,Typeable)+newtype PositionStore = PS (M.Map Window PosStoreRectangle)+                            deriving (Read,Show) data PosStoreRectangle = PSRectangle Double Double Double Double-                            deriving (Read,Show,Typeable)+                            deriving (Read,Show)  instance ExtensionClass PositionStore where   initialValue = PS M.empty   extensionType = PersistentExtension -getPosStore :: X (PositionStore)+getPosStore :: X PositionStore getPosStore = XS.get  modifyPosStore :: (PositionStore -> PositionStore) -> X ()@@ -73,6 +72,6 @@  posStoreMove :: PositionStore -> Window -> Position -> Position -> Rectangle -> Rectangle -> PositionStore posStoreMove posStore w x y oldSr newSr =-    case (posStoreQuery posStore w oldSr) of+    case posStoreQuery posStore w oldSr of         Nothing -> posStore     -- not in store, can't move -> do nothing         Just (Rectangle _ _ wh ht) -> posStoreInsert posStore w (Rectangle x y wh ht) newSr
+ XMonad/Util/Process.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module      :  XMonad.Util.Process+-- Description :  Utilities for unix processes.+-- Copyright   :  (c) 2022 Tomáš Janoušek <tomi@nomi.cz>+-- License     :  BSD3+-- Maintainer  :  Tomáš Janoušek <tomi@nomi.cz>+--+-- This module should not be directly used by users, it's just common code for+-- other modules.+--+module XMonad.Util.Process (+    getPPIDOf,+    getPPIDChain,+    ) where++import Control.Exception (SomeException, handle)+import System.Posix.Types (ProcessID)+import qualified Data.ByteString.Char8 as B++import XMonad.Prelude (fi)++-- | Get the parent process id (PPID) of a given process.+getPPIDOf :: ProcessID -> IO (Maybe ProcessID)+getPPIDOf pid =+    handle+        (\(_ :: SomeException) -> pure Nothing)+        (parse <$> B.readFile ("/proc/" <> show pid <> "/stat"))+  where+    -- Parse PPID out of /proc/*/stat, being careful not to trip over+    -- processes with names like ":-) 1 2 3 4 5 6".+    -- Inspired by https://gitlab.com/procps-ng/procps/-/blob/bcce3e440a1e1ee130c7371251a39c031519336a/proc/readproc.c#L561+    parse stat = case B.words $ snd $ B.spanEnd (/= ')') stat of+        _ : (B.readInt -> Just (ppid, ""))  : _ -> Just (fi ppid)+        _ -> Nothing++-- | Get the chain of parent processes of a given pid. Starts with the given+-- pid and continues up until the parent of all.+getPPIDChain :: ProcessID -> IO [ProcessID]+getPPIDChain pid = (pid :) <$> (maybe (pure []) getPPIDChain =<< getPPIDOf pid)
+ XMonad/Util/PureX.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE DerivingVia, GeneralizedNewtypeDeriving, FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.PureX+-- Description :  Composable @X@ actions.+-- 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,+  focusWindow, focusNth,+  view, greedyView, invisiView,+  shift, shiftWin, curScreen, curWorkspace,+  curTag, curScreenId,+) where++-- xmonad+import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W+import qualified XMonad.Actions.FocusNth++-- mtl+import Control.Monad.State+import Control.Monad.Reader++-- }}}++-- --< Usage >-- {{{++-- $Usage+--+-- The suggested pattern of usage for this module is to write composable, pure+-- actions as @XLike m => m Any@ or @PureX Any@ values, where the encapsulated+-- @Any@ value encodes whether or not a refresh is needed to properly institute+-- changes. These values can then be combined monoidally (i.e. with '<>' AKA+-- '<+>') or with operators such as '<*', '*>', '<?' and '&>' to build seamless+-- new actions. The end user can run and handle the effects of the pure actions+-- in the @X@ monad by applying the @defile@ function, which you may want to+-- re-export. Alternatively, if an action does not make stackset changes that+-- need to be handled by @windows@, it can be written with as an+-- @XLike m => m ()@ and used directly.+--+-- Unfortunately since layouts must handle messages in the @X@ monad, this+-- approach does not quite apply to actions involving them. However a relatively+-- direct translation to impure actions is possible: you can write composable,+-- refresh-tracking actions as @X Any@ values, making sure to eschew+-- refresh-inducing functions like @windows@ and @sendMessage@ in favour of+-- 'modifyWindowSet' and utilities provided by "XMonad.Actions.MessageFeedback".+-- The 'windowBracket_' function recently added to "XMonad.Operations" is the+-- impure analogue of @defile@. Note that @PureX Any@ actions can be composed+-- into impure ones after applying 'toX'; don't use @defile@ for this. E.g.+--+-- > windowBracket_ (composableImpureAction <> toX composablePureAction)+--+-- Although both @X@ and @PureX@ have Monoid instances over monoidal values,+-- @(XLike m, Monoid a)@ is not enough to infer @Monoid (m a)@ (due to the+-- open-world assumption). Hence a @Monoid (m Any)@ constraint may need to be+-- used when working with @XLike m => m Any@ where no context is forcing @m@ to+-- unify with @X@ or @PureX@. This can also be avoided by working with+-- @PureX Any@ values and generalising them with 'toXLike' where necessary.+--+-- @PureX@ also enables a more monadic style when writing windowset operations;+-- see the implementation of the utilities in this module for examples.+-- For an example of a whole module written in terms of this one, see+-- "XMonad.Hooks.RefocusLast".+--++-- }}}++-- --< Core >-- {{{++-- | The @PureX@ newtype over @ReaderT XConf (State XState) a@.+newtype PureX a = PureX (ReaderT XConf (State XState) a)+  deriving (Functor, Applicative, Monad, MonadReader XConf, MonadState XState)+  deriving (Semigroup, Monoid) via Ap PureX a++-- | 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 (const 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 = ($ m) . when' =<< mb++-- | A 'whenJust' that accepts a monoidal return value.+whenJust' :: (Monad m, Monoid b) => Maybe a -> (a -> m b) -> m b+whenJust' = flip $ maybe (return mempty)++-- | Akin to @<*@. Discarding the wrapped value in the second argument either+--   way, keep its effects iff the first argument returns @Any True@.+(<?) :: Monad m => m Any -> m a -> m Any+ifthis <? thenthis = do+  Any b <- ifthis+  when' b (Any b <$ thenthis)+infixl 4 <?++-- | Akin to a low precedence @<>@. Combines applicative effects left-to-right+--   and wrapped @Bool@s with @&&@ (instead of @||@).+(&>) :: Applicative f => f Any -> f Any -> f Any+(&>) = liftA2 $ \(Any b1) (Any b2) -> Any (b1 && b2)+infixl 1 &>++-- | A generalisation of 'withWindowSet'.+withWindowSet' :: XLike m => (WindowSet -> m a) -> m a+withWindowSet' = (=<< gets windowset)++-- | If there is a current tag and a focused window, perform an operation with+--   them, otherwise return mempty.+withFocii :: (XLike m, Monoid a) => (WorkspaceId -> Window -> m a) -> m a+withFocii f = join $ (whenJust' <$> peek) <*> (f <$> curTag)++-- | A generalisation of 'modifyWindowSet'.+modifyWindowSet' :: XLike m => (WindowSet -> WindowSet) -> m ()+modifyWindowSet' f = modify $ \xs -> xs { windowset = f (windowset xs) }++-- | A variant of @W.modify@ and @W.modify'@ handling the @Nothing@ and @Just@+--   cases uniformly.+modify''+  :: (Maybe (W.Stack a) -> Maybe (W.Stack a))+  -> (W.StackSet i l a s sd -> W.StackSet i l a s sd)+modify'' f = W.modify (f Nothing) (f . Just)++-- | Get the stack from the current workspace.+getStack :: XLike m => m (Maybe (W.Stack Window))+getStack = W.stack <$> curWorkspace++-- | Set the stack on the current workspace.+putStack :: XLike m => Maybe (W.Stack Window) -> m ()+putStack mst = modifyWindowSet' . modify'' $ const 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 WindowScreen+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')++-- | A refresh tracking version of @W.shiftWin@.+shiftWin :: XLike m => WorkspaceId -> Window -> m Any+shiftWin tag w = do+  mtag <- gets $ W.findTag w . windowset+  whenJust' mtag $ \wtag ->+    when' (tag /= wtag) $ do+      modifyWindowSet' $ W.shiftWin tag w+      ntag <- gets $ W.findTag w . windowset+      return (Any $ mtag /= ntag)++-- | Internal. Refresh-tracking logic of focus operations.+focusWith :: XLike m => (WindowSet -> WindowSet) -> m Any+focusWith focuser = do+    old <- peek+    modifyWindowSet' focuser+    new <- peek+    return (Any $ old /= new)++-- | A refresh-tracking version of @W.focusWindow@.+focusWindow :: XLike m => Window -> m Any+focusWindow w = focusWith (W.focusWindow w)++-- | A refresh-tracking version of @XMonad.Actions.FocusNth.focusNth@.+focusNth :: XLike m => Int -> m Any+focusNth i = focusWith (W.modify' (XMonad.Actions.FocusNth.focusNth' i))++-- }}}
+ XMonad/Util/Rectangle.hs view
@@ -0,0 +1,208 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.Rectangle+-- Description :  A module for handling pixel rectangles.+-- 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           XMonad.Prelude (fi)+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/column 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 = [PointRectangle (max r2_x1 r1_x1) r1_y1 r1_x2 r2_y1 | r2_y1 > r1_y1 && r2_y1 < r1_y2]+          -- right+          rr = [PointRectangle r2_x2 (max r2_y1 r1_y1) r1_x2 r1_y2 | r2_x2 > r1_x1 && r2_x2 < r1_x2]+          -- bottom+          rb = [PointRectangle r1_x1 r2_y2 (min r2_x2 r1_x2) r1_y2 | r2_y2 > r1_y1 && r2_y2 < r1_y2]+          -- left+          rl = [PointRectangle r1_x1 r1_y1 r2_x1 (min r2_y2 r1_y2) | r2_x1 > r1_x1 && r2_x1 < r1_x2]++-- | 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) =+    W.RationalRect ((fi x1 - fi x2) / fi w2)+                   ((fi y1 - fi y2) / fi h2)+                   (fi w1 / fi w2) (fi h1 / fi h2)
+ XMonad/Util/RemoteWindows.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.RemoteWindows+-- Description :  A module to find out whether the window is remote or local.+-- Copyright   :  (c) Anton Vorontsov <anton@enomsg.org> 2014+-- License     :  BSD-style (as xmonad)+--+-- Maintainer  :  Anton Vorontsov <anton@enomsg.org>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module implements a proper way of finding out whether the window+-- is remote or local.+--+-- Just checking for a hostname and WM_CLIENT_MACHINE being equal is often+-- not enough because the hostname is a changing subject (without any+-- established notification mechanisms), and thus WM_CLIENT_MACHINE and+-- the hostname can diverge even for a local window.+--+-- This module solves the problem. As soon as there is a new window+-- created, we check the hostname and WM_CLIENT_MACHINE, and then we cache+-- the result into the XMONAD_REMOTE property.+--+-- Notice that XMonad itself does not know anything about hostnames, nor+-- does it have any dependency on Network.* modules. For this module it is+-- not a problem: you can provide a mean to get the hostname through your+-- config file (see usage). Or, if you don't like the hassle of handling+-- dynamic hostnames (suppose your hostname never changes), it is also+-- fine: this module will fallback to using environment variables.+--+-----------------------------------------------------------------------------++module XMonad.Util.RemoteWindows+    ( -- $usage+      isLocalWindow+    , manageRemote+    , manageRemoteG+    ) where++import XMonad+import XMonad.Util.WindowProperties+import XMonad.Prelude+import System.Posix.Env++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad+-- > import XMonad.Util.RemoteWindows+-- > import Network.BSD+-- >+-- > main = xmonad def+-- >    { manageHook = manageRemote =<< io getHostName }++guessHostName :: IO String+guessHostName = pickOneMaybe <$> (getEnv `mapM` vars)+  where+    pickOneMaybe = last . (mzero:) . take 1 . catMaybes+    vars = ["XAUTHLOCALHOSTNAME","HOST","HOSTNAME"]++setRemoteProp :: Window -> String -> X ()+setRemoteProp w host = do+    d <- asks display+    p <- getAtom "XMONAD_REMOTE"+    v <- hasProperty (Machine host) w+    io $ changeProperty32 d w p cARDINAL propModeReplace+                          [fromIntegral . fromEnum $ not v]++-- | Given a window, tell if it is a local or a remote process. Normally,+-- it checks XMONAD_REMOTE property. If it does not exist (i.e. the+-- manageRemote hook was not deployed in user's config), it falls back to+-- checking environment variables and assuming that hostname never+-- changes.+isLocalWindow :: Window -> X Bool+isLocalWindow w = getProp32s "XMONAD_REMOTE" w >>= \case+    Just [y] -> return $ y == 0+    _ -> io guessHostName >>= \host -> hasProperty (Machine host) w++-- | Use this hook to let XMonad properly track remote/local windows. For+-- example, @manageHook = manageRemote =<< io getHostName@.+manageRemote :: String -> ManageHook+manageRemote host = ask >>= \w -> liftX (setRemoteProp w host) >> return mempty++-- | Use this hook if you want to manage XMONAD_REMOTE properties, but+-- don't want to use an external getHostName in your config. That way you+-- are retreating to environment variables.+manageRemoteG :: ManageHook+manageRemoteG = manageRemote =<< io guessHostName
XMonad/Util/Replace.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Replace+-- Description :  Implements a @--replace@ flag outside of core. -- Copyright   :  (c) Jan Vornberger 2009 -- License     :  BSD3-style (see LICENSE) --@@ -28,8 +28,7 @@     ) where  import XMonad-import Data.Function-import Control.Monad+import XMonad.Prelude  -- $usage -- You must run the 'replace' action before starting xmonad proper, this@@ -40,7 +39,7 @@ -- > import XMonad.Util.Replace -- > main = do -- >    replace--- >    xmonad $ defaultConfig { .... }+-- >    xmonad $ def { .... } --  -- $shortcomings@@ -61,7 +60,7 @@ -- > main = do -- >    args <- getArgs -- >    when ("--replace" `elem` args) replace--- >    xmonad $ defaultConfig { .... }+-- >    xmonad $ def { .... } -- -- -- Note that your @~\/.xmonad/xmonad-$arch-$os@ binary is not run with the same@@ -79,11 +78,11 @@     rootw  <- rootWindow dpy dflt      -- check for other WM-    wmSnAtom <- internAtom dpy ("WM_S" ++ (show dflt)) False+    wmSnAtom <- internAtom dpy ("WM_S" ++ show dflt) False     currentWmSnOwner <- xGetSelectionOwner dpy wmSnAtom     when (currentWmSnOwner /= 0) $ do-        putStrLn $ "Screen " ++ (show dflt) ++ " on display \""-                    ++ (displayString dpy) ++ "\" already has a window manager."+        putStrLn $ "Screen " ++ show dflt ++ " on display \""+                    ++ displayString dpy ++ "\" already has a window manager."          -- prepare to receive destroyNotify for old WM         selectInput dpy currentWmSnOwner structureNotifyMask@@ -98,19 +97,19 @@             createWindow dpy rootw (-100) (-100) 1 1 0 copyFromParent copyFromParent visual attrmask attributes          -- try to acquire wmSnAtom, this should signal the old WM to terminate-        putStrLn $ "Replacing existing window manager..."+        putStrLn "Replacing existing window manager..."         xSetSelectionOwner dpy wmSnAtom netWmSnOwner currentTime          -- SKIPPED: check if we acquired the selection         -- SKIPPED: send client message indicating that we are now the WM          -- wait for old WM to go away-        putStr $ "Waiting for other window manager to terminate... "+        putStr "Waiting for other window manager to terminate... "         fix $ \again -> do             evt <- allocaXEvent $ \event -> do                 windowEvent dpy currentWmSnOwner structureNotifyMask event                 get_EventType event              when (evt /= destroyNotify) again-        putStrLn $ "done"+        putStrLn "done"     closeDisplay dpy
XMonad/Util/Run.hs view
@@ -1,56 +1,125 @@+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Run--- Copyright   :  (C) 2007 Spencer Janssen, Andrea Rossato, glasser@mit.edu+-- Description :  Several commands, as well as an EDSL, to run external processes.+-- Copyright   :  (C) 2007  Spencer Janssen, Andrea Rossato, glasser@mit.edu+--                    2022  Tony Zorman -- License     :  BSD-style (see LICENSE) ----- Maintainer  :  Christian Thiemann <mail@christian-thiemann.de>+-- Maintainer  :  Tony Zorman <soliditsallgood@mailbox.org> -- Stability   :  unstable -- Portability :  unportable ----- This modules provides several commands to run an external process.--- It is composed of functions formerly defined in "XMonad.Util.Dmenu" (by--- Spencer Janssen), "XMonad.Util.Dzen" (by glasser\@mit.edu) and--- XMonad.Util.RunInXTerm (by Andrea Rossato).+-- This module provides several commands to run an external process.+-- Additionally, it provides an abstraction—particularly geared towards+-- programs like terminals or Emacs—to specify these processes from+-- XMonad in a compositional way. --+-- Originally, this module was composed of functions formerly defined in+-- "XMonad.Util.Dmenu" (by Spencer Janssen), "XMonad.Util.Dzen" (by+-- glasser\@mit.edu) and @XMonad.Util.RunInXTerm@ (by Andrea Rossato). -----------------------------------------------------------------------------  module XMonad.Util.Run (-                          -- * Usage-                          -- $usage-                          runProcessWithInput,-                          runProcessWithInputAndWait,-                          safeSpawn,-                          safeSpawnProg,-                          unsafeSpawn,-                          runInTerm,-                          safeRunInTerm,-                          seconds,-                          spawnPipe,+  -- * Usage+  -- $usage+  runProcessWithInput,+  runProcessWithInputAndWait,+  safeSpawn,+  safeSpawnProg,+  unsafeSpawn,+  runInTerm,+  safeRunInTerm,+  seconds,+  spawnPipe,+  spawnPipeWithLocaleEncoding,+  spawnPipeWithUtf8Encoding,+  spawnPipeWithNoEncoding, -                          hPutStr, hPutStrLn  -- re-export for convenience-                         ) where+  -- * Compositionally Spawning Processes #EDSL#+  -- $EDSL -import Codec.Binary.UTF8.String-import System.Posix.IO-import System.Posix.Process (createSession, executeFile, forkProcess)+  -- ** Configuration and Running+  ProcessConfig (..),+  Input,+  spawnExternalProcess,+  proc,+  getInput,+  toInput,++  -- ** Programs+  inEditor,+  inTerm,+  termInDir,+  inProgram,++  -- ** General Combinators+  (>->),+  (>-$),+  (>&&>),+  (>||>),+  inWorkingDir,+  eval,+  execute,+  executeNoQuote,+  setXClass,+  asString,++  -- ** Emacs Integration+  EmacsLib (..),+  setFrameName,+  withEmacsLibs,+  inEmacs,+  elispFun,+  asBatch,+  require,+  progn,+  quote,+  findFile,+  list,+  saveExcursion,++  -- * Re-exports+  hPutStr,+  hPutStrLn,+) where++import XMonad+import XMonad.Prelude+import qualified XMonad.Util.ExtensibleConf as XC++import Codec.Binary.UTF8.String (encodeString) import Control.Concurrent (threadDelay)+import System.Directory (getDirectoryContents) import System.IO+import System.Posix.IO+import System.Posix.Process (createSession, executeFile, forkProcess) import System.Process (runInteractiveProcess)-import XMonad-import Control.Monad --- $usage--- For an example usage of 'runInTerm' see "XMonad.Prompt.Ssh"------ For an example usage of 'runProcessWithInput' see--- "XMonad.Prompt.DirectoryPrompt", "XMonad.Util.Dmenu",--- "XMonad.Prompt.ShellPrompt", "XMonad.Actions.WmiiActions",--- "XMonad.Prompt.WorkspaceDir"------ For an example usage of 'runProcessWithInputAndWait' see--- "XMonad.Util.Dzen"+{- $usage +You can use this module by importing it in your @xmonad.hs@++> import XMonad.Util.Run++It then all depends on what you want to do:++  - If you want to compositionally spawn programs, see [the relevant+    extended documentation](#g:EDSL).++  - For an example usage of 'runInTerm' see "XMonad.Prompt.Ssh".++  - For an example usage of 'runProcessWithInput' see+    "XMonad.Util.Dmenu", or "XMonad.Prompt.Shell".++  - For an example usage of 'runProcessWithInputAndWait' see+    "XMonad.Util.Dzen".+-}+ -- | Returns the output. runProcessWithInput :: MonadIO m => FilePath -> [String] -> String -> m String runProcessWithInput cmd args input = io $ do@@ -94,7 +163,7 @@ -- -- to the top of your file) or use seconds in prefix form: ----- > 5.5 seconds+-- > seconds 5.5 seconds :: Rational -> Int seconds = fromEnum . (* 1000000) @@ -134,7 +203,7 @@ unsafeSpawn :: MonadIO m => String -> m () unsafeSpawn = spawn --- | Open a terminal emulator. The terminal emulator is specified in @defaultConfig@ as xterm by default. It is then+-- | Open a terminal emulator. The terminal emulator is specified in the default configuration as xterm by default. It is then -- asked to pass the shell a command with certain options. This is unsafe in the sense of 'unsafeSpawn' unsafeRunInTerm, runInTerm :: String -> String -> X () unsafeRunInTerm options command = asks (terminal . config) >>= \t -> unsafeSpawn $ t ++ " " ++ options ++ " -e " ++ command@@ -144,15 +213,350 @@ safeRunInTerm :: String -> String -> X () safeRunInTerm options command = asks (terminal . config) >>= \t -> safeSpawn t [options, " -e " ++ command] --- | Launch an external application through the system shell and return a @Handle@ to its standard input.+-- | Launch an external application through the system shell and+-- return a 'Handle' to its standard input. Note that the 'Handle'+-- is a text 'Handle' using the current locale encoding. spawnPipe :: MonadIO m => String -> m Handle-spawnPipe x = io $ do+spawnPipe = spawnPipeWithLocaleEncoding++-- | Same as 'spawnPipe'.+spawnPipeWithLocaleEncoding :: MonadIO m => String -> m Handle+spawnPipeWithLocaleEncoding = spawnPipe' localeEncoding++-- | Same as 'spawnPipe', but forces the UTF-8 encoding regardless of locale.+spawnPipeWithUtf8Encoding :: MonadIO m => String -> m Handle+spawnPipeWithUtf8Encoding = spawnPipe' utf8++-- | Same as 'spawnPipe', but forces the 'char8' encoding, so unicode strings+-- need 'Codec.Binary.UTF8.String.encodeString'. Should never be needed, but+-- some X functions return already encoded Strings, so it may possibly be+-- useful for someone.+spawnPipeWithNoEncoding :: MonadIO m => String -> m Handle+spawnPipeWithNoEncoding = spawnPipe' char8++spawnPipe' :: MonadIO m => TextEncoding -> String -> m Handle+spawnPipe' encoding x = io $ do     (rd, wr) <- createPipe     setFdOption wr CloseOnExec True     h <- fdToHandle wr+    hSetEncoding h encoding     hSetBuffering h LineBuffering     _ <- xfork $ do           _ <- dupTo rd stdInput           executeFile "/bin/sh" False ["-c", encodeString x] Nothing     closeFd rd     return h++{- $EDSL++To use the provided EDSL, you must first add the 'spawnExternalProcess'+combinator to your xmonad configuration, like so:++> main = xmonad $ … $ spawnExternalProcess def $ … $ def++See 'ProcessConfig' for a list of all default configuration options, in+case you'd like to change them—especially if you want to make use of the+Emacs integration.++After that, the real fun begins!  The format for spawning these+processes is always the same: a call to 'proc', its argument being a+bunch of function calls, separated by the pipe operator '(>->)'.  You+can just bind the resulting function to a key; no additional plumbing+required.  For example, using "XMonad.Util.EZConfig" syntax and with+@terminal = "alacritty"@ in you XMonad configuration, spawning a @ghci@+session with a special class name, "calculator", would look like++> ("M-y", proc $ inTerm >-> setXClass "calculator" >-> execute "ghci")++which would translate, more or less, to @\/usr\/bin\/sh -c "alacritty+--class calculator -e ghci"@.  The usefulness of this notation becomes+apparent with more complicated examples:++> proc $ inEmacs+>    >-> withEmacsLibs [OwnFile "mailboxes"]+>    >-> execute (elispFun "notmuch")+>    >-> setFrameName "mail"++This is equivalent to spawning++> emacs -l /home/slot/.config/emacs/lisp/mailboxes.el+>       -e '(notmuch)'+>       -F '(quote (name . "mail"))'++Notice how we did not have to specify the whole path to @mailboxes.el@,+since we had set the correct 'emacsLispDir' upon starting xmonad.  This+becomes especially relevant when running Emacs in batch mode, where one+has to include [M,Non-GNU]ELPA packages in the call, whose exact names+may change at any time.  Then the following++> do url <- getSelection  -- from XMonad.Util.XSelection+>    proc $ inEmacs+>       >-> withEmacsLibs [ElpaLib "dash", ElpaLib "s", OwnFile "arXiv-citation"]+>       >-> asBatch+>       >-> execute (elispFun $ "arXiv-citation" <> asString url)++becomes++> emacs -L /home/slot/.config/emacs/elpa/dash-20220417.2250+>       -L /home/slot/.config/emacs/elpa/s-20210616.619+>       -l /home/slot/.config/emacs/lisp/arXiv-citation.el+>       --batch+>       -e '(arXiv-citation "<url-in-the-primary-selection>")'++which would be quite bothersome to type indeed!++A blog post going into some more detail and also explaining how to+integrate this new language with the "XMonad.Util.NamedScratchpad"+module is available+<https://tony-zorman.com/posts/2022-05-25-calling-emacs-from-xmonad.html here>.+-}++-----------------------------------------------------------------------+-- Types and whatnot++-- | Additional information that might be useful when spawning external+-- programs.+data ProcessConfig = ProcessConfig+  { editor :: !String+    -- ^ Default editor.  Defaults to @"emacsclient -c -a ''"@.+  , emacsLispDir :: !FilePath+    -- ^ Directory for your custom Emacs lisp files.  Probably+    -- @user-emacs-directory@ or @user-emacs-directory/lisp@.  Defaults+    -- to @"~\/.config\/emacs\/lisp\/"@+  , emacsElpaDir :: !FilePath+    -- ^ Directory for all packages from [M,Non-GNU]ELPA; probably+    -- @user-emacs-directory/elpa@.  Defaults to+    -- @"~\/.config\/emacs\/elpa"@.+  , emacs :: !String+    -- ^ /Standalone/ Emacs executable; this should not be @emacsclient@+    -- since, for example, the client does not support @--batch@ mode.+    -- Defaults to @"emacs"@.+  }++-- | Given a 'ProcessConfig', remember it for spawning external+-- processes later on.+spawnExternalProcess :: ProcessConfig -> XConfig l -> XConfig l+spawnExternalProcess = XC.modifyDef . const++instance Default ProcessConfig where+  def :: ProcessConfig+  def = ProcessConfig+    { editor       = "emacsclient -c -a ''"+    , emacsLispDir = "~/.config/emacs/lisp/"+    , emacsElpaDir = "~/.config/emacs/elpa/"+    , emacs        = "emacs"+    }++-- | Convenient type alias.+type Input = ShowS++-----------------------------------------------------------------------+-- Combinators++-- | Combine inputs together.+(>->) :: X Input -> X Input -> X Input+(>->) = (<>)+infixr 3 >->++-- | Combine an input with an ordinary string.+(>-$) :: X Input -> X String -> X Input+(>-$) xi xs = xi >-> fmap mkDList xs+infixr 3 >-$++-- | @a >&&> b@ glues the different inputs @a@ and @b@ by means of @&&@.+-- For example,+--+-- @+-- pure "do something" >&&> pure "do another thing"+-- @+--+-- would result in @do something && do another thing@ being executed by a+-- shell.+(>&&>) :: X Input -> X Input -> X Input+a >&&> b = a <> toInput " && " <> b+infixr 2 >&&>++-- | Like '(>&&>)', but with @||@.+(>||>) :: X Input -> X Input -> X Input+a >||> b = a <> toInput " || " <> b+infixr 2 >||>++-- | Spawn a completed input.+proc :: X Input -> X ()+proc xi = spawn =<< getInput xi++-- | Create an effectful 'Input' from a 'String'.+toInput :: String -> X Input+toInput = pure . mkDList++-- | Get the completed input string.+getInput :: X Input -> X String+getInput xi = xi <&> ($ "")++-- | Use the 'editor'.+inEditor :: X Input+inEditor = XC.withDef $ \ProcessConfig{editor} -> pure $ mkDList editor++-- | Use the 'XMonad.Core.XConfig.terminal'.+inTerm :: X Input+inTerm = asks $ mkDList . terminal . config++-- | Execute the argument.  Current /thing/ must support a @-e@ option.+-- For programs such as Emacs, 'eval' may be the safer option; while+-- @emacsclient@ supports @-e@, the @emacs@ executable itself does not.+--+-- Note that this function always wraps its argument in single quotes;+-- see 'executeNoQuote' for an alternative.+execute :: String -> X Input+execute this = pure ((" -e " <> tryQuote this) <>)++-- | Like 'execute', but doesn't wrap its argument in single quotes.+executeNoQuote :: String -> X Input+executeNoQuote this = pure ((" -e " <> this) <>)++-- | Eval(uate) the argument.  Current /thing/ must support a @--eval@+-- option.+eval :: String -> X Input+eval this = pure ((" --eval " <> tryQuote this) <>)++-- | Use 'emacs'.+inEmacs :: X Input+inEmacs = XC.withDef $ \ProcessConfig{emacs} -> pure $ mkDList emacs++-- | Use the given program.+inProgram :: String -> X Input+inProgram = pure . mkDList++-- | Spawn /thing/ in the current working directory.  /thing/ must+-- support a @--working-directory@ option.+inWorkingDir :: X Input+inWorkingDir = pure (" --working-directory " <>)++-- | Set a frame name for the @emacsclient@.+--+-- Note that this uses the @-F@ option to set the+-- <https://www.gnu.org/software/emacs/manual/html_node/emacs/Frame-Parameters.html frame parameters>+-- alist, which the @emacs@ executable does not support.+setFrameName :: String -> X Input+setFrameName n = pure ((" -F '(quote (name . \"" <> n <> "\"))' ") <>)++-- | Set the appropriate X class for a window.  This will more often+-- than not actually be the+-- <https://tronche.com/gui/x/icccm/sec-4.html#WM_CLASS instance name>.+setXClass :: String -> X Input+setXClass = pure . mkDList . (" --class " <>)++-- | Spawn the 'XMonad.Core.XConfig.terminal' in some directory; it must+-- support the @--working-directory@ option.+termInDir :: X Input+termInDir = inTerm >-> inWorkingDir++-----------------------------------------------------------------------+-- Emacs++-- | Transform the given input into an elisp function; i.e., surround it+-- with parentheses.+--+-- >>> elispFun "arxiv-citation URL"+-- " '( arxiv-citation URL )' "+elispFun :: String -> String+elispFun f = " '( " <> f <> " )' "++-- | Treat an argument as a string; i.e., wrap it with quotes.+--+-- >>> asString "string"+-- " \"string\" "+asString :: String -> String+asString s = " \"" <> s <> "\" "++-- | Wrap the given commands in a @progn@.  The given commands need not+-- be wrapped in parentheses (but can); this will be done by the+-- function.  For example:+--+-- >>> progn [require "this-lib", "function-from-this-lib arg", "(other-function arg2)"]+-- "(progn (require (quote this-lib)) (function-from-this-lib arg) (other-function arg2))"+progn :: [String] -> String+progn = inParens . ("progn " <>) . unwords . map inParens++-- | Require a package.+--+-- >>> require "arxiv-citation"+-- "(require (quote arxiv-citation))"+require :: String -> String+require = inParens . ("require " <>) . quote++-- | Quote a symbol.+--+-- >>> quote "new-process"+-- "(quote new-process)"+quote :: String -> String+quote = inParens . ("quote " <>)++-- | Call @find-file@.+--+-- >>> findFile "/path/to/file"+-- "(find-file \"/path/to/file\" )"+findFile :: String -> String+findFile = inParens . ("find-file" <>) . asString++-- | Make a list of the given inputs.+--+-- >>> list ["foo", "bar", "baz", "qux"]+-- "(list foo bar baz qux)"+list :: [String] -> String+list = inParens . ("list " <>) . unwords++-- | Like 'progn', but with @save-excursion@.+--+-- >>> saveExcursion [require "this-lib", "function-from-this-lib arg", "(other-function arg2)"]+-- "(save-excursion (require (quote this-lib)) (function-from-this-lib arg) (other-function arg2))"+saveExcursion :: [String] -> String+saveExcursion = inParens . ("save-excursion " <>) . unwords . map inParens++-----------------------------------------------------------------------+-- Batch mode++-- | Tell Emacs to enable batch-mode.+asBatch :: X Input+asBatch = pure (" --batch " <>)++-- | An Emacs library.+data EmacsLib+  = OwnFile !String+    -- ^ A /file/ from 'emacsLispDir'.+  | ElpaLib !String+    -- ^ A /directory/ in 'emacsElpaDir'.+  | Special !String+    -- ^ Special /files/; these will not be looked up somewhere, but+    -- forwarded verbatim (as a path).++-- | Load some Emacs libraries.  This is useful when executing scripts+-- in batch mode.+withEmacsLibs :: [EmacsLib] -> X Input+withEmacsLibs libs = XC.withDef $ \ProcessConfig{emacsLispDir, emacsElpaDir} -> do+  lispDir <- mkAbsolutePath emacsLispDir+  elpaDir <- mkAbsolutePath emacsElpaDir+  lisp    <- liftIO $ getDirectoryContents lispDir+  elpa    <- liftIO $ getDirectoryContents elpaDir++  let getLib :: EmacsLib -> Maybe String = \case+        OwnFile f -> (("-l " <> lispDir) <>) <$> find (f          `isPrefixOf`) lisp+        ElpaLib d -> (("-L " <> elpaDir) <>) <$> find ((d <> "-") `isPrefixOf`) elpa+        Special f -> Just $ " -l " <> f+  pure . mkDList . unwords . mapMaybe getLib $ libs++-----------------------------------------------------------------------+-- Util++mkDList :: String -> ShowS+mkDList = (<>) . (<> " ")++inParens :: String -> String+inParens s = case s of+  '(' : _ -> s+  _       -> "(" <> s <> ")"++tryQuote :: String -> String+tryQuote s = case dropWhile (== ' ') s of+  '\'' : _ -> s+  _        -> "'" <> s <> "'"
XMonad/Util/Scratchpad.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Scratchpad+-- Description :  Very handy hotkey-launched toggleable floating terminal window. -- Copyright   :  (c) Braden Shepherdson 2008 -- License     :  BSD-style (as xmonad) --@@ -12,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module XMonad.Util.Scratchpad (+module XMonad.Util.Scratchpad {-# DEPRECATED "Use XMonad.Util.NamedScratchpad instead" #-} (   -- * Usage   -- $usage   scratchpadSpawnAction@@ -26,6 +27,7 @@ import XMonad import qualified XMonad.StackSet as W import XMonad.Util.NamedScratchpad+import XMonad.Util.WorkspaceCompare (filterOutWs)   -- $usage@@ -108,13 +110,13 @@ scratchpadManageHook rect = namedScratchpadManageHook [NS "" "" scratchpadQuery (customFloating rect)]  --- | Transforms a workspace list containing the SP workspace into one that--- doesn't contain it. Intended for use with logHooks.+-- | Transforms a workspace list containing the NSP workspace into one that+-- doesn't contain it. Intended for use with 'logHook's (see+-- 'XMonad.Hooks.StatusBar.PP.filterOutWsPP') and "XMonad.Hooks.EwmhDesktops"+-- (see 'XMonad.Hooks.EwmhDesktops.addEwmhWorkspaceSort'). scratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace]-scratchpadFilterOutWorkspace = namedScratchpadFilterOutWorkspace+scratchpadFilterOutWorkspace = filterOutWs [scratchpadWorkspaceTag]   scratchpadDefaultRect :: W.RationalRect scratchpadDefaultRect = W.RationalRect 0.25 0.375 0.5 0.25--
+ XMonad/Util/SessionStart.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.SessionStart+-- Description :  A module for detectiong session startup.+-- 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 XMonad.Prelude (when)++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.+-- ---------------------------------------------------------------------++newtype SessionStart = SessionStart { unSessionStart :: Bool }+    deriving (Read, Show)++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
+ XMonad/Util/SpawnNamedPipe.hs view
@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.SpawnNamedPipe+-- Description :  A module for spawning a pipe whose handle lives in the XMonad state.+-- Copyright   :  (c) Christian Wills 2014+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  cwills.dev@gmail.com+-- Stability   :  unstable+-- Portability :  not portable+--+-- A module for spawning a pipe whose 'Handle' lives in the Xmonad state.+--+-----------------------------------------------------------------------------++module XMonad.Util.SpawnNamedPipe (+  -- * Usage+  -- $usage+    spawnNamedPipe+  , getNamedPipe+  ) where++import XMonad+import XMonad.Util.Run+import System.IO+import qualified XMonad.Util.ExtensibleState as XS+import XMonad.Prelude+import qualified Data.Map as Map++-- $usage+-- This module makes it possible to spawn a pipe to Dzen2 in the startupHook+-- and write to it from inside the logHook without the need for global+-- variables.+--+-- > import XMonad.Util.SpawnNamedPipe+-- > import Data.Maybe+-- >+-- > -- StartupHook+-- > startupHook' = spawnNamedPipe "dzen2" "dzenPipe"+-- >+-- > -- LogHook+-- > logHook' = do+-- >     mh <- getNamedPipeHandle "dzenPipe"+-- >         dynamicLogWithPP $ def {+-- >             ppOutput = maybe (\s -> return ()) (hPutStrLn) mh}+-- >+-- > -- Main+-- > main = xmonad $ def { startupHook = startupHook'+-- >                     , logHook = logHook'}+--++newtype NamedPipes = NamedPipes { pipeMap :: Map.Map String Handle }+    deriving (Show)++instance ExtensionClass NamedPipes where+    initialValue = NamedPipes Map.empty++-- | When 'spawnNamedPipe' is executed with a command 'String' and a name+-- 'String' respectively.  The command string is spawned with 'spawnPipe' (as+-- long as the name chosen hasn't been used already) and the 'Handle' returned+-- is saved in Xmonad's state associated with the name 'String'.+spawnNamedPipe :: String -> String -> X ()+spawnNamedPipe cmd name = do+  b <- XS.gets (Map.member name . pipeMap)+  unless b $ do+    h <- spawnPipe cmd+    XS.modify (NamedPipes . Map.insert name h . pipeMap)++-- | Attempts to retrieve a 'Handle' to a pipe previously stored in Xmonad's+-- state associated with the given string via a call to 'spawnNamedPipe'. If the+-- given string doesn't exist in the map stored in Xmonad's state Nothing is+-- returned.+getNamedPipe :: String -> X (Maybe Handle)+getNamedPipe name = XS.gets (Map.lookup name . pipeMap)
XMonad/Util/SpawnOnce.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-}- ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.SpawnOnce+-- Description :  A module for spawning a command once, and only once. -- Copyright   :  (c) Spencer Janssen 2009 -- License     :  BSD3-style (see LICENSE) --@@ -11,29 +10,63 @@ -- Portability :  not portable -- -- A module for spawning a command once, and only once.  Useful to start--- status bars and make session settings inside startupHook.+-- status bars and make session settings inside startupHook. See also+-- "XMonad.Util.SessionStart" for a different and more flexible way to+-- run commands only on first startup. -- ----------------------------------------------------------------------------- -module XMonad.Util.SpawnOnce (spawnOnce) where+module XMonad.Util.SpawnOnce (spawnOnce,+                              -- * 'SpawnOn' helpers+                              -- $spawnon+                              manageSpawn,+                              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+import XMonad.Prelude -data SpawnOnce = SpawnOnce { unspawnOnce :: (Set String) }-    deriving (Read, Show, Typeable)+newtype SpawnOnce = SpawnOnce { unspawnOnce :: Set String }+    deriving (Read, Show)  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.+doOnce :: (String -> X ()) -> String -> X ()+doOnce f s = do+    b <- XS.gets (Set.member s . unspawnOnce)+    unless b $ do+        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 xs = do-    b <- XS.gets (Set.member xs . unspawnOnce)-    when (not b) $ do-        spawn xs-        XS.modify (SpawnOnce . Set.insert xs . unspawnOnce)+spawnOnce = doOnce spawn++-- $spawnon+-- These functions combine 'spawnOnce' with their relatives in+-- "XMonad.Actions.SpawnOn". You must add 'manageSpawn' to your+-- @manageHook@ for them to work, as with @SpawnOn@.++-- | Like 'spawnOnce' but launches the application on the given workspace.+spawnOnOnce :: WorkspaceId -> String -> X ()+spawnOnOnce ws = doOnce (spawnOn ws)++-- | 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 = doOnce (replicateM_ n . spawnOn ws)++-- | Spawn the application once and apply the manage hook. Subsequent+-- attempts to spawn this application will be ignored.+spawnAndDoOnce :: ManageHook -> String -> X ()+spawnAndDoOnce mh = doOnce (spawnAndDo mh)
XMonad/Util/Stack.hs view
@@ -3,6 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Stack+-- Description :  Utility functions for manipulating @Maybe Stack@s. -- Copyright   :  Quentin Moser <moserq@gmail.com> -- License     :  BSD-style (see LICENSE) --@@ -26,6 +27,7 @@                          , toIndex                          , fromTags                          , toTags+                         , zipperFocusedAtFirstOf                             -- * 'Zipper' manipulation functions                            -- ** Insertion, movement@@ -38,6 +40,8 @@                          , focusUpZ                          , focusDownZ                          , focusMasterZ+                         , findS+                         , findZ                            -- ** Extraction                          , getFocusZ                          , getIZ@@ -73,12 +77,12 @@                          , mapE_                          , mapEM                          , mapEM_+                         , reverseS+                         , reverseZ                          ) where  import qualified XMonad.StackSet as W-import Control.Monad (liftM)-import Data.List (sortBy)-+import XMonad.Prelude (guard, sortBy, (!?), (<|>))   type Zipper a = Maybe (W.Stack a)@@ -120,6 +124,18 @@ toTags (Just s) = map Left (reverse . W.up $ s) ++ [Right . W.focus $ s]                   ++ map Left (W.down s) +-- | @differentiate zs xs@ takes the first @z@ from @z2 that also belongs to+-- @xs@ and turns @xs@ into a stack with @z@ being the current element. Acts+-- as 'XMonad.StackSet.differentiate' if @zs@ and @xs@ don't intersect.+zipperFocusedAtFirstOf :: Eq q => [q] -> [q] -> Zipper q+zipperFocusedAtFirstOf []       xs = W.differentiate xs+zipperFocusedAtFirstOf (z : zs) xs+  | z `elem` xs = Just $+        W.Stack { W.focus = z+                , W.up    = reverse $ takeWhile (/= z) xs+                , W.down  = drop 1  $ dropWhile (/= z) xs+                }+  | otherwise = zipperFocusedAtFirstOf zs xs  -- * Zipper functions @@ -159,22 +175,37 @@ focusUpZ Nothing = Nothing focusUpZ (Just s) | u:up <- W.up s = Just $ W.Stack u up (W.focus s:W.down s) focusUpZ (Just s) | null $ W.down s = Just s-focusUpZ (Just (W.Stack f _ down)) = Just $ W.Stack (last down) (reverse (init down) ++ [f]) []+focusUpZ (Just (W.Stack f _ down)) = Just $ W.Stack (last down) (drop 1 (reverse down) ++ [f]) []  -- | Move the focus to the next element focusDownZ :: Zipper a -> Zipper a focusDownZ Nothing = Nothing focusDownZ (Just s) | d:down <- W.down s = Just $ W.Stack d (W.focus s:W.up s) down focusDownZ (Just s) | null $ W.up s = Just s-focusDownZ (Just (W.Stack f up _)) = Just $ W.Stack (last up) [] (reverse (init up) ++ [f])+focusDownZ (Just (W.Stack f up _)) = Just $ W.Stack (last up) [] (drop 1 (reverse up) ++ [f])  -- | Move the focus to the first element focusMasterZ :: Zipper a -> Zipper a focusMasterZ Nothing = Nothing focusMasterZ (Just (W.Stack f up down)) | not $ null up-    = Just $ W.Stack (last up) [] (reverse (init up) ++ [f] ++ down)+    = Just $ W.Stack (last up) [] (drop 1 (reverse up) ++ [f] ++ down) focusMasterZ (Just s) = Just s +-- | Refocus a @Stack a@ on an element satisfying the predicate, or fail to+--   @Nothing@.+findS :: (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@.+findZ :: (a -> Bool) -> Zipper a -> Zipper a+findZ _ Nothing   = Nothing+findZ p (Just st) = findS p st+ -- ** Extraction  -- | Get the focused element@@ -201,7 +232,7 @@ -- | Map a function over a stack. The boolean argument indcates whether -- the current element is the focused one mapZ :: (Bool -> a -> b) -> Zipper a -> Zipper b-mapZ f as = fromTags . map (mapE f) . toTags $ as+mapZ f = fromTags . map (mapE f) . toTags  -- | 'mapZ' without the 'Bool' argument mapZ_ :: (a -> b) -> Zipper a -> Zipper b@@ -209,7 +240,7 @@  -- | Monadic version of 'mapZ' mapZM :: Monad m => (Bool -> a -> m b) -> Zipper a -> m (Zipper b)-mapZM f as = fromTags `liftM` (mapM (mapEM f) . toTags) as+mapZM f as = fromTags <$> (mapM (mapEM f) . toTags) as   -- | Monadic version of 'mapZ_'@@ -266,7 +297,7 @@ -- | Delete the ith element deleteIndexZ :: Int -> Zipper a -> Zipper a deleteIndexZ i z = let numbered = (fromTags . zipWith number [0..] . toTags) z-                       number j ea = mapE (\_ a -> (j,a)) ea+                       number j = mapE (\_ a -> (j,a))                    in mapZ_ snd $ filterZ_ ((/=i) . fst) numbered  -- ** Folds@@ -299,7 +330,7 @@  -- | Find whether an element is present in a stack. elemZ :: Eq a => a -> Zipper a -> Bool-elemZ a as = foldlZ_ step False as+elemZ a = foldlZ_ step False     where step True _ = True           step False a' = a' == a @@ -308,9 +339,8 @@  -- | Safe version of '!!' getI :: Int -> [a] -> Maybe a-getI _ [] = Nothing-getI 0 (a:_) = Just a-getI i (_:as) = getI (i-1) as+getI i xs = xs !? i+{-# DEPRECATED getI "Use XMonad.Prelude.(!?) instead." #-}  -- | Map a function across both 'Left's and 'Right's. -- The 'Bool' argument is 'True' in a 'Right', 'False'@@ -324,8 +354,8 @@  -- | Monadic version of 'mapE' mapEM :: Monad m => (Bool -> a -> m b) -> Either a a -> m (Either b b)-mapEM f (Left a) = Left `liftM` f False a-mapEM f (Right a) = Right `liftM` f True a+mapEM f (Left a) = Left <$> f False a+mapEM f (Right a) = Right <$> f True a  mapEM_ :: Monad m => (a -> m b) -> Either a a -> m (Either b b) mapEM_ = mapEM . const@@ -338,3 +368,11 @@ -- | 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 <$>)
+ XMonad/Util/StickyWindows.hs view
@@ -0,0 +1,142 @@+-- |+-- Module      :  XMonad.Util.StickyWindows+-- Description :  Make windows sticky to a screen across workspace changes.+-- Copyright   :  (c) Yecine Megdiche <yecine.megdiche@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Yecine Megdiche <yecine.megdiche@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- This module provides functionality to make windows \"sticky\" to a particular+-- screen. When a window is marked as sticky on a screen, it will automatically+-- follow that screen across workspace changes, staying visible even when you+-- switch to a different workspace.+--+-- This is particularly useful for windows you want to keep visible at all times+-- on a specific monitor, such as Picture-in-Picture videos, music players,+-- communication apps, or reference documentation.+module XMonad.Util.StickyWindows (+    -- * Usage+    -- $usage+    sticky,+    stick,+    unstick,+) where++import qualified Data.Map as M+import qualified Data.Set as S+import XMonad+import XMonad.Prelude+import qualified XMonad.StackSet as W+import qualified XMonad.Util.ExtensibleState as XS++-- $usage+-- You can use this module with the following in your @xmonad.hs@:+--+-- > import XMonad.Util.StickyWindows+--+-- To enable sticky windows, wrap your config with 'sticky':+--+-- > main = xmonad $ … . sticky . … $ def { ... }+--+-- This adds the necessary hooks to manage sticky windows. Next, add keybindings+-- to stick and unstick windows:+--+-- > , ((modMask, xK_s), withFocused stick)+-- > , ((modMask .|. shiftMask, xK_s), withFocused unstick)+--+-- Now you can:+--+--   1. Focus a window and press @Mod-s@ to make it sticky to the current screen+--   2. Switch workspaces on that screen, and the sticky window will follow+--   3. Press @Mod-Shift-s@ to unstick the window+--+-- Note that windows are sticky to a /specific screen/, not to all screens. If you+-- have multiple monitors, a window marked sticky on screen 0 will only follow+-- workspace changes on screen 0, not on other screens.+--+-- The sticky state persists across XMonad restarts.++data StickyState = SS+    { lastWs :: !(M.Map ScreenId WorkspaceId)+    , stickies :: !(M.Map ScreenId (S.Set Window))+    }+    deriving (Show, Read)++instance ExtensionClass StickyState where+    initialValue = SS mempty mempty+    extensionType = PersistentExtension++modifySticky ::+    (S.Set Window -> S.Set Window) -> ScreenId -> StickyState -> StickyState+modifySticky f sid (SS ws ss) =+    SS ws $ M.alter (Just . f . fromMaybe S.empty) sid ss++modifyStickyM :: (S.Set Window -> S.Set Window) -> ScreenId -> X ()+modifyStickyM f sid = XS.modify (modifySticky f sid)++stick' :: Window -> ScreenId -> X ()+stick' = modifyStickyM . S.insert++unstick' :: Window -> ScreenId -> X ()+unstick' = modifyStickyM . S.delete++-- | Remove the sticky status from the given window on the current screen.+-- The window will no longer automatically follow workspace changes.+--+-- Typically used with 'withFocused':+--+-- > , ((modMask .|. shiftMask, xK_s), withFocused unstick)+unstick :: Window -> X ()+unstick w = unstick' w =<< currentScreen++-- | Mark the given window as sticky to the current screen. The window will+-- automatically follow this screen across workspace changes until explicitly+-- unstuck with 'unstick' or until the window is destroyed.+--+-- Typically used with 'withFocused':+--+-- > , ((modMask, xK_s), withFocused stick)+stick :: Window -> X ()+stick w = stick' w =<< currentScreen++currentScreen :: X ScreenId+currentScreen = gets $ W.screen . W.current . windowset++-- | Incorporates sticky window functionality into an 'XConfig'. This adds+-- the necessary log hook and event hook to:+--+--   * Automatically move sticky windows when workspaces change on their screen+--   * Clean up sticky state when windows are destroyed+--+-- Example usage:+--+-- > main = xmonad $ … . sticky .  … $ def { ... }+sticky :: XConfig l -> XConfig l+sticky xconf =+    xconf+        { logHook = logHook xconf >> stickyLogHook+        , handleEventHook = handleEventHook xconf <> stickyEventHook+        }++stickyLogHook :: X ()+stickyLogHook = do+    lastWS_ <- XS.gets lastWs+    screens <- withWindowSet $ return . map (\s -> (W.screen s, W.tag . W.workspace $ s)) . W.screens+    for_ screens $ \(sid, wsTag) -> do+        unless (M.lookup sid lastWS_ == Just wsTag) $+            -- We need to update the last workspace before moving windows to avoid+            -- getting stuck in a loop: This is a log hook, and calling moveWindows+            -- (which in turn calls 'windows') would trigger another log hook.+            XS.modify (\(SS ws ss) -> SS (M.insert sid wsTag ws) ss)+                >> XS.gets (M.lookup sid . stickies)+                >>= maybe mempty (moveWindows wsTag)++moveWindows :: WorkspaceId -> S.Set Window -> X ()+moveWindows wsTag = traverse_ (\w -> windows $ W.focusDown . W.shiftWin wsTag w)++stickyEventHook :: Event -> X All+stickyEventHook DestroyWindowEvent{ev_window = w} =+    XS.modify (\(SS ws ss) -> SS ws (M.map (S.delete w) ss)) $> All True+stickyEventHook _ = return (All True)
XMonad/Util/StringProp.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.StringProp+-- Description :  Internal utility functions for storing Strings with the root window. -- Copyright   :  (c) Nicolas Pouillard 2009 -- License     :  BSD-style (see LICENSE) --@@ -20,8 +21,6 @@     ) where  import XMonad-import Control.Monad(liftM)-import Control.Applicative((<$>)) import Foreign.C.String (castCCharToChar,castCharToCChar)  type StringProp = String@@ -48,7 +47,7 @@ -- | Given a property name, returns its contents as a list. It uses the empty -- list as default value. getStringListProp :: (MonadIO m) => Display -> StringProp -> m [String]-getStringListProp dpy prop = maybe [] words `liftM` getStringProp dpy prop+getStringListProp dpy prop = maybe [] words <$> getStringProp dpy prop  -- | Given a property name and a list, sets the value of this property with -- the list given as argument.
XMonad/Util/Themes.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Themes+-- Description :  A collection of themes for decorated layouts. -- Copyright   :  (C) 2007 Andrea Rossato -- License     :  BSD3 --@@ -19,7 +20,10 @@     , ppThemeInfo     , xmonadTheme     , smallClean+    , adwaitaTheme+    , adwaitaDarkTheme     , robertTheme+    , darkTheme     , deiflTheme     , oxymor00nTheme     , donaldTheme@@ -45,8 +49,7 @@ -- do not apply to xmonad as a whole.) -- -- If you want to use one of them with one of your decorated layouts,--- you need to substitute defaultTheme with, for instance, (theme--- smallClean).+-- you need to substitute def with, for instance, (theme smallClean). -- -- Here is an example: --@@ -56,7 +59,7 @@ -- > -- > myLayout = tabbed shrinkText (theme smallClean) -- >--- > main = xmonad defaultConfig {layoutHook = myLayout}+-- > main = xmonad def {layoutHook = myLayout} -- -- If you have a theme you would like to share, adding it to this -- module is very easy.@@ -80,17 +83,20 @@        }  newTheme :: ThemeInfo-newTheme = TI "" "" "" defaultTheme+newTheme = TI "" "" "" def  ppThemeInfo :: ThemeInfo -> String-ppThemeInfo t = themeName t <> themeDescription t <> "by" <> themeAuthor t-    where "" <> x = x-          x <> y = x ++ " - " ++ y+ppThemeInfo t = themeName t `add` themeDescription t `add` "by" `add` themeAuthor t+    where "" `add` x = x+          x `add` y = x ++ " - " ++ y   listOfThemes :: [ThemeInfo] listOfThemes = [ xmonadTheme                , smallClean+               , adwaitaTheme+               , adwaitaDarkTheme+               , darkTheme                , deiflTheme                , oxymor00nTheme                , robertTheme@@ -112,7 +118,7 @@     newTheme { themeName        = "xmonadTheme"              , themeAuthor      = "David Roundy"              , themeDescription = "The default xmonad theme"-             , theme            = defaultTheme+             , theme            = def              }  -- | Small decorations with a Ion3 remembrance, by Andrea Rossato.@@ -121,30 +127,72 @@     newTheme { themeName        = "smallClean"              , themeAuthor      = "Andrea Rossato"              , themeDescription = "Small decorations with a Ion3 remembrance"-             , theme            = defaultTheme { activeColor         = "#8a999e"-                                               , inactiveColor       = "#545d75"-                                               , activeBorderColor   = "white"-                                               , inactiveBorderColor = "grey"-                                               , activeTextColor     = "white"-                                               , inactiveTextColor   = "grey"-                                               , decoHeight          = 14-                                               }+             , theme            = def { activeColor         = "#8a999e"+                                      , inactiveColor       = "#545d75"+                                      , activeBorderColor   = "white"+                                      , inactiveBorderColor = "grey"+                                      , activeTextColor     = "white"+                                      , inactiveTextColor   = "grey"+                                      , decoHeight          = 14+                                      }              } +-- | Matching decorations for Adwaita GTK theme+adwaitaTheme :: ThemeInfo+adwaitaTheme =+    newTheme { themeName        = "adwaitaTheme"+             , themeAuthor      = "Alex Griffin"+             , themeDescription = "Matching decorations for Adwaita GTK theme"+             , theme            = def { activeColor         = "#dfdcd8"+                                      , inactiveColor       = "#f6f5f4"+                                      , urgentColor         = "#3584e4"+                                      , activeBorderColor   = "#bfb8b1"+                                      , inactiveBorderColor = "#cdc7c2"+                                      , urgentBorderColor   = "#1658a7"+                                      , activeTextColor     = "#2e3436"+                                      , inactiveTextColor   = "#929595"+                                      , urgentTextColor     = "#ffffff"+                                      , fontName            = "xft:Cantarell:bold:size=11"+                                      , decoWidth           = 400+                                      , decoHeight          = 35+                                      }+             }++-- | Matching decorations for Adwaita-dark GTK theme+adwaitaDarkTheme :: ThemeInfo+adwaitaDarkTheme =+    newTheme { themeName        = "adwaitaDarkTheme"+             , themeAuthor      = "Alex Griffin"+             , themeDescription = "Matching decorations for Adwaita-dark GTK theme"+             , theme            = def { activeColor         = "#2d2d2d"+                                      , inactiveColor       = "#353535"+                                      , urgentColor         = "#15539e"+                                      , activeBorderColor   = "#070707"+                                      , inactiveBorderColor = "#1c1c1c"+                                      , urgentBorderColor   = "#030c17"+                                      , activeTextColor     = "#eeeeec"+                                      , inactiveTextColor   = "#929291"+                                      , urgentTextColor     = "#ffffff"+                                      , fontName            = "xft:Cantarell:bold:size=11"+                                      , decoWidth           = 400+                                      , decoHeight          = 35+                                      }+             }+ -- | Don's preferred colors - from DynamicLog...;) donaldTheme  :: ThemeInfo donaldTheme =     newTheme { themeName        = "donaldTheme"              , themeAuthor      = "Andrea Rossato"              , themeDescription = "Don's preferred colors - from DynamicLog...;)"-             , theme            = defaultTheme { activeColor         = "#2b4f98"-                                               , inactiveColor       = "#cccccc"-                                               , activeBorderColor   = "#2b4f98"-                                               , inactiveBorderColor = "#cccccc"-                                               , activeTextColor     = "white"-                                               , inactiveTextColor   = "black"-                                               , decoHeight          = 16-                                               }+             , theme            = def { activeColor         = "#2b4f98"+                                      , inactiveColor       = "#cccccc"+                                      , activeBorderColor   = "#2b4f98"+                                      , inactiveBorderColor = "#cccccc"+                                      , activeTextColor     = "white"+                                      , inactiveTextColor   = "black"+                                      , decoHeight          = 16+                                      }              }  -- | Ffrom Robert Manea's prompt theme.@@ -153,32 +201,48 @@     newTheme { themeName        = "robertTheme"              , themeAuthor      = "Andrea Rossato"              , themeDescription = "From Robert Manea's prompt theme"-             , theme            = defaultTheme { activeColor         = "#aecf96"-                                               , inactiveColor       = "#111111"-                                               , activeBorderColor   = "#aecf96"-                                               , inactiveBorderColor = "#111111"-                                               , activeTextColor     = "black"-                                               , inactiveTextColor   = "#d5d3a7"-                                               , fontName            = "-*-profont-*-*-*-*-11-*-*-*-*-*-iso8859"-                                               , decoHeight          = 16-                                               }+             , theme            = def { activeColor         = "#aecf96"+                                      , inactiveColor       = "#111111"+                                      , activeBorderColor   = "#aecf96"+                                      , inactiveBorderColor = "#111111"+                                      , activeTextColor     = "black"+                                      , inactiveTextColor   = "#d5d3a7"+                                      , fontName            = "-*-profont-*-*-*-*-11-*-*-*-*-*-iso8859"+                                      , decoHeight          = 16+                                      }              } +-- | 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 =     newTheme { themeName        = "deiflTheme"              , themeAuthor      = "deifl"              , themeDescription = "deifl's Theme"-             , theme            = defaultTheme { inactiveBorderColor = "#708090"-                                               , activeBorderColor   = "#5f9ea0"-                                               , activeColor         = "#000000"-                                               , inactiveColor       = "#333333"-                                               , inactiveTextColor   = "#888888"-                                               , activeTextColor     = "#87cefa"-                                               , fontName            = "-xos4-terminus-*-*-*-*-12-*-*-*-*-*-*-*"-                                               , decoHeight          = 15-                                               }+             , theme            = def { inactiveBorderColor = "#708090"+                                      , activeBorderColor   = "#5f9ea0"+                                      , activeColor         = "#000000"+                                      , inactiveColor       = "#333333"+                                      , inactiveTextColor   = "#888888"+                                      , activeTextColor     = "#87cefa"+                                      , fontName            = "-xos4-terminus-*-*-*-*-12-*-*-*-*-*-*-*"+                                      , decoHeight          = 15+                                      }              }  -- | oxymor00n\'s theme, by Tom Rauchenwald.@@ -187,19 +251,19 @@     newTheme { themeName        = "oxymor00nTheme"              , themeAuthor      = "Tom Rauchenwald"              , themeDescription = "oxymor00n's theme"-             , theme            = defaultTheme { inactiveBorderColor = "#000"-                                               , activeBorderColor = "aquamarine3"-                                               , activeColor = "aquamarine3"-                                               , inactiveColor = "DarkSlateGray4"-                                               , inactiveTextColor = "#222"-                                               , activeTextColor = "#222"-                                               -- This font can be found in the package ttf-alee-                                               -- on debian-systems-                                               , fontName = "-*-Bandal-*-*-*-*-12-*-*-*-*-*-*-*"-                                               , decoHeight = 15-                                               , urgentColor = "#000"-                                               , urgentTextColor = "#63b8ff"-                                               }+             , theme            = def { inactiveBorderColor = "#000"+                                      , activeBorderColor = "aquamarine3"+                                      , activeColor = "aquamarine3"+                                      , inactiveColor = "DarkSlateGray4"+                                      , inactiveTextColor = "#222"+                                      , activeTextColor = "#222"+                                      -- This font can be found in the package ttf-alee+                                      -- on debian-systems+                                      , fontName = "-*-Bandal-*-*-*-*-12-*-*-*-*-*-*-*"+                                      , decoHeight = 15+                                      , urgentColor = "#000"+                                      , urgentTextColor = "#63b8ff"+                                      }              }  wfarrTheme :: ThemeInfo@@ -207,15 +271,15 @@     newTheme { themeName        = "wfarrTheme"              , themeAuthor      = "Will Farrington"              , themeDescription = "A nice blue/black theme."-             , theme            = defaultTheme { activeColor         = "#4c7899"-                                               , inactiveColor       = "#333333"-                                               , activeBorderColor   = "#285577"-                                               , inactiveBorderColor = "#222222"-                                               , activeTextColor     = "#ffffff"-                                               , inactiveTextColor   = "#888888"-                                               , fontName            = "-*-fixed-medium-r-*--10-*-*-*-*-*-iso8859-1"-                                               , decoHeight          = 12-                                               }+             , theme            = def { activeColor         = "#4c7899"+                                      , inactiveColor       = "#333333"+                                      , activeBorderColor   = "#285577"+                                      , inactiveBorderColor = "#222222"+                                      , activeTextColor     = "#ffffff"+                                      , inactiveTextColor   = "#888888"+                                      , fontName            = "-*-fixed-medium-r-*--10-*-*-*-*-*-iso8859-1"+                                      , decoHeight          = 12+                                      }              }  -- | Forest colours, by Kathryn Andersen@@ -224,13 +288,13 @@     newTheme { themeName        = "kavonForestTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Forest colours"-             , theme            = defaultTheme { activeColor         = "#115422"-                                               , activeBorderColor   = "#1a8033"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#543211"-                                               , inactiveBorderColor = "#804c19"-                                               , inactiveTextColor   = "#ffcc33"-                                               }+             , theme            = def { activeColor         = "#115422"+                                      , activeBorderColor   = "#1a8033"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#543211"+                                      , inactiveBorderColor = "#804c19"+                                      , inactiveTextColor   = "#ffcc33"+                                      }              }  -- | Lake (blue/green) colours, by Kathryn Andersen@@ -239,13 +303,13 @@     newTheme { themeName        = "kavonLakeTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Lake (blue/green) colours"-             , theme            = defaultTheme { activeColor         = "#001166"-                                               , activeBorderColor   = "#1f3999"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#09592a"-                                               , inactiveBorderColor = "#198044"-                                               , inactiveTextColor   = "#73e6a3"-                                               }+             , theme            = def { activeColor         = "#001166"+                                      , activeBorderColor   = "#1f3999"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#09592a"+                                      , inactiveBorderColor = "#198044"+                                      , inactiveTextColor   = "#73e6a3"+                                      }              }  -- | Peacock colours, by Kathryn Andersen@@ -254,13 +318,13 @@     newTheme { themeName        = "kavonPeacockTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Peacock colours"-             , theme            = defaultTheme { activeColor         = "#190f4c"-                                               , activeBorderColor   = "#2b1980"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#225173"-                                               , inactiveBorderColor = "#2a638c"-                                               , inactiveTextColor   = "#8fb2cc"-                                               }+             , theme            = def { activeColor         = "#190f4c"+                                      , activeBorderColor   = "#2b1980"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#225173"+                                      , inactiveBorderColor = "#2a638c"+                                      , inactiveTextColor   = "#8fb2cc"+                                      }              }  -- | Violet-Green colours, by Kathryn Andersen@@ -269,13 +333,13 @@     newTheme { themeName        = "kavonVioGreenTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Violet-Green colours"-             , theme            = defaultTheme { activeColor         = "#37174c"-                                               , activeBorderColor   = "#333399"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#174c17"-                                               , inactiveBorderColor = "#336633"-                                               , inactiveTextColor   = "#aaccaa"-                                               }+             , theme            = def { activeColor         = "#37174c"+                                      , activeBorderColor   = "#333399"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#174c17"+                                      , inactiveBorderColor = "#336633"+                                      , inactiveTextColor   = "#aaccaa"+                                      }              }  -- | Blue colours, by Kathryn Andersen@@ -284,13 +348,13 @@     newTheme { themeName        = "kavonBluesTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Blue colours"-             , theme            = defaultTheme { activeColor         = "#000066"-                                               , activeBorderColor   = "#111199"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#9999ee"-                                               , inactiveBorderColor = "#6666cc"-                                               , inactiveTextColor   = "black"-                                               }+             , theme            = def { activeColor         = "#000066"+                                      , activeBorderColor   = "#111199"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#9999ee"+                                      , inactiveBorderColor = "#6666cc"+                                      , inactiveTextColor   = "black"+                                      }              }  -- | Christmas colours, by Kathryn Andersen@@ -299,13 +363,13 @@     newTheme { themeName        = "kavonChristmasTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Christmas (green + red) colours"-             , theme            = defaultTheme { activeColor         = "#660000"-                                               , activeBorderColor   = "#990000"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#006600"-                                               , inactiveBorderColor = "#003300"-                                               , inactiveTextColor   = "#99bb99"-                                               }+             , theme            = def { activeColor         = "#660000"+                                      , activeBorderColor   = "#990000"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#006600"+                                      , inactiveBorderColor = "#003300"+                                      , inactiveTextColor   = "#99bb99"+                                      }              }  -- | Autumn colours, by Kathryn Andersen@@ -314,13 +378,13 @@     newTheme { themeName        = "kavonAutumnTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Autumn (brown + red) colours"-             , theme            = defaultTheme { activeColor         = "#660000"-                                               , activeBorderColor   = "#990000"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#542d11"-                                               , inactiveBorderColor = "#804d1A"-                                               , inactiveTextColor   = "#ffcc33"-                                               }+             , theme            = def { activeColor         = "#660000"+                                      , activeBorderColor   = "#990000"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#542d11"+                                      , inactiveBorderColor = "#804d1A"+                                      , inactiveTextColor   = "#ffcc33"+                                      }              }  -- | Fire colours, by Kathryn Andersen@@ -329,12 +393,11 @@     newTheme { themeName        = "kavonFireTheme"              , themeAuthor      = "Kathryn Andersen"              , themeDescription = "Fire (orange + red) colours"-             , theme            = defaultTheme { activeColor         = "#660000"-                                               , activeBorderColor   = "#990000"-                                               , activeTextColor     = "white"-                                               , inactiveColor       = "#ff8000"-                                               , inactiveBorderColor = "#d9b162"-                                               , inactiveTextColor   = "black"-                                               }+             , theme            = def { activeColor         = "#660000"+                                      , activeBorderColor   = "#990000"+                                      , activeTextColor     = "white"+                                      , inactiveColor       = "#ff8000"+                                      , inactiveBorderColor = "#d9b162"+                                      , inactiveTextColor   = "black"+                                      }              }-
XMonad/Util/Timer.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Timer+-- Description :  A module for setting up timers. -- Copyright   :  (c) Andrea Rossato and David Roundy 2007 -- License     :  BSD-style (see xmonad/LICENSE) --@@ -19,14 +21,14 @@     , TimerId     ) where -import XMonad-import Control.Applicative import Control.Concurrent import Data.Unique+import XMonad+import XMonad.Prelude (listToMaybe)  -- $usage -- This module can be used to setup a timer to handle deferred events.--- See 'XMonad.Layout.ShowWName' for an usage example.+-- See "XMonad.Layout.ShowWName" for an usage example.  type TimerId = Int @@ -42,7 +44,7 @@     a <- internAtom d "XMONAD_TIMER" False     allocaXEvent $ \e -> do          setEventType e clientMessage-         setClientMessageEvent e rw a 32 (fromIntegral u) currentTime+         setClientMessageEvent e rw a 32 (fromIntegral u) 0          sendEvent d rw False structureNotifyMask e     sync d False   return u@@ -50,10 +52,9 @@ -- | Given a 'TimerId' and an 'Event', run an action when the 'Event' -- has been sent by the timer specified by the 'TimerId' handleTimer :: TimerId -> Event -> X (Maybe a) -> X (Maybe a)-handleTimer ti (ClientMessageEvent {ev_message_type = mt, ev_data = dt}) action = do+handleTimer ti ClientMessageEvent{ev_message_type = mt, ev_data = dt} action = do   d <- asks display   a <- io $ internAtom d "XMONAD_TIMER" False-  if mt == a && dt /= [] && fromIntegral (head dt) == ti-     then action-     else return Nothing+  if | mt == a, Just dth <- listToMaybe dt, fromIntegral dth == ti -> action+     | otherwise -> return Nothing handleTimer _ _ _ = return Nothing
+ XMonad/Util/TreeZipper.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Actions.TreeSelect+-- Description :  Zipper over "Data.Tree".+-- Copyright   :  (c) Tom Smeets <tom.tsmeets@gmail.com>+-- License     :  BSD3-style (see LICENSE)+--+-- Maintainer  :  Tom Smeets <tom.tsmeets@gmail.com>+-- Stability   :  unstable+-- Portability :  unportable+--+-- <https://wiki.haskell.org/Zipper Zipper> over the "Data.Tree" data structure.+-- This module is based on <http://hackage.haskell.org/package/rosezipper rosezipper>.+--+-----------------------------------------------------------------------------++module XMonad.Util.TreeZipper(+    -- * Data structure+      TreeZipper(..)+    , cursor++    -- * Conversion+    , fromForest+    , toForest+    , getSubForest++    -- * Navigation+    , rootNode+    , parent+    , children+    , nextChild+    , previousChild++    -- * Utils+    , nodeDepth+    , nodeIndex+    , followPath+    , findChild++    , isLeaf+    , isRoot+    , isLast+    , isFirst+    ) where++import Data.Tree++-- | A <https://wiki.haskell.org/Zipper Zipper> over the "Data.Tree" data structure.+data TreeZipper a = TreeZipper { tz_current :: Tree a -- ^ the currently focused sub-tree under the cursor+                               , tz_before  :: Forest a -- ^ all sub-tree's to the /left/ of the cursor that have the same parent+                               , tz_after   :: Forest a -- ^ all sub-tree's to the /right/ of the cursor that have the same parent+                               , tz_parents :: [(Forest a, a, Forest a)] -- ^ list zippers for each parent level, the first element is the current parent+                               }+-- ^ Very crappy visualization of the 'TreeZipper' data structure+--+-- @+--              (tz_parents)+--        ([*],       *, [*])+--        ([*, *],    *, [])+--        ([],        *                  [*,   *])+--                    |                   |    |+--   +-------+--------+-------+------+  +-*-+  *+--   |       |        |       |      |  |   |+--  (tz_before) (tz_current) (tz_after) *   *+--   |       |                |      |+-- +-*-+     *                *      *+-- |   |+-- *   *+-- @++-- | Get the highlighted value+cursor :: TreeZipper a -> a+cursor = rootLabel . tz_current++-- | Create a 'TreeZipper' from a list of 'Data.Tree.Tree's focused on the first element+fromForest :: Forest a -> TreeZipper a+fromForest [] = error "XMonad.Util.TreeZipper.fromForest: can't create a TreeZipper from an empty list!"+fromForest (x:xs) = TreeZipper { tz_current = x+                               , tz_before  = []+                               , tz_after   = xs+                               , tz_parents = []+                               }++-- | Convert the entire zipper back to a 'Data.Tree.Forest'+toForest :: TreeZipper a -> Forest a+toForest = getSubForest . rootNode++-- | Create a 'Data.Tree.Forest' from all the children of the current parent+getSubForest :: TreeZipper a -> Forest a+getSubForest TreeZipper{..} = reverse tz_before ++ tz_current : tz_after++-- | Go to the upper most node such that+-- nothing is before nor above the cursor+rootNode :: TreeZipper a -> TreeZipper a+rootNode = f+  where+    f z = maybe (g z) f $ parent z+    g z = maybe z g $ previousChild z++-- | Move to the parent node+parent :: TreeZipper a -> Maybe (TreeZipper a)+parent t = case tz_parents t of+    (xs,a,ys) : ps -> Just+        TreeZipper { tz_current  = Node a (reverse (tz_before t) ++ tz_current t : tz_after t)+                   , tz_before   = xs+                   , tz_after    = ys+                   , tz_parents  = ps+                   }+    [] -> Nothing++-- | Move the cursor one level down to the first node+children :: TreeZipper a -> Maybe (TreeZipper a)+children z = case subForest $ tz_current z of+    (n:xs) -> Just+        TreeZipper { tz_current = n+                   , tz_before  = []+                   , tz_after   = xs+                   , tz_parents = (tz_before z, cursor z, tz_after z) : tz_parents z+                   }+    [] -> Nothing++-- | Go to the next child node+nextChild :: TreeZipper a -> Maybe (TreeZipper a)+nextChild z = case tz_after z of+    (n:xs) -> Just+        TreeZipper { tz_current = n+                   , tz_before  = tz_current z : tz_before z+                   , tz_after   = xs+                   , tz_parents = tz_parents z+                   }+    [] -> Nothing++-- | Go to the previous child node+previousChild :: TreeZipper a -> Maybe (TreeZipper a)+previousChild z = case tz_before z of+    (n:xs) -> Just+        TreeZipper { tz_current = n+                   , tz_before  = xs+                   , tz_after   = tz_current z : tz_after z+                   , tz_parents = tz_parents z+                   }+    [] -> Nothing++-- | How many nodes are above this one?+nodeDepth :: TreeZipper a -> Int+nodeDepth = length . tz_parents++-- | How many nodes are before the cursor? (on the current level)+nodeIndex :: TreeZipper a -> Int+nodeIndex = length . tz_before++-- | follow a Path specified by the list of nodes+followPath :: Eq b => (a -> b) -> [b] -> TreeZipper a -> Maybe (TreeZipper a)+followPath _ []     z = Just z+followPath f [x]    z = findChild (\y -> f y == x) z+followPath f (x:xs) z = findChild (\y -> f y == x) z >>= children >>= followPath f xs++-- | go to the first node next to the cursor that matches+findChild :: (a -> Bool) -> TreeZipper a -> Maybe (TreeZipper a)+findChild f z | f (cursor z) = Just z+              | otherwise    = nextChild z >>= findChild f++-- | Check whenther this is a leaf node+isLeaf :: TreeZipper a -> Bool+isLeaf = null . subForest . tz_current++-- | Check whenther this is a leaf node+isRoot :: TreeZipper a -> Bool+isRoot = null . tz_parents++-- | Check whenther this the last child+isLast :: TreeZipper a -> Bool+isLast = null . tz_after++-- | Check whenther this the first child+isFirst :: TreeZipper a -> Bool+isFirst = null . tz_before
XMonad/Util/Types.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.Types+-- Description :  Miscellaneous commonly used types. -- Copyright   :  (c) Daniel Schoepe (2009) -- License     :  BSD3-style (see LICENSE) --@@ -17,14 +17,12 @@                          ,Direction2D(..)                          ) where -import Data.Typeable (Typeable)- -- | One-dimensional directions:-data Direction1D = Next | Prev deriving (Eq,Read,Show,Typeable)+data Direction1D = Next | Prev deriving (Eq,Read,Show)  -- | Two-dimensional directions: data Direction2D = U -- ^ Up                  | D -- ^ Down                  | R -- ^ Right                  | L -- ^ Left-                   deriving (Eq,Read,Show,Ord,Enum,Bounded,Typeable)+                   deriving (Eq,Read,Show,Ord,Enum,Bounded)
+ XMonad/Util/Ungrab.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  XMonad.Util.Ungrab+-- Description :  Release xmonad's keyboard and pointer grabs immediately.+-- Copyright   :  (c) 2016 Brandon S Allbery+-- License     :  BSD-style (see xmonad/LICENSE)+--+-- Maintainer  :  allbery.b@gmail.com+-- Stability   :  unstable+-- Portability :  unportable+--+-- Allow releasing xmonad's keyboard grab+--+-----------------------------------------------------------------------------++module XMonad.Util.Ungrab {-# DEPRECATED "Use XMonad.Operations.unGrab instead" #-}+    ( -- * Usage:+      -- $usage+      unGrab+    ) where++#if MIN_VERSION_xmonad(0, 17, 9)+import XMonad.Operations (unGrab)+#else+import Graphics.X11.Xlib (sync)+import Graphics.X11.Xlib.Extras (currentTime)+import Graphics.X11.Xlib.Misc (ungrabKeyboard, ungrabPointer)+import XMonad.Core++-- $usage+-- Start a keyboard action with this if it is going to run something+-- that needs to do a keyboard, pointer, or server grab. For example,+--+-- > , ((modm .|. controlMask, xK_p), unGrab >> spawn "scrot")+--+-- (Other examples are screen lockers and "gksu".)+-- This avoids needing to insert a pause/sleep before running the+-- command.+--+-- xmonad retains the keyboard grab during key actions because if they+-- use a Submap, they need the keyboard to be grabbed, and if they had+-- to assert their own grab then the asynchronous nature of X11 allows+-- race conditions between xmonad, other clients, and the X server that+-- would cause keys to sometimes be "leaked" to the focused window.++-- | Release xmonad's keyboard grab, so other grabbers can do their thing.+unGrab :: X ()+unGrab = withDisplay $ \d -> io (ungrabKeyboard d currentTime >> ungrabPointer d currentTime >> sync d False)+#endif
XMonad/Util/WindowProperties.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.WindowProperties+-- Description :  EDSL for specifying window properties. -- Copyright   :  (c) Roman Cheplyaka -- License     :  BSD-style (see LICENSE) --@@ -21,10 +22,12 @@     -- $helpers     getProp32, getProp32s) where++import Foreign.C.Types (CLong) import XMonad+import XMonad.Actions.TagWindows (hasTag)+import XMonad.Prelude (filterM) import qualified XMonad.StackSet as W-import Foreign.C.Types (CLong)-import Control.Monad  -- $edsl -- Allows to specify window properties, such as title, classname or@@ -43,13 +46,14 @@               | Or  Property Property               | Not Property               | Const Bool+              | Tagged String -- ^ Tagged via "XMonad.Actions.TagWindows"               deriving (Read, Show) infixr 9 `And` infixr 8 `Or`  -- | Does given window have this property? hasProperty :: Property -> Window -> X Bool-hasProperty p w = runQuery (propertyToQuery p) w+hasProperty p = runQuery (propertyToQuery p)  -- | Does the focused window have this property? focusedHasProperty :: Property -> X Bool@@ -76,8 +80,9 @@ propertyToQuery (Machine s) = stringProperty "WM_CLIENT_MACHINE" =? s propertyToQuery (And p1 p2) = propertyToQuery p1 <&&> propertyToQuery p2 propertyToQuery (Or p1 p2) = propertyToQuery p1 <||> propertyToQuery p2-propertyToQuery (Not p) = not `fmap` propertyToQuery p+propertyToQuery (Not p) = not <$> propertyToQuery p propertyToQuery (Const b) = return b+propertyToQuery (Tagged s) = ask >>= \w -> liftX (hasTag s w)  -- $helpers
+ XMonad/Util/WindowState.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving,+  FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module       : XMonad.Util.WindowState+-- Description  :  Functions for saving per-window data.+-- Copyright    : (c) Dmitry Bogatov <KAction@gnu.org>+-- License      : BSD+--+-- Maintainer   : Dmitry Bogatov <KAction@gnu.org>+-- Stability    : unstable+-- Portability  : unportable+--+-- Functions for saving per-window data.+-----------------------------------------------------------------------------++module XMonad.Util.WindowState ( -- * Usage+                                 -- $usage+                                 get,+                                 put,+                                 StateQuery(..),+                                 runStateQuery,+                                 catchQuery ) where+import XMonad hiding (get, put, modify)+import Control.Monad.Reader(ReaderT(..))+import Control.Monad.State.Class+import Data.Typeable (typeOf)+-- $usage+--+-- This module allow to store state data with some 'Window'.+-- It is implemented with XProperties, so resources will be freed when+-- 'Window' is destoyed.+--+-- This module have advantage over "XMonad.Actions.TagWindows" in that it+-- hides from you implementation details and provides simple type-safe+-- interface.  Main datatype is 'StateQuery', which is simple wrapper around+-- 'Query', which is instance of MonadState, with 'put' and 'get' are+-- functions to acess data, stored in 'Window'.+--+-- To save some data in window you probably want to do following:+-- > (runStateQuery  (put $ Just value)  win) :: X ()+-- To retrive it, you can use+-- > (runStateQuery get win) :: X (Maybe YourValueType)+-- 'Query' can be promoted to 'StateQuery' simply by constructor,+-- and reverse is 'getQuery'.+--+-- For example, I use it to have all X applications @russian@ or @dvorak@+-- layout, but emacs have only @us@, to not screw keybindings. Use your+-- imagination!++-- | Wrapper around 'Query' with phantom type @s@, representing state, saved in+-- window.+newtype StateQuery s a = StateQuery {+      getQuery :: Query a+    } deriving (Monad, MonadIO, Applicative, Functor)++packIntoQuery :: (Window -> X a) -> Query a+packIntoQuery = Query . ReaderT++-- | Apply 'StateQuery' to 'Window'.+runStateQuery :: StateQuery s a -> Window ->  X a+runStateQuery = runQuery . getQuery++-- | Lifted to 'Query' version of 'catchX'+catchQuery :: Query a -> Query (Maybe a)+catchQuery q = packIntoQuery $ \win -> userCode $ runQuery q win++-- | Instance of MonadState for StateQuery.+instance (Show s, Read s, Typeable s) => MonadState (Maybe s) (StateQuery s) where+    get = StateQuery  $ read' <$> get' undefined where+        get'   :: Maybe s -> Query String+        get' x = stringProperty (typePropertyName x)+        read'  :: (Read s) => String -> Maybe s+        read' "" = Nothing+        read' s  = Just $ read s+    put = StateQuery . packIntoQuery <$> setWindowProperty' where+        setWindowProperty' val = setWindowProperty prop strValue where+            prop = typePropertyName val+            strValue = maybe "" show val++typePropertyName :: (Typeable a) => a -> String+typePropertyName x = "_XMONAD_WINSTATE__" ++ show (typeOf x)++type PropertyName = String+setWindowProperty :: PropertyName -> String -> Window -> X ()+setWindowProperty prop val win = withDisplay $ \d -> io $+                                 internAtom d prop False >>=+                                 setTextProperty d win val
XMonad/Util/WorkspaceCompare.hs view
@@ -1,6 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.WorkspaceCompare+-- Description :  Functions for examining, comparing, and sorting workspaces. -- Copyright   :  (c) Spencer Janssen <spencerjanssen@gmail.com> -- License     :  BSD3-style (see LICENSE) --@@ -11,6 +12,7 @@ -----------------------------------------------------------------------------  module XMonad.Util.WorkspaceCompare ( WorkspaceCompare, WorkspaceSort+                                    , filterOutWs                                     , getWsIndex                                     , getWsCompare                                     , getWsCompareByTag@@ -24,15 +26,19 @@  import XMonad import qualified XMonad.StackSet as S-import Data.List-import Data.Monoid-import Data.Ord-import Data.Maybe-import Data.Function+import XMonad.Prelude+import XMonad.Actions.PhysicalScreens (ScreenComparator(ScreenComparator), getScreenIdAndRectangle, screenComparatorById)  type WorkspaceCompare = WorkspaceId -> WorkspaceId -> Ordering type WorkspaceSort = [WindowSpace] -> [WindowSpace] +-- | Transforms a workspace list by filtering out the workspaces that+-- correspond to the given 'tag's.  Intended for use with 'logHook's (see+-- 'XMonad.Hooks.StatusBar.PP.filterOutWsPP') and "XMonad.Hooks.EwmhDesktops"+-- (see 'XMonad.Hooks.EwmhDesktops.addEwmhWorkspaceSort').+filterOutWs :: [WorkspaceId] -> WorkspaceSort+filterOutWs ws = filter (\S.Workspace{ S.tag = tag } -> tag `notElem` ws)+ -- | Lookup the index of a workspace id in the user's config, return Nothing -- if that workspace does not exist in the config. getWsIndex :: X (WorkspaceId -> Maybe Int)@@ -40,12 +46,20 @@     spaces <- asks (workspaces . config)     return $ flip elemIndex spaces +-- | Compare Maybe's differently, so Nothing (i.e. workspaces without indexes)+-- come last in the order+indexCompare :: Maybe Int -> Maybe Int -> Ordering+indexCompare Nothing Nothing = EQ+indexCompare Nothing (Just _) = GT+indexCompare (Just _) Nothing = LT+indexCompare a b = compare a b+ -- | A comparison function for WorkspaceId, based on the index of the --   tags in the user's config. getWsCompare :: X WorkspaceCompare getWsCompare = do     wsIndex <- getWsIndex-    return $ mconcat [compare `on` wsIndex, compare]+    return $ mconcat [indexCompare `on` wsIndex, compare]  -- | A simple comparison function that orders workspaces --   lexicographically by tag.@@ -54,30 +68,24 @@  -- | A comparison function for Xinerama based on visibility, workspace --   and screen id. It produces the same ordering as---   'XMonad.Hooks.DynamicLog.pprWindowSetXinerama'.+--   'XMonad.Hooks.StatusBar.PP.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.@@ -96,13 +104,11 @@ getSortByTag = mkWsSort getWsCompareByTag  -- | Sort serveral workspaces for xinerama displays, in the same order---   produced by 'XMonad.Hooks.DynamicLog.pprWindowSetXinerama': first+--   produced by 'XMonad.Hooks.StatusBar.PP.pprWindowSetXinerama': first --   visible workspaces, sorted by screen, then hidden workspaces, --   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
XMonad/Util/XSelection.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {- | Module      :  XMonad.Util.XSelection+Description :  A module for accessing and manipulating the primary selection. Copyright   :  (C) 2007 Andrea Rossato, Matthew Sackman License     :  BSD3 @@ -17,14 +18,14 @@ module XMonad.Util.XSelection (  -- * Usage                                  -- $usage                                  getSelection,+                                 getClipboard,+                                 getSecondarySelection,                                  promptSelection,                                  safePromptSelection,                                  transformPromptSelection,                                  transformSafePromptSelection) where -import Control.Exception.Extensible as E (catch,SomeException(..))-import Control.Monad (liftM, join)-import Data.Maybe (fromMaybe)+import Control.Exception as E (catch,SomeException(..)) import XMonad import XMonad.Util.Run (safeSpawn, unsafeSpawn) @@ -32,27 +33,47 @@  {- $usage    Add @import XMonad.Util.XSelection@ to the top of Config.hs-   Then make use of getSelection or promptSelection as needed; if-   one wanted to run Firefox with the selection as an argument (perhaps++   If one wanted to run Firefox with the selection as an argument (perhaps    the selection string is an URL you just highlighted), then one could add    to the xmonad.hs a line like thus:     > , ((modm .|. shiftMask, xK_b), promptSelection "firefox") +   To add a 'paste' keybinding in your prompts, use:++   > prompt_extra_bindings = [+   >   ((mod1Mask, xK_v), getClipboard >>= insertString) -- Alt+v to paste+   >   ]+   > +   > prompt_conf = def {+   >   promptKeymap =+   >     foldl (\m (k, a) -> M.insert k a m) defaultXPKeymap prompt_extra_bindings,+   >   -- other prompt config+   > }++   Next use it to construct a prompt, for example in your bindings:++   > ("M-p", shellPrompt prompt_conf),+    Future improvements for XSelection:     * More elaborate functionality: Emacs' registers are nice; if you-      don't know what they are, see <http://www.gnu.org/software/emacs/manual/html_node/emacs/Registers.html#Registers> -}+      don't know what they are, see <http://www.gnu.org/software/emacs/manual/html_node/emacs/Registers.html#Registers> --- | Returns a String corresponding to the current mouse selection in X;---   if there is none, an empty string is returned.-getSelection :: MonadIO m => m String-getSelection = io $ do+   WARNING: these functions are fundamentally implemented incorrectly and may,+   among other possible failure modes, deadlock or crash. For details, see+   <http://code.google.com/p/xmonad/issues/detail?id=573>.+   (These errors are generally very rare in practice, but still exist.) -}++-- Query the content of a selection in X+getSelectionNamed :: String -> IO String+getSelectionNamed sel_name = do   dpy <- openDisplay ""   let dflt = defaultScreen dpy   rootw  <- rootWindow dpy dflt   win <- createSimpleWindow dpy rootw 0 0 1 1 0 0 0-  p <- internAtom dpy "PRIMARY" True+  p <- internAtom dpy sel_name True   ty <- E.catch                (E.catch                      (internAtom dpy "UTF8_STRING" False)@@ -63,11 +84,29 @@   allocaXEvent $ \e -> do     nextEvent dpy e     ev <- getEvent e-    if ev_event_type ev == selectionNotify-       then do res <- getWindowProperty8 dpy clp win-               return $ decode . map fromIntegral . fromMaybe [] $ res-       else destroyWindow dpy win >> return ""+    result <- if ev_event_type ev == selectionNotify+                 then do res <- getWindowProperty8 dpy clp win+                         return $ decode . maybe [] (map fromIntegral) $ res+                 else return ""+    destroyWindow dpy win+    closeDisplay dpy+    return result +-- | Returns a String corresponding to the current mouse selection in X;+--   if there is none, an empty string is returned.+getSelection :: MonadIO m => m String+getSelection = io $ getSelectionNamed "PRIMARY"++-- | Returns a String corresponding to the current clipboard in X;+--   if there is none, an empty string is returned.+getClipboard :: MonadIO m => m String+getClipboard = io $ getSelectionNamed "CLIPBOARD"++-- | Returns a String corresponding to the secondary selection in X;+--   if there is none, an empty string is returned.+getSecondarySelection :: MonadIO m => m String+getSecondarySelection = io $ getSelectionNamed "SECONDARY"+ {- | A wrapper around 'getSelection'. Makes it convenient to run a program with the current selection as an argument.   This is convenient for handling URLs, in particular. For example, in your Config.hs you could bind a key to          @promptSelection \"firefox\"@;@@ -79,8 +118,8 @@   details on the advantages and disadvantages of using safeSpawn. -} promptSelection, safePromptSelection, unsafePromptSelection :: String -> X () promptSelection = unsafePromptSelection-safePromptSelection app = join $ io $ liftM (safeSpawn app . return) getSelection-unsafePromptSelection app = join $ io $ liftM unsafeSpawn $ fmap (\x -> app ++ " " ++ x) getSelection+safePromptSelection app = safeSpawn app . return =<< getSelection+unsafePromptSelection app = unsafeSpawn . (\x -> app ++ " " ++ x) =<< getSelection  {- | A wrapper around 'promptSelection' and its safe variant. They take two parameters, the      first is a function that transforms strings, and the second is the application to run.@@ -88,5 +127,5 @@      One example is to wrap code, such as a command line action copied out of the browser      to be run as @"sudo" ++ cmd@ or @"su - -c \""++ cmd ++"\""@. -} transformPromptSelection, transformSafePromptSelection :: (String -> String) -> String -> X ()-transformPromptSelection f app = join $ io $ liftM (safeSpawn app . return) (fmap f getSelection)-transformSafePromptSelection f app = join $ io $ liftM unsafeSpawn $ fmap (\x -> app ++ " " ++ x) (fmap f getSelection)+transformPromptSelection f app = (safeSpawn app . return . f) =<< getSelection+transformSafePromptSelection f app = unsafeSpawn . (\x -> app ++ " " ++ x) . f =<< getSelection
XMonad/Util/XUtils.hs view
@@ -1,6 +1,11 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module      :  XMonad.Util.XUtils+-- Description :  A module for painting on the screen. -- Copyright   :  (c) 2007 Andrea Rossato --                    2010 Alejandro Serrano -- License     :  BSD-style (see xmonad/LICENSE)@@ -16,7 +21,11 @@ module XMonad.Util.XUtils     ( -- * Usage:       -- $usage-      averagePixels+      withSimpleWindow+    , showSimpleWindow+    , WindowConfig(..)+    , WindowRect(..)+    , averagePixels     , createNewWindow     , showWindow     , showWindows@@ -28,24 +37,33 @@     , paintAndWrite     , paintTextAndIcons     , stringToPixel+    , pixelToString     , fi     ) where -import Data.Maybe+import XMonad.Prelude import XMonad import XMonad.Util.Font import XMonad.Util.Image-import Control.Monad+import qualified XMonad.StackSet as W+import Data.Bits ((.&.))  -- $usage -- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" or -- "XMonad.Layout.Decoration" for usage examples --- | Compute the weighted average the colors of two given Pixel values.+-- | Compute the weighted average the colors of two given 'Pixel' values.+--+-- This function masks out any alpha channel in the passed pixels, and the+-- result has no alpha channel. X11 mishandles @Pixel@ values with alpha+-- channels and throws errors while producing black pixels. averagePixels :: Pixel -> Pixel -> Double -> X Pixel-averagePixels p1 p2 f =+averagePixels p1' p2' f =     do d <- asks display        let cm = defaultColormap d (defaultScreen d)+           mask p = p .&. 0x00FFFFFF+           p1 = mask p1'+           p2 = mask p2'        [Color _ r1 g1 b1 _,Color _ r2 g2 b2 _] <- io $ queryColors d cm [Color p1 0 0 0 0,Color p2 0 0 0 0]        let mn x1 x2 = round (fromIntegral x1 * f + fromIntegral x2 * (1-f))        Color p _ _ _ _ <- io $ allocColor d cm (Color 0 (mn r1 r2) (mn g1 g2) (mn b1 b2) 0)@@ -127,8 +145,8 @@               -> X () paintAndWrite w fs wh ht bw bc borc ffc fbc als strs = do     d <- asks display-    strPositions <- forM (zip als strs) $ \(al, str) ->-        stringPosition d fs (Rectangle 0 0 wh ht) al str+    strPositions <- forM (zip als strs) $+        uncurry (stringPosition d fs (Rectangle 0 0 wh ht))     let ms = Just (fs,ffc,fbc, zip strs strPositions)     paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms Nothing @@ -150,13 +168,92 @@                   -> X () paintTextAndIcons w fs wh ht bw bc borc ffc fbc als strs i_als icons = do     d <- asks display-    strPositions <- forM (zip als strs) $ \(al, str) ->-        stringPosition d fs (Rectangle 0 0 wh ht) al str-    let iconPositions = map ( \(al, icon) -> iconPosition (Rectangle 0 0 wh ht) al icon ) (zip i_als icons)+    strPositions <- forM (zip als strs) $ uncurry (stringPosition d fs (Rectangle 0 0 wh ht))+    let iconPositions = zipWith (iconPosition (Rectangle 0 0 wh ht)) i_als icons         ms = Just (fs,ffc,fbc, zip strs strPositions)         is = Just (ffc, fbc, zip iconPositions icons)     paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms is +-- | The config for a window, as interpreted by 'showSimpleWindow'.+--+-- The font @winFont@ can either be specified in the TODO format or as an+-- xft font.  For example:+--+-- > winFont = "xft:monospace-20"+--+-- or+--+-- > winFont = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"+data WindowConfig = WindowConfig+  { winFont :: !String      -- ^ Font to use.+  , winBg   :: !String      -- ^ Background color.+  , winFg   :: !String      -- ^ Foreground color.+  , winRect :: !WindowRect  -- ^ Position and size of the rectangle.+  }++instance Default WindowConfig where+  def = WindowConfig+    {+#ifdef XFT+      winFont = "xft:monospace-20"+#else+      winFont = "-misc-fixed-*-*-*-*-20-*-*-*-*-*-*-*"+#endif+    , winBg   = "black"+    , winFg   = "white"+    , winRect = CenterWindow+    }++-- | What kind of window we should be.+data WindowRect+  = CenterWindow         -- ^ Centered, big enough to fit all the text.+  | CustomRect Rectangle -- ^ Completely custom dimensions.++-- | Create a window, then fill and show it with the given text.  If you+-- are looking for a version of this function that also takes care of+-- destroying the window, refer to 'withSimpleWindow'.+showSimpleWindow :: WindowConfig -- ^ Window config.+                 -> [String]     -- ^ Lines of text to show.+                 -> X Window+showSimpleWindow WindowConfig{..} strs = do+  let pad = 20+  font <- initXMF winFont+  dpy  <- asks display+  Rectangle sx sy sw sh <- getRectangle winRect++  -- Text extents for centering all fonts+  extends <- maximum . map (uncurry (+)) <$> traverse (textExtentsXMF font) strs+  -- Height and width of entire window+  height <- pure . fi $ (1 + length strs) * fi extends+  width  <- (+ pad) . fi . maximum <$> traverse (textWidthXMF dpy font) strs++  let -- x and y coordinates that specify the upper left corner of the window+      x = sx + (fi sw - width  + 2) `div` 2+      y = sy + (fi sh - height + 2) `div` 2+      -- y position of first string+      yFirst = (height + 2 * extends) `div` fi (2 + length strs)+      -- (x starting, y starting) for all strings+      strPositions = map (pad `div` 2, ) [yFirst, yFirst + extends ..]++  w <- createNewWindow (Rectangle x y (fi width) (fi height)) Nothing "" True+  let ms = Just (font, winFg, winBg, zip strs strPositions)+  showWindow w+  paintWindow' w (Rectangle 0 0 (fi width) (fi height)) 0 winBg "" ms Nothing+  releaseXMF font+  pure w+ where+  getRectangle :: WindowRect -> X Rectangle+  getRectangle = \case+    CenterWindow -> gets $ screenRect . W.screenDetail . W.current . windowset+    CustomRect r -> pure r++-- | Like 'showSimpleWindow', but fully manage the window; i.e., destroy+-- it after the given function finishes its execution.+withSimpleWindow :: WindowConfig -> [String] -> X a -> X a+withSimpleWindow wc strs doStuff = do+  w <- showSimpleWindow wc strs+  doStuff <* withDisplay (io . (`destroyWindow` w))+ -- This stuff is not exported  -- | Paints a titlebar with some strings and icons@@ -208,4 +305,3 @@            set_background_pixel  attributes p            createWindow d rw x y w h 0 (defaultDepthOfScreen s)                         inputOutput visual attrmask attributes-
− scripts/generate-configs 
@@ -1,302 +0,0 @@-#!/bin/bash--# generate-configs - Docstring parser for generating xmonad build configs with-#                    default settings for extensions-# Author: Alex Tarkovsky <alextarkovsky@gmail.com>-# Released into the public domain--# This script parses custom docstrings specifying build-time configuration data-# from xmonad extension source files, then inserts the data into copies of-# xmonad's Config.hs and xmonad.cabal files accordingly.-#-# Usage: generate-configs [ OPTIONS ] --main MAIN_DIR --contrib CONTRIB_DIR-#-# OPTIONS:-#   --active,  -a              Insert data in active mode (default: passive)-#   --contrib, -c CONTRIB_DIR  Path to contrib repository base directory-#   --help,    -h              Show help-#   --main,    -m MAIN_DIR     Path to main repository base directory-#   --output,  -o OUTPUT_DIR   Output directory (default: CONTRIB_DIR)-#-# Data parsed from the extension source files is inserted into Config.hs in-# either active or passive mode. The default is passive mode, in which the-# inserted data is commented out. The --active option inserts the data-# uncommented. Data inserted into xmonad.cabal is always inserted in active-# mode regardless of specified options.-#-# The docstring markup can be extended as needed. Currently the following tags-# are defined, shown with some examples:-#-# ~~~~~-#-# %cabalbuilddep-#-#     Cabal build dependency. Value is appended to the "build-depends" line in-#     xmonad.cabal and automatically prefixed with ", ".  NB: Don't embed-#     comments in this tag!-#-# -- %cabalbuilddep readline>=1.0-#-# %def-#-#     General definition. Value is appended to the end of Config.sh.-#-# -- %def commands :: [(String, X ())]-# -- %def commands = defaultCommands-#-# %import-#-#     Module needed by Config.sh to build the extension. Value is appended to-#     the end of the default import list in Config.sh and automatically-#     prefixed with "import ".-#-# -- %import XMonad.Layout.Accordion-# -- %import qualified XMonad.Actions.FlexibleManipulate as Flex-#-# %keybind-#-#     Tuple defining a key binding. Must be prefixed with ", ". Value is-#     inserted at the end of the "keys" list in Config.sh.-#-# -- %keybind , ((modMask, xK_d), date)-#-# %keybindlist-#-#     Same as %keybind, but instead of a key binding tuple the definition is a-#     list of key binding tuples (or a list comprehension producing them). This-#     list is concatenated to the "keys" list must begin with the "++" operator-#     rather than ", ".-#-# -- %keybindlist ++-# -- %keybindlist -- mod-[1..9] @@ Switch to workspace N-# -- %keybindlist -- mod-shift-[1..9] @@ Move client to workspace N-# -- %keybindlist -- mod-control-shift-[1..9] @@ Copy client to workspace N-# -- %keybindlist [((m .|. modMask, k), f i)-# -- %keybindlist     | (i, k) <- zip [0..fromIntegral (workspaces-1)] [xK_1 ..]-# -- %keybindlist     , (f, m) <- [(view, 0), (shift, shiftMask), (copy, shiftMask .|. controlMask)]]-#-# %layout-#-#     A layout. Must be prefixed with ", ". Value is inserted at the end of the-#     "defaultLayouts" list in Config.sh.-#-# -- %layout , accordion-#-# %mousebind-#-#     Tuple defining a mouse binding. Must be prefixed with ", ". Value is-#     inserted at the end of the "mouseBindings" list in Config.sh.-#-# -- %mousebind , ((modMask, button3), (\\w -> focus w >> Flex.mouseResizeWindow w))-#-# ~~~~~-#-# NB: '/' and '\' characters must be escaped with a '\' character!-#-# Tags may also contain comments, as illustrated in the %keybindlist examples-# above. Comments are a good place for special user instructions:-#-# -- %def -- comment out default logHook definition above if you uncomment this:-# -- %def logHook = dynamicLog--# Markup tag to search for in source files.-TAG_CABALBUILDDEP="%cabalbuilddep"-TAG_DEF="%def"-TAG_IMPORT="%import"-TAG_KEYBIND="%keybind"-TAG_KEYBINDLIST="%keybindlist"-TAG_LAYOUT="%layout"-TAG_MOUSEBIND="%mousebind"--# Insert markers to search for in Config.sh and xmonad.cabal. Values are-# extended sed regular expressions.-INS_MARKER_CABALBUILDDEP='^build-depends:.*'-INS_MARKER_IMPORT='-- % Extension-provided imports$'-INS_MARKER_LAYOUT='-- % Extension-provided layouts$'-INS_MARKER_KEYBIND='-- % Extension-provided key bindings$'-INS_MARKER_KEYBINDLIST='-- % Extension-provided key bindings lists$'-INS_MARKER_MOUSEBIND='-- % Extension-provided mouse bindings$'-INS_MARKER_DEF='-- % Extension-provided definitions$'--# Literal indentation strings. Values may contain escaped chars such as \t.-INS_INDENT_CABALBUILDDEP=""-INS_INDENT_DEF=""-INS_INDENT_IMPORT=""-INS_INDENT_KEYBIND="    "-INS_INDENT_KEYBINDLIST="    "-INS_INDENT_LAYOUT="                 "-INS_INDENT_MOUSEBIND="    "--# Prefix applied to inserted passive data after indent strings have been applied.-INS_PREFIX_DEF="-- "-INS_PREFIX_IMPORT="--import "-INS_PREFIX_KEYBIND="-- "-INS_PREFIX_KEYBINDLIST="-- "-INS_PREFIX_LAYOUT="-- "-INS_PREFIX_MOUSEBIND="-- "--# Prefix applied to inserted active data after indent strings have been applied.-ACTIVE_INS_PREFIX_CABALBUILDDEP=", "-ACTIVE_INS_PREFIX_DEF=""-ACTIVE_INS_PREFIX_IMPORT="import "-ACTIVE_INS_PREFIX_KEYBIND=""-ACTIVE_INS_PREFIX_KEYBINDLIST=""-ACTIVE_INS_PREFIX_LAYOUT=""-ACTIVE_INS_PREFIX_MOUSEBIND=""--# Don't touch these-opt_active=0-opt_contrib=""-opt_main=""-opt_output=""--generate_configs() {-    for extension_srcfile in $(ls --color=never -1 "${opt_contrib}"/*.hs | head -n -1 | sort -r) ; do-        for tag in $TAG_CABALBUILDDEP \-                   $TAG_DEF \-                   $TAG_IMPORT \-                   $TAG_KEYBIND \-                   $TAG_KEYBINDLIST \-                   $TAG_LAYOUT \-                   $TAG_MOUSEBIND ; do--            ifs="$IFS"-            IFS=$'\n'-            tags=( $(sed -n -r -e "s/^.*--\s*${tag}\s//p" "${extension_srcfile}") )-            IFS="${ifs}"--            case $tag in-                $TAG_CABALBUILDDEP) ins_indent=$INS_INDENT_CABALBUILDDEP-                                    ins_marker=$INS_MARKER_CABALBUILDDEP-                                    ins_prefix=$ACTIVE_INS_PREFIX_CABALBUILDDEP-                                    ;;-                $TAG_DEF)           ins_indent=$INS_INDENT_DEF-                                    ins_marker=$INS_MARKER_DEF-                                    ins_prefix=$INS_PREFIX_DEF-                                    ;;-                $TAG_IMPORT)        ins_indent=$INS_INDENT_IMPORT-                                    ins_marker=$INS_MARKER_IMPORT-                                    ins_prefix=$INS_PREFIX_IMPORT-                                    ;;-                $TAG_KEYBIND)       ins_indent=$INS_INDENT_KEYBIND-                                    ins_marker=$INS_MARKER_KEYBIND-                                    ins_prefix=$INS_PREFIX_KEYBIND-                                    ;;-                $TAG_KEYBINDLIST)   ins_indent=$INS_INDENT_KEYBINDLIST-                                    ins_marker=$INS_MARKER_KEYBINDLIST-                                    ins_prefix=$INS_PREFIX_KEYBINDLIST-                                    ;;-                $TAG_LAYOUT)        ins_indent=$INS_INDENT_LAYOUT-                                    ins_marker=$INS_MARKER_LAYOUT-                                    ins_prefix=$INS_PREFIX_LAYOUT-                                    ;;-                $TAG_MOUSEBIND)     ins_indent=$INS_INDENT_MOUSEBIND-                                    ins_marker=$INS_MARKER_MOUSEBIND-                                    ins_prefix=$INS_PREFIX_MOUSEBIND-                                    ;;-            esac--            # Insert in reverse so values will ultimately appear in correct order.-            for i in $( seq $(( ${#tags[*]} - 1 )) -1 0 ) ; do-                [ -z "${tags[i]}" ] && continue-                if [[ $tag == $TAG_CABALBUILDDEP ]] ; then-                    sed -i -r -e "s/${ins_marker}/\\0${ins_prefix}${tags[i]}/" "${CABAL_FILE}"-                else-                    sed -i -r -e "/${ins_marker}/{G;s/$/${ins_indent}${ins_prefix}${tags[i]}/;}" "${CONFIG_FILE}"-                fi-            done--            if [[ $tag != $TAG_CABALBUILDDEP && -n "${tags}" ]] ; then-                ins_group_comment="${ins_indent}--   For extension $(basename $extension_srcfile .hs):"-                sed -i -r -e "/${ins_marker}/{G;s/$/${ins_group_comment}/;}" "${CONFIG_FILE}"-            fi-        done-    done-}--parse_opts() {-    [[ -z "$1" ]] && show_usage 1--    while [[ $# > 0 ]] ; do-        case "$1" in-            --active|-a)  opt_active=1-                          shift ;;--            --contrib|-c) shift-                          if [[ -z "$1" || ! -d "$1" ]] ; then-                              echo "Error: Option --contrib requires a directory as argument. See: generate-configs -h"-                              exit 1-                          fi-                          opt_contrib="$1"-                          shift ;;--            --help|-h)    show_usage ;;--            --main|-m)    shift-                          if [[ -z "$1" || ! -d "$1" ]] ; then-                              echo "Error: Option --main requires a directory as argument. See: generate-configs -h"-                              exit 1-                          fi-                          opt_main="$1"-                          shift ;;--            --output|-o)  shift-                          if [[ -z "$1" || ! -d "$1" ]] ; then-                              echo "Error: Option --output requires a directory as argument. See: generate-configs -h"-                              exit 1-                          fi-                          opt_output="$1"-                          shift ;;--            -*)           echo "Error: Unknown option ${1}. See: generate-configs -h"-                          exit 1 ;;--            *)            show_usage 1 ;;-        esac-    done--    if [[ -z "$opt_main" ]] ; then-      echo "Error: Missing required option --main. See: generate-configs -h"-      exit 1-    fi--    if [[ -z "$opt_contrib" ]] ; then-      echo "Error: Missing required option --contrib. See: generate-configs -h"-      exit 1-    fi-}--show_usage() {-cat << EOF-Usage: generate-configs [ OPTIONS ] --main MAIN_DIR --contrib CONTRIB_DIR--OPTIONS:-  --active,  -a              Insert data in active mode (default: passive)-  --contrib, -c CONTRIB_DIR  Path to contrib repository base directory-  --help,    -h              Show help-  --main,    -m MAIN_DIR     Path to main repository base directory-  --output,  -o OUTPUT_DIR   Output directory (default: CONTRIB_DIR)-EOF-    exit ${1:-0}-}--parse_opts $*--[[ -z "$opt_output" ]] && opt_output="$opt_contrib"--CABAL_FILE="${opt_output}/xmonad.cabal"-CONFIG_FILE="${opt_output}/Config.hs"--cp -f "${opt_main}/xmonad.cabal" "${CABAL_FILE}"-cp -f "${opt_main}/Config.hs" "${CONFIG_FILE}"--if [[ $opt_active == 1 ]] ; then-    INS_PREFIX_DEF=$ACTIVE_INS_PREFIX_DEF-    INS_PREFIX_IMPORT=$ACTIVE_INS_PREFIX_IMPORT-    INS_PREFIX_KEYBIND=$ACTIVE_INS_PREFIX_KEYBIND-    INS_PREFIX_KEYBINDLIST=$ACTIVE_INS_PREFIX_KEYBINDLIST-    INS_PREFIX_LAYOUT=$ACTIVE_INS_PREFIX_LAYOUT-    INS_PREFIX_MOUSEBIND=$ACTIVE_INS_PREFIX_MOUSEBIND-fi--generate_configs
+ scripts/xmonadctl.hs view
@@ -0,0 +1,73 @@+#!/usr/bin/env runhaskell++-- Copyright: (c) Peter Olson 2013 and Andrea Rossato and David Roundy 2007+-- License: BSD-style (see xmonad/LICENSE)+--+-- Compile with @ghc --make xmonadctl.hs@+-- For usage help, do @xmonadctl -h@++import Control.Monad+import Data.Char+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+import System.Environment+import System.IO++main :: IO ()+main = parse True "XMONAD_COMMAND" =<< getArgs++parse :: Bool -> String -> [String] -> IO ()+parse input addr args = case args of+        ["--"] | input -> repl addr+               | otherwise -> return ()+        ("--":xs) -> sendAll addr xs+        ("-a":a:xs) -> parse input a xs+        ("-h":_) -> showHelp+        ("--help":_) -> showHelp+        ("-?":_) -> showHelp+        (a@('-':_):_) -> hPutStrLn stderr ("Unknown option " ++ a)++        (x:xs) -> sendCommand addr x >> parse False addr xs+        [] | input -> repl addr+           | otherwise -> return ()+++repl :: String -> IO ()+repl addr = do e <- isEOF+               unless e $ do+                 l <- getLine+                 sendCommand addr l+                 repl addr++sendAll :: String -> [String] -> IO ()+sendAll addr = foldr (\a b -> sendCommand addr a >> b) (return ())++sendCommand :: String -> String -> IO ()+sendCommand addr s = do+  d   <- openDisplay ""+  rw  <- rootWindow d $ defaultScreen d+  a <- internAtom d addr False+  m <- internAtom d s False+  allocaXEvent $ \e -> do+                  setEventType e clientMessage+                  setClientMessageEvent e rw a 32 m 0+                  sendEvent d rw False structureNotifyMask e+                  sync d False++showHelp :: IO ()+showHelp = do+    pn <- getProgName+    mapM_ putStrLn+        [ "Send commands to a running instance of xmonad."+        , "(xmonad.hs must be configured with XMonad.Hooks.ServerMode to work.)"+        , ""+        , "-a atomname can be used at any point in the command line arguments to"+        , "change which atom it is sending on. The atom defaults to XMONAD_COMMAND."+        , ""+        , "If sent with no arguments or only -a atom arguments, it will read commands from stdin."+        , ""+        , "Ex:"+        , pn ++ " cmd1 cmd2"+        , pn ++ " -a XMONAD_COMMAND cmd1 cmd2 cmd3 -a XMONAD_PRINT hello world"+        , pn ++ " -a XMONAD_PRINT # will read data from stdin."+        ]
+ scripts/xmonadpropread.hs view
@@ -0,0 +1,58 @@+#!/usr/bin/env runhaskell++{-# LANGUAGE LambdaCase #-}++-- Copyright Spencer Janssen <spencerjanssen@gmail.com>+-- BSD3 (see LICENSE)+--+-- Reads from an X property on the root window and writes to standard output.+--+-- May be used together with XMonad.Hooks.StatusBar.xmonadPropLog and a+-- status bar that doesn't support reading from properties itself, such as+-- dzen.+--+-- Usage:+--+--  $ xmonadpropread | dzen2+--+-- or+--+--  $ xmonadpropread _XMONAD_LOG_CUSTOM | dzen2++import Control.Monad+import Graphics.X11+import Graphics.X11.Xlib.Extras+import Codec.Binary.UTF8.String as UTF8+import Foreign.C (CChar)+import System.Environment+import System.IO++main :: IO ()+main = do+    hSetBuffering stdout LineBuffering++    atom <- flip fmap getArgs $ \case+        [a] -> a+        _   -> "_XMONAD_LOG"++    d <- openDisplay ""+    xlog <- internAtom d atom False++    root  <- rootWindow d (defaultScreen d)+    selectInput d root propertyChangeMask++    let printProp = do+            mwp <- getWindowProperty8 d xlog root+            maybe (return ()) (putStrLn . decodeCChar) mwp++    printProp++    allocaXEvent $ \ep -> forever $ do+        nextEvent d ep+        e <- getEvent ep+        case e of+            PropertyEvent { ev_atom = a } | a ==  xlog -> printProp+            _ -> return ()++decodeCChar :: [CChar] -> String+decodeCChar = UTF8.decode . map fromIntegral
+ tests/CycleRecentWS.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wall #-}+module CycleRecentWS where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import XMonad.Actions.CycleRecentWS (unView)+import XMonad.StackSet (view, greedyView, mapLayout)++import Instances+import Utils (tags)++spec :: Spec+spec = do+    prop "prop_unView" prop_unView++prop_unView :: T -> Property+prop_unView ss = conjoin+    [ counterexample desc (unView ss (state (v t ss)) === state ss)+    | t <- tags ss+    , (desc, v) <- [("view " <> show t, view), ("greedyView " <> show t, greedyView)] ]+  where+    state = mapLayout succ
+ tests/EZConfig.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE ViewPatterns               #-}+module EZConfig (spec) where++import Control.Arrow (first, (>>>))+import Data.Coerce+import Foreign.C.Types (CUInt(..))+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import XMonad+import XMonad.Prelude+import XMonad.Util.EZConfig+import XMonad.Util.Parser++spec :: Spec+spec = do+  prop "prop_decodePreservation" prop_decodePreservation+  prop "prop_encodePreservation" prop_encodePreservation++  context "parseKey" $ do+    let prepare = unzip . map (first surround)+        testParseKey (ns, ks) = traverse (runParser parseKey) ns `shouldBe` Just ks+    it "parses all regular keys"    $ testParseKey (unzip   regularKeys   )+    it "parses all function keys"   $ testParseKey (prepare functionKeys  )+    it "parses all special keys"    $ testParseKey (prepare specialKeys   )+    it "parses all multimedia keys" $ testParseKey (prepare multimediaKeys)+  context "parseModifier" $ do+    it "parses all combinations of modifiers" $+      nub . map sort <$> traverse (runParser (many $ parseModifier def))+                                     modifiers+        `shouldBe` Just [[ shiftMask, controlMask+                         , mod1Mask, mod1Mask      -- def M and M1+                         , mod2Mask, mod3Mask, mod4Mask, mod5Mask+                         ]]++  -- Checking for regressions+  describe "readKeySequence" $+    it "Fails on the non-existent key M-10" $+      readKeySequence def "M-10" `shouldBe` Nothing++-- | Parsing preserves all info that printing does.+prop_encodePreservation :: KeyString -> Property+prop_encodePreservation (coerce -> s) = parse s === (parse . pp =<< parse s)+ where parse = runParser (parseKeySequence def)+       pp    = unwords . map keyToString++-- | Printing preserves all info that parsing does.+prop_decodePreservation :: NonEmptyList (AKeyMask, AKeySym) -> Property+prop_decodePreservation (getNonEmpty >>> coerce -> xs) =+  Just (pp xs) === (fmap pp . parse $ pp xs)+ where parse = runParser (parseKeySequence def)+       pp    = unwords . map keyToString++-- | QuickCheck can handle the 8! combinations just fine.+modifiers :: [String]+modifiers = map concat $ permutations mods++mods :: [String]+mods = ["M-", "C-", "S-", "M1-", "M2-", "M3-", "M4-", "M5-"]++surround :: String -> String+surround s = "<" <> s <> ">"++-----------------------------------------------------------------------+-- Newtypes and Arbitrary instances++newtype AKeyMask = AKeyMask KeyMask+  deriving newtype (Show)++instance Arbitrary AKeyMask where+  arbitrary :: Gen AKeyMask+  arbitrary = fmap (coerce . sum . nub) . listOf . elements $+    [noModMask, shiftMask, controlMask, mod1Mask, mod2Mask, mod3Mask, mod4Mask, mod5Mask]++newtype AKeySym = AKeySym KeySym+  deriving newtype (Show)++instance Arbitrary AKeySym where+  arbitrary :: Gen AKeySym+  arbitrary = elements . coerce . map snd $ regularKeys <> allSpecialKeys++newtype KeyString = KeyString String+  deriving newtype (Show)++instance Arbitrary KeyString where+  arbitrary :: Gen KeyString+  arbitrary = coerce . unwords <$> listOf keybinding+   where+    keybinding :: Gen String+    keybinding = do+      let keyStr = map fst $ regularKeys <> allSpecialKeys+      mks <- nub <$> listOf (elements ("" : mods))+      k   <- elements keyStr+      ks  <- listOf . elements $ keyStr+      pure $ concat mks <> k <> " " <> unwords ks
+ tests/ExtensibleConf.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -Wall #-}+module ExtensibleConf where++import Test.Hspec++import XMonad+import qualified XMonad.Util.ExtensibleConf as XC++spec :: Spec+spec = do+    specify "lookup" $+        XC.lookup def `shouldBe` (Nothing :: Maybe ())+    specify "lookup . add" $+        XC.lookup (XC.add "a" def) `shouldBe` Just "a"+    specify "lookup . add . add" $+        XC.lookup (XC.add "b" (XC.add "a" def)) `shouldBe` Just "ab"+    specify "lookup @String . add @String . add @[Int]" $+        XC.lookup (XC.add "a" (XC.add [1 :: Int] def)) `shouldBe` Just "a"+    specify "lookup @[Int] . add @String . add @[Int]" $+        XC.lookup (XC.add "a" (XC.add [1 :: Int] def)) `shouldBe` Just [1 :: Int]+    specify "lookup @() . add @String . add @[Int]" $+        XC.lookup (XC.add "a" (XC.add [1 :: Int] def)) `shouldBe` (Nothing :: Maybe ())++    specify "once" $ do+        let c = XC.once incBorderWidth "a" def+        borderWidth c `shouldBe` succ (borderWidth def)+        XC.lookup c `shouldBe` Just "a"+    specify "once . once" $ do+        let c = XC.once incBorderWidth "b" (XC.once incBorderWidth "a" def)+        borderWidth c `shouldBe` succ (borderWidth def)+        XC.lookup c `shouldBe` Just "ab"++    specify "modifyDef" $ do+        let c = XC.modifyDef (<> "a") def+        XC.lookup c `shouldBe` Just "a"+    specify "modifyDef . modifyDef" $ do+        let c = XC.modifyDef (<> "b") (XC.modifyDef (<> "a") def)+        XC.lookup c `shouldBe` Just "ab"++incBorderWidth :: XConfig l -> XConfig l+incBorderWidth c = c{ borderWidth = succ (borderWidth c) }
+ tests/GridSelect.hs view
@@ -0,0 +1,15 @@+module GridSelect where++import Test.Hspec+import Test.Hspec.QuickCheck++import XMonad.Actions.GridSelect++spec :: Spec+spec = do+  prop "prop_stringToRatio_valuesInRange"  prop_stringToRatio_valuesInRange++prop_stringToRatio_valuesInRange :: String -> Bool+prop_stringToRatio_valuesInRange s =+  let r = stringToRatio s+  in r >= 0 && r <= 1
+ tests/Instances.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Instances where -- copied (and adapted) from the core library+++import           XMonad.Hooks.ManageDocks+import           XMonad.Layout.LimitWindows+import           Test.QuickCheck+import           Utils++import           XMonad.StackSet+import           Control.Monad+import           Data.List                      ( nub )++import           Graphics.X11                   ( Rectangle(Rectangle) )++arbNat :: Gen Int+arbNat = abs <$> arbitrary++arbPos :: Gen Int+arbPos = (+ 1) . abs <$> arbitrary++instance Arbitrary (Stack Int) where+  arbitrary = do+    xs <- arbNat+    ys <- arbNat+    return $ Stack { up    = [xs - 1, xs - 2 .. 0]+                   , focus = xs+                   , down  = [xs + 1 .. xs + ys]+                   }++instance Arbitrary (Selection a) where+  arbitrary = do+    nm <- arbNat+    st <- arbNat+    Sel nm (st + nm) <$> arbPos++--+-- The all important Arbitrary instance for StackSet.+--+instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary l, Arbitrary sd)+         => Arbitrary (StackSet i l a s sd) where+  arbitrary = do+      -- TODO: Fix this to be a reasonable higher number, Possibly use PositiveSized+    numWs        <- choose (1, 20)    -- number of workspaces, there must be at least 1.+    numScreens   <- choose (1, numWs) -- number of physical screens, there must be at least 1+    lay          <- arbitrary                  -- pick any layout++    wsIdxInFocus <- choose (1, numWs) -- pick index of WS to be in focus++    -- The same screen id's will be present in the list, with high possibility.+    screenDims   <- replicateM numScreens arbitrary++    -- Generate a list of "windows" for each workspace.+    wsWindows    <- vector numWs :: Gen [[a]]++    -- Pick a random window "number" in each workspace, to give focus.+    foc          <- sequence+      [ if null windows+          then return Nothing+          else Just <$> choose (0, length windows - 1)+      | windows <- wsWindows+      ]++    let tags'          = [1 .. fromIntegral numWs]+        focusWsWindows = zip foc wsWindows+        wss            = zip tags' focusWsWindows -- tmp representation of a workspace (tag, windows)+        initSs         = new lay tags' screenDims+    return $ view (fromIntegral wsIdxInFocus) $ foldr+      (\(tag', (focus', windows)) ss -> -- Fold through all generated (tags,windows).+              -- set workspace active by tag and fold through all+              -- windows while inserting them.  Apply the given number+              -- of `focusUp` on the resulting StackSet.+        applyN focus' focusUp $ foldr insertUp (view tag' ss) windows+      )+      initSs+      wss+++--+-- Just generate StackSets with Char elements.+--+type Tag = Int+type Window = Char+type T = StackSet Tag Int Window Int Int++++newtype EmptyStackSet = EmptyStackSet T+    deriving Show++instance Arbitrary EmptyStackSet where+  arbitrary = do+    (NonEmptyNubList ns ) <- arbitrary+    (NonEmptyNubList sds) <- arbitrary+    l                     <- arbitrary+    -- there cannot be more screens than workspaces:+    return . EmptyStackSet . new l ns $ take (min (length ns) (length sds)) sds++++newtype NonEmptyWindowsStackSet = NonEmptyWindowsStackSet T+    deriving Show++instance Arbitrary NonEmptyWindowsStackSet where+  arbitrary =+    NonEmptyWindowsStackSet+      `fmap` (arbitrary `suchThat` (not . null . allWindows))++instance Arbitrary RectC where+  arbitrary = do+    (x :: Int, y :: Int) <- arbitrary+    NonNegative w        <- arbitrary+    NonNegative h        <- arbitrary+    return $ RectC+      ( fromIntegral x+      , fromIntegral y+      , fromIntegral $ x + w+      , fromIntegral $ y + h+      )++instance Arbitrary Rectangle where+  arbitrary = Rectangle <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary RationalRect where+  arbitrary = RationalRect <$> dim <*> dim <*> dim <*> dim+   where+    dim = arbitrary `suchThat` liftM2 (&&) (>= 0) (<= 1)++newtype SizedPositive = SizedPositive Int+    deriving (Eq, Ord, Show, Read)++instance Arbitrary SizedPositive where+  arbitrary = sized $ \s -> do+    x <- choose (1, max 1 s)+    return $ SizedPositive x++++newtype NonEmptyNubList a = NonEmptyNubList [a]+    deriving ( Eq, Ord, Show, Read )++instance (Eq a, Arbitrary a) => Arbitrary (NonEmptyNubList a) where+  arbitrary =+    NonEmptyNubList `fmap` (fmap nub arbitrary `suchThat` (not . null))++++-- | Pull out an arbitrary tag from the StackSet. This removes the need for the+-- precondition "n `tagMember x` in many properties and thus reduces the number+-- of discarded tests.+--+--  n <- arbitraryTag x+--+-- We can do the reverse with a simple `suchThat`:+--+-- n <- arbitrary `suchThat` \n' -> not $ n' `tagMember` x+arbitraryTag :: T -> Gen Tag+arbitraryTag x = do+  let ts = tags x+  -- There must be at least 1 workspace, thus at least 1 tag.+  idx <- choose (0, length ts - 1)+  return $ ts !! idx++-- | Pull out an arbitrary window from a StackSet that is guaranteed to have a+-- non empty set of windows. This eliminates the precondition "i `member` x" in+-- a few properties.+--+--+-- foo (nex :: NonEmptyWindowsStackSet) = do+--   let NonEmptyWindowsStackSet x = nex+--   w <- arbitraryWindow nex+--   return $ .......+--+-- We can do the reverse with a simple `suchThat`:+--+--   n <- arbitrary `suchThat` \n' -> not $ n `member` x+arbitraryWindow :: NonEmptyWindowsStackSet -> Gen Window+arbitraryWindow (NonEmptyWindowsStackSet x) = do+  let ws = allWindows x+  -- We know that there are at least 1 window in a NonEmptyWindowsStackSet.+  idx <- choose (0, length ws - 1)+  return $ ws !! idx
+ tests/Main.hs view
@@ -0,0 +1,57 @@+module Main where++import Test.Hspec+import Test.Hspec.QuickCheck++import qualified ExtensibleConf+import qualified ManageDocks+import qualified NoBorders+import qualified RotateSome+import qualified Selective+import qualified SwapWorkspaces+import qualified XPrompt+import qualified CycleRecentWS+import qualified OrgMode+import qualified GridSelect+import qualified EZConfig+import qualified WindowNavigation++main :: IO ()+main = hspec $ do+    context "ManageDocks" $ do+        prop "prop_r2c_c2r" ManageDocks.prop_r2c_c2r+        prop "prop_c2r_r2c" ManageDocks.prop_c2r_r2c+    context "Selective" $ do+        prop "prop_select_length"     Selective.prop_select_length+        prop "prop_update_idem"       Selective.prop_update_idem+        prop "prop_select_master"     Selective.prop_select_master+        prop "prop_select_focus"      Selective.prop_select_focus+        prop "prop_select_increasing" Selective.prop_select_increasing+        prop "prop_select_two_consec" Selective.prop_select_two_consec+        prop "prop_update_nm"         Selective.prop_update_nm+        prop "prop_update_start"      Selective.prop_update_start+        prop "prop_update_nr"         Selective.prop_update_nr+        prop "prop_update_focus_up"   Selective.prop_update_focus_up+        prop "prop_update_focus_down" Selective.prop_update_focus_down+    context "RotateSome" $ do+        prop "prop_rotate_some_length"  RotateSome.prop_rotate_some_length+        prop "prop_rotate_some_cycle"   RotateSome.prop_rotate_some_cycle+        prop "prop_rotate_some_anchors" RotateSome.prop_rotate_some_anchors+        prop "prop_rotate_some_rotate"  RotateSome.prop_rotate_some_rotate+        prop "prop_rotate_some_focus"   RotateSome.prop_rotate_some_focus+    context "SwapWorkspaces" $ do+        prop "prop_double_swap"       SwapWorkspaces.prop_double_swap+        prop "prop_invalid_swap"      SwapWorkspaces.prop_invalid_swap+        prop "prop_swap_only_two"     SwapWorkspaces.prop_swap_only_two+        prop "prop_swap_with_current" SwapWorkspaces.prop_swap_with_current+    context "XPrompt" $ do+        prop "prop_split"            XPrompt.prop_split+        prop "prop_spliInSubListsAt" XPrompt.prop_spliInSubListsAt+        prop "prop_skipGetLastWord"  XPrompt.prop_skipGetLastWord+    context "NoBorders"      NoBorders.spec+    context "ExtensibleConf" ExtensibleConf.spec+    context "CycleRecentWS"  CycleRecentWS.spec+    context "OrgMode"        OrgMode.spec+    context "GridSelect"     GridSelect.spec+    context "EZConfig"       EZConfig.spec+    context "WindowNavigation" WindowNavigation.spec
tests/ManageDocks.hs view
@@ -1,18 +1,6 @@ module ManageDocks where-import XMonad-import XMonad.Hooks.ManageDocks-import Test.QuickCheck-import Foreign.C.Types-import Properties--instance Arbitrary CLong where-    arbitrary = fromIntegral `fmap` (arbitrary :: Gen Int)-instance Arbitrary RectC where-    arbitrary = do-        (x,y) <- arbitrary-        NonNegative w <- arbitrary-        NonNegative h <- arbitrary-        return $ RectC (x,y,x+w,y+h)+import           XMonad                         ( Rectangle )+import           XMonad.Hooks.ManageDocks  prop_r2c_c2r :: RectC -> Bool prop_r2c_c2r r = r2c (c2r r) == r
+ tests/NoBorders.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ViewPatterns    #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wall #-}+module NoBorders where++import Instances ()+import Test.Hspec+import Test.Hspec.QuickCheck++import qualified Data.Map as M++import XMonad hiding (Screen)+import qualified XMonad.Layout.NoBorders as NB+import XMonad.Prelude+import XMonad.StackSet++spec :: Spec+spec = do+    describe "dualhead, fullscreen float on each" $ do+        let s1 = differentiate [1]+        let s2 = differentiate [2]+        let floats = [(1, rrFull), (2, rrFull)]+        let ws = wsDualHead s1 s2 floats+        context "Ambiguity(Never)" $ do+            let amb = NB.Never+            it "removes border on current screen" $ do+                NB.hiddens amb ws r1 s1 [] `shouldBe` [1]+                NB.hiddens amb ws r3 s1 [] `shouldBe` [1]+            it "removes border on visible screen" $ do+                NB.hiddens amb ws r2 s2 [] `shouldBe` [2]+                NB.hiddens amb ws r4 s2 [] `shouldBe` [2]+        context "Ambiguity(OnlyScreenFloat)" $ do+            let amb = NB.OnlyScreenFloat+            it "removes border on current screen" $ do+                NB.hiddens amb ws r1 s1 [] `shouldBe` [1]+                NB.hiddens amb ws r3 s1 [] `shouldBe` [1]+            it "removes border on visible screen" $ do+                NB.hiddens amb ws r2 s2 [] `shouldBe` [2]+                NB.hiddens amb ws r4 s2 [] `shouldBe` [2]+        context "Ambiguity(OnlyLayoutFloat)" $ do+            let amb = NB.OnlyLayoutFloat+            it "removes border on current screen" $ do+                NB.hiddens amb ws r1 s1 [] `shouldBe` [1]+            it "removes border on visible screen" $ do+                NB.hiddens amb ws r2 s2 [] `shouldBe` [2]+        prop "prop_OnlyFloat" prop_OnlyFloat++-- | All floating windows should be borderless.+prop_OnlyFloat+    :: [Window]       -- ^ Windows on the first monitor+    -> [Window]       -- ^ Windows on the second monitor+    -> [RationalRect] -- ^ Floating window rectangles+    -> Bool           -- ^ Whether to consider focused or visible screen+    -> Bool+prop_OnlyFloat (nub -> w1) (nub -> w2) frs b+     = sort (w `intersect` map fst floats)+    == sort (NB.hiddens NB.OnlyFloat ws r (differentiate w) [])+  where+    (w, w', r) = if b then (w1, w2, r1) else (w2, w1, r2)+    ws         = wsDualHead (differentiate w1) (differentiate w2) floats+    floats     = zip (interleave w w') frs++    interleave :: [a] -> [a] -> [a]+    interleave (x : xs) (y : ys) = x : y : interleave xs ys+    interleave []       ys       = ys+    interleave xs       []       = xs++-- +------+------++-- |  r1  |  r2  |+-- |      |      |+-- |+----+|+----+|+-- || r3 ||| r4 ||+-- |+----+|+----+|+-- +------+------++r1, r2, r3, r4 :: Rectangle+r1 = Rectangle   0  0 100 100+r2 = Rectangle 100  0 100 100+r3 = Rectangle  10 10  80  80+r4 = Rectangle 110 10  80  80++rrFull :: RationalRect+rrFull = RationalRect 0 0 1 1++-- | Current screen @r1@ with window stack @w1@,+-- visible screen @r2@ with ws @w2@,+-- no hidden screens, maybe some floats.+wsDualHead :: Maybe (Stack Window) -> Maybe (Stack Window)+           -> [(Window, RationalRect)] -> WindowSet+wsDualHead w1 w2 f = StackSet{..}+    where+        current = mkScreen 1 r1 w1; visible = [mkScreen 2 r2 w2]; hidden = []+        floating = M.fromList f++mkScreen :: ScreenId -> Rectangle -> Maybe (Stack Window)+         -> Screen WorkspaceId l Window ScreenId ScreenDetail+mkScreen i r s = Screen{ workspace = w, screen = i, screenDetail = sd }+    where+        w = Workspace{ tag = show i, layout = undefined, stack = s }+        sd = SD{ screenRect = r }
+ tests/OrgMode.hs view
@@ -0,0 +1,250 @@+{-# OPTIONS_GHC -Wno-orphans             #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# LANGUAGE InstanceSigs       #-}+{-# LANGUAGE TypeApplications   #-}+{-# LANGUAGE TupleSections      #-}+{-# LANGUAGE LambdaCase         #-}+module OrgMode where++import XMonad.Prelude hiding ((!?))+import XMonad.Prompt.OrgMode++import qualified Data.Map.Strict as Map++import Data.Map.Strict (Map, (!), (!?))+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+++spec :: Spec+spec = do+  prop "prop_encodePreservation" prop_encodePreservation+  prop "prop_decodePreservation" prop_decodePreservation++  -- Checking for regressions+  describe "pInput" $ do+    it "works with todo +d 22 january 2021" $ do+      pInput "todo +d 22 ja 2021"+        `shouldBe` Just+          ( Deadline+              "todo"+              (Time {date = Date (22, Just 1, Just 2021), tod = Nothing})+              NoPriority+          )+    it "works with todo +d 22 01 2022" $ do+      pInput "todo +d 22 01 2022"+        `shouldBe` Just+          ( Deadline+              "todo"+              (Time {date = Date (22, Just 1, Just 2022), tod = Nothing})+              NoPriority+          )+    it "works with todo +d 1 01:01" $ do+      pInput "todo +d 1 01:01"+        `shouldBe` Just+          ( Deadline+              "todo"+              (Time {date = Date (1, Nothing, Nothing), tod = Just $ MomentInTime(HHMM 1 1)})+              NoPriority+          )+    it "works with todo +d 22 jan 2021 01:01 #b" $ do+      pInput "todo +d 22 jan 2021 01:01 #b"+        `shouldBe` Just+          ( Deadline+                "todo"+                (Time {date = Date (22, Just 1, Just 2021), tod = Just $ MomentInTime(HHMM 1 1)})+                B+          )+    it "parses no day as today when given a time" $ do+      pInput "todo +s 12:00"+        `shouldBe` Just (Scheduled "todo" (Time {date = Today, tod = Just $ MomentInTime(HHMM 12 0)}) NoPriority)+      pInput "todo +d 14:05 #B"+        `shouldBe` Just (Deadline "todo" (Time {date = Today, tod = Just $ MomentInTime(HHMM 14 5)}) B)+    it "parses `blah+d`, `blah +d`, `blah +d `, and `blah +d #B` as normal messages" $ do+      pInput "blah+d"+        `shouldBe` Just (NormalMsg "blah+d" NoPriority)+      pInput "blah +d"+        `shouldBe` Just (NormalMsg "blah +d" NoPriority)+      pInput "blah +d "+        `shouldBe` Just (NormalMsg "blah +d " NoPriority)+      pInput "blah +d #B"+        `shouldBe` Just (NormalMsg "blah +d" B)++  context "no priority#b" $ do+    it "parses to the correct thing" $+      pInput "no priority#b"+        `shouldBe` Just (NormalMsg "no priority#b" NoPriority)+    it "encode" $ prop_encodePreservation (OrgMsg "no priority#b")+    it "decode" $ prop_decodePreservation (NormalMsg "no priority#b" NoPriority)++  context "+d +d f" $ do+    it "encode" $ prop_encodePreservation (OrgMsg "+d +d f")+    it "decode" $ prop_decodePreservation (Deadline "+d" (Time {date = Next Friday, tod = Nothing}) NoPriority)+  context "+d f 1 +d f #c" $ do+    it "encode" $ prop_encodePreservation (OrgMsg "+d +d f")+    it "decode" $ prop_decodePreservation (Deadline "+d" (Time {date = Next Friday, tod = Nothing}) C)+  context "+d f 1 +d f" $ do+    it "encode" $ prop_encodePreservation (OrgMsg "+d f 1 +d f")+    it "decode" $ prop_decodePreservation (Deadline "+d f 1" (Time {date = Next Friday, tod = Nothing}) NoPriority)+  context "+d f 1 +d f #b" $ do+    it "encode" $ prop_encodePreservation (OrgMsg "+d f 1 +d f #b")+    it "decode" $ prop_decodePreservation (Deadline "+d f 1" (Time {date = Next Friday, tod = Nothing}) B)++-- | Parsing preserves all info that printing does.+prop_encodePreservation :: OrgMsg -> Property+prop_encodePreservation (OrgMsg s) = pInput s === (pInput . ppNote =<< pInput s)++-- | Printing preserves all info that parsing does.+prop_decodePreservation :: Note -> Property+prop_decodePreservation n = Just (ppNote n) === (fmap ppNote . pInput $ ppNote n)++------------------------------------------------------------------------+-- Pretty Printing++ppNote :: Note -> String+ppNote = \case+  Scheduled str t p -> str <> " +s " <> ppTime t <> ppPrio p+  Deadline  str t p -> str <> " +d " <> ppTime t <> ppPrio p+  NormalMsg str   p -> str                       <> ppPrio p++ppPrio :: Priority -> String+ppPrio = \case+  NoPriority -> ""+  prio       -> " #" <> show prio++ppTime :: Time -> String+ppTime (Time d t) = ppDate d <> ppOrgTime t+ where+  ppOrgTime :: Maybe OrgTime -> String+  ppOrgTime = maybe "" ((' ' :) . show)++  ppDate :: Date -> String+  ppDate dte = case days !? dte of+    Just v  -> v+    Nothing -> case d of -- only way it can't be in the map+      Date (d', mbM, mbY) -> show d'+                          <> maybe "" ((' ' :) . (months !)) mbM+                          <> maybe "" ((' ' :) . show)       mbY++------------------------------------------------------------------------+-- Arbitrary Instances++-- | An arbitrary (correct) message string.+newtype OrgMsg = OrgMsg String+  deriving (Show)++instance Arbitrary OrgMsg where+  arbitrary :: Gen OrgMsg+  arbitrary+    = OrgMsg <$> randomString                                             -- note+            <<>> elements [" +s ", " +d ", ""] <<>> dateGen <<>> hourGen  -- time and date+            <<>> elements ("" : map (reverse . (: " #")) "AaBbCc")        -- priority+   where+    dateGen :: Gen String+    dateGen = oneof+      [ pure $ days ! Today+      , pure $ days ! Tomorrow+      , elements $ (days !) . Next <$> [Monday .. Sunday]+      , rNat                                                   -- 17+      , unwords <$> sequenceA [rNat, monthGen]                 -- 17 jan+      , unwords <$> sequenceA [rNat, monthGen, rYear]          -- 17 jan 2021+      , unwords <$> traverse (fmap show) [rNat, rMonth]        -- 17 01+      , unwords <$> traverse (fmap show) [rNat, rMonth, rYear] -- 17 01 2021+      ]+     where+      rNat, rYear, rMonth :: Gen String+      rNat   = show <$> posInt+      rMonth = show <$> posInt `suchThat` (<= 12)+      rYear  = show <$> posInt `suchThat` (>  25)++      monthGen :: Gen String+      monthGen = elements $ Map.elems months++    hourGen :: Gen String+    hourGen = oneof+      [ pure " " <<>> (pad <$> hourInt) <<>> pure ":" <<>> (pad <$> minuteInt)+      , pure " " <<>> (pad <$> hourInt) <<>>               (pad <$> minuteInt)+      , pure ""+      ]+     where+      pad :: Int -> String+      pad n = (if n <= 9 then "0" else "") <> show n++instance Arbitrary Note where+  arbitrary :: Gen Note+  arbitrary = do+    msg <- randomString+    t   <- arbitrary+    p   <- arbitrary+    elements [Scheduled msg t p, Deadline msg t p, NormalMsg msg p]++instance Arbitrary Priority where+  arbitrary :: Gen Priority+  arbitrary = elements [A, B, C, NoPriority]++instance Arbitrary Time where+  arbitrary :: Gen Time+  arbitrary = Time <$> arbitrary <*> arbitrary++instance Arbitrary Date where+  arbitrary :: Gen Date+  arbitrary = oneof+    [ pure Today+    , pure Tomorrow+    , Next . toEnum <$> choose (0, 6)+    , do d <- posInt `suchThat` (<= 31)+         m <- mbPos `suchThat` (<= Just 12)+         Date . (d, m, ) <$> if   isNothing m+                             then pure Nothing+                             else mbPos `suchThat` (>= Just 25)+    ]++instance Arbitrary TimeOfDay where+  arbitrary :: Gen TimeOfDay+  arbitrary = HHMM <$> hourInt <*> minuteInt++instance Arbitrary OrgTime where+  arbitrary :: Gen OrgTime+  arbitrary = oneof+    [ MomentInTime <$> arbitrary+    , TimeSpan <$> arbitrary <*> arbitrary+    ]++------------------------------------------------------------------------+-- Util++randomString :: Gen String+randomString = listOf arbitraryPrintableChar <<>> (noSpace <&> (: []))+ where+  noSpace :: Gen Char+  noSpace = arbitraryPrintableChar `suchThat` (/= ' ')++days :: Map Date String+days = Map.fromList+  [ (Today, "tod"), (Tomorrow, "tom"), (Next Monday, "m"), (Next Tuesday, "tu")+  , (Next Wednesday, "w"), (Next Thursday, "th"), (Next Friday, "f")+  , (Next Saturday,"sa"), (Next Sunday,"su")+  ]++months :: Map Int String+months = Map.fromList+  [ (1, "ja"), (2, "f"), (3, "mar"), (4, "ap"), (5, "may"), (6, "jun")+  , (7, "jul"), (8, "au"), (9, "s"), (10, "o"), (11, "n"), (12, "d")+  ]++posInt :: Gen Int+posInt = getPositive <$> arbitrary @(Positive Int)++hourInt :: Gen Int+hourInt = posInt `suchThat` (<= 23)++minuteInt :: Gen Int+minuteInt = posInt `suchThat` (<= 59)++mbPos :: Num a => Gen (Maybe a)+mbPos = fmap (fromIntegral . getPositive) <$> arbitrary @(Maybe (Positive Int))++infixr 6 <<>>+(<<>>) :: (Applicative f, Monoid a) => f a -> f a -> f a+(<<>>) = liftA2 (<>)
+ tests/RotateSome.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module RotateSome where++import Utils+import Test.QuickCheck (Arbitrary, arbitrary, choose)+import XMonad.StackSet (Stack, integrate, up)+import XMonad.Actions.RotateSome (rotateSome)++newtype Divisor = Divisor Int deriving Show+instance Arbitrary Divisor where+  arbitrary = Divisor <$> choose (1, 5)++isMultOf :: Int -> Int -> Bool+x `isMultOf` n = (x `rem` n) == 0++-- Total number of elements does not change.+prop_rotate_some_length (Divisor d) (stk :: Stack Int) =+  length (integrate stk) == length (integrate $ rotateSome (`isMultOf` d) stk)++-- Applying rotateSome N times completes a cycle, where N is the number of+-- elements that satisfy the predicate.+prop_rotate_some_cycle (Divisor d) (stk :: Stack Int) =+  stk == applyN (Just n) (rotateSome (`isMultOf` d)) stk+  where+    n = length $ filter (`isMultOf` d) (integrate stk)++-- Elements that do not satisfy the predicate remain anchored in place.+prop_rotate_some_anchors (Divisor d) (stk :: Stack Int) =+  all check $+    zip+      (integrate stk)+      (integrate $ rotateSome (`isMultOf` d) stk)+  where+    check (before, after) = (before `isMultOf` d) || before == after++-- Elements that satisfy the predicate rotate by one position.+prop_rotate_some_rotate (Divisor d) (stk :: Stack Int) =+  drop 1 before ++ take 1 before == after+  where+    before = filter p (integrate stk)+    after = filter p (integrate $ rotateSome p stk)+    p = (`isMultOf` d)++-- Focus position is preserved.+prop_rotate_some_focus (Divisor d) (stk :: Stack Int) =+  length (up stk) == length (up $ rotateSome (`isMultOf` d) stk)
tests/Selective.hs view
@@ -1,36 +1,17 @@-{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Selective where  -- Tests for limitSelect-related code in L.LimitWindows. -- To run these tests, export (select,update,Selection(..),updateAndSelect) from -- L.LimitWindows. + import XMonad.Layout.LimitWindows import XMonad.StackSet hiding (focusUp, focusDown, filter)-import Control.Applicative ((<$>)) import Test.QuickCheck-import Control.Arrow (second) -instance Arbitrary (Stack Int) where-    arbitrary = do-                    xs <- arbNat-                    ys <- arbNat-                    return $ Stack { up=[xs-1,xs-2..0], focus=xs, down=[xs+1..xs+ys] }-    coarbitrary = undefined--instance Arbitrary (Selection a) where-    arbitrary = do-                    nm <- arbNat-                    st <- arbNat-                    nr <- arbPos-                    return $ Sel nm (st+nm) nr-    coarbitrary = undefined--arbNat = abs <$> arbitrary-arbPos = (+1) . abs <$> arbitrary---- as many windows as possible should be selected +-- as many windows as possible should be selected -- (when the selection is normalized) prop_select_length sel (stk :: Stack Int) =     (length . integrate $ select sel' stk) == ((nMaster sel' + nRest sel') `min` length (integrate stk))@@ -41,47 +22,58 @@     where sel' = update sel stk  -- select selects the master pane-prop_select_master sel (stk :: Stack Int) = +prop_select_master sel (stk :: Stack Int) =     take (nMaster sel) (integrate stk) == take (nMaster sel) (integrate $ select sel stk)  -- the focus should always be selected in normalized selections-prop_select_focus sel (stk :: Stack Int) = focus stk == (focus $ select sel' stk)+prop_select_focus sel (stk :: Stack Int) = focus stk == focus (select sel' stk)     where sel' = update sel stk  -- select doesn't change order (or duplicate elements) -- relies on the Arbitrary instance for Stack Int generating increasing stacks+prop_select_increasing :: Selection l -> Stack Int -> Bool prop_select_increasing sel (stk :: Stack Int) =     let res = integrate $ select sel stk-     in and . zipWith (<) res $ tail res+     in and . zipWith (<) res $ drop 1 res  -- selection has the form [0..l] ++ [m..n] -- relies on the Arbitrary instance for Stack Int generating stacks like [0..k]+prop_select_two_consec :: Selection l -> Stack Int -> Bool prop_select_two_consec sel (stk :: Stack Int) =     let wins = integrate $ select sel stk-     in (length . filter not . zipWith ((==) . (+1)) wins $ tail wins) <= 1+     in (length . filter not . zipWith ((==) . (+1)) wins $ drop 1 wins) <= 1  -- update preserves invariants on selections+prop_update_nm :: Selection l -> Stack Int -> Bool prop_update_nm sel (stk :: Stack Int) = nMaster (update sel stk) >= 0++prop_update_start :: Selection l -> Stack Int -> Bool prop_update_start sel (stk :: Stack Int) = nMaster sel' <= start sel'     where sel' = update sel stk++prop_update_nr :: Selection l -> Stack Int -> Bool prop_update_nr sel (stk :: Stack Int) = nRest (update sel stk) >= 0  -- moving the focus to a window that's already selected doesn't change the selection+prop_update_focus_up :: Selection l -> Stack Int -> Int -> Property prop_update_focus_up sel (stk :: Stack Int) x' =-    (length (up stk) >= x) && ((up stk !! (x-1)) `elem` integrate stk') ==> +    (length (up stk) >= x) && ((up stk !! (x-1)) `elem` integrate stk') ==>         sel' == update sel' (iterate focusUp stk !! x)     where         x = 1 + abs x'         sel' = update sel stk         stk' = select sel' stk +prop_update_focus_down :: Selection l -> Stack Int -> Int -> Property prop_update_focus_down sel (stk :: Stack Int) x' =-    (length (down stk) >= x) && ((down stk !! (x-1)) `elem` integrate stk') ==> +    (length (down stk) >= x) && ((down stk !! (x-1)) `elem` integrate stk') ==>         sel' == update sel' (iterate focusDown stk !! x)     where         x = 1 + abs x'         sel' = update sel stk         stk' = select sel' stk +focusUp :: Stack a -> Stack a focusUp stk = stk { up=tail (up stk), focus=head (up stk), down=focus stk:down stk }+focusDown :: Stack a -> Stack a focusDown stk = stk { down=tail (down stk), focus=head (down stk), up=focus stk:up stk }
tests/SwapWorkspaces.hs view
@@ -1,27 +1,29 @@ {-# LANGUAGE ScopedTypeVariables #-}-module SwapWorkspaces where+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -import Data.List(find,union)-import Data.Maybe(fromJust)+module SwapWorkspaces where+import Instances import Test.QuickCheck  import XMonad.StackSet-import Properties(T, NonNegative) -- requires tests/Properties.hs from xmonad-core import XMonad.Actions.SwapWorkspaces + -- Ensures that no "loss of information" can happen from a swap.-prop_double_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =-  t1 `tagMember` ss && t2 `tagMember` ss ==>-  ss == swap (swap ss)-  where swap = swapWorkspaces t1 t2+prop_double_swap (ss :: T) = do+  t1 <- arbitraryTag ss+  t2 <- arbitraryTag ss+  let swap = swapWorkspaces t1 t2+  return $ ss == swap (swap ss)  -- Degrade nicely when given invalid data.-prop_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =-  not (t1 `tagMember` ss || t2 `tagMember` ss) ==>-  ss == swapWorkspaces t1 t2 ss+prop_invalid_swap (ss :: T) = do+  t1 <- arbitrary `suchThat` (not . (`tagMember` ss))+  t2 <- arbitrary `suchThat` (not . (`tagMember` ss))+  return $ ss == swapWorkspaces t1 t2 ss  -- This doesn't pass yet. Probably should.--- prop_half_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =+-- prop_half_invalid_swap (ss :: T) (NonNegative t1) (NonNegative t2) = --   t1 `tagMember` ss && not (t2 `tagMember` ss) ==> --   ss == swapWorkspaces t1 t2 ss @@ -32,26 +34,15 @@                           zipWith f (hidden s)  (hidden t)  -- Swap only modifies the workspaces tagged t1 and t2 -- leaves all others alone.-prop_swap_only_two (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =-  t1 `tagMember` ss && t2 `tagMember` ss ==>-  and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss)-  where mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2+prop_swap_only_two (ss :: T) = do+  t1 <- arbitraryTag ss+  t2 <- arbitraryTag ss+  let mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2+  return $ and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss)  -- swapWithCurrent stays on current-prop_swap_with_current (ss :: T) (t :: NonNegative Int) =-  t `tagMember` ss ==>-  layout before == layout after && stack before == stack after-  where before = workspace $ current ss-        after  = workspace $ current $ swapWithCurrent t ss--main = do-  putStrLn "Testing double swap"-  quickCheck prop_double_swap-  putStrLn "Testing invalid swap"-  quickCheck prop_invalid_swap-  -- putStrLn "Testing half-invalid swap"-  -- quickCheck prop_half_invalid_swap-  putStrLn "Testing swap only two"-  quickCheck prop_swap_only_two-  putStrLn "Testing swap with current"-  quickCheck prop_swap_with_current+prop_swap_with_current (ss :: T) = do+  t <- arbitraryTag ss+  let before = workspace $ current ss+  let after  = workspace $ current $ swapWithCurrent t ss+  return $ layout before == layout after && stack before == stack after
+ tests/Utils.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE RankNTypes #-}+module Utils where -- copied from the core library++import XMonad.StackSet hiding (filter)+import Graphics.X11.Xlib.Types (Rectangle(..))+import Data.List (sortBy)++-- Useful operation, the non-local workspaces+hiddenSpaces :: StackSet i l a sid sd -> [Workspace i l a]+hiddenSpaces x = map workspace (visible x) ++ hidden x+++-- normalise workspace list+normal :: Ord i => StackSet i l a s sd -> StackSet i l a s sd+normal s = s { hidden = sortBy g (hidden s), visible = sortBy f (visible s) }+    where+        f a b = tag (workspace a) `compare` tag (workspace b)+        g a b = tag a `compare` tag b+++noOverlaps :: [Rectangle] -> Bool+noOverlaps []  = True+noOverlaps [_] = True+noOverlaps xs  = and [ verts a `notOverlap` verts b+                     | a <- xs+                     , b <- filter (a /=) xs+                     ]+    where+      verts (Rectangle a b w h) = (a,b,a + fromIntegral w - 1, b + fromIntegral h - 1)++      notOverlap (left1,bottom1,right1,top1)+                 (left2,bottom2,right2,top2)+        =  (top1 < bottom2 || top2 < bottom1)+        || (right1 < left2 || right2 < left1)+++applyN :: (Integral n) => Maybe n -> (a -> a) -> a -> a+applyN Nothing  _ v = v+applyN (Just 0) _ v = v+applyN (Just n) f v = applyN (Just $ n - 1) f (f v)++tags :: StackSet i l a sid sd -> [i]+tags x = map tag $ workspaces x+++-- | noOverflows op a b is True if @a `op` fromIntegral b@ overflows (or+-- otherwise gives the same answer when done using Integer+noOverflows :: (Integral b, Integral c) =>+  (forall a. Integral a => a -> a -> a) -> b -> c -> Bool+noOverflows op a b = toInteger (a `op` fromIntegral b) == toInteger a `op` toInteger b
+ tests/WindowNavigation.hs view
@@ -0,0 +1,635 @@+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module WindowNavigation where++import Test.Hspec++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Functor.Identity++import XMonad+import XMonad.Util.Types (Direction2D(..))+import XMonad.Actions.WindowNavigation (goPure, swapPure, WNState)+import qualified XMonad.StackSet as W++spec :: Spec+spec = do+  it "two-window adjacent go right (empty state)" $ do+    -- Simplest case - just move the focus once.+    -- ┌─────┬──────┐+    -- │ 1 ──┼─►  2 │+    -- └─────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect)+    runNav R M.empty (mkws 1 [] [2])+      `shouldBe` (mkstate 960 640, mkws 2 [1] [])++  it "two-window adjacent go right (populated state)" $ do+    -- Like the previous test, but this time internal stat is already populated with a position.+    -- ┌─────┬──────┐+    -- │ 1 ──┼─►  2 │+    -- └─────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect)+    runNav R (mkstate 100 100) (mkws 1 [] [2])+      `shouldBe` (mkstate 960 100, mkws 2 [1] [])++  it "two-window adjacent go right (incorrectly-populated state)" $ do+    -- This time we set the position incorrectly, testing if it will be reset to the center of focused window.+    -- ┌─────┬──────┐+    -- │ 1 ──┼─►  2 │+    -- └─────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2], windowRect)+    runNav R (mkstate 1000 100) (mkws 1 [] [2])+      `shouldBe` (mkstate 960 640, mkws 2 [1] [])++  it "swap windows" $ do+    -- Swap windows around.+    -- ┌─────┬──────┐+    -- │ 1 ◄─┼─►  2 │+    -- └─────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          ]+    runIdentity (swapPure R (M.empty, mkws 1 [] [2], S.fromList [1, 2], windowRect))+      `shouldBe` (mkstate 960 640, mkws 1 [2] [])++  it "tall layout, go up" $ do+    -- ┌─────┬─────┐+    -- │     │ 2 ▲ │+    -- │  1  ├───┼─┤+    -- │     │ 3 │ │+    -- └─────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 640)+          , (3, Rectangle 960 640 960 640)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1, 2, 3], windowRect)+    runNav U M.empty (mkws 3 [] [1, 2])+      `shouldBe` (mkstate 1440 639, mkws 2 [1, 3] [])++  it "tall layout, go down" $ do+    -- ┌─────┬─────┐+    -- │     │ 2   │+    -- │     ├─────┤+    -- │  1  │ 3 │ │+    -- │     ├───┼─┤+    -- │     │ 4 ▼ │+    -- └─────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 400)+          , (3, Rectangle 960 400 960 400)+          , (4, Rectangle 960 800 960 480)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    runNav D M.empty (mkws 3 [] [1, 2, 4])+      `shouldBe` (mkstate 1440 800, mkws 4 [2, 1, 3] [])++  it "tall layout, go left" $ do+    -- ┌─────┬─────┐+    -- │   ◄─┼── 2 │+    -- │     ├─────┤+    -- │ 1   │   3 │+    -- │     ├─────┤+    -- │     │   4 │+    -- └─────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 400)+          , (3, Rectangle 960 400 960 400)+          , (4, Rectangle 960 800 960 480)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    runNav L M.empty (mkws 2 [] [1, 3, 4])+      `shouldBe` (mkstate 959 200, mkws 1 [2] [3, 4])++  it "tall layout, go left and then right (window 2)" $ do+    -- ┌─────┬─────┐+    -- │   ◄─┼── 2 │+    -- │   ──┼─►   │+    -- │     ├─────┤+    -- │ 1   │   3 │+    -- │     ├─────┤+    -- │     │   4 │+    -- └─────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 400)+          , (3, Rectangle 960 400 960 400)+          , (4, Rectangle 960 800 960 480)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    let (st2, ws2) = runNav L M.empty (mkws 2 [] [1, 3, 4])+    (st2, ws2) `shouldBe` (mkstate 959 200, mkws 1 [2] [3, 4])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 960 200, mkws 2 [] [1, 3, 4])++  it "tall layout, go left and then right (window 3)" $ do+    -- ┌─────┬─────┐+    -- │     │   2 │+    -- │     ├─────┤+    -- │ 1 ◄─┼── 3 │+    -- │   ──┼─►   │+    -- │     ├─────┤+    -- │     │   4 │+    -- └─────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 400)+          , (3, Rectangle 960 400 960 400)+          , (4, Rectangle 960 800 960 480)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    let (st2, ws2) = runNav L M.empty (mkws 3 [] [1, 2, 4])+    (st2, ws2) `shouldBe` (mkstate 959 600, mkws 1 [3] [2, 4])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 960 600, mkws 3 [] [1, 2, 4])++  it "tall layout, go left and then right (window 4)" $ do+    -- ┌─────┬─────┐+    -- │     │   2 │+    -- │     ├─────┤+    -- │ 1   │   3 │+    -- │     ├─────┤+    -- │   ◄─┼── 4 │+    -- │   ──┼─►   │+    -- └─────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 400)+          , (3, Rectangle 960 400 960 400)+          , (4, Rectangle 960 800 960 480)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    let (st2, ws2) = runNav L M.empty (mkws 4 [] [1, 2, 3])+    (st2, ws2) `shouldBe` (mkstate 959 1040, mkws 1 [4] [2, 3])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 960 1040, mkws 4 [] [1, 2, 3])++  it "grid layout, go in a circle" $ do+    -- ┌─────┬─────┐+    -- │ 1 ──┼─► 2 │+    -- │     │     │+    -- │ ▲   │   │ │+    -- ├─┼───┼───┼─┤+    -- │ │   │   ▼ │+    -- │     │     │+    -- │ 3 ◄─┼── 4 │+    -- └─────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 640)+          , (2, Rectangle 960 0 960 640)+          , (3, Rectangle 0 640 960 640)+          , (4, Rectangle 960 640 960 640)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    let (st2, ws2) = runNav R M.empty (mkws 1 [] [2, 3, 4])+    (st2, ws2) `shouldBe` (mkstate 960 320, mkws 2 [1] [3, 4])+    let (st3, ws3) = runNav D st2 ws2+    (st3, ws3) `shouldBe` (mkstate 960 640, mkws 4 [3, 2, 1] [])+    let (st4, ws4) = runNav L st3 ws3+    (st4, ws4) `shouldBe` (mkstate 959 640, mkws 3 [2, 1] [4])+    let (st5, ws5) = runNav U st4 ws4+    (st5, ws5) `shouldBe` (mkstate 959 639, mkws 1 [] [2, 3, 4])++  it "ignore window that fully overlaps the current window in parallel direction when pos is outside it" $ do+    -- ┌─────┬──────┬──────┐+    -- │ ┌───┴──────┴────┐ │+    -- │ │   |  4   |    │ │+    -- │ └───┬──────┬────┘ │+    -- │  1  │  2 ──┼─► 3  │+    -- └─────┴──────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 600 1280)+          , (2, Rectangle 600 0 600 1280)+          , (3, Rectangle 1200 0 720 1280)+          , (4, Rectangle 200 200 1520 400)+          ]+    runIdentity (goPure R (mkstate 900 900, mkws 2 [] [1, 3, 4], S.fromList [1..4], windowRect))+      `shouldBe` (mkstate 1200 900, mkws 3 [1,2] [4])++  it "go to window that fully overlaps the current window in parallel direction when pos is inside it" $ do+    -- ┌─────────────────┐+    -- │     ┌──────┐    │+    -- │  1  │      │    │+    -- ├─────┤------├────┤+    -- │     │      │    │+    -- │  2  │  4 ──┼─►  │+    -- │     │      │    │+    -- ├─────┤------├────┤+    -- │  3  │      │    │+    -- │     └──────┘    │+    -- └─────────────────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 1920 400)+          , (2, Rectangle 0 400 1920 400)+          , (3, Rectangle 0 800 1920 480)+          , (4, Rectangle 800 200 400 880)+          ]+    runIdentity (goPure R (mkstate 1000 600, mkws 4 [] [1, 2, 3], S.fromList [1..4], windowRect))+      `shouldBe` (mkstate 1200 600, mkws 2 [1,4] [3])++  it "go from inner window to outer" $ do+    -- ┌───────────────┐+    -- │      ┌──────┐ │+    -- │  1 ◄─┼── 2  │ │+    -- │      └──────┘ │+    -- └───────────────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 1920 1280)+          , (2, Rectangle 600 600 600 600)+          ]+    runIdentity (goPure L (M.empty, mkws 2 [] [1], S.fromList [1, 2], windowRect))+      `shouldBe` (mkstate 599 900, mkws 1 [2] [])++  it "if there are multiple outer windows, go to the smaller one" $ do+    -- ┌────────────────────────┐+    -- │  ┌───────────────┐     │+    -- │  │      ┌──────┐ │     │+    -- │  │  2 ◄─┼── 3  │ │  1  │+    -- │  │      └──────┘ │     │+    -- │  └───────────────┘     │+    -- └────────────────────────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 1920 1280)+          , (2, Rectangle 200 200 1520 880)+          , (3, Rectangle 400 400 400 400)+          ]+    runIdentity (goPure L (M.empty, mkws 3 [] [1, 2], S.fromList [1..3], windowRect))+      `shouldBe` (mkstate 399 600, mkws 2 [1, 3] [])++  it "two tiled and one floating, floating fully inside" $ do+    -- ┌───────────────────┬─────┐+    -- │   ┌───────┐       │     │+    -- │ ──┼─►   ──┼─►   ──┼─►   │+    -- │   │   3   │   1   │   2 │+    -- │   │     ◄─┼──   ◄─┼──   │+    -- │   └───────┘       │     │+    -- └───────────────────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          , (3, Rectangle 400 400 400 400)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect)+    let (st2, ws2) = runNav R (mkstate 100 100) (mkws 1 [] [2, 3])+    (st2, ws2) `shouldBe` (mkstate 400 400, mkws 3 [2, 1] [])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 800 400, mkws 1 [] [2, 3])+    let (st4, ws4) = runNav R st3 ws3+    (st4, ws4) `shouldBe` (mkstate 960 400, mkws 2 [1] [3])+    let (st5, ws5) = runNav L st4 ws4+    (st5, ws5) `shouldBe` (mkstate 959 400, mkws 1 [] [2, 3])+    let (st6, ws6) = runNav L st5 ws5+    (st6, ws6) `shouldBe` (mkstate 799 400, mkws 3 [2, 1] [])++  it "two floating windows inside one big tiled one" $ do+    -- ┌─────────┐+    -- │    │    │+    -- │ ┌──┼──┐ │+    -- │ │  ▼  │ │+    -- │ │  3  │ │+    -- │ └──┼──┘ │+    -- │    ▼    │+    -- │    1    │+    -- │ ┌──┼──┐ │+    -- │ │  ▼  │ │+    -- │ │  4  │ │+    -- │ └──┼──┘ │+    -- │    ▼    │+    -- ├────┼────┤+    -- │    ▼    │+    -- │    2    │+    -- └─────────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 1920 640)+          , (2, Rectangle 0 640 1920 640)+          , (3, Rectangle 200 200 100 100)+          , (4, Rectangle 1000 400 100 100)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    let (st2, ws2) = runNav D (mkstate 1000 250) (mkws 1 [] [2, 3, 4])+    (st2, ws2) `shouldBe` (mkstate 299 250, mkws 3 [2, 1] [4])+    let (st3, ws3) = runNav D st2 ws2+    (st3, ws3) `shouldBe` (mkstate 299 300, mkws 1 [] [2, 3, 4])+    let (st4, ws4) = runNav D st3 ws3+    (st4, ws4) `shouldBe` (mkstate 1000 400, mkws 4 [3, 2, 1] [])+    let (st5, ws5) = runNav D st4 ws4+    (st5, ws5) `shouldBe` (mkstate 1000 500, mkws 1 [] [2, 3, 4])+    let (st6, ws6) = runNav D st5 ws5+    (st6, ws6) `shouldBe` (mkstate 1000 640, mkws 2 [1] [3, 4])++  it "floating window between two tiled ones" $ do+    -- ┌───────┬────────┐+    -- │ 1 ┌───┴───┐  2 │+    -- │ ──┼─► 3 ──┼─►  │+    -- │   └───┬───┘    │+    -- └───────┴────────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          , (3, Rectangle 860 540 200 200)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect)+    let (st2, ws2) = runNav R M.empty (mkws 1 [] [2, 3])+    (st2, ws2) `shouldBe` (mkstate 860 640, mkws 3 [2, 1] [])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 960 640, mkws 2 [1] [3])++  it "floating window overlapping four tiled ones" $ do+    -- ┌───────┬───────┐+    -- │   ┌───┴───┐   │+    -- │ 1 │       │ 2 │+    -- ├───┤       ├───┤+    -- │ ──┼─► 5 ──┼─► │+    -- │ 3 └───┬───┘ 4 │+    -- └───────┴───────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 640)+          , (2, Rectangle 960 0 960 640)+          , (3, Rectangle 0 640 960 640)+          , (4, Rectangle 960 640 960 640)+          , (5, Rectangle 760 440 400 400)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..5], windowRect)+    let (st2, ws2) = runNav R (mkstate 480 640) (mkws 3 [] [1, 2, 4, 5])+    (st2, ws2) `shouldBe` (mkstate 760 640, mkws 5 [4, 2, 1, 3] [])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 960 640, mkws 4 [2, 1, 3] [5])++  it "sequential inner floating windows" $ do+    -- ┌───────────────────────────────────┬──────┐+    -- │   ┌───────┐                       │      │+    -- │   │       │       ┌───────┐       │      │+    -- │ ──┼─► 3 ──┼─► 1 ──┼─► 4 ──┼─►   ──┼─► 2  │+    -- │ ◄─┼──   ◄─┼──   ◄─┼──   ◄─┼──   ◄─┼──    │+    -- │   └───────┘       │       │       │      │+    -- │                   └───────┘       │      │+    -- └───────────────────────────────────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          , (3, Rectangle 200 200 200 200)+          , (4, Rectangle 600 600 200 200)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    let (st2, ws2) = runNav R (mkstate 100 100) (mkws 1 [] [2, 3, 4])+    (st2, ws2) `shouldBe` (mkstate 200 200, mkws 3 [2,1] [4])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 400 200, mkws 1 [] [2, 3, 4])+    let (st4, ws4) = runNav R st3 ws3+    (st4, ws4) `shouldBe` (mkstate 600 600, mkws 4 [3, 2, 1] [])+    let (st5, ws5) = runNav R st4 ws4+    (st5, ws5) `shouldBe` (mkstate 800 600, mkws 1 [] [2, 3, 4])+    let (st6, ws6) = runNav R st5 ws5+    (st6, ws6) `shouldBe` (mkstate 960 600, mkws 2 [1] [3, 4])+    let (st7, ws7) = runNav L st6 ws6+    (st7, ws7) `shouldBe` (mkstate 959 600, mkws 1 [] [2, 3, 4])+    let (st8, ws8) = runNav L st7 ws7+    (st8, ws8) `shouldBe` (mkstate 799 600, mkws 4 [3, 2, 1] [])+    let (st9, ws9) = runNav L st8 ws8+    (st9, ws9) `shouldBe` (mkstate 599 600, mkws 1 [] [2, 3, 4])+    let (st10, ws10) = runNav L st9 ws9+    (st10, ws10) `shouldBe` (mkstate 399 399, mkws 3 [2, 1] [4])+    let (st11, ws11) = runNav L st10 ws10+    (st11, ws11) `shouldBe` (mkstate 199 399, mkws 1 [] [2, 3, 4])++  it "overlapping inner floating windows" $ do+    -- ┌─────────────────────┬──────┐+    -- │ ┌─────────┐         │      │+    -- │ │  3 ┌────┴─┐       │      │+    -- │ │  ──┼─►  ──┼─► 1 ──┼─►  2 │+    -- │ │  ◄─┼──  ◄─┼──   ◄─┼──    │+    -- │ │    │  4   │       │      │+    -- │ └────┤      │       │      │+    -- │      └──────┘       │      │+    -- └─────────────────────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          , (3, Rectangle 200 200 400 400)+          , (4, Rectangle 300 300 400 400)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..4], windowRect)+    let (st2, ws2) = runNav R M.empty (mkws 3 [] [1, 2, 4])+    (st2, ws2) `shouldBe` (mkstate 400 400, mkws 4 [2, 1, 3] [])+    let (st3, ws3) = runNav R st2 ws2+    (st3, ws3) `shouldBe` (mkstate 700 400, mkws 1 [3] [2, 4])+    let (st4, ws4) = runNav R st3 ws3+    (st4, ws4) `shouldBe` (mkstate 960 400, mkws 2 [1, 3] [4])+    let (st5, ws5) = runNav L st4 ws4+    (st5, ws5) `shouldBe` (mkstate 959 400, mkws 1 [3] [2, 4])+    let (st6, ws6) = runNav L st5 ws5+    (st6, ws6) `shouldBe` (mkstate 699 400, mkws 4 [2, 1, 3] [])+    let (st7, ws7) = runNav L st6 ws6+    (st7, ws7) `shouldBe` (mkstate 599 400, mkws 3 [] [1, 2, 4])++  it "bounce back from the wall to the floating window" $ do+    -- ┌────────────────┬─────┐+    -- │  1   ┌──────┐  │     │+    -- │  ┌───┼─►  3 │  │  2  │+    -- │  └── │      │  │     │+    -- │      └──────┘  │     │+    -- └────────────────┴─────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 1280)+          , (3, Rectangle 400 400 200 200)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..3], windowRect)+    runNav L (mkstate 100 640) (mkws 1 [] [2, 3])+      `shouldBe` (mkstate 400 599, mkws 3 [2, 1] [])++  it "jump between screens" $ do+    -- ┌─────┬──────┐  ┌────────┐+    -- │     │  2   │  │    5   │+    -- │     ├──────┤  ├────────┤+    -- │  1  │  3 ──┼──┼─►  6   │+    -- │     ├──────┤  └────────┘+    -- │     │  4   │+    -- └─────┴──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 400)+          , (3, Rectangle 960 400 960 400)+          , (4, Rectangle 960 800 960 480)+          , (5, Rectangle 1920 0 1280 384)+          , (6, Rectangle 1920 384 1280 384)+          ]+        initWindowSet =+          W.StackSet+          { W.current =+              W.Screen+              { W.workspace =+                  W.Workspace+                  { W.tag = "A"+                  , W.layout = Layout NullLayout+                  , W.stack = Just $ W.Stack { W.focus = 3, W.up = [], W.down = [1, 2, 4] }+                  }+              , W.screen = 1+              , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 }+              }+          , W.visible =+              [ W.Screen+                { W.workspace =+                    W.Workspace+                    { W.tag = "B"+                    , W.layout = Layout NullLayout+                    , W.stack = Just $ W.Stack { W.focus = 5, W.up = [], W.down = [6] }+                    }+                , W.screen = 2+                , W.screenDetail = SD { screenRect = Rectangle 1920 0 1280 768 }+                }+              ]+          , W.hidden = []+          , W.floating = M.empty+          }+        expectedWindowSet =+          W.StackSet+          { W.current =+              W.Screen+              { W.workspace =+                  W.Workspace+                  { W.tag = "B"+                  , W.layout = Layout NullLayout+                  , W.stack = Just $ W.Stack { W.focus = 6, W.up = [5], W.down = [] }+                  }+              , W.screen = 2+              , W.screenDetail = SD { screenRect = Rectangle 1920 0 1280 768 }+              }+          , W.visible =+              [ W.Screen+                { W.workspace =+                    W.Workspace+                    { W.tag = "A"+                    , W.layout = Layout NullLayout+                    , W.stack = Just $ W.Stack { W.focus = 3, W.up = [], W.down = [1, 2, 4] }+                    }+                , W.screen = 1+                , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 }+                }+              ]+          , W.hidden = []+          , W.floating = M.empty+          }++    runIdentity (goPure R (M.empty, initWindowSet, S.fromList [1..6], windowRect))+      `shouldBe` (M.fromList [("B", Point 1920 600)], expectedWindowSet)++  it "floating window overlapping fully in the orthogonal direction" $ do+    -- ┌─────┬──────────────────┐+    -- │     │      ┌───────┐   │+    -- │     │    2 │       │   │+    -- │     ├──────┤-------├───┤+    -- │  1  │    3 │       │ 3 │+    -- │   ◄─┼──  ◄─┼── 5 ◄─┼── │+    -- │     ├──────┤-------├───┤+    -- │     │    4 │       │   │+    -- │     │      └───────┘   │+    -- └─────┴──────────────────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 960 0 960 400)+          , (3, Rectangle 960 400 960 400)+          , (4, Rectangle 960 800 960 480)+          , (5, Rectangle 1360 200 200 800)+          ]+        runNav dir st ws = runIdentity $ goPure dir (st, ws, S.fromList [1..5], windowRect)+    let (st2, ws2) = runNav L (mkstate 1800 600) (mkws 3 [] [1, 2, 4, 5])+    (st2, ws2) `shouldBe` (mkstate 1559 600, mkws 5 [4, 2, 1, 3] [])+    let (st3, ws3) = runNav L st2 ws2+    (st3, ws3) `shouldBe` (mkstate 1359 600, mkws 3 [] [1, 2, 4, 5])+    let (st4, ws4) = runNav L st3 ws3+    (st4, ws4) `shouldBe` (mkstate 959 600, mkws 1 [3] [2, 4, 5])++  it "navigation to free-floating windows on the same screen" $ do+    -- ┌──────┐+    -- │      │  ┌──────┐+    -- │      │  │      │+    -- │    ──┼──┼─►  2 │+    -- │      │  │      │+    -- │   1  │  └──────┘+    -- │      │+    -- │      │+    -- └──────┘+    let windowRect w =+          Identity $ M.lookup w $ M.fromList+          [ (1, Rectangle 0 0 960 1280)+          , (2, Rectangle 1200 400 400 400)+          ]+    runIdentity (goPure R (M.empty, mkws 1 [] [2], S.fromList [1, 2], windowRect))+      `shouldBe` (mkstate 1200 640, mkws 2 [1] [])++  it "switch between windows in Full layout" $ do+    let windowRect w = Identity $ M.lookup w $ M.fromList [(1, Rectangle 0 0 1920 1280)]+    runIdentity (goPure D (M.empty, mkws 1 [] [2, 3], S.fromList [1], windowRect))+      `shouldBe` (M.empty, mkws 2 [1] [3])++data NullLayout a = NullLayout deriving (Show, Read, Eq)+instance LayoutClass NullLayout a++-- to make WindowSets comparable+instance Eq (Layout w) where+  (==) a b = show a == show b+  (/=) a b = show a /= show b++-- make a state with a position for a single workspace+mkstate :: Position -> Position -> WNState+mkstate px py = M.fromList [("A", Point px py)]++-- make a single-workspace WindowSet+mkws :: Window -> [Window] -> [Window] -> WindowSet+mkws focusedWindow upWindows downWindows = W.StackSet+  { W.current = W.Screen+    { W.workspace = W.Workspace+      { W.tag = "A"+      , W.layout = Layout NullLayout+      , W.stack = Just $ W.Stack { W.focus = focusedWindow, W.up = upWindows, W.down = downWindows }+      }+    , W.screen = 1+    , W.screenDetail = SD { screenRect = Rectangle 0 0 1920 1280 }+    }+  , W.visible = []+  , W.hidden = []+  , W.floating = M.empty+  }
tests/XPrompt.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} ------------------------------------- -- -- Tests for XPrompt and ShellPrompt@@ -6,49 +7,35 @@ ------------------------------------- module XPrompt where -import Data.Char import Test.QuickCheck -import Data.List-+import XMonad.Prelude (chunksOf) import XMonad.Prompt import qualified XMonad.Prompt.Shell as S-import Properties- -{--instance Arbitrary Char where-    arbitrary     = choose ('\32', '\255')-    coarbitrary c = variant (ord c `rem` 4) --}--doubleCheck p = check (defaultConfig { configMaxTest = 1000}) p-deepCheck p = check (defaultConfig { configMaxTest = 10000}) p-deepestCheck p = check (defaultConfig { configMaxTest = 100000}) p- -- brute force check for exceptions-prop_split (str :: [Char]) =+prop_split (str :: String) =     forAll (elements str) $ \e -> S.split e str == S.split e str  -- check if the first element of the new list is indeed the first part -- of the string.-prop_spliInSubListsAt (x :: Int) (str :: [Char]) =+prop_spliInSubListsAt (x :: Int) (str :: String) =     x < length str ==> result == take x str-    where result = case splitInSubListsAt x str of+    where result = case chunksOf x str of                      [] -> []-                     x -> head x+                     y -> head y  -- skipLastWord is complementary to getLastWord, unless the only space -- in the string is the final character, in which case skipLastWord -- and getLastWord will produce the same result.-prop_skipGetLastWord (str :: [Char]) =+prop_skipGetLastWord (str :: String) =     skipLastWord str ++ getLastWord str == str || skipLastWord str == getLastWord str   -- newIndex and newCommand get only non empy lists elemGen :: Gen ([String],String) elemGen = do-  a <- arbitrary :: Gen [[Char]]+  a <- arbitrary :: Gen [String]   let l = case filter (/= []) a of             [] -> ["a"]             x -> x@@ -67,15 +54,6 @@ -- this is actually the definition of newCommand... -- just to check something. {--prop_newCommandIndex = +prop_newCommandIndex =     forAll elemGen $ \(l,c) -> (skipLastWord c ++ (l !! (newIndex c l)))  == newCommand c l -}--main = do-  putStrLn "Testing ShellPrompt.split"-  deepCheck prop_split-  putStrLn "Testing spliInSubListsAt"-  deepCheck prop_spliInSubListsAt-  putStrLn "Testing skip + get lastWord"-  deepCheck prop_skipGetLastWord-
− tests/genMain.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-{- | generate another Main from all modules in the current directory,-extracting all functions with @prop_@.--Usage (your QuickCheck-1 version may vary):--> ln -s ../../xmonad/tests/Properties.hs .-> runghc genMain.hs > Main.hs-> ghc -DTESTING -i.. -i. -package QuickCheck-1.2.0.0 Main.hs -e ':main 200'---}-module Main where--import Control.Monad.List-import Data.Char-import Data.IORef-import Data.List-import qualified Data.Set as S-import System.Directory-import System.FilePath-import Text.PrettyPrint.HughesPJ--main = do-    imports <- newIORef S.empty-    props <- runListT $ do-        f @ ((isUpper -> True) : (takeExtension -> ".hs"))-            <- ListT (getDirectoryContents ".")-        guard $ f `notElem` ["Main.hs", "Common.hs", "Properties.hs"]-        let b = takeBaseName f-        nesting <- io $ newIORef 0-        decl : _ <- ListT $ (map words . lines) `fmap` readFile f-        case decl of-            "{-" -> io $ modifyIORef nesting succ-            "-}" -> io $ modifyIORef nesting pred-            _ -> return ()-        0 <- io $ readIORef nesting-        guard $ "prop_" `isPrefixOf` decl-        io $ modifyIORef imports (S.insert b)-        return (b ++ "." ++ decl)-    imports <- S.toList `fmap` readIORef imports-    print $ genModule imports props--genModule :: [String] -> [String] -> Doc-genModule imports props = vcat [header,imports', main ]-    where-        header = text "module Main where"-        imports' = text "import Test.QuickCheck; import Data.Maybe; \-                            \import System.Environment; import Text.Printf; \-                            \import Properties hiding (main); import Control.Monad"-                $$ vcat [ text "import qualified" <+> text im | im <- imports ]-        props' = [ parens $ doubleQuotes (text p) <> comma <> text "mytest" <+> text p-                            | p <- props ]-        main = hang (text "main = do") 4 $-                    text "n <- maybe (return 100) readIO . listToMaybe =<< getArgs"-                    $$-                    hang (text "let props = ") 8-                        (brackets $ foldr1 (\x xs -> x <> comma $$ xs) props')-                    $$-                    text "(results, passed) <- liftM unzip $ \-                            \mapM (\\(s,a) -> printf \"%-40s: \" s >> a n) props"-                    $$-                    text "printf \"Passed %d tests!\\n\" (sum passed)"-                    $$-                    text "when (any not results) $ fail \"Not all tests passed!\""--io x = liftIO x
xmonad-contrib.cabal view
@@ -1,10 +1,12 @@ name:               xmonad-contrib-version:            0.11.4-homepage:           http://xmonad.org/-synopsis:           Third party extensions for xmonad+version:            0.18.2+-- ^ also update cpp-options: -DXMONAD_CONTRIB_VERSION_*++homepage:           https://xmonad.org/+synopsis:           Community-maintained extensions for xmonad description:-    Third party tiling algorithms, configurations and scripts to xmonad,-    a tiling window manager for X.+    Community-maintained tiling algorithms and extension modules for xmonad,+    an X11 tiling window manager.     .     For an introduction to building, configuring and using xmonad     extensions, see "XMonad.Doc". In particular:@@ -21,87 +23,91 @@ license-file:       LICENSE author:             Spencer Janssen & others maintainer:         xmonad@haskell.org-extra-source-files: README scripts/generate-configs scripts/run-xmonad.sh+extra-source-files: README.md+                    CHANGES.md+                    scripts/run-xmonad.sh                     scripts/window-properties.sh-                    scripts/xinitrc scripts/xmonad-acpi.c+                    scripts/xinitrc+                    scripts/xmonad-acpi.c                     scripts/xmonad-clock.c-                    tests/genMain.hs-                    tests/ManageDocks.hs-                    tests/Selective.hs-                    tests/SwapWorkspaces.hs-                    tests/XPrompt.hs-cabal-version:      >= 1.6+                    scripts/xmonadctl.hs+                    scripts/xmonadpropread.hs+                    XMonad/Config/dmwit.xmobarrc+                    XMonad/Config/Example.hs+cabal-version:      1.12 build-type:         Simple-bug-reports:        http://code.google.com/p/xmonad/issues/list+bug-reports:        https://github.com/xmonad/xmonad-contrib/issues -tested-with:        GHC == 7.8.2, GHC==7.6.2, GHC==7.4.1, GHC==7.2.1, GHC==7.0.4+tested-with:        GHC == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.8 || == 9.4.8 || == 9.6.7 || == 9.8.4 || == 9.10.3 || == 9.12.2 || == 9.14.1  source-repository head-  type:     darcs-  location: http://code.haskell.org/XMonadContrib+  type:     git+  location: https://github.com/xmonad/xmonad-contrib  -flag small_base-  description: Choose the new smaller, split-up base package.- flag use_xft   description: Use Xft to render text -flag testing-  description: Testing mode-  default: False+flag pedantic+  description: Be pedantic (-Werror and the like)+  default:     False+  manual:      True  library-    if flag(small_base)-        build-depends: base >= 3 && < 5,-                       containers,-                       directory,-                       extensible-exceptions,-                       old-locale,-                       old-time,-                       process,-                       random-    else-        build-depends: base < 3--    if flag(use_xft)-        build-depends: X11-xft >= 0.2, utf8-string-        extensions: ForeignFunctionInterface-        cpp-options: -DXFT--    build-depends:      mtl >= 1 && < 3, unix, X11 >= 1.6.1 && < 1.7, xmonad >= 0.11 && < 0.12, utf8-string--    if true-        ghc-options:    -fwarn-tabs -Wall+    build-depends: base >= 4.12 && < 5,+                   bytestring >= 0.10 && < 0.13,+                   containers >= 0.5 && < 0.9,+                   directory,+                   filepath,+                   time >= 1.8 && < 1.16,+                   process,+                   random,+                   mtl >= 1 && < 3,+                   transformers,+                   unix,+                   X11 >= 1.10 && < 1.11,+                   xmonad >= 0.18.0 && < 0.19,+                   utf8-string,+                   deepseq+    default-language: Haskell2010 -    extensions:         ForeignFunctionInterface+    cpp-options:   -DXMONAD_CONTRIB_VERSION_MAJOR=0+                   -DXMONAD_CONTRIB_VERSION_MINOR=18+                   -DXMONAD_CONTRIB_VERSION_PATCH=2+    ghc-options:   -Wall -Wno-unused-do-bind -    if flag(testing)-        ghc-options:    -fwarn-tabs -Werror+    if flag(pedantic)+       ghc-options: -Werror -Wwarn=deprecations+    if impl(ghc >= 9.10)+       ghc-options: -Wno-incomplete-record-selectors -    if impl(ghc >= 6.12.1)-        ghc-options:    -fno-warn-unused-do-bind+    -- Keep this in sync with the oldest version in 'tested-with'+    if impl(ghc > 8.8.4)+       -- don't treat unused-imports warning as errors, they may be necessary+       -- for compatibility with older versions of base (or other deps)+       ghc-options: -Wwarn=unused-imports -    if impl (ghc == 6.10.1) && arch (x86_64)-        ghc-options:    -O0+    if flag(use_xft)+        build-depends: X11-xft >= 0.2+        cpp-options: -DXFT -    exposed-modules:    XMonad.Doc-                        XMonad.Doc.Configuring-                        XMonad.Doc.Extending-                        XMonad.Doc.Developing+    exposed-modules:    XMonad.Actions.AfterDrag                         XMonad.Actions.BluetileCommands                         XMonad.Actions.Commands                         XMonad.Actions.ConstrainedResize                         XMonad.Actions.CopyWindow                         XMonad.Actions.CycleRecentWS                         XMonad.Actions.CycleSelectedLayouts-                        XMonad.Actions.CycleWindows                         XMonad.Actions.CycleWS+                        XMonad.Actions.CycleWindows+                        XMonad.Actions.CycleWorkspaceByScreen                         XMonad.Actions.DeManage                         XMonad.Actions.DwmPromote-                        XMonad.Actions.DynamicWorkspaces+                        XMonad.Actions.DynamicProjects                         XMonad.Actions.DynamicWorkspaceGroups                         XMonad.Actions.DynamicWorkspaceOrder+                        XMonad.Actions.DynamicWorkspaces+                        XMonad.Actions.EasyMotion                         XMonad.Actions.FindEmptyWorkspace                         XMonad.Actions.FlexibleManipulate                         XMonad.Actions.FlexibleResize@@ -110,96 +116,155 @@                         XMonad.Actions.FocusNth                         XMonad.Actions.GridSelect                         XMonad.Actions.GroupNavigation+                        XMonad.Actions.KeyRemap                         XMonad.Actions.Launcher+                        XMonad.Actions.LinkWorkspaces                         XMonad.Actions.MessageFeedback+                        XMonad.Actions.Minimize+                        XMonad.Actions.MostRecentlyUsed                         XMonad.Actions.MouseGestures                         XMonad.Actions.MouseResize                         XMonad.Actions.Navigation2D                         XMonad.Actions.NoBorders                         XMonad.Actions.OnScreen+                        XMonad.Actions.PerLayoutKeys+                        XMonad.Actions.PerWindowKeys                         XMonad.Actions.PerWorkspaceKeys                         XMonad.Actions.PhysicalScreens                         XMonad.Actions.Plane+                        XMonad.Actions.Prefix+                        XMonad.Actions.Profiles                         XMonad.Actions.Promote                         XMonad.Actions.RandomBackground-                        XMonad.Actions.KeyRemap+                        XMonad.Actions.RepeatAction+                        XMonad.Actions.Repeatable                         XMonad.Actions.RotSlaves+                        XMonad.Actions.RotateSome                         XMonad.Actions.Search                         XMonad.Actions.ShowText+                        XMonad.Actions.Sift                         XMonad.Actions.SimpleDate                         XMonad.Actions.SinkAll                         XMonad.Actions.SpawnOn                         XMonad.Actions.Submap+                        XMonad.Actions.SwapPromote                         XMonad.Actions.SwapWorkspaces                         XMonad.Actions.TagWindows+                        XMonad.Actions.TiledWindowDragging+                        XMonad.Actions.ToggleFullFloat                         XMonad.Actions.TopicSpace+                        XMonad.Actions.TreeSelect                         XMonad.Actions.UpdateFocus                         XMonad.Actions.UpdatePointer+                        XMonad.Actions.UpKeys                         XMonad.Actions.Warp                         XMonad.Actions.WindowBringer                         XMonad.Actions.WindowGo                         XMonad.Actions.WindowMenu                         XMonad.Actions.WindowNavigation                         XMonad.Actions.WithAll+                        XMonad.Actions.Workscreen                         XMonad.Actions.WorkspaceCursors                         XMonad.Actions.WorkspaceNames-                        XMonad.Actions.Workscreen                         XMonad.Config.Arossato                         XMonad.Config.Azerty+                        XMonad.Config.Bepo                         XMonad.Config.Bluetile                         XMonad.Config.Desktop+                        XMonad.Config.Dmwit                         XMonad.Config.Droundy                         XMonad.Config.Gnome                         XMonad.Config.Kde+                        XMonad.Config.Mate+                        XMonad.Config.Prime                         XMonad.Config.Sjanssen                         XMonad.Config.Xfce+                        XMonad.Doc+                        XMonad.Doc.Configuring+                        XMonad.Doc.Developing+                        XMonad.Doc.Extending+                        XMonad.Hooks.BorderPerWindow                         XMonad.Hooks.CurrentWorkspaceOnTop                         XMonad.Hooks.DebugEvents                         XMonad.Hooks.DebugKeyEvents+                        XMonad.Hooks.DebugStack                         XMonad.Hooks.DynamicBars                         XMonad.Hooks.DynamicHooks+                        XMonad.Hooks.DynamicIcons                         XMonad.Hooks.DynamicLog-                        XMonad.Hooks.DebugStack+                        XMonad.Hooks.DynamicProperty                         XMonad.Hooks.EwmhDesktops                         XMonad.Hooks.FadeInactive                         XMonad.Hooks.FadeWindows+                        XMonad.Hooks.FloatConfigureReq                         XMonad.Hooks.FloatNext-                        XMonad.Hooks.ICCCMFocus+                        XMonad.Hooks.Focus                         XMonad.Hooks.InsertPosition+                        XMonad.Hooks.ManageDebug                         XMonad.Hooks.ManageDocks                         XMonad.Hooks.ManageHelpers                         XMonad.Hooks.Minimize+                        XMonad.Hooks.Modal+                        XMonad.Hooks.OnPropertyChange                         XMonad.Hooks.Place                         XMonad.Hooks.PositionStoreHooks-                        XMonad.Hooks.RestoreMinimized+                        XMonad.Hooks.RefocusLast+                        XMonad.Hooks.Rescreen                         XMonad.Hooks.ScreenCorners                         XMonad.Hooks.Script                         XMonad.Hooks.ServerMode                         XMonad.Hooks.SetWMName+                        XMonad.Hooks.ShowWName+                        XMonad.Hooks.StatusBar+                        XMonad.Hooks.StatusBar.PP+                        XMonad.Hooks.StatusBar.WorkspaceScreen+                        XMonad.Hooks.TaffybarPagerHints                         XMonad.Hooks.ToggleHook                         XMonad.Hooks.UrgencyHook+                        XMonad.Hooks.WallpaperSetter+                        XMonad.Hooks.WindowSwallowing                         XMonad.Hooks.WorkspaceByPos+                        XMonad.Hooks.WorkspaceHistory                         XMonad.Hooks.XPropManage                         XMonad.Layout.Accordion                         XMonad.Layout.AutoMaster+                        XMonad.Layout.AvoidFloats+                        XMonad.Layout.BinaryColumn+                        XMonad.Layout.BinarySpacePartition                         XMonad.Layout.BorderResize                         XMonad.Layout.BoringWindows                         XMonad.Layout.ButtonDecoration+                        XMonad.Layout.CenterMainFluid+                        XMonad.Layout.CenteredIfSingle                         XMonad.Layout.CenteredMaster                         XMonad.Layout.Circle+                        XMonad.Layout.CircleEx                         XMonad.Layout.Column+                        XMonad.Layout.Columns                         XMonad.Layout.Combo                         XMonad.Layout.ComboP                         XMonad.Layout.Cross                         XMonad.Layout.Decoration+                        XMonad.Layout.DecorationEx+                        XMonad.Layout.DecorationEx.Common+                        XMonad.Layout.DecorationEx.Engine+                        XMonad.Layout.DecorationEx.Geometry+                        XMonad.Layout.DecorationEx.Widgets+                        XMonad.Layout.DecorationEx.LayoutModifier+                        XMonad.Layout.DecorationEx.TextEngine+                        XMonad.Layout.DecorationEx.DwmGeometry+                        XMonad.Layout.DecorationEx.TabbedGeometry                         XMonad.Layout.DecorationAddons                         XMonad.Layout.DecorationMadness                         XMonad.Layout.Dishes-                        XMonad.Layout.DraggingVisualizer                         XMonad.Layout.DragPane+                        XMonad.Layout.DraggingVisualizer                         XMonad.Layout.Drawer+                        XMonad.Layout.Dwindle                         XMonad.Layout.DwmStyle+                        XMonad.Layout.FixedAspectRatio                         XMonad.Layout.FixedColumn+                        XMonad.Layout.FocusTracking                         XMonad.Layout.Fullscreen                         XMonad.Layout.Gaps                         XMonad.Layout.Grid@@ -208,13 +273,14 @@                         XMonad.Layout.Groups.Examples                         XMonad.Layout.Groups.Helpers                         XMonad.Layout.Groups.Wmii+                        XMonad.Layout.Hidden                         XMonad.Layout.HintedGrid                         XMonad.Layout.HintedTile                         XMonad.Layout.IM+                        XMonad.Layout.IfMax                         XMonad.Layout.ImageButtonDecoration                         XMonad.Layout.IndependentScreens                         XMonad.Layout.LayoutBuilder-                        XMonad.Layout.LayoutBuilderP                         XMonad.Layout.LayoutCombinators                         XMonad.Layout.LayoutHints                         XMonad.Layout.LayoutModifier@@ -231,83 +297,225 @@                         XMonad.Layout.MosaicAlt                         XMonad.Layout.MouseResizableTile                         XMonad.Layout.MultiColumns+                        XMonad.Layout.MultiDishes                         XMonad.Layout.MultiToggle                         XMonad.Layout.MultiToggle.Instances+                        XMonad.Layout.MultiToggle.TabBarDecoration                         XMonad.Layout.Named                         XMonad.Layout.NoBorders                         XMonad.Layout.NoFrillsDecoration                         XMonad.Layout.OnHost                         XMonad.Layout.OneBig+                        XMonad.Layout.PerScreen                         XMonad.Layout.PerWorkspace                         XMonad.Layout.PositionStoreFloat                         XMonad.Layout.Reflect                         XMonad.Layout.Renamed+                        XMonad.Layout.ResizableThreeColumns                         XMonad.Layout.ResizableTile                         XMonad.Layout.ResizeScreen                         XMonad.Layout.Roledex                         XMonad.Layout.ShowWName+                        XMonad.Layout.SideBorderDecoration                         XMonad.Layout.SimpleDecoration                         XMonad.Layout.SimpleFloat                         XMonad.Layout.Simplest                         XMonad.Layout.SimplestFloat+                        XMonad.Layout.SortedLayout                         XMonad.Layout.Spacing                         XMonad.Layout.Spiral                         XMonad.Layout.Square                         XMonad.Layout.StackTile+                        XMonad.Layout.StateFull+                        XMonad.Layout.Stoppable                         XMonad.Layout.SubLayouts                         XMonad.Layout.TabBarDecoration                         XMonad.Layout.Tabbed+                        XMonad.Layout.TallMastersCombo                         XMonad.Layout.ThreeColumns                         XMonad.Layout.ToggleLayouts                         XMonad.Layout.TrackFloating                         XMonad.Layout.TwoPane+                        XMonad.Layout.TwoPanePersistent+                        XMonad.Layout.VoidBorders                         XMonad.Layout.WindowArranger                         XMonad.Layout.WindowNavigation                         XMonad.Layout.WindowSwitcherDecoration                         XMonad.Layout.WorkspaceDir                         XMonad.Layout.ZoomRow+                        XMonad.Prelude                         XMonad.Prompt-                        XMonad.Prompt.AppendFile                         XMonad.Prompt.AppLauncher-                        XMonad.Prompt.Directory+                        XMonad.Prompt.AppendFile+                        XMonad.Prompt.ConfirmPrompt                         XMonad.Prompt.DirExec+                        XMonad.Prompt.Directory                         XMonad.Prompt.Email+                        XMonad.Prompt.FuzzyMatch                         XMonad.Prompt.Input                         XMonad.Prompt.Layout                         XMonad.Prompt.Man+                        XMonad.Prompt.OrgMode+                        XMonad.Prompt.Pass                         XMonad.Prompt.RunOrRaise                         XMonad.Prompt.Shell                         XMonad.Prompt.Ssh                         XMonad.Prompt.Theme+                        XMonad.Prompt.Unicode                         XMonad.Prompt.Window                         XMonad.Prompt.Workspace                         XMonad.Prompt.XMonad+                        XMonad.Prompt.Zsh+                        XMonad.Util.ActionCycle+                        XMonad.Util.ActionQueue+                        XMonad.Util.ClickableWorkspaces                         XMonad.Util.Cursor                         XMonad.Util.CustomKeys                         XMonad.Util.DebugWindow                         XMonad.Util.Dmenu+                        XMonad.Util.DynamicScratchpads                         XMonad.Util.Dzen-                        XMonad.Util.ExtensibleState                         XMonad.Util.EZConfig+                        XMonad.Util.ExclusiveScratchpads+                        XMonad.Util.ExtensibleConf+                        XMonad.Util.ExtensibleState                         XMonad.Util.Font+                        XMonad.Util.Grab+                        XMonad.Util.Hacks+                        XMonad.Util.History                         XMonad.Util.Image                         XMonad.Util.Invisible                         XMonad.Util.Loggers+                        XMonad.Util.Loggers.NamedScratchpad+                        XMonad.Util.Minimize                         XMonad.Util.NamedActions                         XMonad.Util.NamedScratchpad                         XMonad.Util.NamedWindows+                        XMonad.Util.NoTaskbar+                        XMonad.Util.Parser                         XMonad.Util.Paste                         XMonad.Util.PositionStore+                        XMonad.Util.Process+                        XMonad.Util.PureX+                        XMonad.Util.Rectangle+                        XMonad.Util.RemoteWindows                         XMonad.Util.Replace                         XMonad.Util.Run                         XMonad.Util.Scratchpad+                        XMonad.Util.SessionStart+                        XMonad.Util.SpawnNamedPipe                         XMonad.Util.SpawnOnce                         XMonad.Util.Stack+                        XMonad.Util.StickyWindows                         XMonad.Util.StringProp                         XMonad.Util.Themes                         XMonad.Util.Timer+                        XMonad.Util.TreeZipper                         XMonad.Util.Types+                        XMonad.Util.Ungrab                         XMonad.Util.WindowProperties+                        XMonad.Util.WindowState                         XMonad.Util.WorkspaceCompare                         XMonad.Util.XSelection                         XMonad.Util.XUtils++test-suite tests+  type:           exitcode-stdio-1.0+  main-is:        Main.hs+  other-modules:  CycleRecentWS+                  EZConfig+                  ExtensibleConf+                  GridSelect+                  Instances+                  ManageDocks+                  NoBorders+                  OrgMode+                  RotateSome+                  Selective+                  SwapWorkspaces+                  WindowNavigation+                  Utils+                  XMonad.Actions.CopyWindow+                  XMonad.Actions.CycleRecentWS+                  XMonad.Actions.CycleWS+                  XMonad.Actions.FocusNth+                  XMonad.Actions.GridSelect+                  XMonad.Actions.PhysicalScreens+                  XMonad.Actions.Repeatable+                  XMonad.Actions.RotateSome+                  XMonad.Actions.Submap+                  XMonad.Actions.SwapWorkspaces+                  XMonad.Actions.TagWindows+                  XMonad.Actions.WindowBringer+                  XMonad.Actions.WindowGo+                  XMonad.Actions.WindowNavigation+                  XMonad.Hooks.ManageDocks+                  XMonad.Hooks.ManageHelpers+                  XMonad.Hooks.UrgencyHook+                  XMonad.Hooks.WorkspaceHistory+                  XMonad.Hooks.StatusBar.PP+                  XMonad.Layout.Decoration+                  XMonad.Layout.LayoutModifier+                  XMonad.Layout.LimitWindows+                  XMonad.Layout.NoBorders+                  XMonad.Layout.WindowArranger+                  XMonad.Prelude+                  XMonad.Prompt+                  XMonad.Prompt.OrgMode+                  XMonad.Prompt.Shell+                  XMonad.Util.Dmenu+                  XMonad.Util.Dzen+                  XMonad.Util.EZConfig+                  XMonad.Util.ExtensibleConf+                  XMonad.Util.ExtensibleState+                  XMonad.Util.Font+                  XMonad.Util.Image+                  XMonad.Util.Invisible+                  XMonad.Util.NamedActions+                  XMonad.Util.NamedWindows+                  XMonad.Util.Parser+                  XMonad.Util.Process+                  XMonad.Util.PureX+                  XMonad.Util.Rectangle+                  XMonad.Util.Run+                  XMonad.Util.Stack+                  XMonad.Util.Timer+                  XMonad.Util.Types+                  XMonad.Util.WindowProperties+                  XMonad.Util.WorkspaceCompare+                  XMonad.Util.XSelection+                  XMonad.Util.XUtils+                  XPrompt+  hs-source-dirs: tests, .+  build-depends: base >= 4.12 && < 5+               , QuickCheck >= 2+               , X11 >= 1.10 && < 1.11+               , bytestring >= 0.10 && < 0.13+               , containers+               , directory+               , time >= 1.8 && < 1.16+               , hspec >= 2.4.0 && < 3+               , mtl+               , random+               , process+               , unix+               , utf8-string+               , deepseq+               , xmonad >= 0.16.9999 && < 0.19+  cpp-options: -DTESTING+  ghc-options: -Wall -Wno-unused-do-bind+  default-language: Haskell2010++  if flag(pedantic)+     ghc-options: -Werror -Wwarn=deprecations+     if impl(ghc >= 9.10)+       ghc-options: -Wno-incomplete-record-selectors++  -- Keep this in sync with the oldest version in 'tested-with'+  if impl(ghc > 8.8.4)+     -- don't treat unused-imports warning as errors, they may be necessary+     -- for compatibility with older versions of base (or other deps)+     ghc-options: -Wwarn=unused-imports++  if impl(ghc > 9.8)+    ghc-options:   -Wno-x-partial