From 4866f2e367dfcf22a9591231ba40948826a1b438 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Thu, 1 Nov 2007 21:10:59 +0100 Subject: Hierarchify darcs-hash:20071101201059-a5988-fc1f1262bec1b69e13ba18ae7cefeafc8c4471d4.gz --- XMonad/Actions/Commands.hs | 114 ++++++ XMonad/Actions/ConstrainedResize.hs | 58 +++ XMonad/Actions/CopyWindow.hs | 79 ++++ XMonad/Actions/CycleWS.hs | 102 ++++++ XMonad/Actions/DeManage.hs | 58 +++ XMonad/Actions/DwmPromote.hs | 47 +++ XMonad/Actions/DynamicWorkspaces.hs | 107 ++++++ XMonad/Actions/FindEmptyWorkspace.hs | 72 ++++ XMonad/Actions/FlexibleManipulate.hs | 122 +++++++ XMonad/Actions/FlexibleResize.hs | 67 ++++ XMonad/Actions/FloatKeys.hs | 112 ++++++ XMonad/Actions/FocusNth.hs | 48 +++ XMonad/Actions/MouseGestures.hs | 116 ++++++ XMonad/Actions/RotSlaves.hs | 60 +++ XMonad/Actions/RotView.hs | 53 +++ XMonad/Actions/SimpleDate.hs | 39 ++ XMonad/Actions/SinkAll.hs | 36 ++ XMonad/Actions/Submap.hs | 71 ++++ XMonad/Actions/SwapWorkspaces.hs | 55 +++ XMonad/Actions/TagWindows.hs | 205 +++++++++++ XMonad/Actions/Warp.hs | 74 ++++ XMonad/Actions/WindowBringer.hs | 84 +++++ XMonad/Actions/WmiiActions.hs | 102 ++++++ XMonad/Hooks/DynamicLog.hs | 211 +++++++++++ XMonad/Hooks/EwmhDesktops | 130 +++++++ XMonad/Hooks/ManageDocks.hs | 153 ++++++++ XMonad/Hooks/SetWMName.hs | 114 ++++++ XMonad/Hooks/UrgencyHook.hs | 134 +++++++ XMonad/Hooks/XPropManage.hs | 91 +++++ XMonad/Layout/Accordion.hs | 50 +++ XMonad/Layout/Circle.hs | 70 ++++ XMonad/Layout/Combo.hs | 139 +++++++ XMonad/Layout/Dishes.hs | 57 +++ XMonad/Layout/DragPane.hs | 137 +++++++ XMonad/Layout/Grid.hs | 65 ++++ XMonad/Layout/HintedTile.hs | 98 +++++ XMonad/Layout/LayoutCombinators.hs | 128 +++++++ XMonad/Layout/LayoutHints.hs | 57 +++ XMonad/Layout/LayoutModifier.hs | 69 ++++ XMonad/Layout/LayoutScreens.hs | 84 +++++ XMonad/Layout/MagicFocus.hs | 51 +++ XMonad/Layout/Magnifier.hs | 69 ++++ XMonad/Layout/Maximize.hs | 73 ++++ XMonad/Layout/Mosaic.hs | 407 +++++++++++++++++++++ XMonad/Layout/MosaicAlt.hs | 163 +++++++++ XMonad/Layout/NoBorders.hs | 106 ++++++ XMonad/Layout/ResizableTile.hs | 93 +++++ XMonad/Layout/Roledex.hs | 70 ++++ XMonad/Layout/Spiral.hs | 112 ++++++ XMonad/Layout/Square.hs | 56 +++ XMonad/Layout/SwitchTrans.hs | 194 ++++++++++ XMonad/Layout/Tabbed.hs | 214 +++++++++++ XMonad/Layout/ThreeColumns.hs | 80 ++++ XMonad/Layout/TilePrime.hs | 104 ++++++ XMonad/Layout/ToggleLayouts.hs | 84 +++++ XMonad/Layout/TwoPane.hs | 61 ++++ XMonad/Layout/WindowNavigation.hs | 214 +++++++++++ XMonad/Layout/WorkspaceDir.hs | 78 ++++ XMonad/Prompt.hs | 686 +++++++++++++++++++++++++++++++++++ XMonad/Prompt/Directory.hs | 43 +++ XMonad/Prompt/Man.hs | 107 ++++++ XMonad/Prompt/Shell.hs | 127 +++++++ XMonad/Prompt/Ssh.hs | 104 ++++++ XMonad/Prompt/Window.hs | 89 +++++ XMonad/Prompt/Workspace.hs | 45 +++ XMonad/Prompt/XMonad.hs | 54 +++ XMonad/Util/Anneal.hs | 90 +++++ XMonad/Util/Dmenu.hs | 49 +++ XMonad/Util/Dzen.hs | 71 ++++ XMonad/Util/Invisible.hs | 45 +++ XMonad/Util/NamedWindows.hs | 57 +++ XMonad/Util/Run.hs | 114 ++++++ XMonad/Util/XSelection.hs | 175 +++++++++ XMonad/Util/XUtils.hs | 191 ++++++++++ 74 files changed, 7944 insertions(+) create mode 100644 XMonad/Actions/Commands.hs create mode 100644 XMonad/Actions/ConstrainedResize.hs create mode 100644 XMonad/Actions/CopyWindow.hs create mode 100644 XMonad/Actions/CycleWS.hs create mode 100644 XMonad/Actions/DeManage.hs create mode 100644 XMonad/Actions/DwmPromote.hs create mode 100644 XMonad/Actions/DynamicWorkspaces.hs create mode 100644 XMonad/Actions/FindEmptyWorkspace.hs create mode 100644 XMonad/Actions/FlexibleManipulate.hs create mode 100644 XMonad/Actions/FlexibleResize.hs create mode 100644 XMonad/Actions/FloatKeys.hs create mode 100644 XMonad/Actions/FocusNth.hs create mode 100644 XMonad/Actions/MouseGestures.hs create mode 100644 XMonad/Actions/RotSlaves.hs create mode 100644 XMonad/Actions/RotView.hs create mode 100644 XMonad/Actions/SimpleDate.hs create mode 100644 XMonad/Actions/SinkAll.hs create mode 100644 XMonad/Actions/Submap.hs create mode 100644 XMonad/Actions/SwapWorkspaces.hs create mode 100644 XMonad/Actions/TagWindows.hs create mode 100644 XMonad/Actions/Warp.hs create mode 100644 XMonad/Actions/WindowBringer.hs create mode 100644 XMonad/Actions/WmiiActions.hs create mode 100644 XMonad/Hooks/DynamicLog.hs create mode 100644 XMonad/Hooks/EwmhDesktops create mode 100644 XMonad/Hooks/ManageDocks.hs create mode 100644 XMonad/Hooks/SetWMName.hs create mode 100644 XMonad/Hooks/UrgencyHook.hs create mode 100644 XMonad/Hooks/XPropManage.hs create mode 100644 XMonad/Layout/Accordion.hs create mode 100644 XMonad/Layout/Circle.hs create mode 100644 XMonad/Layout/Combo.hs create mode 100644 XMonad/Layout/Dishes.hs create mode 100644 XMonad/Layout/DragPane.hs create mode 100644 XMonad/Layout/Grid.hs create mode 100644 XMonad/Layout/HintedTile.hs create mode 100644 XMonad/Layout/LayoutCombinators.hs create mode 100644 XMonad/Layout/LayoutHints.hs create mode 100644 XMonad/Layout/LayoutModifier.hs create mode 100644 XMonad/Layout/LayoutScreens.hs create mode 100644 XMonad/Layout/MagicFocus.hs create mode 100644 XMonad/Layout/Magnifier.hs create mode 100644 XMonad/Layout/Maximize.hs create mode 100644 XMonad/Layout/Mosaic.hs create mode 100644 XMonad/Layout/MosaicAlt.hs create mode 100644 XMonad/Layout/NoBorders.hs create mode 100644 XMonad/Layout/ResizableTile.hs create mode 100644 XMonad/Layout/Roledex.hs create mode 100644 XMonad/Layout/Spiral.hs create mode 100644 XMonad/Layout/Square.hs create mode 100644 XMonad/Layout/SwitchTrans.hs create mode 100644 XMonad/Layout/Tabbed.hs create mode 100644 XMonad/Layout/ThreeColumns.hs create mode 100644 XMonad/Layout/TilePrime.hs create mode 100644 XMonad/Layout/ToggleLayouts.hs create mode 100644 XMonad/Layout/TwoPane.hs create mode 100644 XMonad/Layout/WindowNavigation.hs create mode 100644 XMonad/Layout/WorkspaceDir.hs create mode 100644 XMonad/Prompt.hs create mode 100644 XMonad/Prompt/Directory.hs create mode 100644 XMonad/Prompt/Man.hs create mode 100644 XMonad/Prompt/Shell.hs create mode 100644 XMonad/Prompt/Ssh.hs create mode 100644 XMonad/Prompt/Window.hs create mode 100644 XMonad/Prompt/Workspace.hs create mode 100644 XMonad/Prompt/XMonad.hs create mode 100644 XMonad/Util/Anneal.hs create mode 100644 XMonad/Util/Dmenu.hs create mode 100644 XMonad/Util/Dzen.hs create mode 100644 XMonad/Util/Invisible.hs create mode 100644 XMonad/Util/NamedWindows.hs create mode 100644 XMonad/Util/Run.hs create mode 100644 XMonad/Util/XSelection.hs create mode 100644 XMonad/Util/XUtils.hs (limited to 'XMonad') diff --git a/XMonad/Actions/Commands.hs b/XMonad/Actions/Commands.hs new file mode 100644 index 0000000..eaf6624 --- /dev/null +++ b/XMonad/Actions/Commands.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.Commands +-- Copyright : (c) David Glasser 2007 +-- License : BSD3 +-- +-- Maintainer : glasser@mit.edu +-- Stability : stable +-- Portability : portable +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.Commands ( + -- * Usage + -- $usage + commandMap, + runCommand, + runCommand', + workspaceCommands, + screenCommands, + defaultCommands + ) where + +import XMonad +import XMonad.Operations +import XMonad.StackSet hiding (workspaces) +import XMonad.Util.Dmenu (dmenu) +import XMonad.Layouts + +import Control.Monad.Reader +import qualified Data.Map as M +import System.Exit +import Data.Maybe + +-- $usage +-- +-- To use, modify your Config.hs to: +-- +-- > import XMonad.Actions.Commands +-- +-- and add a keybinding to the runCommand action: +-- +-- > , ((modMask .|. controlMask, xK_y), runCommand commands) +-- +-- and define the list commands: +-- +-- > commands :: [(String, X ())] +-- > commands = defaultCommands +-- +-- A popup menu of internal xmonad commands will appear. You can +-- change the commands by changing the contents of the list +-- 'commands'. (If you like it enough, you may even want to get rid +-- of many of your other key bindings!) + +-- %def commands :: [(String, X ())] +-- %def commands = defaultCommands +-- %import XMonad.Actions.Commands +-- %keybind , ((modMask .|. controlMask, xK_y), runCommand commands) + +commandMap :: [(String, X ())] -> M.Map String (X ()) +commandMap c = M.fromList c + +workspaceCommands :: X [(String, X ())] +workspaceCommands = asks (workspaces . config) >>= \spaces -> return + [((m ++ show i), windows $ f i) + | i <- spaces + , (f, m) <- [(view, "view"), (shift, "shift")] ] + +screenCommands :: [(String, X ())] +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-")] + ] + +defaultCommands :: X [(String, X ())] +defaultCommands = do + wscmds <- workspaceCommands + return $ wscmds ++ screenCommands ++ otherCommands + where + sr = broadcastMessage ReleaseResources + otherCommands = + [ ("shrink" , sendMessage Shrink ) + , ("expand" , sendMessage Expand ) + , ("next-layout" , sendMessage NextLayout ) + , ("default-layout" , asks (layoutHook . config) >>= setLayout ) + , ("restart-wm" , sr >> restart Nothing True ) + , ("restart-wm-no-resume", sr >> restart Nothing False ) + , ("xterm" , spawn =<< asks (terminal . config) ) + , ("run" , spawn "exe=`dmenu_path | dmenu -b` && exec $exe" ) + , ("kill" , kill ) + , ("refresh" , refresh ) + , ("focus-up" , windows $ focusUp ) + , ("focus-down" , windows $ focusDown ) + , ("swap-up" , windows $ swapUp ) + , ("swap-down" , windows $ swapDown ) + , ("swap-master" , windows $ swapMaster ) + , ("sink" , withFocused $ windows . sink ) + , ("quit-wm" , io $ exitWith ExitSuccess ) + ] + +runCommand :: [(String, X ())] -> X () +runCommand cl = do + let m = commandMap cl + choice <- dmenu (M.keys m) + fromMaybe (return ()) (M.lookup choice m) + +runCommand' :: String -> X () +runCommand' c = do + m <- fmap commandMap defaultCommands + fromMaybe (return ()) (M.lookup c m) diff --git a/XMonad/Actions/ConstrainedResize.hs b/XMonad/Actions/ConstrainedResize.hs new file mode 100644 index 0000000..cb49d0a --- /dev/null +++ b/XMonad/Actions/ConstrainedResize.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.ConstrainedResize +-- Copyright : (c) Dougal Stanton +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- Lets you constrain the aspect ratio of a floating +-- window by holding shift while you resize. +-- +-- Useful for making a nice circular XClock window. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.ConstrainedResize ( + -- * Usage + -- $usage + XMonad.Actions.ConstrainedResize.mouseResizeWindow +) where + +import XMonad +import XMonad.Operations +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +-- $usage +-- Put something like this in your Config.hs file: +-- +-- > import qualified XMonad.Actions.ConstrainedResize as Sqr +-- > mouseBindings = M.fromList +-- > [ ... +-- > , ((modMask, button3), (\w -> focus w >> Sqr.mouseResizeWindow w False)) +-- > , ((modMask .|. shiftMask, button3), (\w -> focus w >> Sqr.mouseResizeWindow w True )) ] +-- +-- The line without the shiftMask replaces the standard mouse resize function call, so it's +-- not completely necessary but seems neater this way. + +-- %import qualified XMonad.Actions.ConstrainedResize as Sqr +-- %mousebind , ((modMask, button3), (\\w -> focus w >> Sqr.mouseResizeWindow w False)) +-- %mousebind , ((modMask .|. shiftMask, button3), (\\w -> focus w >> Sqr.mouseResizeWindow w True)) + +-- | 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 + 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 + let x = ex - fromIntegral (wa_x wa) + y = ey - fromIntegral (wa_y wa) + sz = if c then (max x y, max x y) else (x,y) + io $ resizeWindow d w `uncurry` + applySizeHints sh sz) + (float w) diff --git a/XMonad/Actions/CopyWindow.hs b/XMonad/Actions/CopyWindow.hs new file mode 100644 index 0000000..cb6a619 --- /dev/null +++ b/XMonad/Actions/CopyWindow.hs @@ -0,0 +1,79 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.CopyWindow +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- Provides a binding to duplicate a window on multiple workspaces, +-- providing dwm-like tagging functionality. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.CopyWindow ( + -- * Usage + -- $usage + copy, kill1 + ) where + +import Prelude hiding ( filter ) +import Control.Monad.State ( gets ) +import qualified Data.List as L +import XMonad +import XMonad.Operations ( windows, kill ) +import XMonad.StackSet + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Actions.CopyWindow +-- +-- > -- mod-[1..9] @@ Switch to workspace N +-- > -- mod-shift-[1..9] @@ Move client to workspace N +-- > -- mod-control-shift-[1..9] @@ Copy client to workspace N +-- > [((m .|. modMask, k), f i) +-- > | (i, k) <- zip workspaces [xK_1 ..] +-- > , (f, m) <- [(view, 0), (shift, shiftMask), (copy, shiftMask .|. controlMask)]] +-- +-- you may also wish to redefine the binding to kill a window so it only +-- removes it from the current workspace, if it's present elsewhere: +-- +-- > , ((modMask .|. shiftMask, xK_c ), kill1) -- @@ Close the focused window + +-- %import XMonad.Actions.CopyWindow +-- %keybind -- comment out default close window binding above if you uncomment this: +-- %keybind , ((modMask .|. shiftMask, xK_c ), kill1) -- @@ Close the focused window +-- %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 workspaces [xK_1 ..] +-- %keybindlist , (f, m) <- [(view, 0), (shift, shiftMask), (copy, shiftMask .|. controlMask)]] + +-- | copy. Copy a window to a new workspace. +copy :: WorkspaceId -> WindowSet -> WindowSet +copy n = copy' + where copy' s = if n `tagMember` s && n /= tag (workspace (current s)) + then maybe s (go s) (peek s) + else s + go s w = view (tag (workspace (current s))) $ insertUp' w $ view n s + insertUp' a s = modify (Just $ Stack a [] []) + (\(Stack t l r) -> Just $ Stack a (L.delete a l) (L.delete a (t:r))) s + +-- | Remove the focussed window from this workspace. If it's present in no +-- other workspace, then kill it instead. If we do kill it, we'll get a +-- delete notify back from X. +-- +-- There are two ways to delete a window. Either just kill it, or if it +-- supports the delete protocol, send a delete event (e.g. firefox) +-- +kill1 :: X () +kill1 = do ss <- gets windowset + whenJust (peek ss) $ \w -> if member w $ delete'' w ss + then windows $ delete'' w + else kill + where delete'' w = modify Nothing (filter (/= w)) diff --git a/XMonad/Actions/CycleWS.hs b/XMonad/Actions/CycleWS.hs new file mode 100644 index 0000000..6e854bc --- /dev/null +++ b/XMonad/Actions/CycleWS.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.CycleWS +-- Copyright : (c) Joachim Breitner , +-- Nelson Elhage (`toggleWS' function) +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Joachim Breitner +-- Stability : unstable +-- Portability : unportable +-- +-- Provides bindings to cycle forward or backward through the list +-- of workspaces, and to move windows there. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.CycleWS ( + -- * Usage + -- $usage + nextWS, + prevWS, + shiftToNext, + shiftToPrev, + toggleWS, + ) where + +import Control.Monad.Reader ( asks ) +import Control.Monad.State ( gets ) +import Data.List ( sortBy, findIndex ) +import Data.Maybe ( fromMaybe ) +import Data.Ord ( comparing ) + +import XMonad hiding (workspaces) +import qualified XMonad (workspaces) +import XMonad.StackSet hiding (filter) +import XMonad.Operations + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Actions.CycleWS +-- +-- > , ((modMask, xK_Right), nextWS) +-- > , ((modMask, xK_Left), prevWS) +-- > , ((modMask .|. shiftMask, xK_Right), shiftToNext) +-- > , ((modMask .|. shiftMask, xK_Left), shiftToPrev) +-- > , ((modMask, xK_t), toggleWS) +-- +-- If you want to follow the moved window, you can use both actions: +-- +-- > , ((modMask .|. shiftMask, xK_Right), shiftToNext >> nextWS) +-- > , ((modMask .|. shiftMask, xK_Left), shiftToPrev >> prevWS) +-- + +-- %import XMonad.Actions.CycleWS +-- %keybind , ((modMask, xK_Right), nextWS) +-- %keybind , ((modMask, xK_Left), prevWS) +-- %keybind , ((modMask .|. shiftMask, xK_Right), shiftToNext) +-- %keybind , ((modMask .|. shiftMask, xK_Left), shiftToPrev) +-- %keybind , ((modMask, xK_t), toggleWS) + + +-- | Switch to next workspace +nextWS :: X () +nextWS = switchWorkspace 1 + +-- | Switch to previous workspace +prevWS :: X () +prevWS = switchWorkspace (-1) + +-- | Move focused window to next workspace +shiftToNext :: X () +shiftToNext = shiftBy 1 + +-- | Move focused window to previous workspace +shiftToPrev :: X () +shiftToPrev = shiftBy (-1) + +-- | Toggle to the workspace displayed previously +toggleWS :: X () +toggleWS = windows $ view =<< tag . head . hidden + +switchWorkspace :: Int -> X () +switchWorkspace d = wsBy d >>= windows . greedyView + +shiftBy :: Int -> X () +shiftBy d = wsBy d >>= windows . shift + +wsBy :: Int -> X (WorkspaceId) +wsBy d = do + ws <- gets windowset + spaces <- asks (XMonad.workspaces . config) + let orderedWs = sortBy (comparing (wsIndex spaces)) (workspaces ws) + let now = fromMaybe 0 $ findWsIndex (workspace (current ws)) orderedWs + let next = orderedWs !! ((now + d) `mod` length orderedWs) + return $ tag next + +wsIndex :: [WorkspaceId] -> WindowSpace -> Maybe Int +wsIndex spaces ws = findIndex (== tag ws) spaces + +findWsIndex :: WindowSpace -> [WindowSpace] -> Maybe Int +findWsIndex ws wss = findIndex ((== tag ws) . tag) wss diff --git a/XMonad/Actions/DeManage.hs b/XMonad/Actions/DeManage.hs new file mode 100644 index 0000000..9bff48a --- /dev/null +++ b/XMonad/Actions/DeManage.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.DeManage +-- Copyright : (c) Spencer Janssen +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen +-- Stability : unstable +-- Portability : unportable +-- +-- This module provides a method to cease management of a window, without +-- unmapping it. This is especially useful for applications like kicker and +-- gnome-panel. +-- +-- To make a panel display correctly with xmonad: +-- +-- * Determine the pixel size of the panel, add that value to defaultGaps +-- +-- * Launch the panel +-- +-- * Give the panel window focus, then press mod-d +-- +-- * Convince the panel to move\/resize to the correct location. Changing the +-- panel's position setting several times seems to work. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.DeManage ( + -- * Usage + -- $usage + demanage + ) where + +import qualified XMonad.StackSet as W +import XMonad +import XMonad.Operations +import Control.Monad.State +import Graphics.X11 (Window) + +-- $usage +-- To use demanage, add this import: +-- +-- > import XMonad.Actions.DeManage +-- +-- And add a keybinding to it: +-- +-- > , ((modMask, xK_d ), withFocused demanage) +-- + +-- %import XMonad.Actions.DeManage +-- %keybind , ((modMask, xK_d ), withFocused demanage) + +-- | Stop managing the current focused window. +demanage :: Window -> X () +demanage w = do + -- use modify to defeat automatic 'unmanage' calls. + modify (\s -> s { windowset = W.delete w (windowset s) }) + refresh diff --git a/XMonad/Actions/DwmPromote.hs b/XMonad/Actions/DwmPromote.hs new file mode 100644 index 0000000..dfe7cc6 --- /dev/null +++ b/XMonad/Actions/DwmPromote.hs @@ -0,0 +1,47 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.DwmPromote +-- Copyright : (c) Miikka Koskinen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : arcatan@kapsi.fi +-- Stability : unstable +-- Portability : unportable +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.DwmPromote ( + -- * Usage + -- $usage + dwmpromote + ) where + +import XMonad +import XMonad.Operations (windows) +import XMonad.StackSet + +-- $usage +-- +-- To use, modify your Config.hs to: +-- +-- > import XMonad.Actions.DwmPromote +-- +-- and add a keybinding or substitute promote with dwmpromote: +-- +-- > , ((modMask, xK_Return), dwmpromote) + +-- %import XMonad.Actions.DwmPromote +-- %keybind , ((modMask, xK_Return), dwmpromote) + +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 diff --git a/XMonad/Actions/DynamicWorkspaces.hs b/XMonad/Actions/DynamicWorkspaces.hs new file mode 100644 index 0000000..6aa3fb9 --- /dev/null +++ b/XMonad/Actions/DynamicWorkspaces.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.DynamicWorkspaces +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- Provides bindings to add and delete workspaces. Note that you may only +-- delete a workspace that is already empty. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.DynamicWorkspaces ( + -- * Usage + -- $usage + addWorkspace, removeWorkspace, + selectWorkspace, renameWorkspace, + toNthWorkspace, withNthWorkspace + ) where + +import Control.Monad.State ( gets ) +import Data.List ( sort ) + +import XMonad ( X, XState(..), Layout, WorkspaceId, WindowSet ) +import XMonad.Operations +import XMonad.StackSet hiding (filter, modify, delete) +import Graphics.X11.Xlib ( Window ) +import XMonad.Prompt.Workspace +import XMonad.Prompt ( XPConfig ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Actions.DynamicWorkspaces +-- +-- > , ((modMask .|. shiftMask, xK_n), selectWorkspace defaultXPConfig layoutHook) +-- > , ((modMask .|. shiftMask, xK_BackSpace), removeWorkspace) +-- > , ((modMask .|. shiftMask .|. controlMask, xK_r), renameWorkspace defaultXPConfig) +-- +-- > -- mod-[1..9] %! Switch to workspace N +-- > -- mod-shift-[1..9] %! Move client to workspace N +-- > ++ +-- > zip (zip (repeat modMask) [xK_1..xK_9]) (map (withNthWorkspace W.greedyView) [0..]) +-- > ++ +-- > zip (zip (repeat (modMask .|. shiftMask)) [xK_1..xK_9]) (map (withNthWorkspace W.shift) [0..]) + +allPossibleTags :: [WorkspaceId] +allPossibleTags = map (:"") ['0'..] + +renameWorkspace :: XPConfig -> X () +renameWorkspace conf = workspacePrompt conf $ \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 + +toNthWorkspace :: (String -> X ()) -> Int -> X () +toNthWorkspace job wnum = do ws <- gets (sort . map tag . workspaces . windowset) + case drop wnum ws of + (w:_) -> job w + [] -> return () + +withNthWorkspace :: (String -> WindowSet -> WindowSet) -> Int -> X () +withNthWorkspace job wnum = do ws <- gets (sort . map tag . workspaces . windowset) + case drop wnum ws of + (w:_) -> windows $ job w + [] -> return () + +selectWorkspace :: XPConfig -> Layout Window -> X () +selectWorkspace conf l = workspacePrompt conf $ \w -> + windows $ \s -> if tagMember w s + then greedyView w s + else addWorkspace' w l s + +addWorkspace :: Layout Window -> X () +addWorkspace l = do s <- gets windowset + let newtag:_ = filter (not . (`tagMember` s)) allPossibleTags + windows (addWorkspace' newtag l) + +removeWorkspace :: X () +removeWorkspace = do s <- gets windowset + case s of + StackSet { current = Screen { workspace = torem } + , hidden = (w:_) } + -> do windows $ view (tag w) + windows (removeWorkspace' (tag torem)) + _ -> return () + +addWorkspace' :: i -> l -> StackSet i l a sid sd -> StackSet i l a sid sd +addWorkspace' newtag l s@(StackSet { current = scr@(Screen { workspace = w }) + , hidden = ws }) + = s { current = scr { workspace = Workspace newtag l Nothing } + , hidden = w: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 } + 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 diff --git a/XMonad/Actions/FindEmptyWorkspace.hs b/XMonad/Actions/FindEmptyWorkspace.hs new file mode 100644 index 0000000..a0fb621 --- /dev/null +++ b/XMonad/Actions/FindEmptyWorkspace.hs @@ -0,0 +1,72 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.FindEmptyWorkspace +-- Copyright : (c) Miikka Koskinen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : arcatan@kapsi.fi +-- Stability : unstable +-- Portability : unportable +-- +-- Find an empty workspace in XMonad. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.FindEmptyWorkspace ( + -- * Usage + -- $usage + viewEmptyWorkspace, tagToEmptyWorkspace + ) where + +import Control.Monad.State +import Data.List +import Data.Maybe ( isNothing ) + +import XMonad +import XMonad.StackSet + +import XMonad.Operations + +-- $usage +-- +-- To use, modify your Config.hs to: +-- +-- > import XMonad.Actions.FindEmptyWorkspace +-- +-- and add a keybinding: +-- +-- > , ((modMask, xK_m ), viewEmptyWorkspace) +-- > , ((modMask .|. shiftMask, xK_m ), tagToEmptyWorkspace) +-- +-- Now you can jump to an empty workspace with mod-m. Mod-shift-m will +-- tag the current window to an empty workspace and view it. + +-- %import XMonad.Actions.FindEmptyWorkspace +-- %keybind , ((modMask, xK_m ), viewEmptyWorkspace) +-- %keybind , ((modMask .|. shiftMask, xK_m ), tagToEmptyWorkspace) + + +-- | Find the first hidden empty workspace in a StackSet. Returns +-- Nothing if all workspaces are in use. Function searches currently +-- focused workspace, other visible workspaces (when in Xinerama) and +-- hidden workspaces in this order. +findEmptyWorkspace :: StackSet i l a s sd -> Maybe (Workspace i l a) +findEmptyWorkspace = find (isNothing . stack) . allWorkspaces + where + allWorkspaces ss = (workspace . current) ss : + (map workspace . visible) ss ++ hidden ss + +withEmptyWorkspace :: (WorkspaceId -> X ()) -> X () +withEmptyWorkspace f = do + ws <- gets windowset + whenJust (findEmptyWorkspace ws) (f . tag) + +-- | Find and view an empty workspace. Do nothing if all workspaces are +-- in use. +viewEmptyWorkspace :: X () +viewEmptyWorkspace = withEmptyWorkspace (windows . view) + +-- | Tag current window to an empty workspace and view it. Do nothing if +-- all workspaces are in use. +tagToEmptyWorkspace :: X () +tagToEmptyWorkspace = withEmptyWorkspace $ \w -> windows $ view w . shift w diff --git a/XMonad/Actions/FlexibleManipulate.hs b/XMonad/Actions/FlexibleManipulate.hs new file mode 100644 index 0000000..b7fa25d --- /dev/null +++ b/XMonad/Actions/FlexibleManipulate.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.FlexibleManipulate +-- Copyright : (c) Michael Sloan +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- Lets you move and resize floating windows without warping the mouse. +-- +----------------------------------------------------------------------------- + +-- Based on the FlexibleResize code by Lukas Mai (Mauke) + +module XMonad.Actions.FlexibleManipulate ( + -- * Usage + -- $usage + mouseWindow, discrete, linear, resize, position +) where + +import XMonad +import XMonad.Operations +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +-- $usage +-- Add this import to your Config.hs file: +-- +-- > import qualified XMonad.Actions.FlexibleManipulate as Flex +-- +-- Set one of the mouse button bindings up like this: +-- +-- > mouseBindings = M.fromList +-- > [ ((modMask, button1), (\w -> focus w >> Flex.mouseWindow Flex.linear w)) ], ... +-- +-- Flex.linear indicates that positions between the edges and the middle +-- indicate a combination scale\/position. +-- Flex.discrete indicates that there are discrete pick regions. (window +-- is divided by thirds for each axis) +-- Flex.resize performs only resize of the window, based on which quadrant +-- the mouse is in +-- Flex.position is similar to the built-in mouseMoveWindow +-- +-- You can also write your own function for this parameter. It should take +-- a value between 0 and 1 indicating position, and return a value indicating +-- the corresponding position if plain Flex.linear was used. + +-- %import qualified XMonad.Actions.FlexibleManipulate as Flex +-- %mousebind , ((modMask, button1), (\\w -> focus w >> Flex.mouseWindow Flex.linear w)) + +discrete, linear, resize, position :: Double -> Double + +discrete x | x < 0.33 = 0 + | x > 0.66 = 1 + | otherwise = 0.5 + +linear = id + +resize x = if x < 0.5 then 0 else 1 +position = const 0.5 + +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 + sh <- io $ getWMNormalHints d w + pointer <- io $ queryPointer d w >>= return . pointerPos + + let uv = (pointer - wpos) / wsize + fc = mapP f uv + mul = mapP (\x -> 2 - 2 * abs(x - 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 + 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 = applySizeHints sh $ mapP (round :: Double -> Integer) (nbr - ntl) + moveResizeWindow d w (round $ fst ntl) (round $ snd ntl) `uncurry` nwidth + return ()) + (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) +zipP f (ax,ay) (bx,by) = (f ax bx, f ay by) + +minP :: Ord a => (a,a) -> (a,a) -> (a,a) +minP = zipP min + +instance Num Pnt where + (+) = zipP (+) + (-) = zipP (-) + (*) = zipP (*) + abs = mapP abs + signum = mapP signum + fromInteger = const undefined + +instance Fractional Pnt where + fromRational = const undefined + recip = mapP recip diff --git a/XMonad/Actions/FlexibleResize.hs b/XMonad/Actions/FlexibleResize.hs new file mode 100644 index 0000000..9f111f7 --- /dev/null +++ b/XMonad/Actions/FlexibleResize.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.FlexibleResize +-- Copyright : (c) Lukas Mai +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- Lets you resize floating windows from any corner. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.FlexibleResize ( + -- * Usage + -- $usage + XMonad.Actions.FlexibleResize.mouseResizeWindow +) where + +import XMonad +import XMonad.Operations +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Foreign.C.Types + +-- $usage +-- Put something like this in your Config.hs file: +-- +-- > import qualified XMonad.Actions.FlexibleResize as Flex +-- > mouseBindings = M.fromList +-- > [ ... +-- > , ((modMask, button3), (\w -> focus w >> Flex.mouseResizeWindow w)) ] + +-- %import qualified XMonad.Actions.FlexibleResize as Flex +-- %mousebind , ((modMask, button3), (\\w -> focus w >> Flex.mouseResizeWindow w)) + +mouseResizeWindow :: Window -> X () +mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + sh <- io $ getWMNormalHints d w + (_, _, _, _, _, ix, iy, _) <- io $ queryPointer d w + let + [pos_x, pos_y, width, height] = map (fromIntegral . ($ wa)) [wa_x, wa_y, wa_width, wa_height] + west = firstHalf ix width + north = firstHalf 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 + wa' <- io $ getWindowAttributes d w + let [px, py] = map (fromIntegral . ($ wa')) [wa_x, wa_y] + io $ moveResizeWindow d w (fx px (fromIntegral ex)) + (fy py (fromIntegral ey)) + `uncurry` applySizeHints sh (gx $ fromIntegral ex, gy $ fromIntegral ey)) + (float w) + where + firstHalf :: CInt -> Position -> Bool + firstHalf a b = fromIntegral a * 2 <= b + cfst = curry fst + csnd = curry snd + mkSel :: Bool -> Position -> Position -> (Position, a -> a -> a, CInt -> Position) + mkSel b k p = + if b + then (0, csnd, ((k + p) -) . fromIntegral) + else (k, cfst, subtract p . fromIntegral) diff --git a/XMonad/Actions/FloatKeys.hs b/XMonad/Actions/FloatKeys.hs new file mode 100644 index 0000000..52ca90e --- /dev/null +++ b/XMonad/Actions/FloatKeys.hs @@ -0,0 +1,112 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.FloatKeys +-- Copyright : (c) Karsten Schoelzel +-- License : BSD +-- +-- Maintainer : Karsten Schoelzel +-- Stability : unstable +-- Portability : unportable +-- +-- Move and resize floating windows. +----------------------------------------------------------------------------- + +module XMonad.Actions.FloatKeys ( + -- * Usage + -- $usage + keysMoveWindow, + keysMoveWindowTo, + keysResizeWindow, + keysAbsResizeWindow) where + +import XMonad.Operations +import XMonad +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +-- $usage +-- > import XMonad.Actions.FloatKeys +-- +-- > , ((modMask, xK_d ), withFocused (keysResizeWindow (-10,-10) (1,1))) +-- > , ((modMask, xK_s ), withFocused (keysResizeWindow (10,10) (1,1))) +-- > , ((modMask .|. shiftMask, xK_d ), withFocused (keysAbsResizeWindow (-10,-10) (1024,752))) +-- > , ((modMask .|. shiftMask, xK_s ), withFocused (keysAbsResizeWindow (10,10) (1024,752))) +-- > , ((modMask, xK_a ), withFocused (keysMoveWindowTo (512,384) (1%2,1%2))) +-- +-- +-- keysMoveWindow (dx, dy) moves the window by dx pixels to the right and dy pixels down +-- +-- keysMoveWindowTo (x, y) (gx, gy) moves the window relative point (gx, gy) to the point (x,y) +-- where (gx,gy) gives a position relative to the window border, i.e. +-- gx = 0 is the left border and gx = 1 the right border +-- gy = 0 is the top border and gy = 1 the bottom border +-- +-- examples on a 1024x768 screen: keysMoveWindowTo (512,384) (1%2, 1%2) centers the window on screen +-- keysMoveWindowTo (1024,0) (1, 0) puts it into the top right corner +-- +-- keysResizeWindow (dx, dy) (gx, gy) changes the width by dx and the height by dy leaving the window +-- relative point (gx, gy) fixed +-- +-- examples: keysResizeWindow (10, 0) (0, 0) makes the window 10 pixels larger to the right +-- keysResizeWindow (10, 0) (0, 1%2) does the same, unless sizeHints are applied +-- keysResizeWindow (10, 10) (1%2, 1%2) adds 5 pixels on each side +-- keysResizeWindow (-10, -10) (0, 1) shrinks the window in direction of the bottom-left corner +-- +-- keysAbsResizeWindow (dx, dy) (ax, ay) changes the width by dx and the height by dy leaving the screen +-- absolut point (ax, ay) fixed +-- +-- examples on a 1024x768 screen: keysAbsResizeWindow (10, 10) (0, 0) enlarge the window and if it is not in the top-left corner it will also be moved away +-- +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)) + float w + +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))) + float w + +type G = (Rational, Rational) +type P = (Position, Position) + +keysResizeWindow :: D -> G -> Window -> X () +keysResizeWindow = keysMoveResize keysResizeWindow' + +keysAbsResizeWindow :: D -> D -> Window -> X () +keysAbsResizeWindow = keysMoveResize keysAbsResizeWindow' + +keysAbsResizeWindow' :: SizeHints -> P -> D -> D -> D -> (P,D) +keysAbsResizeWindow' sh (x,y) (w,h) (dx,dy) (ax, ay) = ((round nx, round ny), (nw, nh)) + where + (nw, nh) = applySizeHints sh (w + dx, h + dy) + nx :: Rational + nx = fromIntegral (ax * w + nw * (fromIntegral x - ax)) / fromIntegral w + ny :: Rational + ny = fromIntegral (ay * h + nh * (fromIntegral y - ay)) / fromIntegral h + +keysResizeWindow' :: SizeHints -> P -> D -> D -> G -> (P,D) +keysResizeWindow' sh (x,y) (w,h) (dx,dy) (gx, gy) = ((nx, ny), (nw, nh)) + where + (nw, nh) = applySizeHints 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 + +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 + 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) + (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 + diff --git a/XMonad/Actions/FocusNth.hs b/XMonad/Actions/FocusNth.hs new file mode 100644 index 0000000..42336ef --- /dev/null +++ b/XMonad/Actions/FocusNth.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.FocusNth +-- Copyright : (c) Karsten Schoelzel +-- License : BSD +-- +-- Maintainer : Karsten Schoelzel +-- Stability : unstable +-- Portability : unportable +-- +-- Focus the nth window on the screen. +----------------------------------------------------------------------------- + +module XMonad.Actions.FocusNth ( + -- * Usage + -- $usage + focusNth) where + +import XMonad.StackSet +import XMonad.Operations +import XMonad + +-- $usage +-- > import XMonad.Actions.FocusNth + +-- > -- mod4-[1..9] @@ Switch to window N +-- > ++ [((mod4Mask, k), focusNth i) +-- > | (i, k) <- zip [0 .. 8] [xK_1 ..]] + +-- %import XMonad.Actions.FocusNth +-- %keybdindextra ++ +-- %keybdindextra -- mod4-[1..9] @@ Switch to window N +-- %keybdindextra [((mod4Mask, k), focusNth i) +-- %keybdindextra | (i, k) <- zip [0 .. 8] [xK_1 ..]] + +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) + + diff --git a/XMonad/Actions/MouseGestures.hs b/XMonad/Actions/MouseGestures.hs new file mode 100644 index 0000000..32d7e60 --- /dev/null +++ b/XMonad/Actions/MouseGestures.hs @@ -0,0 +1,116 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.MouseGestures +-- Copyright : (c) Lukas Mai +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- Support for simple mouse gestures +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.MouseGestures ( + -- * Usage + -- $usage + Direction(..), + mouseGesture +) where + +import XMonad +import XMonad.Operations +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Control.Monad.Reader +import Data.IORef +import qualified Data.Map as M +import Data.Map (Map) + +import System.IO + +-- $usage +-- In your Config.hs: +-- +-- > import XMonad.Actions.MouseGestures +-- > ... +-- > mouseBindings = M.fromList $ +-- > [ ... +-- > , ((modMask .|. shiftMask, button3), mouseGesture gestures) +-- > ] +-- > where +-- > gestures = M.fromList +-- > [ ([], focus) +-- > , ([U], \w -> focus w >> windows W.swapUp) +-- > , ([D], \w -> focus w >> windows W.swapDown) +-- > , ([R, D], \_ -> sendMessage NextLayout) +-- > ] +-- +-- This is just an example, of course. You can use any mouse button and +-- gesture definitions you want. + +data Direction = L | U | R | D + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +type Pos = (Position, Position) + +delta :: Pos -> Pos -> Position +delta (ax, ay) (bx, by) = max (d ax bx) (d ay by) + where + d a b = abs (a - b) + +dir :: Pos -> Pos -> Direction +dir (ax, ay) (bx, by) = trans . (/ pi) $ atan2 (fromIntegral $ ay - by) (fromIntegral $ bx - ax) + where + trans :: Double -> Direction + trans x + | rg (-3/4) (-1/4) x = D + | rg (-1/4) (1/4) x = R + | rg (1/4) (3/4) x = U + | otherwise = L + rg a z x = a <= x && x < z + +debugging :: Int +debugging = 0 + +collect :: IORef (Pos, [(Direction, Pos, Pos)]) -> Position -> Position -> X () +collect st nx ny = do + let np = (nx, ny) + stx@(op, ds) <- io $ readIORef st + when (debugging > 0) $ io $ putStrLn $ show "Mouse Gesture" ++ unwords (map show (extract stx)) ++ (if debugging > 1 then "; " ++ show op ++ "-" ++ show np else "") + case ds of + [] + | insignificant np op -> return () + | otherwise -> io $ writeIORef st (op, [(dir op np, np, op)]) + (d, zp, ap_) : ds' + | insignificant np zp -> return () + | otherwise -> do + let + d' = dir zp np + ds'' + | d == d' = (d, np, ap_) : ds' + | otherwise = (d', np, zp) : ds + io $ writeIORef st (op, ds'') + where + insignificant a b = delta a b < 10 + +extract :: (Pos, [(Direction, Pos, Pos)]) -> [Direction] +extract (_, xs) = reverse . map (\(x, _, _) -> x) $ xs + +mouseGesture :: Map [Direction] (Window -> X ()) -> Window -> X () +mouseGesture tbl win = withDisplay $ \dpy -> do + root <- asks theRoot + let win' = if win == none then root else win + acc <- io $ do + qp@(_, _, _, ix, iy, _, _, _) <- queryPointer dpy win' + when (debugging > 1) $ putStrLn $ show "queryPointer" ++ show qp + when (debugging > 1 && win' == none) $ putStrLn $ show "mouseGesture" ++ "zomg none" + newIORef ((fromIntegral ix, fromIntegral iy), []) + mouseDrag (collect acc) $ do + when (debugging > 0) $ io $ putStrLn $ show "" + gest <- io $ liftM extract $ readIORef acc + case M.lookup gest tbl of + Nothing -> return () + Just f -> f win' diff --git a/XMonad/Actions/RotSlaves.hs b/XMonad/Actions/RotSlaves.hs new file mode 100644 index 0000000..95ef1f4 --- /dev/null +++ b/XMonad/Actions/RotSlaves.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.RotSlaves +-- Copyright : (c) Hans Philipp Annen , Mischa Dieterle +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Hans Philipp Annen +-- Stability : unstable +-- Portability : unportable +-- +-- Rotate all windows except the master window +-- and keep the focus in place. +----------------------------------------------------------------------------- +module XMonad.Actions.RotSlaves ( + -- $usag + rotSlaves', rotSlavesUp, rotSlavesDown, + rotAll', rotAllUp, rotAllDown + ) where + +import XMonad.StackSet +import XMonad.Operations +import XMonad + +-- $usage +-- +-- To use this module, import it with: +-- +-- > import XMonad.Actions.RotSlaves +-- +-- and add a keybinding: +-- +-- > , ((modMask .|. shiftMask, xK_Tab ), rotSlavesUp) +-- +-- +-- This operation will rotate all windows except the master window, while the focus +-- stays where it is. It is useful together with the TwoPane-Layout (see XMonad.Actions.TwoPane). + +-- %import XMonad.Actions.RotSlaves +-- %keybind , ((modMask .|. shiftMask, xK_Tab ), rotSlavesUp) + +-- | Rotate the windows in the current stack excluding the first one +rotSlavesUp,rotSlavesDown :: X () +rotSlavesUp = windows $ modify' (rotSlaves' (\l -> (tail l)++[head l])) +rotSlavesDown = windows $ modify' (rotSlaves' (\l -> [last l]++(init l))) + +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)) + +-- | Rotate 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))) + +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)) diff --git a/XMonad/Actions/RotView.hs b/XMonad/Actions/RotView.hs new file mode 100644 index 0000000..6d4f8ea --- /dev/null +++ b/XMonad/Actions/RotView.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.RotView +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- Provides bindings to cycle through non-empty workspaces. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.RotView ( + -- * Usage + -- $usage + rotView + ) where + +import Control.Monad.State ( gets ) +import Data.List ( sortBy, find ) +import Data.Maybe ( isJust ) +import Data.Ord ( comparing ) + +import XMonad +import XMonad.StackSet hiding (filter) +import XMonad.Operations + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Actions.RotView +-- +-- > , ((modMask .|. shiftMask, xK_Right), rotView True) +-- > , ((modMask .|. shiftMask, xK_Left), rotView False) + +-- %import XMonad.Actions.RotView +-- %keybind , ((modMask .|. shiftMask, xK_Right), rotView True) +-- %keybind , ((modMask .|. shiftMask, xK_Left), rotView False) + +rotView :: Bool -> X () +rotView forward = do + ws <- gets windowset + let currentTag = tag . workspace . current $ ws + sortWs = sortBy (comparing tag) + isNotEmpty = isJust . stack + sorted = sortWs (hidden ws) + pivoted = let (a,b) = span ((< currentTag) . tag) sorted in b ++ a + pivoted' | forward = pivoted + | otherwise = reverse pivoted + nextws = find isNotEmpty pivoted' + whenJust nextws (windows . view . tag) diff --git a/XMonad/Actions/SimpleDate.hs b/XMonad/Actions/SimpleDate.hs new file mode 100644 index 0000000..a30d78b --- /dev/null +++ b/XMonad/Actions/SimpleDate.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.SimpleDate +-- Copyright : (c) Don Stewart 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : stable +-- Portability : portable +-- +-- An example external contrib module for XMonad. +-- Provides a simple binding to dzen2 to print the date as a popup menu. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.SimpleDate ( + -- * Usage + -- $usage + date + ) where + +import XMonad + +-- $usage +-- To use, modify your Config.hs to: +-- +-- > import XMonad.Actions.SimpleDate +-- +-- and add a keybinding: +-- +-- > , ((modMask, xK_d ), date) +-- +-- a popup date menu will now be bound to mod-d + +-- %import XMonad.Actions.SimpleDate +-- %keybind , ((modMask, xK_d ), date) + +date :: X () +date = spawn "(date; sleep 10) | dzen2" diff --git a/XMonad/Actions/SinkAll.hs b/XMonad/Actions/SinkAll.hs new file mode 100644 index 0000000..c193ad0 --- /dev/null +++ b/XMonad/Actions/SinkAll.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XmonadContrib.SinkAll +-- License : BSD3-style (see LICENSE) +-- Stability : unstable +-- Portability : unportable +-- +-- Provides a simple binding that pushes all floating windows on the current +-- workspace back into tiling. +----------------------------------------------------------------------------- + +module XMonad.Actions.SinkAll ( + -- * Usage + -- $usage + sinkAll) where + +import XMonad.Operations +import XMonad +import XMonad.StackSet + +import Graphics.X11.Xlib + +-- $usage +-- > import XMonad.Actions.SinkAll +-- > keys = [ ((modMask .|. shiftMask, xK_t), sinkAll) ] + +-- %import XMonad.Actions.SinkAll +-- %keybind , ((modMask .|. shiftMask, xK_t), sinkAll) + +sinkAll :: X () +sinkAll = withAll sink + +-- Apply a function to all windows on current workspace. +withAll :: (Window -> WindowSet -> WindowSet) -> X () +withAll f = windows $ \ws -> let all' = integrate' . stack . workspace . current $ ws + in foldr f ws all' diff --git a/XMonad/Actions/Submap.hs b/XMonad/Actions/Submap.hs new file mode 100644 index 0000000..98d44c6 --- /dev/null +++ b/XMonad/Actions/Submap.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.Submap +-- Copyright : (c) Jason Creighton +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Jason Creighton +-- Stability : unstable +-- Portability : unportable +-- +-- A module that allows the user to create a sub-mapping of keys bindings. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.Submap ( + -- * Usage + -- $usage + submap + ) where + +import Control.Monad.Reader + +import XMonad +import XMonad.Operations (cleanMask) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import qualified Data.Map as M + +{- $usage +Allows you to create a sub-mapping of keys. Example: + +> , ((modMask, xK_a), submap . M.fromList $ +> [ ((0, xK_n), spawn "mpc next") +> , ((0, xK_p), spawn "mpc prev") +> , ((0, xK_z), spawn "mpc random") +> , ((0, xK_space), spawn "mpc toggle") +> ]) + +So, for example, to run 'spawn \"mpc next\"', you would hit mod-a (to trigger the +submapping) and then 'n' to run that action. (0 means \"no modifier\"). You are, +of course, free to use any combination of modifiers in the submapping. However, +anyModifier will not work, because that is a special value passed to XGrabKey() +and not an actual modifier. +-} + +-- %import XMonad.Actions.Submap +-- %keybind , ((modMask, xK_a), submap . M.fromList $ +-- %keybind [ ((0, xK_n), spawn "mpc next") +-- %keybind , ((0, xK_p), spawn "mpc prev") +-- %keybind , ((0, xK_z), spawn "mpc random") +-- %keybind , ((0, xK_space), spawn "mpc toggle") +-- %keybind ]) + +submap :: M.Map (KeyMask, KeySym) (X ()) -> X () +submap keys = do + XConf { theRoot = root, display = d } <- ask + + io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime + + (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) + + io $ ungrabKeyboard d currentTime + + m' <- cleanMask m + whenJust (M.lookup (m', s) keys) id diff --git a/XMonad/Actions/SwapWorkspaces.hs b/XMonad/Actions/SwapWorkspaces.hs new file mode 100644 index 0000000..3f0ca35 --- /dev/null +++ b/XMonad/Actions/SwapWorkspaces.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.SwapWorkspaces +-- Copyright : (c) Devin Mullins +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Devin Mullins +-- Stability : unstable +-- Portability : unportable +-- +-- Lets you swap workspace tags, so you can keep related ones next to +-- each other, without having to move individual windows. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.SwapWorkspaces ( + -- * Usage + -- $usage + swapWithCurrent, + swapWorkspaces + ) where + +import XMonad.StackSet + +-- $usage +-- Add this import to your Config.hs: +-- +-- > import XMonad.Actions.SwapWorkspaces +-- +-- Throw this in your keys definition: +-- +-- > ++ +-- > [((modMask .|. controlMask, k), windows $ swapWithCurrent i) +-- > | (i, k) <- zip workspaces [xK_1 ..]] + +-- %import XMonad.Actions.SwapWorkspaces +-- %keybindlist ++ +-- %keybindlist [((modMask .|. controlMask, k), windows $ swapWithCurrent i) +-- %keybindlist | (i, k) <- zip workspaces [xK_1 ..]] +-- +-- After installing this update, if you're on workspace 1, hitting mod-ctrl-5 +-- will swap workspaces 1 and 5. + +-- | Swaps the currently focused workspace with the given workspace tag, via +-- @swapWorkspaces@. +swapWithCurrent :: Eq i => i -> StackSet i l a s sd -> StackSet i l a s sd +swapWithCurrent t s = swapWorkspaces t (tag $ workspace $ current s) s + +-- | 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 diff --git a/XMonad/Actions/TagWindows.hs b/XMonad/Actions/TagWindows.hs new file mode 100644 index 0000000..938eb10 --- /dev/null +++ b/XMonad/Actions/TagWindows.hs @@ -0,0 +1,205 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.TagWindows +-- Copyright : (c) Karsten Schoelzel +-- License : BSD +-- +-- Maintainer : Karsten Schoelzel +-- Stability : unstable +-- Portability : unportable +-- +-- Functions for tagging windows and selecting them by tags. +----------------------------------------------------------------------------- + +module XMonad.Actions.TagWindows ( + -- * Usage + -- $usage + addTag, delTag, unTag, + setTags, getTags, hasTag, + withTaggedP, withTaggedGlobalP, withFocusedP, + withTagged , withTaggedGlobal , + focusUpTagged, focusUpTaggedGlobal, + focusDownTagged, focusDownTaggedGlobal, + shiftHere, shiftToScreen, + tagPrompt, + tagDelPrompt + ) where + +import Data.List (nub,concat,sortBy) + +import Control.Monad.State +import XMonad.StackSet hiding (filter) +import XMonad.Operations (windows, withFocused) + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad.Prompt +import XMonad hiding (workspaces) + +-- $usage +-- +-- To use window tags add in your Config.hs: +-- +-- > import XMonad.Actions.TagWindows +-- > import XMonad.Prompt -- to use tagPrompt +-- +-- and add keybindings like as follows: +-- +-- > , ((modMask, xK_f ), withFocused (addTag "abc")) +-- > , ((modMask .|. controlMask, xK_f ), withFocused (delTag "abc")) +-- > , ((modMask .|. shiftMask, xK_f ), withTaggedGlobal "abc" sink) +-- > , ((modMask, xK_d ), withTaggedP "abc" (shiftWin "2")) +-- > , ((modMask .|. shiftMask, xK_d ), withTaggedGlobalP "abc" shiftHere) +-- > , ((modMask .|. controlMask, xK_d ), focusUpTaggedGlobal "abc") +-- > , ((modMask, xK_g ), tagPrompt defaultXPConfig (\s -> withFocused (addTag s))) +-- > , ((modMask .|. controlMask, xK_g ), tagDelPrompt defaultXPConfig) +-- > , ((modMask .|. shiftMask, xK_g ), tagPrompt defaultXPConfig (\s -> withTaggedGlobal s float)) +-- > , ((modWinMask, xK_g ), tagPrompt defaultXPConfig (\s -> withTaggedP s (shiftWin "2"))) +-- > , ((modWinMask .|. shiftMask, xK_g ), tagPrompt defaultXPConfig (\s -> withTaggedGlobalP s shiftHere)) +-- > , ((modWinMask .|. controlMask, xK_g), tagPrompt defaultXPConfig (\s -> focusUpTaggedGlobal s)) +-- +-- NOTE: Tags are saved as space seperated string 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". + +-- %import XMonad.Actions.TagWindows +-- %import XMonad.Prompt -- to use tagPrompt + +-- set multiple tags for a window at once (overriding any previous tags) +setTags :: [String] -> Window -> X () +setTags = setTag . unwords + +-- set a tag for a window (overriding any previous tags) +-- writes it to the "_XMONAD_TAGS" window property +setTag :: String -> Window -> X () +setTag s w = withDisplay $ \d -> + io $ internAtom d "_XMONAD_TAGS" False >>= setTextProperty d w s + +-- read all tags of a window +-- reads from the "_XMONAD_TAGS" window property +getTags :: Window -> X [String] +getTags w = withDisplay $ \d -> + io $ catch (internAtom d "_XMONAD_TAGS" False >>= + getTextProperty d w >>= + wcTextPropertyToTextList d) + (\_ -> return [[]]) + >>= return . words . unwords + +-- check a window for the given tag +hasTag :: String -> Window -> X Bool +hasTag s w = (s `elem`) `liftM` 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 () + +-- remove a tag from a window, if it exists +delTag :: String -> Window -> X () +delTag s w = do + tags <- getTags w + setTags (filter (/= s) tags) w + +-- remove all tags +unTag :: Window -> X () +unTag = setTag "" + +-- Move the focus in a group of windows, which share the same given tag. +-- The Global variants move through all workspaces, whereas the other +-- ones operate only on the current workspace +focusUpTagged, focusDownTagged, focusUpTaggedGlobal, focusDownTaggedGlobal :: String -> X () +focusUpTagged = focusTagged' (reverse . wsToList) +focusDownTagged = focusTagged' wsToList +focusUpTaggedGlobal = focusTagged' (reverse . wsToListGlobal) +focusDownTaggedGlobal = focusTagged' wsToListGlobal + +-- +wsToList :: (Ord i) => StackSet i l a s sd -> [a] +wsToList ws = crs ++ cls + where + (crs, cls) = (cms down, cms (reverse . up)) + cms f = maybe [] f (stack . workspace . current $ ws) + +wsToListGlobal :: (Ord i) => StackSet i l a s sd -> [a] +wsToListGlobal ws = concat ([crs] ++ rws ++ lws ++ [cls]) + where + curtag = tag . workspace . current $ ws + (crs, cls) = (cms down, cms (reverse . up)) + cms f = maybe [] f (stack . workspace . current $ ws) + (lws, rws) = (mws (<), mws (>)) + mws cmp = map (integrate' . stack) . sortByTag . filter (\w -> tag w `cmp` curtag) . workspaces $ ws + sortByTag = sortBy (\x y -> compare (tag x) (tag y)) + +focusTagged' :: (WindowSet -> [Window]) -> String -> X () +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) +withTaggedGlobalP t f = withTaggedGlobal' t (winMap f) + +winMap :: (Window -> WindowSet -> WindowSet) -> [Window] -> X () +winMap f tw = when (tw /= []) (windows $ foldl1 (.) (map f tw)) + +withTagged, withTaggedGlobal :: String -> (Window -> X ()) -> X () +withTagged t f = withTagged' t (mapM_ f) +withTaggedGlobal t f = withTaggedGlobal' t (mapM_ f) + +withTagged' :: String -> ([Window] -> X ()) -> X () +withTagged' t m = gets windowset >>= + filterM (hasTag t) . integrate' . stack . workspace . current >>= m + +withTaggedGlobal' :: String -> ([Window] -> X ()) -> X () +withTaggedGlobal' t m = gets windowset >>= + filterM (hasTag t) . concat . map (integrate' . stack) . workspaces >>= m + +withFocusedP :: (Window -> WindowSet -> WindowSet) -> X () +withFocusedP f = withFocused $ windows . f + +shiftHere :: (Ord a, Eq s, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd +shiftHere w s = shiftWin (tag . workspace . current $ 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 + [] -> s + (t:_) -> shiftWin (tag . workspace $ t) w s + +data TagPrompt = TagPrompt + +instance XPrompt TagPrompt where + showXPrompt TagPrompt = "Select Tag: " + + +tagPrompt :: XPConfig -> (String -> X ()) -> X () +tagPrompt c f = do + sc <- tagComplList + mkXPrompt TagPrompt c (mkComplFunFromList' sc) f + +tagComplList :: X [String] +tagComplList = gets (concat . map (integrate' . stack) . workspaces . windowset) >>= + mapM getTags >>= + return . nub . concat + + +tagDelPrompt :: XPConfig -> X () +tagDelPrompt c = do + sc <- tagDelComplList + if (sc /= []) + then mkXPrompt TagPrompt c (mkComplFunFromList' sc) (\s -> withFocused (delTag s)) + else return () + +tagDelComplList :: X [String] +tagDelComplList = gets windowset >>= maybe (return []) getTags . peek + + +mkComplFunFromList' :: [String] -> String -> IO [String] +mkComplFunFromList' l [] = return l +mkComplFunFromList' l s = + return $ filter (\x -> take (length s) x == s) l diff --git a/XMonad/Actions/Warp.hs b/XMonad/Actions/Warp.hs new file mode 100644 index 0000000..bc7bacc --- /dev/null +++ b/XMonad/Actions/Warp.hs @@ -0,0 +1,74 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.Warp +-- Copyright : (c) daniel@wagner-home.com +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : daniel@wagner-home.com +-- Stability : unstable +-- Portability : unportable +-- +-- This can be used to make a keybinding that warps the pointer to a given +-- window or screen. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.Warp ( + -- * Usage + -- $usage + warpToScreen, + warpToWindow + ) where + +import Data.Ratio +import Data.List +import Control.Monad.RWS +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import XMonad.Operations +import XMonad +import XMonad.StackSet as W + +{- $usage +This can be used to make a keybinding that warps the pointer to a given +window or screen. For example, I've added the following keybindings to +my Config.hs: + +> , ((modMask, xK_z ), warpToWindow (1%2) (1%2)) -- @@ Move pointer to currently focused window +> +>-- mod-ctrl-{w,e,r} @@ Move mouse pointer to screen 1, 2, or 3 +> +> [((modMask .|. controlMask, key), warpToScreen sc (1%2) (1%2)) +> | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..]] + +Note that warping to a particular screen may change the focus. +-} + +-- %import XMonad.Actions.Warp +-- %keybind , ((modMask, xK_z ), warpToWindow (1%2) (1%2)) -- @@ Move pointer to currently focused window +-- %keybindlist ++ +-- %keybindlist -- mod-ctrl-{w,e,r} @@ Move mouse pointer to screen 1, 2, or 3 +-- %keybindlist [((modMask .|. controlMask, key), warpToScreen sc (1%2) (1%2)) +-- %keybindlist | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..]] + +fraction :: (Integral a, Integral b) => Rational -> a -> b +fraction f x = floor (f * fromIntegral x) + +warp :: Window -> Position -> Position -> X () +warp w x y = withDisplay $ \d -> io $ warpPointer d none w 0 0 0 0 x y + +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)) + +warpToScreen :: ScreenId -> Rational -> Rational -> X () +warpToScreen n h v = do + root <- asks theRoot + (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)) + (rect_y r + fraction v (rect_height r)) diff --git a/XMonad/Actions/WindowBringer.hs b/XMonad/Actions/WindowBringer.hs new file mode 100644 index 0000000..bec4f0a --- /dev/null +++ b/XMonad/Actions/WindowBringer.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.WindowBringer +-- Copyright : Devin Mullins +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Devin Mullins +-- Stability : unstable +-- Portability : unportable +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.WindowBringer ( + -- * Usage + -- $usage + gotoMenu, bringMenu, windowMapWith + ) where + +import Control.Monad.State (gets) +import Data.Char (toLower) +import qualified Data.Map as M +import Graphics.X11.Xlib (Window()) + +import XMonad.Operations (windows) +import qualified XMonad.StackSet as W +import XMonad (X) +import qualified XMonad as X +import XMonad.Util.Dmenu (dmenuMap) +import XMonad.Util.NamedWindows (getName) + +-- $usage +-- +-- Place in your Config.hs: +-- +-- > import XMonad.Actions.WindowBringer +-- +-- and in the keys definition: +-- +-- > , ((modMask .|. shiftMask, xK_g ), gotoMenu) +-- > , ((modMask .|. shiftMask, xK_b ), bringMenu) + +-- %import XMonad.Actions.WindowBringer +-- %keybind , ((modMask .|. shiftMask, xK_g ), gotoMenu) +-- %keybind , ((modMask .|. shiftMask, xK_b ), bringMenu) + +-- | Pops open a dmenu with window titles. Choose one, and you will be +-- taken to the corresponding workspace. +gotoMenu :: X () +gotoMenu = workspaceMap >>= actionMenu (windows . W.greedyView) + where workspaceMap = windowMapWith (W.tag . fst) + +-- | Pops open a dmenu with window titles. Choose one, and it will be +-- dragged, kicking and screaming, into your current workspace. +bringMenu :: X () +bringMenu = windowMap >>= actionMenu (windows . bringWindow) + where windowMap = windowMapWith snd + bringWindow w ws = W.shiftWin (W.tag . W.workspace . W.current $ ws) w ws + +-- | Calls dmenuMap to grab the appropriate element from the Map, and hands it +-- off to action if found. +actionMenu :: (a -> X ()) -> M.Map String a -> X () +actionMenu action windowMap = dmenuMap windowMap >>= flip X.whenJust action + +-- | Generates a Map from window name to . For use with +-- dmenuMap. +windowMapWith :: ((X.WindowSpace, Window) -> a) -> X (M.Map String a) +windowMapWith value = do -- TODO: extract the pure, creamy center. + 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 (,) (value (ws, w)) `fmap` decorateName 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 + return $ name ++ " [" ++ W.tag ws ++ "]" diff --git a/XMonad/Actions/WmiiActions.hs b/XMonad/Actions/WmiiActions.hs new file mode 100644 index 0000000..d98003b --- /dev/null +++ b/XMonad/Actions/WmiiActions.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.WmiiActions +-- Copyright : (c) Juraj Hercek +-- License : BSD3 +-- +-- Maintainer : Juraj Hercek +-- Stability : unstable +-- Portability : unportable +-- +-- Provides `actions' as known from Wmii window manager ( +-- ). It also provides slightly better interface for +-- running dmenu on xinerama screens. If you want to use xinerama functions, +-- you have to apply following patch (see Dmenu.hs extension): +-- . Don't forget to +-- recompile dmenu afterwards ;-). +----------------------------------------------------------------------------- + +module XMonad.Actions.WmiiActions ( + -- * Usage + -- $usage + wmiiActions + , wmiiActionsXinerama + , executables + , executablesXinerama + ) where + +import XMonad +import XMonad.Util.Dmenu (dmenu, dmenuXinerama) +import XMonad.Util.Run (runProcessWithInput) + +import Control.Monad (filterM, liftM, liftM2) +import System.Directory (getDirectoryContents, doesFileExist, getPermissions, executable) + +-- $usage +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Actions.WmiiActions +-- +-- and add following to the list of keyboard bindings: +-- +-- > ,((modMask, xK_a), wmiiActions "/home/joe/.wmii-3.5/") +-- +-- or, if you are using xinerama, you can use +-- +-- > ,((modMask, xK_a), wmiiActionsXinerama "/home/joe/.wmii-3.5/") +-- +-- however, make sure you have also xinerama build of dmenu (for more +-- information see "XMonad.Util.Dmenu" extension). + +-- | The 'wmiiActions' function takes the file path as a first argument and +-- executes dmenu with all executables found in the provided path. +wmiiActions :: FilePath -> X () +wmiiActions path = + wmiiActionsDmenu path dmenu + +-- | The 'wmiiActionsXinerama' does the same as 'wmiiActions', but it shows +-- dmenu only on workspace which currently owns focus. +wmiiActionsXinerama :: FilePath -> X () +wmiiActionsXinerama path = + wmiiActionsDmenu path dmenuXinerama + +wmiiActionsDmenu :: FilePath -> ([String] -> X String) -> X () +wmiiActionsDmenu path dmenuBrand = + let path' = path ++ "/" in + getExecutableFileList path' >>= dmenuBrand >>= spawn . (path' ++) + +getExecutableFileList :: FilePath -> X [String] +getExecutableFileList path = + io $ getDirectoryContents path >>= + filterM (\x -> let x' = path ++ x in + liftM2 (&&) + (doesFileExist x') + (liftM executable (getPermissions x'))) + +{- +getExecutableFileList :: FilePath -> X [String] +getExecutableFileList path = + io $ getDirectoryContents path >>= + filterM (doesFileExist . (path ++)) >>= + filterM (liftM executable . getPermissions . (path ++)) +-} + +-- | The 'executables' function runs dmenu_path script providing list of +-- executable files accessible from $PATH variable. +executables :: X () +executables = executablesDmenu dmenu + +-- | The 'executablesXinerama' function does the same as 'executables' function +-- but on workspace which currently owns focus. +executablesXinerama :: X () +executablesXinerama = executablesDmenu dmenuXinerama + +executablesDmenu :: ([String] -> X String) -> X () +executablesDmenu dmenuBrand = + getExecutablesList >>= dmenuBrand >>= spawn + +getExecutablesList :: X [String] +getExecutablesList = + io $ liftM lines $ runProcessWithInput "dmenu_path" [] "" + diff --git a/XMonad/Hooks/DynamicLog.hs b/XMonad/Hooks/DynamicLog.hs new file mode 100644 index 0000000..16f036a --- /dev/null +++ b/XMonad/Hooks/DynamicLog.hs @@ -0,0 +1,211 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.DynamicLog +-- Copyright : (c) Don Stewart +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Don Stewart +-- Stability : unstable +-- Portability : unportable +-- +-- DynamicLog +-- +-- Log events in: +-- +-- > 1 2 [3] 4 8 +-- +-- format. Suitable to pipe into dzen. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.DynamicLog ( + -- * Usage + -- $usage + dynamicLog, + dynamicLogDzen, + dynamicLogWithPP, + dynamicLogXinerama, + + pprWindowSet, + pprWindowSetXinerama, + + PP(..), defaultPP, dzenPP, sjanssenPP, + wrap, pad, shorten, + xmobarColor, dzenColor, dzenEscape + ) where + +-- +-- Useful imports +-- +import XMonad +import Control.Monad.Reader +import Data.Maybe ( isJust ) +import Data.List +import Data.Ord ( comparing ) +import qualified XMonad.StackSet as S +import Data.Monoid +import XMonad.Util.NamedWindows + +-- $usage +-- +-- To use, set: +-- +-- > import XMonad.Hooks.DynamicLog +-- > logHook = dynamicLog + +-- %import XMonad.Hooks.DynamicLog +-- %def -- comment out default logHook definition above if you uncomment any of these: +-- %def logHook = dynamicLog + + +-- | +-- An example log hook, print a status bar output to stdout, in the form: +-- +-- > 1 2 [3] 4 7 : full : title +-- +-- That is, the currently populated workspaces, the current +-- workspace layout, and the title of the focused window. +-- +dynamicLog :: X () +dynamicLog = dynamicLogWithPP defaultPP + +-- | +-- A log function that uses the 'PP' hooks to customize output. +dynamicLogWithPP :: PP -> X () +dynamicLogWithPP pp = do + spaces <- asks (workspaces . config) + -- layout description + ld <- withWindowSet $ return . description . S.layout . S.workspace . S.current + -- workspace list + ws <- withWindowSet $ return . pprWindowSet spaces pp + -- window title + wt <- withWindowSet $ maybe (return "") (fmap show . getName) . S.peek + + io . putStrLn . sepBy (ppSep pp) . ppOrder pp $ + [ ws + , ppLayout pp ld + , ppTitle pp wt + ] + +-- | An example log hook that emulates dwm's status bar, using colour codes printed to dzen +-- Requires dzen. Workspaces, xinerama, layouts and the window title are handled. +-- +dynamicLogDzen :: X () +dynamicLogDzen = dynamicLogWithPP dzenPP + + +pprWindowSet :: [String] -> PP -> WindowSet -> String +pprWindowSet spaces pp s = sepBy (ppWsSep pp) $ map fmt $ sortBy cmp + (map S.workspace (S.current s : S.visible s) ++ S.hidden s) + where f Nothing Nothing = EQ + f (Just _) Nothing = LT + f Nothing (Just _) = GT + f (Just x) (Just y) = compare x y + + wsIndex = flip elemIndex spaces . S.tag + + cmp a b = f (wsIndex a) (wsIndex b) `mappend` compare (S.tag a) (S.tag b) + + this = S.tag (S.workspace (S.current s)) + visibles = map (S.tag . S.workspace) (S.visible s) + + fmt w = printer pp (S.tag w) + where printer | S.tag w == this = ppCurrent + | S.tag w `elem` visibles = ppVisible + | isJust (S.stack w) = ppHidden + | otherwise = ppHiddenNoWindows + +-- | +-- Workspace logger with a format designed for Xinerama: +-- +-- > [1 9 3] 2 7 +-- +-- where 1, 9, and 3 are the workspaces on screens 1, 2 and 3, respectively, +-- and 2 and 7 are non-visible, non-empty workspaces +-- +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 :: String -> String -> String -> String +wrap _ _ "" = "" +wrap l r m = l ++ m ++ r + +pad :: String -> String +pad = wrap " " " " + +shorten :: Int -> String -> String +shorten n xs | length xs < n = xs + | otherwise = (take (n - length end) xs) ++ end + where + end = "..." + +sepBy :: String -> [String] -> String +sepBy sep = concat . intersperse sep . filter (not . null) + +dzenColor :: String -> String -> 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 metacharaters. +dzenEscape :: String -> String +dzenEscape = concatMap (\x -> if x == '^' then "^^" else [x]) + +xmobarColor :: String -> String -> String -> String +xmobarColor fg bg = wrap t "" + where t = concat [""] + +-- | The 'PP' type allows the user to customize various behaviors of +-- dynamicLogPP +data PP = PP { ppCurrent, ppVisible + , ppHidden, ppHiddenNoWindows :: WorkspaceId -> String + , ppSep, ppWsSep :: String + , ppTitle :: String -> String + , ppLayout :: String -> String + , ppOrder :: [String] -> [String] } + +-- | The default pretty printing options, as seen in dynamicLog +defaultPP :: PP +defaultPP = PP { ppCurrent = wrap "[" "]" + , ppVisible = wrap "<" ">" + , ppHidden = id + , ppHiddenNoWindows = const "" + , ppSep = " : " + , ppWsSep = " " + , ppTitle = shorten 80 + , ppLayout = id + , ppOrder = id } + +-- | 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 "" + , ppWsSep = "" + , ppSep = "" + , ppLayout = dzenColor "black" "#cccccc" . + (\ x -> case x of + "TilePrime Horizontal" -> " TTT " + "TilePrime Vertical" -> " []= " + "Hinted Full" -> " [ ] " + _ -> pad x + ) + , ppTitle = ("^bg(#324c80) " ++) . dzenEscape + } + +-- | The options that sjanssen likes to use, as an example. Note the use of +-- 'xmobarColor' and the record update on defaultPP +sjanssenPP :: PP +sjanssenPP = defaultPP { ppCurrent = xmobarColor "white" "#ff000000" + , ppTitle = xmobarColor "#00ee00" "" . shorten 80 + } diff --git a/XMonad/Hooks/EwmhDesktops b/XMonad/Hooks/EwmhDesktops new file mode 100644 index 0000000..4e2d754 --- /dev/null +++ b/XMonad/Hooks/EwmhDesktops @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonadContrib.EwmhDesktops +-- Copyright : (c) Joachim Breitner +-- License : BSD +-- +-- Maintainer : Joachim Breitner +-- Stability : unstable +-- Portability : unportable +-- +-- Makes xmonad use the EWMH hints to tell panel applications about its +-- workspaces and the windows therein. +----------------------------------------------------------------------------- +module XMonadContrib.EwmhDesktops ( + -- * Usage + -- $usage + ewmhDesktopsLogHook + ) where + +import Data.List (elemIndex, sortBy) +import Data.Ord (comparing) +import Data.Maybe (fromMaybe) + +import Control.Monad.Reader +import XMonad +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonadContrib.SetWMName + +-- $usage +-- Add the imports to your configuration file and add the logHook: +-- +-- > import XMonadContrib.EwmhDesktops +-- +-- > logHook :: X() +-- > logHook = do ewmhDesktopsLogHook +-- > return () + +-- %import XMonadContrib.EwmhDesktops +-- %def -- comment out default logHook definition above if you uncomment this: +-- %def logHook = ewmhDesktopsLogHook + + +-- | +-- Notifies pagers and window lists, such as those in the gnome-panel +-- of the current state of workspaces and windows. +ewmhDesktopsLogHook :: X () +ewmhDesktopsLogHook = withWindowSet $ \s -> do + -- Bad hack because xmonad forgets the original order of things, it seems + -- see http://code.google.com/p/xmonad/issues/detail?id=53 + let ws = sortBy (comparing W.tag) $ W.workspaces s + let wins = W.allWindows s + + setSupported + + -- Number of Workspaces + setNumberOfDesktops (length ws) + + -- Names thereof + setDesktopNames (map W.tag ws) + + -- Current desktop + fromMaybe (return ()) $ do + n <- W.lookupWorkspace 0 s + i <- elemIndex n $ map W.tag ws + return $ setCurrentDesktop i + + setClientList wins + + -- Per window Desktop + forM (zip ws [(0::Int)..]) $ \(w, wn) -> + forM (W.integrate' (W.stack w)) $ \win -> do + setWindowDesktop win wn + + return () + + +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] + +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] + +setDesktopNames :: [String] -> X () +setDesktopNames names = withDisplay $ \dpy -> do + -- Names thereof + r <- asks theRoot + a <- getAtom "_NET_DESKTOP_NAMES" + c <- getAtom "UTF8_STRING" + let names' = map (fromIntegral.fromEnum) $ + concatMap (("Workspace "++) . (++['\0'])) names + io $ changeProperty8 dpy r a c propModeReplace names' + +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) + +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] + +setSupported :: X () +setSupported = withDisplay $ \dpy -> do + r <- asks theRoot + a <- getAtom "_NET_SUPPORTED" + c <- getAtom "ATOM" + supp <- mapM getAtom ["_NET_WM_STATE_HIDDEN"] + io $ changeProperty32 dpy r a c propModeReplace (fmap fromIntegral supp) + + setWMName "xmonad" + + diff --git a/XMonad/Hooks/ManageDocks.hs b/XMonad/Hooks/ManageDocks.hs new file mode 100644 index 0000000..434701e --- /dev/null +++ b/XMonad/Hooks/ManageDocks.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.ManageDocks +-- Copyright : (c) Joachim Breitner +-- License : BSD +-- +-- Maintainer : Joachim Breitner +-- Stability : unstable +-- Portability : unportable +-- +-- Makes xmonad detect windows with type DOCK and does not put them in +-- layouts. It also detects window with STRUT set and modifies the +-- gap accordingly. +-- +-- It also allows you to reset the gap to reflect the state of current STRUT +-- windows (for example, after you resized or closed a panel), and to toggle the Gap +-- in a STRUT-aware fashion. +----------------------------------------------------------------------------- +module XMonad.Hooks.ManageDocks ( + -- * Usage + -- $usage + manageDocksHook + ,resetGap + ,toggleGap + ,avoidStruts + ) where + +import Control.Monad.Reader +import XMonad +import XMonad.Operations +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Data.Word (Word32) +import Data.Maybe (catMaybes) + +-- $usage +-- Add the imports to your configuration file and add the mangeHook: +-- +-- > import XMonad.Hooks.ManageDocks +-- +-- > manageHook w _ _ _ = manageDocksHook w +-- +-- and comment out the default `manageHook _ _ _ _ = return id` line. +-- +-- Then you can bind resetGap or toggleGap as you wish: +-- +-- > , ((modMask, xK_b), toggleGap) + +-- %import XMonad.Hooks.ManageDocks +-- %def -- comment out default manageHook definition above if you uncomment this: +-- %def manageHook w _ _ _ = manageDocksHook w +-- %keybind , ((modMask, xK_b), toggleGap) + + +-- | +-- 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. +manageDocksHook :: Window -> X (WindowSet -> WindowSet) +manageDocksHook w = do + hasStrut <- getStrut w + maybe (return ()) setGap hasStrut + + isDock <- checkDock w + if isDock then do + reveal w + return (W.delete w) + else do + return id + +-- | +-- Checks if a window is a DOCK window +checkDock :: Window -> X (Bool) +checkDock w = do + a <- getAtom "_NET_WM_WINDOW_TYPE" + d <- getAtom "_NET_WM_WINDOW_TYPE_DOCK" + mbr <- getProp a w + case mbr of + Just [r] -> return (fromIntegral r == d) + _ -> return False + +-- | +-- Gets the STRUT config, if present, in xmonad gap order +getStrut :: Window -> X (Maybe (Int, Int, Int, Int)) +getStrut w = do + a <- getAtom "_NET_WM_STRUT" + mbr <- getProp a w + case mbr of + Just [l,r,t,b] -> return (Just ( + fromIntegral t, + fromIntegral b, + fromIntegral l, + fromIntegral r)) + _ -> return Nothing + +-- | +-- Helper to read a property +getProp :: Atom -> Window -> X (Maybe [Word32]) +getProp a w = withDisplay $ \dpy -> io $ getWindowProperty32 dpy a w + +-- | +-- Modifies the gap, setting new max +setGap :: (Int, Int, Int, Int) -> X () +setGap gap = modifyGap (\_ -> max4 gap) + + +-- | +-- Goes through the list of windows and find the gap so that all STRUT +-- settings are satisfied. +calcGap :: X (Int, Int, Int, Int) +calcGap = withDisplay $ \dpy -> 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 <- catMaybes `fmap` mapM getStrut wins + return $ foldl max4 (0,0,0,0) struts + +-- | +-- Adjusts the gap to the STRUTs of all current Windows +resetGap :: X () +resetGap = do + newGap <- calcGap + modifyGap (\_ _ -> newGap) + +-- | +-- Removes the gap or, if already removed, sets the gap according to the windows’ STRUT +toggleGap :: X () +toggleGap = do + newGap <- calcGap + modifyGap (\_ old -> if old == (0,0,0,0) then newGap else (0,0,0,0)) + +-- | +-- Piecewise maximum of a 4-tuple of Ints +max4 :: (Int, Int, Int, Int) -> (Int, Int, Int, Int) -> (Int, Int, Int, Int) +max4 (a1,a2,a3,a4) (b1,b2,b3,b4) = (max a1 b1, max a2 b2, max a3 b3, max a4 b4) + +-- | Adjust layout automagically. +avoidStruts :: LayoutClass l a => l a -> AvoidStruts l a +avoidStruts = AvoidStruts + +data AvoidStruts l a = AvoidStruts (l a) deriving ( Read, Show ) + +instance LayoutClass l a => LayoutClass (AvoidStruts l) a where + doLayout (AvoidStruts lo) (Rectangle x y w h) s = + do (t,l,b,r) <- calcGap + let rect = Rectangle (x+10+fromIntegral l) (y+fromIntegral t) + (w-fromIntegral l-fromIntegral r) (h-fromIntegral t-fromIntegral b) + (wrs,mlo') <- doLayout lo rect s + return (wrs, AvoidStruts `fmap` mlo') + handleMessage (AvoidStruts l) m = + do ml' <- handleMessage l m + return (AvoidStruts `fmap` ml') + description (AvoidStruts l) = description l diff --git a/XMonad/Hooks/SetWMName.hs b/XMonad/Hooks/SetWMName.hs new file mode 100644 index 0000000..30bb4ce --- /dev/null +++ b/XMonad/Hooks/SetWMName.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.SetWMName +-- Copyright : © 2007 Ivan Tarasov +-- License : BSD +-- +-- Maintainer : Ivan.Tarasov@gmail.com +-- Stability : experimental +-- Portability : unportable +-- +-- 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" +-- and use Java 1.6u1 (1.6.0_01-ea-b03 works for me) or later. +-- +-- Remember that you need to call the setWMName action yourself (at least until +-- we have startup hooks). E.g., you can bind it in your Config.hs: +-- +-- > ((modMask .|. controlMask .|. shiftMask, xK_z), setWMName "LG3D") -- @@ Java hack +-- +-- and press the key combination before running the Java programs (you only +-- need to do it once per XMonad execution) +-- +-- For details on the problems with running Java GUI programs in non-reparenting +-- WMs, see "http:\/\/bugs.sun.com\/bugdatabase\/view_bug.do?bug_id=6429775" and +-- related bugs. +-- +-- Setting WM name to "compiz" does not solve the problem, because of yet +-- another bug in AWT code (related to insets). For LG3D insets are explicitly +-- set to 0, while for other WMs the insets are \"guessed\" and the algorithm +-- fails miserably by guessing absolutely bogus values. +----------------------------------------------------------------------------- + +module XMonad.Hooks.SetWMName ( + setWMName) where + +import Control.Monad (join) +import Control.Monad.Reader (asks) +import Data.Bits ((.|.)) +import Data.Char (ord) +import Data.List (nub) +import Data.Maybe (fromJust, listToMaybe, maybeToList) +import Data.Word (Word8) + +import Foreign.Marshal.Alloc (alloca) + +import XMonad +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Atom +import Graphics.X11.Xlib.Extras + +-- | sets WM name +setWMName :: String -> X () +setWMName name = do + atom_NET_SUPPORTING_WM_CHECK <- netSupportingWMCheckAtom + atom_NET_WM_NAME <- getAtom "_NET_WM_NAME" + atom_NET_SUPPORTED_ATOM <- getAtom "_NET_SUPPORTED" + atom_UTF8_STRING <- getAtom "UTF8_STRING" + + root <- asks theRoot + supportWindow <- getSupportWindow + 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] + -- 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 (latin1StringToWord8List 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) + where + netSupportingWMCheckAtom :: X Atom + netSupportingWMCheckAtom = getAtom "_NET_SUPPORTING_WM_CHECK" + + latin1StringToWord8List :: String -> [Word8] + latin1StringToWord8List str = map (fromIntegral . ord) str + + 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) + + validateWindow :: Maybe Window -> X Window + validateWindow w = do + valid <- maybe (return False) isValidWindow w + if valid then + return $ fromJust w + else + createSupportWindow + + -- is there a better way to check the validity of the window? + isValidWindow :: Window -> X Bool + isValidWindow w = withDisplay $ \dpy -> io $ alloca $ \p -> do + status <- xGetWindowAttributes dpy w p + return (status /= 0) + + -- this code was translated from C (see OpenBox WM, screen.c) + createSupportWindow :: X Window + createSupportWindow = withDisplay $ \dpy -> do + root <- asks theRoot + let visual = defaultVisual dpy (defaultScreen dpy) -- should be CopyFromParent (=0), but the constructor is hidden in X11.XLib + window <- io $ allocaSetWindowAttributes $ \winAttrs -> do + set_override_redirect winAttrs True -- WM cannot decorate/move/close this window + set_event_mask winAttrs propertyChangeMask -- not sure if this is needed + let bogusX = -100 + bogusY = -100 + in + createWindow dpy root bogusX bogusY 1 1 0 0 inputOutput visual (cWEventMask .|. cWOverrideRedirect) winAttrs + io $ mapWindow dpy window -- not sure if this is needed + io $ lowerWindow dpy window -- not sure if this is needed + return window diff --git a/XMonad/Hooks/UrgencyHook.hs b/XMonad/Hooks/UrgencyHook.hs new file mode 100644 index 0000000..9163b69 --- /dev/null +++ b/XMonad/Hooks/UrgencyHook.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.UrgencyHook +-- Copyright : Devin Mullins +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Devin Mullins +-- Stability : unstable +-- Portability : unportable +-- +-- 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.) +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.UrgencyHook ( + -- * Usage + -- $usage + withUrgencyHook, + focusUrgent, + readUrgents, + withUrgents + ) where + +import {-# SOURCE #-} Config (urgencyHook, logHook) +import Operations (windows) +import qualified StackSet as W +import XMonad +import XMonad.Layout.LayoutModifier + +import Control.Monad (when) +import Control.Monad.State (gets) +import Data.Bits (testBit, clearBit) +import Data.IORef +import Data.List ((\\), delete) +import Data.Maybe (listToMaybe) +import qualified Data.Set as S +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Foreign (unsafePerformIO) + +-- $usage +-- To wire this up, add: +-- +-- > import XMonad.Hooks.UrgencyHook +-- +-- to your import list in Config. Change your defaultLayout such that +-- withUrgencyHook is applied along the chain. Mine, for example: +-- +-- > layoutHook = Layout $ withUrgencyHook $ windowNavigation $ +-- > Select layouts +-- +-- It shouldn't hurt to have the "withUrgencyHook $" at the outermost layer, +-- as above, as UrgencyHook is a LayoutModifier, and hence passes on any +-- messages sent to it. Next, add your actual urgencyHook to Config. This +-- needs to take a Window and return an X () action. Here's an example: +-- +-- > import XMonad.Util.Dzen +-- ... +-- > urgencyHook :: Window -> X () +-- > urgencyHook = dzenUrgencyHook (5 `seconds`) +-- +-- If you're comfortable with programming in the X monad, then you can build +-- whatever urgencyHook you like. Finally, in order to make this compile, +-- open up your Config.hs-boot file and add the following to it: +-- +-- > urgencyHook :: Window -> X () +-- +-- Compile! +-- +-- You can also modify your logHook to print out information about urgent windows. +-- The functions readUrgents and withUrgents are there to help you with that. +-- No example for you. + +-- | Focuses the most recently urgent window. Good for what ails ya -- I mean, your keybindings. +-- Example keybinding: +-- > , ((modMask , xK_BackSpace), focusUrgent) +focusUrgent :: X () +focusUrgent = withUrgents $ flip whenJust (windows . W.focusWindow) . listToMaybe + +-- | Stores the global set of all urgent windows, across workspaces. Not exported -- use +-- @readUrgents@ or @withUrgents@ instead. +{-# NOINLINE urgents #-} +urgents :: IORef [Window] +urgents = unsafePerformIO (newIORef []) + +readUrgents :: X [Window] +readUrgents = io $ readIORef urgents + +withUrgents :: ([Window] -> X a) -> X a +withUrgents f = readUrgents >>= f + +data WithUrgencyHook a = WithUrgencyHook deriving (Read, Show) + +instance LayoutModifier WithUrgencyHook Window where + handleMess _ mess + | Just PropertyEvent { ev_event_type = t, ev_atom = a, ev_window = w } <- fromMessage mess = do + when (t == propertyNotify && a == wM_HINTS) $ withDisplay $ \dpy -> do + wmh@WMHints { wmh_flags = flags } <- io $ getWMHints dpy w + when (testBit flags urgencyHintBit) $ do + urgencyHook w + -- Clear the urgency bit in the WMHints flags field. According to the + -- Xlib manual, the *client* is supposed to clear this flag when the urgency + -- has been resolved, but, Xchat2, for example, sets the WMHints several + -- times (e.g. causing the dzen to blink) unless it's cleared. XMonad is + -- not a typical WM, so we're just breaking one more rule, here. + io $ setWMHints dpy w wmh { wmh_flags = clearBit flags urgencyHintBit } + adjustUrgents (\ws -> if elem w ws then ws else w : ws) + logHook -- call logHook after IORef has been modified + -- Doing the setWMHints triggers another propertyNotify with the bit + -- cleared, so we ignore that message. This has the potentially wrong + -- effect of ignoring *all* urgency-clearing messages, some of which might + -- be legitimate. Let's wait for bug reports on that, though. + return Nothing + | Just DestroyWindowEvent {ev_window = w} <- fromMessage mess = do + adjustUrgents (delete w) + return Nothing + | otherwise = + return Nothing + + -- Clear the urgency bit and remove from the urgent list when the window becomes visible. + redoLayout _ _ _ windowRects = do + visibles <- gets mapped + adjustUrgents (\\ (S.toList visibles)) + return (windowRects, Nothing) + +adjustUrgents :: ([Window] -> [Window]) -> X () +adjustUrgents f = io $ modifyIORef urgents f + +withUrgencyHook :: LayoutClass l Window => l Window -> ModifiedLayout WithUrgencyHook l Window +withUrgencyHook = ModifiedLayout WithUrgencyHook diff --git a/XMonad/Hooks/XPropManage.hs b/XMonad/Hooks/XPropManage.hs new file mode 100644 index 0000000..245a6a6 --- /dev/null +++ b/XMonad/Hooks/XPropManage.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.XPropManage +-- Copyright : (c) Karsten Schoelzel +-- License : BSD +-- +-- Maintainer : Karsten Schoelzel +-- Stability : unstable +-- Portability : unportable +-- +-- A ManageHook matching on XProperties. +----------------------------------------------------------------------------- + +module XMonad.Hooks.XPropManage ( + -- * Usage + -- $usage + xPropManageHook, XPropMatch, pmX, pmP + ) where + +import Data.Char (chr) +import Data.List (concat) + +import Control.Monad.State +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad + +-- $usage +-- +-- Add something like the following lines to Config.hs to use this module +-- +-- > import XMonad.Hooks.XPropManage +-- +-- > manageHook = xPropManageHook xPropMatches +-- > +-- > xPropMatches :: [XPropMatch] +-- > xPropMatches = [ ([ (wM_CLASS, any ("gimp"==)))], (\w -> float w >> return (W.shift "2"))) +-- > , ([ (wM_COMMAND, any ("screen" ==)), (wM_CLASS, any ("xterm" ==))], pmX (addTag "screen")) +-- > , ([ (wM_NAME, any ("Iceweasel" `isInfixOf`))], pmP (W.shift "3")) +-- > ] +-- +-- Properties known to work: wM_CLASS, wM_NAME, wM_COMMAND +-- +-- A XPropMatch consists of a list of conditions and function telling what to do. +-- +-- The list entries are pairs of an XProperty to match on (like wM_CLASS, wM_NAME)^1, +-- and an function which matches onto the value of the property (represented as a List +-- of Strings). +-- +-- If a match succeeds the function is called immediately, can perform any action and then return +-- a function to apply in 'windows' (see Operations.hs). So if the action does only work on the +-- WindowSet use just 'pmP function'. +-- +-- \*1 You can get the available properties of an application with the xprop utility. STRING properties +-- should work fine. Others might not work. +-- + +type XPropMatch = ([(Atom, [String] -> Bool)], (Window -> X (WindowSet -> WindowSet))) + +pmX :: (Window -> X ()) -> Window -> X (WindowSet -> WindowSet) +pmX f w = f w >> return id + +pmP :: (WindowSet -> WindowSet) -> Window -> X (WindowSet -> WindowSet) +pmP f _ = return f + +xPropManageHook :: [XPropMatch] -> Window -> X (WindowSet -> WindowSet) +xPropManageHook tms w = withDisplay $ \d -> do + fs <- mapM (matchProp d w `uncurry`) tms + return (foldr (.) id fs) + +matchProp :: Display -> Window -> [(Atom, [String] -> Bool)] -> (Window -> X (WindowSet -> WindowSet)) -> X (WindowSet -> WindowSet) +matchProp d w tm tf = do + m <- and `liftM` sequence (map (\(k,f) -> f `liftM` getProp d w k) tm) + case m of + True -> tf w + False -> return id + +getProp :: Display -> Window -> Atom -> X ([String]) +getProp d w p = do + prop <- io $ catch (getTextProperty d w p >>= wcTextPropertyToTextList d) (\_ -> return [[]]) + let filt q | q == wM_COMMAND = concat . map splitAtNull + | otherwise = id + return (filt p prop) + +splitAtNull :: String -> [String] +splitAtNull s = case dropWhile (== (chr 0)) s of + "" -> [] + s' -> w : splitAtNull s'' + where (w, s'') = break (== (chr 0)) s' + diff --git a/XMonad/Layout/Accordion.hs b/XMonad/Layout/Accordion.hs new file mode 100644 index 0000000..f844c22 --- /dev/null +++ b/XMonad/Layout/Accordion.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Accordion +-- Copyright : (c) glasser@mit.edu +-- License : BSD +-- +-- Maintainer : glasser@mit.edu +-- Stability : unstable +-- Portability : unportable +-- +-- LayoutClass that puts non-focused windows in ribbons at the top and bottom +-- of the screen. +----------------------------------------------------------------------------- + +module XMonad.Layout.Accordion ( + -- * Usage + -- $usage + Accordion(Accordion)) where + +import XMonad +import XMonad.Layouts +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Data.Ratio + +-- $usage +-- > import XMonad.Layout.Accordion +-- > layouts = [ Layout Accordion ] + +-- %import XMonad.Layout.Accordion +-- %layout , Layout Accordion + +data Accordion a = Accordion deriving ( Read, Show ) + +instance LayoutClass Accordion Window where + pureLayout _ sc ws = zip ups tops ++ [(W.focus ws, mainPane)] ++ zip dns bottoms + where + ups = W.up ws + dns = W.down ws + (top, allButTop) = splitVerticallyBy (1%8 :: Ratio Int) sc + (center, bottom) = splitVerticallyBy (6%7 :: Ratio Int) allButTop + (allButBottom, _) = splitVerticallyBy (7%8 :: Ratio Int) sc + mainPane | ups /= [] && dns /= [] = center + | ups /= [] = allButTop + | dns /= [] = allButBottom + | otherwise = sc + tops = if ups /= [] then splitVertically (length ups) top else [] + bottoms = if dns /= [] then splitVertically (length dns) bottom else [] diff --git a/XMonad/Layout/Circle.hs b/XMonad/Layout/Circle.hs new file mode 100644 index 0000000..2d85dfc --- /dev/null +++ b/XMonad/Layout/Circle.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Circle +-- Copyright : (c) Peter De Wachter +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Peter De Wachter +-- Stability : unstable +-- Portability : unportable +-- +-- Circle is an elliptical, overlapping layout, by Peter De Wachter +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Circle ( + -- * Usage + -- $usage + Circle (..) + ) where -- actually it's an ellipse + +import Data.List +import Graphics.X11.Xlib +import XMonad +import XMonad.StackSet (integrate, peek) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Circle +-- > layouts = [ Layout Circle ] + +-- %import XMonad.Layout.Circle + +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 + +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 + diff --git a/XMonad/Layout/Combo.hs b/XMonad/Layout/Combo.hs new file mode 100644 index 0000000..a89f281 --- /dev/null +++ b/XMonad/Layout/Combo.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Combo +-- Copyright : (c) David Roundy +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- A layout that combines multiple layouts. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Combo ( + -- * Usage + -- $usage + combineTwo, + CombineTwo + ) where + +import Control.Arrow ( first ) +import Data.List ( delete, intersect, (\\) ) +import Data.Maybe ( isJust ) +import XMonad +import XMonad.StackSet ( integrate, Stack(..) ) +import XMonad.Util.Invisible +import XMonad.Layout.WindowNavigation ( MoveWindowToWindow(..) ) +import qualified XMonad.StackSet as W ( differentiate ) + +-- $usage +-- +-- To use this layout write, in your Config.hs: +-- +-- > import XMonad.Layout.Combo +-- +-- and add something like +-- +-- > combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf) +-- +-- to your layouts. + +-- combineTwo is a new simple layout combinator. It allows the combination +-- of two layouts using a third to split the screen between the two, but +-- has the advantage of allowing you to dynamically adjust the layout, in +-- terms of the number of windows in each sublayout. To do this, use +-- WindowNavigation, and add the following key bindings (or something +-- similar): + +-- , ((modMask .|. controlMask .|. shiftMask, xK_Right), sendMessage $ Move R) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Left), sendMessage $ Move L) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Up), sendMessage $ Move U) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Down), sendMessage $ Move D) + +-- These bindings will move a window into the sublayout that is +-- up/down/left/right of its current position. Note that there is some +-- weirdness in combineTwo, in that the mod-tab focus order is not very +-- closely related to the layout order. This is because we're forced to +-- keep track of the window positions sparately, and this is ugly. If you +-- don't like this, lobby for hierarchical stacks in core xmonad or go +-- reimelement the core of xmonad yourself. + +-- %import XMonad.Layout.Combo +-- %layout , combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf) + +data CombineTwo l l1 l2 a = C2 [a] [a] (l ()) (l1 a) (l2 a) + deriving (Read, Show) + +combineTwo :: (Read a, Eq a, LayoutClass super (), LayoutClass l1 a, LayoutClass l2 a) => + super () -> l1 a -> l2 a -> CombineTwo super l1 l2 a +combineTwo = C2 [] [] + +instance (LayoutClass l (), LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) + => LayoutClass (CombineTwo l l1 l2) a where + doLayout (C2 f w2 super l1 l2) rinput s = arrange (integrate s) + where arrange [] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage Hide) + l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage Hide) + return ([], Just $ C2 [] [] super l1' l2') + arrange [w] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage Hide) + l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage Hide) + return ([(w,rinput)], Just $ C2 [w] [w] super l1' l2') + arrange origws = + do let w2' = case origws `intersect` w2 of [] -> [head origws] + [x] -> [x] + x -> case origws \\ x of + [] -> init x + _ -> x + superstack = if focus s `elem` w2' + then Stack { focus=(), up=[], down=[()] } + else Stack { focus=(), up=[], down=[()] } + s1 = differentiate f' (origws \\ w2') + s2 = differentiate f' w2' + f' = focus s:delete (focus s) f + ([((),r1),((),r2)], msuper') <- doLayout super rinput superstack + (wrs1, ml1') <- runLayout l1 r1 s1 + (wrs2, ml2') <- runLayout l2 r2 s2 + return (wrs1++wrs2, Just $ C2 f' w2' + (maybe super id msuper') (maybe l1 id ml1') (maybe l2 id 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 + 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 + let ws2' = case delete w1 ws2 of [] -> [w2] + x -> x + return $ Just $ C2 f ws2' super l1' l2' + | otherwise = do ml1' <- broadcastPrivate m [l1] + ml2' <- broadcastPrivate m [l2] + 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') + 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 + else return Nothing + where f l = handleMessage l a `catchX` return Nothing diff --git a/XMonad/Layout/Dishes.hs b/XMonad/Layout/Dishes.hs new file mode 100644 index 0000000..ecc27db --- /dev/null +++ b/XMonad/Layout/Dishes.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Dishes +-- Copyright : (c) Jeremy Apthorp +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jeremy Apthorp +-- Stability : unstable +-- Portability : portable +-- +-- Dishes is a layout that stacks extra windows underneath the master +-- windows. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Dishes ( + -- * Usage + -- $usage + Dishes (..) + ) where + +import Data.List +import XMonad +import XMonad.Layouts +import XMonad.StackSet (integrate) +import Control.Monad (ap) +import Graphics.X11.Xlib + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Dishes +-- +-- and add the following line to your 'layouts' +-- +-- > , Layout $ Dishes 2 (1%6) + +-- %import XMonad.Layout.Dishes +-- %layout , Layout $ Dishes 2 (1%6) + +data Dishes a = Dishes Int Rational deriving (Show, Read) +instance LayoutClass Dishes a where + doLayout (Dishes nmaster h) r = + return . (\x->(x,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 + +dishes :: Rational -> Rectangle -> Int -> Int -> [Rectangle] +dishes h s nmaster n = if n <= nmaster + then splitHorizontally n s + else ws + where + (m,rest) = splitVerticallyBy (1 - (fromIntegral $ n - nmaster) * h) s + ws = splitHorizontally nmaster m ++ splitVertically (n - nmaster) rest diff --git a/XMonad/Layout/DragPane.hs b/XMonad/Layout/DragPane.hs new file mode 100644 index 0000000..8428d2b --- /dev/null +++ b/XMonad/Layout/DragPane.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.DragPane +-- Copyright : (c) Spencer Janssen +-- David Roundy , +-- Andrea Rossato +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Andrea Rossato +-- Stability : unstable +-- Portability : unportable +-- +-- 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. + +----------------------------------------------------------------------------- + +module XMonad.Layout.DragPane ( + -- * Usage + -- $usage + dragPane + , DragPane, DragType (..) + ) where + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import XMonad +import Data.Bits +import Data.Unique + +import XMonad.Layouts +import XMonad.Operations +import qualified XMonad.StackSet as W +import XMonad.Util.Invisible +import XMonad.Util.XUtils + +-- $usage +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.DragPane +-- +-- and add, to the list of layouts: +-- +-- > Layout $ dragPane Horizontal 0.1 0.5 + +halfHandleWidth :: Integral a => a +halfHandleWidth = 1 + +handleColor :: String +handleColor = "#000000" + +dragPane :: DragType -> Double -> Double -> DragPane a +dragPane t x y = DragPane (I Nothing) t x y + +data DragPane a = + DragPane (Invisible Maybe (Window,Rectangle,Int)) DragType Double Double + deriving ( Show, Read ) + +data DragType = Horizontal | Vertical deriving ( Show, Read ) + +instance LayoutClass DragPane a where + doLayout d@(DragPane _ Vertical _ _) = doLay id d + doLayout d@(DragPane _ Horizontal _ _) = doLay mirrorRect d + handleMessage = handleMess + +data SetFrac = SetFrac Int Double deriving ( Show, Read, Eq, Typeable ) +instance Message SetFrac + +handleMess :: DragPane a -> SomeMessage -> X (Maybe (DragPane a)) +handleMess d@(DragPane mb@(I (Just (win,_,ident))) ty delta split) x + | Just e <- fromMessage x :: Maybe Event = do handleEvent d e + return Nothing + | Just Hide <- fromMessage x = do hideWindow win + return $ Just (DragPane mb ty delta split) + | Just ReleaseResources <- fromMessage x = do deleteWindow win + return $ Just (DragPane (I Nothing) ty delta split) + -- 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 + 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 + 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) + sendMessage (SetFrac ident frac)) + (return ()) +handleEvent _ _ = return () + +doLay :: (Rectangle -> Rectangle) -> DragPane a -> Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (DragPane a)) +doLay mirror (DragPane mw ty delta split) r s = do + let r' = mirror r + (left', right') = splitHorizontallyBy split r' + left = case left' of Rectangle x y w h -> + mirror $ Rectangle x y (w-halfHandleWidth) h + right = case right' of + Rectangle x y w h -> + mirror $ Rectangle (x+halfHandleWidth) y (w-halfHandleWidth) h + handr = case left' of + Rectangle x y w h -> + mirror $ Rectangle (x + fromIntegral w - halfHandleWidth) y (2*halfHandleWidth) h + wrs = case reverse (W.up s) of + (master:_) -> [(master,left),(W.focus s,right)] + [] -> case W.down s of + (next:_) -> [(W.focus s,left),(next,right)] + [] -> [(W.focus s, r)] + if length wrs > 1 + then case mw of + I (Just (w,_,ident)) -> do + w' <- deleteWindow w >> newDragWin handr + return (wrs, Just $ DragPane (I $ Just (w',r',ident)) ty delta split) + I Nothing -> do + w <- newDragWin handr + i <- io $ newUnique + return (wrs, Just $ DragPane (I $ Just (w,r',hashUnique i)) ty delta split) + else return (wrs, Nothing) + + +newDragWin :: Rectangle -> X Window +newDragWin r = do + let mask = Just $ exposureMask .|. buttonPressMask + w <- createNewWindow r mask handleColor + showWindow w + return w diff --git a/XMonad/Layout/Grid.hs b/XMonad/Layout/Grid.hs new file mode 100644 index 0000000..b10a8ac --- /dev/null +++ b/XMonad/Layout/Grid.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Grid +-- Copyright : (c) Lukas Mai +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- A simple layout that attempts to put all windows in a square grid. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Grid ( + -- * Usage + -- $usage + Grid(..) +) where + +import XMonad +import XMonad.StackSet +import Graphics.X11.Xlib.Types + +-- $usage +-- Put the following in your Config.hs file: +-- +-- > import XMonad.Layout.Grid +-- > ... +-- > layouts = [ ... +-- > , Layout Grid +-- > ] + +-- %import XMonad.Layout.Grid +-- %layout , Layout Grid + +data Grid a = Grid deriving (Read, Show) + +instance LayoutClass Grid a where + pureLayout Grid r s = arrange r (integrate s) + +arrange :: Rectangle -> [a] -> [(a, Rectangle)] +arrange (Rectangle rx ry rw rh) st = zip st rectangles + where + nwins = length st + ncols = ceiling . (sqrt :: Double -> Double) . fromIntegral $ nwins + mincs = 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' + where + k :: Dimension + k = m `div` fromIntegral n + m' = fromIntegral m + k' :: Position + k' = fromIntegral k + xcoords = chop ncols rw + ycoords = chop mincs rh + ycoords' = chop (succ mincs) rh + (xbase, xext) = splitAt (ncols - extrs) xcoords + rectangles = combine ycoords xbase ++ combine ycoords' xext + where + combine ys xs = [Rectangle (rx + x) (ry + y) w h | (x, w) <- xs, (y, h) <- ys] diff --git a/XMonad/Layout/HintedTile.hs b/XMonad/Layout/HintedTile.hs new file mode 100644 index 0000000..2ec9d3c --- /dev/null +++ b/XMonad/Layout/HintedTile.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.HintedTile +-- Copyright : (c) Peter De Wachter +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Peter De Wachter +-- Stability : unstable +-- Portability : unportable +-- +-- A gapless tiled layout that attempts to obey window size hints, +-- rather than simply ignoring them. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.HintedTile ( + -- * Usage + -- $usage + tall, wide) where + +import XMonad +import XMonad.Operations (Resize(..), IncMasterN(..), applySizeHints) +import qualified XMonad.StackSet as W +import {-# SOURCE #-} Config (borderWidth) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Control.Monad + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import qualified XMonad.Layout.HintedTile +-- +-- > layouts = [ XMonad.Layout.HintedTile.tall nmaster delta ratio, ... ] + +-- %import qualified XMonad.Layout.HintedTile +-- +-- %layout , XMonad.Layout.HintedTile.tall nmaster delta ratio + +-- this sucks +addBorder, substractBorder :: (Dimension, Dimension) -> (Dimension, Dimension) +addBorder (w, h) = (w + 2 * borderWidth, h + 2 * borderWidth) +substractBorder (w, h) = (w - 2 * borderWidth, h - 2 * borderWidth) + + +tall, wide :: Int -> Rational -> Rational -> Layout Window +wide = tile splitVertically divideHorizontally +tall = tile splitHorizontally divideVertically + +tile split divide nmaster delta frac = + Layout { doLayout = \r w' -> let w = W.integrate w' + in do { hints <- sequence (map getHints w) + ; return (zip w (tiler frac r `uncurry` splitAt nmaster hints) + , Nothing) } + , modifyLayout = \m -> return $ fmap resize (fromMessage m) `mplus` + fmap incmastern (fromMessage m) } + + where resize Shrink = tile split divide nmaster delta (frac-delta) + resize Expand = tile split divide nmaster delta (frac+delta) + incmastern (IncMasterN d) = tile split divide (max 0 (nmaster+d)) delta frac + + tiler f r masters slaves = if null masters || null slaves + then divide (masters ++ slaves) r + else split f r (divide masters) (divide slaves) + +getHints :: Window -> X SizeHints +getHints w = withDisplay $ \d -> io $ getWMNormalHints d w + +-- +-- Divide the screen vertically (horizontally) into n subrectangles +-- +divideVertically, divideHorizontally :: [SizeHints] -> Rectangle -> [Rectangle] +divideVertically [] _ = [] -- there's a fold here, struggling to get out +divideVertically (hints:rest) (Rectangle sx sy sw sh) = (Rectangle sx sy w h) : + (divideVertically rest (Rectangle sx (sy + fromIntegral h) sw (sh - h))) + where (w, h) = addBorder $ applySizeHints hints $ substractBorder + (sw, sh `div` fromIntegral (1 + (length rest))) + +divideHorizontally [] _ = [] +divideHorizontally (hints:rest) (Rectangle sx sy sw sh) = (Rectangle sx sy w h) : + (divideHorizontally rest (Rectangle (sx + fromIntegral w) sy (sw - w) sh)) + where (w, h) = addBorder $ applySizeHints hints $ substractBorder + (sw `div` fromIntegral (1 + (length rest)), sh) + + +-- Split the screen into two rectangles, using a rational to specify the ratio +splitHorizontally, splitVertically :: Rational -> Rectangle -> (Rectangle -> [Rectangle]) -> (Rectangle -> [Rectangle]) -> [Rectangle] +splitHorizontally f (Rectangle sx sy sw sh) left right = leftRects ++ rightRects + where leftw = floor $ fromIntegral sw * f + leftRects = left $ Rectangle sx sy leftw sh + rightx = (maximum . map rect_width) leftRects + rightRects = right $ Rectangle (sx + fromIntegral rightx) sy (sw - rightx) sh + +splitVertically f (Rectangle sx sy sw sh) top bottom = topRects ++ bottomRects + where toph = floor $ fromIntegral sh * f + topRects = top $ Rectangle sx sy sw toph + bottomy = (maximum . map rect_height) topRects + bottomRects = bottom $ Rectangle sx (sy + fromIntegral bottomy) sw (sh - bottomy) diff --git a/XMonad/Layout/LayoutCombinators.hs b/XMonad/Layout/LayoutCombinators.hs new file mode 100644 index 0000000..4b2aa09 --- /dev/null +++ b/XMonad/Layout/LayoutCombinators.hs @@ -0,0 +1,128 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutCombinators +-- Copyright : (c) David Roundy +-- License : BSD +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : portable +-- +-- A module for combining Layouts +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutCombinators ( + -- * Usage + -- $usage + (<|>), (), (<||>), (), (|||), JumpToLayout(JumpToLayout) + ) where + +import Data.Maybe ( isJust ) + +import XMonad +import Layouts ( Tall(..), Mirror(..), ChangeLayout(NextLayout) ) +import XMonad.Layout.Combo +import XMonad.Layout.DragPane + +-- $usage +-- Use LayoutCombinators to easily combine Layouts. + +(<||>), () :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a) => + l1 a -> l2 a -> CombineTwo DragPane l1 l2 a +(<|>) :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a) + => l1 a -> l2 a -> CombineTwo Tall l1 l2 a +() :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a) + => l1 a -> l2 a -> CombineTwo (Mirror Tall) l1 l2 a + +(<||>) = combineTwo (dragPane Vertical 0.1 0.5) +() = combineTwo (dragPane Horizontal 0.1 0.5) +(<|>) = combineTwo (Tall 1 0.1 0.5) +() = combineTwo (Mirror $ Tall 1 0.1 0.5) + +(|||) :: (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 NoWrap = NextLayoutNoWrap | Wrap deriving ( Read, Show, Typeable ) +instance Message NoWrap + +data JumpToLayout = JumpToLayout String deriving ( Read, Show, Typeable ) +instance Message JumpToLayout + +instance (LayoutClass l1 a, LayoutClass l2 a) => LayoutClass (NewSelect l1 l2) a where + doLayout (NewSelect True l1 l2) r s = do (wrs, ml1') <- doLayout l1 r s + return (wrs, (\l1' -> NewSelect True l1' l2) `fmap` ml1') + doLayout (NewSelect False l1 l2) r s = do (wrs, ml2') <- doLayout l2 r s + return (wrs, (\l2' -> NewSelect False l1 l2') `fmap` ml2') + description (NewSelect True l1 _) = description l1 + description (NewSelect False _ l2) = description l2 + handleMessage (NewSelect False l1 l2) m + | Just Wrap <- fromMessage m = + do ml2' <- handleMessage l2 (SomeMessage Hide) + ml1' <- handleMessage l1 m + return $ Just $ NewSelect True (maybe l1 id ml1') (maybe l2 id ml2') + handleMessage (NewSelect True l1 l2) m + | Just NextLayoutNoWrap <- fromMessage m = + do ml1' <- handleMessage l1 m + case ml1' of + Just l1' -> return $ Just (NewSelect True l1' l2) + Nothing -> do ml1'' <- handleMessage l1 (SomeMessage Hide) + ml2' <- handleMessage l2 (SomeMessage Wrap) + return $ Just $ NewSelect False (maybe l1 id ml1'') (maybe l2 id ml2') + handleMessage l@(NewSelect True _ _) m + | Just NextLayout <- fromMessage m = handleMessage l (SomeMessage NextLayoutNoWrap) + handleMessage l@(NewSelect False l1 l2) m + | Just NextLayout <- fromMessage m = + do ml' <- handleMessage l (SomeMessage NextLayoutNoWrap) + case ml' of + Just l' -> return $ Just l' + Nothing -> do ml2' <- handleMessage l2 (SomeMessage Hide) + ml1' <- handleMessage l1 (SomeMessage Wrap) + return $ Just $ NewSelect True (maybe l1 id ml1') (maybe l2 id ml2') + handleMessage (NewSelect True l1 l2) m + | Just (JumpToLayout d) <- fromMessage m, + d == description l2 = do ml1' <- handleMessage l1 (SomeMessage Hide) + return $ Just $ NewSelect False (maybe l1 id ml1') l2 + handleMessage (NewSelect True l1 l2) m + | Just (JumpToLayout d) <- fromMessage m + = do ml1' <- handleMessage l1 m + case ml1' of + Just l1' -> return $ Just $ NewSelect True l1' l2 + Nothing -> + do ml2' <- handleMessage l2 m + case ml2' of + Nothing -> return Nothing + Just l2' -> do ml1'' <- handleMessage l1 (SomeMessage Hide) + return $ Just $ NewSelect False (maybe l1 id ml1'') l2' + handleMessage (NewSelect False l1 l2) m + | Just (JumpToLayout d) <- fromMessage m, + d == description l1 = do ml2' <- handleMessage l2 (SomeMessage Hide) + return $ Just $ NewSelect True l1 (maybe l2 id ml2') + handleMessage (NewSelect False l1 l2) m + | Just (JumpToLayout d) <- fromMessage m + = do ml2' <- handleMessage l2 m + case ml2' of + Just l2' -> return $ Just $ NewSelect False l1 l2' + Nothing -> + do ml1' <- handleMessage l1 m + case ml1' of + Nothing -> return Nothing + Just l1' -> do ml2'' <- handleMessage l2 (SomeMessage Hide) + return $ Just $ NewSelect True l1' (maybe l2 id ml2'') + 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 (NewSelect True l1 l2) m = + do ml1' <- handleMessage l1 m + return $ (\l1' -> NewSelect True l1' l2) `fmap` ml1' + handleMessage (NewSelect False l1 l2) m = + do ml2' <- handleMessage l2 m + return $ (\l2' -> NewSelect False l1 l2') `fmap` ml2' diff --git a/XMonad/Layout/LayoutHints.hs b/XMonad/Layout/LayoutHints.hs new file mode 100644 index 0000000..1268b3f --- /dev/null +++ b/XMonad/Layout/LayoutHints.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutHints +-- Copyright : (c) David Roundy +-- License : BSD +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : portable +-- +-- Make layouts respect size hints. +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutHints ( + -- * usage + -- $usage + layoutHints, + LayoutHints) where + +import XMonad.Operations ( applySizeHints, D ) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras ( getWMNormalHints ) +import {-#SOURCE#-} Config (borderWidth) +import XMonad hiding ( trace ) +import XMonad.Layout.LayoutModifier + +-- $usage +-- > import XMonad.Layout.LayoutHints +-- > layouts = [ layoutHints tiled , layoutHints $ Mirror tiled ] + +-- %import XMonad.Layout.LayoutHints +-- %layout , layoutHints $ tiled +-- %layout , layoutHints $ Mirror tiled + +layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a +layoutHints = ModifiedLayout LayoutHints + +-- | Expand a size by the given multiple of the border width. The +-- multiple is most commonly 1 or -1. +adjBorders :: Dimension -> D -> D +adjBorders mult (w,h) = (w+2*mult*borderWidth, h+2*mult*borderWidth) + +data LayoutHints a = LayoutHints deriving (Read, Show) + +instance LayoutModifier LayoutHints Window where + modifierDescription _ = "Hinted" + redoLayout _ _ _ xs = do + xs' <- mapM applyHint xs + return (xs', Nothing) + where + applyHint (w,Rectangle a b c d) = + withDisplay $ \disp -> do + sh <- io $ getWMNormalHints disp w + let (c',d') = adjBorders 1 . applySizeHints sh . adjBorders (-1) $ (c,d) + return (w, Rectangle a b c' d') diff --git a/XMonad/Layout/LayoutModifier.hs b/XMonad/Layout/LayoutModifier.hs new file mode 100644 index 0000000..7d8c615 --- /dev/null +++ b/XMonad/Layout/LayoutModifier.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutModifier +-- Copyright : (c) David Roundy +-- License : BSD +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : portable +-- +-- A module for writing easy Layouts +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutModifier ( + -- * Usage + -- $usage + LayoutModifier(..), ModifiedLayout(..) + ) where + +import Graphics.X11.Xlib ( Rectangle ) +import XMonad +import XMonad.StackSet ( Stack ) + +-- $usage +-- Use LayoutHelpers to help write easy Layouts. + +class (Show (m a), Read (m a)) => LayoutModifier m a where + handleMess :: m a -> SomeMessage -> X (Maybe (m a)) + handleMess m mess | Just Hide <- fromMessage mess = doUnhook + | Just ReleaseResources <- fromMessage mess = doUnhook + | otherwise = return Nothing + where doUnhook = do unhook m; return Nothing + handleMessOrMaybeModifyIt :: m a -> SomeMessage -> X (Maybe (Either (m a) SomeMessage)) + handleMessOrMaybeModifyIt m mess = do mm' <- handleMess m mess + return (Left `fmap` mm') + redoLayout :: m a -> Rectangle -> Stack a -> [(a, Rectangle)] + -> X ([(a, Rectangle)], Maybe (m a)) + redoLayout m _ _ wrs = do hook m; return (wrs, Nothing) + hook :: m a -> X () + hook _ = return () + unhook :: m a -> X () + unhook _ = return () + modifierDescription :: m a -> String + modifierDescription = const "" + +instance (LayoutModifier m a, LayoutClass l a) => LayoutClass (ModifiedLayout m l) a where + doLayout (ModifiedLayout m l) r s = + do (ws, ml') <- doLayout l r s + (ws', mm') <- redoLayout m r s ws + let ml'' = case mm' of + Just m' -> Just $ (ModifiedLayout m') $ maybe l id ml' + Nothing -> ModifiedLayout m `fmap` ml' + return (ws', ml'') + handleMessage (ModifiedLayout m l) mess = + do mm' <- handleMessOrMaybeModifyIt m mess + ml' <- case mm' of + 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' + description (ModifiedLayout m l) = modifierDescription m <> description l + where "" <> x = x + x <> y = x ++ " " ++ y + +data ModifiedLayout m l a = ModifiedLayout (m a) (l a) deriving ( Read, Show ) diff --git a/XMonad/Layout/LayoutScreens.hs b/XMonad/Layout/LayoutScreens.hs new file mode 100644 index 0000000..7277681 --- /dev/null +++ b/XMonad/Layout/LayoutScreens.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutScreens +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutScreens ( + -- * Usage + -- $usage + layoutScreens, fixedLayout + ) where + +import Control.Monad.Reader ( asks ) + +import XMonad +import qualified XMonad.StackSet as W +import qualified XMonad.Operations as O +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +-- $usage +-- This module allows you to pretend that you have more than one screen by +-- dividing a single screen into multiple screens that xmonad will treat as +-- separate screens. This should definitely be useful for testing the +-- behavior of xmonad under Xinerama, and it's possible that it'd also be +-- handy for use as an actual user interface, if you've got a very large +-- screen and long for greater flexibility (e.g. being able to see your +-- email window at all times, a crude mimic of sticky windows). +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.LayoutScreens +-- +-- > , ((modMask .|. shiftMask, xK_space), layoutScreens 2 (TwoPane 0.5 0.5)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen) +-- +-- Another example use would be to handle a scenario where xrandr didn't +-- work properly (e.g. a VNC X server in my case) and you want to be able +-- to resize your screen (e.g. to match the size of a remote VNC client): +-- +-- > import XMonad.Layout.LayoutScreens +-- +-- > , ((modMask .|. shiftMask, xK_space), +-- > layoutScreens 1 (fixedLayout $ Rectangle 0 0 1024 768)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen) + +-- %import XMonad.Layout.LayoutScreens +-- %keybind , ((modMask .|. shiftMask, xK_space), layoutScreens 2 (twoPane 0.5 0.5)) +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen) + +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 + (wss, _) <- doLayout l rtrect W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] } + O.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 + gaps = map (statusGap . W.screenDetail) $ v:vs + (s:ss, g:gg) = (map snd wss, take nscr $ gaps ++ repeat (head gaps)) + in ws { W.current = W.Screen x 0 (SD s g) + , W.visible = zipWith3 W.Screen xs [1 ..] $ zipWith SD ss gg + , 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) + +data FixedLayout a = FixedLayout [Rectangle] deriving (Read,Show) + +instance LayoutClass FixedLayout a where + doLayout (FixedLayout rs) _ s = return (zip (W.integrate s) rs, Nothing) + +fixedLayout :: [Rectangle] -> FixedLayout a +fixedLayout = FixedLayout diff --git a/XMonad/Layout/MagicFocus.hs b/XMonad/Layout/MagicFocus.hs new file mode 100644 index 0000000..57e5b7a --- /dev/null +++ b/XMonad/Layout/MagicFocus.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.MagicFocus +-- Copyright : (c) Peter De Wachter +-- License : BSD +-- +-- Maintainer : Peter De Wachter +-- Stability : unstable +-- Portability : unportable +-- +-- Automagically put the focused window in the master area. +----------------------------------------------------------------------------- + +module XMonad.Layout.MagicFocus + (-- * Usage + -- $usage + MagicFocus(MagicFocus) + ) where + +import Graphics.X11.Xlib +import XMonad +import XMonad.StackSet + +-- $usage +-- > import XMonad.Layout.MagicFocus +-- > layouts = [ Layout $ MagicFocus tiled , Layout $ MagicFocus $ Mirror tiled ] + +-- %import XMonad.Layout.MagicFocus +-- %layout , Layout $ MagicFocus tiled +-- %layout , Layout $ MagicFocus $ Mirror tiled + + +data MagicFocus l a = MagicFocus (l a) deriving ( Show , Read ) + +instance (LayoutClass l Window) => LayoutClass (MagicFocus l) Window where + doLayout = magicFocus + +magicFocus :: LayoutClass l Window => MagicFocus l Window -> Rectangle + -> Stack Window -> X ([(Window, Rectangle)], Maybe (MagicFocus l Window)) +magicFocus (MagicFocus l) r s = + withWindowSet $ \wset -> do + (ws,nl) <- doLayout l r (swap s $ peek wset) + case nl of + Nothing -> return (ws, Nothing) + Just l' -> return (ws, Just $ MagicFocus l') + +swap :: (Eq a) => Stack a -> Maybe a -> Stack a +swap (Stack f u d) focused | Just f == focused = Stack f [] (reverse u ++ d) + | otherwise = Stack f u d diff --git a/XMonad/Layout/Magnifier.hs b/XMonad/Layout/Magnifier.hs new file mode 100644 index 0000000..bcff71d --- /dev/null +++ b/XMonad/Layout/Magnifier.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Magnifier +-- Copyright : (c) Peter De Wachter 2007 +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : Peter De Wachter +-- Stability : unstable +-- Portability : unportable +-- +-- Screenshot : +-- +-- This layout hack increases the size of the window that has focus. +-- +----------------------------------------------------------------------------- + + +module XMonad.Layout.Magnifier ( + -- * Usage + -- $usage + magnifier, magnifier') where + +import Graphics.X11.Xlib (Window, Rectangle(..)) +import XMonad +import XMonad.StackSet +import XMonad.Layout.LayoutHelpers + +-- $usage +-- > import XMonad.Layout.Magnifier +-- > layouts = [ magnifier tiled , magnifier $ mirror tiled ] + +-- %import XMonad.Layout.Magnifier +-- %layout , magnifier tiled +-- %layout , magnifier $ mirror tiled + +-- | Increase the size of the window that has focus, unless it is the master window. +magnifier :: Layout Window -> Layout Window +magnifier = layoutModify (unlessMaster applyMagnifier) idModMod + +-- | Increase the size of the window that has focus, even if it is the master window. +magnifier' :: Layout Window -> Layout Window +magnifier' = layoutModify applyMagnifier idModMod + +unlessMaster :: ModDo Window -> ModDo Window +unlessMaster mainmod r s wrs = if null (up s) then return (wrs, Nothing) + else mainmod r s wrs + +applyMagnifier :: ModDo Window +applyMagnifier r _ wrs = do focused <- withWindowSet (return . peek) + let mag (w,wr) ws | focused == Just w = ws ++ [(w, shrink r $ magnify wr)] + | otherwise = (w,wr) : ws + return (reverse $ foldr mag [] wrs, Nothing) + +magnify :: Rectangle -> Rectangle +magnify (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 * zoom + h' = round $ fromIntegral h * zoom + zoom = 1.5 :: Double + +shrink :: Rectangle -> Rectangle -> Rectangle +shrink (Rectangle sx sy sw sh) (Rectangle x y w h) = Rectangle x' y' w' h' + where x' = max sx x + y' = max sy y + w' = min w (fromIntegral sx + sw - fromIntegral x') + h' = min h (fromIntegral sy + sh - fromIntegral y') diff --git a/XMonad/Layout/Maximize.hs b/XMonad/Layout/Maximize.hs new file mode 100644 index 0000000..cf1e938 --- /dev/null +++ b/XMonad/Layout/Maximize.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Maximize +-- Copyright : (c) 2007 James Webb +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : xmonad#jwebb,sygneca,com +-- Stability : unstable +-- Portability : unportable +-- +-- Temporarily yanks the focused window out of the layout to mostly fill +-- the screen. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Maximize ( + -- * Usage + -- $usage + maximize, + maximizeRestore + ) where + +import Graphics.X11.Xlib +import XMonad +import XMonad.Layout.LayoutModifier +import Data.List ( partition ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Maximize +-- +-- > layouts = ... +-- > , Layout $ maximize $ tiled ... +-- > ... +-- +-- > keys = ... +-- > , ((modMask, xK_backslash), withFocused (sendMessage . maximizeRestore)) +-- > ... + +-- %import XMonad.Layout.Maximize +-- %layout , Layout $ maximize $ tiled + +data Maximize a = Maximize (Maybe Window) deriving ( Read, Show ) +maximize :: LayoutClass l Window => l Window -> ModifiedLayout Maximize l Window +maximize = ModifiedLayout $ Maximize Nothing + +data MaximizeRestore = MaximizeRestore Window deriving ( Typeable, Eq ) +instance Message MaximizeRestore +maximizeRestore :: Window -> MaximizeRestore +maximizeRestore = MaximizeRestore + +instance LayoutModifier Maximize Window where + modifierDescription (Maximize _) = "Maximize" + redoLayout (Maximize mw) rect _ wrs = case mw of + Just win -> + return (maxed ++ rest, Nothing) + where + maxed = map (\(w, _) -> (w, maxRect)) toMax + (toMax, rest) = partition (\(w, _) -> w == win) wrs + maxRect = Rectangle (rect_x rect + 50) (rect_y rect + 50) + (rect_width rect - 100) (rect_height rect - 100) + Nothing -> return (wrs, Nothing) + handleMess (Maximize mw) m = case fromMessage m of + Just (MaximizeRestore w) -> case mw of + Just _ -> return $ Just $ Maximize Nothing + Nothing -> return $ Just $ Maximize $ Just w + _ -> return Nothing + +-- vim: sw=4:et diff --git a/XMonad/Layout/Mosaic.hs b/XMonad/Layout/Mosaic.hs new file mode 100644 index 0000000..aec7aab --- /dev/null +++ b/XMonad/Layout/Mosaic.hs @@ -0,0 +1,407 @@ +{-# OPTIONS -fglasgow-exts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Mosaic +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- This module defines a \"mosaic\" layout, which tries to give each window a +-- user-configurable relative area, while also trying to give them aspect +-- ratios configurable at run-time by the user. +-- +----------------------------------------------------------------------------- +module XMonad.Layout.Mosaic ( + -- * Usage + -- $usage + mosaic, expandWindow, shrinkWindow, squareWindow, myclearWindow, + tallWindow, wideWindow, flexibleWindow, + getName, withNamedWindow ) where + +import Control.Monad.State ( State, put, get, runState ) +import System.Random ( StdGen, mkStdGen ) + +import Data.Ratio +import Graphics.X11.Xlib +import XMonad hiding ( trace ) +import XMonad.Operations ( full, Resize(Shrink, Expand) ) +import qualified XMonad.StackSet as W +import qualified Data.Map as M +import Data.List ( sort ) +import Data.Typeable ( Typeable ) +import Control.Monad ( mplus ) + +import XMonad.Util.NamedWindows +import XMonad.Util.Anneal + +-- $usage +-- +-- Key bindings: +-- +-- You can use this module with the following in your Config.hs: +-- +-- > import XMonad.Layout.Mosaic +-- +-- > layouts :: [Layout Window] +-- > layouts = [ mosaic 0.25 0.5 M.empty, full ] +-- +-- In the key-bindings, do something like: +-- +-- > , ((controlMask .|. modMask .|. shiftMask, xK_h), withNamedWindow (sendMessage . tallWindow)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_l), withNamedWindow (sendMessage . wideWindow)) +-- > , ((modMask .|. shiftMask, xK_h ), withNamedWindow (sendMessage . shrinkWindow)) +-- > , ((modMask .|. shiftMask, xK_l ), withNamedWindow (sendMessage . expandWindow)) +-- > , ((modMask .|. shiftMask, xK_s ), withNamedWindow (sendMessage . squareWindow)) +-- > , ((modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . myclearWindow)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . flexibleWindow)) +-- + +-- %import XMonad.Layout.Mosaic +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_h), withNamedWindow (sendMessage . tallWindow)) +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_l), withNamedWindow (sendMessage . wideWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_h ), withNamedWindow (sendMessage . shrinkWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_l ), withNamedWindow (sendMessage . expandWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_s ), withNamedWindow (sendMessage . squareWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . myclearWindow)) +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . flexibleWindow)) +-- %layout , mosaic 0.25 0.5 M.empty + +data HandleWindow = ExpandWindow NamedWindow | ShrinkWindow NamedWindow + | SquareWindow NamedWindow | ClearWindow NamedWindow + | TallWindow NamedWindow | WideWindow NamedWindow + | FlexibleWindow NamedWindow + deriving ( Typeable, Eq ) + +instance Message HandleWindow + +expandWindow, shrinkWindow, squareWindow, flexibleWindow, myclearWindow,tallWindow, wideWindow :: NamedWindow -> HandleWindow +expandWindow = ExpandWindow +shrinkWindow = ShrinkWindow +squareWindow = SquareWindow +flexibleWindow = FlexibleWindow +myclearWindow = ClearWindow +tallWindow = TallWindow +wideWindow = WideWindow + +largeNumber :: Int +largeNumber = 50 + +defaultArea :: Double +defaultArea = 1 + +flexibility :: Double +flexibility = 0.1 + +mosaic :: Double -> Double -> M.Map NamedWindow [WindowHint] -> Layout Window +mosaic delta tileFrac hints = full { doLayout = \r -> mosaicL tileFrac hints r . W.integrate + , modifyLayout = return . mlayout } + where mlayout x = (m1 `fmap` fromMessage x) `mplus` (m2 `fmap` fromMessage x) + m1 Shrink = mosaic delta (tileFrac/(1+delta)) hints + m1 Expand = mosaic delta (tileFrac*(1+delta)) hints + m2 (ExpandWindow w) = mosaic delta tileFrac (multiply_area (1+delta) w hints) + m2 (ShrinkWindow w) = mosaic delta tileFrac (multiply_area (1/(1+ delta)) w hints) + m2 (SquareWindow w) = mosaic delta tileFrac (set_aspect_ratio 1 w hints) + m2 (FlexibleWindow w) = mosaic delta tileFrac (make_flexible w hints) + m2 (TallWindow w) = mosaic delta tileFrac (multiply_aspect (1/(1+delta)) w hints) + m2 (WideWindow w) = mosaic delta tileFrac (multiply_aspect (1+delta) w hints) + m2 (ClearWindow w) = mosaic delta tileFrac (M.delete w hints) + +multiply_area :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +multiply_area a = alterlist f where f [] = [RelArea (defaultArea*a)] + f (RelArea a':xs) = RelArea (a'*a) : xs + f (x:xs) = x : f xs + +set_aspect_ratio :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +set_aspect_ratio r = alterlist f where f [] = [AspectRatio r] + f (FlexibleAspectRatio _:x) = AspectRatio r:x + f (AspectRatio _:x) = AspectRatio r:x + f (x:xs) = x:f xs + +make_flexible :: NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +make_flexible = alterlist (map f) where f (AspectRatio r) = FlexibleAspectRatio r + f (FlexibleAspectRatio r) = AspectRatio r + f x = x + +multiply_aspect :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +multiply_aspect r = alterlist f where f [] = [FlexibleAspectRatio r] + f (AspectRatio r':x) = AspectRatio (r*r'):x + f (FlexibleAspectRatio r':x) = FlexibleAspectRatio (r*r'):x + f (x:xs) = x:f xs + +findlist :: Ord k => k -> M.Map k [a] -> [a] +findlist = M.findWithDefault [] + +alterlist :: (Ord k, Ord a) => ([a] -> [a]) -> k -> M.Map k [a] -> M.Map k [a] +alterlist f k = M.alter f' k + where f' Nothing = f' (Just []) + f' (Just xs) = case f xs of + [] -> Nothing + xs' -> Just xs' + +mosaicL :: Double -> M.Map NamedWindow [WindowHint] + -> Rectangle -> [Window] -> X ([(Window, Rectangle)],Maybe (Layout Window)) +mosaicL _ _ _ [] = return ([], Nothing) +mosaicL f hints origRect origws + = do namedws <- mapM getName origws + let sortedws = reverse $ map the_value $ sort $ map (\w -> Rated (sumareas [w]) w) namedws + -- TODO: remove all this dead code + myv = runCountDown largeNumber $ mosaic_splits even_split origRect Vertical sortedws + myv2 = mc_mosaic sortedws Vertical + myh2 = mc_mosaic sortedws Horizontal +-- myv2 = maxL $ runCountDown largeNumber $ +-- sequence $ replicate mediumNumber $ +-- mosaic_splits one_split origRect Vertical sortedws + myh = runCountDown largeNumber $ mosaic_splits even_split origRect Horizontal sortedws +-- myh2 = maxL $ runCountDown largeNumber $ +-- sequence $ replicate mediumNumber $ +-- mosaic_splits one_split origRect Horizontal sortedws + return (map (\(nw,r)->(--trace ("rate1:"++ unlines [show nw, + -- show $ rate f meanarea (findlist nw hints) r, + -- show r, + -- show $ area r/meanarea, + -- show $ findlist nw hints]) $ + unName nw,crop' (findlist nw hints) r)) $ + flattenMosaic $ the_value $ maxL [myh,myv,myh2,myv2], Nothing) + where mosaic_splits _ _ _ [] = return $ Rated 0 $ M [] + mosaic_splits _ r _ [w] = return $ Rated (rate f meanarea (findlist w hints) r) $ OM (w,r) + mosaic_splits spl r d ws = maxL `fmap` mapCD (spl r d) (init $ allsplits ws) + even_split :: Rectangle -> CutDirection -> [[NamedWindow]] + -> State CountDown (Rated Double (Mosaic (NamedWindow, Rectangle))) + even_split r d [ws] = even_split r d $ map (:[]) ws + even_split r d wss = + do let areas = map sumareas wss + let wsr_s :: [([NamedWindow], Rectangle)] + wsr_s = zip wss (partitionR d r areas) + submosaics <- mapM (\(ws',r') -> + mosaic_splits even_split r' (otherDirection d) ws') wsr_s + return $ fmap M $ catRated submosaics + {- + another_mosaic :: [NamedWindow] -> CutDirection + -> Rated Double (Mosaic (NamedWindow,Rectangle)) + another_mosaic ws d = rate_mosaic ratew $ + rect_mosaic origRect d $ + zipML (example_mosaic ws) (map findarea ws) + -} + mc_mosaic :: [NamedWindow] -> CutDirection + -> Rated Double (Mosaic (NamedWindow,Rectangle)) + mc_mosaic ws d = fmap (rect_mosaic origRect d) $ + annealMax (zipML (example_mosaic ws) (map findarea ws)) + (the_rating . rate_mosaic ratew . rect_mosaic origRect d ) + changeMosaic + + ratew :: (NamedWindow,Rectangle) -> Double + ratew (w,r) = rate f meanarea (findlist w hints) r + example_mosaic :: [NamedWindow] -> Mosaic NamedWindow + example_mosaic ws = M (map OM ws) + rect_mosaic :: Rectangle -> CutDirection -> Mosaic (a,Double) -> Mosaic (a,Rectangle) + rect_mosaic r _ (OM (w,_)) = OM (w,r) + rect_mosaic r d (M ws) = M $ zipWith (\w' r' -> rect_mosaic r' d' w') ws rs + where areas = map (sum . map snd . flattenMosaic) ws + rs = partitionR d r areas + d' = otherDirection d + rate_mosaic :: ((NamedWindow,Rectangle) -> Double) + -> Mosaic (NamedWindow,Rectangle) -> Rated Double (Mosaic (NamedWindow,Rectangle)) + rate_mosaic r m = catRatedM $ fmap (\x -> Rated (r x) x) m +{- + one_split :: Rectangle -> CutDirection -> [[NamedWindow]] + -> State CountDown (Rated Double (Mosaic (NamedWindow, Rectangle))) + one_split r d [ws] = one_split r d $ map (:[]) ws + one_split r d wss = + do rnd <- mapM (const (fractional resolutionNumber)) [1..length wss] + let wsr_s :: [([NamedWindow], Rectangle)] + wsr_s = zip wss (partitionR d r rnd) + submosaics <- mapM (\(ws',r') -> + mosaic_splits even_split r' (otherDirection d) ws') wsr_s + return $ fmap M $ catRated submosaics +-} + partitionR :: CutDirection -> Rectangle -> [Double] -> [Rectangle] + partitionR _ _ [] = [] + partitionR _ r [_] = [r] + partitionR d r (a:ars) = r1 : partitionR d r2 ars + where totarea = sum (a:ars) + (r1,r2) = split d (a/totarea) r + theareas = hints2area `fmap` hints + sumareas ws = sum $ map findarea ws + findarea :: NamedWindow -> Double + findarea w = M.findWithDefault 1 w theareas + meanarea = area origRect / fromIntegral (length origws) + +maxL :: Ord a => [a] -> a +maxL [] = error "maxL on empty list" +maxL [a] = a +maxL (a:b:c) = maxL (max a b:c) + +catRated :: Floating v => [Rated v a] -> Rated v [a] +catRated xs = Rated (product $ map the_rating xs) (map the_value xs) + +catRatedM :: Floating v => Mosaic (Rated v a) -> Rated v (Mosaic a) +catRatedM (OM (Rated v x)) = Rated v (OM x) +catRatedM (M xs) = case catRated $ map catRatedM xs of Rated v xs' -> Rated v (M xs') + +data CountDown = CD !StdGen !Int + +tries_left :: State CountDown Int +tries_left = do CD _ n <- get + return (max 0 n) + +mapCD :: (a -> State CountDown b) -> [a] -> State CountDown [b] +mapCD f xs = do n <- tries_left + let len = length xs + mapM (run_with_only ((n `div` len)+1) . f) $ take (n+1) xs + +run_with_only :: Int -> State CountDown a -> State CountDown a +run_with_only limit j = + do CD g n <- get + let leftover = n - limit + if leftover < 0 then j + else do put $ CD g limit + x <- j + CD g' n' <- get + put $ CD g' (leftover + n') + return x + +data WindowHint = RelArea Double + | AspectRatio Double + | FlexibleAspectRatio Double + deriving ( Show, Read, Eq, Ord ) + +fixedAspect :: [WindowHint] -> Bool +fixedAspect [] = False +fixedAspect (AspectRatio _:_) = True +fixedAspect (_:x) = fixedAspect x + +rate :: Double -> Double -> [WindowHint] -> Rectangle -> Double +rate defaulta meanarea xs rr + | fixedAspect xs = (area (crop xs rr) / meanarea) ** weight + | otherwise = (area rr / meanarea)**(weight-flexibility) + * (area (crop (xs++[FlexibleAspectRatio defaulta]) rr) / meanarea)**flexibility + where weight = hints2area xs + +crop :: [WindowHint] -> Rectangle -> Rectangle +crop (AspectRatio f:_) = cropit f +crop (FlexibleAspectRatio f:_) = cropit f +crop (_:hs) = crop hs +crop [] = id + +crop' :: [WindowHint] -> Rectangle -> Rectangle +crop' (AspectRatio f:_) = cropit f +crop' (_:hs) = crop' hs +crop' [] = id + +cropit :: Double -> Rectangle -> Rectangle +cropit f (Rectangle a b w h) | w -/- h > f = Rectangle a b (ceiling $ h -* f) h + | otherwise = Rectangle a b w (ceiling $ w -/ f) + +hints2area :: [WindowHint] -> Double +hints2area [] = defaultArea +hints2area (RelArea r:_) = r +hints2area (_:x) = hints2area x + +area :: Rectangle -> Double +area (Rectangle _ _ w h) = fromIntegral w * fromIntegral h + +(-/-) :: (Integral a, Integral b) => a -> b -> Double +a -/- b = fromIntegral a / fromIntegral b + +(-/) :: (Integral a) => a -> Double -> Double +a -/ b = fromIntegral a / b + +(-*) :: (Integral a) => a -> Double -> Double +a -* b = fromIntegral a * b + +split :: CutDirection -> Double -> Rectangle -> (Rectangle, Rectangle) +split Vertical frac (Rectangle sx sy sw sh) = (Rectangle sx sy sw h, + Rectangle sx (sy+fromIntegral h) sw (sh-h)) + where h = floor $ fromIntegral sh * frac +split Horizontal frac (Rectangle sx sy sw sh) = (Rectangle sx sy w sh, + Rectangle (sx+fromIntegral w) sy (sw-w) sh) + where w = floor $ fromIntegral sw * frac + +data CutDirection = Vertical | Horizontal +otherDirection :: CutDirection -> CutDirection +otherDirection Vertical = Horizontal +otherDirection Horizontal = Vertical + +data Mosaic a = M [Mosaic a] | OM a + deriving ( Show ) + +instance Functor Mosaic where + fmap f (OM x) = OM (f x) + fmap f (M xs) = M (map (fmap f) xs) + +zipMLwith :: (a -> b -> c) -> Mosaic a -> [b] -> Mosaic c +zipMLwith f (OM x) (y:_) = OM (f x y) +zipMLwith _ (OM _) [] = error "bad zipMLwith" +zipMLwith f (M xxs) yys = makeM $ foo xxs yys + where foo (x:xs) ys = zipMLwith f x (take (lengthM x) ys) : + foo xs (drop (lengthM x) ys) + foo [] _ = [] + +zipML :: Mosaic a -> [b] -> Mosaic (a,b) +zipML = zipMLwith (\a b -> (a,b)) + +lengthM :: Mosaic a -> Int +lengthM (OM _) = 1 +lengthM (M x) = sum $ map lengthM x + +changeMosaic :: Mosaic a -> [Mosaic a] +changeMosaic (OM _) = [] +changeMosaic (M xs) = map makeM (concatenations xs) ++ + map makeM (splits xs) ++ + map M (tryAll changeMosaic xs) + +tryAll :: (a -> [a]) -> [a] -> [[a]] +tryAll _ [] = [] +tryAll f (x:xs) = map (:xs) (f x) ++ map (x:) (tryAll f xs) + +splits :: [Mosaic a] -> [[Mosaic a]] +splits [] = [] +splits (OM x:y) = map (OM x:) $ splits y +splits (M (x:y):z) = (x:makeM y:z) : map (makeM (x:y) :) (splits z) +splits (M []:x) = splits x + +concatenations :: [Mosaic a] -> [[Mosaic a]] +concatenations (x:y:z) = (concatenateMosaic x y:z):(map (x:) $ concatenations (y:z)) +concatenations _ = [] + +concatenateMosaic :: Mosaic a -> Mosaic a -> Mosaic a +concatenateMosaic (OM a) (OM b) = M [OM a, OM b] +concatenateMosaic (OM a) (M b) = M (OM a:b) +concatenateMosaic (M a) (OM b) = M (a++[OM b]) +concatenateMosaic (M a) (M b) = M (a++b) + +makeM :: [Mosaic a] -> Mosaic a +makeM [m] = m +makeM [] = error "makeM []" +makeM ms = M ms + +flattenMosaic :: Mosaic a -> [a] +flattenMosaic (OM a) = [a] +flattenMosaic (M xs) = concatMap flattenMosaic xs + +allsplits :: [a] -> [[[a]]] +allsplits [] = [[[]]] +allsplits [a] = [[[a]]] +allsplits (x:xs) = (map ([x]:) splitsrest) ++ (map (maphead (x:)) splitsrest) + where splitsrest = allsplits' xs + +allsplits' :: [a] -> [[[a]]] +allsplits' [] = [[[]]] +allsplits' [a] = [[[a]]] +allsplits' (x:xs) = (map (maphead (x:)) splitsrest) ++ (map ([x]:) splitsrest) + where splitsrest = allsplits xs + +maphead :: (a->a) -> [a] -> [a] +maphead f (x:xs) = f x : xs +maphead _ [] = [] + +runCountDown :: Int -> State CountDown a -> a +runCountDown n x = fst $ runState x (CD (mkStdGen n) n) diff --git a/XMonad/Layout/MosaicAlt.hs b/XMonad/Layout/MosaicAlt.hs new file mode 100644 index 0000000..a2b9e6a --- /dev/null +++ b/XMonad/Layout/MosaicAlt.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.MosaicAlt +-- Copyright : (c) 2007 James Webb +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : xmonad#jwebb,sygneca,com +-- Stability : unstable +-- Portability : unportable +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.MosaicAlt ( + -- * Usage: + -- $usage + MosaicAlt(..) + , shrinkWindowAlt + , expandWindowAlt + , tallWindowAlt + , wideWindowAlt + , resetAlt + ) where + +import XMonad +import XMonad.Layouts +import Graphics.X11.Xlib +import qualified XMonad.StackSet as W +import qualified Data.Map as M +import Data.List ( sortBy ) +import Data.Ratio +import Graphics.X11.Types ( Window ) + +-- $usage +-- You can use this module with the following in your configuration file: +-- +-- > import XMonad.Layout.MosaicAlt +-- +-- > layouts = ... +-- > , Layout $ MosaicAlt M.empty +-- > ... +-- +-- > keys = ... +-- > , ((modMask .|. shiftMask, xK_a), withFocused (sendMessage . expandWindowAlt)) +-- > , ((modMask .|. shiftMask, xK_z), withFocused (sendMessage . shrinkWindowAlt)) +-- > , ((modMask .|. shiftMask, xK_s), withFocused (sendMessage . tallWindowAlt)) +-- > , ((modMask .|. shiftMask, xK_d), withFocused (sendMessage . wideWindowAlt)) +-- > , ((modMask .|. controlMask, xK_space), sendMessage resetAlt) +-- > ... + +-- %import XMonad.Layout.MosaicAlt +-- %layout , Layout $ MosaicAlt M.empty + +data HandleWindowAlt = + ShrinkWindowAlt Window + | ExpandWindowAlt Window + | TallWindowAlt Window + | WideWindowAlt Window + | ResetAlt + deriving ( Typeable, Eq ) +instance Message HandleWindowAlt +shrinkWindowAlt, expandWindowAlt :: Window -> HandleWindowAlt +tallWindowAlt, wideWindowAlt :: Window -> HandleWindowAlt +shrinkWindowAlt = ShrinkWindowAlt +expandWindowAlt = ExpandWindowAlt +tallWindowAlt = TallWindowAlt +wideWindowAlt = WideWindowAlt +resetAlt :: HandleWindowAlt +resetAlt = ResetAlt + +data Param = Param { area, aspect :: Rational } deriving ( Show, Read ) +type Params = M.Map Window Param +data MosaicAlt a = MosaicAlt Params deriving ( Show, Read ) + +instance LayoutClass MosaicAlt Window where + description _ = "MosaicAlt" + doLayout (MosaicAlt params) rect stack = + 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 + + handleMessage (MosaicAlt params) msg = return $ case fromMessage msg of + Just (ShrinkWindowAlt w) -> Just $ MosaicAlt $ alter params w (4 % 5) 1 + Just (ExpandWindowAlt w) -> Just $ MosaicAlt $ alter params w (6 % 5) 1 + Just (TallWindowAlt w) -> Just $ MosaicAlt $ alter params w 1 (3 % 4) + Just (WideWindowAlt w) -> Just $ MosaicAlt $ alter params w 1 (5 % 4) + Just ResetAlt -> Just $ MosaicAlt M.empty + _ -> Nothing + +-- Change requested params for a window. +alter :: Params -> Window -> Rational -> Rational -> Params +alter params win arDelta asDelta = case M.lookup win params of + Just (Param ar as) -> M.insert win (Param (ar * arDelta) (as * asDelta)) params + Nothing -> M.insert win (Param arDelta (1.5 * asDelta)) params + +-- Layout algorithm entry point. +arrange :: Rectangle -> W.Stack Window -> Params -> [(Window, Rectangle)] +arrange rect stack params = r + where + (_, r) = findSplits 3 rect tree params + tree = makeTree (sortBy areaCompare wins) params + wins = reverse (W.up stack) ++ W.focus stack : W.down stack + areaCompare a b = or1 b `compare` or1 a + or1 w = maybe 1 area $ M.lookup w params + +-- Recursively group windows into a binary tree. Aim to balance the tree +-- according to the total requested area in each branch. +data Tree = Node (Rational, Tree) (Rational, Tree) | Leaf Window | None +makeTree :: [Window] -> Params -> Tree +makeTree wins params = case wins of + [] -> None + [x] -> Leaf x + _ -> Node (aArea, makeTree aWins params) (bArea, makeTree bWins params) + where ((aWins, aArea), (bWins, bArea)) = areaSplit params wins + +-- Split a list of windows in half by area. +areaSplit :: Params -> [Window] -> (([Window], Rational), ([Window], Rational)) +areaSplit params wins = gather [] 0 [] 0 wins + where + gather a aa b ba (r : rs) = + if aa <= ba + then gather (r : a) (aa + or1 r) b ba rs + else gather a aa (r : b) (ba + or1 r) rs + gather a aa b ba [] = ((reverse a, aa), (b, ba)) + or1 w = maybe 1 area $ M.lookup w params + +-- Figure out which ways to split the space, by exhaustive search. +-- Complexity is quadratic in the number of windows. +findSplits :: Int -> Rectangle -> Tree -> Params -> (Double, [(Window, Rectangle)]) +findSplits _ _ None _ = (0, []) +findSplits _ rect (Leaf w) params = (aspectBadness rect w params, [(w, rect)]) +findSplits depth rect (Node (aArea, aTree) (bArea, bTree)) params = + if hBadness < vBadness then (hBadness, hList) else (vBadness, vList) + where + (hBadness, hList) = trySplit splitHorizontallyBy + (vBadness, vList) = trySplit splitVerticallyBy + trySplit splitBy = + (aBadness + bBadness, aList ++ bList) + where + (aBadness, aList) = findSplits (depth - 1) aRect aTree params + (bBadness, bList) = findSplits (depth - 1) bRect bTree params + (aRect, bRect) = splitBy ratio rect + ratio = aArea / (aArea + bArea) + +-- Decide how much we like this rectangle. +aspectBadness :: Rectangle -> Window -> Params -> Double +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) + a = (w / h) / fromRational (maybe 1.5 aspect $ M.lookup win params) + w = fromIntegral $ rect_width rect + h = fromIntegral $ rect_height rect + +-- vim: sw=4:et diff --git a/XMonad/Layout/NoBorders.hs b/XMonad/Layout/NoBorders.hs new file mode 100644 index 0000000..8aa64fb --- /dev/null +++ b/XMonad/Layout/NoBorders.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.NoBorders +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.NoBorders ( + -- * Usage + -- $usage + noBorders, + smartBorders, + withBorder + ) where + +import Control.Monad.State (gets) +import Control.Monad.Reader (asks) +import Graphics.X11.Xlib + +import XMonad +import XMonad.Layout.LayoutModifier +import qualified XMonad.StackSet as W +import Data.List ((\\)) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.NoBorders +-- +-- and modify the layouts to call noBorders on the layouts you want to lack +-- borders +-- +-- > layouts = [ Layout (noBorders Full), ... ] +-- + +-- %import XMonad.Layout.NoBorders +-- %layout -- prepend noBorders to default layouts above to remove their borders, like so: +-- %layout , noBorders Full + +-- todo, use an InvisibleList. +data WithBorder a = WithBorder Dimension [a] deriving ( Read, Show ) + +instance LayoutModifier WithBorder Window where + modifierDescription (WithBorder 0 _) = "NoBorders" + modifierDescription (WithBorder n _) = "Borders " ++ show n + + unhook (WithBorder _ s) = asks (borderWidth . config) >>= setBorders s + + redoLayout (WithBorder n s) _ _ wrs = do + asks (borderWidth . config) >>= setBorders (s \\ ws) + setBorders ws n + return (wrs, Just $ WithBorder n ws) + where + ws = map fst wrs + +noBorders :: LayoutClass l Window => l Window -> ModifiedLayout WithBorder l Window +noBorders = ModifiedLayout $ WithBorder 0 [] + +withBorder :: LayoutClass l a => Dimension -> l a -> ModifiedLayout WithBorder l a +withBorder b = ModifiedLayout $ WithBorder b [] + +setBorders :: [Window] -> Dimension -> X () +setBorders ws bw = withDisplay $ \d -> mapM_ (\w -> io $ setWindowBorderWidth d w bw) ws + +data SmartBorder a = SmartBorder [a] deriving (Read, Show) + +instance LayoutModifier SmartBorder Window where + modifierDescription _ = "SmartBorder" + + unhook (SmartBorder s) = asks (borderWidth . config) >>= setBorders s + + redoLayout (SmartBorder s) _ _ wrs = do + ss <- gets (W.screens . windowset) + + if singleton ws && singleton ss + then do + asks (borderWidth . config) >>= setBorders (s \\ ws) + setBorders ws 0 + return (wrs, Just $ SmartBorder ws) + else do + asks (borderWidth . config) >>= setBorders s + return (wrs, Just $ SmartBorder []) + where + ws = map fst wrs + singleton = null . drop 1 + +-- +-- | You can cleverly set no borders on a range of layouts, using a +-- layoutHook like so: +-- +-- > layoutHook = Layout $ smartBorders $ Select layouts +-- +smartBorders :: LayoutClass l a => l a -> ModifiedLayout SmartBorder l a +smartBorders = ModifiedLayout (SmartBorder []) diff --git a/XMonad/Layout/ResizableTile.hs b/XMonad/Layout/ResizableTile.hs new file mode 100644 index 0000000..a70a987 --- /dev/null +++ b/XMonad/Layout/ResizableTile.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ResizableTile +-- Copyright : (c) MATSUYAMA Tomohiro +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : MATSUYAMA Tomohiro +-- Stability : unstable +-- Portability : unportable +-- +-- More useful tiled layout that allows you to change a width\/height of window. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.ResizableTile ( + -- * Usage + -- $usage + ResizableTall(..), MirrorResize(..) + ) where + +import XMonad +import XMonad.Layouts (Resize(..), IncMasterN(..)) +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Control.Monad.State +import Control.Monad + +-- $usage +-- +-- To use, modify your Config.hs to: +-- +-- > import XMonad.Layout.ResizableTile +-- +-- and add a keybinding: +-- +-- > , ((modMask, xK_a ), sendMessage MirrorShrink) +-- > , ((modMask, xK_z ), sendMessage MirrorExpand) +-- +-- and redefine "tiled" as: +-- +-- > tiled = ResizableTall nmaster delta ratio [] + +data MirrorResize = MirrorShrink | MirrorExpand deriving Typeable +instance Message MirrorResize + +data ResizableTall a = ResizableTall Int Rational Rational [Rational] deriving (Show, Read) +instance LayoutClass ResizableTall a where + doLayout (ResizableTall nmaster _ frac mfrac) r = + return . (\x->(x,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 + case ms of + Nothing -> return Nothing + Just s -> return $ msum [fmap resize (fromMessage m) + ,fmap (\x -> mresize x s) (fromMessage m) + ,fmap incmastern (fromMessage m)] + where 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' s d = let n = length $ W.up s + 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' + modifymfrac [] _ _ = [] + modifymfrac (f:fx) d n | n == 0 = f+d : fx + | otherwise = f : modifymfrac fx d (n-1) + incmastern (IncMasterN d) = ResizableTall (max 0 (nmaster+d)) delta frac mfrac + description _ = "ResizableTall" + +tile :: Rational -> [Rational] -> Rectangle -> Int -> Int -> [Rectangle] +tile f mf r nmaster n = if n <= nmaster || nmaster == 0 + then splitVertically mf n r + else splitVertically mf nmaster r1 ++ splitVertically (drop nmaster mf) (n-nmaster) r2 -- two columns + where (r1,r2) = splitHorizontallyBy f r + +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) = Rectangle sx sy sw smallh : + splitVertically fx (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) + where smallh = floor $ fromIntegral (sh `div` fromIntegral n) * f --hmm, this is a fold or map. + +splitHorizontallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle) +splitHorizontallyBy f (Rectangle sx sy sw sh) = + ( Rectangle sx sy leftw sh + , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) + where leftw = floor $ fromIntegral sw * f diff --git a/XMonad/Layout/Roledex.hs b/XMonad/Layout/Roledex.hs new file mode 100644 index 0000000..0c4eb5f --- /dev/null +++ b/XMonad/Layout/Roledex.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Roledex +-- Copyright : (c) tim.thelion@gmail.com +-- License : BSD +-- +-- Maintainer : tim.thelion@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- Screenshot : +-- +-- This is a completely pointless layout which acts like Microsoft's Flip 3D +----------------------------------------------------------------------------- + +module XMonad.Layout.Roledex ( + -- * Usage + -- $usage + Roledex(Roledex)) where + +import XMonad +import XMonad.Layouts +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Data.Ratio + +-- $usage +-- +-- > import XMonad.Layout.Roledex +-- > layouts = [ Layout Roledex ] + +-- %import XMonad.Layout.Roledex +-- %layout , Layout Roledex + +data Roledex a = Roledex deriving ( Show, Read ) + +instance LayoutClass Roledex Window where + doLayout _ = roledexLayout + +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)) + ,Nothing) + where ups = W.up ws + dns = W.down ws + c = length ups + length dns + rect = fst $ splitHorizontallyBy (2%3 :: Ratio Int) $ fst (splitVerticallyBy (2%3 :: Ratio Int) sc) + gw = div' (w - rw) (fromIntegral c) + where + (Rectangle _ _ w _) = sc + (Rectangle _ _ rw _) = rect + gh = div' (h - rh) (fromIntegral c) + where + (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 + tops = map f $ cd c (length dns) + 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) + else [] + +div' :: Integral a => a -> a -> a +div' _ 0 = 0 +div' n o = div n o diff --git a/XMonad/Layout/Spiral.hs b/XMonad/Layout/Spiral.hs new file mode 100644 index 0000000..013a017 --- /dev/null +++ b/XMonad/Layout/Spiral.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Spiral +-- Copyright : (c) Joe Thornber +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Joe Thornber +-- Stability : stable +-- Portability : portable +-- +-- Spiral adds a spiral tiling layout +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Spiral ( + -- * Usage + -- $usage + spiral + , spiralWithDir + , Rotation (..) + , Direction (..) + ) where + +import Graphics.X11.Xlib +import XMonad.Operations +import Data.Ratio +import XMonad +import XMonad.Layouts +import XMonad.StackSet ( integrate ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Spiral +-- +-- > layouts = [ ..., Layout $ spiral (1 % 1), ... ] + +-- %import XMonad.Layout.Spiral +-- %layout , Layout $ spiral (1 % 1) + +fibs :: [Integer] +fibs = 1 : 1 : (zipWith (+) fibs (tail fibs)) + +mkRatios :: [Integer] -> [Rational] +mkRatios (x1:x2:xs) = (x1 % x2) : mkRatios (x2:xs) +mkRatios _ = [] + +data Rotation = CW | CCW deriving (Read, Show) +data Direction = East | South | West | North deriving (Eq, Enum, Read, Show) + +blend :: Rational -> [Rational] -> [Rational] +blend scale ratios = zipWith (+) ratios scaleFactors + where + len = length ratios + step = (scale - (1 % 1)) / (fromIntegral len) + scaleFactors = map (* step) . reverse . take len $ [0..] + +spiral :: Rational -> SpiralWithDir a +spiral = spiralWithDir East CW + +spiralWithDir :: Direction -> Rotation -> Rational -> SpiralWithDir a +spiralWithDir = SpiralWithDir + +data SpiralWithDir a = SpiralWithDir Direction Rotation Rational + deriving ( Read, Show ) + +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 + rects = divideRects (zip ratios dirs) sc + dirs = dropWhile (/= dir) $ case rot of + CW -> cycle [East .. North] + CCW -> cycle [North, West, South, East] + handleMessage (SpiralWithDir dir rot scale) = return . fmap resize . fromMessage + where resize Expand = spiralWithDir dir rot $ (21 % 20) * scale + resize Shrink = spiralWithDir dir rot $ (20 % 21) * scale + description _ = "Spiral" + +-- This will produce one more rectangle than there are splits details +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) + +-- It's much simpler if we work with all Integers and convert to +-- Rectangle at the end. +data Rect = Rect Integer Integer Integer Integer + +fromRect :: Rect -> Rectangle +fromRect (Rect x y w h) = Rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + +toRect :: Rectangle -> Rect +toRect (Rectangle x y w h) = Rect (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + +divideRect :: Rational -> Direction -> Rectangle -> (Rectangle, Rectangle) +divideRect r d rect = let (r1, r2) = divideRect' r d $ toRect rect in + (fromRect r1, fromRect r2) + +divideRect' :: Rational -> Direction -> Rect -> (Rect, Rect) +divideRect' ratio dir (Rect x y w h) = + case dir of + East -> let (w1, w2) = chop ratio w in (Rect x y w1 h, Rect (x + w1) y w2 h) + South -> let (h1, h2) = chop ratio h in (Rect x y w h1, Rect x (y + h1) w h2) + West -> let (w1, w2) = chop (1 - ratio) w in (Rect (x + w1) y w2 h, Rect x y w1 h) + 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 + (f, n - f) diff --git a/XMonad/Layout/Square.hs b/XMonad/Layout/Square.hs new file mode 100644 index 0000000..e05f549 --- /dev/null +++ b/XMonad/Layout/Square.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Square +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- 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). +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Square ( + -- * Usage + -- $usage + Square(..) ) where + +import XMonad +import Graphics.X11.Xlib +import XMonad.StackSet ( integrate ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Square +-- +-- An example layout using square together with "XMonad.Layout.Combo" +-- to make the very last area square: +-- +-- > , combo (combo (mirror $ twoPane 0.03 0.85),1)] (twoPane 0.03 0.5) ) +-- > [(twoPane 0.03 0.2,1),(combo [(twoPane 0.03 0.8,1),(square,1)] +-- > [(tabbed,3),(tabbed,30),(tabbed,1),(tabbed,1)] + +-- %import XMonad.Layout.Square + +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)] + arrange [] = [] -- actually, this is an impossible case + (rest, sq) = splitSquare r + +splitSquare :: Rectangle -> (Rectangle, Rectangle) +splitSquare (Rectangle x y w h) + | w > h = (Rectangle x y (w - h) h, Rectangle (x+fromIntegral (w-h)) y h h) + | otherwise = (Rectangle x y w (h-w), Rectangle x (y+fromIntegral (h-w)) w w) diff --git a/XMonad/Layout/SwitchTrans.hs b/XMonad/Layout/SwitchTrans.hs new file mode 100644 index 0000000..986202e --- /dev/null +++ b/XMonad/Layout/SwitchTrans.hs @@ -0,0 +1,194 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.SwitchTrans +-- Copyright : (c) Lukas Mai +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : +-- Stability : unstable +-- Portability : unportable +-- +-- +-- Ordinary layout transformers are simple and easy to use but inflexible. +-- This module provides a more structured interface to them. +-- +-- The basic idea is to have a base layout and a set of layout transformers, +-- of which at most one is active at any time. Enabling another transformer +-- first disables any currently active transformer; i.e. it works like +-- a group of radio buttons. +-- +-- A side effect of this meta-layout is that layout transformers no longer +-- receive any messages; any message not handled by @SwitchTrans@ itself will +-- undo the current layout transformer, pass the message on to the base layout, +-- then reapply the transformer. +-- +-- Another potential problem is that functions can't be (de-)serialized so this +-- layout will not preserve state across xmonad restarts. +-- +-- Here's how you might use this in Config.hs: +-- +-- > layouts = +-- > map ( +-- > mkSwitch (M.fromList [ +-- > ("full", const $ Layout $ noBorders Full) +-- > ]) . +-- > mkSwitch (M.fromList [ +-- > ("mirror", Layout . Mirror) +-- > ]) +-- > ) [ Layout tiled ] +-- +-- (The @noBorders@ transformer is from "XMonad.Layout.NoBorders".) +-- +-- This example is probably overkill but it's very close to what I actually use. +-- Anyway, this layout behaves like the default @tiled@ layout, until you send it +-- @Enable@\/@Disable@\/@Toggle@ messages. From the definition of @keys@: +-- +-- > ... +-- > , ((modMask, xK_f ), sendMessage $ Toggle "full") +-- > , ((modMask, xK_r ), sendMessage $ Toggle "mirror") +-- +-- (You may want to use other keys. I don't use Xinerama so the default mod-r +-- binding is useless to me.) +-- +-- After this, pressing @mod-f@ switches the current window to fullscreen mode. +-- Pressing @mod-f@ again switches it back. Similarly, @mod-r@ rotates the layout +-- by 90 degrees (and back). The nice thing is that your changes are kept: +-- Rotating first then changing the size of the master area then rotating back +-- does not undo the master area changes. +-- +-- The reason I use two stacked @SwitchTrans@ transformers instead of @mkSwitch +-- (M.fromList [(\"full\", const $ Layout $ noBorders Full), (\"mirror\", +-- Layout . Mirror)])@ is that I use @mod-f@ to \"zoom in\" on interesting +-- windows, no matter what other layout transformers may be active. Having an +-- extra fullscreen mode on top of everything else means I can zoom in and out +-- without implicitly undoing \"normal\" layout transformers, like @Mirror@. +-- Remember, inside a @SwitchTrans@ there can be at most one active layout +-- transformer. +----------------------------------------------------------------------------- + +module XMonad.Layout.SwitchTrans ( + Toggle(..), + Enable(..), + Disable(..), + mkSwitch +) where + +import XMonad +import XMonad.Operations + +import qualified Data.Map as M +import Data.Map (Map) + +--import System.IO + + +-- | Toggle the specified layout transformer. +data Toggle = Toggle String deriving (Eq, Typeable) +instance Message Toggle +-- | Enable the specified transformer. +data Enable = Enable String deriving (Eq, Typeable) +instance Message Enable +-- | Disable the specified transformer. +data Disable = Disable String deriving (Eq, Typeable) +instance Message Disable + +data SwitchTrans a = SwitchTrans { + base :: Layout a, + currTag :: Maybe String, + currLayout :: Layout a, + currFilt :: Layout a -> Layout a, + filters :: Map String (Layout a -> Layout a) +} + +instance Show (SwitchTrans a) where + show st = "SwitchTrans #" + +instance Read (SwitchTrans a) where + readsPrec _ _ = [] + +unLayout :: Layout a -> (forall l. (LayoutClass l a) => l a -> r) -> r +unLayout (Layout l) k = k l + +acceptChange :: (LayoutClass l a) => SwitchTrans a -> ((l a -> SwitchTrans a) -> b -> c) -> X b -> X c +acceptChange st f action = + -- seriously, Dave, you need to stop this + fmap (f (\l -> st{ currLayout = Layout l})) action + +instance LayoutClass SwitchTrans a where + description _ = "SwitchTrans" + + doLayout st r s = currLayout st `unLayout` \l -> do + --io $ hPutStrLn stderr $ "[ST]{ " ++ show st + x{- @(_, w) -} <- acceptChange st (fmap . fmap) (doLayout l r s) + --io $ hPutStrLn stderr $ "[ST]} " ++ show w + return x + + pureLayout st r s = currLayout st `unLayout` \l -> pureLayout l r s + + handleMessage st m + | Just (Disable tag) <- fromMessage m + , M.member tag (filters st) + = provided (currTag st == Just tag) $ disable + | Just (Enable tag) <- fromMessage m + , Just alt <- M.lookup tag (filters st) + = provided (currTag st /= Just tag) $ enable tag alt + | Just (Toggle tag) <- fromMessage m + , Just alt <- M.lookup tag (filters st) + = + if (currTag st == Just tag) then + disable + else + enable tag alt + | Just ReleaseResources <- fromMessage m + = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]~ " ++ show st + acceptChange st fmap (handleMessage cl m) + | Just Hide <- fromMessage m + = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]< " ++ show st + x <- acceptChange st fmap (handleMessage cl m) + --io $ hPutStrLn stderr $ "[ST]> " ++ show x + return x + | otherwise = base st `unLayout` \b -> do + x <- handleMessage b m + case x of + Nothing -> return Nothing + Just b' -> currLayout st `unLayout` \cl -> do + handleMessage cl (SomeMessage ReleaseResources) + let b'' = Layout b' + return . Just $ st{ base = b'', currLayout = currFilt st b'' } + where + enable tag alt = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]+ " ++ show cl ++ " -> " ++ show (alt (base st)) + handleMessage cl (SomeMessage ReleaseResources) + return . Just $ st{ + currTag = Just tag, + currFilt = alt, + currLayout = alt (base st) } + disable = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]- " ++ show cl ++ " -> " ++ show (base st) + handleMessage cl (SomeMessage ReleaseResources) + return . Just $ st{ + currTag = Nothing, + currFilt = id, + currLayout = base st } + +-- | Take a transformer table and a base layout, and return a +-- SwitchTrans layout. +mkSwitch :: Map String (Layout a -> Layout a) -> Layout a -> Layout a +mkSwitch fs b = Layout st + where + st = SwitchTrans{ + base = b, + currTag = Nothing, + currLayout = b, + currFilt = id, + filters = fs } + +provided :: Bool -> X (Maybe a) -> X (Maybe a) +provided c x + | c = x + | otherwise = return Nothing + diff --git a/XMonad/Layout/Tabbed.hs b/XMonad/Layout/Tabbed.hs new file mode 100644 index 0000000..92ef150 --- /dev/null +++ b/XMonad/Layout/Tabbed.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Tabbed +-- Copyright : (c) 2007 David Roundy, Andrea Rossato +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : droundy@darcs.net, andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A tabbed layout for the Xmonad Window Manager +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Tabbed ( + -- * Usage: + -- $usage + tabbed + , shrinkText + , TConf (..), defaultTConf + ) where + +import Control.Monad.State ( gets ) +import Control.Monad.Reader +import Data.Maybe +import Data.Bits +import Data.List + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad +import XMonad.Operations +import qualified XMonad.StackSet as W + +import XMonad.Util.NamedWindows +import XMonad.Util.Invisible +import XMonad.Util.XUtils + +-- $usage +-- You can use this module with the following in your configuration file: +-- +-- > import XMonad.Layout.Tabbed +-- +-- > layouts :: [Layout Window] +-- > layouts = [ Layout tiled +-- > , Layout $ Mirror tiled +-- > , Layout Full +-- > +-- > -- Extension-provided layouts +-- > , Layout $ tabbed shrinkText defaultTConf +-- > ] +-- > +-- > , ... ] +-- +-- You can also edit the default configuration options. +-- +-- > myTabConfig = defaultTConf { inactiveBorderColor = "#FF0000" +-- > , activeTextColor = "#00FF00"} +-- +-- and +-- +-- > layouts = [ ... +-- > , Layout $ tabbed shrinkText myTabConfig ] + +-- %import XMonad.Layout.Tabbed +-- %layout , tabbed shrinkText defaultTConf + +tabbed :: Shrinker -> TConf -> Tabbed a +tabbed s t = Tabbed (I Nothing) (I (Just s)) t + +data TConf = + TConf { activeColor :: String + , inactiveColor :: String + , activeBorderColor :: String + , inactiveTextColor :: String + , inactiveBorderColor :: String + , activeTextColor :: String + , fontName :: String + , tabSize :: Int + } deriving (Show, Read) + +defaultTConf :: TConf +defaultTConf = + TConf { activeColor = "#999999" + , inactiveColor = "#666666" + , activeBorderColor = "#FFFFFF" + , inactiveBorderColor = "#BBBBBB" + , activeTextColor = "#FFFFFF" + , inactiveTextColor = "#BFBFBF" + , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , tabSize = 20 + } + +data TabState = + TabState { tabsWindows :: [(Window,Window)] + , scr :: Rectangle + , fontS :: FontStruct -- FontSet + } + +data Tabbed a = + Tabbed (Invisible Maybe TabState) (Invisible Maybe Shrinker) TConf + deriving (Show, Read) + +instance LayoutClass Tabbed Window where + doLayout (Tabbed ist ishr conf) = doLay ist ishr conf + handleMessage = handleMess + description _ = "Tabbed" + +doLay :: Invisible Maybe TabState -> Invisible Maybe Shrinker -> TConf + -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed Window)) +doLay ist ishr c sc (W.Stack w [] []) = do + whenIJust ist $ \st -> mapM_ deleteWindow (map fst $ tabsWindows st) + return ([(w,sc)], Just $ Tabbed (I Nothing) ishr c) +doLay ist ishr conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do + let ws = W.integrate s + width = wid `div` fromIntegral (length ws) + -- initialize state + st <- case ist of + (I Nothing ) -> initState conf sc ws + (I (Just ts)) -> if map snd (tabsWindows ts) == ws && scr ts == sc + then return ts + else do mapM_ deleteWindow (map fst $ tabsWindows ts) + tws <- createTabs conf sc ws + return (ts {scr = sc, tabsWindows = zip tws ws}) + mapM_ showWindow $ map fst $ tabsWindows st + mapM_ (updateTab ishr conf (fontS st) width) $ tabsWindows st + return ([(w,shrink conf sc)], Just (Tabbed (I (Just st)) ishr conf)) + +handleMess :: Tabbed Window -> SomeMessage -> X (Maybe (Tabbed Window)) +handleMess (Tabbed (I (Just st@(TabState {tabsWindows = tws}))) ishr conf) m + | Just e <- fromMessage m :: Maybe Event = handleEvent ishr conf st e >> return Nothing + | Just Hide == fromMessage m = mapM_ hideWindow (map fst tws) >> return Nothing + | Just ReleaseResources == fromMessage m = do mapM_ deleteWindow $ map fst tws + releaseFont (fontS st) + return $ Just $ Tabbed (I Nothing) (I Nothing) conf +handleMess _ _ = return Nothing + +handleEvent :: Invisible Maybe Shrinker -> TConf -> TabState -> Event -> X () +-- button press +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t }) + | t == buttonPress, tl <- map fst tws, thisw `elem` tl || thisbw `elem` tl = do + case lookup thisw tws of + Just x -> do focus x + updateTab ishr conf fs width (thisw, x) + Nothing -> return () + where width = rect_width screen `div` fromIntegral (length tws) +-- propertyNotify +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (PropertyEvent {ev_window = thisw }) + | thisw `elem` (map snd tws) = do + let tabwin = (fst $ fromJust $ find ((== thisw) . snd) tws, thisw) + updateTab ishr conf fs width tabwin + where width = rect_width screen `div` fromIntegral (length tws) +-- expose +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (ExposeEvent {ev_window = thisw }) + | thisw `elem` (map fst tws) = do + updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws) + where width = rect_width screen `div` fromIntegral (length tws) +handleEvent _ _ _ _ = return () + +initState :: TConf -> Rectangle -> [Window] -> X TabState +initState conf sc ws = do + fs <- initFont (fontName conf) + tws <- createTabs conf sc ws + return $ TabState (zip tws ws) sc fs + +createTabs :: TConf -> Rectangle -> [Window] -> X [Window] +createTabs _ _ [] = return [] +createTabs c (Rectangle x y wh ht) owl@(ow:ows) = do + let wid = wh `div` (fromIntegral $ length owl) + height = fromIntegral $ tabSize c + mask = Just (exposureMask .|. buttonPressMask) + d <- asks display + w <- createNewWindow (Rectangle x y wid height) mask (inactiveColor c) + io $ restackWindows d $ w : [ow] + ws <- createTabs c (Rectangle (x + fromIntegral wid) y (wh - wid) ht) ows + return (w:ws) + +updateTab :: Invisible Maybe Shrinker -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X () +updateTab ishr c fs wh (tabw,ow) = do + nw <- getName ow + let ht = fromIntegral $ tabSize c :: Dimension + focusColor win ic ac = (maybe ic (\focusw -> if focusw == win + then ac else ic) . W.peek) + `fmap` gets windowset + (bc',borderc',tc') <- focusColor ow + (inactiveColor c, inactiveBorderColor c, inactiveTextColor c) + (activeColor c, activeBorderColor c, activeTextColor c) + let s = fromIMaybe shrinkText ishr + name = shrinkWhile s (\n -> textWidth fs n > + fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) + paintAndWrite tabw fs wh ht 1 bc' borderc' tc' bc' AlignCenter name + +shrink :: TConf -> Rectangle -> Rectangle +shrink c (Rectangle x y w h) = + Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c)) + +type Shrinker = String -> [String] + +shrinkWhile :: Shrinker -> (String -> Bool) -> String -> String +shrinkWhile sh p x = sw $ sh x + where sw [n] = n + sw [] = "" + sw (n:ns) | p n = sw ns + | otherwise = n + +shrinkText :: Shrinker +shrinkText "" = [""] +shrinkText cs = cs : shrinkText (init cs) diff --git a/XMonad/Layout/ThreeColumns.hs b/XMonad/Layout/ThreeColumns.hs new file mode 100644 index 0000000..2dd2551 --- /dev/null +++ b/XMonad/Layout/ThreeColumns.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ThreeColumns +-- Copyright : (c) Kai Grossjohann +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : ? +-- Stability : unstable +-- Portability : unportable +-- +-- A layout similar to tall but with three columns. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.ThreeColumns ( + -- * Usage + -- $usage + ThreeCol(..) + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Layouts ( Resize(..), IncMasterN(..), splitVertically, splitHorizontallyBy ) + +import Data.Ratio + +--import Control.Monad.State +import Control.Monad.Reader + +import Graphics.X11.Xlib + +-- $usage +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.ThreeColumns +-- +-- and add, to the list of layouts: +-- +-- > ThreeCol nmaster delta ratio + +-- %import XMonad.Layout.ThreeColumns +-- %layout , ThreeCol nmaster delta ratio + +data ThreeCol a = ThreeCol Int Rational Rational deriving (Show,Read) + +instance LayoutClass ThreeCol a where + doLayout (ThreeCol nmaster _ frac) r = + return . (\x->(x,Nothing)) . + ap zip (tile3 frac r nmaster . length) . W.integrate + handleMessage (ThreeCol nmaster delta frac) m = + return $ msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] + where resize Shrink = ThreeCol nmaster delta (max 0 $ frac-delta) + resize Expand = ThreeCol nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = ThreeCol (max 0 (nmaster+d)) delta frac + description _ = "ThreeCol" + +-- | tile3. Compute window positions using 3 panes +tile3 :: Rational -> Rectangle -> Int -> Int -> [Rectangle] +tile3 f r nmaster n + | n <= nmaster || nmaster == 0 = splitVertically n r + | n <= nmaster+1 = splitVertically nmaster s1 ++ splitVertically (n-nmaster) s2 + | otherwise = splitVertically nmaster r1 ++ splitVertically nmid r2 ++ splitVertically nright r3 + where (r1, r2, r3) = split3HorizontallyBy f r + (s1, s2) = splitHorizontallyBy f r + nslave = (n - nmaster) + nmid = ceiling (nslave % 2) + nright = (n - nmaster - nmid) + +split3HorizontallyBy :: Rational -> Rectangle -> (Rectangle, Rectangle, Rectangle) +split3HorizontallyBy f (Rectangle sx sy sw sh) = + ( Rectangle sx sy leftw sh + , Rectangle (sx + fromIntegral leftw) sy midw sh + , Rectangle (sx + fromIntegral leftw + fromIntegral midw) sy rightw sh ) + where leftw = ceiling $ fromIntegral sw * (2/3) * f + midw = ceiling ( (sw - leftw) % 2 ) + rightw = sw - leftw - midw diff --git a/XMonad/Layout/TilePrime.hs b/XMonad/Layout/TilePrime.hs new file mode 100644 index 0000000..36d54f6 --- /dev/null +++ b/XMonad/Layout/TilePrime.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} +-- -------------------------------------------------------------------------- +-- -- | +-- -- Module : TilePrime.hs +-- -- Copyright : (c) Eric Mertens 2007 +-- -- License : BSD3-style (see LICENSE) +-- -- +-- -- Maintainer : emertens@gmail.com +-- -- Stability : unstable +-- -- Portability : not portable +-- -- +-- -- TilePrime. Tile windows filling gaps created by resize hints +-- -- +-- ----------------------------------------------------------------------------- +-- + +module XMonad.Layout.TilePrime ( + -- * Usage + -- $usage + TilePrime(TilePrime) + ) where + +import Control.Monad (mplus) +import Data.List (mapAccumL) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras (getWMNormalHints) +import XMonad.Operations +import XMonad hiding (trace) +import qualified XMonad.StackSet as W +import {-#SOURCE#-} Config (borderWidth) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.TilePrime +-- +-- and add the following line to your 'layouts' +-- +-- > , Layout $ TilePrime nmaster delta ratio False +-- +-- Use True as the last argument to get a wide layout. + +-- %import XMonad.Layout.TilePrime +-- %layout , Layout $ TilePrime nmaster delta ratio False + +data TilePrime a = TilePrime + { nmaster :: Int + , delta, frac :: Rational + , flipped :: Bool + } deriving (Show, Read) + +instance LayoutClass TilePrime Window where + description c | flipped c = "TilePrime Horizontal" + | otherwise = "TilePrime Vertical" + + pureMessage c m = fmap resize (fromMessage m) `mplus` + fmap incmastern (fromMessage m) + where + resize Shrink = c { frac = max 0 $ frac c - delta c } + resize Expand = c { frac = min 1 $ frac c + delta c } + incmastern (IncMasterN d) = c { nmaster = max 0 $ nmaster c + d } + + doLayout TilePrime { frac = f, nmaster = m, flipped = flp } rect s = do + let xs = W.integrate s + hints <- withDisplay $ \ disp -> io (mapM (getWMNormalHints disp) xs) + let xs' = zip xs hints + (leftXs, rightXs) = splitAt m xs' + (leftRect, rightRect) + | null rightXs = (rect, Rectangle 0 0 0 0) + | null leftXs = (Rectangle 0 0 0 0, rect) + | flp = splitVerticallyBy f rect + | otherwise = splitHorizontallyBy f rect + masters = fillWindows leftRect leftXs + slaves = fillWindows rightRect rightXs + return (masters ++ slaves, Nothing) + + where + fillWindows r xs = snd $ mapAccumL aux (r,n) xs + where n = fromIntegral (length xs) :: Rational + + aux (r,n) (x,hint) = ((rest,n-1),(x,r')) + where + (allocated, _) | flp = splitHorizontallyBy (recip n) r + | otherwise = splitVerticallyBy (recip n) r + + (w,h) = applySizeHints hint `underBorders` rect_D allocated + + r' = r { rect_width = w, rect_height = h } + + rest | flp = r { rect_x = rect_x r + toEnum (fromEnum w) + , rect_width = rect_width r - w } + | otherwise = r { rect_y = rect_y r + toEnum (fromEnum h) + , rect_height = rect_height r - h } + +rect_D :: Rectangle -> D +rect_D Rectangle { rect_width = w, rect_height = h } = (w,h) + +-- | Transform a function on dimensions into one without regard for borders +underBorders :: (D -> D) -> D -> D +underBorders f = adjBorders 1 . f . adjBorders (-1) + +-- | Modify dimensions by a multiple of the current borders +adjBorders :: Dimension -> D -> D +adjBorders mult (w,h) = (w+2*mult*borderWidth, h+2*mult*borderWidth) diff --git a/XMonad/Layout/ToggleLayouts.hs b/XMonad/Layout/ToggleLayouts.hs new file mode 100644 index 0000000..0130cf7 --- /dev/null +++ b/XMonad/Layout/ToggleLayouts.hs @@ -0,0 +1,84 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ToggleLayouts +-- Copyright : (c) David Roundy +-- License : BSD +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : portable +-- +-- A module for writing easy Layouts +----------------------------------------------------------------------------- + +module XMonad.Layout.ToggleLayouts ( + -- * Usage + -- $usage + toggleLayouts, ToggleLayout(..) + ) where + +import XMonad + +-- $usage +-- Use toggleLayouts to toggle between two layouts. +-- +-- import XMonad.Layout.ToggleLayouts +-- +-- and add to your layoutHook something like +-- +-- > layoutHook = Layout $ toggleLayouts (noBorders Full) $ Select layouts +-- +-- and a key binding like +-- > , ((modMask .|. controlMask, xK_space), sendMessage ToggleLayout) +-- +-- or a key binding like +-- > , ((modMask .|. controlMask, xK_space), sendMessage (Toggle "Full")) + +data ToggleLayouts lt lf a = ToggleLayouts Bool (lt a) (lf a) deriving (Read,Show) +data ToggleLayout = ToggleLayout | Toggle String deriving (Read,Show,Typeable) +instance Message ToggleLayout + +toggleLayouts :: (LayoutClass lt a, LayoutClass lf a) => lt a -> lf a -> ToggleLayouts lt lf a +toggleLayouts = ToggleLayouts False + +instance (LayoutClass lt a, LayoutClass lf a) => LayoutClass (ToggleLayouts lt lf) a where + doLayout (ToggleLayouts True lt lf) r s = do (ws,mlt') <- doLayout lt r s + return (ws,fmap (\lt' -> ToggleLayouts True lt' lf) mlt') + doLayout (ToggleLayouts False lt lf) r s = do (ws,mlf') <- doLayout lf r s + return (ws,fmap (\lf' -> ToggleLayouts False lt lf') mlf') + description (ToggleLayouts True lt _) = description lt + description (ToggleLayouts False _ lf) = description lf + handleMessage (ToggleLayouts bool lt lf) m + | Just ReleaseResources <- fromMessage m = + do mlf' <- handleMessage lf m + mlt' <- handleMessage lt m + return $ case (mlt',mlf') of + (Nothing ,Nothing ) -> Nothing + (Just lt',Nothing ) -> Just $ ToggleLayouts bool lt' lf + (Nothing ,Just lf') -> Just $ ToggleLayouts bool lt lf' + (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' + 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' + 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' + 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' + return $ Just $ ToggleLayouts True lt lf' + | otherwise = do mlf' <- handleMessage lf m + return $ fmap (\lf' -> ToggleLayouts False lt lf') mlf' diff --git a/XMonad/Layout/TwoPane.hs b/XMonad/Layout/TwoPane.hs new file mode 100644 index 0000000..bca49a7 --- /dev/null +++ b/XMonad/Layout/TwoPane.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.TwoPane +-- Copyright : (c) Spencer Janssen +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen +-- Stability : unstable +-- Portability : unportable +-- +-- 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. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.TwoPane ( + -- * Usage + -- $usage + TwoPane (..) + ) where + +import XMonad +import XMonad.Layouts ( Resize(..), splitHorizontallyBy ) +import XMonad.StackSet ( focus, up, down) + +-- $usage +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.TwoPane +-- +-- and add, to the list of layouts: +-- +-- > , (Layout $ TwoPane 0.03 0.5) + +-- %import XMonad.Layout.TwoPane +-- %layout , (Layout $ TwoPane 0.03 0.5) + +data TwoPane a = + TwoPane Rational Rational + deriving ( Show, Read ) + +instance LayoutClass TwoPane a where + doLayout (TwoPane _ split) r s = return (arrange r s,Nothing) + where + arrange rect st = case reverse (up st) of + (master:_) -> [(master,left),(focus st,right)] + [] -> case down st of + (next:_) -> [(focus st,left),(next,right)] + [] -> [(focus st, rect)] + where (left, right) = splitHorizontallyBy split rect + + handleMessage (TwoPane delta split) x = + return $ case fromMessage x of + Just Shrink -> Just (TwoPane delta (split - delta)) + Just Expand -> Just (TwoPane delta (split + delta)) + _ -> Nothing + diff --git a/XMonad/Layout/WindowNavigation.hs b/XMonad/Layout/WindowNavigation.hs new file mode 100644 index 0000000..4608ba5 --- /dev/null +++ b/XMonad/Layout/WindowNavigation.hs @@ -0,0 +1,214 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.WindowNavigation +-- Copyright : (c) 2007 David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- WindowNavigation is an extension to allow easy navigation of a workspace. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.WindowNavigation ( + -- * Usage + -- $usage + windowNavigation, configurableNavigation, + Navigate(..), Direction(..), + MoveWindowToWindow(..), + navigateColor, navigateBrightness, + noNavigateBorders, defaultWNConfig + ) where + +import Graphics.X11.Xlib ( Rectangle(..), Window, Pixel, setWindowBorder ) +import Control.Monad.Reader ( ask ) +import Control.Monad.State ( gets ) +import Data.List ( nub, sortBy, (\\) ) +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Operations ( windows, focus ) +import XMonad.Layout.LayoutModifier +import XMonad.Util.Invisible +import XMonad.Util.XUtils + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.WindowNavigation +-- > +-- > layoutHook = Layout $ windowNavigation $ Select ... +-- +-- or perhaps +-- +-- > layoutHook = Layout $ configurableNavigation (navigateColor "green") $ Select ... +-- +-- In keybindings: +-- +-- > , ((modMask, xK_Right), sendMessage $ Go R) +-- > , ((modMask, xK_Left ), sendMessage $ Go L) +-- > , ((modMask, xK_Up ), sendMessage $ Go U) +-- > , ((modMask, xK_Down ), sendMessage $ Go D) + +-- %import XMonad.Layout.WindowNavigation +-- %keybind , ((modMask, xK_Right), sendMessage $ Go R) +-- %keybind , ((modMask, xK_Left ), sendMessage $ Go L) +-- %keybind , ((modMask, xK_Up ), sendMessage $ Go U) +-- %keybind , ((modMask, xK_Down ), sendMessage $ Go D) +-- %keybind , ((modMask .|. controlMask, xK_Right), sendMessage $ Swap R) +-- %keybind , ((modMask .|. controlMask, xK_Left ), sendMessage $ Swap L) +-- %keybind , ((modMask .|. controlMask, xK_Up ), sendMessage $ Swap U) +-- %keybind , ((modMask .|. controlMask, xK_Down ), sendMessage $ Swap D) +-- %layout -- include 'windowNavigation' in layoutHook definition above. +-- %layout -- just before the list, like the following (don't uncomment next line): +-- %layout -- layoutHook = Layout $ windowNavigation $ ... +-- %layout -- or +-- %layout -- layoutHook = Layout $ configurableNavigation (navigateColor "green") $ ... + +data MoveWindowToWindow a = MoveWindowToWindow a a deriving ( Read, Show, Typeable ) +instance Typeable a => Message (MoveWindowToWindow a) + +data Navigate = Go Direction | Swap Direction | Move Direction deriving ( Read, Show, Typeable ) +data Direction = U | D | R | L deriving ( Read, Show, Eq ) +instance Message Navigate + +data WNConfig = + WNC { brightness :: Maybe Double -- Indicates a fraction of the focus color. + , upColor :: String + , downColor :: String + , leftColor :: String + , rightColor :: String + } deriving (Show, Read) + +noNavigateBorders :: WNConfig +noNavigateBorders = + defaultWNConfig {brightness = Just 0} + +navigateColor :: String -> WNConfig +navigateColor c = + WNC Nothing c c c c + +navigateBrightness :: Double -> WNConfig +navigateBrightness f | f > 1 = navigateBrightness 1 + | f < 0 = navigateBrightness 0 +navigateBrightness f = defaultWNConfig { brightness = Just f } + +defaultWNConfig :: WNConfig +defaultWNConfig = WNC (Just 0.5) "#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)) + +configurableNavigation :: LayoutClass l a => WNConfig -> l a -> ModifiedLayout WindowNavigation l a +configurableNavigation conf = ModifiedLayout (WindowNavigation conf (I Nothing)) + +instance LayoutModifier WindowNavigation Window where + redoLayout (WindowNavigation conf (I state)) rscr s wrs = + do XConf { normalBorder = nbc, focusedBorder = fbc } <- ask + [uc,dc,lc,rc] <- + case brightness conf of + Just frac -> do myc <- averagePixels fbc nbc frac + return [myc,myc,myc,myc] + Nothing -> mapM stringToPixel [upColor conf, downColor conf, + leftColor conf, rightColor conf] + let dirc U = uc + dirc D = dc + dirc L = lc + dirc R = rc + let w = W.focus s + r = case filter ((==w).fst) wrs of ((_,x):_) -> x + [] -> rscr + pt = case state of Just (NS ptold _) | ptold `inrect` r -> ptold + _ -> center r + wrs' = filter ((/=w) . fst) wrs + wnavigable = nub $ concatMap + (\d -> truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L] + wnavigablec = nub $ concatMap + (\d -> map (\(win,_) -> (win,dirc d)) $ + truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L] + wothers = case state of Just (NS _ wo) -> map fst wo + _ -> [] + mapM_ (sc nbc) (wothers \\ map fst wnavigable) + mapM_ (\(win,c) -> sc c win) wnavigablec + return (wrs, Just $ WindowNavigation conf $ I $ Just $ NS pt wnavigable) + + handleMessOrMaybeModifyIt (WindowNavigation conf (I (Just (NS pt wrs)))) m + | Just (Go d) <- fromMessage m = + case sortby d $ filter (inr d pt . snd) wrs of + [] -> return Nothing + ((w,r):_) -> do focus w + return $ Just $ Left $ WindowNavigation conf $ I $ Just $ + NS (centerd d pt r) wrs + | Just (Swap d) <- fromMessage m = + case sortby d $ filter (inr d pt . snd) wrs of + [] -> return Nothing + ((w,_):_) -> do let swap st = unint (W.focus st) $ map (swapw (W.focus st)) $ W.integrate st + swapw y x | x == w = y + | x == y = w + | otherwise = x + unint f xs = case span (/= f) xs of + (u,_:dn) -> W.Stack { W.focus = f + , W.up = reverse u + , W.down = dn } + _ -> W.Stack { W.focus = f + , W.down = xs + , W.up = [] } + windows $ W.modify' swap + return Nothing + | Just (Move d) <- fromMessage m = + case sortby d $ filter (inr d pt . snd) wrs of + [] -> return Nothing + ((w,_):_) -> do mst <- gets (W.stack . W.workspace . W.current . windowset) + return $ do st <- mst + Just $ Right $ SomeMessage $ MoveWindowToWindow (W.focus st) w + | Just Hide <- fromMessage m = + do XConf { normalBorder = nbc } <- ask + mapM_ (sc nbc . fst) wrs + return $ Just $ Left $ WindowNavigation conf $ I $ Just $ NS pt [] + | Just ReleaseResources <- fromMessage m = + handleMessOrMaybeModifyIt (WindowNavigation conf (I $ Just (NS pt wrs))) (SomeMessage Hide) + handleMessOrMaybeModifyIt _ _ = return Nothing + +truncHead :: [a] -> [a] +truncHead (x:_) = [x] +truncHead [] = [] + +sc :: Pixel -> Window -> X () +sc c win = withDisplay $ \dpy -> io $ setWindowBorder dpy win c + +center :: Rectangle -> Point +center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2) (fromIntegral y + fromIntegral h/2) + +centerd :: Direction -> Point -> Rectangle -> Point +centerd d (P xx yy) (Rectangle x y w h) | d == U || d == D = P xx (fromIntegral y + fromIntegral h/2) + | otherwise = P (fromIntegral x + fromIntegral w/2) yy + +inr :: Direction -> Point -> Rectangle -> Bool +inr D (P x y) (Rectangle l yr w h) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + y < fromIntegral yr + fromIntegral h +inr U (P x y) (Rectangle l yr w _) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + y > fromIntegral yr +inr R (P a x) (Rectangle b l _ w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + a < fromIntegral b +inr L (P a x) (Rectangle b l c w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + a > fromIntegral b + fromIntegral c + +inrect :: Point -> Rectangle -> Bool +inrect (P x y) (Rectangle a b w h) = x > fromIntegral a && x < fromIntegral a + fromIntegral w && + y > fromIntegral b && y < fromIntegral b + fromIntegral h + +sortby :: Direction -> [(a,Rectangle)] -> [(a,Rectangle)] +sortby U = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y' y) +sortby D = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y y') +sortby R = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x x') +sortby L = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x' x) + +data Point = P Double Double diff --git a/XMonad/Layout/WorkspaceDir.hs b/XMonad/Layout/WorkspaceDir.hs new file mode 100644 index 0000000..e5f15ce --- /dev/null +++ b/XMonad/Layout/WorkspaceDir.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.WorkspaceDir +-- Copyright : (c) 2007 David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- 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. +-- +-- Requires the 'directory' package +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.WorkspaceDir ( + -- * Usage + -- $usage + workspaceDir, + changeDir + ) where + +import System.Directory ( setCurrentDirectory ) + +import XMonad +import XMonad.Operations ( sendMessage ) +import XMonad.Util.Run ( runProcessWithInput ) +import XMonad.Prompt ( XPConfig ) +import XMonad.Prompt.Directory ( directoryPrompt ) +import XMonad.Layout.LayoutModifier + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.WorkspaceDir +-- > +-- > layouts = map (workspaceDir "~") [ tiled, ... ] +-- +-- In keybindings: +-- +-- > , ((modMask .|. shiftMask, xK_x ), changeDir defaultXPConfig) + +-- %import XMonad.Layout.WorkspaceDir +-- %keybind , ((modMask .|. shiftMask, xK_x ), changeDir defaultXPConfig) +-- %layout -- prepend 'map (workspaceDir "~")' to layouts definition above, +-- %layout -- just before the list, like the following (don't uncomment next line): +-- %layout -- layouts = map (workspaceDir "~") [ tiled, ... ] + + +data Chdir = Chdir String deriving ( Typeable ) +instance Message Chdir + +data WorkspaceDir a = WorkspaceDir String deriving ( Read, Show ) + +instance LayoutModifier WorkspaceDir a where + hook (WorkspaceDir s) = scd s + handleMess (WorkspaceDir _) m = return $ do Chdir wd <- fromMessage m + Just (WorkspaceDir wd) + +workspaceDir :: LayoutClass l a => String -> l a + -> ModifiedLayout WorkspaceDir l a +workspaceDir s = ModifiedLayout (WorkspaceDir s) + +scd :: String -> X () +scd x = do x' <- io (runProcessWithInput "bash" [] ("echo -n " ++ x) `catch` \_ -> return x) + catchIO $ setCurrentDirectory x' + +changeDir :: XPConfig -> X () +changeDir c = directoryPrompt c "Set working directory: " (sendMessage . Chdir) diff --git a/XMonad/Prompt.hs b/XMonad/Prompt.hs new file mode 100644 index 0000000..0bd53fb --- /dev/null +++ b/XMonad/Prompt.hs @@ -0,0 +1,686 @@ +{-# LANGUAGE ExistentialQuantification #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonadContrib.XPrompt +-- Copyright : (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for writing graphical prompts for XMonad +-- +----------------------------------------------------------------------------- + +module XMonad.Prompt ( + -- * Usage + -- $usage + mkXPrompt + , defaultXPConfig + , mkComplFunFromList + , XPType (..) + , XPPosition (..) + , XPConfig (..) + , XPrompt (..) + , ComplFunction + -- * X Utilities + -- $xutils + , mkUnmanagedWindow + , fillDrawable + , printString + -- * Other Utilities + -- $utils + , getLastWord + , skipLastWord + , splitInSubListsAt + , breakAtSpace + , newIndex + , newCommand + , uniqSort + ) where + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import XMonad hiding (config, io) +import XMonad.Operations (initColor) +import qualified XMonad.StackSet as W +import XMonad.Util.XUtils +import XMonad.Util.XSelection (getSelection) + +import Control.Arrow ((***),(&&&)) +import Control.Monad.Reader +import Control.Monad.State +import Data.Bits +import Data.Char +import Data.Maybe +import Data.List +import Data.Set (fromList, toList) +import System.Environment (getEnv) +import System.IO +import System.Posix.Files + +-- $usage +-- For usage examples see "XMonadContrib.ShellPrompt", +-- "XMonadContrib.XMonadPrompt" or "XMonadContrib.SshPrompt" +-- +-- TODO: +-- +-- * scrolling the completions that don't fit in the window (?) +-- +-- * commands to edit the command line + +type XP = StateT XPState IO + +data XPState = + XPS { dpy :: Display + , rootw :: Window + , win :: Window + , screen :: Rectangle + , complWin :: Maybe Window + , complWinDim :: Maybe ComplWindowDim + , completionFunction :: String -> IO [String] + , gcon :: GC + , fontS :: FontStruct + , xptype :: XPType + , command :: String + , offset :: Int + , history :: [History] + , config :: XPConfig + } + +data XPConfig = + XPC { font :: String -- ^ Font + , bgColor :: String -- ^ Backgroud color + , fgColor :: String -- ^ Font color + , fgHLight :: String -- ^ Font color of a highlighted completion entry + , bgHLight :: String -- ^ Backgroud color of a highlighted completion entry + , borderColor :: String -- ^ Border color + , promptBorderWidth :: Dimension -- ^ Border width + , position :: XPPosition -- ^ Position: 'Top' or 'Bottom' + , height :: Dimension -- ^ Window height + , historySize :: Int -- ^ The number of history entries to be saved + } deriving (Show, Read) + +data XPType = forall p . XPrompt p => XPT p + +instance Show XPType where + show (XPT p) = showXPrompt p + +instance XPrompt XPType where + showXPrompt = show + +-- | 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 + showXPrompt :: t -> String + +data XPPosition = Top + | Bottom + deriving (Show,Read) + +defaultXPConfig :: XPConfig +defaultXPConfig = + XPC { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , bgColor = "#333333" + , fgColor = "#FFFFFF" + , fgHLight = "#000000" + , bgHLight = "#BBBBBB" + , borderColor = "#FFFFFF" + , promptBorderWidth = 1 + , position = Bottom + , height = 18 + , historySize = 256 + } + +type ComplFunction = String -> IO [String] + +initState :: XPrompt p => Display -> Window -> Window -> Rectangle -> ComplFunction + -> GC -> FontStruct -> p -> [History] -> XPConfig -> XPState +initState d rw w s compl gc fonts pt h c = + XPS d rw w s Nothing Nothing compl gc fonts (XPT pt) "" 0 h c + +-- | 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 = do + c <- ask + let d = display c + rw = theRoot c + s <- gets $ screenRect . W.screenDetail . W.current . windowset + w <- liftIO $ createWin d rw conf s + liftIO $ selectInput d w $ exposureMask .|. keyPressMask + gc <- liftIO $ createGC d w + liftIO $ setGraphicsExposures d gc False + (hist,h) <- liftIO $ readHistory + fs <- initFont (font conf) + liftIO $ setFont d gc $ fontFromFontStruct fs + let st = initState d rw w s compl gc fs (XPT t) hist conf + st' <- liftIO $ execStateT runXP st + + releaseFont fs + liftIO $ freeGC d gc + liftIO $ hClose h + when (command st' /= "") $ do + let htw = take (historySize conf) (history st') + liftIO $ writeHistory htw + action (command st') + +runXP :: XP () +runXP = do + st <- get + let (d,w) = (dpy &&& win) st + 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 + +-- Main event handler +handle :: KeyStroke -> Event -> XP () +handle k@(ks,_) e@(KeyEvent {ev_event_type = t}) + | t == keyPress && ks == xK_Tab = do + c <- getCompletions + completionHandle c k e +handle ks (KeyEvent {ev_event_type = t, ev_state = m}) + | t == keyPress = keyPressHandle m ks +handle _ (ExposeEvent {ev_window = w}) = do + st <- get + when (win st == w) updateWindows + eventLoop handle +handle _ _ = eventLoop handle + +-- completion event handler +completionHandle :: [String] -> KeyStroke -> Event -> XP () +completionHandle c (ks,_) (KeyEvent {ev_event_type = t}) + | t == keyPress && ks == xK_Tab = do + st <- get + case c of + [] -> do updateWindows + eventLoop handle + l -> do let new_command = newCommand (command st) l + modify $ \s -> s { command = new_command, offset = length new_command } + redrawWindows c + eventLoop (completionHandle c) +-- key release + | t == keyRelease && ks == xK_Tab = eventLoop (completionHandle c) +-- other keys +completionHandle _ ks (KeyEvent {ev_event_type = t, ev_state = m}) + | t == keyPress = keyPressHandle m ks +-- some other event: go back to main loop +completionHandle _ k e = handle k e + +-- | Given a completion and a list of possible completions, returns the +-- index of the next completion in the list +newIndex :: String -> [String] -> Int +newIndex com cl = + case elemIndex (getLastWord com) cl of + Just i -> if i >= length cl - 1 then 0 else i + 1 + Nothing -> 0 + +-- | Given a completion and a list of possible completions, returns the +-- the next completion in the list +newCommand :: String -> [String] -> String +newCommand com cl = + skipLastWord com ++ (cl !! (newIndex com cl)) + +-- KeyPresses + +data Direction = Prev | Next deriving (Eq,Show,Read) + +keyPressHandle :: KeyMask -> KeyStroke -> XP () +-- commands: ctrl + ... todo +keyPressHandle mask (ks,_) + | mask == controlMask = + -- control sequences + case () of + _ | ks == xK_u -> killBefore >> go + | ks == xK_k -> killAfter >> go + | ks == xK_a -> startOfLine >> go + | ks == xK_e -> endOfLine >> go + | ks == xK_y -> pasteString >> go + | ks == xK_g || ks == xK_c -> quit + | otherwise -> eventLoop handle -- unhandled control sequence + | ks == xK_Return = historyPush >> return () + | ks == xK_BackSpace = deleteString Prev >> go + | ks == xK_Delete = deleteString Next >> go + | ks == xK_Left = moveCursor Prev >> go + | ks == xK_Right = moveCursor Next >> go + | ks == xK_Up = moveHistory Prev >> go + | ks == xK_Down = moveHistory Next >> go + | ks == xK_Home = startOfLine >> go + | ks == xK_End = endOfLine >> go + | ks == xK_Escape = quit + where + go = updateWindows >> eventLoop handle + quit = flushString >> return () -- quit and discard everything +-- insert a character +keyPressHandle _ (_,s) + | s == "" = eventLoop handle + | otherwise = do insertString s + updateWindows + eventLoop handle + +-- KeyPress and State + +-- | Kill the portion of the command before the cursor +killBefore :: XP () +killBefore = + modify $ \s -> s { command = drop (offset s) (command s) + , offset = 0 } + +-- | Kill the portion of the command including and after the cursor +killAfter :: XP () +killAfter = + modify $ \s -> s { command = take (offset s) (command s) } + +-- | 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 offest +flushString :: XP () +flushString = do + modify (\s -> s { command = "", offset = 0} ) + +-- | Insert a character at the cursor position +insertString :: String -> XP () +insertString str = + modify (\s -> s { command = c (command s) (offset s), offset = o (offset s)} ) + 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 :: Direction -> XP () +deleteString d = + modify (\s -> s { command = c (command s) (offset 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 :: Direction -> 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) + +moveHistory :: Direction -> XP () +moveHistory d = do + h <- getHistory + c <- gets command + let str = if h /= [] then head h else c + let nc = case elemIndex c h of + Just i -> case d of + Prev -> h !! (if (i + 1) > (length h - 1) then 0 else i + 1) + Next -> h !! (max (i - 1) 0) + Nothing -> str + modify (\s -> s { command = nc, offset = length nc }) + +-- 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 + bgcolor <- io $ initColor d (bgColor c) + 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 . xptype &&& command &&& offset) st + str = prt ++ com + -- scompose the string in 3 part: 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,psl) = (textWidth fs *** textWidth fs) (f,p) + (_,asc,desc,_) = textExtents fs str + y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc + x = (asc + desc) `div` 2 + fgcolor <- io $ initColor d $ fgColor c + bgcolor <- io $ initColor d $ bgColor c + -- print the first part + io $ printString d drw gc fgcolor bgcolor x y f + -- reverse the colors and print the "cursor" ;-) + io $ printString d drw gc bgcolor fgcolor (x + fsl) y p + -- reverse the colors and print the rest of the string + io $ printString d drw gc fgcolor bgcolor (x + fsl + psl) y ss + +-- Completions + +getCompletions :: XP [String] +getCompletions = do + s <- get + io $ (completionFunction s) (getLastWord $ command s) + `catch` \_ -> 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 + + let max_compl_len = (fi ht `div` 2) + (maximum . map (textWidth fs) $ compl) + 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)) + + let (_,asc,desc,_) = textExtents fs $ head compl + 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 + bgcolor <- io $ initColor d (bgColor c) + fgcolor <- io $ initColor d (fgColor c) + 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 bgcolor xx yy ac + 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 /= [] ) + 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 + +printComplList :: Display -> Drawable -> GC -> Pixel -> Pixel + -> [Position] -> [Position] -> [[String]] -> XP () +printComplList _ _ _ _ _ _ _ [] = return () +printComplList _ _ _ _ _ [] _ _ = return () +printComplList d drw gc fc bc (x:xs) y (s:ss) = do + printComplColumn d drw gc fc bc x y s + printComplList d drw gc fc bc xs y ss + +printComplColumn :: Display -> Drawable -> GC -> Pixel -> Pixel + -> Position -> [Position] -> [String] -> XP () +printComplColumn _ _ _ _ _ _ _ [] = return () +printComplColumn _ _ _ _ _ _ [] _ = return () +printComplColumn d drw gc fc bc x (y:yy) (s:ss) = do + printComplString d drw gc fc bc x y s + printComplColumn d drw gc fc bc x yy ss + +printComplString :: Display -> Drawable -> GC -> Pixel -> Pixel + -> Position -> Position -> String -> XP () +printComplString d drw gc fc bc x y s = do + st <- get + if s == getLastWord (command st) + then do bhc <- io $ initColor d (bgHLight $ config st) + fhc <- io $ initColor d (fgHLight $ config st) + io $ printString d drw gc fhc bhc x y s + else io $ printString d drw gc fc bc x y s + +-- History + +data History = + H { prompt :: String + , command_history :: String + } deriving (Show, Read, Eq) + +historyPush :: XP () +historyPush = do + c <- gets command + when (c /= []) $ modify (\s -> s { history = nub $ H (showXPrompt (xptype s)) c : history s }) + +getHistory :: XP [String] +getHistory = do + hist <- gets history + pt <- gets xptype + return $ map command_history . filter (\h -> prompt h == showXPrompt pt) $ hist + +readHistory :: IO ([History],Handle) +readHistory = do + home <- getEnv "HOME" + let path = home ++ "/.xmonad_history" + f <- fileExist path + if f then do h <- openFile path ReadMode + str <- hGetContents h + case (reads str) of + [(hist,_)] -> return (hist,h) + [] -> return ([],h) + _ -> return ([],h) + else do h <- openFile path WriteMode + return ([],h) + +writeHistory :: [History] -> IO () +writeHistory hist = do + home <- getEnv "HOME" + let path = home ++ "/.xmonad_history" + catch (writeFile path (show hist)) (\_ -> do putStrLn "error in writing"; return ()) + +-- $xutils + +-- | Prints a string on a 'Drawable' +printString :: Display -> Drawable -> GC -> Pixel -> Pixel + -> Position -> Position -> String -> IO () +printString d drw gc fc bc x y s = do + setForeground d gc fc + setBackground d gc bc + drawImageString d drw gc x y s + +-- | 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 + +-- Lift an IO action into the XP +io :: IO a -> XP a +io = liftIO + +-- Shorthand for fromIntegral +fi :: (Num b, Integral a) => a -> b +fi = fromIntegral + +-- | 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 + +-- | Sort a list and remove duplicates. +uniqSort :: Ord a => [a] -> [a] +uniqSort = toList . fromList diff --git a/XMonad/Prompt/Directory.hs b/XMonad/Prompt/Directory.hs new file mode 100644 index 0000000..1ceaab8 --- /dev/null +++ b/XMonad/Prompt/Directory.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.Directory +-- Copyright : (C) 2007 Andrea Rossato, David Roundy +-- License : BSD3 +-- +-- Maintainer : droundy@darcs.net +-- Stability : unstable +-- Portability : unportable +-- +-- A directory prompt for XMonad +-- +----------------------------------------------------------------------------- + +module XMonad.Prompt.Directory ( + -- * Usage + -- $usage + directoryPrompt + ) where + +import XMonad +import XMonad.Prompt +import XMonad.Util.Run ( runProcessWithInput ) + +-- $usage +-- For an example usage see "XMonad.Layout.WorkspaceDir" + +data Dir = Dir String + +instance XPrompt Dir where + showXPrompt (Dir x) = x + +directoryPrompt :: XPConfig -> String -> (String -> X ()) -> X () +directoryPrompt c prom job = mkXPrompt (Dir prom) c getDirCompl job + +getDirCompl :: String -> IO [String] +getDirCompl s = (filter notboring . lines) `fmap` + runProcessWithInput "/bin/bash" [] ("compgen -A directory " ++ s ++ "\n") + +notboring :: String -> Bool +notboring ('.':'.':_) = True +notboring ('.':_) = False +notboring _ = True diff --git a/XMonad/Prompt/Man.hs b/XMonad/Prompt/Man.hs new file mode 100644 index 0000000..5a9f4ef --- /dev/null +++ b/XMonad/Prompt/Man.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.Man +-- Copyright : (c) 2007 Valery V. Vorotyntsev +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : valery.vv@gmail.com +-- Stability : unstable +-- Portability : non-portable (uses \"manpath\" and \"bash\") +-- +-- A manual page prompt for XMonad window manager. +-- +-- TODO +-- +-- * narrow completions by section number, if the one is specified +-- (like @\/etc\/bash_completion@ does) +-- +-- * test with QuickCheck +----------------------------------------------------------------------------- + +module XMonad.Prompt.Man ( + -- * Usage + -- $usage + manPrompt + , getCommandOutput + ) where + +import XMonad +import XMonad.Prompt +import XMonad.Util.Run +import XMonad.Prompt.Shell (split) + +import System.Directory +import System.Process +import System.IO + +import qualified Control.Exception as E +import Control.Monad +import Data.List +import Data.Maybe + +-- $usage +-- 1. In Config.hs add: +-- +-- > import XMonad.Prompt.ManPrompt +-- +-- 2. In your keybindings add something like: +-- +-- > , ((modMask, xK_F1), manPrompt defaultXPConfig) -- mod-f1 %! Query for manual page to be displayed + +-- %import XMonad.Prompt.XPrompt +-- %import XMonad.Prompt.ManPrompt +-- %keybind , ((modMask, xK_F1), manPrompt defaultXPConfig) + +data Man = Man + +instance XPrompt Man where + showXPrompt Man = "Manual page: " + +-- | Query for manual page to be displayed. +manPrompt :: XPConfig -> X () +manPrompt c = mkXPrompt Man c manCompl $ runInTerm . (++) "man " + +manCompl :: String -> IO [String] +manCompl str | '/' `elem` str = do + -- XXX It may be better to use readline instead of bash's compgen... + lines `fmap` getCommandOutput ("bash -c 'compgen -A file " ++ str ++ "'") + | otherwise = do + mp <- getCommandOutput "manpath -g 2>/dev/null" `E.catch` \_ -> return [] + let sects = ["man" ++ show n | n <- [1..9 :: Int]] + dirs = [d ++ "/" ++ s | d <- split ':' mp, s <- sects] + stripExt = reverse . drop 1 . dropWhile (/= '.') . reverse + mans <- forM dirs $ \d -> do + exists <- doesDirectoryExist d + if exists + then map (stripExt . stripSuffixes [".gz", ".bz2"]) `fmap` + getDirectoryContents d + else return [] + mkComplFunFromList (uniqSort $ concat mans) str + +-- | Run a command using shell and return its output. +-- +-- XXX merge with 'Run.runProcessWithInput'? +-- +-- * update documentation of the latter (there is no 'Maybe' in result) +-- +-- * ask \"gurus\" whether @evaluate (length ...)@ approach is +-- better\/more idiomatic +getCommandOutput :: String -> IO String +getCommandOutput s = do + (pin, pout, perr, ph) <- runInteractiveCommand s + hClose pin + output <- hGetContents pout + E.evaluate (length output) + hClose perr + waitForProcess ph + return output + +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 diff --git a/XMonad/Prompt/Shell.hs b/XMonad/Prompt/Shell.hs new file mode 100644 index 0000000..dfbfb09 --- /dev/null +++ b/XMonad/Prompt/Shell.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.Shell +-- Copyright : (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A shell prompt for XMonad +-- +----------------------------------------------------------------------------- + +module XMonad.Prompt.Shell( + -- * Usage + -- $usage + shellPrompt + , getShellCompl + , split + , prompt + , safePrompt + ) where + +import System.Environment +import Control.Monad +import Data.List +import System.Directory +import System.IO +import XMonad.Util.Run +import XMonad +import XMonad.Prompt + +-- $usage +-- +-- 1. In Config.hs add: +-- +-- > import XMonad.Prompt +-- > import XMonad.Prompt.Shell +-- +-- 2. In your keybindings add something like: +-- +-- > , ((modMask .|. controlMask, xK_x), shellPrompt defaultXPConfig) +-- + +-- %import XMonad.Prompt +-- %import XMonad.Prompt.ShellPrompt +-- %keybind , ((modMask .|. controlMask, xK_x), shellPrompt defaultXPConfig) + +data Shell = Shell + +instance XPrompt Shell where + showXPrompt Shell = "Run: " + +shellPrompt :: XPConfig -> X () +shellPrompt c = do + cmds <- io $ getCommands + mkXPrompt Shell c (getShellCompl cmds) spawn + +-- | See safe and unsafeSpawn. prompt is an alias for safePrompt; +-- 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 +-- is the program to be run with the interactive input. +-- You would use these like this: +-- +-- > , ((modMask, xK_b ), safePrompt "firefox" greenXPConfig) +-- > , ((modMask .|. shiftMask, xK_c ), prompt ("xterm" ++ " -e") greenXPConfig) +-- +-- Note that you want to use safePrompt for Firefox input, as Firefox +-- wants URLs, and unsafePrompt for the XTerm example because this allows +-- you to easily start a terminal executing an arbitrary command, like +-- 'top'. +prompt, unsafePrompt, safePrompt :: FilePath -> XPConfig -> X () +prompt = unsafePrompt +safePrompt c config = mkXPrompt Shell config (getShellCompl [c]) run + where run = safeSpawn c +unsafePrompt c config = mkXPrompt Shell config (getShellCompl [c]) 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") + return . map escape . uniqSort $ f ++ commandCompletionFunction cmds s + +commandCompletionFunction :: [String] -> String -> [String] +commandCompletionFunction cmds str | '/' `elem` str = [] + | otherwise = filter (isPrefixOf str) cmds + +getCommands :: IO [String] +getCommands = do + p <- getEnv "PATH" `catch` const (return []) + let ds = split ':' p + fp d f = d ++ "/" ++ f + es <- forM ds $ \d -> do + exists <- doesDirectoryExist d + if exists + then getDirectoryContents d >>= filterM (isExecutable . fp d) + else return [] + return . uniqSort . concat $ es + +isExecutable :: FilePath ->IO Bool +isExecutable f = do + fe <- doesFileExist f + if fe + then fmap executable $ getPermissions f + else return False + +split :: Eq a => a -> [a] -> [[a]] +split _ [] = [] +split e l = + f : split e (rest ls) + where + (f,ls) = span (/=e) l + rest s | s == [] = [] + | otherwise = tail s + +escape :: String -> String +escape [] = "" +escape (' ':xs) = "\\ " ++ escape xs +escape (x:xs) + | isSpecialChar x = '\\' : x : escape xs + | otherwise = x : escape xs + +isSpecialChar :: Char -> Bool +isSpecialChar = flip elem "\\@\"'#?$*()[]{};" diff --git a/XMonad/Prompt/Ssh.hs b/XMonad/Prompt/Ssh.hs new file mode 100644 index 0000000..9194b27 --- /dev/null +++ b/XMonad/Prompt/Ssh.hs @@ -0,0 +1,104 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.Ssh +-- Copyright : (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A ssh prompt for XMonad +-- +----------------------------------------------------------------------------- + +module XMonad.Prompt.Ssh( + -- * Usage + -- $usage + sshPrompt + ) where + +import XMonad +import XMonad.Util.Run +import XMonad.Prompt + +import System.Directory +import System.Environment + +import Control.Monad +import Data.List +import Data.Maybe + +-- $usage +-- 1. In Config.hs add: +-- +-- > import XMonad.Prompt +-- > import XMonad.Prompt.SshPrompt +-- +-- 2. In your keybindings add something like: +-- +-- > , ((modMask .|. controlMask, xK_s), sshPrompt defaultXPConfig) +-- + +-- %import XMonad.Prompt +-- %import XMonad.Prompt.SshPrompt +-- %keybind , ((modMask .|. controlMask, xK_s), sshPrompt defaultXPConfig) + +data Ssh = Ssh + +instance XPrompt Ssh where + showXPrompt Ssh = "SSH to: " + +sshPrompt :: XPConfig -> X () +sshPrompt c = do + sc <- io $ sshComplList + mkXPrompt Ssh c (mkComplFunFromList sc) ssh + +ssh :: String -> X () +ssh s = runInTerm ("ssh " ++ s) + +sshComplList :: IO [String] +sshComplList = uniqSort `fmap` liftM2 (++) sshComplListLocal sshComplListGlobal + +sshComplListLocal :: IO [String] +sshComplListLocal = do + h <- getEnv "HOME" + sshComplListFile $ h ++ "/.ssh/known_hosts" + +sshComplListGlobal :: IO [String] +sshComplListGlobal = do + env <- getEnv "SSH_KNOWN_HOSTS" `catch` (\_ -> return "/nonexistent") + fs <- mapM fileExists [ env + , "/usr/local/etc/ssh/ssh_known_hosts" + , "/usr/local/etc/ssh_known_hosts" + , "/etc/ssh/ssh_known_hosts" + , "/etc/ssh_known_hosts" + ] + case catMaybes fs of + [] -> return [] + (f:_) -> sshComplListFile' f + +sshComplListFile :: String -> IO [String] +sshComplListFile kh = do + f <- doesFileExist kh + if f then sshComplListFile' kh + else return [] + +sshComplListFile' :: String -> IO [String] +sshComplListFile' kh = do + l <- readFile kh + return $ map (takeWhile (/= ',') . concat . take 1 . words) + $ filter nonComment + $ lines l + +fileExists :: String -> IO (Maybe String) +fileExists kh = do + f <- doesFileExist kh + if f then return $ Just kh + else return Nothing + +nonComment :: String -> Bool +nonComment [] = False +nonComment ('#':_) = False +nonComment ('|':_) = False -- hashed, undecodeable +nonComment _ = True diff --git a/XMonad/Prompt/Window.hs b/XMonad/Prompt/Window.hs new file mode 100644 index 0000000..2c017ee --- /dev/null +++ b/XMonad/Prompt/Window.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.Window +-- Copyright : Devin Mullins +-- Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Devin Mullins +-- Andrea Rossato +-- Stability : unstable +-- Portability : unportable +-- +-- xprompt operations to bring windows to you, and bring you to windows. +-- +----------------------------------------------------------------------------- + +module XMonad.Prompt.Window + ( + -- * Usage + -- $usage + windowPromptGoto, + windowPromptBring + ) where + +import qualified Data.Map as M +import Data.List + +import qualified XMonad.StackSet as W +import XMonad +import XMonad.Operations (windows) +import XMonad.Prompt +import XMonad.Actions.WindowBringer + +-- $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. +-- +-- Place in your Config.hs: +-- +-- > import XMonad.Prompt +-- > import XMonad.Prompt.WindowPrompt +-- +-- and in the keys definition: +-- +-- > , ((modMask .|. shiftMask, xK_g ), windowPromptGoto defaultXPConfig) +-- > , ((modMask .|. shiftMask, xK_b ), windowPromptBring defaultXPConfig) + +-- %import XMonad.Prompt +-- %import XMonad.Prompt.WindowPrompt +-- %keybind , ((modMask .|. shiftMask, xK_g ), windowPromptGoto defaultXPConfig) +-- %keybind , ((modMask .|. shiftMask, xK_b ), windowPromptBring defaultXPConfig) + + +data WindowPrompt = Goto | Bring +instance XPrompt WindowPrompt where + showXPrompt Goto = "Go to window: " + showXPrompt Bring = "Bring me here: " + +windowPromptGoto, windowPromptBring :: XPConfig -> X () +windowPromptGoto c = doPrompt Goto c +windowPromptBring c = doPrompt Bring c + +-- | 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 -> return . gotoAction =<< windowMapWith (W.tag . fst) + Bring -> return . bringAction =<< windowMapWith snd + wm <- windowMapWith id + mkXPrompt t c (compList wm) a + + where + + winAction a m = flip whenJust (windows . a) . flip M.lookup m . unescape + gotoAction = winAction W.greedyView + bringAction = winAction bringWindow + bringWindow w ws = W.shiftWin (W.tag . W.workspace . W.current $ ws) w ws + + compList m s = return . filter (isPrefixOf s) . map (escape . fst) . M.toList $ m + + escape [] = [] + escape (' ':xs) = "\\ " ++ escape xs + escape (x :xs) = x : escape xs + + unescape [] = [] + unescape ('\\':' ':xs) = ' ' : unescape xs + unescape (x:xs) = x : unescape xs diff --git a/XMonad/Prompt/Workspace.hs b/XMonad/Prompt/Workspace.hs new file mode 100644 index 0000000..c05ead0 --- /dev/null +++ b/XMonad/Prompt/Workspace.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.Workspace +-- Copyright : (C) 2007 Andrea Rossato, David Roundy +-- License : BSD3 +-- +-- Maintainer : droundy@darcs.net +-- Stability : unstable +-- Portability : unportable +-- +-- A directory prompt for XMonad +-- +----------------------------------------------------------------------------- + +module XMonad.Prompt.Workspace ( + -- * Usage + -- $usage + workspacePrompt + ) where + +import Control.Monad.State ( gets ) +import Data.List ( sort ) +import XMonad hiding ( workspaces ) +import XMonad.Prompt +import XMonad.StackSet ( workspaces, tag ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Prompt.WorkspacePrompt +-- +-- > , ((modMask .|. shiftMask, xK_m ), workspacePrompt myXPConfig (windows . W.shift)) + +data Wor = Wor String + +instance XPrompt Wor where + showXPrompt (Wor x) = x + +workspacePrompt :: XPConfig -> (String -> X ()) -> X () +workspacePrompt c job = do ws <- gets (workspaces . windowset) + let ts = sort $ map tag ws + mkXPrompt (Wor "") c (mkCompl ts) job + +mkCompl :: [String] -> String -> IO [String] +mkCompl l s = return $ filter (\x -> take (length s) x == s) l diff --git a/XMonad/Prompt/XMonad.hs b/XMonad/Prompt/XMonad.hs new file mode 100644 index 0000000..5effbe4 --- /dev/null +++ b/XMonad/Prompt/XMonad.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Prompt.XMonad +-- Copyright : (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A prompt for running XMonad commands +-- +----------------------------------------------------------------------------- + +module XMonad.Prompt.XMonad ( + -- * Usage + -- $usage + xmonadPrompt, + xmonadPromptC + ) where + +import XMonad +import XMonad.Prompt +import XMonad.Actions.Commands (defaultCommands, runCommand') + +-- $usage +-- +-- in Config.hs add: +-- +-- > import XMonad.Prompt +-- > import XMonad.Prompt.XMonad +-- +-- in you keybindings add: +-- +-- > , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultXPConfig) +-- + +-- %import XMonad.Prompt +-- %import XMonad.Prompt.XMonad +-- %keybind , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultXPConfig) + +data XMonad = XMonad + +instance XPrompt XMonad where + showXPrompt XMonad = "XMonad: " + +xmonadPrompt :: XPConfig -> X () +xmonadPrompt c = do + cmds <- defaultCommands + mkXPrompt XMonad c (mkComplFunFromList (map fst cmds)) runCommand' + +-- xmonad prompt with custom command list +xmonadPromptC :: [(String, X ())] -> XPConfig -> X () +xmonadPromptC commands c = mkXPrompt XMonad c (mkComplFunFromList (map fst commands)) runCommand' diff --git a/XMonad/Util/Anneal.hs b/XMonad/Util/Anneal.hs new file mode 100644 index 0000000..6852308 --- /dev/null +++ b/XMonad/Util/Anneal.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Anneal +-- Copyright : (c) David Roundy +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- Requires the 'random' package +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Anneal ( Rated(Rated), the_value, the_rating + , anneal, annealMax ) where + +import System.Random ( StdGen, Random, mkStdGen, randomR ) +import Control.Monad.State ( State, runState, put, get, gets, modify ) + +-- %import XMonad.Util.Anneal + +data Rated a b = Rated !a !b + deriving ( Show ) +instance Functor (Rated a) where + f `fmap` (Rated v a) = Rated v (f a) + +the_value :: Rated a b -> b +the_value (Rated _ b) = b +the_rating :: Rated a b -> a +the_rating (Rated a _) = a + +instance Eq a => Eq (Rated a b) where + (Rated a _) == (Rated a' _) = a == a' +instance Ord a => Ord (Rated a b) where + compare (Rated a _) (Rated a' _) = compare a a' + +anneal :: a -> (a -> Double) -> (a -> [a]) -> Rated Double a +anneal st r sel = runAnneal st r (do_anneal sel) + +annealMax :: a -> (a -> Double) -> (a -> [a]) -> Rated Double a +annealMax st r sel = runAnneal st (negate . r) (do_anneal sel) + +do_anneal :: (a -> [a]) -> State (Anneal a) (Rated Double a) +do_anneal sel = do sequence_ $ replicate 100 da + gets best + where da = do select_metropolis sel + modify $ \s -> s { temperature = temperature s *0.99 } + +data Anneal a = A { g :: StdGen + , best :: Rated Double a + , current :: Rated Double a + , rate :: a -> Rated Double a + , temperature :: Double } + +runAnneal :: a -> (a -> Double) -> State (Anneal a) b -> b +runAnneal start r x = fst $ runState x (A { g = mkStdGen 137 + , best = Rated (r start) start + , current = Rated (r start) start + , rate = \xx -> Rated (r xx) xx + , temperature = 1.0 }) + +select_metropolis :: (a -> [a]) -> State (Anneal a) () +select_metropolis x = do c <- gets current + a <- select $ x $ the_value c + metropolis a + +metropolis :: a -> State (Anneal a) () +metropolis x = do r <- gets rate + c <- gets current + t <- gets temperature + let rx = r x + boltz = exp $ (the_rating c - the_rating rx) / t + if rx < c then do modify $ \s -> s { current = rx, best = rx } + else do p <- getOne (0,1) + if p < boltz + then modify $ \s -> s { current = rx } + else return () + +select :: [a] -> State (Anneal a) a +select [] = the_value `fmap` gets best +select [x] = return x +select xs = do n <- getOne (0,length xs - 1) + return (xs !! n) + +getOne :: (Random a) => (a,a) -> State (Anneal x) a +getOne bounds = do s <- get + (x,g') <- return $ randomR bounds (g s) + put $ s { g = g' } + return x diff --git a/XMonad/Util/Dmenu.hs b/XMonad/Util/Dmenu.hs new file mode 100644 index 0000000..8eeb0d9 --- /dev/null +++ b/XMonad/Util/Dmenu.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Dmenu +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen +-- Stability : unstable +-- Portability : unportable +-- +-- A convenient binding to dmenu. +-- +-- Requires the process-1.0 package +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Dmenu ( + -- * Usage + -- $usage + dmenu, dmenuXinerama, dmenuMap + ) where + +import XMonad +import qualified XMonad.StackSet as W +import qualified Data.Map as M +import Control.Monad.State +import XMonad.Util.Run + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Util.Dmenu + +-- %import XMonad.Util.Dmenu + +-- | Starts dmenu on the current screen. Requires this patch to dmenu: +-- +dmenuXinerama :: [String] -> X String +dmenuXinerama opts = do + curscreen <- (fromIntegral . W.screen . W.current) `liftM` gets windowset :: X Int + io $ runProcessWithInput "dmenu" ["-xs", show (curscreen+1)] (unlines opts) + +dmenu :: [String] -> X String +dmenu opts = io $ runProcessWithInput "dmenu" [] (unlines opts) + +dmenuMap :: M.Map String a -> X (Maybe a) +dmenuMap selectionMap = do + selection <- dmenu (M.keys selectionMap) + return $ M.lookup selection selectionMap diff --git a/XMonad/Util/Dzen.hs b/XMonad/Util/Dzen.hs new file mode 100644 index 0000000..02fce05 --- /dev/null +++ b/XMonad/Util/Dzen.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Dzen +-- Copyright : (c) glasser@mit.edu +-- License : BSD +-- +-- Maintainer : glasser@mit.edu +-- Stability : unstable +-- Portability : unportable +-- +-- Handy wrapper for dzen. Requires dzen >= 0.2.4. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Dzen (dzen, dzenWithArgs, dzenScreen, + dzenUrgencyHook, dzenUrgencyHookWithArgs, + seconds) where + +import Control.Monad (when) +import Control.Monad.State (gets) +import qualified Data.Set as S +import Graphics.X11.Types (Window) + +import qualified XMonad.StackSet as W +import XMonad + +import XMonad.Util.NamedWindows (getName) +import XMonad.Util.Run (runProcessWithInputAndWait, seconds) + +-- | @dzen str timeout@ pipes @str@ to dzen2 for @timeout@ microseconds. +-- Example usage: +-- > dzen "Hi, mom!" (5 `seconds`) +dzen :: String -> Int -> X () +dzen str timeout = dzenWithArgs str [] timeout + +-- | @dzen str args timeout@ pipes @str@ to dzen2 for @timeout@ seconds, passing @args@ to dzen. +-- Example usage: +-- > dzenWithArgs "Hi, dons!" ["-ta", "r"] (5 `seconds`) +dzenWithArgs :: String -> [String] -> Int -> X () +dzenWithArgs str args timeout = io $ runProcessWithInputAndWait "dzen2" args (unchomp str) timeout + -- dzen seems to require the input to terminate with exactly one newline. + where unchomp s@['\n'] = s + unchomp [] = ['\n'] + unchomp (c:cs) = c : unchomp cs + +-- | @dzenScreen sc str timeout@ pipes @str@ to dzen2 for @timeout@ microseconds, and on screen @sc@. +-- Requires dzen to be compiled with Xinerama support. +dzenScreen :: ScreenId -> String -> Int -> X() +dzenScreen sc str timeout = dzenWithArgs str ["-xs", screen] timeout + where screen = toXineramaArg sc + toXineramaArg n = show ( ((fromIntegral n)+1)::Int ) + +-- | Flashes when a window requests your attention and you can't see it. For use with +-- XMonadContrib.UrgencyHook. Usage: +-- > urgencyHook = dzenUrgencyHook (5 `seconds`) +dzenUrgencyHook :: Int -> Window -> X () +dzenUrgencyHook = dzenUrgencyHookWithArgs [] + +-- | Flashes when a window requests your attention and you can't see it. For use with +-- XMonadContrib.UrgencyHook. Usage: +-- > urgencyHook = dzenUrgencyHookWithArgs ["-bg", "darkgreen"] (5 `seconds`) +dzenUrgencyHookWithArgs :: [String] -> Int -> Window -> X () +dzenUrgencyHookWithArgs args duration w = do + visibles <- gets mapped + name <- getName w + ws <- gets windowset + whenJust (W.findTag w ws) (flash name visibles) + where flash name visibles index = + when (not $ S.member w visibles) $ + dzenWithArgs (show name ++ " requests your attention on workspace " ++ index) + args duration diff --git a/XMonad/Util/Invisible.hs b/XMonad/Util/Invisible.hs new file mode 100644 index 0000000..f387158 --- /dev/null +++ b/XMonad/Util/Invisible.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Invisible +-- Copyright : (c) 2007 Andrea Rossato, David Roundy +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it, droundy@darcs.net +-- Stability : unstable +-- Portability : unportable +-- +-- A data type to store the layout state +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Invisible ( + -- * Usage: + -- $usage + Invisible (..) + , whenIJust + , fromIMaybe + ) where + +-- $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) + +instance (Functor m, Monad m) => Read (Invisible m a) where + readsPrec _ s = [(fail "Read Invisible", s)] + +instance Monad m => Show (Invisible m a) where + show _ = "" + +whenIJust :: (Monad m) => Invisible Maybe a -> (a -> m ()) -> m () +whenIJust (I (Just x)) f = f x +whenIJust (I Nothing) _ = return () + +fromIMaybe :: a -> Invisible Maybe a -> a +fromIMaybe _ (I (Just x)) = x +fromIMaybe a (I Nothing) = a diff --git a/XMonad/Util/NamedWindows.hs b/XMonad/Util/NamedWindows.hs new file mode 100644 index 0000000..05613b2 --- /dev/null +++ b/XMonad/Util/NamedWindows.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.NamedWindows +-- Copyright : (c) David Roundy +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy +-- Stability : unstable +-- Portability : unportable +-- +-- This module allows you to associate the X titles of windows with +-- them. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.NamedWindows ( + -- * Usage + -- $usage + NamedWindow, + getName, + withNamedWindow, + unName + ) where + +import Control.Monad.Reader ( asks ) +import Control.Monad.State ( gets ) + +import qualified XMonad.StackSet as W ( peek ) + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad + +-- $usage +-- See "XMonadContrib.Mosaic" for an example of its use. + + +data NamedWindow = NW !String !Window +instance Eq NamedWindow where + (NW s _) == (NW s' _) = s == s' +instance Ord NamedWindow where + compare (NW s _) (NW s' _) = compare s s' +instance Show NamedWindow where + show (NW n _) = n + +getName :: Window -> X NamedWindow +getName w = asks display >>= \d -> do s <- io $ getClassHint d w + n <- maybe (resName s) id `fmap` io (fetchName d w) + return $ NW n 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 diff --git a/XMonad/Util/Run.hs b/XMonad/Util/Run.hs new file mode 100644 index 0000000..39a653a --- /dev/null +++ b/XMonad/Util/Run.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Run +-- Copyright : (C) 2007 Spencer Janssen, Andrea Rossato, glasser@mit.edu +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Christian Thiemann +-- 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 +-- Spenver Jannsen), XMonad.Util.Dzen (by glasser@mit.edu) and +-- XMonad.Util.RunInXTerm (by Andrea Rossato). +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Run ( + -- * Usage + -- $usage + runProcessWithInput, + runProcessWithInputAndWait, + safeSpawn, + unsafeSpawn, + runInTerm, + safeRunInTerm, + seconds + ) where + +import Control.Monad.Reader +import System.Posix.Process (createSession, forkProcess, executeFile, + getProcessStatus) +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import System.Exit (ExitCode(ExitSuccess), exitWith) +import System.IO (IO, FilePath, hPutStr, hGetContents, hFlush, hClose) +import System.Process (runInteractiveProcess, waitForProcess) +import XMonad + +-- $usage +-- For an example usage of runInTerm see XMonad.Prompt.Ssh +-- +-- For an example usage of runProcessWithInput see +-- XMonad.Prompt.{DirectoryPrompt,Dmenu,ShellPrompt,WmiiActions,WorkspaceDir} +-- +-- For an example usage of runProcessWithInputAndWait see XMonad.Util.Dzen + +-- | Returns Just output if the command succeeded, and Nothing if it didn't. +-- This corresponds to dmenu's notion of exit code 1 for a cancelled invocation. +runProcessWithInput :: FilePath -> [String] -> String -> IO String +runProcessWithInput cmd args input = do + (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing + hPutStr pin input + hClose pin + output <- hGetContents pout + when (output==output) $ return () + hClose pout + hClose perr + waitForProcess ph + return output + +-- wait is in us +runProcessWithInputAndWait :: FilePath -> [String] -> String -> Int -> IO () +runProcessWithInputAndWait cmd args input timeout = do + pid <- forkProcess $ do + forkProcess $ do -- double fork it over to init + createSession + (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing + hPutStr pin input + hFlush pin + threadDelay timeout + hClose pin + hClose pout + hClose perr + waitForProcess ph + return () + exitWith ExitSuccess + return () + getProcessStatus True False pid + return () + +{- | Multiplies by ONE MILLION, for use with runProcessWithInputAndWait. + Use like: + > (5.5 `seconds`) +-} +seconds :: Rational -> Int +seconds = fromEnum . (* 1000000) + +{- | safeSpawn bypasses XMonad's 'spawn' command, because spawn passes strings to /bin/sh to be interpreted as shell + commands. This is often what one wants, but in many cases the passed string will contain shell metacharacters + which one does not want interpreted as such (URLs particularly often have shell metacharacters like '&' in them). + In this case, it is more useful to specify a file or program to be run and a string to give it as an argument so + as to bypass the shell and be certain the program will receive the string as you typed it. + unsafeSpawn is an alias for XMonad's 'spawn', to remind one that use of it can be, well, unsafe. + Examples: + > , ((modMask, xK_Print ), unsafeSpawn "import -window root png:$HOME/xwd-$(date +%s)$$.png") + > , ((modMask, xK_d ), safeSpawn "firefox" "") + + Note that the unsafeSpawn example must be unsafe and not safe because it makes use of shell interpretation by relying on + $HOME and interpolation, whereas the safeSpawn example can be safe because Firefox doesn't need any arguments if it is + just being started. +-} +safeSpawn :: FilePath -> String -> X () +safeSpawn prog arg = io (try (forkProcess $ executeFile prog True [arg] Nothing) >> return ()) +unsafeSpawn :: String -> X () +unsafeSpawn = spawn + +-- | Run a given program in the preferred terminal emulator. This uses safeSpawn. +safeRunInTerm :: String -> X () +safeRunInTerm command = asks (terminal . config) >>= \t -> safeSpawn t ("-e " ++ command) + +unsafeRunInTerm, runInTerm :: String -> X () +unsafeRunInTerm command = asks (terminal . config) >>= \t -> unsafeSpawn $ t ++ " -e " ++ command +runInTerm = unsafeRunInTerm diff --git a/XMonad/Util/XSelection.hs b/XMonad/Util/XSelection.hs new file mode 100644 index 0000000..00d6723 --- /dev/null +++ b/XMonad/Util/XSelection.hs @@ -0,0 +1,175 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonadContrib.XSelection +-- Copyright : (C) 2007 Andrea Rossato, Matthew Sackman +-- License : BSD3 +-- +-- Maintainer : Andrea Rossato , +-- Matthew Sackman +-- Stability : unstable +-- Portability : unportable +-- +-- A module for accessing and manipulating the X Window mouse selection (used in copy and pasting). +-- getSelection and putSelection are adaptations of Hxsel.hs and Hxput.hs from XMonad-utils, available: +-- +-- $ darcs get "http:\/\/gorgias.mine.nu\/repos\/xmonad-utils" +----------------------------------------------------------------------------- + +module XMonad.Util.XSelection ( + -- * Usage + -- $usage + getSelection, + promptSelection, + safePromptSelection, + putSelection) where + +import Graphics.X11.Xlib.Extras (Graphics.X11.Xlib.Extras.Event(ev_event_display, + ev_time, ev_property, ev_target, ev_selection, + ev_requestor, ev_event_type), + xConvertSelection, xGetSelectionOwner, xSetSelectionOwner, getEvent, + currentTime, setSelectionNotify, getWindowProperty8, changeProperty8, + propModeReplace) +import Graphics.X11.Xlib (destroyWindow, createSimpleWindow, Display, XEventPtr, + sendEvent, nextEvent, sync, allocaXEvent, openDisplay, rootWindow, + defaultScreen, internAtom, Atom, selectionNotify, selectionRequest, noEventMask) +import Control.Concurrent (forkIO) +import Control.Exception as E (catch) +import Control.Monad(Monad (return, (>>)), Functor(..), liftM, join) +import Data.Char (chr, ord) +import Data.Maybe (fromMaybe) +import Foreign(Word8, Data.Bits.Bits (shiftL, (.&.), (.|.))) +import XMonad.Util.Run (safeSpawn, unsafeSpawn) +import XMonad (X, io) + +{- $usage + Add 'import XMonadContrib.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 (say, + the selection is an URL you just highlighted), then one could add + to the Config.hs a line like thus: + +> , ((modMask .|. shiftMask, xK_b ), promptSelection "firefox") + + TODO: + + * Fix Unicode handling. Currently it's still better than calling + 'chr' to translate to ASCII, though. + As near as I can tell, the mangling happens when the String is + outputted somewhere, such as via promptSelection's passing through + the shell, or GHCi printing to the terminal. utf-string has IO functions + which can fix this, though I do not know have to use them here. It's + a complex issue; see + + and . + + * Possibly add some more elaborate functionality: Emacs' registers are nice. +-} + +-- | Returns a String corresponding to the current mouse selection in X; if there is none, an empty string is returned. Note that this is +-- really only reliable for ASCII text and currently escapes or otherwise mangles more complex UTF-8 characters. +getSelection :: IO String +getSelection = 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 + ty <- E.catch + (E.catch + (internAtom dpy "UTF8_STRING" False) + (\_ -> internAtom dpy "COMPOUND_TEXT" False)) + (\_ -> internAtom dpy "sTring" False) + clp <- internAtom dpy "BLITZ_SEL_STRING" False + xConvertSelection dpy p ty clp win currentTime + allocaXEvent $ \e -> do + nextEvent dpy e + ev <- getEvent e + if ev_event_type ev == selectionNotify + then do res <- getWindowProperty8 dpy clp win + return $ decode . fromMaybe [] $ res + else destroyWindow dpy win >> return "" + +-- | Set the current X Selection to a given String. +putSelection :: String -> IO () +putSelection text = 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 + ty <- internAtom dpy "UTF8_STRING" False + xSetSelectionOwner dpy p win currentTime + winOwn <- xGetSelectionOwner dpy p + if winOwn == win + then do forkIO ((allocaXEvent $ processEvent dpy ty text) >> destroyWindow dpy win) >> return () + else do putStrLn "Unable to obtain ownership of the selection" >> destroyWindow dpy win + return () + where + processEvent :: Display -> Atom -> [Char] -> XEventPtr -> IO () + processEvent dpy ty txt e = do + nextEvent dpy e + ev <- getEvent e + if ev_event_type ev == selectionRequest + then do print ev + -- selection == eg PRIMARY + -- target == type eg UTF8 + -- property == property name or None + allocaXEvent $ \replyPtr -> do + changeProperty8 (ev_event_display ev) + (ev_requestor ev) + (ev_property ev) + ty + propModeReplace + (map (fromIntegral . ord) txt) + setSelectionNotify replyPtr (ev_requestor ev) (ev_selection ev) (ev_target ev) (ev_property ev) (ev_time ev) + sendEvent dpy (ev_requestor ev) False noEventMask replyPtr + sync dpy False + else do putStrLn "Unexpected Message Received" + print ev + processEvent dpy ty text e + +{- | 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\"@; +this would allow you to highlight a URL string and then immediately open it up in Firefox. + +promptSelection passes strings through the shell; if you do not wish your selected text to be interpreted/mangled +by the shell, use safePromptSelection which will bypass the shell using safeSpawn from Run.hs; see Run.hs for more +details on the advantages/disadvantages of this. -} +promptSelection, safePromptSelection, unsafePromptSelection :: String -> X () +promptSelection = unsafePromptSelection +safePromptSelection app = join $ io $ liftM (safeSpawn app) (getSelection) +unsafePromptSelection app = join $ io $ liftM unsafeSpawn $ fmap (\x -> app ++ " " ++ x) getSelection + +{- UTF-8 decoding for internal use in getSelection. This code is copied from Eric Mertens's utf-string library + (version 0.1), which is BSD-3 licensed, as is this module. + It'd be better to just import Codec.Binary.UTF8.String (decode), but then users of this would need to install it; Xmonad has enough + dependencies already. -} +decode :: [Word8] -> String +decode [ ] = "" +decode (c:cs) + | c < 0x80 = chr (fromEnum c) : decode cs + | c < 0xc0 = replacement_character : decode cs + | c < 0xe0 = multi_byte 1 0x1f 0x80 + | c < 0xf0 = multi_byte 2 0xf 0x800 + | c < 0xf8 = multi_byte 3 0x7 0x10000 + | c < 0xfc = multi_byte 4 0x3 0x200000 + | c < 0xfe = multi_byte 5 0x1 0x4000000 + | otherwise = replacement_character : decode cs + where + replacement_character :: Char + replacement_character = '\xfffd' + + multi_byte :: Int -> Word8 -> Int -> [Char] + multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) + where + aux :: Int -> [Word8] -> Int -> [Char] + aux 0 rs acc + | overlong <= acc && acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs + | otherwise = replacement_character : decode rs + aux n (r:rs) acc + | r .&. 0xc0 == 0x80 = aux (n-1) rs + $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) + aux _ rs _ = replacement_character : decode rs diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs new file mode 100644 index 0000000..3986389 --- /dev/null +++ b/XMonad/Util/XUtils.hs @@ -0,0 +1,191 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.XUtils +-- Copyright : (c) 2007 Andrea Rossato +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for painting on the screen +-- +----------------------------------------------------------------------------- + +module XMonad.Util.XUtils ( + -- * Usage: + -- $usage + stringToPixel + , averagePixels + , initFont + , releaseFont + , createNewWindow + , showWindow + , hideWindow + , deleteWindow + , paintWindow + , Align (..) + , stringPosition + , paintAndWrite + ) where + + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Control.Monad.Reader +import Data.Maybe +import XMonad +import XMonad.Operations + +-- $usage +-- See Tabbed or DragPane for usage examples + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +stringToPixel :: String -> X Pixel +stringToPixel s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = initColor d s + fallBack d = const $ return $ blackPixel d (defaultScreen d) + +-- | Compute the weighted average the colors of two given Pixel values. +averagePixels :: Pixel -> Pixel -> Double -> X Pixel +averagePixels p1 p2 f = + do d <- asks display + let cm = defaultColormap d (defaultScreen d) + [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) + return p + +-- | Given a fontname returns the fonstructure. If the font name is +-- not valid the default font will be loaded and returned. +initFont :: String -> X FontStruct +initFont s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = loadQueryFont d s + fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseFont :: FontStruct -> X () +releaseFont fs = do + d <- asks display + io $ freeFont d fs + +-- | Create a simple window given a rectangle. If Nothing is given +-- only the exposureMask will be set, otherwise the Just value. +-- Use 'showWindow' to map and hideWindow to unmap. +createNewWindow :: Rectangle -> Maybe EventMask -> String -> X Window +createNewWindow (Rectangle x y w h) m col = do + d <- asks display + rw <- asks theRoot + c <- stringToPixel col + win <- io $ createSimpleWindow d rw x y w h 0 c c + case m of + Just em -> io $ selectInput d win em + Nothing -> io $ selectInput d win exposureMask + return win + +-- | Map a window +showWindow :: Window -> X () +showWindow w = do + d <- asks display + io $ mapWindow d w + +-- | unmap a window +hideWindow :: Window -> X () +hideWindow w = do + d <- asks display + io $ unmapWindow d w + +-- | destroy a window +deleteWindow :: Window -> X () +deleteWindow w = do + d <- asks display + io $ destroyWindow d w + +-- | Fill a window with a rectangle and a border +paintWindow :: Window -- ^ The window where to draw + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> X () +paintWindow w wh ht bw c bc = + paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing + +-- | String position +data Align = AlignCenter | AlignRight | AlignLeft + +-- | Return the string x and y 'Position' in a 'Rectangle', given a +-- 'FontStruct' and the 'Align'ment +stringPosition :: FontStruct -> Rectangle -> Align -> String -> (Position,Position) +stringPosition fs (Rectangle _ _ w h) al s = (x,y) + where width = textWidth fs s + (_,a,d,_) = textExtents fs s + y = fi $ ((h - fi (a + d)) `div` 2) + fi a + x = case al of + AlignCenter -> fi (w `div` 2) - fi (width `div` 2) + AlignLeft -> 1 + AlignRight -> fi (w - (fi width + 1)) + +-- | Fill a window with a rectangle and a border, and write a string at given position +paintAndWrite :: Window -- ^ The window where to draw + -> FontStruct -- ^ The FontStruct + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> String -- ^ String color + -> String -- ^ String background color + -> Align -- ^ String 'Align'ment + -> String -- ^ String to be printed + -> X () +paintAndWrite w fs wh ht bw bc borc ffc fbc al str = + paintWindow' w r bw bc borc ms + where ms = Just (fs,ffc,fbc,str) + r = Rectangle x y wh ht + (x,y) = stringPosition fs (Rectangle 0 0 wh ht) al str + +-- This stuf is not exported + +paintWindow' :: Window -> Rectangle -> Dimension -> String -> String -> Maybe (FontStruct,String,String,String) -> X () +paintWindow' win (Rectangle x y wh ht) bw color b_color str = do + d <- asks display + p <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d) + gc <- io $ createGC d p + -- draw + io $ setGraphicsExposures d gc False + [c',bc'] <- mapM stringToPixel [color,b_color] + -- we start with the border + io $ setForeground d gc bc' + io $ fillRectangle d p gc 0 0 wh ht + -- and now again + io $ setForeground d gc c' + io $ fillRectangle d p gc (fi bw) (fi bw) ((wh - (bw * 2))) (ht - (bw * 2)) + when (isJust str) $ do + let (fs,fc,bc,s) = fromJust str + io $ setFont d gc $ fontFromFontStruct fs + printString d p gc fc bc x y s + -- copy the pixmap over the window + io $ copyArea d p win gc 0 0 wh ht 0 0 + -- free the pixmap and GC + io $ freePixmap d p + io $ freeGC d gc + +-- | Prints a string on a 'Drawable' +printString :: Display -> Drawable -> GC -> String -> String + -> Position -> Position -> String -> X () +printString d drw gc fc bc x y s = do + [fc',bc'] <- mapM stringToPixel [fc,bc] + io $ setForeground d gc fc' + io $ setBackground d gc bc' + io $ drawImageString d drw gc x y s + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral -- cgit v1.2.3