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 --- Accordion.hs | 50 --- Anneal.hs | 90 ----- Circle.hs | 70 ---- Combo.hs | 139 ------- Commands.hs | 114 ------ ConstrainedResize.hs | 58 --- CopyWindow.hs | 79 ---- CycleWS.hs | 102 ------ DeManage.hs | 58 --- DirectoryPrompt.hs | 43 --- Dishes.hs | 57 --- Dmenu.hs | 49 --- DragPane.hs | 137 ------- DwmPromote.hs | 47 --- DynamicLog.hs | 211 ----------- DynamicWorkspaces.hs | 107 ------ Dzen.hs | 71 ---- EwmhDesktops.hs | 130 ------- FindEmptyWorkspace.hs | 72 ---- FlexibleManipulate.hs | 122 ------- FlexibleResize.hs | 67 ---- FloatKeys.hs | 112 ------ FocusNth.hs | 48 --- Grid.hs | 65 ---- HintedTile.hs | 98 ----- Invisible.hs | 45 --- LayoutCombinators.hs | 128 ------- LayoutHints.hs | 57 --- LayoutModifier.hs | 69 ---- LayoutScreens.hs | 84 ----- MagicFocus.hs | 51 --- Magnifier.hs | 69 ---- ManPrompt.hs | 107 ------ ManageDocks.hs | 153 -------- Maximize.hs | 73 ---- MetaModule.hs | 152 ++++---- Mosaic.hs | 407 --------------------- MosaicAlt.hs | 163 --------- MouseGestures.hs | 116 ------ NamedWindows.hs | 57 --- NoBorders.hs | 106 ------ ResizableTile.hs | 93 ----- Roledex.hs | 70 ---- RotSlaves.hs | 60 --- RotView.hs | 53 --- Run.hs | 114 ------ SetWMName.hs | 114 ------ ShellPrompt.hs | 127 ------- SimpleDate.hs | 39 -- SinkAll.hs | 36 -- Spiral.hs | 112 ------ Square.hs | 56 --- SshPrompt.hs | 104 ------ Submap.hs | 71 ---- SwapWorkspaces.hs | 55 --- SwitchTrans.hs | 194 ---------- Tabbed.hs | 214 ----------- TagWindows.hs | 205 ----------- ThreeColumns.hs | 80 ---- TilePrime.hs | 104 ------ ToggleLayouts.hs | 84 ----- TwoPane.hs | 61 ---- UrgencyHook.hs | 134 ------- Warp.hs | 74 ---- WindowBringer.hs | 84 ----- WindowNavigation.hs | 214 ----------- WindowPrompt.hs | 89 ----- WmiiActions.hs | 102 ------ WorkspaceDir.hs | 78 ---- WorkspacePrompt.hs | 45 --- 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 ++++++++++ XMonadPrompt.hs | 54 --- XPrompt.hs | 686 ----------------------------------- XPropManage.hs | 91 ----- XSelection.hs | 175 --------- XUtils.hs | 191 ---------- tests/test_SwapWorkspaces.hs | 2 +- tests/test_XPrompt.hs | 4 +- 151 files changed, 8023 insertions(+), 8023 deletions(-) delete mode 100644 Accordion.hs delete mode 100644 Anneal.hs delete mode 100644 Circle.hs delete mode 100644 Combo.hs delete mode 100644 Commands.hs delete mode 100644 ConstrainedResize.hs delete mode 100644 CopyWindow.hs delete mode 100644 CycleWS.hs delete mode 100644 DeManage.hs delete mode 100644 DirectoryPrompt.hs delete mode 100644 Dishes.hs delete mode 100644 Dmenu.hs delete mode 100644 DragPane.hs delete mode 100644 DwmPromote.hs delete mode 100644 DynamicLog.hs delete mode 100644 DynamicWorkspaces.hs delete mode 100644 Dzen.hs delete mode 100644 EwmhDesktops.hs delete mode 100644 FindEmptyWorkspace.hs delete mode 100644 FlexibleManipulate.hs delete mode 100644 FlexibleResize.hs delete mode 100644 FloatKeys.hs delete mode 100644 FocusNth.hs delete mode 100644 Grid.hs delete mode 100644 HintedTile.hs delete mode 100644 Invisible.hs delete mode 100644 LayoutCombinators.hs delete mode 100644 LayoutHints.hs delete mode 100644 LayoutModifier.hs delete mode 100644 LayoutScreens.hs delete mode 100644 MagicFocus.hs delete mode 100644 Magnifier.hs delete mode 100644 ManPrompt.hs delete mode 100644 ManageDocks.hs delete mode 100644 Maximize.hs delete mode 100644 Mosaic.hs delete mode 100644 MosaicAlt.hs delete mode 100644 MouseGestures.hs delete mode 100644 NamedWindows.hs delete mode 100644 NoBorders.hs delete mode 100644 ResizableTile.hs delete mode 100644 Roledex.hs delete mode 100644 RotSlaves.hs delete mode 100644 RotView.hs delete mode 100644 Run.hs delete mode 100644 SetWMName.hs delete mode 100644 ShellPrompt.hs delete mode 100644 SimpleDate.hs delete mode 100644 SinkAll.hs delete mode 100644 Spiral.hs delete mode 100644 Square.hs delete mode 100644 SshPrompt.hs delete mode 100644 Submap.hs delete mode 100644 SwapWorkspaces.hs delete mode 100644 SwitchTrans.hs delete mode 100644 Tabbed.hs delete mode 100644 TagWindows.hs delete mode 100644 ThreeColumns.hs delete mode 100644 TilePrime.hs delete mode 100644 ToggleLayouts.hs delete mode 100644 TwoPane.hs delete mode 100644 UrgencyHook.hs delete mode 100644 Warp.hs delete mode 100644 WindowBringer.hs delete mode 100644 WindowNavigation.hs delete mode 100644 WindowPrompt.hs delete mode 100644 WmiiActions.hs delete mode 100644 WorkspaceDir.hs delete mode 100644 WorkspacePrompt.hs 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 delete mode 100644 XMonadPrompt.hs delete mode 100644 XPrompt.hs delete mode 100644 XPropManage.hs delete mode 100644 XSelection.hs delete mode 100644 XUtils.hs diff --git a/Accordion.hs b/Accordion.hs deleted file mode 100644 index f5c24d8..0000000 --- a/Accordion.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Accordion --- > layouts = [ Layout Accordion ] - --- %import XMonadContrib.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/Anneal.hs b/Anneal.hs deleted file mode 100644 index d30c4d9..0000000 --- a/Anneal.hs +++ /dev/null @@ -1,90 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.Anneal --- Copyright : (c) David Roundy --- License : BSD-style (see LICENSE) --- --- Maintainer : David Roundy --- Stability : unstable --- Portability : unportable --- --- Requires the 'random' package --- ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.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/Circle.hs b/Circle.hs deleted file mode 100644 index d0f343b..0000000 --- a/Circle.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Circle --- > layouts = [ Layout Circle ] - --- %import XMonadContrib.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/Combo.hs b/Combo.hs deleted file mode 100644 index 15c7155..0000000 --- a/Combo.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.Combo --- Copyright : (c) David Roundy --- License : BSD-style (see LICENSE) --- --- Maintainer : David Roundy --- Stability : unstable --- Portability : unportable --- --- A layout that combines multiple layouts. --- ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.Invisible -import XMonadContrib.WindowNavigation ( MoveWindowToWindow(..) ) -import qualified XMonad.StackSet as W ( differentiate ) - --- $usage --- --- To use this layout write, in your Config.hs: --- --- > import XMonadContrib.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 XMonadContrib.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/Commands.hs b/Commands.hs deleted file mode 100644 index dd97ad5..0000000 --- a/Commands.hs +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib module. --- ------------------------------------------------------------------------------ - -module XMonadContrib.Commands ( - -- * Usage - -- $usage - commandMap, - runCommand, - runCommand', - workspaceCommands, - screenCommands, - defaultCommands - ) where - -import XMonad -import XMonad.Operations -import XMonad.StackSet hiding (workspaces) -import XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/ConstrainedResize.hs b/ConstrainedResize.hs deleted file mode 100644 index 5e54861..0000000 --- a/ConstrainedResize.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.ConstrainedResize ( - -- * Usage - -- $usage - XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/CopyWindow.hs b/CopyWindow.hs deleted file mode 100644 index 1e825ef..0000000 --- a/CopyWindow.hs +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/CycleWS.hs b/CycleWS.hs deleted file mode 100644 index 931ed47..0000000 --- a/CycleWS.hs +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/DeManage.hs b/DeManage.hs deleted file mode 100644 index 3994541..0000000 --- a/DeManage.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.DeManage --- --- And add a keybinding to it: --- --- > , ((modMask, xK_d ), withFocused demanage) --- - --- %import XMonadContrib.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/DirectoryPrompt.hs b/DirectoryPrompt.hs deleted file mode 100644 index a8d58f8..0000000 --- a/DirectoryPrompt.hs +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.DirectoryPrompt --- Copyright : (C) 2007 Andrea Rossato, David Roundy --- License : BSD3 --- --- Maintainer : droundy@darcs.net --- Stability : unstable --- Portability : unportable --- --- A directory prompt for XMonad --- ------------------------------------------------------------------------------ - -module XMonadContrib.DirectoryPrompt ( - -- * Usage - -- $usage - directoryPrompt - ) where - -import XMonad -import XMonadContrib.XPrompt -import XMonadContrib.Run ( runProcessWithInput ) - --- $usage --- For an example usage see "XMonadContrib.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/Dishes.hs b/Dishes.hs deleted file mode 100644 index a1eae21..0000000 --- a/Dishes.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Dishes --- --- and add the following line to your 'layouts' --- --- > , Layout $ Dishes 2 (1%6) - --- %import XMonadContrib.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/Dmenu.hs b/Dmenu.hs deleted file mode 100644 index 51cca67..0000000 --- a/Dmenu.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Run - --- $usage --- You can use this module with the following in your Config.hs file: --- --- > import XMonadContrib.Dmenu - --- %import XMonadContrib.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/DragPane.hs b/DragPane.hs deleted file mode 100644 index 0ae9761..0000000 --- a/DragPane.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Invisible -import XMonadContrib.XUtils - --- $usage --- --- You can use this module with the following in your Config.hs file: --- --- > import XMonadContrib.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/DwmPromote.hs b/DwmPromote.hs deleted file mode 100644 index 7e81e7b..0000000 --- a/DwmPromote.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.DwmPromote ( - -- * Usage - -- $usage - dwmpromote - ) where - -import XMonad -import XMonad.Operations (windows) -import XMonad.StackSet - --- $usage --- --- To use, modify your Config.hs to: --- --- > import XMonadContrib.DwmPromote --- --- and add a keybinding or substitute promote with dwmpromote: --- --- > , ((modMask, xK_Return), dwmpromote) - --- %import XMonadContrib.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/DynamicLog.hs b/DynamicLog.hs deleted file mode 100644 index adacc0c..0000000 --- a/DynamicLog.hs +++ /dev/null @@ -1,211 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.NamedWindows - --- $usage --- --- To use, set: --- --- > import XMonadContrib.DynamicLog --- > logHook = dynamicLog - --- %import XMonadContrib.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/DynamicWorkspaces.hs b/DynamicWorkspaces.hs deleted file mode 100644 index 34f57f1..0000000 --- a/DynamicWorkspaces.hs +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.WorkspacePrompt -import XMonadContrib.XPrompt ( XPConfig ) - --- $usage --- You can use this module with the following in your Config.hs file: --- --- > import XMonadContrib.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/Dzen.hs b/Dzen.hs deleted file mode 100644 index 5853ace..0000000 --- a/Dzen.hs +++ /dev/null @@ -1,71 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.NamedWindows (getName) -import XMonadContrib.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/EwmhDesktops.hs b/EwmhDesktops.hs deleted file mode 100644 index 4e2d754..0000000 --- a/EwmhDesktops.hs +++ /dev/null @@ -1,130 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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/FindEmptyWorkspace.hs b/FindEmptyWorkspace.hs deleted file mode 100644 index 27b0de8..0000000 --- a/FindEmptyWorkspace.hs +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/FlexibleManipulate.hs b/FlexibleManipulate.hs deleted file mode 100644 index 7c96c77..0000000 --- a/FlexibleManipulate.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/FlexibleResize.hs b/FlexibleResize.hs deleted file mode 100644 index e6bb338..0000000 --- a/FlexibleResize.hs +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.FlexibleResize --- Copyright : (c) Lukas Mai --- License : BSD3-style (see LICENSE) --- --- Maintainer : --- Stability : unstable --- Portability : unportable --- --- Lets you resize floating windows from any corner. --- ------------------------------------------------------------------------------ - -module XMonadContrib.FlexibleResize ( - -- * Usage - -- $usage - XMonadContrib.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 XMonadContrib.FlexibleResize as Flex --- > mouseBindings = M.fromList --- > [ ... --- > , ((modMask, button3), (\w -> focus w >> Flex.mouseResizeWindow w)) ] - --- %import qualified XMonadContrib.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/FloatKeys.hs b/FloatKeys.hs deleted file mode 100644 index 1f090e6..0000000 --- a/FloatKeys.hs +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.FloatKeys --- Copyright : (c) Karsten Schoelzel --- License : BSD --- --- Maintainer : Karsten Schoelzel --- Stability : unstable --- Portability : unportable --- --- Move and resize floating windows. ------------------------------------------------------------------------------ - -module XMonadContrib.FloatKeys ( - -- * Usage - -- $usage - keysMoveWindow, - keysMoveWindowTo, - keysResizeWindow, - keysAbsResizeWindow) where - -import XMonad.Operations -import XMonad -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras - --- $usage --- > import XMonadContrib.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/FocusNth.hs b/FocusNth.hs deleted file mode 100644 index 28e8e96..0000000 --- a/FocusNth.hs +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.FocusNth --- Copyright : (c) Karsten Schoelzel --- License : BSD --- --- Maintainer : Karsten Schoelzel --- Stability : unstable --- Portability : unportable --- --- Focus the nth window on the screen. ------------------------------------------------------------------------------ - -module XMonadContrib.FocusNth ( - -- * Usage - -- $usage - focusNth) where - -import XMonad.StackSet -import XMonad.Operations -import XMonad - --- $usage --- > import XMonadContrib.FocusNth - --- > -- mod4-[1..9] @@ Switch to window N --- > ++ [((mod4Mask, k), focusNth i) --- > | (i, k) <- zip [0 .. 8] [xK_1 ..]] - --- %import XMonadContrib.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/Grid.hs b/Grid.hs deleted file mode 100644 index c18f997..0000000 --- a/Grid.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Grid --- > ... --- > layouts = [ ... --- > , Layout Grid --- > ] - --- %import XMonadContrib.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/HintedTile.hs b/HintedTile.hs deleted file mode 100644 index c641896..0000000 --- a/HintedTile.hs +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.HintedTile --- --- > layouts = [ XMonadContrib.HintedTile.tall nmaster delta ratio, ... ] - --- %import qualified XMonadContrib.HintedTile --- --- %layout , XMonadContrib.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/Invisible.hs b/Invisible.hs deleted file mode 100644 index 5ee9c25..0000000 --- a/Invisible.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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/LayoutCombinators.hs b/LayoutCombinators.hs deleted file mode 100644 index a368481..0000000 --- a/LayoutCombinators.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.LayoutCombinators --- Copyright : (c) David Roundy --- License : BSD --- --- Maintainer : David Roundy --- Stability : unstable --- Portability : portable --- --- A module for combining Layouts ------------------------------------------------------------------------------ - -module XMonadContrib.LayoutCombinators ( - -- * Usage - -- $usage - (<|>), (), (<||>), (), (|||), JumpToLayout(JumpToLayout) - ) where - -import Data.Maybe ( isJust ) - -import XMonad -import Layouts ( Tall(..), Mirror(..), ChangeLayout(NextLayout) ) -import XMonadContrib.Combo -import XMonadContrib.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/LayoutHints.hs b/LayoutHints.hs deleted file mode 100644 index 8f6f110..0000000 --- a/LayoutHints.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.LayoutHints --- Copyright : (c) David Roundy --- License : BSD --- --- Maintainer : David Roundy --- Stability : unstable --- Portability : portable --- --- Make layouts respect size hints. ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.LayoutModifier - --- $usage --- > import XMonadContrib.LayoutHints --- > layouts = [ layoutHints tiled , layoutHints $ Mirror tiled ] - --- %import XMonadContrib.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/LayoutModifier.hs b/LayoutModifier.hs deleted file mode 100644 index 16bdbcb..0000000 --- a/LayoutModifier.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.LayoutModifier --- Copyright : (c) David Roundy --- License : BSD --- --- Maintainer : David Roundy --- Stability : unstable --- Portability : portable --- --- A module for writing easy Layouts ------------------------------------------------------------------------------ - -module XMonadContrib.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/LayoutScreens.hs b/LayoutScreens.hs deleted file mode 100644 index 10e1fc9..0000000 --- a/LayoutScreens.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.LayoutScreens --- Copyright : (c) David Roundy --- License : BSD3-style (see LICENSE) --- --- Maintainer : David Roundy --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.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 XMonadContrib.LayoutScreens --- --- > , ((modMask .|. shiftMask, xK_space), --- > layoutScreens 1 (fixedLayout $ Rectangle 0 0 1024 768)) --- > , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen) - --- %import XMonadContrib.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/MagicFocus.hs b/MagicFocus.hs deleted file mode 100644 index 91f38ee..0000000 --- a/MagicFocus.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.MagicFocus - (-- * Usage - -- $usage - MagicFocus(MagicFocus) - ) where - -import Graphics.X11.Xlib -import XMonad -import XMonad.StackSet - --- $usage --- > import XMonadContrib.MagicFocus --- > layouts = [ Layout $ MagicFocus tiled , Layout $ MagicFocus $ Mirror tiled ] - --- %import XMonadContrib.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/Magnifier.hs b/Magnifier.hs deleted file mode 100644 index 3997d5d..0000000 --- a/Magnifier.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.Magnifier ( - -- * Usage - -- $usage - magnifier, magnifier') where - -import Graphics.X11.Xlib (Window, Rectangle(..)) -import XMonad -import XMonad.StackSet -import XMonadContrib.LayoutHelpers - --- $usage --- > import XMonadContrib.Magnifier --- > layouts = [ magnifier tiled , magnifier $ mirror tiled ] - --- %import XMonadContrib.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/ManPrompt.hs b/ManPrompt.hs deleted file mode 100644 index 2eddb39..0000000 --- a/ManPrompt.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.ManPrompt --- 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 XMonadContrib.ManPrompt ( - -- * Usage - -- $usage - manPrompt - , getCommandOutput - ) where - -import XMonad -import XMonadContrib.XPrompt -import XMonadContrib.Run -import XMonadContrib.ShellPrompt (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 XMonadContrib.ManPrompt --- --- 2. In your keybindings add something like: --- --- > , ((modMask, xK_F1), manPrompt defaultXPConfig) -- mod-f1 %! Query for manual page to be displayed - --- %import XMonadContrib.XPrompt --- %import XMonadContrib.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/ManageDocks.hs b/ManageDocks.hs deleted file mode 100644 index 9651c5e..0000000 --- a/ManageDocks.hs +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/Maximize.hs b/Maximize.hs deleted file mode 100644 index 2138917..0000000 --- a/Maximize.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.Maximize ( - -- * Usage - -- $usage - maximize, - maximizeRestore - ) where - -import Graphics.X11.Xlib -import XMonad -import XMonadContrib.LayoutModifier -import Data.List ( partition ) - --- $usage --- You can use this module with the following in your Config.hs file: --- --- > import XMonadContrib.Maximize --- --- > layouts = ... --- > , Layout $ maximize $ tiled ... --- > ... --- --- > keys = ... --- > , ((modMask, xK_backslash), withFocused (sendMessage . maximizeRestore)) --- > ... - --- %import XMonadContrib.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/MetaModule.hs b/MetaModule.hs index 4475c49..cb1922a 100644 --- a/MetaModule.hs +++ b/MetaModule.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- | --- Module : XMonadContrib.MetaModule +-- Module : XMonad.MetaModule -- Copyright : (c) 2007 Spencer Janssen -- License : BSD3-style (see LICENSE) -- @@ -8,7 +8,7 @@ -- Stability : unstable -- Portability : unportable -- --- This is an artificial dependency on all the XMonadContrib.* modules. It is +-- This is an artificial dependency on all the XMonad.* modules. It is -- intended to help xmonad hackers ensure that contrib modules build after API -- changes. -- @@ -17,78 +17,78 @@ ----------------------------------------------------------------------------- -module XMonadContrib.MetaModule () where +module XMonad.MetaModule () where -import XMonadContrib.Accordion () -import XMonadContrib.Anneal () -import XMonadContrib.Circle () -import XMonadContrib.Commands () -import XMonadContrib.Combo () -- broken under ghc head -import XMonadContrib.ConstrainedResize () -import XMonadContrib.CopyWindow () -import XMonadContrib.CycleWS () -import XMonadContrib.DeManage () -import XMonadContrib.DirectoryPrompt () -import XMonadContrib.Dishes () -import XMonadContrib.Dmenu () -import XMonadContrib.DragPane () -import XMonadContrib.DwmPromote () -import XMonadContrib.DynamicLog () -import XMonadContrib.DynamicWorkspaces () -import XMonadContrib.Dzen () -import XMonadContrib.EwmhDesktops () -import XMonadContrib.FindEmptyWorkspace () -import XMonadContrib.FlexibleResize () -import XMonadContrib.FlexibleManipulate () -import XMonadContrib.FloatKeys () -import XMonadContrib.FocusNth () -import XMonadContrib.Grid () -import XMonadContrib.Invisible () --- import XMonadContrib.HintedTile () -import XMonadContrib.LayoutCombinators () -import XMonadContrib.LayoutModifier () -import XMonadContrib.LayoutHints () -import XMonadContrib.LayoutScreens () -import XMonadContrib.MagicFocus () -import XMonadContrib.ManageDocks () -import XMonadContrib.ManPrompt () --- import XMonadContrib.Magnifier () -import XMonadContrib.Maximize () --- import XMonadContrib.Mosaic () -import XMonadContrib.MosaicAlt () -import XMonadContrib.MouseGestures () -import XMonadContrib.NamedWindows () -import XMonadContrib.NoBorders () -import XMonadContrib.ResizableTile () -import XMonadContrib.Roledex () -import XMonadContrib.RotSlaves () -import XMonadContrib.RotView () -import XMonadContrib.Run () -import XMonadContrib.SetWMName () -import XMonadContrib.ShellPrompt () -import XMonadContrib.SimpleDate () -import XMonadContrib.SinkAll () -import XMonadContrib.Spiral () -import XMonadContrib.Square () -import XMonadContrib.SshPrompt () -import XMonadContrib.Submap () -import XMonadContrib.SwapWorkspaces () -import XMonadContrib.SwitchTrans () -import XMonadContrib.Tabbed () -import XMonadContrib.TagWindows () -import XMonadContrib.ThreeColumns () -import XMonadContrib.TilePrime () -import XMonadContrib.ToggleLayouts () -import XMonadContrib.TwoPane () -import XMonadContrib.XMonadPrompt () -import XMonadContrib.XPrompt () -import XMonadContrib.XPropManage () -import XMonadContrib.XSelection () -import XMonadContrib.XUtils () -import XMonadContrib.Warp () -import XMonadContrib.WindowBringer () -import XMonadContrib.WindowNavigation () -import XMonadContrib.WindowPrompt () -import XMonadContrib.WmiiActions () -import XMonadContrib.WorkspaceDir () -import XMonadContrib.WorkspacePrompt () +import XMonad.Accordion () +import XMonad.Anneal () +import XMonad.Circle () +import XMonad.Commands () +-- import XMonad.Combo () -- broken under ghc head +import XMonad.ConstrainedResize () +import XMonad.CopyWindow () +import XMonad.CycleWS () +import XMonad.DeManage () +import XMonad.DirectoryPrompt () +import XMonad.Dishes () +import XMonad.Dmenu () +import XMonad.DragPane () +import XMonad.DwmPromote () +import XMonad.DynamicLog () +import XMonad.DynamicWorkspaces () +import XMonad.Dzen () +import XMonad.EwmhDesktops () +import XMonad.FindEmptyWorkspace () +import XMonad.FlexibleResize () +import XMonad.FlexibleManipulate () +import XMonad.FloatKeys () +import XMonad.FocusNth () +import XMonad.Grid () +import XMonad.Invisible () +-- import XMonad.HintedTile () +-- import XMonad.LayoutCombinators () +import XMonad.LayoutModifier () +-- import XMonad.LayoutHints () +import XMonad.LayoutScreens () +import XMonad.MagicFocus () +-- import XMonad.ManageDocks () +import XMonad.ManPrompt () +-- import XMonad.Magnifier () +import XMonad.Maximize () +-- import XMonad.Mosaic () +import XMonad.MosaicAlt () +import XMonad.MouseGestures () +import XMonad.NamedWindows () +import XMonad.NoBorders () +import XMonad.ResizableTile () +import XMonad.Roledex () +import XMonad.RotSlaves () +import XMonad.RotView () +import XMonad.Run () +import XMonad.SetWMName () +import XMonad.ShellPrompt () +import XMonad.SimpleDate () +import XMonad.SinkAll () +import XMonad.Spiral () +import XMonad.Square () +import XMonad.SshPrompt () +import XMonad.Submap () +import XMonad.SwapWorkspaces () +-- import XMonad.SwitchTrans () +import XMonad.Tabbed () +import XMonad.TagWindows () +import XMonad.ThreeColumns () +-- import XMonad.TilePrime () +import XMonad.ToggleLayouts () +import XMonad.TwoPane () +import XMonad.XMonadPrompt () +import XMonad.XPrompt () +import XMonad.XPropManage () +import XMonad.XSelection () +import XMonad.XUtils () +import XMonad.Warp () +import XMonad.WindowBringer () +import XMonad.WindowNavigation () +import XMonad.WindowPrompt () +import XMonad.WmiiActions () +import XMonad.WorkspaceDir () +import XMonad.WorkspacePrompt () diff --git a/Mosaic.hs b/Mosaic.hs deleted file mode 100644 index 8defbc7..0000000 --- a/Mosaic.hs +++ /dev/null @@ -1,407 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.NamedWindows -import XMonadContrib.Anneal - --- $usage --- --- Key bindings: --- --- You can use this module with the following in your Config.hs: --- --- > import XMonadContrib.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 XMonadContrib.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/MosaicAlt.hs b/MosaicAlt.hs deleted file mode 100644 index 0129028..0000000 --- a/MosaicAlt.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/MouseGestures.hs b/MouseGestures.hs deleted file mode 100644 index 93eea03..0000000 --- a/MouseGestures.hs +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.MouseGestures --- Copyright : (c) Lukas Mai --- License : BSD3-style (see LICENSE) --- --- Maintainer : --- Stability : unstable --- Portability : unportable --- --- Support for simple mouse gestures --- ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.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/NamedWindows.hs b/NamedWindows.hs deleted file mode 100644 index 9237255..0000000 --- a/NamedWindows.hs +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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/NoBorders.hs b/NoBorders.hs deleted file mode 100644 index a1fdc96..0000000 --- a/NoBorders.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.NoBorders ( - -- * Usage - -- $usage - noBorders, - smartBorders, - withBorder - ) where - -import Control.Monad.State (gets) -import Control.Monad.Reader (asks) -import Graphics.X11.Xlib - -import XMonad -import XMonadContrib.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 XMonadContrib.NoBorders --- --- and modify the layouts to call noBorders on the layouts you want to lack --- borders --- --- > layouts = [ Layout (noBorders Full), ... ] --- - --- %import XMonadContrib.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/ResizableTile.hs b/ResizableTile.hs deleted file mode 100644 index c41f225..0000000 --- a/ResizableTile.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/Roledex.hs b/Roledex.hs deleted file mode 100644 index 66c58ba..0000000 --- a/Roledex.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Roledex --- > layouts = [ Layout Roledex ] - --- %import XMonadContrib.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/RotSlaves.hs b/RotSlaves.hs deleted file mode 100644 index b5406b0..0000000 --- a/RotSlaves.hs +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.TwoPane). - --- %import XMonadContrib.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/RotView.hs b/RotView.hs deleted file mode 100644 index 304eba2..0000000 --- a/RotView.hs +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.RotView --- --- > , ((modMask .|. shiftMask, xK_Right), rotView True) --- > , ((modMask .|. shiftMask, xK_Left), rotView False) - --- %import XMonadContrib.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/Run.hs b/Run.hs deleted file mode 100644 index 2e0258c..0000000 --- a/Run.hs +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.Dmenu (by --- Spenver Jannsen), XMonadContrib.Dzen (by glasser@mit.edu) and --- XMonadContrib.RunInXTerm (by Andrea Rossato). --- ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.SshPrompt --- --- For an example usage of runProcessWithInput see --- XMonadContrib.{DirectoryPrompt,Dmenu,ShellPrompt,WmiiActions,WorkspaceDir} --- --- For an example usage of runProcessWithInputAndWait see XMonadContrib.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/SetWMName.hs b/SetWMName.hs deleted file mode 100644 index 6eddda6..0000000 --- a/SetWMName.hs +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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/ShellPrompt.hs b/ShellPrompt.hs deleted file mode 100644 index 756b216..0000000 --- a/ShellPrompt.hs +++ /dev/null @@ -1,127 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.ShellPrompt --- Copyright : (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- --- A shell prompt for XMonad --- ------------------------------------------------------------------------------ - -module XMonadContrib.ShellPrompt ( - -- * Usage - -- $usage - shellPrompt - , getShellCompl - , split - , prompt - , safePrompt - ) where - -import System.Environment -import Control.Monad -import Data.List -import System.Directory -import System.IO -import XMonadContrib.Run -import XMonad -import XMonadContrib.XPrompt - --- $usage --- --- 1. In Config.hs add: --- --- > import XMonadContrib.XPrompt --- > import XMonadContrib.ShellPrompt --- --- 2. In your keybindings add something like: --- --- > , ((modMask .|. controlMask, xK_x), shellPrompt defaultXPConfig) --- - --- %import XMonadContrib.XPrompt --- %import XMonadContrib.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/SimpleDate.hs b/SimpleDate.hs deleted file mode 100644 index 6712a5c..0000000 --- a/SimpleDate.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.SimpleDate ( - -- * Usage - -- $usage - date - ) where - -import XMonad - --- $usage --- To use, modify your Config.hs to: --- --- > import XMonadContrib.SimpleDate --- --- and add a keybinding: --- --- > , ((modMask, xK_d ), date) --- --- a popup date menu will now be bound to mod-d - --- %import XMonadContrib.SimpleDate --- %keybind , ((modMask, xK_d ), date) - -date :: X () -date = spawn "(date; sleep 10) | dzen2" diff --git a/SinkAll.hs b/SinkAll.hs deleted file mode 100644 index 9ba9915..0000000 --- a/SinkAll.hs +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 XMonadContrib.SinkAll ( - -- * Usage - -- $usage - sinkAll) where - -import XMonad.Operations -import XMonad -import XMonad.StackSet - -import Graphics.X11.Xlib - --- $usage --- > import XMonadContrib.SinkAll --- > keys = [ ((modMask .|. shiftMask, xK_t), sinkAll) ] - --- %import XMonadContrib.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/Spiral.hs b/Spiral.hs deleted file mode 100644 index 0aba738..0000000 --- a/Spiral.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.Spiral --- Copyright : (c) Joe Thornber --- License : BSD3-style (see LICENSE) --- --- Maintainer : Joe Thornber --- Stability : stable --- Portability : portable --- --- Spiral adds a spiral tiling layout --- ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.Spiral --- --- > layouts = [ ..., Layout $ spiral (1 % 1), ... ] - --- %import XMonadContrib.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/Square.hs b/Square.hs deleted file mode 100644 index 46ad2e7..0000000 --- a/Square.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 --- "XMonadContrib.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 XMonadContrib.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 XMonadContrib.Square --- --- An example layout using square together with "XMonadContrib.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 XMonadContrib.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/SshPrompt.hs b/SshPrompt.hs deleted file mode 100644 index 64dd5ef..0000000 --- a/SshPrompt.hs +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.SshPrompt --- Copyright : (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- --- A ssh prompt for XMonad --- ------------------------------------------------------------------------------ - -module XMonadContrib.SshPrompt ( - -- * Usage - -- $usage - sshPrompt - ) where - -import XMonad -import XMonadContrib.Run -import XMonadContrib.XPrompt - -import System.Directory -import System.Environment - -import Control.Monad -import Data.List -import Data.Maybe - --- $usage --- 1. In Config.hs add: --- --- > import XMonadContrib.XPrompt --- > import XMonadContrib.SshPrompt --- --- 2. In your keybindings add something like: --- --- > , ((modMask .|. controlMask, xK_s), sshPrompt defaultXPConfig) --- - --- %import XMonadContrib.XPrompt --- %import XMonadContrib.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/Submap.hs b/Submap.hs deleted file mode 100644 index a9a2749..0000000 --- a/Submap.hs +++ /dev/null @@ -1,71 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/SwapWorkspaces.hs b/SwapWorkspaces.hs deleted file mode 100644 index 735426f..0000000 --- a/SwapWorkspaces.hs +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.SwapWorkspaces ( - -- * Usage - -- $usage - swapWithCurrent, - swapWorkspaces - ) where - -import XMonad.StackSet - --- $usage --- Add this import to your Config.hs: --- --- > import XMonadContrib.SwapWorkspaces --- --- Throw this in your keys definition: --- --- > ++ --- > [((modMask .|. controlMask, k), windows $ swapWithCurrent i) --- > | (i, k) <- zip workspaces [xK_1 ..]] - --- %import XMonadContrib.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/SwitchTrans.hs b/SwitchTrans.hs deleted file mode 100644 index 3050924..0000000 --- a/SwitchTrans.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 "XMonadContrib.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 XMonadContrib.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/Tabbed.hs b/Tabbed.hs deleted file mode 100644 index 0b61cf3..0000000 --- a/Tabbed.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.NamedWindows -import XMonadContrib.Invisible -import XMonadContrib.XUtils - --- $usage --- You can use this module with the following in your configuration file: --- --- > import XMonadContrib.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 XMonadContrib.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/TagWindows.hs b/TagWindows.hs deleted file mode 100644 index e11b579..0000000 --- a/TagWindows.hs +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.TagWindows --- Copyright : (c) Karsten Schoelzel --- License : BSD --- --- Maintainer : Karsten Schoelzel --- Stability : unstable --- Portability : unportable --- --- Functions for tagging windows and selecting them by tags. ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.XPrompt -import XMonad hiding (workspaces) - --- $usage --- --- To use window tags add in your Config.hs: --- --- > import XMonadContrib.TagWindows --- > import XMonadContrib.XPrompt -- 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 XMonadContrib.TagWindows --- %import XMonadContrib.XPrompt -- 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/ThreeColumns.hs b/ThreeColumns.hs deleted file mode 100644 index 9b10cc4..0000000 --- a/ThreeColumns.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.ThreeColumns --- --- and add, to the list of layouts: --- --- > ThreeCol nmaster delta ratio - --- %import XMonadContrib.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/TilePrime.hs b/TilePrime.hs deleted file mode 100644 index c939d81..0000000 --- a/TilePrime.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# 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 XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/ToggleLayouts.hs b/ToggleLayouts.hs deleted file mode 100644 index efcaab7..0000000 --- a/ToggleLayouts.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.ToggleLayouts --- Copyright : (c) David Roundy --- License : BSD --- --- Maintainer : David Roundy --- Stability : unstable --- Portability : portable --- --- A module for writing easy Layouts ------------------------------------------------------------------------------ - -module XMonadContrib.ToggleLayouts ( - -- * Usage - -- $usage - toggleLayouts, ToggleLayout(..) - ) where - -import XMonad - --- $usage --- Use toggleLayouts to toggle between two layouts. --- --- import XMonadContrib.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/TwoPane.hs b/TwoPane.hs deleted file mode 100644 index 2dc266f..0000000 --- a/TwoPane.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.TwoPane --- --- and add, to the list of layouts: --- --- > , (Layout $ TwoPane 0.03 0.5) - --- %import XMonadContrib.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/UrgencyHook.hs b/UrgencyHook.hs deleted file mode 100644 index 8f59af8..0000000 --- a/UrgencyHook.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.UrgencyHook ( - -- * Usage - -- $usage - withUrgencyHook, - focusUrgent, - readUrgents, - withUrgents - ) where - -import {-# SOURCE #-} Config (urgencyHook, logHook) -import Operations (windows) -import qualified StackSet as W -import XMonad -import XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/Warp.hs b/Warp.hs deleted file mode 100644 index e53b82c..0000000 --- a/Warp.hs +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.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/WindowBringer.hs b/WindowBringer.hs deleted file mode 100644 index b6020d2..0000000 --- a/WindowBringer.hs +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.Dmenu (dmenuMap) -import XMonadContrib.NamedWindows (getName) - --- $usage --- --- Place in your Config.hs: --- --- > import XMonadContrib.WindowBringer --- --- and in the keys definition: --- --- > , ((modMask .|. shiftMask, xK_g ), gotoMenu) --- > , ((modMask .|. shiftMask, xK_b ), bringMenu) - --- %import XMonadContrib.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/WindowNavigation.hs b/WindowNavigation.hs deleted file mode 100644 index 05c3bb8..0000000 --- a/WindowNavigation.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 XMonadContrib.LayoutModifier -import XMonadContrib.Invisible -import XMonadContrib.XUtils - --- $usage --- You can use this module with the following in your Config.hs file: --- --- > import XMonadContrib.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 XMonadContrib.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/WindowPrompt.hs b/WindowPrompt.hs deleted file mode 100644 index 5311f15..0000000 --- a/WindowPrompt.hs +++ /dev/null @@ -1,89 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.WindowPrompt --- 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 XMonadContrib.WindowPrompt - ( - -- * 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 XMonadContrib.XPrompt -import XMonadContrib.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 XMonadContrib.XPrompt --- > import XMonadContrib.WindowPrompt --- --- and in the keys definition: --- --- > , ((modMask .|. shiftMask, xK_g ), windowPromptGoto defaultXPConfig) --- > , ((modMask .|. shiftMask, xK_b ), windowPromptBring defaultXPConfig) - --- %import XMonadContrib.XPrompt --- %import XMonadContrib.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/WmiiActions.hs b/WmiiActions.hs deleted file mode 100644 index 2a82791..0000000 --- a/WmiiActions.hs +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.WmiiActions ( - -- * Usage - -- $usage - wmiiActions - , wmiiActionsXinerama - , executables - , executablesXinerama - ) where - -import XMonad -import XMonadContrib.Dmenu (dmenu, dmenuXinerama) -import XMonadContrib.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 XMonadContrib.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 "XMonadContrib.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/WorkspaceDir.hs b/WorkspaceDir.hs deleted file mode 100644 index a967741..0000000 --- a/WorkspaceDir.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.WorkspaceDir ( - -- * Usage - -- $usage - workspaceDir, - changeDir - ) where - -import System.Directory ( setCurrentDirectory ) - -import XMonad -import XMonad.Operations ( sendMessage ) -import XMonadContrib.Run ( runProcessWithInput ) -import XMonadContrib.XPrompt ( XPConfig ) -import XMonadContrib.DirectoryPrompt ( directoryPrompt ) -import XMonadContrib.LayoutModifier - --- $usage --- You can use this module with the following in your Config.hs file: --- --- > import XMonadContrib.WorkspaceDir --- > --- > layouts = map (workspaceDir "~") [ tiled, ... ] --- --- In keybindings: --- --- > , ((modMask .|. shiftMask, xK_x ), changeDir defaultXPConfig) - --- %import XMonadContrib.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/WorkspacePrompt.hs b/WorkspacePrompt.hs deleted file mode 100644 index 1087cf0..0000000 --- a/WorkspacePrompt.hs +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.WorkspacePrompt --- Copyright : (C) 2007 Andrea Rossato, David Roundy --- License : BSD3 --- --- Maintainer : droundy@darcs.net --- Stability : unstable --- Portability : unportable --- --- A directory prompt for XMonad --- ------------------------------------------------------------------------------ - -module XMonadContrib.WorkspacePrompt ( - -- * Usage - -- $usage - workspacePrompt - ) where - -import Control.Monad.State ( gets ) -import Data.List ( sort ) -import XMonad hiding ( workspaces ) -import XMonadContrib.XPrompt -import XMonad.StackSet ( workspaces, tag ) - --- $usage --- You can use this module with the following in your Config.hs file: --- --- > import XMonadContrib.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/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 diff --git a/XMonadPrompt.hs b/XMonadPrompt.hs deleted file mode 100644 index d60fe67..0000000 --- a/XMonadPrompt.hs +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.XMonadPrompt --- Copyright : (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- --- A prompt for running XMonad commands --- ------------------------------------------------------------------------------ - -module XMonadContrib.XMonadPrompt ( - -- * Usage - -- $usage - xmonadPrompt, - xmonadPromptC - ) where - -import XMonad -import XMonadContrib.XPrompt -import XMonadContrib.Commands (defaultCommands, runCommand') - --- $usage --- --- in Config.hs add: --- --- > import XMonadContrib.XPrompt --- > import XMonadContrib.XMonadPrompt --- --- in you keybindings add: --- --- > , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultXPConfig) --- - --- %import XMonadContrib.XPrompt --- %import XMonadContrib.XMonadPrompt --- %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/XPrompt.hs b/XPrompt.hs deleted file mode 100644 index 8df0d2f..0000000 --- a/XPrompt.hs +++ /dev/null @@ -1,686 +0,0 @@ -{-# 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 XMonadContrib.XPrompt ( - -- * 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 XMonadContrib.XUtils -import XMonadContrib.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/XPropManage.hs b/XPropManage.hs deleted file mode 100644 index e946832..0000000 --- a/XPropManage.hs +++ /dev/null @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.XPropManage --- Copyright : (c) Karsten Schoelzel --- License : BSD --- --- Maintainer : Karsten Schoelzel --- Stability : unstable --- Portability : unportable --- --- A ManageHook matching on XProperties. ------------------------------------------------------------------------------ - -module XMonadContrib.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 XMonadContrib.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/XSelection.hs b/XSelection.hs deleted file mode 100644 index 78d70fe..0000000 --- a/XSelection.hs +++ /dev/null @@ -1,175 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 XMonadContrib.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 XMonadContrib.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/XUtils.hs b/XUtils.hs deleted file mode 100644 index 15c89b2..0000000 --- a/XUtils.hs +++ /dev/null @@ -1,191 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.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 XMonadContrib.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 diff --git a/tests/test_SwapWorkspaces.hs b/tests/test_SwapWorkspaces.hs index cc1ee6d..dc4c82c 100644 --- a/tests/test_SwapWorkspaces.hs +++ b/tests/test_SwapWorkspaces.hs @@ -6,7 +6,7 @@ import Test.QuickCheck import StackSet import Properties(T, NonNegative) -import XMonadContrib.SwapWorkspaces +import XMonad.SwapWorkspaces -- Ensures that no "loss of information" can happen from a swap. prop_double_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) = diff --git a/tests/test_XPrompt.hs b/tests/test_XPrompt.hs index 11283d7..f82c036 100644 --- a/tests/test_XPrompt.hs +++ b/tests/test_XPrompt.hs @@ -10,8 +10,8 @@ import Test.QuickCheck import Data.List -import XMonadContrib.XPrompt -import qualified XMonadContrib.ShellPrompt as S +import XMonad.XPrompt +import qualified XMonad.ShellPrompt as S instance Arbitrary Char where arbitrary = choose ('\32', '\255') -- cgit v1.2.3