adddir ./Thunk adddir ./include addfile ./Setup.lhs hunk ./Setup.lhs 1 +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain addfile ./Thunk/Wm.hs hunk ./Thunk/Wm.hs 1 +{-# OPTIONS_GHC -fglasgow-exts #-} + +module Thunk.Wm where + +import Data.Sequence +import Control.Monad.State +import System.IO (hFlush, hPutStrLn, stderr) +import Graphics.X11.Xlib + +data WmState = WmState + { display :: Display + , screenWidth :: Int + , screenHeight :: Int + , windows :: Seq Window + } + +newtype Wm a = Wm (StateT WmState IO a) + deriving (Monad, MonadIO{-, MonadState WmState-}) + +runWm :: Wm a -> WmState -> IO (a, WmState) +runWm (Wm m) = runStateT m + +l :: IO a -> Wm a +l = liftIO + +trace msg = l $ do + hPutStrLn stderr msg + hFlush stderr + +withIO :: (forall b. (a -> IO b) -> IO b) -> (a -> Wm c) -> Wm c +withIO f g = do + s <- Wm get + (y, s') <- l $ f $ \x -> runWm (g x) s + Wm (put s') + return y + +getDisplay = Wm (gets display) + +getWindows = Wm (gets windows) + +getScreenWidth = Wm (gets screenWidth) + +getScreenHeight = Wm (gets screenHeight) + +setWindows x = Wm (modify (\s -> s {windows = x})) + +modifyWindows :: (Seq Window -> Seq Window) -> Wm () +modifyWindows f = Wm (modify (\s -> s {windows = f (windows s)})) addfile ./Thunk/XlibExtras.hsc hunk ./Thunk/XlibExtras.hsc 1 +module Thunk.XlibExtras where + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Types +import Foreign +import Foreign.C.Types +import Control.Monad (ap) + +#include "XlibExtras.h" + +data Event + = AnyEvent + { event_type :: EventType + , serial :: CULong + , send_event :: Bool + , event_display :: Display + , window :: Window + } + | ConfigureRequestEvent + { event_type :: EventType + , serial :: CULong + , send_event :: Bool + , event_display :: Display + , parent :: Window + , window :: Window + , x :: Int + , y :: Int + , width :: Int + , height :: Int + , border_width :: Int + , above :: Window + , detail :: Int + , value_mask :: CULong + } + | MapRequestEvent + { event_type :: EventType + , serial :: CULong + , send_event :: Bool + , event_display :: Display + , parent :: Window + , window :: Window + } + | KeyEvent + { event_type :: EventType + , serial :: CULong + , send_event :: Bool + , event_display :: Display + , window :: Window + , root :: Window + , subwindow :: Window + , time :: Time + , x :: Int + , y :: Int + , x_root :: Int + , y_root :: Int + , state :: KeyMask + , keycode :: KeyCode + , same_screen :: Bool + } + | DestroyWindowEvent + { event_type :: EventType + , serial :: CULong + , send_event :: Bool + , event_display :: Display + , event :: Window + , window :: Window + } + | UnmapEvent + { event_type :: EventType + , serial :: CULong + , send_event :: Bool + , event_display :: Display + , event :: Window + , window :: Window + , fromConfigure :: Bool + } + deriving Show + +getEvent :: XEventPtr -> IO Event +getEvent p = do + -- All events share this layout and naming convention, there is also a + -- common Window field, but the names for this field vary. + type_ <- #{peek XAnyEvent, type} p + serial_ <- #{peek XAnyEvent, serial} p + send_event_ <- #{peek XAnyEvent, send_event} p + display_ <- fmap Display (#{peek XAnyEvent, display} p) + case () of + + ------------------------- + -- ConfigureRequestEvent: + ------------------------- + _ | type_ == configureRequest -> do + parent_ <- #{peek XConfigureRequestEvent, parent } p + window_ <- #{peek XConfigureRequestEvent, window } p + x_ <- #{peek XConfigureRequestEvent, x } p + y_ <- #{peek XConfigureRequestEvent, y } p + width_ <- #{peek XConfigureRequestEvent, width } p + height_ <- #{peek XConfigureRequestEvent, height } p + border_width_ <- #{peek XConfigureRequestEvent, border_width} p + above_ <- #{peek XConfigureRequestEvent, above } p + detail_ <- #{peek XConfigureRequestEvent, detail } p + value_mask_ <- #{peek XConfigureRequestEvent, value_mask } p + return $ ConfigureRequestEvent + { event_type = type_ + , serial = serial_ + , send_event = send_event_ + , event_display = display_ + , parent = parent_ + , window = window_ + , x = x_ + , y = y_ + , width = width_ + , height = height_ + , border_width = border_width_ + , above = above_ + , detail = detail_ + , value_mask = value_mask_ + } + + ------------------- + -- MapRequestEvent: + ------------------- + | type_ == mapRequest -> do + parent_ <- #{peek XMapRequestEvent, parent} p + window_ <- #{peek XMapRequestEvent, window} p + return $ MapRequestEvent + { event_type = type_ + , serial = serial_ + , send_event = send_event_ + , event_display = display_ + , parent = parent_ + , window = window_ + } + + ------------ + -- KeyEvent: + ------------ + | type_ == keyPress || type_ == keyRelease -> do + window_ <- #{peek XKeyEvent, window } p + root_ <- #{peek XKeyEvent, root } p + subwindow_ <- #{peek XKeyEvent, subwindow } p + time_ <- #{peek XKeyEvent, time } p + x_ <- #{peek XKeyEvent, x } p + y_ <- #{peek XKeyEvent, y } p + x_root_ <- #{peek XKeyEvent, x_root } p + y_root_ <- #{peek XKeyEvent, y_root } p + state_ <- #{peek XKeyEvent, state } p + keycode_ <- #{peek XKeyEvent, keycode } p + same_screen_ <- #{peek XKeyEvent, same_screen} p + return $ KeyEvent + { event_type = type_ + , serial = serial_ + , send_event = send_event_ + , event_display = display_ + , window = window_ + , root = root_ + , subwindow = subwindow_ + , time = time_ + , x = x_ + , y = y_ + , x_root = x_root_ + , y_root = y_root_ + , state = state_ + , keycode = keycode_ + , same_screen = same_screen_ + } + + ---------------------- + -- DestroyWindowEvent: + ---------------------- + | type_ == destroyNotify -> do + event_ <- #{peek XDestroyWindowEvent, event } p + window_ <- #{peek XDestroyWindowEvent, window} p + return $ DestroyWindowEvent + { event_type = type_ + , serial = serial_ + , send_event = send_event_ + , event_display = display_ + , event = event_ + , window = window_ + } + + + -------------------- + -- UnmapNotifyEvent: + -------------------- + | type_ == unmapNotify -> do + event_ <- #{peek XUnmapEvent, event } p + window_ <- #{peek XUnmapEvent, window } p + fromConfigure_ <- #{peek XUnmapEvent, from_configure} p + return $ UnmapEvent + { event_type = type_ + , serial = serial_ + , send_event = send_event_ + , event_display = display_ + , event = event_ + , window = window_ + , fromConfigure = fromConfigure_ + } + + -- We don't handle this event specifically, so return the generic + -- AnyEvent. + | otherwise -> do + window_ <- #{peek XAnyEvent, window} p + return $ AnyEvent + { event_type = type_ + , serial = serial_ + , send_event = send_event_ + , event_display = display_ + , window = window_ + } + +data WindowChanges = WindowChanges + { wcX :: Int + , wcY :: Int + , wcWidth :: Int + , wcHeight:: Int + , wcBorderWidth :: Int + , wcSibling :: Window + , wcStackMode :: Int + } + +instance Storable WindowChanges where + sizeOf _ = #{size XWindowChanges} + + -- I really hope this is right: + alignment _ = alignment (undefined :: Int) + + poke p wc = do + #{poke XWindowChanges, x } p $ wcX wc + #{poke XWindowChanges, y } p $ wcY wc + #{poke XWindowChanges, width } p $ wcWidth wc + #{poke XWindowChanges, height } p $ wcHeight wc + #{poke XWindowChanges, border_width} p $ wcBorderWidth wc + #{poke XWindowChanges, sibling } p $ wcSibling wc + #{poke XWindowChanges, stack_mode } p $ wcStackMode wc + + peek p = return WindowChanges + `ap` (#{peek XWindowChanges, x} p) + `ap` (#{peek XWindowChanges, y} p) + `ap` (#{peek XWindowChanges, width} p) + `ap` (#{peek XWindowChanges, height} p) + `ap` (#{peek XWindowChanges, border_width} p) + `ap` (#{peek XWindowChanges, sibling} p) + `ap` (#{peek XWindowChanges, stack_mode} p) + +foreign import ccall unsafe "XlibExtras.h XConfigureWindow" + xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO Int + +configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO () +configureWindow d w m c = do + with c (xConfigureWindow d w m) + return () addfile ./include/XlibExtras.h hunk ./include/XlibExtras.h 1 +/* This file copied from the X11 package */ + +/* ----------------------------------------------------------------------------- + * Definitions for package `X11' which are visible in Haskell land. + * ---------------------------------------------------------------------------* + */ + +#ifndef XLIBEXTRAS_H +#define XLIBEXTRAS_H +#include +/* This doesn't always work, so we play safe below... */ +#define XUTIL_DEFINE_FUNCTIONS +#include +#include +#include +#include +#include +/* Xutil.h overrides some functions with macros. + * In recent versions of X this can be turned off with + * #define XUTIL_DEFINE_FUNCTIONS + * before the #include, but this doesn't work with older versions. + * As a workaround, we undef the macros here. Note that this is only + * safe for functions with return type int. + */ +#undef XDestroyImage +#undef XGetPixel +#undef XPutPixel +#undef XSubImage +#undef XAddPixel +#define XK_MISCELLANY +#define XK_LATIN1 +#include +#endif addfile ./thunk.cabal hunk ./thunk.cabal 1 +Name: thunk +Version: 0.0 +Description: A lightweight X11 window manager. +Author: Spencer Janssen +Maintainer: sjanssen@cse.unl.edu +Build-Depends: base >= 2.0, X11, unix, mtl + +Executable: thunk +Main-Is: thunk.hs +Extensions: ForeignFunctionInterface +Other-Modules: Thunk.XlibExtras +Include-Dirs: include addfile ./thunk.hs hunk ./thunk.hs 1 +{-# OPTIONS_GHC -fglasgow-exts #-} + +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Sequence as Seq +import qualified Data.Foldable as Fold +import Data.Bits +import Control.Monad.State +import System.IO +import Graphics.X11.Xlib +import System.Process (runCommand) +import System.Exit +import Thunk.Wm +import Thunk.XlibExtras + +handler :: Event -> Wm () +handler (MapRequestEvent {window = w}) = manage w +handler (DestroyWindowEvent {window = w}) = do + modifyWindows (Seq.fromList . filter (/= w) . Fold.toList) + refresh +handler (KeyEvent {event_type = t, state = mod, keycode = code}) + | t == keyPress = do + dpy <- getDisplay + sym <- l $ keycodeToKeysym dpy code 0 + case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of + [] -> return () + ((_, _, act):_) -> act +handler _ = return () + +switch :: Wm () +switch = do + ws' <- getWindows + case viewl ws' of + EmptyL -> return () + (w :< ws) -> do + setWindows (ws |> w) + refresh + +spawn :: String -> Wm () +spawn c = do + l $ runCommand c + return () + +keys :: [(KeyMask, KeySym, Wm ())] +keys = + [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") + , (controlMask, xK_space, spawn "gmrun") + , (mod1Mask, xK_Tab, switch) + , (mod1Mask .|. shiftMask, xK_q, l $ exitWith ExitSuccess) + ] + +grabkeys = do + dpy <- getDisplay + root <- l $ rootWindow dpy (defaultScreen dpy) + forM_ keys $ \(mod, sym, _) -> do + code <- l $ keysymToKeycode dpy sym + l $ grabKey dpy code mod root True grabModeAsync grabModeAsync + +manage :: Window -> Wm () +manage w = do + trace "manage" + d <- getDisplay + ws <- getWindows + when (Fold.notElem w ws) $ do + trace "modifying" + modifyWindows (w <|) + l $ mapWindow d w + refresh + +refresh :: Wm () +refresh = do + v <- getWindows + case viewl v of + EmptyL -> return () + (w :< _) -> do + d <- getDisplay + sw <- getScreenWidth + sh <- getScreenHeight + l $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) + l $ raiseWindow d w + +main = do + dpy <- openDisplay "" + runWm main' (WmState + { display = dpy + , screenWidth = displayWidth dpy (defaultScreen dpy) + , screenHeight = displayHeight dpy (defaultScreen dpy) + , windows = Seq.empty + }) + return () + +main' = do + dpy <- getDisplay + let screen = defaultScreen dpy + root <- l $ rootWindow dpy screen + l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) + l $ sync dpy False + grabkeys + loop + +loop :: Wm () +loop = do + dpy <- getDisplay + e <- l $ allocaXEvent $ \ev -> do + nextEvent dpy ev + getEvent ev + handler e + loop hunk ./thunk.cabal 1 -Name: thunk -Version: 0.0 -Description: A lightweight X11 window manager. -Author: Spencer Janssen -Maintainer: sjanssen@cse.unl.edu -Build-Depends: base >= 2.0, X11, unix, mtl +name: thunk +version: 0.0 +description: A lightweight X11 window manager. +synopsis: A lightweight X11 window manager. +category: System +author: Spencer Janssen +maintainer: sjanssen@cse.unl.edu +build-depends: base >= 2.0, X11, unix, mtl hunk ./thunk.cabal 10 -Executable: thunk -Main-Is: thunk.hs -Extensions: ForeignFunctionInterface -Other-Modules: Thunk.XlibExtras -Include-Dirs: include +executable: thunk +main-is: thunk.hs +extensions: ForeignFunctionInterface +other-modules: Thunk.XlibExtras +ghc-options: -O +include-dirs: include +-- OpenBSD: +-- include-dirs: include /usr/X11R6/include addfile ./LICENSE hunk ./LICENSE 1 +Copyright (c) Spencer Janssen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. hunk ./thunk.cabal 6 +license: BSD3 +license-file: LICENSE addfile ./README hunk ./README 1 +Motivation +---------- move ./Thunk/Wm.hs ./Wm.hs move ./Thunk/XlibExtras.hsc ./XlibExtras.hsc rmdir ./Thunk hunk ./Wm.hs 3 -module Thunk.Wm where +module Wm where hunk ./XlibExtras.hsc 1 -module Thunk.XlibExtras where +module XlibExtras where hunk ./thunk.cabal 15 -other-modules: Thunk.XlibExtras +other-modules: XlibExtras hunk ./thunk.hs 13 -import Thunk.Wm -import Thunk.XlibExtras + +import Wm +import XlibExtras hunk ./XlibExtras.hsc 1 -module XlibExtras where - -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Types -import Foreign -import Foreign.C.Types -import Control.Monad (ap) - -#include "XlibExtras.h" - -data Event - = AnyEvent - { event_type :: EventType - , serial :: CULong - , send_event :: Bool - , event_display :: Display - , window :: Window - } - | ConfigureRequestEvent - { event_type :: EventType - , serial :: CULong - , send_event :: Bool - , event_display :: Display - , parent :: Window - , window :: Window - , x :: Int - , y :: Int - , width :: Int - , height :: Int - , border_width :: Int - , above :: Window - , detail :: Int - , value_mask :: CULong - } - | MapRequestEvent - { event_type :: EventType - , serial :: CULong - , send_event :: Bool - , event_display :: Display - , parent :: Window - , window :: Window - } - | KeyEvent - { event_type :: EventType - , serial :: CULong - , send_event :: Bool - , event_display :: Display - , window :: Window - , root :: Window - , subwindow :: Window - , time :: Time - , x :: Int - , y :: Int - , x_root :: Int - , y_root :: Int - , state :: KeyMask - , keycode :: KeyCode - , same_screen :: Bool - } - | DestroyWindowEvent - { event_type :: EventType - , serial :: CULong - , send_event :: Bool - , event_display :: Display - , event :: Window - , window :: Window - } - | UnmapEvent - { event_type :: EventType - , serial :: CULong - , send_event :: Bool - , event_display :: Display - , event :: Window - , window :: Window - , fromConfigure :: Bool - } - deriving Show - -getEvent :: XEventPtr -> IO Event -getEvent p = do - -- All events share this layout and naming convention, there is also a - -- common Window field, but the names for this field vary. - type_ <- #{peek XAnyEvent, type} p - serial_ <- #{peek XAnyEvent, serial} p - send_event_ <- #{peek XAnyEvent, send_event} p - display_ <- fmap Display (#{peek XAnyEvent, display} p) - case () of - - ------------------------- - -- ConfigureRequestEvent: - ------------------------- - _ | type_ == configureRequest -> do - parent_ <- #{peek XConfigureRequestEvent, parent } p - window_ <- #{peek XConfigureRequestEvent, window } p - x_ <- #{peek XConfigureRequestEvent, x } p - y_ <- #{peek XConfigureRequestEvent, y } p - width_ <- #{peek XConfigureRequestEvent, width } p - height_ <- #{peek XConfigureRequestEvent, height } p - border_width_ <- #{peek XConfigureRequestEvent, border_width} p - above_ <- #{peek XConfigureRequestEvent, above } p - detail_ <- #{peek XConfigureRequestEvent, detail } p - value_mask_ <- #{peek XConfigureRequestEvent, value_mask } p - return $ ConfigureRequestEvent - { event_type = type_ - , serial = serial_ - , send_event = send_event_ - , event_display = display_ - , parent = parent_ - , window = window_ - , x = x_ - , y = y_ - , width = width_ - , height = height_ - , border_width = border_width_ - , above = above_ - , detail = detail_ - , value_mask = value_mask_ - } - - ------------------- - -- MapRequestEvent: - ------------------- - | type_ == mapRequest -> do - parent_ <- #{peek XMapRequestEvent, parent} p - window_ <- #{peek XMapRequestEvent, window} p - return $ MapRequestEvent - { event_type = type_ - , serial = serial_ - , send_event = send_event_ - , event_display = display_ - , parent = parent_ - , window = window_ - } - - ------------ - -- KeyEvent: - ------------ - | type_ == keyPress || type_ == keyRelease -> do - window_ <- #{peek XKeyEvent, window } p - root_ <- #{peek XKeyEvent, root } p - subwindow_ <- #{peek XKeyEvent, subwindow } p - time_ <- #{peek XKeyEvent, time } p - x_ <- #{peek XKeyEvent, x } p - y_ <- #{peek XKeyEvent, y } p - x_root_ <- #{peek XKeyEvent, x_root } p - y_root_ <- #{peek XKeyEvent, y_root } p - state_ <- #{peek XKeyEvent, state } p - keycode_ <- #{peek XKeyEvent, keycode } p - same_screen_ <- #{peek XKeyEvent, same_screen} p - return $ KeyEvent - { event_type = type_ - , serial = serial_ - , send_event = send_event_ - , event_display = display_ - , window = window_ - , root = root_ - , subwindow = subwindow_ - , time = time_ - , x = x_ - , y = y_ - , x_root = x_root_ - , y_root = y_root_ - , state = state_ - , keycode = keycode_ - , same_screen = same_screen_ - } - - ---------------------- - -- DestroyWindowEvent: - ---------------------- - | type_ == destroyNotify -> do - event_ <- #{peek XDestroyWindowEvent, event } p - window_ <- #{peek XDestroyWindowEvent, window} p - return $ DestroyWindowEvent - { event_type = type_ - , serial = serial_ - , send_event = send_event_ - , event_display = display_ - , event = event_ - , window = window_ - } - - - -------------------- - -- UnmapNotifyEvent: - -------------------- - | type_ == unmapNotify -> do - event_ <- #{peek XUnmapEvent, event } p - window_ <- #{peek XUnmapEvent, window } p - fromConfigure_ <- #{peek XUnmapEvent, from_configure} p - return $ UnmapEvent - { event_type = type_ - , serial = serial_ - , send_event = send_event_ - , event_display = display_ - , event = event_ - , window = window_ - , fromConfigure = fromConfigure_ - } - - -- We don't handle this event specifically, so return the generic - -- AnyEvent. - | otherwise -> do - window_ <- #{peek XAnyEvent, window} p - return $ AnyEvent - { event_type = type_ - , serial = serial_ - , send_event = send_event_ - , event_display = display_ - , window = window_ - } - -data WindowChanges = WindowChanges - { wcX :: Int - , wcY :: Int - , wcWidth :: Int - , wcHeight:: Int - , wcBorderWidth :: Int - , wcSibling :: Window - , wcStackMode :: Int - } - -instance Storable WindowChanges where - sizeOf _ = #{size XWindowChanges} - - -- I really hope this is right: - alignment _ = alignment (undefined :: Int) - - poke p wc = do - #{poke XWindowChanges, x } p $ wcX wc - #{poke XWindowChanges, y } p $ wcY wc - #{poke XWindowChanges, width } p $ wcWidth wc - #{poke XWindowChanges, height } p $ wcHeight wc - #{poke XWindowChanges, border_width} p $ wcBorderWidth wc - #{poke XWindowChanges, sibling } p $ wcSibling wc - #{poke XWindowChanges, stack_mode } p $ wcStackMode wc - - peek p = return WindowChanges - `ap` (#{peek XWindowChanges, x} p) - `ap` (#{peek XWindowChanges, y} p) - `ap` (#{peek XWindowChanges, width} p) - `ap` (#{peek XWindowChanges, height} p) - `ap` (#{peek XWindowChanges, border_width} p) - `ap` (#{peek XWindowChanges, sibling} p) - `ap` (#{peek XWindowChanges, stack_mode} p) - -foreign import ccall unsafe "XlibExtras.h XConfigureWindow" - xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO Int - -configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO () -configureWindow d w m c = do - with c (xConfigureWindow d w m) - return () rmfile ./XlibExtras.hsc hunk ./include/XlibExtras.h 1 -/* This file copied from the X11 package */ - -/* ----------------------------------------------------------------------------- - * Definitions for package `X11' which are visible in Haskell land. - * ---------------------------------------------------------------------------* - */ - -#ifndef XLIBEXTRAS_H -#define XLIBEXTRAS_H -#include -/* This doesn't always work, so we play safe below... */ -#define XUTIL_DEFINE_FUNCTIONS -#include -#include -#include -#include -#include -/* Xutil.h overrides some functions with macros. - * In recent versions of X this can be turned off with - * #define XUTIL_DEFINE_FUNCTIONS - * before the #include, but this doesn't work with older versions. - * As a workaround, we undef the macros here. Note that this is only - * safe for functions with return type int. - */ -#undef XDestroyImage -#undef XGetPixel -#undef XPutPixel -#undef XSubImage -#undef XAddPixel -#define XK_MISCELLANY -#define XK_LATIN1 -#include -#endif rmfile ./include/XlibExtras.h rmdir ./include hunk ./thunk.cabal 10 -build-depends: base >= 2.0, X11, unix, mtl +build-depends: base >= 2.0, X11, X11-extras, unix, mtl hunk ./thunk.cabal 14 -extensions: ForeignFunctionInterface -other-modules: XlibExtras hunk ./thunk.cabal 15 -include-dirs: include --- OpenBSD: --- include-dirs: include /usr/X11R6/include hunk ./thunk.hs 11 +import Graphics.X11.Xlib.Extras hunk ./thunk.hs 16 -import XlibExtras hunk ./README 1 -Motivation ----------- + thunk : a lightweight X11 window manager. + +Motivation: + + dwm is great, but we can do better, building a more robust, + more correct window manager in less lines of code, using strong + static typing. Enter Haskell. + + If the aim of dwm is to fit in under 2000 lines of C, the aim of dwm + is to fit in under 500 lines of Haskell with similar functionality. + +Building: + + Get the dependencies + + X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2 + unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 + mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-1.0 + + X11-extras: darcs get http://www.cse.unsw.edu.au/~dons/code/X11-extras + +Use: + + add: + + exec /home/dons/bin/thunk + + as the last line of your .xsession file + +Authors: + + Spencer Janssen + Don Stewart move ./thunk.hs ./Main.hs hunk ./thunk.cabal 10 -build-depends: base >= 2.0, X11, X11-extras, unix, mtl +build-depends: base==2.0, X11==1.1, X11-extras==0.0, unix==1.0, mtl==1.0 hunk ./thunk.cabal 13 -main-is: thunk.hs +main-is: Main.hs hunk ./Main.hs 1 -{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Main.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, uses cunning newtype deriving +-- +----------------------------------------------------------------------------- +-- +-- thunk, a minimal window manager for X11 +-- hunk ./Main.hs 38 - sym <- l $ keycodeToKeysym dpy code 0 + sym <- io $ keycodeToKeysym dpy code 0 hunk ./Main.hs 55 - l $ runCommand c + io $ runCommand c hunk ./Main.hs 63 - , (mod1Mask .|. shiftMask, xK_q, l $ exitWith ExitSuccess) + , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) hunk ./Main.hs 68 - root <- l $ rootWindow dpy (defaultScreen dpy) + root <- io $ rootWindow dpy (defaultScreen dpy) hunk ./Main.hs 70 - code <- l $ keysymToKeycode dpy sym - l $ grabKey dpy code mod root True grabModeAsync grabModeAsync + code <- io $ keysymToKeycode dpy sym + io $ grabKey dpy code mod root True grabModeAsync grabModeAsync hunk ./Main.hs 81 - l $ mapWindow d w + io $ mapWindow d w hunk ./Main.hs 93 - l $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) - l $ raiseWindow d w + io $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) + io $ raiseWindow d w hunk ./Main.hs 109 - root <- l $ rootWindow dpy screen - l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) - l $ sync dpy False + io $ do root <- rootWindow dpy screen + selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) + sync dpy False hunk ./Main.hs 118 - e <- l $ allocaXEvent $ \ev -> do - nextEvent dpy ev - getEvent ev + e <- io $ allocaXEvent $ \ev -> do + nextEvent dpy ev + getEvent ev hunk ./Wm.hs 1 -{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Wm.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, uses cunning newtype deriving +-- +----------------------------------------------------------------------------- +-- +-- The Wm monad, a state monad transformer over IO, for the window manager state. +-- hunk ./Wm.hs 23 -data WmState = WmState - { display :: Display - , screenWidth :: Int - , screenHeight :: Int - , windows :: Seq Window - } +data WmState = WmState + { display :: Display + , screenWidth :: !Int + , screenHeight :: !Int + , windows :: Seq Window + } hunk ./Wm.hs 36 -l :: IO a -> Wm a -l = liftIO +io :: IO a -> Wm a +io = liftIO hunk ./Wm.hs 39 -trace msg = l $ do +trace msg = io $ do hunk ./Wm.hs 46 - (y, s') <- l $ f $ \x -> runWm (g x) s + (y, s') <- io $ f $ \x -> runWm (g x) s hunk ./thunk.cabal 15 +extensions: GeneralizedNewtypeDeriving hunk ./Main.hs 9 --- Portability : not portable, uses cunning newtype deriving +-- Portability : not portable, uses mtl, X11, posix hunk ./Main.hs 30 +------------------------------------------------------------------------ + +-- +-- let's get underway +-- +main :: IO () +main = do + dpy <- openDisplay "" + runWm realMain $ WmState + { display = dpy + , screenWidth = displayWidth dpy (defaultScreen dpy) + , screenHeight = displayHeight dpy (defaultScreen dpy) + , windows = Seq.empty + } + return () + +-- +-- Grab the display and input, and jump into the input loop +-- +realMain :: Wm () +realMain = do + dpy <- getDisplay + let screen = defaultScreen dpy + io $ do root <- rootWindow dpy screen + selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) + sync dpy False + grabkeys + loop + +-- +-- The main event handling loop +-- +loop :: Wm () +loop = do + dpy <- getDisplay + forever $ do + e <- io $ allocaXEvent $ \ev -> nextEvent dpy ev >> getEvent ev + handler e + where + forever a = a >> forever a + +-- +-- The event handler +-- hunk ./Main.hs 76 + hunk ./Main.hs 80 + hunk ./Main.hs 90 +-- +-- switch focus (?) +-- hunk ./Main.hs 102 +-- +-- | spawn. Launch an external application +-- hunk ./Main.hs 106 -spawn c = do - io $ runCommand c - return () +spawn = io_ . runCommand hunk ./Main.hs 108 +-- +-- | Keys we understand. +-- hunk ./Main.hs 112 -keys = +keys = hunk ./Main.hs 114 - , (controlMask, xK_space, spawn "gmrun") - , (mod1Mask, xK_Tab, switch) - , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) + , (controlMask, xK_space, spawn "gmrun") + , (mod1Mask, xK_Tab, switch) + , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) hunk ./Main.hs 119 +-- +-- | grabkeys. Register key commands +-- +grabkeys :: Wm () hunk ./Main.hs 130 +-- +-- +-- hunk ./Main.hs 144 +-- +-- refresh the windows +-- hunk ./Main.hs 156 - io $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) - io $ raiseWindow d w + io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) + raiseWindow d w hunk ./Main.hs 159 -main = do - dpy <- openDisplay "" - runWm main' (WmState - { display = dpy - , screenWidth = displayWidth dpy (defaultScreen dpy) - , screenHeight = displayHeight dpy (defaultScreen dpy) - , windows = Seq.empty - }) - return () - -main' = do - dpy <- getDisplay - let screen = defaultScreen dpy - io $ do root <- rootWindow dpy screen - selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) - sync dpy False - grabkeys - loop - -loop :: Wm () -loop = do - dpy <- getDisplay - e <- io $ allocaXEvent $ \ev -> do - nextEvent dpy ev - getEvent ev - handler e - loop hunk ./Wm.hs 36 +-- +-- | Lift an IO action into the Wm monad +-- hunk ./Wm.hs 42 +-- +-- | Lift an IO action into the Wm monad, discarding any result +-- +io_ :: IO a -> Wm () +io_ f = liftIO f >> return () + hunk ./thunk.cabal 14 -ghc-options: -O +ghc-options: -O -funbox-strict-fields move ./Wm.hs ./W.hs hunk ./Main.hs 28 -import Wm +import W hunk ./Main.hs 38 - runWm realMain $ WmState + runW realMain $ WState hunk ./Main.hs 49 -realMain :: Wm () +realMain :: W () hunk ./Main.hs 62 -loop :: Wm () +loop :: W () hunk ./Main.hs 74 -handler :: Event -> Wm () +handler :: Event -> W () hunk ./Main.hs 93 -switch :: Wm () +switch :: W () hunk ./Main.hs 105 -spawn :: String -> Wm () +spawn :: String -> W () hunk ./Main.hs 111 -keys :: [(KeyMask, KeySym, Wm ())] +keys :: [(KeyMask, KeySym, W ())] hunk ./Main.hs 122 -grabkeys :: Wm () +grabkeys :: W () hunk ./Main.hs 133 -manage :: Window -> Wm () +manage :: Window -> W () hunk ./Main.hs 147 -refresh :: Wm () +refresh :: W () hunk ./W.hs 3 --- Module : Wm.hs +-- Module : W.hs hunk ./W.hs 13 --- The Wm monad, a state monad transformer over IO, for the window manager state. +-- The W monad, a state monad transformer over IO, for the window manager state. hunk ./W.hs 16 -module Wm where +module W where hunk ./W.hs 23 -data WmState = WmState +-- +-- | WState, the window manager state. +-- Just the display, width, height and a window list +-- +data WState = WState hunk ./W.hs 34 -newtype Wm a = Wm (StateT WmState IO a) - deriving (Monad, MonadIO{-, MonadState WmState-}) +-- | The W monad, a StateT transformer over IO encapuslating the window +-- manager state +-- +newtype W a = W (StateT WState IO a) + deriving (Functor, Monad, MonadIO) hunk ./W.hs 40 -runWm :: Wm a -> WmState -> IO (a, WmState) -runWm (Wm m) = runStateT m +-- | Run the W monad, given a chunk of W monad code, and an initial state +-- Return the result, and final state +-- +runW :: W a -> WState -> IO (a, WState) +runW (W m) = runStateT m + +withIO :: (forall b. (a -> IO b) -> IO b) -> (a -> W c) -> W c +withIO f g = do + s <- W get + (y, t) <- io (f (flip runW s . g)) + W (put t) + return y hunk ./W.hs 54 --- | Lift an IO action into the Wm monad +-- | Lift an IO action into the W monad hunk ./W.hs 56 -io :: IO a -> Wm a +io :: IO a -> W a hunk ./W.hs 60 --- | Lift an IO action into the Wm monad, discarding any result +-- | Lift an IO action into the W monad, discarding any result hunk ./W.hs 62 -io_ :: IO a -> Wm () +io_ :: IO a -> W () hunk ./W.hs 65 +-- +-- | A 'trace' for the W monad +-- +trace :: String -> W () hunk ./W.hs 73 -withIO :: (forall b. (a -> IO b) -> IO b) -> (a -> Wm c) -> Wm c -withIO f g = do - s <- Wm get - (y, s') <- io $ f $ \x -> runWm (g x) s - Wm (put s') - return y +-- --------------------------------------------------------------------- +-- Getting at the window manager state hunk ./W.hs 76 -getDisplay = Wm (gets display) +-- | Return the current dispaly +getDisplay :: W Display +getDisplay = W (gets display) hunk ./W.hs 80 -getWindows = Wm (gets windows) +-- | Return the current windows +getWindows :: W (Seq Window) +getWindows = W (gets windows) hunk ./W.hs 84 -getScreenWidth = Wm (gets screenWidth) +-- | Return the screen width +getScreenWidth :: W Int +getScreenWidth = W (gets screenWidth) hunk ./W.hs 88 -getScreenHeight = Wm (gets screenHeight) +-- | Return the screen height +getScreenHeight :: W Int +getScreenHeight = W (gets screenHeight) hunk ./W.hs 92 -setWindows x = Wm (modify (\s -> s {windows = x})) +-- | Set the current window list +setWindows :: Seq Window -> W () +setWindows x = W (modify (\s -> s {windows = x})) hunk ./W.hs 96 -modifyWindows :: (Seq Window -> Seq Window) -> Wm () -modifyWindows f = Wm (modify (\s -> s {windows = f (windows s)})) +-- | Modify the current window list +modifyWindows :: (Seq Window -> Seq Window) -> W () +modifyWindows f = W (modify (\s -> s {windows = f (windows s)})) hunk ./Main.hs 18 + hunk ./Main.hs 21 + hunk ./Main.hs 23 -import Control.Monad.State + hunk ./Main.hs 25 -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras hunk ./Main.hs 28 +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Control.Monad.State + hunk ./Main.hs 73 - where - forever a = a >> forever a hunk ./Main.hs 84 -handler (KeyEvent {event_type = t, state = mod, keycode = code}) - | t == keyPress = do - dpy <- getDisplay - sym <- io $ keycodeToKeysym dpy code 0 - case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of - [] -> return () - ((_, _, act):_) -> act +handler (KeyEvent {event_type = t, state = mod, keycode = code}) + | t == keyPress = do + dpy <- getDisplay + sym <- io $ keycodeToKeysym dpy code 0 + case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of + [] -> return () + ((_, _, act):_) -> act + hunk ./W.hs 13 --- The W monad, a state monad transformer over IO, for the window manager state. +-- The W monad, a state monad transformer over IO, for the window +-- manager state, and support routines. hunk ./W.hs 74 +-- +-- | Run an action forever +-- +forever :: (Monad m) => m a -> m b +forever a = a >> forever a + hunk ./Main.hs 95 --- switch focus (?) +-- switch focus to next window in list. hunk ./Main.hs 118 + , (mod1Mask, xK_p, spawn "exec=`dmenu_path | dmenu` && exec $exe") hunk ./README 21 + + dmenu 2.5 http://suckless.org hunk ./thunk.cabal 10 -build-depends: base==2.0, X11==1.1, X11-extras==0.0, unix==1.0, mtl==1.0 +build-depends: base==2.0, X11>=1.1, X11-extras==0.0, unix==1.0, mtl==1.0 hunk ./Main.hs 118 - , (mod1Mask, xK_p, spawn "exec=`dmenu_path | dmenu` && exec $exe") + , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") hunk ./README 22 - dmenu 2.5 http://suckless.org + dmenu 2.{5,6,7} http://www.suckless.org/download/dmenu-2.7.tar.gz hunk ./Main.hs 19 -import Data.Sequence as Seq -import qualified Data.Foldable as Fold - hunk ./Main.hs 44 - , windows = Seq.empty + , windows = [] hunk ./Main.hs 78 - modifyWindows (Seq.fromList . filter (/= w) . Fold.toList) + modifyWindows (filter (/= w)) hunk ./Main.hs 96 - ws' <- getWindows - case viewl ws' of - EmptyL -> return () - (w :< ws) -> do - setWindows (ws |> w) + ws <- getWindows + case ws of + [] -> return () + (x:xs) -> do + setWindows (xs++[x]) -- snoc. polish this. hunk ./Main.hs 140 - when (Fold.notElem w ws) $ do + when (w `notElem` ws) $ do hunk ./Main.hs 142 - modifyWindows (w <|) + modifyWindows (w :) hunk ./Main.hs 151 - v <- getWindows - case viewl v of - EmptyL -> return () - (w :< _) -> do + ws <- getWindows + case ws of + [] -> return () + (w:_) -> do hunk ./W.hs 19 -import Data.Sequence -import Control.Monad.State -import System.IO (hFlush, hPutStrLn, stderr) +import System.IO hunk ./W.hs 21 +import Control.Monad.State hunk ./W.hs 31 - , windows :: Seq Window + , windows :: Windows hunk ./W.hs 34 +type Windows = [Window] + hunk ./W.hs 89 -getWindows :: W (Seq Window) +getWindows :: W Windows hunk ./W.hs 101 -setWindows :: Seq Window -> W () +setWindows ::Windows -> W () hunk ./W.hs 105 -modifyWindows :: (Seq Window -> Seq Window) -> W () +modifyWindows :: (Windows -> Windows) -> W () hunk ./Main.hs 16 -import qualified Data.Map as Map -import Data.Map (Map) - -import Data.Bits +import Data.Bits hiding (rotate) hunk ./Main.hs 29 ------------------------------------------------------------------------- - hunk ./Main.hs 35 - runW realMain $ WState - { display = dpy - , screenWidth = displayWidth dpy (defaultScreen dpy) - , screenHeight = displayHeight dpy (defaultScreen dpy) - , windows = [] - } + let dflt = defaultScreen dpy + initState = WState + { display = dpy + , screenWidth = displayWidth dpy dflt + , screenHeight = displayHeight dpy dflt + , windows = [] } + + runW initState $ do + root <- io $ rootWindow dpy dflt + io $ do selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) + sync dpy False + registerKeys dpy root + go dpy + hunk ./Main.hs 50 + where + -- The main loop + go dpy = forever $ do + e <- io $ allocaXEvent $ \ev -> nextEvent dpy ev >> getEvent ev + handle e hunk ./Main.hs 57 --- Grab the display and input, and jump into the input loop +-- | grabkeys. Register key commands hunk ./Main.hs 59 -realMain :: W () -realMain = do - dpy <- getDisplay - let screen = defaultScreen dpy - io $ do root <- rootWindow dpy screen - selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) - sync dpy False - grabkeys - loop +registerKeys :: Display -> Window -> W () +registerKeys dpy root = + forM_ keys $ \(mod, sym, _) -> do + kc <- io (keysymToKeycode dpy sym) + io $ grabKey dpy kc mod root True grabModeAsync grabModeAsync hunk ./Main.hs 65 --- --- The main event handling loop --- -loop :: W () -loop = do - dpy <- getDisplay - forever $ do - e <- io $ allocaXEvent $ \ev -> nextEvent dpy ev >> getEvent ev - handler e +keys :: [(KeyMask, KeySym, W ())] +keys = + [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") + , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") + , (controlMask, xK_space, spawn "gmrun") + , (mod1Mask, xK_Tab, switch) + , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) + ] hunk ./Main.hs 77 -handler :: Event -> W () -handler (MapRequestEvent {window = w}) = manage w +handle :: Event -> W () +handle (MapRequestEvent {window = w}) = manage w hunk ./Main.hs 80 -handler (DestroyWindowEvent {window = w}) = do +handle (DestroyWindowEvent {window = w}) = do hunk ./Main.hs 84 -handler (KeyEvent {event_type = t, state = mod, keycode = code}) +handle (KeyEvent {event_type = t, state = mod, keycode = code}) hunk ./Main.hs 92 -handler _ = return () +handle _ = return () hunk ./Main.hs 94 --- --- switch focus to next window in list. --- -switch :: W () -switch = do - ws <- getWindows - case ws of - [] -> return () - (x:xs) -> do - setWindows (xs++[x]) -- snoc. polish this. - refresh +-- --------------------------------------------------------------------- +-- Managing windows hunk ./Main.hs 97 --- --- | spawn. Launch an external application --- -spawn :: String -> W () -spawn = io_ . runCommand +-- | Modify the current window list with a pure funtion, and refresh +withWindows :: (Windows -> Windows) -> W () +withWindows f = do + modifyWindows f + refresh hunk ./Main.hs 103 --- --- | Keys we understand. --- -keys :: [(KeyMask, KeySym, W ())] -keys = - [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") - , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") - , (controlMask, xK_space, spawn "gmrun") - , (mod1Mask, xK_Tab, switch) - , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) - ] +-- | Run an action on the currently focused window +withCurrent :: (Window -> W ()) -> W () +withCurrent f = do + ws <- getWindows + case ws of + [] -> return () + (w:_) -> f w hunk ./Main.hs 112 --- | grabkeys. Register key commands +-- | refresh. Refresh the currently focused window. Resizes to full +-- screen and raises the window. hunk ./Main.hs 115 -grabkeys :: W () -grabkeys = do - dpy <- getDisplay - root <- io $ rootWindow dpy (defaultScreen dpy) - forM_ keys $ \(mod, sym, _) -> do - code <- io $ keysymToKeycode dpy sym - io $ grabKey dpy code mod root True grabModeAsync grabModeAsync +refresh :: W () +refresh = withCurrent $ \w -> do + d <- getDisplay + sw <- getScreenWidth + sh <- getScreenHeight + io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) + raiseWindow d w hunk ./Main.hs 124 +-- | manage. Add a new window to be managed hunk ./Main.hs 126 --- hunk ./Main.hs 129 - d <- getDisplay - ws <- getWindows - when (w `notElem` ws) $ do - trace "modifying" - modifyWindows (w :) - io $ mapWindow d w - refresh + d <- getDisplay + withWindows $ \ws -> if w `elem` ws then ws else w:ws -- a set + io $ mapWindow d w + hunk ./Main.hs 135 --- refresh the windows +-- | switch. switch focus to next window in list. +-- The currently focused window is always the head of the list hunk ./Main.hs 138 -refresh :: W () -refresh = do - ws <- getWindows - case ws of - [] -> return () - (w:_) -> do - d <- getDisplay - sw <- getScreenWidth - sh <- getScreenHeight - io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) - raiseWindow d w +switch :: W () +switch = withWindows rotate hunk ./Main.hs 141 +-- +-- | spawn. Launch an external application +-- +spawn :: String -> W () +spawn = io_ . runCommand hunk ./W.hs 23 --- hunk ./W.hs 25 --- hunk ./W.hs 29 - , windows :: Windows + , windows :: !Windows hunk ./W.hs 36 --- -newtype W a = W (StateT WState IO a) +newtype W a = W { unW :: StateT WState IO a } hunk ./W.hs 41 --- -runW :: W a -> WState -> IO (a, WState) -runW (W m) = runStateT m +runW :: WState -> W a -> IO (a, WState) +runW st a = runStateT (unW a) st hunk ./W.hs 44 -withIO :: (forall b. (a -> IO b) -> IO b) -> (a -> W c) -> W c -withIO f g = do - s <- W get - (y, t) <- io (f (flip runW s . g)) - W (put t) - return y - --- hunk ./W.hs 45 --- hunk ./W.hs 48 --- hunk ./W.hs 49 --- hunk ./W.hs 52 --- --- | A 'trace' for the W monad --- +-- | A 'trace' for the W monad. Logs a string to stderr. The result may +-- be found in your .xsession-errors file hunk ./W.hs 59 --- --- | Run an action forever --- -forever :: (Monad m) => m a -> m b -forever a = a >> forever a - hunk ./W.hs 86 +-- --------------------------------------------------------------------- +-- Generic utilities + +-- | Run an action forever +forever :: (Monad m) => m a -> m b +forever a = a >> forever a + +-- | Add an element onto the end of a list +snoc :: [a] -> a -> [a] +snoc xs x = xs ++ [x] + +-- | Rotate a list one element +rotate [] = [] +rotate (x:xs) = xs `snoc` x + hunk ./Main.hs 81 - modifyWindows (filter (/= w)) - refresh + ws <- getWindows + when (elem w ws) (unmanage w) + +handle (UnmapEvent {window = w}) = do + ws <- getWindows + when (elem w ws) (unmanage w) hunk ./Main.hs 96 +handle e@(ConfigureRequestEvent {}) = do + dpy <- getDisplay + io $ configureWindow dpy (window e) (value_mask e) $ + WindowChanges + { wcX = x e + , wcY = y e + , wcWidth = width e + , wcHeight = height e + , wcBorderWidth = border_width e + , wcSibling = above e + , wcStackMode = detail e + } + io $ sync dpy False + hunk ./Main.hs 151 +-- +-- | unmanage, a window no longer exists, remove it from the stack +-- +unmanage :: Window -> W () +unmanage w = do + dpy <- getDisplay + io $ grabServer dpy + modifyWindows (filter (/= w)) + io $ sync dpy False + io $ ungrabServer dpy + refresh hunk ./Main.hs 81 - ws <- getWindows + ws <- gets windows hunk ./Main.hs 85 - ws <- getWindows + ws <- gets windows hunk ./Main.hs 90 - dpy <- getDisplay + dpy <- gets display hunk ./Main.hs 97 - dpy <- getDisplay + dpy <- gets display hunk ./Main.hs 124 - ws <- getWindows + ws <- gets windows hunk ./Main.hs 135 - d <- getDisplay - sw <- getScreenWidth - sh <- getScreenHeight + d <- gets display + sw <- gets screenWidth + sh <- gets screenHeight hunk ./Main.hs 147 - d <- getDisplay + d <- gets display hunk ./Main.hs 156 - dpy <- getDisplay + dpy <- gets display hunk ./W.hs 37 - deriving (Functor, Monad, MonadIO) + deriving (Functor, Monad, MonadIO, MonadState WState) hunk ./W.hs 62 --- | Return the current dispaly -getDisplay :: W Display -getDisplay = W (gets display) - --- | Return the current windows -getWindows :: W Windows -getWindows = W (gets windows) - --- | Return the screen width -getScreenWidth :: W Int -getScreenWidth = W (gets screenWidth) - --- | Return the screen height -getScreenHeight :: W Int -getScreenHeight = W (gets screenHeight) - --- | Set the current window list -setWindows ::Windows -> W () -setWindows x = W (modify (\s -> s {windows = x})) - hunk ./W.hs 63 -modifyWindows :: (Windows -> Windows) -> W () -modifyWindows f = W (modify (\s -> s {windows = f (windows s)})) +modifyWindows :: (Windows -> Windows) -> W () +modifyWindows f = modify $ \s -> s {windows = f (windows s)} hunk ./Main.hs 99 - WindowChanges + WindowChanges addfile ./TODO hunk ./TODO 1 +- think about the statusbar/multithreading. + Three shared TVars: + windowTitle :: TVar String + workspace :: TVar Int + statusText :: TVar String + Three threads: + Main thread, handles all of the events that it handles now. When + necessary, it writes to workspace or windowTitle + + Status IO thread, the algorithm is something like this: + forever $ do + s <- getLine + atomic (writeTVar statusText s) + + Statusbar drawing thread, waits for changes in all three TVars, and + redraws whenever it finds a change. hunk ./Main.hs 70 - , (mod1Mask, xK_Tab, switch) + , (mod1Mask, xK_Tab, focus 1) + , (mod1Mask, xK_j, focus 1) + , (mod1Mask, xK_k, focus (-1)) hunk ./Main.hs 117 --- | Modify the current window list with a pure funtion, and refresh -withWindows :: (Windows -> Windows) -> W () -withWindows f = do - modifyWindows f - refresh - --- | Run an action on the currently focused window -withCurrent :: (Window -> W ()) -> W () -withCurrent f = do - ws <- gets windows - case ws of - [] -> return () - (w:_) -> f w - hunk ./Main.hs 122 -refresh = withCurrent $ \w -> do - d <- gets display - sw <- gets screenWidth - sh <- gets screenHeight - io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) - raiseWindow d w +refresh = do + ws <- gets windows + case ws of + [] -> return () + (w:_) -> do + d <- gets display + sw <- liftM fromIntegral (gets screenWidth) + sh <- liftM fromIntegral (gets screenHeight) + io $ do moveResizeWindow d w 0 0 sw sh + raiseWindow d w + +-- | Modify the current window list with a pure funtion, and refresh +withWindows :: (Windows -> Windows) -> W () +withWindows f = do + modifyWindows f + refresh hunk ./Main.hs 139 --- hunk ./Main.hs 140 --- hunk ./Main.hs 144 - withWindows $ \ws -> if w `elem` ws then ws else w:ws -- a set + withWindows (nub . (w :)) hunk ./Main.hs 147 --- hunk ./Main.hs 148 --- hunk ./Main.hs 151 - io $ grabServer dpy - modifyWindows (filter (/= w)) - io $ sync dpy False - io $ ungrabServer dpy - refresh + io $ do grabServer dpy + sync dpy False + ungrabServer dpy + withWindows $ filter (/= w) hunk ./Main.hs 156 --- --- | switch. switch focus to next window in list. +-- | focus. focus to window at offset 'n' in list. hunk ./Main.hs 158 --- -switch :: W () -switch = withWindows rotate +focus :: Int -> W () +focus n = withWindows (rotate n) hunk ./Main.hs 161 --- hunk ./Main.hs 162 --- hunk ./W.hs 32 +-- +-- Multithreaded issues: +-- +-- We'll want a status bar, it will probably read from stdin +-- but will thus need to run in its own thread, and modify its status +-- bar window +-- + hunk ./W.hs 85 --- | Rotate a list one element -rotate [] = [] -rotate (x:xs) = xs `snoc` x +-- | Rotate a list by 'n' elements. +-- +-- for xs = [5..8] ++ [1..4] +-- +-- rotate 0 +-- [5,6,7,8,1,2,3,4] +-- +-- rotate 1 +-- [6,7,8,1,2,3,4,5] +-- +-- rotate (-1) +-- [4,5,6,7,8,1,2,3] +-- +rotate n xs = take l . drop offset . cycle $ xs + where + l = length xs + offset | n < 0 = l + n + | otherwise = n + + hunk ./Main.hs 17 +import Data.List hunk ./W.hs 81 --- | Add an element onto the end of a list -snoc :: [a] -> a -> [a] -snoc xs x = xs ++ [x] - hunk ./W.hs 100 - hunk ./Main.hs 30 +-- +-- The keys list +-- +keys :: [(KeyMask, KeySym, W ())] +keys = + [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") + , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") + , (controlMask, xK_space, spawn "gmrun") + , (mod1Mask, xK_Tab, focus 1) + , (mod1Mask, xK_j, focus 1) + , (mod1Mask, xK_k, focus (-1)) + , (mod1Mask .|. shiftMask, xK_c, kill) + , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) + ] + hunk ./Main.hs 81 -keys :: [(KeyMask, KeySym, W ())] -keys = - [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") - , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") - , (controlMask, xK_space, spawn "gmrun") - , (mod1Mask, xK_Tab, focus 1) - , (mod1Mask, xK_j, focus 1) - , (mod1Mask, xK_k, focus (-1)) - , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) - ] - hunk ./Main.hs 170 +-- | Kill the currently focused client +kill :: W () +kill = do + ws <- gets windows + dpy <- gets display + case ws of + [] -> return () + (w:_) -> do + -- if(isprotodel(sel)) + -- sendevent(sel->win, wmatom[WMProtocols], wmatom[WMDelete]); + io $ xKillClient dpy w -- ignoring result + return () + hunk ./Main.hs 107 - { wcX = x e - , wcY = y e - , wcWidth = width e - , wcHeight = height e + { wcX = x e + , wcY = y e + , wcWidth = width e + , wcHeight = height e hunk ./Main.hs 112 - , wcSibling = above e - , wcStackMode = detail e + , wcSibling = above e + , wcStackMode = detail e hunk ./Main.hs 144 --- | manage. Add a new window to be managed +-- | manage. Add a new window to be managed. Bring it into focus. hunk ./Main.hs 147 - trace "manage" hunk ./Main.hs 148 - withWindows (nub . (w :)) hunk ./Main.hs 149 + withWindows (nub . (w :)) hunk ./Main.hs 179 - io $ xKillClient dpy w -- ignoring result + io $ killClient dpy w -- ignoring result hunk ./Main.hs 19 +import qualified Data.Map as M + hunk ./Main.hs 35 -keys :: [(KeyMask, KeySym, W ())] -keys = - [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") - , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") - , (controlMask, xK_space, spawn "gmrun") - , (mod1Mask, xK_Tab, focus 1) - , (mod1Mask, xK_j, focus 1) - , (mod1Mask, xK_k, focus (-1)) - , (mod1Mask .|. shiftMask, xK_c, kill) - , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) +keys :: M.Map (KeyMask, KeySym) (W ()) +keys = M.fromList + [ ((mod1Mask .|. shiftMask, xK_Return), spawn "xterm") + , ((mod1Mask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") + , ((controlMask, xK_space ), spawn "gmrun") + , ((mod1Mask, xK_Tab ), focus 1) + , ((mod1Mask, xK_j ), focus 1) + , ((mod1Mask, xK_k ), focus (-1)) + , (mod1Mask .|. shiftMask, xK_c ), kill) + , ((mod1Mask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) hunk ./Main.hs 74 --- --- | grabkeys. Register key commands --- -registerKeys :: Display -> Window -> W () -registerKeys dpy root = - forM_ keys $ \(mod, sym, _) -> do - kc <- io (keysymToKeycode dpy sym) - io $ grabKey dpy kc mod root True grabModeAsync grabModeAsync + -- register keys + registerKeys dpy root = forM_ (M.keys keys) $ \(mod,sym) -> io $ do + kc <- keysymToKeycode dpy sym + grabKey dpy kc mod root True grabModeAsync grabModeAsync hunk ./Main.hs 83 -handle (MapRequestEvent {window = w}) = manage w - -handle (DestroyWindowEvent {window = w}) = do - ws <- gets windows - when (elem w ws) (unmanage w) - -handle (UnmapEvent {window = w}) = do - ws <- gets windows - when (elem w ws) (unmanage w) +handle (MapRequestEvent {window = w}) = manage w +handle (DestroyWindowEvent {window = w}) = unmanage w +handle (UnmapEvent {window = w}) = unmanage w hunk ./Main.hs 91 - case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of - [] -> return () - ((_, _, act):_) -> act + M.lookup (mod,sym) keys hunk ./Main.hs 95 - io $ configureWindow dpy (window e) (value_mask e) $ - WindowChanges + io $ configureWindow dpy (window e) (value_mask e) $ WindowChanges hunk ./Main.hs 143 - dpy <- gets display - io $ do grabServer dpy - sync dpy False - ungrabServer dpy - withWindows $ filter (/= w) + ws <- gets windows + when (w `elem` ws) $ do + dpy <- gets display + io $ do grabServer dpy + sync dpy False + ungrabServer dpy + withWindows $ filter (/= w) hunk ./W.hs 19 -import System.IO -import Graphics.X11.Xlib hunk ./W.hs 20 +import System.IO +import Graphics.X11.Xlib (Display,Window) hunk ./Main.hs 43 - , (mod1Mask .|. shiftMask, xK_c ), kill) + , ((mod1Mask .|. shiftMask, xK_c ), kill) hunk ./Main.hs 61 - root <- io $ rootWindow dpy dflt - io $ do selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) + r <- io $ rootWindow dpy dflt + io $ do selectInput dpy r (substructureRedirectMask .|. substructureNotifyMask) hunk ./Main.hs 64 - registerKeys dpy root + registerKeys dpy r hunk ./Main.hs 75 - registerKeys dpy root = forM_ (M.keys keys) $ \(mod,sym) -> io $ do - kc <- keysymToKeycode dpy sym - grabKey dpy kc mod root True grabModeAsync grabModeAsync + registerKeys dpy r = forM_ (M.keys keys) $ \(m,s) -> io $ do + kc <- keysymToKeycode dpy s + grabKey dpy kc m r True grabModeAsync grabModeAsync hunk ./Main.hs 87 -handle (KeyEvent {event_type = t, state = mod, keycode = code}) +handle (KeyEvent {event_type = t, state = m, keycode = code}) hunk ./Main.hs 90 - sym <- io $ keycodeToKeysym dpy code 0 - M.lookup (mod,sym) keys + s <- io $ keycodeToKeysym dpy code 0 + case M.lookup (m,s) keys of + Nothing -> return () + Just a -> a hunk ./W.hs 94 +rotate :: Int -> [a] -> [a] hunk ./thunk.cabal 14 -ghc-options: -O -funbox-strict-fields +ghc-options: -O -funbox-strict-fields -Wall -Werror -optl-Wl,-s hunk ./thunk.cabal 14 -ghc-options: -O -funbox-strict-fields -Wall -Werror -optl-Wl,-s +ghc-options: -O -funbox-strict-fields -Wall -optl-Wl,-s hunk ./Main.hs 18 - +import qualified Data.Sequence as S +import qualified Data.Foldable as F hunk ./Main.hs 44 - , ((mod1Mask .|. shiftMask, xK_c ), kill) + , ((mod1Mask .|. shiftMask, xK_c ), kill) hunk ./Main.hs 46 + + , ((mod1Mask, xK_1 ), view 1) + , ((mod1Mask, xK_2 ), view 2) + , ((mod1Mask, xK_3 ), view 3) + , ((mod1Mask, xK_4 ), view 4) + , ((mod1Mask, xK_5 ), view 5) + hunk ./Main.hs 66 - , windows = [] } + , workspace = (0,S.fromList (replicate 5 [])) + } hunk ./Main.hs 89 --- The event handler +-- | handle. Handle X events hunk ./Main.hs 92 -handle (MapRequestEvent {window = w}) = manage w +handle (MapRequestEvent {window = w}) = manage w hunk ./Main.hs 94 -handle (UnmapEvent {window = w}) = unmanage w +handle (UnmapEvent {window = w}) = unmanage w hunk ./Main.hs 128 - ws <- gets windows + (n,wks) <- gets workspace + let ws = wks `S.index` n hunk ./Main.hs 131 - [] -> return () + [] -> return () -- do nothing. hmm. so no empty workspaces? + -- we really need to hide all non-visible windows + -- ones on other screens hunk ./Main.hs 138 - io $ do moveResizeWindow d w 0 0 sw sh + io $ do moveResizeWindow d w 0 0 sw sh -- size hunk ./Main.hs 147 --- | manage. Add a new window to be managed. Bring it into focus. +-- | manage. Add a new window to be managed in the current workspace. Bring it into focus. hunk ./Main.hs 154 --- | unmanage, a window no longer exists, remove it from the stack +-- | unmanage. A window no longer exists, remove it from the window +-- list, on whatever workspace hunk ./Main.hs 158 - ws <- gets windows - when (w `elem` ws) $ do - dpy <- gets display - io $ do grabServer dpy - sync dpy False - ungrabServer dpy - withWindows $ filter (/= w) + (_,wks) <- gets workspace + mapM_ rm (F.toList wks) + where + rm ws = when (w `elem` ws) $ do + dpy <- gets display + io $ do grabServer dpy + sync dpy False + ungrabServer dpy + withWindows $ filter (/= w) hunk ./Main.hs 180 - ws <- gets windows - dpy <- gets display + dpy <- gets display + (n,wks) <- gets workspace + let ws = wks `S.index` n hunk ./Main.hs 191 +-- | Change the current workspace to workspce at offset 'n-1'. +view :: Int -> W () +view n = return () + +-- +-- So the problem is that I don't quite understand X here. +-- The following code will set the right list of windows to be current, +-- according to our view of things. +-- +-- We just need to tell X that it is only those in the current window +-- list that are indeed visible, and everything else is hidden. +-- +-- In particular, if we switch to a new empty workspace, nothing should +-- be visible but the root. So: how do we hide windows? +-- +{- do + let m = n-1 + modifyWorkspaces $ \old@(_,wks) -> + if m < S.length wks && m >= 0 then (m,wks) else old + refresh +-} + hunk ./W.hs 22 +import qualified Data.Sequence as S hunk ./W.hs 30 - , windows :: !Windows + , workspace :: !WorkSpaces -- ^ workspace list hunk ./W.hs 33 --- --- Multithreaded issues: --- --- We'll want a status bar, it will probably read from stdin --- but will thus need to run in its own thread, and modify its status --- bar window --- - -type Windows = [Window] +type WorkSpaces = (Int, S.Seq Windows) +type Windows = [Window] hunk ./W.hs 64 +-- | Modify the workspace list +modifyWorkspaces :: (WorkSpaces -> WorkSpaces) -> W () +modifyWorkspaces f = modify $ \s -> s { workspace = f (workspace s) } + hunk ./W.hs 69 -modifyWindows :: (Windows -> Windows) -> W () -modifyWindows f = modify $ \s -> s {windows = f (windows s)} +modifyWindows :: (Windows -> Windows) -> W () +modifyWindows f = modifyWorkspaces $ \(i,wk) -> (i, S.adjust f i wk) hunk ./W.hs 81 --- for xs = [5..8] ++ [1..4] +-- rotate 0 --> [5,6,7,8,1,2,3,4] +-- rotate 1 --> [6,7,8,1,2,3,4,5] +-- rotate (-1) --> [4,5,6,7,8,1,2,3] hunk ./W.hs 85 --- rotate 0 --- [5,6,7,8,1,2,3,4] --- --- rotate 1 --- [6,7,8,1,2,3,4,5] --- --- rotate (-1) --- [4,5,6,7,8,1,2,3] +-- where xs = [5..8] ++ [1..4] hunk ./Main.hs 66 - , workspace = (0,S.fromList (replicate 5 [])) + , workspace = (0,S.fromList (replicate 5 [])) -- 5 empty workspaces hunk ./Main.hs 138 - io $ do moveResizeWindow d w 0 0 sw sh -- size + io $ do moveResizeWindow d w 0 0 sw sh -- fullscreen hunk ./Main.hs 155 --- list, on whatever workspace +-- list, on whatever workspace it is. hunk ./Main.hs 192 +-- Todo: refactor hunk ./Main.hs 194 -view n = return () - --- --- So the problem is that I don't quite understand X here. --- The following code will set the right list of windows to be current, --- according to our view of things. --- --- We just need to tell X that it is only those in the current window --- list that are indeed visible, and everything else is hidden. --- --- In particular, if we switch to a new empty workspace, nothing should --- be visible but the root. So: how do we hide windows? --- -{- do +view n = do hunk ./Main.hs 198 + + dpy <- gets display + sw <- liftM fromIntegral (gets screenWidth) + sh <- liftM fromIntegral (gets screenHeight) + (i,wks) <- gets workspace + + -- clear the screen: remove all window stacks + forM_ (concat $ F.toList wks) $ \win -> do + io $ moveWindow dpy win (2*sw) (2*sh) + + -- expose just the visible stack + forM_ (wks `S.index` i) $ \win -> do + io $ moveWindow dpy win 0 0 + hunk ./Main.hs 213 --} hunk ./Main.hs 192 --- Todo: refactor hunk ./Main.hs 194 - let m = n-1 - modifyWorkspaces $ \old@(_,wks) -> - if m < S.length wks && m >= 0 then (m,wks) else old + let new = n-1 + (old,wks) <- gets workspace + when (new /= old && new >= 0 && new < S.length wks) $ do + modifyWorkspaces $ \_ -> (new,wks) + hideWindows (wks `S.index` old) + showWindows (wks `S.index` new) + refresh hunk ./Main.hs 202 +-- | Hide a list of windows by moving them offscreen. +hideWindows :: Windows -> W () +hideWindows ws = do hunk ./Main.hs 208 - (i,wks) <- gets workspace + forM_ ws $ \w -> io $ moveWindow dpy w (2*sw) (2*sh) hunk ./Main.hs 210 - -- clear the screen: remove all window stacks - forM_ (concat $ F.toList wks) $ \win -> do - io $ moveWindow dpy win (2*sw) (2*sh) - - -- expose just the visible stack - forM_ (wks `S.index` i) $ \win -> do - io $ moveWindow dpy win 0 0 - - refresh +-- | Expose a list of windows, moving them on screen +showWindows :: Windows -> W () +showWindows ws = do + dpy <- gets display + forM_ ws $ \w -> io $ moveWindow dpy w 0 0 hunk ./Main.hs 53 + , ((mod1Mask .|. shiftMask, xK_1 ), tag 1) + , ((mod1Mask .|. shiftMask, xK_2 ), tag 2) + , ((mod1Mask .|. shiftMask, xK_3 ), tag 3) + , ((mod1Mask .|. shiftMask, xK_4 ), tag 4) + , ((mod1Mask .|. shiftMask, xK_5 ), tag 5) + hunk ./Main.hs 197 +-- | tag. associate a window with a new workspace +tag :: Int -> W () +tag n = do + let new = n-1 + (old,wks) <- gets workspace + when (new /= old && new >= 0 && new < S.length wks) $ do + let this = wks `S.index` old + if null this + then return () -- no client to retag + else do let (t:_) = this + modifyWorkspaces $ \(i,w) -> + let w' = S.adjust tail old w + w'' = S.adjust (t:) new w' in (i,w'') + hideWindows [t] + refresh + hunk ./Main.hs 80 + (_, _, ws) <- io $ queryTree dpy r + forM_ ws $ \w -> do + wa <- io $ getWindowAttributes dpy w + when (waMapState wa == waIsViewable) (manage w) hunk ./Main.hs 127 -handle _ = return () +handle e = trace (eventName e) -- return () hunk ./Main.hs 33 +-- +-- The number of workspaces: +-- +workspaces :: Int +workspaces = 5 + hunk ./Main.hs 43 -keys = M.fromList +keys = M.fromList $ hunk ./Main.hs 52 + ] ++ + -- generate keybindings for each workspace: + [((m .|. mod1Mask, xK_0 + fromIntegral i), f i) + | i <- [1 .. workspaces] + , (f, m) <- [(view, 0), (tag, shiftMask)]] hunk ./Main.hs 58 - , ((mod1Mask, xK_1 ), view 1) - , ((mod1Mask, xK_2 ), view 2) - , ((mod1Mask, xK_3 ), view 3) - , ((mod1Mask, xK_4 ), view 4) - , ((mod1Mask, xK_5 ), view 5) - - , ((mod1Mask .|. shiftMask, xK_1 ), tag 1) - , ((mod1Mask .|. shiftMask, xK_2 ), tag 2) - , ((mod1Mask .|. shiftMask, xK_3 ), tag 3) - , ((mod1Mask .|. shiftMask, xK_4 ), tag 4) - , ((mod1Mask .|. shiftMask, xK_5 ), tag 5) - - ] hunk ./Main.hs 70 - , workspace = (0,S.fromList (replicate 5 [])) -- 5 empty workspaces + , workspace = (0,S.fromList (replicate workspaces [])) -- empty workspaces hunk ./Main.hs 130 +-- | spawn. Launch an external application +spawn :: String -> W () +spawn = io_ . runCommand + hunk ./Main.hs 185 --- | spawn. Launch an external application -spawn :: String -> W () -spawn = io_ . runCommand - hunk ./thunk.cabal 14 -ghc-options: -O -funbox-strict-fields -Wall -optl-Wl,-s +ghc-options: -O -Wall -optl-Wl,-s addfile ./StackSet.hs hunk ./Main.hs 16 -import Data.Bits hiding (rotate) hunk ./Main.hs 17 -import qualified Data.Sequence as S -import qualified Data.Foldable as F +import Data.Bits hiding (rotate) hunk ./Main.hs 21 -import System.Process (runCommand) hunk ./Main.hs 29 +import qualified StackSet as W hunk ./Main.hs 45 - , ((mod1Mask, xK_Tab ), focus 1) - , ((mod1Mask, xK_j ), focus 1) - , ((mod1Mask, xK_k ), focus (-1)) + , ((mod1Mask, xK_Tab ), focus GT) + , ((mod1Mask, xK_j ), focus GT) + , ((mod1Mask, xK_k ), focus LT) hunk ./Main.hs 51 - -- generate keybindings for each workspace: + -- generate keybindings to each workspace: hunk ./Main.hs 68 - , workspace = (0,S.fromList (replicate workspaces [])) -- empty workspaces + , workspace = W.empty workspaces hunk ./Main.hs 106 - case M.lookup (m,s) keys of - Nothing -> return () - Just a -> a + maybe (return ()) id (M.lookup (m,s) keys) hunk ./Main.hs 126 --- | spawn. Launch an external application -spawn :: String -> W () -spawn = io_ . runCommand - --- hunk ./Main.hs 128 --- hunk ./Main.hs 129 -refresh = do - (n,wks) <- gets workspace - let ws = wks `S.index` n - case ws of - [] -> return () -- do nothing. hmm. so no empty workspaces? - -- we really need to hide all non-visible windows - -- ones on other screens - (w:_) -> do - d <- gets display - sw <- liftM fromIntegral (gets screenWidth) - sh <- liftM fromIntegral (gets screenHeight) - io $ do moveResizeWindow d w 0 0 sw sh -- fullscreen - raiseWindow d w +refresh = whenJust W.peek $ \w -> do + d <- gets display + sw <- liftM fromIntegral (gets screenWidth) + sh <- liftM fromIntegral (gets screenHeight) + io $ do moveResizeWindow d w 0 0 sw sh -- fullscreen + raiseWindow d w + +-- | hide. Hide a list of windows by moving them offscreen. +hide :: Window -> W () +hide w = do + dpy <- gets display + sw <- liftM fromIntegral (gets screenWidth) + sh <- liftM fromIntegral (gets screenHeight) + io $ moveWindow dpy w (2*sw) (2*sh) + +-- | reveal. Expose a list of windows, moving them on screen +reveal :: Window -> W () +reveal w = do + dpy <- gets display + io $ moveWindow dpy w 0 0 hunk ./Main.hs 150 --- | Modify the current window list with a pure funtion, and refresh -withWindows :: (Windows -> Windows) -> W () -withWindows f = do - modifyWindows f +-- | windows. Modify the current window list with a pure function, and refresh +windows :: (WorkSpace -> WorkSpace) -> W () +windows f = do + modifyWorkspace f hunk ./Main.hs 156 +-- --------------------------------------------------------------------- +-- Window operations + hunk ./Main.hs 160 +-- If the window is already under management, it is just raised. hunk ./Main.hs 165 - withWindows (nub . (w :)) + windows $ W.push w hunk ./Main.hs 171 - (_,wks) <- gets workspace - mapM_ rm (F.toList wks) - where - rm ws = when (w `elem` ws) $ do - dpy <- gets display - io $ do grabServer dpy - sync dpy False - ungrabServer dpy - withWindows $ filter (/= w) + ws <- gets workspace + when (W.member w ws) $ do + dpy <- gets display + io $ do grabServer dpy + sync dpy False + ungrabServer dpy + windows $ W.delete w hunk ./Main.hs 181 -focus :: Int -> W () -focus n = withWindows (rotate n) +focus :: Ordering -> W () +focus = windows . W.rotate hunk ./Main.hs 187 - dpy <- gets display - (n,wks) <- gets workspace - let ws = wks `S.index` n - case ws of - [] -> return () - (w:_) -> do - -- if(isprotodel(sel)) - -- sendevent(sel->win, wmatom[WMProtocols], wmatom[WMDelete]); - io $ killClient dpy w -- ignoring result - return () + dpy <- gets display + whenJust W.peek $ io_ . killClient dpy hunk ./Main.hs 190 --- | tag. associate a window with a new workspace +-- | tag. Move a window to a new workspace hunk ./Main.hs 192 -tag n = do - let new = n-1 - (old,wks) <- gets workspace - when (new /= old && new >= 0 && new < S.length wks) $ do - let this = wks `S.index` old - if null this - then return () -- no client to retag - else do let (t:_) = this - modifyWorkspaces $ \(i,w) -> - let w' = S.adjust tail old w - w'' = S.adjust (t:) new w' in (i,w'') - hideWindows [t] - refresh +tag o = do + ws <- gets workspace + when (n /= W.cursor ws) $ + whenJust W.peek $ \w -> do + hide w + windows $ W.shift n + where n = o -1 hunk ./Main.hs 200 --- | Change the current workspace to workspce at offset 'n-1'. +-- | view. Change the current workspace to workspce at offset 'n-1'. hunk ./Main.hs 202 -view n = do - let new = n-1 - (old,wks) <- gets workspace - when (new /= old && new >= 0 && new < S.length wks) $ do - modifyWorkspaces $ \_ -> (new,wks) - hideWindows (wks `S.index` old) - showWindows (wks `S.index` new) - refresh - --- | Hide a list of windows by moving them offscreen. -hideWindows :: Windows -> W () -hideWindows ws = do - dpy <- gets display - sw <- liftM fromIntegral (gets screenWidth) - sh <- liftM fromIntegral (gets screenHeight) - forM_ ws $ \w -> io $ moveWindow dpy w (2*sw) (2*sh) +view o = do + ws <- gets workspace + when (n /= W.cursor ws) $ + whenJust (flip W.index n) $ \new -> do + mapM_ hide (W.stack ws) + mapM_ reveal new + windows $ W.view n + where n = o-1 hunk ./Main.hs 211 --- | Expose a list of windows, moving them on screen -showWindows :: Windows -> W () -showWindows ws = do - dpy <- gets display - forM_ ws $ \w -> io $ moveWindow dpy w 0 0 hunk ./StackSet.hs 1 +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : StackSet +-- Copyright : (c) Don Stewart 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : stable +-- Portability : portable, needs GHC 6.6 +-- +----------------------------------------------------------------------------- +-- +-- The 'StackSet' data type encodes a set of stacks. A given stack in the +-- set is always current. +-- + +module StackSet ( + + StackSet, -- abstract + + -- * Introduction + empty, -- :: Int -> StackSet a + fromList, -- :: [[a]] -> StackSet a + + -- * Inspection + member, -- :: Ord a => a -> StackSet a -> Bool + peek, -- :: StackSet a -> Maybe a + stack, -- :: StackSet a -> [a] + cursor, -- :: StackSet a -> Int + index, -- :: StackSet a -> Int -> Maybe [a] + + -- * Modification to the current stack + push, -- :: Ord a => a -> StackSet a -> StackSet a + pop, -- :: Ord a => StackSet a -> StackSet a + rotate, -- :: Ordering -> StackSet a -> StackSet a + shift, -- :: Ord a => Int -> StackSet a -> StackSet a + + -- * Modification to arbitrary stacks + delete, -- :: Ord a => a -> StackSet a -> StackSet a + + -- * Changing which stack is 'current' + view, -- :: Int -> StackSet a -> StackSet a + + ) where + +import Data.Maybe +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Sequence as S + +-- All for testing: +#if TESTING +import Control.Exception (assert) +import Control.Monad +import Test.QuickCheck +import System.IO +import System.Random +import Text.Printf +import Data.List (sort,group,sort,intersperse) +#endif + +------------------------------------------------------------------------ + +-- | The StackSet data structure. A table of stacks, with a cursor +data StackSet a = + StackSet + { cursor :: {-# UNPACK #-} !Int -- ^ the currently visible stack + , size :: {-# UNPACK #-} !Int -- ^ size of the stack list + , stacks :: {-# UNPACK #-} !(S.Seq [a]) -- ^ the separate stacks + , cache :: {-# UNPACK #-} !(M.Map a Int) -- ^ a cache of windows back to their stacks + } deriving Eq + +instance Show a => Show (StackSet a) where show = show . toList + +-- Ord a constraint on 'a' as we use it as a key. +-- +-- The cache is used to check on insertion that we don't already have +-- this window managed on another stack +-- +-- Currently stacks are of a fixed size. There's no firm reason to +-- do this (new empty stacks could be created on the fly). + +------------------------------------------------------------------------ + +-- | Create a new empty stacks of size 'n', indexed from 0. The +-- 0-indexed stack will be current. +empty :: Int -> StackSet a +empty n = StackSet { cursor = 0 + , size = n -- constant + , stacks = S.fromList (replicate n []) + , cache = M.empty + } + +-- | True if x is somewhere in the StackSet +member :: Ord a => a -> StackSet a -> Bool +member a w = M.member a (cache w) + +------------------------------------------------------------------------ + +-- | fromList. Build a new StackSet from a list of list of elements +-- If there are duplicates in the list, the last occurence wins. +fromList :: Ord a => (Int,[[a]]) -> StackSet a +fromList (_,[]) + = error "Cannot build a StackSet from an empty list" + +fromList (n,xs) + | n < 0 || n >= length xs + = error $ "Cursor index is out of range: " ++ show (n, length xs) + +fromList (o,xs) = view o $ + foldr (\(i,ys) s -> + foldr (\a t -> insert a i t) s ys) + (empty (length xs)) (zip [0..] xs) + +-- | toList. Flatten a stackset to a list of lists +toList :: StackSet a -> (Int,[[a]]) +toList x = (cursor x, F.toList (stacks x)) + +------------------------------------------------------------------------ + +-- | Push. Insert an element onto the top of the current stack. +-- If the element is already in the current stack, it is moved to the top. +-- If the element is managed on another stack, it is removed from that +-- stack first. +push :: Ord a => a -> StackSet a -> StackSet a +push k w = insert k (cursor w) w + +-- | Pop. Pop the element off the top of the stack and discard it. +-- A new StackSet is returned. If the current stack is empty, the +-- original StackSet is returned unchanged. +pop :: Ord a => StackSet a -> StackSet a +pop w = case peek w of + Nothing -> w + Just t -> delete t w + +-- | Extract the element on the top of the current stack. If no such +-- element exists, Nothing is returned. +peek :: StackSet a -> Maybe a +peek = listToMaybe . stack + +-- | Index. Extract stack at index 'n'. If the index is invalid, +-- Nothing is returned. +index :: StackSet a -> Int -> Maybe [a] +index w n | n < 0 || n >= size w = Nothing + | otherwise = Just (stacks w `S.index` n) + +-- | Return the current stack +stack :: StackSet a -> [a] +stack w = case index w (cursor w) of + Just s -> s + Nothing -> error $ "current: no 'current' stack in StackSet: " ++ show (cursor w) -- can't happen + +-- | rotate. cycle the current window list up or down. +-- +-- rotate EQ --> [5,6,7,8,1,2,3,4] +-- rotate GT --> [6,7,8,1,2,3,4,5] +-- rotate LT --> [4,5,6,7,8,1,2,3] +-- +-- where xs = [5..8] ++ [1..4] +-- +rotate :: Ordering -> StackSet a -> StackSet a +rotate o = unsafeModify rot -- safe, since 'rot' is guaranteed to only permute the list + where + rot s = take l . drop offset . cycle $ s + where + n = fromEnum o - 1 + l = length s + offset = if n < 0 then l + n else n + +-- --------------------------------------------------------------------- + +-- | view. Set the stack specified by the Int argument as being the +-- current StackSet. If the index is out of range, the original +-- StackSet is returned. StackSet are indexed from 0. +view :: Int -> StackSet a -> StackSet a +view n w | n >= 0 && n < size w = w { cursor = n } + | otherwise = w + +-- | shift. move the client on top of the current stack to the top of stack 'n'. +-- The new StackSet is returned. +-- +-- If the stack to move to is not valid, the original StackSet is returned. +-- If there are no elements in the current stack, nothing changes. +-- +shift :: Ord a => Int -> StackSet a -> StackSet a +shift n w | n < 0 || n >= size w = w + | otherwise = case peek w of + Nothing -> w -- nothing to do + Just k -> insert k n (pop w) + +------------------------------------------------------------------------ + +-- | Insert an element onto the top of stack 'n'. +-- If the index is wrong, the original StackSet is returned unchanged. +-- If the element is already in the stack 'n', it is moved to the top. +-- If the element exists on another stack, it is removed from that stack. +-- +insert :: Ord a => a -> Int -> StackSet a -> StackSet a +insert k n old + | n < 0 || n >= size old = old + | otherwise = new { cache = M.insert k n (cache new) + , stacks = S.adjust (L.nub . (k:)) n (stacks new) } + where new = delete k old + +-- | Delete an element entirely from from the StackSet. +-- This can be used to ensure that a given element is not managed elsewhere. +-- If the element doesn't exist, the original StackSet is returned unmodified. +delete :: Ord a => a -> StackSet a -> StackSet a +delete k w = case M.lookup k (cache w) of + Nothing -> w -- we don't know about this window + Just i -> w { cache = M.delete k (cache w) + , stacks = S.adjust (L.delete k) i (stacks w) } + +-- --------------------------------------------------------------------- +-- Internal functions + +-- | modify the current stack with a pure function. This function is +-- unsafe: the argument function must only permute the current stack, +-- and must not add or remove elements, or duplicate elements. +-- +unsafeModify :: ([a] -> [a]) -> StackSet a -> StackSet a +unsafeModify f w = w { stacks = S.adjust f (cursor w) (stacks w) } + + +#if TESTING +-- --------------------------------------------------------------------- +-- QuickCheck properties + +-- | Height of stack 'n' +height :: Int -> StackSet a -> Int +height i w = length (S.index (stacks w) i) + +-- build (non-empty) StackSets with between 1 and 100 stacks +instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where + arbitrary = do + sz <- choose (1,20) + n <- choose (0,sz-1) + ls <- vector sz + return $ fromList (n,ls) + coarbitrary = error "no coarbitrary for StackSet" + +prop_id x = fromList (toList x) == x + where _ = x :: StackSet Int + +prop_uniq_pushpop i x = not (member i x) ==> + (pop . push i) x == x + where _ = x :: StackSet Int + +prop_pushpop i x = + (pop . push i) x == delete i x + where _ = x :: StackSet Int + +-- popping an empty stack leaves an empty stack +prop_popempty x = height (cursor x) x == 0 ==> pop x == x + where _ = x :: StackSet Int + +prop_popone x = + let l = height (cursor x) x + in l > 0 ==> height (cursor x) (pop x) == l-1 + where _ = x :: StackSet Int + +-- check the cache of the size works +prop_size_length x = + size x == S.length (stacks x) + where _ = x :: StackSet Int + +prop_delete_uniq i x = not (member i x) ==> + delete i x == x + where _ = x :: StackSet Int + +prop_delete2 i x = + delete i x == delete i (delete i x) + where _ = x :: StackSet Int + +prop_uniq_insertdelete i n x = not (member i x) ==> + delete i (insert i n x) == x + where _ = x :: StackSet Int + +prop_insertdelete i n x = + delete i (insert i n x) == delete i x + where _ = x :: StackSet Int + +prop_rotaterotate x = rotate LT (rotate GT x) == x + where _ = x :: StackSet Int + +prop_viewview r x = + let n = cursor x + sz = size x + i = r `mod` sz + in + view n (view i x) == x + + where _ = x :: StackSet Int + +prop_shiftshift r x = + let n = cursor x + in + shift n (shift r x) == x + where _ = x :: StackSet Int + +------------------------------------------------------------------------ + +testall :: IO () +testall = mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests + where + n = 100 + + tests = + [("fromList.toList ", mytest prop_id) + ,("pop/push ", mytest prop_uniq_pushpop) + ,("pop/push/delete ", mytest prop_pushpop) + ,("pop/empty ", mytest prop_popempty) + ,("size/length ", mytest prop_size_length) + ,("delete/not.member", mytest prop_delete_uniq) + ,("delete idempotent", mytest prop_delete2) + ,("delete/insert new", mytest prop_uniq_insertdelete) + ,("delete/insert ", mytest prop_insertdelete) + ,("rotate/rotate ", mytest prop_rotaterotate) + ,("pop one ", mytest prop_popone) + ,("view/view ", mytest prop_viewview) + ] + +debug = False + +mytest :: Testable a => a -> Int -> IO () +mytest a n = mycheck defaultConfig + { configMaxTest=n + , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + +mycheck :: Testable a => Config -> a -> IO () +mycheck config a = do + rnd <- newStdGen + mytests config (evaluate a) rnd 0 0 [] + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +mytests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = do done "OK," ntest stamps + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | otherwise = + do putStr (configEvery config ntest (arguments result)) >> hFlush stdout + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + putStr ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) >> hFlush stdout + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +------------------------------------------------------------------------ +#endif hunk ./W.hs 19 +import StackSet + hunk ./W.hs 23 +import System.Process (runCommand) hunk ./W.hs 25 -import qualified Data.Sequence as S hunk ./W.hs 30 - , screenWidth :: !Int - , screenHeight :: !Int - , workspace :: !WorkSpaces -- ^ workspace list + , screenWidth :: {-# UNPACK #-} !Int + , screenHeight :: {-# UNPACK #-} !Int + , workspace :: {-# UNPACK #-} !WorkSpace -- ^ workspace list hunk ./W.hs 35 -type WorkSpaces = (Int, S.Seq Windows) -type Windows = [Window] +type WorkSpace = StackSet Window hunk ./W.hs 55 +-- | Run an action forever +forever :: (Monad m) => m a -> m b +forever a = a >> forever a + +-- | spawn. Launch an external application +spawn :: String -> W () +spawn = io_ . runCommand + hunk ./W.hs 70 --- --------------------------------------------------------------------- --- Getting at the window manager state - hunk ./W.hs 71 -modifyWorkspaces :: (WorkSpaces -> WorkSpaces) -> W () -modifyWorkspaces f = modify $ \s -> s { workspace = f (workspace s) } - --- | Modify the current window list -modifyWindows :: (Windows -> Windows) -> W () -modifyWindows f = modifyWorkspaces $ \(i,wk) -> (i, S.adjust f i wk) - --- --------------------------------------------------------------------- --- Generic utilities - --- | Run an action forever -forever :: (Monad m) => m a -> m b -forever a = a >> forever a +modifyWorkspace :: (WorkSpace -> WorkSpace) -> W () +modifyWorkspace f = do + modify $ \s -> s { workspace = f (workspace s) } + ws <- gets workspace + trace (show $ ws) hunk ./W.hs 77 --- | Rotate a list by 'n' elements. --- --- rotate 0 --> [5,6,7,8,1,2,3,4] --- rotate 1 --> [6,7,8,1,2,3,4,5] --- rotate (-1) --> [4,5,6,7,8,1,2,3] --- --- where xs = [5..8] ++ [1..4] --- -rotate :: Int -> [a] -> [a] -rotate n xs = take l . drop offset . cycle $ xs - where - l = length xs - offset | n < 0 = l + n - | otherwise = n +-- | Like 'when' but for (WorkSpace -> Maybe a) +whenJust :: (WorkSpace -> Maybe a) -> (a -> W ()) -> W () +whenJust mg f = do + ws <- gets workspace + case mg ws of + Nothing -> return () + Just w -> f w adddir ./tests hunk ./StackSet.hs 1 -{-# OPTIONS -cpp #-} hunk ./StackSet.hs 19 - StackSet, -- abstract + StackSet, -- abstract hunk ./StackSet.hs 24 + toList, -- :: StackSet -> [[a]] hunk ./StackSet.hs 27 + size, -- :: StackSet -> Int hunk ./StackSet.hs 42 + insert, -- :: Ord a => a -> Int -> StackSet a -> StackSet a hunk ./StackSet.hs 55 --- All for testing: -#if TESTING -import Control.Exception (assert) -import Control.Monad -import Test.QuickCheck -import System.IO -import System.Random -import Text.Printf -import Data.List (sort,group,sort,intersperse) -#endif - hunk ./StackSet.hs 218 -#if TESTING --- --------------------------------------------------------------------- --- QuickCheck properties - --- | Height of stack 'n' -height :: Int -> StackSet a -> Int -height i w = length (S.index (stacks w) i) - --- build (non-empty) StackSets with between 1 and 100 stacks -instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where - arbitrary = do - sz <- choose (1,20) - n <- choose (0,sz-1) - ls <- vector sz - return $ fromList (n,ls) - coarbitrary = error "no coarbitrary for StackSet" - -prop_id x = fromList (toList x) == x - where _ = x :: StackSet Int - -prop_uniq_pushpop i x = not (member i x) ==> - (pop . push i) x == x - where _ = x :: StackSet Int - -prop_pushpop i x = - (pop . push i) x == delete i x - where _ = x :: StackSet Int - --- popping an empty stack leaves an empty stack -prop_popempty x = height (cursor x) x == 0 ==> pop x == x - where _ = x :: StackSet Int - -prop_popone x = - let l = height (cursor x) x - in l > 0 ==> height (cursor x) (pop x) == l-1 - where _ = x :: StackSet Int - --- check the cache of the size works -prop_size_length x = - size x == S.length (stacks x) - where _ = x :: StackSet Int - -prop_delete_uniq i x = not (member i x) ==> - delete i x == x - where _ = x :: StackSet Int - -prop_delete2 i x = - delete i x == delete i (delete i x) - where _ = x :: StackSet Int - -prop_uniq_insertdelete i n x = not (member i x) ==> - delete i (insert i n x) == x - where _ = x :: StackSet Int - -prop_insertdelete i n x = - delete i (insert i n x) == delete i x - where _ = x :: StackSet Int - -prop_rotaterotate x = rotate LT (rotate GT x) == x - where _ = x :: StackSet Int - -prop_viewview r x = - let n = cursor x - sz = size x - i = r `mod` sz - in - view n (view i x) == x - - where _ = x :: StackSet Int - -prop_shiftshift r x = - let n = cursor x - in - shift n (shift r x) == x - where _ = x :: StackSet Int - ------------------------------------------------------------------------- - -testall :: IO () -testall = mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests - where - n = 100 - - tests = - [("fromList.toList ", mytest prop_id) - ,("pop/push ", mytest prop_uniq_pushpop) - ,("pop/push/delete ", mytest prop_pushpop) - ,("pop/empty ", mytest prop_popempty) - ,("size/length ", mytest prop_size_length) - ,("delete/not.member", mytest prop_delete_uniq) - ,("delete idempotent", mytest prop_delete2) - ,("delete/insert new", mytest prop_uniq_insertdelete) - ,("delete/insert ", mytest prop_insertdelete) - ,("rotate/rotate ", mytest prop_rotaterotate) - ,("pop one ", mytest prop_popone) - ,("view/view ", mytest prop_viewview) - ] - -debug = False - -mytest :: Testable a => a -> Int -> IO () -mytest a n = mycheck defaultConfig - { configMaxTest=n - , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a - -mycheck :: Testable a => Config -> a -> IO () -mycheck config a = do - rnd <- newStdGen - mytests config (evaluate a) rnd 0 0 [] - -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () -mytests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = do done "OK," ntest stamps - | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps - | otherwise = - do putStr (configEvery config ntest (arguments result)) >> hFlush stdout - case ok result of - Nothing -> - mytests config gen rnd1 ntest (nfail+1) stamps - Just True -> - mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - putStr ( "Falsifiable after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) >> hFlush stdout - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 - -done :: String -> Int -> [[String]] -> IO () -done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) - where - table = display - . map entry - . reverse - . sort - . map pairLength - . group - . sort - . filter (not . null) - $ stamps - - display [] = ".\n" - display [x] = " (" ++ x ++ ").\n" - display xs = ".\n" ++ unlines (map (++ ".") xs) - - pairLength xss@(xs:_) = (length xss, xs) - entry (n, xs) = percentage n ntest - ++ " " - ++ concat (intersperse ", " xs) - - percentage n m = show ((100 * n) `div` m) ++ "%" - ------------------------------------------------------------------------- -#endif - addfile ./Properties.hs move ./Properties.hs ./tests/Properties.hs hunk ./tests/Properties.hs 1 + +import StackSet + +import System.Environment +import Control.Exception (assert) +import Control.Monad +import Test.QuickCheck +import System.IO +import System.Random +import Text.Printf +import Data.List (sort,group,sort,intersperse) + +-- --------------------------------------------------------------------- +-- QuickCheck properties for the StackSet + +-- | Height of stack 'n' +height :: Int -> StackSet a -> Int +height i w = case index w i of + Nothing -> error $ "height: i out of range: " ++ show i + Just ss -> length ss + +-- build (non-empty) StackSets with between 1 and 100 stacks +instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where + arbitrary = do + sz <- choose (1,20) + n <- choose (0,sz-1) + ls <- vector sz + return $ fromList (n,ls) + coarbitrary = error "no coarbitrary for StackSet" + +prop_id x = fromList (toList x) == x + where _ = x :: StackSet Int + +prop_uniq_pushpop i x = not (member i x) ==> + (pop . push i) x == x + where _ = x :: StackSet Int + +prop_pushpop i x = + (pop . push i) x == delete i x + where _ = x :: StackSet Int + +-- popping an empty stack leaves an empty stack +prop_popempty x = height (cursor x) x == 0 ==> pop x == x + where _ = x :: StackSet Int + +prop_popone x = + let l = height (cursor x) x + in l > 0 ==> height (cursor x) (pop x) == l-1 + where _ = x :: StackSet Int + +prop_delete_uniq i x = not (member i x) ==> + delete i x == x + where _ = x :: StackSet Int + +prop_delete2 i x = + delete i x == delete i (delete i x) + where _ = x :: StackSet Int + +prop_uniq_insertdelete i n x = not (member i x) ==> + delete i (insert i n x) == x + where _ = x :: StackSet Int + +prop_insertdelete i n x = + delete i (insert i n x) == delete i x + where _ = x :: StackSet Int + +prop_rotaterotate x = rotate LT (rotate GT x) == x + where _ = x :: StackSet Int + +prop_viewview r x = + let n = cursor x + sz = size x + i = r `mod` sz + in + view n (view i x) == x + + where _ = x :: StackSet Int + +prop_shiftshift r x = + let n = cursor x + in + shift n (shift r x) == x + where _ = x :: StackSet Int + +------------------------------------------------------------------------ + +main :: IO () +main = do + args <- getArgs + let n = if null args then 100 else read (head args) + mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests + where + n = 100 + + tests = + [("fromList.toList ", mytest prop_id) + ,("pop/push ", mytest prop_uniq_pushpop) + ,("pop/push/delete ", mytest prop_pushpop) + ,("pop/empty ", mytest prop_popempty) + ,("delete/not.member", mytest prop_delete_uniq) + ,("delete idempotent", mytest prop_delete2) + ,("delete/insert new", mytest prop_uniq_insertdelete) + ,("delete/insert ", mytest prop_insertdelete) + ,("rotate/rotate ", mytest prop_rotaterotate) + ,("pop one ", mytest prop_popone) + ,("view/view ", mytest prop_viewview) + ] + +debug = False + +mytest :: Testable a => a -> Int -> IO () +mytest a n = mycheck defaultConfig + { configMaxTest=n + , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + +mycheck :: Testable a => Config -> a -> IO () +mycheck config a = do + rnd <- newStdGen + mytests config (evaluate a) rnd 0 0 [] + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +mytests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = do done "OK," ntest stamps + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | otherwise = + do putStr (configEvery config ntest (arguments result)) >> hFlush stdout + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + putStr ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) >> hFlush stdout + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +------------------------------------------------------------------------ move ./W.hs ./WMonad.hs hunk ./Main.hs 28 -import W +import WMonad hunk ./WMonad.hs 17 -module W where +module WMonad where hunk ./WMonad.hs 70 --- | Modify the workspace list +-- | Modify the workspace list. hunk ./WMonad.hs 75 - trace (show $ ws) + trace (show ws) -- log state changes to stderr hunk ./WMonad.hs 77 --- | Like 'when' but for (WorkSpace -> Maybe a) +-- | Run a side effecting action with the current workspace. Like 'when' but +-- for (WorkSpace -> Maybe a). hunk ./Main.hs 103 - | t == keyPress = do - dpy <- gets display + | t == keyPress = withDisplay $ \dpy -> do hunk ./Main.hs 128 -refresh = whenJust W.peek $ \w -> do - d <- gets display - sw <- liftM fromIntegral (gets screenWidth) - sh <- liftM fromIntegral (gets screenHeight) - io $ do moveResizeWindow d w 0 0 sw sh -- fullscreen - raiseWindow d w +refresh = whenJust W.peek $ \w -> withScreen $ \(d,sw,sh) -> io $ do + moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen + raiseWindow d w hunk ./Main.hs 134 -hide w = do - dpy <- gets display - sw <- liftM fromIntegral (gets screenWidth) - sh <- liftM fromIntegral (gets screenHeight) - io $ moveWindow dpy w (2*sw) (2*sh) +hide w = withScreen $ \(dpy,sw,sh) -> io $ + moveWindow dpy w (2*fromIntegral sw) (2*fromIntegral sh) hunk ./Main.hs 139 -reveal w = do - dpy <- gets display - io $ moveWindow dpy w 0 0 +reveal w = withDisplay $ \d -> io $ moveWindow d w 0 0 hunk ./Main.hs 143 -windows f = do - modifyWorkspace f - refresh +windows f = modifyWorkspace f >> refresh hunk ./Main.hs 151 -manage w = do - d <- gets display - io $ mapWindow d w - windows $ W.push w +manage w = do withDisplay $ \d -> io $ mapWindow d w + windows $ W.push w hunk ./Main.hs 160 - dpy <- gets display - io $ do grabServer dpy - sync dpy False - ungrabServer dpy + withDisplay $ \d -> io $ withServer d $ sync d False hunk ./Main.hs 170 -kill = do - dpy <- gets display - whenJust W.peek $ io_ . killClient dpy +kill = withDisplay $ \d -> whenJust W.peek $ io_ . killClient d hunk ./WMonad.hs 69 + +-- | Run a monad action with the current display settings +withDisplay :: (Display -> W ()) -> W () +withDisplay f = gets display >>= f + +-- | Run a monadic action with the display, screen width and height +withScreen :: ((Display,Int,Int) -> W ()) -> W () +withScreen f = do + d <- gets display + sw <- gets screenWidth + sh <- gets screenHeight + f (d,sw,sh) hunk ./Main.hs 75 - registerKeys dpy r + grabKeys dpy r hunk ./Main.hs 89 - -- register keys - registerKeys dpy r = forM_ (M.keys keys) $ \(m,s) -> io $ do - kc <- keysymToKeycode dpy s - grabKey dpy kc m r True grabModeAsync grabModeAsync +-- | Grab the keys back +grabKeys :: Display -> Window -> W () +grabKeys dpy r = forM_ (M.keys keys) $ \(m,s) -> io $ do + kc <- keysymToKeycode dpy s + grabKey dpy kc m r True grabModeAsync grabModeAsync hunk ./Main.hs 97 +-- dwm handles: +-- +-- [ButtonPress] = buttonpress, +-- [ConfigureRequest] = configurerequest, +-- [DestroyNotify] = destroynotify, +-- [EnterNotify] = enternotify, +-- [LeaveNotify] = leavenotify, +-- [Expose] = expose, +-- [KeyPress] = keypress, +-- [MappingNotify] = mappingnotify, +-- [MapRequest] = maprequest, +-- [PropertyNotify] = propertynotify, +-- [UnmapNotify] = unmapnotify hunk ./Main.hs 116 +handle (MappingNotifyEvent {window = w}) = do + trace $ "Got mapping notify event for window: " ++ show w + +{- +, mapping= m@(r,_,_)}) = do + io $ refreshKeyboardMapping m + when (r == mappingKeyboard) $ withDisplay $ \d -> grabKeys d w +-} + hunk ./Main.hs 143 -handle e = trace (eventName e) -- return () +-- Typical events I see still unhandled: +-- ConfigureNotify +-- MapNotify +-- CreateNotify +-- KeyRelease +-- +-- In particular, ConfigureNotify and MapNotify a lot on firefox +-- +handle e = trace (eventName e) hunk ./StackSet.hs 14 --- set is always current. +-- set is always current. Elements may appear only once in the entire +-- stack set. +-- +-- A StackSet provides a nice datastructure for multiscreen +-- windowmanagers, where each screen has a stack of windows, and a window +-- may be on only 1 screen at any given time. hunk ./Main.hs 112 -handle (MapRequestEvent {window = w}) = manage w +handle (MapRequestEvent {window = w}) = withDisplay $ \dpy -> do + wa <- io $ getWindowAttributes dpy w + when (not (waOverrideRedirect wa)) $ manage w + hunk ./Main.hs 119 -handle (MappingNotifyEvent {window = w}) = do - trace $ "Got mapping notify event for window: " ++ show w - -{- -, mapping= m@(r,_,_)}) = do +handle e@(MappingNotifyEvent {window = w}) = do + let m = (request e, first_keycode e, count e) hunk ./Main.hs 122 - when (r == mappingKeyboard) $ withDisplay $ \d -> grabKeys d w --} + when (request e == mappingKeyboard) $ withDisplay $ flip grabKeys w hunk ./Main.hs 56 - hunk ./Main.hs 94 +-- --------------------------------------------------------------------- +-- Event handler hunk ./Main.hs 98 --- dwm handles: hunk ./Main.hs 99 --- [ButtonPress] = buttonpress, --- [ConfigureRequest] = configurerequest, --- [DestroyNotify] = destroynotify, --- [EnterNotify] = enternotify, --- [LeaveNotify] = leavenotify, --- [Expose] = expose, --- [KeyPress] = keypress, --- [MappingNotify] = mappingnotify, --- [MapRequest] = maprequest, +-- Events dwm handles that we don't: +-- +-- [ButtonPress] = buttonpress, +-- [EnterNotify] = enternotify, +-- [LeaveNotify] = leavenotify, +-- [Expose] = expose, hunk ./Main.hs 106 --- [UnmapNotify] = unmapnotify hunk ./Main.hs 108 + hunk ./Main.hs 139 --- Typical events I see still unhandled: --- ConfigureNotify --- MapNotify --- CreateNotify --- KeyRelease --- --- In particular, ConfigureNotify and MapNotify a lot on firefox --- hunk ./README 20 - X11-extras: darcs get http://www.cse.unsw.edu.au/~dons/code/X11-extras + X11-extras: darcs get http://darcs.haskell.org/~sjanssen/X11-extras hunk ./StackSet.hs 24 - StackSet, -- abstract + StackSet, -- abstract, deriving Show,Eq hunk ./StackSet.hs 28 - fromList, -- :: [[a]] -> StackSet a - toList, -- :: StackSet -> [[a]] + fromList, -- :: Ord a => (Int,[[a]]) -> StackSet a + toList, -- :: StackSet a -> (Int,[[a]]) hunk ./StackSet.hs 32 - size, -- :: StackSet -> Int - member, -- :: Ord a => a -> StackSet a -> Bool + size, -- :: StackSet a -> Int hunk ./StackSet.hs 34 - stack, -- :: StackSet a -> [a] - cursor, -- :: StackSet a -> Int - index, -- :: StackSet a -> Int -> Maybe [a] + index, -- :: Int -> StackSet a -> Maybe [a] + member, -- :: Ord a => a -> StackSet a -> Bool + current, -- :: StackSet a -> Int hunk ./StackSet.hs 38 - -- * Modification to the current stack + -- * Modification hunk ./StackSet.hs 40 - pop, -- :: Ord a => StackSet a -> StackSet a hunk ./StackSet.hs 42 - - -- * Modification to arbitrary stacks hunk ./StackSet.hs 43 - insert, -- :: Ord a => a -> Int -> StackSet a -> StackSet a - - -- * Changing which stack is 'current' hunk ./StackSet.hs 55 --- | The StackSet data structure. A table of stacks, with a cursor +-- | The StackSet data structure. A table of stacks, with a current pointer hunk ./StackSet.hs 58 - { cursor :: {-# UNPACK #-} !Int -- ^ the currently visible stack + { current:: {-# UNPACK #-} !Int -- ^ the currently visible stack hunk ./StackSet.hs 64 -instance Show a => Show (StackSet a) where show = show . toList +instance Show a => Show (StackSet a) where + showsPrec p s r = showsPrec p (show . toList $ s) r hunk ./StackSet.hs 80 -empty n = StackSet { cursor = 0 +empty n = StackSet { current= 0 hunk ./StackSet.hs 109 -toList x = (cursor x, F.toList (stacks x)) +toList x = (current x, F.toList (stacks x)) hunk ./StackSet.hs 118 -push k w = insert k (cursor w) w - --- | Pop. Pop the element off the top of the stack and discard it. --- A new StackSet is returned. If the current stack is empty, the --- original StackSet is returned unchanged. -pop :: Ord a => StackSet a -> StackSet a -pop w = case peek w of - Nothing -> w - Just t -> delete t w +push k w = insert k (current w) w hunk ./StackSet.hs 123 -peek = listToMaybe . stack +peek w = listToMaybe . fromJust $ index (current w) w hunk ./StackSet.hs 127 -index :: StackSet a -> Int -> Maybe [a] -index w n | n < 0 || n >= size w = Nothing +index :: Int -> StackSet a -> Maybe [a] +index n w | n < 0 || n >= size w = Nothing hunk ./StackSet.hs 131 --- | Return the current stack -stack :: StackSet a -> [a] -stack w = case index w (cursor w) of - Just s -> s - Nothing -> error $ "current: no 'current' stack in StackSet: " ++ show (cursor w) -- can't happen - hunk ./StackSet.hs 154 -view n w | n >= 0 && n < size w = w { cursor = n } +view n w | n >= 0 && n < size w = w { current = n } hunk ./StackSet.hs 200 -unsafeModify f w = w { stacks = S.adjust f (cursor w) (stacks w) } +unsafeModify f w = w { stacks = S.adjust f (current w) (stacks w) } hunk ./StackSet.hs 202 +-- | Pop. Pop the element off the top of the stack and discard it. +-- A new StackSet is returned. If the current stack is empty, the +-- original StackSet is returned unchanged. +pop :: Ord a => StackSet a -> StackSet a +pop w = maybe w (flip delete w) (peek w) hunk ./Main.hs 147 -refresh = whenJust W.peek $ \w -> withScreen $ \(d,sw,sh) -> io $ do - moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen - raiseWindow d w +refresh = do + ws <- gets workspace + whenJust (W.peek ws) $ \w -> + withScreen $ \(d,sw,sh) -> io $ do + moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen + raiseWindow d w hunk ./Main.hs 173 -manage w = do withDisplay $ \d -> io $ mapWindow d w - windows $ W.push w +manage w = do + withDisplay $ io . flip mapWindow w + windows $ W.push w hunk ./Main.hs 193 -kill = withDisplay $ \d -> whenJust W.peek $ io_ . killClient d +kill = withDisplay $ \d -> do + ws <- gets workspace + whenJust (W.peek ws) $ io_ . killClient d hunk ./Main.hs 201 - when (n /= W.cursor ws) $ - whenJust W.peek $ \w -> do + let m = W.current ws + when (n /= m) $ + whenJust (W.peek ws) $ \w -> do hunk ./Main.hs 206 - where n = o -1 + where n = o-1 hunk ./Main.hs 212 - when (n /= W.cursor ws) $ - whenJust (flip W.index n) $ \new -> do - mapM_ hide (W.stack ws) + let m = W.current ws + when (n /= m) $ + whenJust (W.index n ws) $ \new -> + whenJust (W.index m ws) $ \old -> do + mapM_ hide old hunk ./WMonad.hs 19 -import StackSet +import StackSet (StackSet) hunk ./WMonad.hs 90 --- for (WorkSpace -> Maybe a). -whenJust :: (WorkSpace -> Maybe a) -> (a -> W ()) -> W () -whenJust mg f = do - ws <- gets workspace - case mg ws of - Nothing -> return () - Just w -> f w +whenJust :: Maybe a -> (a -> W ()) -> W () +whenJust mg f = maybe (return ()) f mg hunk ./tests/Properties.hs 18 -height i w = case index w i of +height i w = case index i w of hunk ./tests/Properties.hs 34 -prop_uniq_pushpop i x = not (member i x) ==> - (pop . push i) x == x - where _ = x :: StackSet Int - -prop_pushpop i x = - (pop . push i) x == delete i x - where _ = x :: StackSet Int - --- popping an empty stack leaves an empty stack -prop_popempty x = height (cursor x) x == 0 ==> pop x == x - where _ = x :: StackSet Int - -prop_popone x = - let l = height (cursor x) x - in l > 0 ==> height (cursor x) (pop x) == l-1 - where _ = x :: StackSet Int - -prop_delete_uniq i x = not (member i x) ==> - delete i x == x +prop_delete_uniq i x = not (member i x) ==> delete i x == x hunk ./tests/Properties.hs 41 -prop_uniq_insertdelete i n x = not (member i x) ==> - delete i (insert i n x) == x - where _ = x :: StackSet Int - -prop_insertdelete i n x = - delete i (insert i n x) == delete i x - where _ = x :: StackSet Int - hunk ./tests/Properties.hs 45 - let n = cursor x + let n = current x hunk ./tests/Properties.hs 54 - let n = cursor x + let n = current x hunk ./tests/Properties.hs 70 - [("fromList.toList ", mytest prop_id) - ,("pop/push ", mytest prop_uniq_pushpop) - ,("pop/push/delete ", mytest prop_pushpop) - ,("pop/empty ", mytest prop_popempty) + [("read.show ", mytest prop_id) hunk ./tests/Properties.hs 73 - ,("delete/insert new", mytest prop_uniq_insertdelete) - ,("delete/insert ", mytest prop_insertdelete) hunk ./tests/Properties.hs 74 - ,("pop one ", mytest prop_popone) hunk ./Main.hs 213 - when (n /= m) $ - whenJust (W.index n ws) $ \new -> - whenJust (W.index m ws) $ \old -> do - mapM_ hide old - mapM_ reveal new - windows $ W.view n + when (n /= m) $ do + mapM_ hide (W.index m ws) + mapM_ reveal (W.index n ws) + windows $ W.view n hunk ./StackSet.hs 17 --- A StackSet provides a nice datastructure for multiscreen --- windowmanagers, where each screen has a stack of windows, and a window +-- A StackSet provides a nice data structure for multiscreen +-- window managers, where each screen has a stack of windows, and a window hunk ./StackSet.hs 34 - index, -- :: Int -> StackSet a -> Maybe [a] + index, -- :: Int -> StackSet a -> [a] hunk ./StackSet.hs 123 -peek w = listToMaybe . fromJust $ index (current w) w +peek w = listToMaybe $ index (current w) w hunk ./StackSet.hs 125 --- | Index. Extract stack at index 'n'. If the index is invalid, --- Nothing is returned. -index :: Int -> StackSet a -> Maybe [a] -index n w | n < 0 || n >= size w = Nothing - | otherwise = Just (stacks w `S.index` n) +-- | Index. Extract the stack at index 'n'. +-- If the index is invalid, an exception is thrown. +index :: Int -> StackSet a -> [a] +index n w = stacks w `S.index` n + +-- | view. Set the stack specified by the Int argument as being the +-- current StackSet. If the index is out of range an exception is thrown. +view :: Int -> StackSet a -> StackSet a +view n w | n >= 0 && n < size w = w { current = n } + | otherwise = error $ "view: index out of bounds: " ++ show n hunk ./StackSet.hs 145 -rotate o = unsafeModify rot -- safe, since 'rot' is guaranteed to only permute the list +rotate o w = w { stacks = S.adjust rot (current w) (stacks w) } hunk ./StackSet.hs 153 --- --------------------------------------------------------------------- - --- | view. Set the stack specified by the Int argument as being the --- current StackSet. If the index is out of range, the original --- StackSet is returned. StackSet are indexed from 0. -view :: Int -> StackSet a -> StackSet a -view n w | n >= 0 && n < size w = w { current = n } - | otherwise = w - hunk ./StackSet.hs 154 --- The new StackSet is returned. --- --- If the stack to move to is not valid, the original StackSet is returned. --- If there are no elements in the current stack, nothing changes. +-- If the stack to move to is not valid, and exception is thrown. hunk ./StackSet.hs 157 -shift n w | n < 0 || n >= size w = w - | otherwise = case peek w of - Nothing -> w -- nothing to do - Just k -> insert k n (pop w) - ------------------------------------------------------------------------- +shift n w = maybe w (\k -> insert k n (delete k w)) (peek w) hunk ./StackSet.hs 160 --- If the index is wrong, the original StackSet is returned unchanged. hunk ./StackSet.hs 162 +-- If the index is wrong an exception is thrown. hunk ./StackSet.hs 165 -insert k n old - | n < 0 || n >= size old = old - | otherwise = new { cache = M.insert k n (cache new) - , stacks = S.adjust (L.nub . (k:)) n (stacks new) } +insert k n old = new { cache = M.insert k n (cache new) + , stacks = S.adjust (L.nub . (k:)) n (stacks new) } hunk ./StackSet.hs 173 -delete k w = case M.lookup k (cache w) of - Nothing -> w -- we don't know about this window - Just i -> w { cache = M.delete k (cache w) - , stacks = S.adjust (L.delete k) i (stacks w) } - --- --------------------------------------------------------------------- --- Internal functions - --- | modify the current stack with a pure function. This function is --- unsafe: the argument function must only permute the current stack, --- and must not add or remove elements, or duplicate elements. --- -unsafeModify :: ([a] -> [a]) -> StackSet a -> StackSet a -unsafeModify f w = w { stacks = S.adjust f (current w) (stacks w) } - --- | Pop. Pop the element off the top of the stack and discard it. --- A new StackSet is returned. If the current stack is empty, the --- original StackSet is returned unchanged. -pop :: Ord a => StackSet a -> StackSet a -pop w = maybe w (flip delete w) (peek w) +delete k w = maybe w tweak (M.lookup k (cache w)) + where tweak i = w { cache = M.delete k (cache w) + , stacks = S.adjust (L.delete k) i (stacks w) } hunk ./tests/Properties.hs 18 -height i w = case index i w of - Nothing -> error $ "height: i out of range: " ++ show i - Just ss -> length ss +height i w = length (index i w) hunk ./StackSet.hs 48 -import qualified Data.Foldable as F hunk ./StackSet.hs 50 -import qualified Data.Sequence as S +import qualified Data.IntMap as I hunk ./StackSet.hs 59 - , stacks :: {-# UNPACK #-} !(S.Seq [a]) -- ^ the separate stacks + , stacks :: {-# UNPACK #-} !(I.IntMap [a]) -- ^ the separate stacks hunk ./StackSet.hs 76 --- | Create a new empty stacks of size 'n', indexed from 0. The +-- | /O(n)/. Create a new empty stacks of size 'n', indexed from 0. The hunk ./StackSet.hs 81 - , stacks = S.fromList (replicate n []) + , stacks = I.fromList (zip [0..n-1] (repeat [])) hunk ./StackSet.hs 85 --- | True if x is somewhere in the StackSet +-- | /O(log w)/. True if x is somewhere in the StackSet hunk ./StackSet.hs 108 -toList x = (current x, F.toList (stacks x)) +toList x = (current x, map snd $ I.toList (stacks x)) hunk ./StackSet.hs 119 --- | Extract the element on the top of the current stack. If no such +-- | /O(log s)/. Extract the element on the top of the current stack. If no such hunk ./StackSet.hs 124 --- | Index. Extract the stack at index 'n'. +-- | /O(log s)/. Index. Extract the stack at index 'n'. hunk ./StackSet.hs 127 -index n w = stacks w `S.index` n +index k w = fromJust (I.lookup k (stacks w)) hunk ./StackSet.hs 129 --- | view. Set the stack specified by the Int argument as being the +-- | /O(1)/. view. Set the stack specified by the Int argument as being the hunk ./StackSet.hs 135 --- | rotate. cycle the current window list up or down. +-- | /O(log n)/. rotate. cycle the current window list up or down. hunk ./StackSet.hs 144 -rotate o w = w { stacks = S.adjust rot (current w) (stacks w) } +rotate o w = w { stacks = I.adjust rot (current w) (stacks w) } hunk ./StackSet.hs 152 --- | shift. move the client on top of the current stack to the top of stack 'n'. --- If the stack to move to is not valid, and exception is thrown. +-- | /O(log n)/. shift. move the client on top of the current stack to +-- the top of stack 'n'. If the stack to move to is not valid, and +-- exception is thrown. hunk ./StackSet.hs 159 --- | Insert an element onto the top of stack 'n'. +-- | /O(log n)/. Insert an element onto the top of stack 'n'. hunk ./StackSet.hs 166 - , stacks = S.adjust (L.nub . (k:)) n (stacks new) } + , stacks = I.adjust (L.nub . (k:)) n (stacks new) } hunk ./StackSet.hs 169 --- | Delete an element entirely from from the StackSet. +-- | /O(log n)/. Delete an element entirely from from the StackSet. hunk ./StackSet.hs 175 - , stacks = S.adjust (L.delete k) i (stacks w) } + , stacks = I.adjust (L.delete k) i (stacks w) } hunk ./StackSet.hs 22 -module StackSet ( - - StackSet, -- abstract, deriving Show,Eq - - -- * Introduction - empty, -- :: Int -> StackSet a - fromList, -- :: Ord a => (Int,[[a]]) -> StackSet a - toList, -- :: StackSet a -> (Int,[[a]]) - - -- * Inspection - size, -- :: StackSet a -> Int - peek, -- :: StackSet a -> Maybe a - index, -- :: Int -> StackSet a -> [a] - member, -- :: Ord a => a -> StackSet a -> Bool - current, -- :: StackSet a -> Int - - -- * Modification - push, -- :: Ord a => a -> StackSet a -> StackSet a - rotate, -- :: Ordering -> StackSet a -> StackSet a - shift, -- :: Ord a => Int -> StackSet a -> StackSet a - delete, -- :: Ord a => a -> StackSet a -> StackSet a - view, -- :: Int -> StackSet a -> StackSet a - - ) where +module StackSet {- everything -} where hunk ./StackSet.hs 25 -import qualified Data.List as L +import qualified Data.List as L (nub,delete) hunk ./StackSet.hs 35 - , size :: {-# UNPACK #-} !Int -- ^ size of the stack list hunk ./StackSet.hs 46 --- --- Currently stacks are of a fixed size. There's no firm reason to --- do this (new empty stacks could be created on the fly). hunk ./StackSet.hs 52 -empty n = StackSet { current= 0 - , size = n -- constant - , stacks = I.fromList (zip [0..n-1] (repeat [])) - , cache = M.empty - } +empty n = StackSet { current = 0 + , stacks = I.fromList (zip [0..n-1] (repeat [])) + , cache = M.empty } hunk ./StackSet.hs 60 +-- | /O(n)/. Number of stacks +size :: StackSet a -> Int +size = I.size . stacks + hunk ./StackSet.hs 69 -fromList (_,[]) - = error "Cannot build a StackSet from an empty list" +fromList (_,[]) = error "Cannot build a StackSet from an empty list" hunk ./StackSet.hs 71 -fromList (n,xs) - | n < 0 || n >= length xs - = error $ "Cursor index is out of range: " ++ show (n, length xs) +fromList (n,xs) | n < 0 || n >= length xs + = error $ "Cursor index is out of range: " ++ show (n, length xs) hunk ./StackSet.hs 74 -fromList (o,xs) = view o $ - foldr (\(i,ys) s -> - foldr (\a t -> insert a i t) s ys) - (empty (length xs)) (zip [0..] xs) +fromList (o,xs) = view o $ foldr (\(i,ys) s -> + foldr (\a t -> insert a i t) s ys) + (empty (length xs)) (zip [0..] xs) hunk ./StackSet.hs 82 ------------------------------------------------------------------------- - hunk ./StackSet.hs 102 -view n w | n >= 0 && n < size w = w { current = n } - | otherwise = error $ "view: index out of bounds: " ++ show n +view n w | n >= 0 && n < I.size (stacks w) = w { current = n } + | otherwise = error $ "view: index out of bounds: " ++ show n hunk ./StackSet.hs 115 - where - rot s = take l . drop offset . cycle $ s - where - n = fromEnum o - 1 - l = length s - offset = if n < 0 then l + n else n + where rot s = take l . drop offset . cycle $ s + where n = fromEnum o - 1 + l = length s + offset = if n < 0 then l + n else n hunk ./tests/Properties.hs 46 - in - view n (view i x) == x + in view n (view i x) == x hunk ./tests/Properties.hs 52 - in - shift n (shift r x) == x + in shift n (shift r x) == x hunk ./tests/Properties.hs 4 +import Data.Maybe hunk ./tests/Properties.hs 12 -import Data.List (sort,group,sort,intersperse) +import Data.List (nub,sort,group,sort,intersperse) hunk ./tests/Properties.hs 31 - where _ = x :: StackSet Int + where _ = x :: T + +prop_member1 i n = member i (push i x) + where x = empty n :: T + +prop_member2 i x = not (member i (delete i x)) + where _ = x :: T + +prop_member3 i n = member i (empty n :: T) == False + +prop_sizepush is n = n > 0 ==> size (foldr push x is ) == n + where x = empty n :: T + +prop_currentpush is n = n > 0 ==> + height (current x) (foldr push x js) == length js + where + js = nub is + x = empty n :: T + +prop_pushpeek x is = not (null is) ==> fromJust (peek (foldr push x is)) == head is + where _ = x :: T + +prop_peekmember x = case peek x of + Just w -> member w x + Nothing -> True {- then we don't know anything -} + where _ = x :: T + +type T = StackSet Int hunk ./tests/Properties.hs 61 - where _ = x :: StackSet Int + where _ = x :: T hunk ./tests/Properties.hs 65 - where _ = x :: StackSet Int + where _ = x :: T hunk ./tests/Properties.hs 68 - where _ = x :: StackSet Int + where _ = x :: T hunk ./tests/Properties.hs 76 - where _ = x :: StackSet Int + where _ = x :: T hunk ./tests/Properties.hs 81 - where _ = x :: StackSet Int + where _ = x :: T hunk ./tests/Properties.hs 95 + ,("member/push ", mytest prop_member1) + ,("member/peek ", mytest prop_peekmember) + ,("member/delete ", mytest prop_member2) + ,("member/empty ", mytest prop_member3) + ,("size/push ", mytest prop_sizepush) + ,("height/push ", mytest prop_currentpush) + ,("push/peek ", mytest prop_pushpeek) hunk ./Main.hs 150 - withScreen $ \(d,sw,sh) -> io $ do - moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen - raiseWindow d w + withDisplay $ \d -> do + sw <- gets screenWidth + sh <- gets screenHeight + io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen + raiseWindow d w hunk ./Main.hs 158 -hide w = withScreen $ \(dpy,sw,sh) -> io $ - moveWindow dpy w (2*fromIntegral sw) (2*fromIntegral sh) +hide w = withDisplay $ \d -> do + sw <- gets screenWidth + sh <- gets screenHeight + io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) hunk ./Main.hs 169 -windows f = modifyWorkspace f >> refresh +windows f = do + modify $ \s -> s { workspace = f (workspace s) } + ws <- gets workspace + refresh + trace (show ws) -- log state changes to stderr hunk ./WMonad.hs 17 -module WMonad where +module WMonad ( + W, WorkSpace, WState(..), + runW, withDisplay, io, io_, forever, spawn, trace, whenJust + ) where hunk ./WMonad.hs 42 -newtype W a = W { unW :: StateT WState IO a } +newtype W a = W (StateT WState IO a) hunk ./WMonad.hs 48 -runW st a = runStateT (unW a) st +runW st (W a) = runStateT a st + +-- | Run a monad action with the current display settings +withDisplay :: (Display -> W ()) -> W () +withDisplay f = gets display >>= f + +------------------------------------------------------------------------ hunk ./WMonad.hs 72 --- | A 'trace' for the W monad. Logs a string to stderr. The result may --- be found in your .xsession-errors file -trace :: String -> W () -trace msg = io $ do - hPutStrLn stderr msg - hFlush stderr - --- | Run a monad action with the current display settings -withDisplay :: (Display -> W ()) -> W () -withDisplay f = gets display >>= f - --- | Run a monadic action with the display, screen width and height -withScreen :: ((Display,Int,Int) -> W ()) -> W () -withScreen f = do - d <- gets display - sw <- gets screenWidth - sh <- gets screenHeight - f (d,sw,sh) - --- | Modify the workspace list. -modifyWorkspace :: (WorkSpace -> WorkSpace) -> W () -modifyWorkspace f = do - modify $ \s -> s { workspace = f (workspace s) } - ws <- gets workspace - trace (show ws) -- log state changes to stderr - hunk ./WMonad.hs 77 +-- | A 'trace' for the W monad. Logs a string to stderr. The result may +-- be found in your .xsession-errors file +trace :: String -> W () +trace msg = io $ do hPutStrLn stderr msg; hFlush stderr + hunk ./Main.hs 57 --- let's get underway +-- The main entry point hunk ./Main.hs 79 - go dpy - + forever $ handle =<< io (allocaXEvent $ \ev -> + nextEvent dpy ev >> getEvent ev) hunk ./Main.hs 83 - -- The main loop - go dpy = forever $ do - e <- io $ allocaXEvent $ \ev -> nextEvent dpy ev >> getEvent ev - handle e + forever a = a >> forever a hunk ./Main.hs 168 - ws <- gets workspace hunk ./Main.hs 169 - trace (show ws) -- log state changes to stderr + -- ws <- gets workspace + -- trace (show ws) -- log state changes to stderr hunk ./Main.hs 200 - whenJust (W.peek ws) $ io_ . killClient d + whenJust (W.peek ws) $ \w -> io (killClient d w) >> return () hunk ./WMonad.hs 3 --- Module : W.hs +-- Module : WMonad.hs hunk ./WMonad.hs 19 - runW, withDisplay, io, io_, forever, spawn, trace, whenJust + runW, withDisplay, io, spawn, trace, whenJust hunk ./WMonad.hs 60 --- | Lift an IO action into the W monad, discarding any result -io_ :: IO a -> W () -io_ f = liftIO f >> return () - --- | Run an action forever -forever :: (Monad m) => m a -> m b -forever a = a >> forever a - hunk ./WMonad.hs 62 -spawn = io_ . runCommand +spawn x = io (runCommand x) >> return () hunk ./WMonad.hs 68 - hunk ./StackSet.hs 22 -module StackSet {- everything -} where +module StackSet ( + StackSet, -- abstract + + -- * Introduction and elimination + empty, -- :: Int -> StackSet a + fromList, -- :: Ord a => (Int,[[a]]) -> StackSet a + toList, -- :: StackSet a -> (Int,[[a]]) + index, -- :: Int -> StackSet a -> [a] + current, -- :: StackSet a -> Int + + -- * Queries + member, -- :: Ord a => a -> StackSet a -> Bool + size, -- :: StackSet a -> Int + peek, -- :: StackSet a -> Maybe a + + -- * Modifcations + push, -- :: Ord a => a -> StackSet a -> StackSet a + view, -- :: Int -> StackSet a -> StackSet a + rotate, -- :: Ordering -> StackSet a -> StackSet a + shift, -- :: Ord a => Int -> StackSet a -> StackSet a + insert, -- :: Ord a => a -> Int -> StackSet a -> StackSet a + delete, -- :: Ord a => a -> StackSet a -> StackSet a + + ) where hunk ./Main.hs 158 - io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) + io $! moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) hunk ./Main.hs 162 -reveal w = withDisplay $ \d -> io $ moveWindow d w 0 0 +reveal w = withDisplay $ \d -> io $! moveWindow d w 0 0 hunk ./WMonad.hs 71 -trace msg = io $ do hPutStrLn stderr msg; hFlush stderr +trace msg = io $! do hPutStrLn stderr msg; hFlush stderr hunk ./thunk.cabal 14 -ghc-options: -O -Wall -optl-Wl,-s +ghc-options: -O2 -Wall -optl-Wl,-s +-- ghc-options: -O2 -Wall -optl-Wl,-s -prof -auto-all hunk ./WMonad.hs 59 +{-# INLINE io #-} hunk ./thunk.cabal 10 -build-depends: base==2.0, X11>=1.1, X11-extras==0.0, unix==1.0, mtl==1.0 +build-depends: base==2.0, X11>=1.1, X11-extras==0.0, mtl==1.0 hunk ./StackSet.hs 53 + +-- +-- N.B we probably want to think about strict 'adjust' and inserts on +-- these data structures in the long run. +-- hunk ./StackSet.hs 23 - StackSet, -- abstract + StackSet, -- abstract hunk ./StackSet.hs 50 -import qualified Data.IntMap as I hunk ./StackSet.hs 61 - { current:: {-# UNPACK #-} !Int -- ^ the currently visible stack - , stacks :: {-# UNPACK #-} !(I.IntMap [a]) -- ^ the separate stacks - , cache :: {-# UNPACK #-} !(M.Map a Int) -- ^ a cache of windows back to their stacks + { current:: {-# UNPACK #-} !Int -- ^ the currently visible stack + , stacks :: {-# UNPACK #-} !(M.Map Int [a]) -- ^ the separate stacks + , cache :: {-# UNPACK #-} !(M.Map a Int) -- ^ a cache of windows back to their stacks hunk ./StackSet.hs 80 - , stacks = I.fromList (zip [0..n-1] (repeat [])) + , stacks = M.fromList (zip [0..n-1] (repeat [])) hunk ./StackSet.hs 89 -size = I.size . stacks +size = M.size . stacks hunk ./StackSet.hs 107 -toList x = (current x, map snd $ I.toList (stacks x)) +toList x = (current x, map snd $ M.toList (stacks x)) hunk ./StackSet.hs 124 -index k w = fromJust (I.lookup k (stacks w)) +index k w = fromJust (M.lookup k (stacks w)) hunk ./StackSet.hs 129 -view n w | n >= 0 && n < I.size (stacks w) = w { current = n } +view n w | n >= 0 && n < M.size (stacks w) = w { current = n } hunk ./StackSet.hs 141 -rotate o w = w { stacks = I.adjust rot (current w) (stacks w) } +rotate o w = w { stacks = M.adjust rot (current w) (stacks w) } hunk ./StackSet.hs 161 - , stacks = I.adjust (L.nub . (k:)) n (stacks new) } + , stacks = M.adjust (L.nub . (k:)) n (stacks new) } hunk ./StackSet.hs 170 - , stacks = I.adjust (L.delete k) i (stacks w) } + , stacks = M.adjust (L.delete k) i (stacks w) } hunk ./StackSet.hs 48 -import qualified Data.List as L (nub,delete) +import qualified Data.List as L (delete) hunk ./StackSet.hs 161 - , stacks = M.adjust (L.nub . (k:)) n (stacks new) } + , stacks = M.adjust (k:) n (stacks new) } hunk ./StackSet.hs 22 -module StackSet ( - StackSet, -- abstract - - -- * Introduction and elimination - empty, -- :: Int -> StackSet a - fromList, -- :: Ord a => (Int,[[a]]) -> StackSet a - toList, -- :: StackSet a -> (Int,[[a]]) - index, -- :: Int -> StackSet a -> [a] - current, -- :: StackSet a -> Int - - -- * Queries - member, -- :: Ord a => a -> StackSet a -> Bool - size, -- :: StackSet a -> Int - peek, -- :: StackSet a -> Maybe a - - -- * Modifcations - push, -- :: Ord a => a -> StackSet a -> StackSet a - view, -- :: Int -> StackSet a -> StackSet a - rotate, -- :: Ordering -> StackSet a -> StackSet a - shift, -- :: Ord a => Int -> StackSet a -> StackSet a - insert, -- :: Ord a => a -> Int -> StackSet a -> StackSet a - delete, -- :: Ord a => a -> StackSet a -> StackSet a - - ) where +module StackSet where hunk ./WMonad.hs 18 - W, WorkSpace, WState(..), - runW, withDisplay, io, spawn, trace, whenJust + W, WorkSpace, WState(..),runW, withDisplay, io, spawn, trace, whenJust hunk ./README 17 - unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 hunk ./Main.hs 76 + + -- scan for initial windows hunk ./Main.hs 80 - when (waMapState wa == waIsViewable) (manage w) + when (not (waOverrideRedirect wa) && waMapState wa == waIsViewable) + (manage w) + hunk ./Main.hs 72 - io $ do selectInput dpy r (substructureRedirectMask .|. substructureNotifyMask) + io $ do selectInput dpy r $ substructureRedirectMask + .|. substructureNotifyMask + .|. enterWindowMask + .|. leaveWindowMask + hunk ./Main.hs 118 +-- XCreateWindowEvent(3X11) +-- Window manager clients normally should ignore this window if the +-- override_redirect member is True. + hunk ./Main.hs 70 - runW initState $ do + allocaXEvent $ \ev -> + runW initState $ do hunk ./Main.hs 73 - io $ do selectInput dpy r $ substructureRedirectMask - .|. substructureNotifyMask - .|. enterWindowMask - .|. leaveWindowMask + io $ sync dpy False + io $ selectInput dpy r $ substructureRedirectMask + .|. substructureNotifyMask + .|. enterWindowMask + .|. leaveWindowMask hunk ./Main.hs 79 - sync dpy False hunk ./Main.hs 88 - forever $ handle =<< io (allocaXEvent $ \ev -> - nextEvent dpy ev >> getEvent ev) + io $ sync dpy False + forever $ handle =<< io (nextEvent dpy ev >> getEvent ev) + hunk ./Main.hs 97 -grabKeys dpy r = forM_ (M.keys keys) $ \(m,s) -> io $ do - kc <- keysymToKeycode dpy s - grabKey dpy kc m r True grabModeAsync grabModeAsync +grabKeys dpy root = do + io $ ungrabKey dpy '\0' {-AnyKey-} anyModifier root + forM_ (M.keys keys) $ \(mask,s) -> io $ do + kc <- keysymToKeycode dpy s + let grab m = grabKey dpy kc m root True grabModeAsync grabModeAsync + grab mask + grab (mask .|. lockMask) + -- no numlock hunk ./Main.hs 80 - (_, _, ws) <- io $ queryTree dpy r hunk ./Main.hs 82 + (_, _, ws) <- io $ queryTree dpy r hunk ./Main.hs 97 -grabKeys dpy root = do - io $ ungrabKey dpy '\0' {-AnyKey-} anyModifier root +grabKeys dpy r = do + io $ ungrabKey dpy '\0' {-AnyKey-} anyModifier r hunk ./Main.hs 101 - let grab m = grabKey dpy kc m root True grabModeAsync grabModeAsync + let grab m = grabKey dpy kc m r True grabModeAsync grabModeAsync hunk ./Main.hs 121 -handle (MapRequestEvent {window = w}) = withDisplay $ \dpy -> do - wa <- io $ getWindowAttributes dpy w - when (not (waOverrideRedirect wa)) $ manage w - hunk ./Main.hs 124 +handle (MapRequestEvent {window = w}) = withDisplay $ \dpy -> do + wa <- io $ getWindowAttributes dpy w + when (not (waOverrideRedirect wa)) $ manage w hunk ./Main.hs 143 + ws <- gets workspace + let w = window e + + when (W.member w ws) $ -- already managed, reconfigure (see client:configure() + trace ("Reconfigure already managed window: " ++ show w) + hunk ./Main.hs 150 - { wcX = x e - , wcY = y e - , wcWidth = width e - , wcHeight = height e - , wcBorderWidth = border_width e - , wcSibling = above e - , wcStackMode = detail e - } + { wcX = x e + , wcY = y e + , wcWidth = width e + , wcHeight = height e + , wcBorderWidth = border_width e + , wcSibling = above e + , wcStackMode = detail e + } + hunk ./README 6 - more correct window manager in less lines of code, using strong + more correct window manager in fewer lines of code, using strong hunk ./Main.hs 75 - .|. substructureNotifyMask - .|. enterWindowMask - .|. leaveWindowMask + .|. substructureNotifyMask + .|. enterWindowMask + .|. leaveWindowMask hunk ./Main.hs 118 +-- +-- on EnterNotify we should SetFocus to the window we're entering, +-- on LeaveNotify, we set it back to root. +-- +-- Needs XCrossing support hunk ./Main.hs 207 +-- +-- When we start to manage a window, it gains focus. +-- hunk ./Main.hs 212 - withDisplay $ io . flip mapWindow w + withDisplay $ \d -> io $ do + mapWindow d w + -- setInputFocus d w revertToPointerRoot 0 -- CurrentTime hunk ./Main.hs 217 + + hunk ./Main.hs 62 - let dflt = defaultScreen dpy - initState = WState + let dflt = defaultScreen dpy + st = WState hunk ./Main.hs 70 - allocaXEvent $ \ev -> - runW initState $ do - r <- io $ rootWindow dpy dflt - io $ sync dpy False - io $ selectInput dpy r $ substructureRedirectMask - .|. substructureNotifyMask - .|. enterWindowMask - .|. leaveWindowMask + -- setup initial X environment + rootw <- rootWindow dpy dflt + sync dpy False + selectInput dpy rootw $ substructureRedirectMask + .|. substructureNotifyMask + .|. enterWindowMask + .|. leaveWindowMask + grabKeys dpy rootw + sync dpy False hunk ./Main.hs 80 - grabKeys dpy r + ws <- scan dpy rootw + allocaXEvent $ \e -> + runW st $ do + mapM_ manage ws + forever $ handle =<< xevent dpy e + where + xevent d e = io (nextEvent d e >> getEvent e) + forever a = a >> forever a hunk ./Main.hs 89 - -- scan for initial windows - (_, _, ws) <- io $ queryTree dpy r - forM_ ws $ \w -> do - wa <- io $ getWindowAttributes dpy w - when (not (waOverrideRedirect wa) && waMapState wa == waIsViewable) - (manage w) - - io $ sync dpy False - forever $ handle =<< io (nextEvent dpy ev >> getEvent ev) +-- --------------------------------------------------------------------- +-- IO stuff. Doesn't require any W state +-- Most of these things run only on startup (bar grabkeys) hunk ./Main.hs 93 - return () +-- | scan for any initial windows to manage +scan :: Display -> Window -> IO [Window] +scan dpy rootw = do + (_, _, ws) <- queryTree dpy rootw + filterM ok ws hunk ./Main.hs 99 - forever a = a >> forever a + ok w = do wa <- getWindowAttributes dpy w + return $ not (waOverrideRedirect wa) + && waMapState wa == waIsViewable hunk ./Main.hs 104 -grabKeys :: Display -> Window -> W () -grabKeys dpy r = do - io $ ungrabKey dpy '\0' {-AnyKey-} anyModifier r - forM_ (M.keys keys) $ \(mask,s) -> io $ do - kc <- keysymToKeycode dpy s - let grab m = grabKey dpy kc m r True grabModeAsync grabModeAsync - grab mask - grab (mask .|. lockMask) - -- no numlock +grabKeys :: Display -> Window -> IO () +grabKeys dpy rootw = do + ungrabKey dpy '\0' {-AnyKey-} anyModifier rootw + forM_ (M.keys keys) $ \(mask,sym) -> do + kc <- keysymToKeycode dpy sym + mapM_ (grab kc) [mask, mask .|. lockMask] -- note: no numlock + where + grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync hunk ./Main.hs 130 +-- +-- Todo: seperate IO from W monad stuff. We want to be able to test the +-- handler, and client functions, with dummy X interface ops, in QuickCheck +-- +-- Will require an abstract interpreter from Event -> W Action, which +-- modifies the internal W state, and then produces an IO action to +-- evaluate. hunk ./Main.hs 153 - when (request e == mappingKeyboard) $ withDisplay $ flip grabKeys w + when (request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w hunk ./Main.hs 231 - - hunk ./WMonad.hs 46 -runW :: WState -> W a -> IO (a, WState) -runW st (W a) = runStateT a st +runW :: WState -> W a -> IO () +runW st (W a) = runStateT a st >> return () hunk ./Main.hs 45 - , ((mod1Mask, xK_Tab ), focus GT) - , ((mod1Mask, xK_j ), focus GT) - , ((mod1Mask, xK_k ), focus LT) + , ((mod1Mask, xK_Tab ), raise GT) + , ((mod1Mask, xK_j ), raise GT) + , ((mod1Mask, xK_k ), raise LT) hunk ./Main.hs 87 + hunk ./Main.hs 122 --- [EnterNotify] = enternotify, --- [LeaveNotify] = leavenotify, hunk ./Main.hs 125 --- on EnterNotify we should SetFocus to the window we're entering, --- on LeaveNotify, we set it back to root. --- --- Needs XCrossing support --- hunk ./Main.hs 131 --- -handle :: Event -> W () - +-- hunk ./Main.hs 135 +-- +handle :: Event -> W () + hunk ./Main.hs 155 +handle e@(CrossingEvent {event_type = t}) + | t == enterNotify && mode e == notifyNormal && detail e /= notifyInferior + = withDisplay $ \d -> do + let w = window e + ws <- gets workspace + -- note: we get enter events for what appear to be subwindows of + -- ones under managment. we need to ignore those. hence we check either for + -- root, or for ismember. + if W.member w ws + then io $ setInputFocus d w revertToPointerRoot 0 -- it is ours, manage it + else do let dflt = defaultScreen d + rootw <- io $ rootWindow d dflt -- should be in state + when (w == rootw) $ do + let w' = maybe rootw id (W.peek ws) -- focus to the top of the stack + io $ setInputFocus d w' revertToPointerRoot 0 + +handle e@(CrossingEvent {event_type = t}) + | t == leaveNotify + = withDisplay $ \d -> do + let dflt = defaultScreen d + rootw <- io $ rootWindow d dflt + when (window e == rootw && not (same_screen e)) $ + io $ setInputFocus d rootw revertToPointerRoot 0 + hunk ./Main.hs 199 -handle e = trace (eventName e) +handle e = trace (eventName e) -- ignoring hunk ./Main.hs 232 - -- ws <- gets workspace - -- trace (show ws) -- log state changes to stderr + ws <- gets workspace + trace (show ws) -- log state changes to stderr hunk ./Main.hs 246 + selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask hunk ./Main.hs 248 - -- setInputFocus d w revertToPointerRoot 0 -- CurrentTime + setInputFocus d w revertToPointerRoot 0 -- CurrentTime hunk ./Main.hs 260 --- | focus. focus to window at offset 'n' in list. +-- | raise. focus to window at offset 'n' in list. hunk ./Main.hs 262 -focus :: Ordering -> W () -focus = windows . W.rotate +raise :: Ordering -> W () +raise = windows . W.rotate hunk ./README 9 - If the aim of dwm is to fit in under 2000 lines of C, the aim of dwm - is to fit in under 500 lines of Haskell with similar functionality. + If the aim of dwm is to fit in under 2000 lines of C, the aim of + thunk is to fit in under 400 lines of Haskell with similar functionality. hunk ./Main.hs 288 - mapM_ hide (W.index m ws) hunk ./Main.hs 289 + mapM_ hide (W.index m ws) hunk ./Main.hs 35 -workspaces = 5 +workspaces = 9 hunk ./Main.hs 26 +import Numeric hunk ./Main.hs 246 + trace ("Managing window: 0x" ++ showHex w (", " ++ show w)) hunk ./Main.hs 271 - whenJust (W.peek ws) $ \w -> io (killClient d w) >> return () + whenJust (W.peek ws) $ \w -> do + trace ("Attempting to kill window: 0x" ++ showHex w (", " ++ show w)) + io (killClient d w) >> return () move ./WMonad.hs ./XMonad.hs hunk ./Main.hs 29 -import WMonad +import XMonad hunk ./Main.hs 41 -keys :: M.Map (KeyMask, KeySym) (W ()) +keys :: M.Map (KeyMask, KeySym) (X ()) hunk ./Main.hs 64 - st = WState + st = XState hunk ./Main.hs 83 - runW st $ do + runX st $ do hunk ./Main.hs 92 --- IO stuff. Doesn't require any W state +-- IO stuff. Doesn't require any X state hunk ./Main.hs 126 --- Todo: seperate IO from W monad stuff. We want to be able to test the +-- Todo: seperate IO from X monad stuff. We want to be able to test the hunk ./Main.hs 129 --- Will require an abstract interpreter from Event -> W Action, which --- modifies the internal W state, and then produces an IO action to +-- Will require an abstract interpreter from Event -> X Action, which +-- modifies the internal X state, and then produces an IO action to hunk ./Main.hs 137 -handle :: Event -> W () +handle :: Event -> X () hunk ./Main.hs 207 -refresh :: W () +refresh :: X () hunk ./Main.hs 218 -hide :: Window -> W () +hide :: Window -> X () hunk ./Main.hs 225 -reveal :: Window -> W () +reveal :: Window -> X () hunk ./Main.hs 229 -windows :: (WorkSpace -> WorkSpace) -> W () +windows :: (WorkSpace -> WorkSpace) -> X () hunk ./Main.hs 244 -manage :: Window -> W () +manage :: Window -> X () hunk ./Main.hs 255 -unmanage :: Window -> W () +unmanage :: Window -> X () hunk ./Main.hs 264 -raise :: Ordering -> W () +raise :: Ordering -> X () hunk ./Main.hs 268 -kill :: W () +kill :: X () hunk ./Main.hs 276 -tag :: Int -> W () +tag :: Int -> X () hunk ./Main.hs 287 -view :: Int -> W () +view :: Int -> X () hunk ./XMonad.hs 3 --- Module : WMonad.hs +-- Module : XMonad.hs hunk ./XMonad.hs 13 --- The W monad, a state monad transformer over IO, for the window +-- The X monad, a state monad transformer over IO, for the window hunk ./XMonad.hs 17 -module WMonad ( - W, WorkSpace, WState(..),runW, withDisplay, io, spawn, trace, whenJust +module XMonad ( + X, WorkSpace, XState(..),runX, withDisplay, io, spawn, trace, whenJust hunk ./XMonad.hs 28 --- | WState, the window manager state. +-- | XState, the window manager state. hunk ./XMonad.hs 30 -data WState = WState +data XState = XState hunk ./XMonad.hs 39 --- | The W monad, a StateT transformer over IO encapuslating the window +-- | The X monad, a StateT transformer over IO encapuslating the window hunk ./XMonad.hs 41 -newtype W a = W (StateT WState IO a) - deriving (Functor, Monad, MonadIO, MonadState WState) +newtype X a = X (StateT XState IO a) + deriving (Functor, Monad, MonadIO, MonadState XState) hunk ./XMonad.hs 44 --- | Run the W monad, given a chunk of W monad code, and an initial state +-- | Run the X monad, given a chunk of X monad code, and an initial state hunk ./XMonad.hs 46 -runW :: WState -> W a -> IO () -runW st (W a) = runStateT a st >> return () +runX :: XState -> X a -> IO () +runX st (X a) = runStateT a st >> return () hunk ./XMonad.hs 50 -withDisplay :: (Display -> W ()) -> W () +withDisplay :: (Display -> X ()) -> X () hunk ./XMonad.hs 55 --- | Lift an IO action into the W monad -io :: IO a -> W a +-- | Lift an IO action into the X monad +io :: IO a -> X a hunk ./XMonad.hs 61 -spawn :: String -> W () +spawn :: String -> X () hunk ./XMonad.hs 65 -whenJust :: Maybe a -> (a -> W ()) -> W () +whenJust :: Maybe a -> (a -> X ()) -> X () hunk ./XMonad.hs 68 --- | A 'trace' for the W monad. Logs a string to stderr. The result may +-- | A 'trace' for the X monad. Logs a string to stderr. The result may hunk ./XMonad.hs 70 -trace :: String -> W () +trace :: String -> X () move ./thunk.cabal ./xmonad.cabal hunk ./Main.hs 13 --- thunk, a minimal window manager for X11 +-- xmonad, a minimal window manager for X11 hunk ./README 1 - thunk : a lightweight X11 window manager. + xmonad : a lightweight X11 window manager. hunk ./README 27 - exec /home/dons/bin/thunk + exec /home/dons/bin/xmonad hunk ./xmonad.cabal 1 -name: thunk +name: xmonad hunk ./xmonad.cabal 12 -executable: thunk +executable: xmonad hunk ./Main.hs 74 + hunk ./Main.hs 88 - xevent d e = io (nextEvent d e >> getEvent e) + xevent d e = do ev <- io (nextEvent d e >> getEvent e) + trace ("GOT: " ++ eventName ev) + return ev hunk ./Main.hs 159 +-- +-- there's a race here, we might enter a window (e.g. on firefox +-- exiting), just as firefox destroys the window anyway. Setting focus +-- here will just trigger an error +-- hunk ./Main.hs 172 + trace $ "Got enter notify message for: " ++ show w hunk ./Main.hs 174 - then io $ setInputFocus d w revertToPointerRoot 0 -- it is ours, manage it + then do trace $ "It's one of ours, set input focus" + -- it might have already disappeared (firefox close event) + io $ setInputFocus d w revertToPointerRoot 0 -- it is ours, manage it hunk ./Main.hs 181 + trace $ "It's not one of ours, set focus to: " ++ show w' hunk ./Main.hs 183 + io $ sync d False hunk ./Main.hs 213 -handle e = trace (eventName e) -- ignoring +handle e = trace ("IGNORING: " ++ eventName e) -- ignoring hunk ./Main.hs 259 - trace ("Managing window: 0x" ++ showHex w (", " ++ show w)) hunk ./Main.hs 269 + trace $ "Asked to unmanage: " ++ show w + -- + -- quitting firefox will ask us to unmange one of its subwindows + -- then there'll be an EnterNotify event for the main window, which + -- will already have disappeared. leading to bad XsetFocus errors + -- hunk ./Main.hs 276 - when (W.member w ws) $ do - withDisplay $ \d -> io $ withServer d $ sync d False - windows $ W.delete w + when (W.member w ws) $ withDisplay $ \d -> + withServerX d $ do -- be sure to set focus on unmanaging + modify $ \s -> s { workspace = W.delete w (workspace s) } + ws' <- gets workspace + case W.peek ws' of + Just w' -> io $ setInputFocus d w' revertToPointerRoot 0 + Nothing -> do + let dflt = defaultScreen d + rootw <- io $ rootWindow d dflt + io $ setInputFocus d rootw revertToPointerRoot 0 + + io (sync d False) + +-- Grab the X server (lock it) from the X monad +withServerX :: Display -> X () -> X () +withServerX dpy f = do + io $ grabServer dpy + f + io $ ungrabServer dpy hunk ./Main.hs 306 - trace ("Attempting to kill window: 0x" ++ showHex w (", " ++ show w)) - io (killClient d w) >> return () + protocols <- io $ getWMProtocols d w + wmdelete <- io $ internAtom d "WM_DELETE_WINDOW" False -- stick in X state + wmprotocols <- io $ internAtom d "WM_PROTOCOLS" False + if wmdelete `elem` protocols + then io $ allocaXEvent $ \ev -> do + setEventType ev clientMessage + setClientMessageEvent ev w wmprotocols 32 wmdelete 0 + sendEvent d w False noEventMask ev + else io (killClient d w) >> return () hunk ./Main.hs 26 -import Numeric hunk ./Main.hs 61 - dpy <- openDisplay "" + dpy <- openDisplay "" hunk ./Main.hs 63 - st = XState + rootw <- rootWindow dpy dflt + wmdelt <- internAtom dpy "WM_DELETE_WINDOW" False + wmprot <- internAtom dpy "WM_PROTOCOLS" False + + let st = XState hunk ./Main.hs 69 - , screenWidth = displayWidth dpy dflt - , screenHeight = displayHeight dpy dflt + , screen = dflt + , theRoot = rootw + , wmdelete = wmdelt + , wmprotocols = wmprot + , dimensions = (displayWidth dpy dflt, displayHeight dpy dflt) hunk ./Main.hs 77 + xSetErrorHandler -- in C, I'm too lazy to write the binding + hunk ./Main.hs 80 - rootw <- rootWindow dpy dflt hunk ./Main.hs 81 - hunk ./Main.hs 88 - ws <- scan dpy rootw + ws <- scan dpy rootw hunk ./Main.hs 94 - xevent d e = do ev <- io (nextEvent d e >> getEvent e) - trace ("GOT: " ++ eventName ev) - return ev - + xevent d e = io (nextEvent d e >> getEvent e) hunk ./Main.hs 162 --- --- there's a race here, we might enter a window (e.g. on firefox --- exiting), just as firefox destroys the window anyway. Setting focus --- here will just trigger an error --- hunk ./Main.hs 167 - -- note: we get enter events for what appear to be subwindows of - -- ones under managment. we need to ignore those. hence we check either for - -- root, or for ismember. - trace $ "Got enter notify message for: " ++ show w hunk ./Main.hs 168 - then do trace $ "It's one of ours, set input focus" - -- it might have already disappeared (firefox close event) - io $ setInputFocus d w revertToPointerRoot 0 -- it is ours, manage it - else do let dflt = defaultScreen d - rootw <- io $ rootWindow d dflt -- should be in state + then io $ setInputFocus d w revertToPointerRoot 0 -- it is ours, manage it + else do rootw <- gets theRoot hunk ./Main.hs 171 - let w' = maybe rootw id (W.peek ws) -- focus to the top of the stack - trace $ "It's not one of ours, set focus to: " ++ show w' - io $ setInputFocus d w' revertToPointerRoot 0 + let new_w = maybe rootw id (W.peek ws) -- focus to the top of the stack + io $ setInputFocus d new_w revertToPointerRoot 0 hunk ./Main.hs 203 -handle e = trace ("IGNORING: " ++ eventName e) -- ignoring +handle e = trace (eventName e) -- ignoring hunk ./Main.hs 213 - whenJust (W.peek ws) $ \w -> - withDisplay $ \d -> do - sw <- gets screenWidth - sh <- gets screenHeight - io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen - raiseWindow d w + whenJust (W.peek ws) $ \w -> withDisplay $ \d -> do + (sw,sh) <- gets dimensions + io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen + raiseWindow d w + +-- | windows. Modify the current window list with a pure function, and refresh +windows :: (WorkSpace -> WorkSpace) -> X () +windows f = do + modify $ \s -> s { workspace = f (workspace s) } + refresh + ws <- gets workspace + trace (show ws) -- log state changes to stderr hunk ./Main.hs 229 - sw <- gets screenWidth - sh <- gets screenHeight + (sw,sh) <- gets dimensions hunk ./Main.hs 236 --- | windows. Modify the current window list with a pure function, and refresh -windows :: (WorkSpace -> WorkSpace) -> X () -windows f = do - modify $ \s -> s { workspace = f (workspace s) } - refresh - ws <- gets workspace - trace (show ws) -- log state changes to stderr - hunk ./Main.hs 256 - trace $ "Asked to unmanage: " ++ show w - -- - -- quitting firefox will ask us to unmange one of its subwindows - -- then there'll be an EnterNotify event for the main window, which - -- will already have disappeared. leading to bad XsetFocus errors - -- hunk ./Main.hs 257 - when (W.member w ws) $ withDisplay $ \d -> - withServerX d $ do -- be sure to set focus on unmanaging + when (W.member w ws) $ withDisplay $ \d -> withServerX d $ do + -- xseterrorhandler(dummy) hunk ./Main.hs 260 - ws' <- gets workspace - case W.peek ws' of - Just w' -> io $ setInputFocus d w' revertToPointerRoot 0 - Nothing -> do - let dflt = defaultScreen d - rootw <- io $ rootWindow d dflt + new_ws <- gets workspace + case W.peek new_ws of + Just new -> io $ setInputFocus d new revertToPointerRoot 0 + Nothing -> do + rootw <- gets theRoot hunk ./Main.hs 268 + -- xseterrorhandler(error) hunk ./Main.hs 270 --- Grab the X server (lock it) from the X monad +-- | Grab the X server (lock it) from the X monad hunk ./Main.hs 287 - protocols <- io $ getWMProtocols d w - wmdelete <- io $ internAtom d "WM_DELETE_WINDOW" False -- stick in X state - wmprotocols <- io $ internAtom d "WM_PROTOCOLS" False - if wmdelete `elem` protocols + protocols <- io $ getWMProtocols d w + wmdelt <- gets wmdelete + wmprot <- gets wmprotocols + if wmdelt `elem` protocols hunk ./Main.hs 293 - setClientMessageEvent ev w wmprotocols 32 wmdelete 0 + setClientMessageEvent ev w wmprot 32 wmdelt 0 hunk ./XMonad.hs 26 -import Graphics.X11.Xlib (Display,Window) +import Graphics.X11.Xlib hunk ./XMonad.hs 32 - , screenWidth :: {-# UNPACK #-} !Int - , screenHeight :: {-# UNPACK #-} !Int + , screen :: {-# UNPACK #-} !ScreenNumber + , theRoot :: {-# UNPACK #-} !Window + , wmdelete :: {-# UNPACK #-} !Atom + , wmprotocols :: {-# UNPACK #-} !Atom + , dimensions :: {-# UNPACK #-} !(Int,Int) hunk ./Main.hs 160 - maybe (return ()) id (M.lookup (m,s) keys) + whenJust (M.lookup (m,s) keys) id hunk ./Main.hs 162 -handle e@(CrossingEvent {event_type = t}) +handle e@(CrossingEvent {window = w, event_type = t}) hunk ./Main.hs 164 - = withDisplay $ \d -> do - let w = window e - ws <- gets workspace - if W.member w ws - then io $ setInputFocus d w revertToPointerRoot 0 -- it is ours, manage it - else do rootw <- gets theRoot - when (w == rootw) $ do - let new_w = maybe rootw id (W.peek ws) -- focus to the top of the stack - io $ setInputFocus d new_w revertToPointerRoot 0 - io $ sync d False + = do ws <- gets workspace + if W.member w ws + then setFocus w + else do b <- isRoot w + when b setTopFocus hunk ./Main.hs 172 - = withDisplay $ \d -> do - let dflt = defaultScreen d - rootw <- io $ rootWindow d dflt - when (window e == rootw && not (same_screen e)) $ - io $ setInputFocus d rootw revertToPointerRoot 0 + = do rootw <- gets theRoot + when (window e == rootw && not (same_screen e)) $ setFocus rootw hunk ./Main.hs 175 -handle e@(ConfigureRequestEvent {}) = do +handle e@(ConfigureRequestEvent {window = w}) = do hunk ./Main.hs 178 - let w = window e hunk ./Main.hs 240 - setInputFocus d w revertToPointerRoot 0 -- CurrentTime + setFocus w hunk ./Main.hs 248 - when (W.member w ws) $ withDisplay $ \d -> withServerX d $ do - -- xseterrorhandler(dummy) + when (W.member w ws) $ do hunk ./Main.hs 250 - new_ws <- gets workspace - case W.peek new_ws of - Just new -> io $ setInputFocus d new revertToPointerRoot 0 - Nothing -> do - rootw <- gets theRoot - io $ setInputFocus d rootw revertToPointerRoot 0 + withDisplay $ \d -> + withServerX d $ do + setTopFocus + io (sync d False) + +-- | Explicitly set the keyboard focus to the given window +setFocus :: Window -> X () +setFocus w = withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 + +-- | Set the focus to the window on top of the stack, or root +setTopFocus :: X () +setTopFocus = do + ws <- gets workspace + case W.peek ws of + Just new -> setFocus new + Nothing -> gets theRoot >>= setFocus hunk ./Main.hs 267 - io (sync d False) - -- xseterrorhandler(error) +-- | True if the given window is the root window +isRoot :: Window -> X Bool +isRoot w = liftM (w==) (gets theRoot) hunk ./Main.hs 221 - io $! moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) + io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) hunk ./Main.hs 225 -reveal w = withDisplay $ \d -> io $! moveWindow d w 0 0 +reveal w = withDisplay $ \d -> io $ moveWindow d w 0 0 hunk ./Main.hs 250 - withDisplay $ \d -> - withServerX d $ do - setTopFocus - io (sync d False) + withServerX $ do + setTopFocus + withDisplay $ \d -> io (sync d False) -- TODO, everything operates on the current display, so wrap it up. + +-- | Grab the X server (lock it) from the X monad +withServerX :: X () -> X () +withServerX f = withDisplay $ \dpy -> do + io $ grabServer dpy + f + io $ ungrabServer dpy hunk ./Main.hs 277 --- | Grab the X server (lock it) from the X monad -withServerX :: Display -> X () -> X () -withServerX dpy f = do - io $ grabServer dpy - f - io $ ungrabServer dpy - hunk ./Main.hs 272 - --- | True if the given window is the root window -isRoot :: Window -> X Bool -isRoot w = liftM (w==) (gets theRoot) hunk ./XMonad.hs 18 - X, WorkSpace, XState(..),runX, withDisplay, io, spawn, trace, whenJust + X, WorkSpace, XState(..),runX, + io, withDisplay, isRoot, + spawn, trace, whenJust hunk ./XMonad.hs 54 +-- --------------------------------------------------------------------- +-- Convenient wrappers to state + hunk ./XMonad.hs 61 ------------------------------------------------------------------------- +-- | True if the given window is the root window +isRoot :: Window -> X Bool +isRoot w = liftM (w==) (gets theRoot) + +-- --------------------------------------------------------------------- +-- Utilities hunk ./Main.hs 145 +-- run window manager command +handle (KeyEvent {event_type = t, state = m, keycode = code}) + | t == keyPress + = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 + whenJust (M.lookup (m,s) keys) id + +-- manage a new window hunk ./Main.hs 154 - wa <- io $ getWindowAttributes dpy w + wa <- io $ getWindowAttributes dpy w -- ignore override windows hunk ./Main.hs 157 -handle (DestroyWindowEvent {window = w}) = unmanage w -handle (UnmapEvent {window = w}) = unmanage w +-- window destroyed, unmanage it +handle (DestroyWindowEvent {window = w}) = do b <- isClient w; when b $ unmanage w + +-- window gone, unmanage it +handle (UnmapEvent {window = w}) = do b <- isClient w; when b $ unmanage w hunk ./Main.hs 163 +-- set keyboard mapping hunk ./Main.hs 169 -handle (KeyEvent {event_type = t, state = m, keycode = code}) - | t == keyPress = withDisplay $ \dpy -> do - s <- io $ keycodeToKeysym dpy code 0 - whenJust (M.lookup (m,s) keys) id - +-- entered a normal window hunk ./Main.hs 178 +-- left a window, check if we need to focus root hunk ./Main.hs 184 +-- configure a window hunk ./Main.hs 257 - ws <- gets workspace - when (W.member w ws) $ do - modify $ \s -> s { workspace = W.delete w (workspace s) } - withServerX $ do - setTopFocus - withDisplay $ \d -> io (sync d False) -- TODO, everything operates on the current display, so wrap it up. + modify $ \s -> s { workspace = W.delete w (workspace s) } + withServerX $ do + setTopFocus + withDisplay $ \d -> io (sync d False) + -- TODO, everything operates on the current display, so wrap it up. hunk ./Main.hs 325 +-- | True if window is under management by us +isClient :: Window -> X Bool +isClient w = liftM (W.member w) (gets workspace) + hunk ./XMonad.hs 29 +import Control.Exception hunk ./XMonad.hs 76 -spawn x = io (runCommand x) >> return () +spawn x = do v <- io $ handle (return . Just) (runCommand x >> return Nothing) + whenJust v $ \e -> trace $ "xmonad:spawn: unable to fork "++show x++": "++show e hunk ./README 18 + unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 (included with ghc) hunk ./XMonad.hs 27 -import System.Process (runCommand) +import System.Posix.Process (newSession, executeFile) hunk ./XMonad.hs 76 -spawn x = do v <- io $ handle (return . Just) (runCommand x >> return Nothing) - whenJust v $ \e -> trace $ "xmonad:spawn: unable to fork "++show x++": "++show e +spawn x = io $ forkProcess (do newSession; executeFile "/bin/sh" False ["-c", x] Nothing) hunk ./xmonad.cabal 10 -build-depends: base==2.0, X11>=1.1, X11-extras==0.0, mtl==1.0 +build-depends: base==2.0, X11>=1.1, X11-extras==0.0, mtl==1.0, unix>=1.0 hunk ./XMonad.hs 27 -import System.Posix.Process (newSession, executeFile) +import System.Posix.Process (createSession, executeFile, forkProcess) hunk ./XMonad.hs 76 -spawn x = io $ forkProcess (do newSession; executeFile "/bin/sh" False ["-c", x] Nothing) +spawn x = do + io $ forkProcess $ do createSession; executeFile "/bin/sh" False ["-c", x] Nothing + return () hunk ./XMonad.hs 27 -import System.Posix.Process (createSession, executeFile, forkProcess) +import System.Posix.Process (executeFile, forkProcess, getProcessStatus) +import System.Exit hunk ./XMonad.hs 77 -spawn x = do - io $ forkProcess $ do createSession; executeFile "/bin/sh" False ["-c", x] Nothing +spawn x = io $ do + pid <- forkProcess $ do + forkProcess (executeFile "/bin/sh" False ["-c", x] Nothing) + exitWith ExitSuccess + return () + getProcessStatus True False pid hunk ./TODO 18 +- tiling: + - StackSet currently holds one stack, it needs to hold two. One stack + contains focus info, the top of that stack is always the window that + is in the foreground and has focus. + + The other stack keeps track of window layout order. In tiling mode, + the first window in the stack is in the master area. In both tiling + and full screen mode, window cycling follows the order in this stack. + + - Layout calculation: a simple function from number of windows to list + of coordinates. + + - state components, key combos, etc. for changing the current layout + scheme + hunk ./README 10 - thunk is to fit in under 400 lines of Haskell with similar functionality. + xmonad is to fit in under 400 lines of Haskell with similar functionality. hunk ./TODO 1 +- tasks before 0.1: + - tiling + - Refactor to make user configuration reasonable. There should be one + file (Config.hs) with all the knobs a user can twist. + hunk ./Main.hs 37 +-- +-- modMask lets you easily change which modkey you use. +-- +modMask = mod1Mask + hunk ./Main.hs 47 - [ ((mod1Mask .|. shiftMask, xK_Return), spawn "xterm") - , ((mod1Mask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") + [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") + , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") hunk ./Main.hs 50 - , ((mod1Mask, xK_Tab ), raise GT) - , ((mod1Mask, xK_j ), raise GT) - , ((mod1Mask, xK_k ), raise LT) - , ((mod1Mask .|. shiftMask, xK_c ), kill) - , ((mod1Mask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) + , ((modMask, xK_Tab ), raise GT) + , ((modMask, xK_j ), raise GT) + , ((modMask, xK_k ), raise LT) + , ((modMask .|. shiftMask, xK_c ), kill) + , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) hunk ./Main.hs 57 - [((m .|. mod1Mask, xK_0 + fromIntegral i), f i) + [((m .|. modMask, xK_0 + fromIntegral i), f i) hunk ./Main.hs 40 +modMask :: KeyMask hunk ./XMonad.hs 30 -import Control.Exception hunk ./Main.hs 50 - , ((controlMask, xK_space ), spawn "gmrun") + , ((controlMask, xK_space ), spawn "gmrun") hunk ./Main.hs 17 +import Data.Maybe hunk ./Main.hs 26 +import Graphics.X11.Xinerama hunk ./Main.hs 74 + xinesc <- getScreenInfo dpy hunk ./Main.hs 79 + , xineScreens = xinesc + , wsOnScreen = M.fromList $ map ((\n -> (n,n)) . fromIntegral . xsi_screen_number) xinesc hunk ./Main.hs 184 - if W.member w ws - then setFocus w - else do b <- isRoot w - when b setTopFocus + case W.lookup w ws of + Just n -> do setFocus w + windows $ W.view n + Nothing -> do b <- isRoot w + when b setTopFocus hunk ./Main.hs 226 - whenJust (W.peek ws) $ \w -> withDisplay $ \d -> do - (sw,sh) <- gets dimensions - io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) -- fullscreen - raiseWindow d w + ws2sc <- gets wsOnScreen + xinesc <- gets xineScreens + forM_ (M.assocs ws2sc) $ \(n, scn) -> + whenJust (listToMaybe $ W.index n ws) $ \w -> withDisplay $ \d -> do + let sc = xinesc !! scn + io $ do moveResizeWindow d w (fromIntegral $ xsi_x_org sc) + (fromIntegral $ xsi_y_org sc) + (fromIntegral $ xsi_width sc) + (fromIntegral $ xsi_height sc) -- fullscreen + raiseWindow d w + whenJust (W.peek ws) setFocus hunk ./Main.hs 246 --- | hide. Hide a list of windows by moving them offscreen. +-- | hide. Hide a window by moving it offscreen. hunk ./Main.hs 252 --- | reveal. Expose a list of windows, moving them on screen -reveal :: Window -> X () -reveal w = withDisplay $ \d -> io $ moveWindow d w 0 0 - hunk ./Main.hs 324 - hide w + hide w hunk ./Main.hs 332 + ws2sc <- gets wsOnScreen hunk ./Main.hs 335 - mapM_ reveal (W.index n ws) - mapM_ hide (W.index m ws) - windows $ W.view n + -- is the workspace we want to switch to currently visible? + if M.member n ws2sc + then windows $ W.view n + else do + -- This assumes that the current workspace is visible. + -- Is that always going to be true? + let Just curscreen = M.lookup m ws2sc + modify $ \s -> s { wsOnScreen = M.insert n curscreen (M.delete m ws2sc) } + windows $ W.view n + mapM_ hide (W.index m ws) + setTopFocus hunk ./Main.hs 348 - hunk ./StackSet.hs 63 + +-- | /O(log n)/. Looks up the stack that x is in, if it is in the StackSet +lookup :: (Monad m, Ord a) => a -> StackSet a -> m Int +lookup x w = M.lookup x (cache w) hunk ./XMonad.hs 18 - X, WorkSpace, XState(..),runX, + X, WorkSpace, XState(..), runX, hunk ./XMonad.hs 31 +import Graphics.X11.Xinerama + +import qualified Data.Map as M + hunk ./XMonad.hs 40 + , xineScreens :: {-# UNPACK #-} ![XineramaScreenInfo] + -- a mapping of workspaces to xinerama screen numbers + , wsOnScreen :: {-# UNPACK #-} !(M.Map Int Int) hunk ./Main.hs 339 - -- This assumes that the current workspace is visible. - -- Is that always going to be true? - let Just curscreen = M.lookup m ws2sc - modify $ \s -> s { wsOnScreen = M.insert n curscreen (M.delete m ws2sc) } + sc <- case M.lookup m ws2sc of + Nothing -> do + trace "Current workspace isn't visible! This should never happen!" + -- we don't know what screen to use, just use the first one. + return 0 + Just sc -> return sc + modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } hunk ./Main.hs 272 - modify $ \s -> s { workspace = W.delete w (workspace s) } + windows $ W.delete w hunk ./Main.hs 184 - case W.lookup w ws of - Just n -> do setFocus w - windows $ W.view n - Nothing -> do b <- isRoot w - when b setTopFocus + if W.member w ws + then setFocus w + else do b <- isRoot w + when b setTopFocus hunk ./Main.hs 345 + gets wsOnScreen >>= trace . show hunk ./Main.hs 228 - whenJust (listToMaybe $ W.index n ws) $ \w -> withDisplay $ \d -> do + whenJust (W.peekStack n ws) $ \w -> withDisplay $ \d -> do hunk ./StackSet.hs 40 + , focus :: {-# UNPACK #-} !(M.Map Int a) -- ^ the window focused in each stack hunk ./StackSet.hs 59 + , focus = M.empty hunk ./StackSet.hs 102 -peek w = listToMaybe $ index (current w) w +peek w = peekStack (current w) w + +-- | /O(log s)/. Extract the element on the top of the given stack. If no such +-- element exists, Nothing is returned. +peekStack :: Int -> StackSet a -> Maybe a +peekStack n w = M.lookup n (focus w) hunk ./StackSet.hs 128 -rotate :: Ordering -> StackSet a -> StackSet a -rotate o w = w { stacks = M.adjust rot (current w) (stacks w) } - where rot s = take l . drop offset . cycle $ s - where n = fromEnum o - 1 - l = length s - offset = if n < 0 then l + n else n +rotate :: Eq a => Ordering -> StackSet a -> StackSet a +rotate o w = maybe w id $ do + f <- M.lookup (current w) (focus w) + s <- M.lookup (current w) (stacks w) + ea <- case o of + EQ -> Nothing + GT -> elemAfter f s + LT -> elemAfter f (reverse s) + return (w { focus = M.insert (current w) ea (focus w) }) hunk ./StackSet.hs 152 - , stacks = M.adjust (k:) n (stacks new) } + , stacks = M.adjust (k:) n (stacks new) + , focus = M.insert n k (focus new) } hunk ./StackSet.hs 162 - , stacks = M.adjust (L.delete k) i (stacks w) } + , stacks = M.adjust (L.delete k) i (stacks w) + , focus = M.update (\k' -> if k == k' then elemAfter k (stacks w M.! i) else Just k') i (focus w) } + +elemAfter :: Eq a => a -> [a] -> Maybe a +elemAfter w ws = listToMaybe . filter (/= w) . dropWhile (/= w) $ ws ++ ws hunk ./Main.hs 80 - , wsOnScreen = M.fromList $ map ((\n -> (n,n)) . fromIntegral . xsi_screen_number) xinesc + , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0..((length xinesc)-1)] hunk ./Main.hs 230 - io $ do moveResizeWindow d w (fromIntegral $ xsi_x_org sc) - (fromIntegral $ xsi_y_org sc) - (fromIntegral $ xsi_width sc) - (fromIntegral $ xsi_height sc) -- fullscreen + io $ do moveResizeWindow d w (rect_x sc) + (rect_y sc) + (rect_width sc) + (rect_height sc) hunk ./XMonad.hs 31 -import Graphics.X11.Xinerama - hunk ./XMonad.hs 38 - , xineScreens :: {-# UNPACK #-} ![XineramaScreenInfo] + , xineScreens :: {-# UNPACK #-} ![Rectangle] hunk ./Main.hs 79 - , xineScreens = xinesc - , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0..((length xinesc)-1)] + , xineScreens = xinesc + , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0..((length xinesc)-1)] hunk ./Main.hs 228 - whenJust (W.peekStack n ws) $ \w -> withDisplay $ \d -> do - let sc = xinesc !! scn - io $ do moveResizeWindow d w (rect_x sc) - (rect_y sc) - (rect_width sc) - (rect_height sc) - raiseWindow d w + whenJust (W.peekStack n ws) $ \w -> withDisplay $ \d -> do + let sc = xinesc !! scn + io $ do moveResizeWindow d w (rect_x sc) + (rect_y sc) + (rect_width sc) + (rect_height sc) + raiseWindow d w hunk ./Main.hs 323 - hide w + hide w hunk ./Main.hs 334 - -- is the workspace we want to switch to currently visible? - if M.member n ws2sc - then windows $ W.view n - else do - sc <- case M.lookup m ws2sc of - Nothing -> do - trace "Current workspace isn't visible! This should never happen!" - -- we don't know what screen to use, just use the first one. - return 0 - Just sc -> return sc - modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } - gets wsOnScreen >>= trace . show - windows $ W.view n - mapM_ hide (W.index m ws) - setTopFocus + -- is the workspace we want to switch to currently visible? + if M.member n ws2sc + then windows $ W.view n + else do + sc <- case M.lookup m ws2sc of + Nothing -> do + trace "Current workspace isn't visible! This should never happen!" + -- we don't know what screen to use, just use the first one. + return 0 + Just sc -> return sc + modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } + gets wsOnScreen >>= trace . show + windows $ W.view n + mapM_ hide (W.index m ws) + setTopFocus hunk ./Main.hs 234 - raiseWindow d w + raiseWindow d w hunk ./Main.hs 58 + , ((modMask, xK_space ), switchLayout) hunk ./Main.hs 65 +ratio :: Rational +ratio = 0.5 + hunk ./Main.hs 90 + , layout = Full hunk ./Main.hs 232 - forM_ (M.assocs ws2sc) $ \(n, scn) -> - whenJust (W.peekStack n ws) $ \w -> withDisplay $ \d -> do - let sc = xinesc !! scn - io $ do moveResizeWindow d w (rect_x sc) - (rect_y sc) - (rect_width sc) - (rect_height sc) - raiseWindow d w + d <- gets display + l <- gets layout + let move w a b c e = io $ moveResizeWindow d w a b c e + forM_ (M.assocs ws2sc) $ \(n, scn) -> do + let sc = xinesc !! scn + sx = rect_x sc + sy = rect_y sc + sw = rect_width sc + sh = rect_height sc + case l of + Full -> whenJust (W.peekStack n ws) $ \w -> do + move w sx sy sw sh + io $ raiseWindow d w + Tile -> case W.index n ws of + [] -> return () + [w] -> do move w sx sy sw sh; io $ raiseWindow d w + (w:s) -> do + let lw = floor $ fromIntegral sw * ratio + rw = sw - fromIntegral lw + rh = fromIntegral sh `div` fromIntegral (length s) + move w sx sy (fromIntegral lw) sh + zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) [0..] s + whenJust (W.peek ws) (io . raiseWindow d) -- this is always Just hunk ./Main.hs 257 +-- | switchLayout. Switch to another layout scheme. +switchLayout :: X () +switchLayout = do + modify (\s -> s {layout = case layout s of + Full -> Tile + Tile -> Full }) + refresh + hunk ./TODO 5 + - Code clean up after tiling and StackSet changes + - Make sure the quickchecks make sense with the new StackSet hunk ./TODO 26 - - StackSet currently holds one stack, it needs to hold two. One stack - contains focus info, the top of that stack is always the window that - is in the foreground and has focus. - - The other stack keeps track of window layout order. In tiling mode, - the first window in the stack is in the master area. In both tiling - and full screen mode, window cycling follows the order in this stack. - - - Layout calculation: a simple function from number of windows to list - of coordinates. - - - state components, key combos, etc. for changing the current layout - scheme + - Layout calculation: the current algorithm is crude, windows overlap + - make focus remain between workspace switches + - change focus in the StackSet structure on EnterNotify + - operations to change window order (like dwm's mod+enter) + - add 'ratio' to XState, add bindings to change it on the fly + - borders (low priority, maybe wait until 0.2) hunk ./XMonad.hs 18 - X, WorkSpace, XState(..), runX, - io, withDisplay, isRoot, + X, WorkSpace, XState(..), Layout(..), + runX, io, withDisplay, isRoot, hunk ./XMonad.hs 46 + , layout :: {-# UNPACK #-} !Layout hunk ./XMonad.hs 51 +-- | The different layout modes +data Layout = Full | Tile + hunk ./Main.hs 65 +-- +-- The mask for the numlock key. You may need to change this on some systems. +-- +numlockMask :: KeySym +numlockMask = lockMask + hunk ./Main.hs 139 - mapM_ (grab kc) [mask, mask .|. lockMask] -- note: no numlock + mapM_ (grab kc) [mask, mask .|. numlockMask] -- note: no numlock hunk ./StackSet.hs 164 + +-- | /O(log n)/. If the given window is contained in a workspace, make it the +-- focused window of that workspace. +raiseFocus :: Ord a => a -> StackSet a -> StackSet a +raiseFocus k w = case M.lookup k (cache w) of + Nothing -> w + Just i -> w { focus = M.insert i k (focus w) } hunk ./Main.hs 64 + -- generate keybindings to each screen: + ++ + [((m .|. modMask, key), screenWS sc >>= f) + | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] + , (f, m) <- [(view, 0), (tag, shiftMask)]] + hunk ./Main.hs 395 +-- | screenWS. Returns the workspace currently visible on screen n +screenWS :: Int -> X Int +screenWS n = do + ws2sc <- gets wsOnScreen + -- FIXME: It's ugly to have to query this way. We need a different way to + -- keep track of screen <-> workspace mappings. + let ws = fmap fst $ find (\(_, scn) -> scn == (n-1)) (M.assocs ws2sc) + return $ (fromMaybe 0 ws) + 1 + hunk ./Main.hs 143 - forM_ (M.keys keys) $ \(mask,sym) -> do + flip mapM_ (M.keys keys) $ \(mask,sym) -> do hunk ./Main.hs 247 - forM_ (M.assocs ws2sc) $ \(n, scn) -> do + flip mapM_ (M.assocs ws2sc) $ \(n, scn) -> do hunk ./xmonad.cabal 10 -build-depends: base==2.0, X11>=1.1, X11-extras==0.0, mtl==1.0, unix>=1.0 +build-depends: base>=1.0, X11>=1.1, X11-extras==0.0, mtl==1.0, unix>=1.0 hunk ./Main.hs 18 +import Data.Ratio hunk ./Main.hs 57 + , ((modMask, xK_h ), changeWidth (negate defaultDelta)) + , ((modMask, xK_l ), changeWidth defaultDelta) hunk ./Main.hs 74 +-- How much to change the size of the windows on the left by default +defaultDelta :: Rational +defaultDelta = 3%100 + hunk ./Main.hs 84 -ratio :: Rational -ratio = 0.5 - hunk ./Main.hs 107 + , leftWidth = 3%5 hunk ./Main.hs 251 + ratio <- gets leftWidth hunk ./Main.hs 282 + +-- | changeWidth. Change the width of the main window in tiling mode. +changeWidth :: Rational -> X () +changeWidth delta = do + modify (\s -> s {leftWidth = leftWidth s + delta}) + refresh hunk ./XMonad.hs 47 + -- how much of the screen the main window should take + , leftWidth :: {-# UNPACK #-} !Rational hunk ./Main.hs 74 +-- The default size for the left pane +defaultLeftWidth :: Rational +defaultLeftWidth = 3%5 + hunk ./Main.hs 111 - , leftWidth = 3%5 + , leftWidth = defaultLeftWidth hunk ./Main.hs 76 -defaultLeftWidth = 3%5 +defaultLeftWidth = 1%2 hunk ./StackSet.hs 171 + +-- | Move a window to the top of its workspace. +promote :: Ord a => a -> StackSet a -> StackSet a +promote k w = case M.lookup k (cache w) of + Nothing -> w + Just i -> w { stacks = M.adjust (\ks -> k : filter (/= k) ks) i (stacks w) } hunk ./Main.hs 62 + , ((modMask, xK_Return), promote) hunk ./Main.hs 358 +-- | promote. Make the focused window the master window in its workspace +promote :: X () +promote = windows (\w -> maybe w (\k -> W.promote k w) (W.peek w)) + hunk ./Main.hs 31 +import System.Posix.Process +import System.Environment + hunk ./Main.hs 64 + , ((modMask .|. shiftMask, xK_F12 ), io restart) hunk ./Main.hs 163 +-- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has +-- to be in PATH for this to work. +restart :: IO () +restart = do prog <- getProgName + args <- getArgs + executeFile prog True args Nothing + hunk ./Main.hs 405 - when (n /= m) $ do - -- is the workspace we want to switch to currently visible? - if M.member n ws2sc - then windows $ W.view n - else do - sc <- case M.lookup m ws2sc of - Nothing -> do - trace "Current workspace isn't visible! This should never happen!" - -- we don't know what screen to use, just use the first one. - return 0 - Just sc -> return sc - modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } - gets wsOnScreen >>= trace . show - windows $ W.view n - mapM_ hide (W.index m ws) - setTopFocus + -- is the workspace we want to switch to currently visible? + if M.member n ws2sc + then windows $ W.view n + else do + sc <- case M.lookup m ws2sc of + Nothing -> do + trace "Current workspace isn't visible! This should never happen!" + -- we don't know what screen to use, just use the first one. + return 0 + Just sc -> return sc + modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } + gets wsOnScreen >>= trace . show + windows $ W.view n + mapM_ hide (W.index m ws) + setTopFocus addfile ./Config.lhs hunk ./Config.lhs 1 +> module Config where + +xmonad places each window into a "workspace." Each workspace can have any +number of windows, which you can cycle though with mod-j and mod-k. Windows are +either displayed full screen, or tiled. You can toggle the layout mode with +mod-space. + +You can switch to workspace N with mod-N. For example, to switch to workspace +5, you would press mod-5. Similarly, you can move the current window to another +workspace with mod-shift-N. + +When running with multiple monitors (Xinerama), each screen has exactly 1 +workspace visible. When xmonad starts, workspace 1 is on screen 1, workspace 2 +is on screen 2, etc. If you switch to a workspace which is currently visible on +another screen, xmonad simply switches focus to that screen. If you switch to a +workspace which is *not* visible, xmonad replaces the workspace on the +*current* screen with the workspace you selected. + +For example, if you have the following configuration: + +Screen 1: Workspace 2 +Screen 2: Workspace 5 (current workspace) + +and you wanted to view workspace 7 on screen 1, you would press: + +mod-2 (to select workspace 2, and make screen 1 the current screen) +mod-7 (to select workspace 7) + +Since switching to the workspace currently visible on a given screen is such a +common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace +currently visible on screens 1, 2, and 3 respectively. Likewise, +shift-mod-{w,e,r} moves the current window to the workspace on that screen. +Using these keys, the above example would become mod-w mod-7. + +Some imports we need: + +> import Data.Ratio +> import Data.Bits +> import qualified Data.Map as M +> import System.Exit +> import Graphics.X11.Xlib +> import XMonad +> import Operations + +The number of workspaces: + +> workspaces :: Int +> workspaces = 9 + +modMask lets you easily change which modkey you use. The default is mod1Mask. +("alt") + +> modMask :: KeyMask +> modMask = mod1Mask + +The default size for the left pane. + +> defaultLeftWidth :: Rational +> defaultLeftWidth = 1%2 + +How much to change the size of the windows on the left by default. + +> defaultDelta :: Rational +> defaultDelta = 3%100 + +The mask for the numlock key. You may need to change this on some systems. + +> numlockMask :: KeySym +> numlockMask = lockMask + +The keys list. + +> keys :: M.Map (KeyMask, KeySym) (X ()) +> keys = M.fromList $ +> [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") +> , ((modMask, xK_p ), spawn "exe=`emenu_path | dmenu` && exec $exe") +> , ((controlMask, xK_space ), spawn "gmrun") +> , ((modMask, xK_Tab ), raise GT) +> , ((modMask, xK_j ), raise GT) +> , ((modMask, xK_k ), raise LT) +> , ((modMask, xK_h ), changeWidth (negate defaultDelta)) +> , ((modMask, xK_l ), changeWidth defaultDelta) +> , ((modMask .|. shiftMask, xK_c ), kill) +> , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) +> , ((modMask .|. shiftMask, xK_F12 ), io restart) +> , ((modMask, xK_space ), switchLayout) +> , ((modMask, xK_Return), promote) +> ] ++ + +Keybindings to each workspace: + +> [((m .|. modMask, xK_0 + fromIntegral i), f i) +> | i <- [1 .. workspaces] +> , (f, m) <- [(view, 0), (tag, shiftMask)]] + +Keybindings to each screen: + +> ++ +> [((m .|. modMask, key), screenWS sc >>= f) +> | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] +> , (f, m) <- [(view, 0), (tag, shiftMask)]] hunk ./Main.hs 16 -import Data.List -import Data.Maybe -import Data.Ratio -import Data.Bits hiding (rotate) +import Data.Bits hunk ./Main.hs 19 -import System.IO -import System.Exit - hunk ./Main.hs 25 -import System.Posix.Process -import System.Environment - -import XMonad hunk ./Main.hs 27 --- --- The number of workspaces: --- -workspaces :: Int -workspaces = 9 - --- --- modMask lets you easily change which modkey you use. --- -modMask :: KeyMask -modMask = mod1Mask - --- --- The keys list --- -keys :: M.Map (KeyMask, KeySym) (X ()) -keys = M.fromList $ - [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") - , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") - , ((controlMask, xK_space ), spawn "gmrun") - , ((modMask, xK_Tab ), raise GT) - , ((modMask, xK_j ), raise GT) - , ((modMask, xK_k ), raise LT) - , ((modMask, xK_h ), changeWidth (negate defaultDelta)) - , ((modMask, xK_l ), changeWidth defaultDelta) - , ((modMask .|. shiftMask, xK_c ), kill) - , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) - , ((modMask .|. shiftMask, xK_F12 ), io restart) - , ((modMask, xK_space ), switchLayout) - , ((modMask, xK_Return), promote) - ] ++ - -- generate keybindings to each workspace: - [((m .|. modMask, xK_0 + fromIntegral i), f i) - | i <- [1 .. workspaces] - , (f, m) <- [(view, 0), (tag, shiftMask)]] - -- generate keybindings to each screen: - ++ - [((m .|. modMask, key), screenWS sc >>= f) - | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] - , (f, m) <- [(view, 0), (tag, shiftMask)]] - - --- The default size for the left pane -defaultLeftWidth :: Rational -defaultLeftWidth = 1%2 - --- How much to change the size of the windows on the left by default -defaultDelta :: Rational -defaultDelta = 3%100 - --- --- The mask for the numlock key. You may need to change this on some systems. --- -numlockMask :: KeySym -numlockMask = lockMask +import XMonad +import Operations +import Config hunk ./Main.hs 101 --- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has --- to be in PATH for this to work. -restart :: IO () -restart = do prog <- getProgName - args <- getArgs - executeFile prog True args Nothing - hunk ./Main.hs 186 --- --------------------------------------------------------------------- --- Managing windows - --- | refresh. Refresh the currently focused window. Resizes to full --- screen and raises the window. -refresh :: X () -refresh = do - ws <- gets workspace - ws2sc <- gets wsOnScreen - xinesc <- gets xineScreens - d <- gets display - l <- gets layout - ratio <- gets leftWidth - let move w a b c e = io $ moveResizeWindow d w a b c e - flip mapM_ (M.assocs ws2sc) $ \(n, scn) -> do - let sc = xinesc !! scn - sx = rect_x sc - sy = rect_y sc - sw = rect_width sc - sh = rect_height sc - case l of - Full -> whenJust (W.peekStack n ws) $ \w -> do - move w sx sy sw sh - io $ raiseWindow d w - Tile -> case W.index n ws of - [] -> return () - [w] -> do move w sx sy sw sh; io $ raiseWindow d w - (w:s) -> do - let lw = floor $ fromIntegral sw * ratio - rw = sw - fromIntegral lw - rh = fromIntegral sh `div` fromIntegral (length s) - move w sx sy (fromIntegral lw) sh - zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) [0..] s - whenJust (W.peek ws) (io . raiseWindow d) -- this is always Just - whenJust (W.peek ws) setFocus - --- | switchLayout. Switch to another layout scheme. -switchLayout :: X () -switchLayout = do - modify (\s -> s {layout = case layout s of - Full -> Tile - Tile -> Full }) - refresh - --- | changeWidth. Change the width of the main window in tiling mode. -changeWidth :: Rational -> X () -changeWidth delta = do - modify (\s -> s {leftWidth = leftWidth s + delta}) - refresh - --- | windows. Modify the current window list with a pure function, and refresh -windows :: (WorkSpace -> WorkSpace) -> X () -windows f = do - modify $ \s -> s { workspace = f (workspace s) } - refresh - ws <- gets workspace - trace (show ws) -- log state changes to stderr - --- | hide. Hide a window by moving it offscreen. -hide :: Window -> X () -hide w = withDisplay $ \d -> do - (sw,sh) <- gets dimensions - io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) - --- --------------------------------------------------------------------- --- Window operations - --- | manage. Add a new window to be managed in the current workspace. Bring it into focus. --- If the window is already under management, it is just raised. --- --- When we start to manage a window, it gains focus. --- -manage :: Window -> X () -manage w = do - withDisplay $ \d -> io $ do - selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask - mapWindow d w - setFocus w - windows $ W.push w - --- | unmanage. A window no longer exists, remove it from the window --- list, on whatever workspace it is. -unmanage :: Window -> X () -unmanage w = do - windows $ W.delete w - withServerX $ do - setTopFocus - withDisplay $ \d -> io (sync d False) - -- TODO, everything operates on the current display, so wrap it up. - --- | Grab the X server (lock it) from the X monad -withServerX :: X () -> X () -withServerX f = withDisplay $ \dpy -> do - io $ grabServer dpy - f - io $ ungrabServer dpy - --- | Explicitly set the keyboard focus to the given window -setFocus :: Window -> X () -setFocus w = withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 - --- | Set the focus to the window on top of the stack, or root -setTopFocus :: X () -setTopFocus = do - ws <- gets workspace - case W.peek ws of - Just new -> setFocus new - Nothing -> gets theRoot >>= setFocus - --- | raise. focus to window at offset 'n' in list. --- The currently focused window is always the head of the list -raise :: Ordering -> X () -raise = windows . W.rotate - --- | promote. Make the focused window the master window in its workspace -promote :: X () -promote = windows (\w -> maybe w (\k -> W.promote k w) (W.peek w)) - --- | Kill the currently focused client -kill :: X () -kill = withDisplay $ \d -> do - ws <- gets workspace - whenJust (W.peek ws) $ \w -> do - protocols <- io $ getWMProtocols d w - wmdelt <- gets wmdelete - wmprot <- gets wmprotocols - if wmdelt `elem` protocols - then io $ allocaXEvent $ \ev -> do - setEventType ev clientMessage - setClientMessageEvent ev w wmprot 32 wmdelt 0 - sendEvent d w False noEventMask ev - else io (killClient d w) >> return () - --- | tag. Move a window to a new workspace -tag :: Int -> X () -tag o = do - ws <- gets workspace - let m = W.current ws - when (n /= m) $ - whenJust (W.peek ws) $ \w -> do - hide w - windows $ W.shift n - where n = o-1 - --- | view. Change the current workspace to workspce at offset 'n-1'. -view :: Int -> X () -view o = do - ws <- gets workspace - ws2sc <- gets wsOnScreen - let m = W.current ws - -- is the workspace we want to switch to currently visible? - if M.member n ws2sc - then windows $ W.view n - else do - sc <- case M.lookup m ws2sc of - Nothing -> do - trace "Current workspace isn't visible! This should never happen!" - -- we don't know what screen to use, just use the first one. - return 0 - Just sc -> return sc - modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } - gets wsOnScreen >>= trace . show - windows $ W.view n - mapM_ hide (W.index m ws) - setTopFocus - where n = o-1 - --- | True if window is under management by us -isClient :: Window -> X Bool -isClient w = liftM (W.member w) (gets workspace) - --- | screenWS. Returns the workspace currently visible on screen n -screenWS :: Int -> X Int -screenWS n = do - ws2sc <- gets wsOnScreen - -- FIXME: It's ugly to have to query this way. We need a different way to - -- keep track of screen <-> workspace mappings. - let ws = fmap fst $ find (\(_, scn) -> scn == (n-1)) (M.assocs ws2sc) - return $ (fromMaybe 0 ws) + 1 addfile ./Operations.hs hunk ./Operations.hs 1 +module Operations where + +import Data.List +import Data.Maybe +import Data.Bits +import qualified Data.Map as M + +import Control.Monad.State + +import System.Posix.Process +import System.Environment + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad + +import qualified StackSet as W + +-- --------------------------------------------------------------------- +-- Managing windows + +-- | refresh. Refresh the currently focused window. Resizes to full +-- screen and raises the window. +refresh :: X () +refresh = do + ws <- gets workspace + ws2sc <- gets wsOnScreen + xinesc <- gets xineScreens + d <- gets display + l <- gets layout + ratio <- gets leftWidth + let move w a b c e = io $ moveResizeWindow d w a b c e + flip mapM_ (M.assocs ws2sc) $ \(n, scn) -> do + let sc = xinesc !! scn + sx = rect_x sc + sy = rect_y sc + sw = rect_width sc + sh = rect_height sc + case l of + Full -> whenJust (W.peekStack n ws) $ \w -> do + move w sx sy sw sh + io $ raiseWindow d w + Tile -> case W.index n ws of + [] -> return () + [w] -> do move w sx sy sw sh; io $ raiseWindow d w + (w:s) -> do + let lw = floor $ fromIntegral sw * ratio + rw = sw - fromIntegral lw + rh = fromIntegral sh `div` fromIntegral (length s) + move w sx sy (fromIntegral lw) sh + zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) [0..] s + whenJust (W.peek ws) (io . raiseWindow d) -- this is always Just + whenJust (W.peek ws) setFocus + +-- | switchLayout. Switch to another layout scheme. +switchLayout :: X () +switchLayout = do + modify (\s -> s {layout = case layout s of + Full -> Tile + Tile -> Full }) + refresh + +-- | changeWidth. Change the width of the main window in tiling mode. +changeWidth :: Rational -> X () +changeWidth delta = do + modify (\s -> s {leftWidth = leftWidth s + delta}) + refresh + +-- | windows. Modify the current window list with a pure function, and refresh +windows :: (WorkSpace -> WorkSpace) -> X () +windows f = do + modify $ \s -> s { workspace = f (workspace s) } + refresh + ws <- gets workspace + trace (show ws) -- log state changes to stderr + +-- | hide. Hide a window by moving it offscreen. +hide :: Window -> X () +hide w = withDisplay $ \d -> do + (sw,sh) <- gets dimensions + io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) + +-- --------------------------------------------------------------------- +-- Window operations + +-- | manage. Add a new window to be managed in the current workspace. Bring it into focus. +-- If the window is already under management, it is just raised. +-- +-- When we start to manage a window, it gains focus. +-- +manage :: Window -> X () +manage w = do + withDisplay $ \d -> io $ do + selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + mapWindow d w + setFocus w + windows $ W.push w + +-- | unmanage. A window no longer exists, remove it from the window +-- list, on whatever workspace it is. +unmanage :: Window -> X () +unmanage w = do + windows $ W.delete w + withServerX $ do + setTopFocus + withDisplay $ \d -> io (sync d False) + -- TODO, everything operates on the current display, so wrap it up. + +-- | Grab the X server (lock it) from the X monad +withServerX :: X () -> X () +withServerX f = withDisplay $ \dpy -> do + io $ grabServer dpy + f + io $ ungrabServer dpy + +-- | Explicitly set the keyboard focus to the given window +setFocus :: Window -> X () +setFocus w = withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 + +-- | Set the focus to the window on top of the stack, or root +setTopFocus :: X () +setTopFocus = do + ws <- gets workspace + case W.peek ws of + Just new -> setFocus new + Nothing -> gets theRoot >>= setFocus + +-- | raise. focus to window at offset 'n' in list. +-- The currently focused window is always the head of the list +raise :: Ordering -> X () +raise = windows . W.rotate + +-- | promote. Make the focused window the master window in its workspace +promote :: X () +promote = windows (\w -> maybe w (\k -> W.promote k w) (W.peek w)) + +-- | Kill the currently focused client +kill :: X () +kill = withDisplay $ \d -> do + ws <- gets workspace + whenJust (W.peek ws) $ \w -> do + protocols <- io $ getWMProtocols d w + wmdelt <- gets wmdelete + wmprot <- gets wmprotocols + if wmdelt `elem` protocols + then io $ allocaXEvent $ \ev -> do + setEventType ev clientMessage + setClientMessageEvent ev w wmprot 32 wmdelt 0 + sendEvent d w False noEventMask ev + else io (killClient d w) >> return () + +-- | tag. Move a window to a new workspace +tag :: Int -> X () +tag o = do + ws <- gets workspace + let m = W.current ws + when (n /= m) $ + whenJust (W.peek ws) $ \w -> do + hide w + windows $ W.shift n + where n = o-1 + +-- | view. Change the current workspace to workspce at offset 'n-1'. +view :: Int -> X () +view o = do + ws <- gets workspace + ws2sc <- gets wsOnScreen + let m = W.current ws + -- is the workspace we want to switch to currently visible? + if M.member n ws2sc + then windows $ W.view n + else do + sc <- case M.lookup m ws2sc of + Nothing -> do + trace "Current workspace isn't visible! This should never happen!" + -- we don't know what screen to use, just use the first one. + return 0 + Just sc -> return sc + modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } + gets wsOnScreen >>= trace . show + windows $ W.view n + mapM_ hide (W.index m ws) + setTopFocus + where n = o-1 + +-- | True if window is under management by us +isClient :: Window -> X Bool +isClient w = liftM (W.member w) (gets workspace) + +-- | screenWS. Returns the workspace currently visible on screen n +screenWS :: Int -> X Int +screenWS n = do + ws2sc <- gets wsOnScreen + -- FIXME: It's ugly to have to query this way. We need a different way to + -- keep track of screen <-> workspace mappings. + let ws = fmap fst $ find (\(_, scn) -> scn == (n-1)) (M.assocs ws2sc) + return $ (fromMaybe 0 ws) + 1 + +-- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has +-- to be in PATH for this to work. +restart :: IO () +restart = do prog <- getProgName + args <- getArgs + executeFile prog True args Nothing move ./Config.lhs ./Config.hs hunk ./Config.hs 1 -> module Config where +module Config where hunk ./Config.hs 3 -xmonad places each window into a "workspace." Each workspace can have any -number of windows, which you can cycle though with mod-j and mod-k. Windows are -either displayed full screen, or tiled. You can toggle the layout mode with -mod-space. +-- xmonad places each window into a "workspace." Each workspace can have any +-- number of windows, which you can cycle though with mod-j and mod-k. Windows are +-- either displayed full screen, or tiled. You can toggle the layout mode with +-- mod-space. +-- +-- You can switch to workspace N with mod-N. For example, to switch to workspace +-- 5, you would press mod-5. Similarly, you can move the current window to another +-- workspace with mod-shift-N. +-- +-- When running with multiple monitors (Xinerama), each screen has exactly 1 +-- workspace visible. When xmonad starts, workspace 1 is on screen 1, workspace 2 +-- is on screen 2, etc. If you switch to a workspace which is currently visible on +-- another screen, xmonad simply switches focus to that screen. If you switch to a +-- workspace which is *not* visible, xmonad replaces the workspace on the +-- *current* screen with the workspace you selected. +-- +-- For example, if you have the following configuration: +-- +-- Screen 1: Workspace 2 +-- Screen 2: Workspace 5 (current workspace) +-- +-- and you wanted to view workspace 7 on screen 1, you would press: +-- +-- mod-2 (to select workspace 2, and make screen 1 the current screen) +-- mod-7 (to select workspace 7) +-- +-- Since switching to the workspace currently visible on a given screen is such a +-- common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace +-- currently visible on screens 1, 2, and 3 respectively. Likewise, +-- shift-mod-{w,e,r} moves the current window to the workspace on that screen. +-- Using these keys, the above example would become mod-w mod-7. hunk ./Config.hs 35 -You can switch to workspace N with mod-N. For example, to switch to workspace -5, you would press mod-5. Similarly, you can move the current window to another -workspace with mod-shift-N. +import Data.Ratio +import Data.Bits +import qualified Data.Map as M +import System.Exit +import Graphics.X11.Xlib +import XMonad +import Operations hunk ./Config.hs 43 -When running with multiple monitors (Xinerama), each screen has exactly 1 -workspace visible. When xmonad starts, workspace 1 is on screen 1, workspace 2 -is on screen 2, etc. If you switch to a workspace which is currently visible on -another screen, xmonad simply switches focus to that screen. If you switch to a -workspace which is *not* visible, xmonad replaces the workspace on the -*current* screen with the workspace you selected. +-- The number of workspaces: +workspaces :: Int +workspaces = 9 hunk ./Config.hs 47 -For example, if you have the following configuration: +-- modMask lets you easily change which modkey you use. The default is mod1Mask. +-- ("alt") +modMask :: KeyMask +modMask = mod1Mask hunk ./Config.hs 52 -Screen 1: Workspace 2 -Screen 2: Workspace 5 (current workspace) +-- The default size for the left pane. +defaultLeftWidth :: Rational +defaultLeftWidth = 1%2 hunk ./Config.hs 56 -and you wanted to view workspace 7 on screen 1, you would press: +-- How much to change the size of the windows on the left by default. +defaultDelta :: Rational +defaultDelta = 3%100 hunk ./Config.hs 60 -mod-2 (to select workspace 2, and make screen 1 the current screen) -mod-7 (to select workspace 7) +-- The mask for the numlock key. You may need to change this on some systems. +numlockMask :: KeySym +numlockMask = lockMask hunk ./Config.hs 64 -Since switching to the workspace currently visible on a given screen is such a -common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace -currently visible on screens 1, 2, and 3 respectively. Likewise, -shift-mod-{w,e,r} moves the current window to the workspace on that screen. -Using these keys, the above example would become mod-w mod-7. - -Some imports we need: - -> import Data.Ratio -> import Data.Bits -> import qualified Data.Map as M -> import System.Exit -> import Graphics.X11.Xlib -> import XMonad -> import Operations - -The number of workspaces: - -> workspaces :: Int -> workspaces = 9 - -modMask lets you easily change which modkey you use. The default is mod1Mask. -("alt") - -> modMask :: KeyMask -> modMask = mod1Mask - -The default size for the left pane. - -> defaultLeftWidth :: Rational -> defaultLeftWidth = 1%2 - -How much to change the size of the windows on the left by default. - -> defaultDelta :: Rational -> defaultDelta = 3%100 - -The mask for the numlock key. You may need to change this on some systems. - -> numlockMask :: KeySym -> numlockMask = lockMask - -The keys list. - -> keys :: M.Map (KeyMask, KeySym) (X ()) -> keys = M.fromList $ -> [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -> , ((modMask, xK_p ), spawn "exe=`emenu_path | dmenu` && exec $exe") -> , ((controlMask, xK_space ), spawn "gmrun") -> , ((modMask, xK_Tab ), raise GT) -> , ((modMask, xK_j ), raise GT) -> , ((modMask, xK_k ), raise LT) -> , ((modMask, xK_h ), changeWidth (negate defaultDelta)) -> , ((modMask, xK_l ), changeWidth defaultDelta) -> , ((modMask .|. shiftMask, xK_c ), kill) -> , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) -> , ((modMask .|. shiftMask, xK_F12 ), io restart) -> , ((modMask, xK_space ), switchLayout) -> , ((modMask, xK_Return), promote) -> ] ++ - -Keybindings to each workspace: - -> [((m .|. modMask, xK_0 + fromIntegral i), f i) -> | i <- [1 .. workspaces] -> , (f, m) <- [(view, 0), (tag, shiftMask)]] - -Keybindings to each screen: - -> ++ -> [((m .|. modMask, key), screenWS sc >>= f) -> | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] -> , (f, m) <- [(view, 0), (tag, shiftMask)]] +-- The keys list. +keys :: M.Map (KeyMask, KeySym) (X ()) +keys = M.fromList $ + [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") + , ((modMask, xK_p ), spawn "exe=`emenu_path | dmenu` && exec $exe") + , ((controlMask, xK_space ), spawn "gmrun") + , ((modMask, xK_Tab ), raise GT) + , ((modMask, xK_j ), raise GT) + , ((modMask, xK_k ), raise LT) + , ((modMask, xK_h ), changeWidth (negate defaultDelta)) + , ((modMask, xK_l ), changeWidth defaultDelta) + , ((modMask .|. shiftMask, xK_c ), kill) + , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) + , ((modMask .|. shiftMask, xK_F12 ), io restart) + , ((modMask, xK_space ), switchLayout) + , ((modMask, xK_Return), promote) + ] ++ + -- Keybindings to each workspace: + [((m .|. modMask, xK_0 + fromIntegral i), f i) + | i <- [1 .. workspaces] + , (f, m) <- [(view, 0), (tag, shiftMask)]] + -- Keybindings to each screen: + ++ + [((m .|. modMask, key), screenWS sc >>= f) + | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] + , (f, m) <- [(view, 0), (tag, shiftMask)]] hunk ./Operations.hs 67 - modify (\s -> s {leftWidth = leftWidth s + delta}) + -- the min/max stuff is to make sure that 0 <= leftWidth <= 1 + modify (\s -> s {leftWidth = min 1 $ max 0 $ leftWidth s + delta}) hunk ./README 24 -Use: +And then build with Cabal: hunk ./README 26 - add: + runhaskell Setup.lhs configure --prefix=/home/dons + runhaskell Setup.lhs build + runhaskell Setup.lhs install + +Then add: hunk ./README 34 - as the last line of your .xsession file + to the last line of your .xsession file hunk ./TODO 33 +* Don't resize past end of screen +* Tile vertically/ resize height. + hunk ./Main.hs 186 - hunk ./Operations.hs 27 - ws <- gets workspace - ws2sc <- gets wsOnScreen + ws <- gets workspace + ws2sc <- gets wsOnScreen hunk ./Operations.hs 30 - d <- gets display - l <- gets layout - ratio <- gets leftWidth + d <- gets display + l <- gets layout + ratio <- gets leftWidth hunk ./Operations.hs 168 - ws <- gets workspace + ws <- gets workspace hunk ./TODO 29 - - operations to change window order (like dwm's mod+enter) - - add 'ratio' to XState, add bindings to change it on the fly + - let mod+enter demote a master window hunk ./TODO 31 + - get this to play nicely with Xinerama (at least under TwinView, things + are very strange) + - let click events/scrollwheel events change the focus hunk ./Config.hs 64 +-- What layout to start in. See the definition of Layout in XMonad.hs for options. +defaultLayout :: Layout +defaultLayout = Full + hunk ./Main.hs 53 - , layout = Full + , layout = defaultLayout hunk ./TODO 35 -* Don't resize past end of screen hunk ./Operations.hs 120 -setFocus w = withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 +setFocus w = do + withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 + -- This does not use 'windows' intentionally. 'windows' calls refresh, + -- which means infinite loops. + modify (\s -> s { workspace = W.raiseFocus w (workspace s) }) hunk ./Config.hs 72 - , ((modMask, xK_p ), spawn "exe=`emenu_path | dmenu` && exec $exe") + , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") hunk ./Config.hs 52 --- The default size for the left pane. -defaultLeftWidth :: Rational -defaultLeftWidth = 1%2 - hunk ./Config.hs 60 --- What layout to start in. See the definition of Layout in XMonad.hs for options. -defaultLayout :: Layout -defaultLayout = Full + + +-- What layout to start in, and what the default proportion for the +-- left pane should be in the tiled layout. See LayoutDesc and +-- friends in XMonad.hs for options. +startingLayoutDesc :: LayoutDesc +startingLayoutDesc = LayoutDesc { layoutType = Full + , tileFraction = 1%2 + } + + hunk ./Config.hs 77 - , ((controlMask, xK_space ), spawn "gmrun") +-- Stealing Ctrl + Space is evil. +-- , ((controlMask, xK_space ), spawn "gmrun") hunk ./Main.hs 44 - { display = dpy - , screen = dflt - , xineScreens = xinesc - , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0..((length xinesc)-1)] - , theRoot = rootw - , wmdelete = wmdelt - , wmprotocols = wmprot - , dimensions = (displayWidth dpy dflt, displayHeight dpy dflt) - , workspace = W.empty workspaces - , layout = defaultLayout - , leftWidth = defaultLeftWidth + { display = dpy + , screen = dflt + , xineScreens = xinesc + , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0..((length xinesc)-1)] + , theRoot = rootw + , wmdelete = wmdelt + , wmprotocols = wmprot + , dimensions = (displayWidth dpy dflt, displayHeight dpy dflt) + , workspace = W.empty workspaces + , defaultLayoutDesc = startingLayoutDesc + , layoutDescs = M.empty hunk ./Operations.hs 20 + hunk ./Operations.hs 32 - l <- gets layout - ratio <- gets leftWidth + fls <- gets layoutDescs + dfltfl <- gets defaultLayoutDesc + -- l <- gets layout + -- ratio <- gets leftWidth hunk ./Operations.hs 43 + fl = M.findWithDefault dfltfl n fls + l = layoutType fl + ratio = tileFraction fl hunk ./Operations.hs 62 --- | switchLayout. Switch to another layout scheme. +-- | switchLayout. Switch to another layout scheme. Switches the current workspace. hunk ./Operations.hs 64 -switchLayout = do - modify (\s -> s {layout = case layout s of - Full -> Tile - Tile -> Full }) - refresh +switchLayout = layout $ \fl -> fl { layoutType = case layoutType fl of + Full -> Tile + Tile -> Full } hunk ./Operations.hs 71 - -- the min/max stuff is to make sure that 0 <= leftWidth <= 1 - modify (\s -> s {leftWidth = min 1 $ max 0 $ leftWidth s + delta}) - refresh + layout $ \fl -> fl { tileFraction = min 1 $ max 0 $ tileFraction fl + delta } + +-- | layout. Modify the current workspace's layout with a pure function and refresh. +layout :: (LayoutDesc -> LayoutDesc) -> X () +layout f = do modify $ \s -> let fls = layoutDescs s + n = W.current . workspace $ s + fl = M.findWithDefault (defaultLayoutDesc s) n fls + in s { layoutDescs = M.insert n (f fl) fls } + refresh + hunk ./Operations.hs 223 + + hunk ./XMonad.hs 18 - X, WorkSpace, XState(..), Layout(..), + X, WorkSpace, XState(..), Layout(..), LayoutDesc(..), hunk ./XMonad.hs 46 - , layout :: {-# UNPACK #-} !Layout + , defaultLayoutDesc :: {-# UNPACK #-} !LayoutDesc + , layoutDescs :: {-# UNPACK #-} !(M.Map Int LayoutDesc) + -- ^ mapping of workspaces to descriptions of their layouts + + -- , layout :: {-# UNPACK #-} !Layout hunk ./XMonad.hs 52 - , leftWidth :: {-# UNPACK #-} !Rational + -- , leftWidth :: {-# UNPACK #-} !Rational hunk ./XMonad.hs 60 +-- | A full description of a particular workspace's layout parameters. +data LayoutDesc = LayoutDesc { layoutType :: !Layout + , tileFraction :: !Rational + } + + + + hunk ./Config.hs 77 --- Stealing Ctrl + Space is evil. --- , ((controlMask, xK_space ), spawn "gmrun") + , ((controlMask, xK_space ), spawn "gmrun") hunk ./TODO 3 - - Refactor to make user configuration reasonable. There should be one - file (Config.hs) with all the knobs a user can twist. hunk ./Config.hs 60 - - hunk ./Config.hs 68 - - hunk ./TODO 2 - - tiling hunk ./Main.hs 145 - let m = (request e, first_keycode e, count e) + -- this fromIntegral is only necessary with the old X11 version that uses + -- Int instead of CInt. TODO delete it when there is a new release of X11 + let m = (request e, first_keycode e, fromIntegral $ count e) hunk ./Main.hs 181 - , wcStackMode = detail e + -- this fromIntegral is only necessary with the old X11 version that uses + -- Int instead of CInt. TODO delete it when there is a new release of X11 + , wcStackMode = fromIntegral $ detail e hunk ./tests/Properties.hs 13 +import Data.Map (keys,elems) hunk ./tests/Properties.hs 84 +prop_fullcache x = cached == allvals where + cached = sort . keys $ cache x + allvals = sort . concat . elems $ stacks x + _ = x :: T + hunk ./tests/Properties.hs 112 + ,("fullcache ", mytest prop_fullcache) hunk ./Main.hs 123 + +safeFocus :: Window -> X () +safeFocus w = do ws <- gets workspace + if W.member w ws + then setFocus w + else do b <- isRoot w + when b setTopFocus + hunk ./Main.hs 159 +-- click on an unfocussed window +handle (ButtonEvent {window = w, event_type = t}) + | t == buttonPress + = safeFocus w + hunk ./Main.hs 167 - = do ws <- gets workspace - if W.member w ws - then setFocus w - else do b <- isRoot w - when b setTopFocus + = safeFocus w hunk ./Operations.hs 34 - -- l <- gets layout - -- ratio <- gets leftWidth hunk ./Operations.hs 44 + mapM_ (setButtonGrab True) (W.index n ws) + when (n == W.current ws) $ + maybe (return ()) (setButtonGrab False) (W.peekStack n ws) hunk ./Operations.hs 100 +-- | setButtonGrab. Tell whether or not to intercept clicks on a given window +buttonsToGrab :: [ButtonMask] +buttonsToGrab = [button1, button2, button3] + +setButtonGrab :: Bool -> Window -> X () +setButtonGrab True w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab (\b -> + grabButton d b anyModifier w False + (buttonPressMask .|. buttonReleaseMask) + grabModeAsync grabModeSync none none) +setButtonGrab False w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab (\b -> + ungrabButton d b anyModifier w) + hunk ./Operations.hs 236 - - hunk ./TODO 28 - - get this to play nicely with Xinerama (at least under TwinView, things - are very strange) - - let click events/scrollwheel events change the focus + - let focus-follows-mouse also change the active workspace (not just the + active window); note that this currently also makes click-to-focus appear + slightly buggy, since sometimes, the wrong window is exempted from setButtonGrab hunk ./XMonad.hs 49 - - -- , layout :: {-# UNPACK #-} !Layout - -- how much of the screen the main window should take - -- , leftWidth :: {-# UNPACK #-} !Rational hunk ./StackSet.hs 166 --- focused window of that workspace. +-- focused window of that workspace, and make that workspace the current one. hunk ./StackSet.hs 170 - Just i -> w { focus = M.insert i k (focus w) } + Just i -> w { focus = M.insert i k (focus w), current = i } hunk ./TODO 28 - - let focus-follows-mouse also change the active workspace (not just the - active window); note that this currently also makes click-to-focus appear - slightly buggy, since sometimes, the wrong window is exempted from setButtonGrab hunk ./Main.hs 19 -import Graphics.X11.Xlib +import Graphics.X11.Xlib hiding (refreshKeyboardMapping) hunk ./Main.hs 156 - io $ refreshKeyboardMapping m + withDisplay $ \d -> io $ refreshKeyboardMapping d m hunk ./Operations.hs 101 -buttonsToGrab :: [ButtonMask] +buttonsToGrab :: [Button] hunk ./README 17 + (Unfortunately X11-1.2 does not work correctly on AMD64. The latest + darcs version from http://darcs.haskell.org/packages/X11 does.) + hunk ./Operations.hs 145 + -- Remove the border for the window no longer in focus. + ws <- gets workspace + whenJust (W.peek ws) (\oldw -> setBorder oldw 0xdddddd) + -- Set focus to the given window. hunk ./Operations.hs 153 + -- Set new border for raised window. + setBorder w 0xff0000 hunk ./Operations.hs 164 +-- | Set the border color for a particular window. +setBorder :: Window -> Pixel -> X () +setBorder w p = withDisplay $ \d -> io $ setWindowBorder d w p + hunk ./TODO 27 - - borders (low priority, maybe wait until 0.2) hunk ./Main.hs 130 + refocus hunk ./Operations.hs 44 - mapM_ (setButtonGrab True) (W.index n ws) - when (n == W.current ws) $ - maybe (return ()) (setButtonGrab False) (W.peekStack n ws) hunk ./Operations.hs 59 + refocus + +refocus :: X () +refocus = do + ws2sc <- gets wsOnScreen + ws <- gets workspace + flip mapM_ (M.keys ws2sc) $ \n -> do + mapM_ (setButtonGrab True) (W.index n ws) + when (n == W.current ws) $ + maybe (return ()) (setButtonGrab False) (W.peekStack n ws) hunk ./Main.hs 130 - refocus hunk ./Operations.hs 59 - refocus - -refocus :: X () -refocus = do - ws2sc <- gets wsOnScreen - ws <- gets workspace - flip mapM_ (M.keys ws2sc) $ \n -> do - mapM_ (setButtonGrab True) (W.index n ws) - when (n == W.current ws) $ - maybe (return ()) (setButtonGrab False) (W.peekStack n ws) hunk ./Operations.hs 142 - -- Remove the border for the window no longer in focus. hunk ./Operations.hs 143 - whenJust (W.peek ws) (\oldw -> setBorder oldw 0xdddddd) - -- Set focus to the given window. + ws2sc <- gets wsOnScreen + -- clear mouse button grab and border on other windows + flip mapM_ (M.keys ws2sc) $ \n -> do + flip mapM_ (W.index n ws) $ \otherw -> do + setButtonGrab True otherw + setBorder otherw 0xdddddd + hunk ./Operations.hs 151 + setButtonGrab False w + setBorder w 0xff0000 hunk ./Operations.hs 156 - -- Set new border for raised window. - setBorder w 0xff0000 hunk ./Main.hs 123 - -safeFocus :: Window -> X () -safeFocus w = do ws <- gets workspace - if W.member w ws - then setFocus w - else do b <- isRoot w - when b setTopFocus hunk ./Operations.hs 138 + +safeFocus :: Window -> X () +safeFocus w = do ws <- gets workspace + if W.member w ws + then setFocus w + else do b <- isRoot w + when b setTopFocus hunk ./Operations.hs 45 - Full -> whenJust (W.peekStack n ws) $ \w -> do - move w sx sy sw sh - io $ raiseWindow d w + Full -> whenJust (W.peekStack n ws) $ \w -> + do move w sx sy sw sh; io $ raiseWindow d w hunk ./Operations.hs 55 - zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) [0..] s + zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) + [0..] s hunk ./Operations.hs 62 -switchLayout = layout $ \fl -> fl { layoutType = case layoutType fl of - Full -> Tile - Tile -> Full } +switchLayout = layout $ \fl -> fl { layoutType = swap (layoutType fl) } hunk ./Operations.hs 66 -changeWidth delta = do - layout $ \fl -> fl { tileFraction = min 1 $ max 0 $ tileFraction fl + delta } +changeWidth delta = layout $ \fl -> + fl { tileFraction = min 1 (max 0 (tileFraction fl + delta)) } hunk ./Operations.hs 71 -layout f = do modify $ \s -> let fls = layoutDescs s - n = W.current . workspace $ s - fl = M.findWithDefault (defaultLayoutDesc s) n fls - in s { layoutDescs = M.insert n (f fl) fls } - refresh - +layout f = do + modify $ \s -> + let fls = layoutDescs s + n = W.current . workspace $ s + fl = M.findWithDefault (defaultLayoutDesc s) n fls + in s { layoutDescs = M.insert n (f fl) fls } + refresh hunk ./Operations.hs 101 -setButtonGrab True w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab (\b -> - grabButton d b anyModifier w False - (buttonPressMask .|. buttonReleaseMask) - grabModeAsync grabModeSync none none) -setButtonGrab False w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab (\b -> - ungrabButton d b anyModifier w) +setButtonGrab True w = withDisplay $ \d -> io $ + flip mapM_ buttonsToGrab $ \b -> + grabButton d b anyModifier w False + (buttonPressMask .|. buttonReleaseMask) + grabModeAsync grabModeSync none none + +setButtonGrab False w = withDisplay $ \d -> io $ + flip mapM_ buttonsToGrab $ \b -> + ungrabButton d b anyModifier w hunk ./Operations.hs 151 - ws <- gets workspace + ws <- gets workspace hunk ./Operations.hs 153 + hunk ./Operations.hs 162 - setBorder w 0xff0000 + setBorder w 0xff0000 -- make this configurable + hunk ./Operations.hs 166 - modify (\s -> s { workspace = W.raiseFocus w (workspace s) }) + modify $ \s -> s { workspace = W.raiseFocus w (workspace s) } hunk ./Operations.hs 187 -promote = windows (\w -> maybe w (\k -> W.promote k w) (W.peek w)) +promote = windows $ \w -> maybe w (\k -> W.promote k w) (W.peek w) hunk ./Operations.hs 224 - else do + else do hunk ./Operations.hs 226 - Nothing -> do + Nothing -> do hunk ./Operations.hs 254 -restart = do prog <- getProgName - args <- getArgs - executeFile prog True args Nothing +restart = do + prog <- getProgName + args <- getArgs + executeFile prog True args Nothing hunk ./XMonad.hs 20 - spawn, trace, whenJust + spawn, trace, whenJust, swap hunk ./XMonad.hs 56 +-- | 'not' for Layout. +swap :: Layout -> Layout +swap Full = Tile +swap _ = Full + hunk ./Config.hs 64 -startingLayoutDesc = LayoutDesc { layoutType = Full - , tileFraction = 1%2 - } +startingLayoutDesc = + LayoutDesc { layoutType = Full + , tileFraction = 1%2 } hunk ./StackSet.hs 161 - where tweak i = w { cache = M.delete k (cache w) - , stacks = M.adjust (L.delete k) i (stacks w) - , focus = M.update (\k' -> if k == k' then elemAfter k (stacks w M.! i) else Just k') i (focus w) } + where + tweak i = w { cache = M.delete k (cache w) + , stacks = M.adjust (L.delete k) i (stacks w) + , focus = M.update (\k' -> if k == k' then elemAfter k (stacks w M.! i) + else Just k') i + (focus w) + } hunk ./StackSet.hs 182 +-- | hunk ./Config.hs 73 - , ((controlMask, xK_space ), spawn "gmrun") +-- , ((modMask .|. shiftMask, xK_F11 ), spawn "gmrun") hunk ./Config.hs 52 --- How much to change the size of the windows on the left by default. +-- How much to change the horizontal/vertical split bar by defalut. hunk ./Config.hs 56 +-- How much to change the size of a tiled window, by default. +sizeDelta :: Rational +sizeDelta = 3%100 + hunk ./Config.hs 68 -startingLayoutDesc = - LayoutDesc { layoutType = Full - , tileFraction = 1%2 } +startingLayoutDesc = LayoutDesc { layoutType = Full + , tileFraction = 1%2 + } hunk ./Config.hs 77 --- , ((modMask .|. shiftMask, xK_F11 ), spawn "gmrun") + , ((modMask .|. shiftMask, xK_F11 ), spawn "gmrun") hunk ./Config.hs 79 - , ((modMask, xK_j ), raise GT) - , ((modMask, xK_k ), raise LT) - , ((modMask, xK_h ), changeWidth (negate defaultDelta)) - , ((modMask, xK_l ), changeWidth defaultDelta) + , ((modMask, xK_j ), changeVert defaultDelta) + , ((modMask, xK_k ), changeVert (negate defaultDelta)) + , ((modMask, xK_h ), changeHorz (negate defaultDelta)) + , ((modMask, xK_l ), changeHorz defaultDelta) + , ((modMask, xK_F10 ), changeSize sizeDelta (1%100)) + , ((modMask, xK_F9 ), changeSize (negate sizeDelta) (1%100)) hunk ./Main.hs 53 - , defaultLayoutDesc = startingLayoutDesc hunk ./Main.hs 54 + , dispositions = M.empty hunk ./Operations.hs 17 +import Data.Ratio hunk ./Operations.hs 34 - dfltfl <- gets defaultLayoutDesc - let move w a b c e = io $ moveResizeWindow d w a b c e + let move w (Rectangle p q r s) = io $ moveResizeWindow d w p q r s + flipRect (Rectangle p q r s) = Rectangle q p s r hunk ./Operations.hs 38 - sx = rect_x sc - sy = rect_y sc - sw = rect_width sc - sh = rect_height sc - fl = M.findWithDefault dfltfl n fls + fl = M.findWithDefault basicLayoutDesc n fls hunk ./Operations.hs 40 - ratio = tileFraction fl + fullWindow w = move w sc >> io (raiseWindow d w) + + -- runRects draws the windows, figuring out their rectangles. + -- The code here is for a horizontal split, and tr is possibly + -- used to convert to the vertical case. + runRects :: Rectangle -> (Rectangle -> Rectangle) -> (Rational -> Disposition -> Disposition) + -> (Disposition -> Rational) -> Rational -> [Window] -> X () + runRects _ _ _ _ _ [] = return () -- impossible + runRects (Rectangle sx sy sw sh) tr dfix fracFn tf (w:s) = do + -- get the dispositions in the relevant direction (vert/horz) + -- as specified by fracFn. + ds <- mapM (liftM fracFn . gets . disposition) s + + -- do some math. + let lw = round (fromIntegral sw * tf) -- lhs width + rw = sw - fromIntegral lw -- rhs width + ns = map (/ sum ds) ds -- normalized ratios for rhs. + + -- Normalize dispositions while we have the opportunity. + -- This is BAD. Rational numbers will SPACE LEAK each + -- time we make an adjustment. Floating point numbers are + -- better here. (Change it when somebody complains.) + zipWithM_ (\ratio a -> disposeW a (dfix ratio)) ns s + + -- do some more math. + let ps = map (round . (* fromIntegral sh)) . scanl (+) 0 $ ns + -- ps are the vertical positions, [p1 = 0, p2, ..., pn, sh] + xs = map fromIntegral . zipWith (-) (tail ps) $ ps + -- xs are the heights of windows, [p2-p1,p3-p2,...,sh-pn] + rects = zipWith (\p q -> Rectangle (sx + lw) p rw q) ps xs + -- rects are the rectangles of our windows. + + -- Move our lhs window, the big main one. + move w (tr (Rectangle sx sy (fromIntegral lw) sh)) + + -- Move our rhs windows. + zipWithM_ (\r a -> move a (tr r)) rects s + + -- And raise this one, for good measure. + whenJust (W.peek ws) (io . raiseWindow d) hunk ./Operations.hs 81 - Full -> whenJust (W.peekStack n ws) $ \w -> - do move w sx sy sw sh; io $ raiseWindow d w + Full -> whenJust (W.peekStack n ws) $ \w -> do + move w sx sy sw sh + io $ raiseWindow d w hunk ./Operations.hs 92 - zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) - [0..] s + zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) [0..] s hunk ./Operations.hs 98 -switchLayout = layout $ \fl -> fl { layoutType = swap (layoutType fl) } +switchLayout = layout $ \fl -> fl { layoutType = case layoutType fl of + Full -> Tile + Tile -> Full } hunk ./Operations.hs 104 -changeWidth delta = layout $ \fl -> - fl { tileFraction = min 1 (max 0 (tileFraction fl + delta)) } +changeWidth delta = do + layout $ \fl -> fl { tileFraction = min 1 $ max 0 $ tileFraction fl + delta } hunk ./Operations.hs 109 -layout f = do - modify $ \s -> - let fls = layoutDescs s - n = W.current . workspace $ s - fl = M.findWithDefault (defaultLayoutDesc s) n fls - in s { layoutDescs = M.insert n (f fl) fls } - refresh +layout f = do modify $ \s -> let fls = layoutDescs s + n = W.current . workspace $ s + fl = M.findWithDefault (defaultLayoutDesc s) n fls + in s { layoutDescs = M.insert n (f fl) fls } + refresh + hunk ./XMonad.hs 18 - X, WorkSpace, XState(..), Layout(..), LayoutDesc(..), + X, WorkSpace, XState(..), Layout(..), LayoutDesc(..), Disposition(..), + basicLayoutDesc, currentDesc, disposition, hunk ./XMonad.hs 25 +import qualified StackSet as W +import Data.Ratio hunk ./XMonad.hs 49 - , defaultLayoutDesc :: {-# UNPACK #-} !LayoutDesc hunk ./XMonad.hs 50 + , dispositions :: {-# UNPACK #-} !(M.Map Window Disposition) hunk ./XMonad.hs 56 + +-- --------------------------------------------------------------------- +-- Dispositions and Layout + +-- | Disposition. Short for 'Display Position,' it describes how much +-- of the screen a window would like to occupy, when tiled with others. +data Disposition + = Disposition { vertFrac, horzFrac :: {-# UNPACK #-} !Rational } + +basicDisposition :: Disposition +basicDisposition = Disposition (1%3) (1%3) + hunk ./XMonad.hs 69 -data Layout = Full | Tile +data Layout = Full | Horz | Vert hunk ./XMonad.hs 77 -data LayoutDesc = LayoutDesc { layoutType :: !Layout - , tileFraction :: !Rational - } +data LayoutDesc = LayoutDesc { layoutType :: !Layout, + horzTileFrac :: !Rational, + vertTileFrac :: !Rational } hunk ./XMonad.hs 81 +basicLayoutDesc :: LayoutDesc +basicLayoutDesc = LayoutDesc { layoutType = Full, + horzTileFrac = 1%2, + vertTileFrac = 1%2 } + +-- | disposition. Gets the disposition of a particular window. +disposition :: Window -> XState -> Disposition +disposition w s = M.findWithDefault basicDisposition w (dispositions s) + +-- | Gets the current layoutDesc. +currentDesc :: XState -> LayoutDesc +currentDesc s = M.findWithDefault basicLayoutDesc n (layoutDescs s) + where n = (W.current . workspace $ s) hunk ./XMonad.hs 118 + + hunk ./Config.hs 98 - | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] + | (key, sc) <- zip [xK_e, xK_r, xK_t] [1..] hunk ./Config.hs 64 --- What layout to start in, and what the default proportion for the --- left pane should be in the tiled layout. See LayoutDesc and --- friends in XMonad.hs for options. -startingLayoutDesc :: LayoutDesc -startingLayoutDesc = LayoutDesc { layoutType = Full - , tileFraction = 1%2 - } hunk ./Operations.hs 59 - -- This is BAD. Rational numbers will SPACE LEAK each + -- This is bad. Rational numbers might space leak each hunk ./Operations.hs 61 - -- better here. (Change it when somebody complains.) + -- better here. I am being paranoid. hunk ./Operations.hs 81 - Full -> whenJust (W.peekStack n ws) $ \w -> do - move w sx sy sw sh - io $ raiseWindow d w - Tile -> case W.index n ws of - [] -> return () - [w] -> do move w sx sy sw sh; io $ raiseWindow d w - (w:s) -> do - let lw = floor $ fromIntegral sw * ratio - rw = sw - fromIntegral lw - rh = fromIntegral sh `div` fromIntegral (length s) - move w sx sy (fromIntegral lw) sh - zipWithM_ (\i a -> move a (sx + lw) (sy + i * rh) rw (fromIntegral rh)) [0..] s - whenJust (W.peek ws) (io . raiseWindow d) -- this is always Just + Full -> whenJust (W.peekStack n ws) fullWindow + _ -> case W.index n ws of + [] -> return () + [w] -> fullWindow w + s -> case l of + Horz -> runRects sc id (\r dp -> dp {horzFrac = r}) horzFrac (horzTileFrac fl) s + Vert -> runRects (flipRect sc) flipRect (\r dp -> dp {vertFrac = r}) vertFrac (vertTileFrac fl) s + _ -> error "Operations.refresh: the absurdly impossible happened. Please complain about this." hunk ./Operations.hs 93 -switchLayout = layout $ \fl -> fl { layoutType = case layoutType fl of - Full -> Tile - Tile -> Full } +switchLayout = layout $ \fl -> fl { layoutType = rot (layoutType fl) } hunk ./Operations.hs 95 --- | changeWidth. Change the width of the main window in tiling mode. -changeWidth :: Rational -> X () -changeWidth delta = do - layout $ \fl -> fl { tileFraction = min 1 $ max 0 $ tileFraction fl + delta } +-- | changeVert. Changes the vertical split, if it's visible. +changeVert :: Rational -> X () +changeVert delta = do + l <- gets (layoutType . currentDesc) + case l of + Vert -> layout $ \d -> d {vertTileFrac = min 1 $ max 0 $ vertTileFrac d + delta} + _ -> return () + +-- | changeHorz. Changes the horizontal split, if it's visible. +changeHorz :: Rational -> X () +changeHorz delta = do + l <- gets (layoutType . currentDesc) + case l of + Horz -> layout $ \d -> d {horzTileFrac = min 1 $ max 0 $ horzTileFrac d + delta} + _ -> return () + +-- | changeSize. Changes the size of the window, except in Full mode, with the +-- size remaining above the given mini-mum. +changeSize :: Rational -> Rational -> X () +changeSize delta mini = do + l <- gets (layoutType . currentDesc) + mw <- gets (W.peek . workspace) + whenJust mw $ \w -> do + case l of -- This is always Just. + Full -> return () + Horz -> disposeW w $ \d -> d {horzFrac = max mini $ horzFrac d + delta} + Vert -> disposeW w $ \d -> d {vertFrac = max mini $ vertFrac d + delta} -- hrm... + refresh hunk ./Operations.hs 126 -layout f = do modify $ \s -> let fls = layoutDescs s - n = W.current . workspace $ s - fl = M.findWithDefault (defaultLayoutDesc s) n fls - in s { layoutDescs = M.insert n (f fl) fls } - refresh - +layout f = do + modify $ \s -> + let n = W.current . workspace $ s + fl = currentDesc s + in s { layoutDescs = M.insert n (f fl) (layoutDescs s) } + refresh + +-- | disposeW. Changes the disposition of a particular window. +disposeW :: Window -> (Disposition -> Disposition) -> X () +disposeW w f = modify $ \s -> let d = f (disposition w s) + in s {dispositions = M.insert w d (dispositions s)} + -- NO refresh. Do not put refresh here. + -- refresh calls this function. + hunk ./XMonad.hs 21 - spawn, trace, whenJust, swap + spawn, trace, whenJust, rot hunk ./XMonad.hs 58 --- Dispositions and Layout +-- Display Positions and Layout hunk ./XMonad.hs 71 --- | 'not' for Layout. -swap :: Layout -> Layout -swap Full = Tile -swap _ = Full +-- | 'rot' for Layout. +rot :: Layout -> Layout +rot Full = Horz +rot Horz = Vert +rot Vert = Full hunk ./Config.hs 71 - , ((modMask, xK_Tab ), raise GT) - , ((modMask, xK_j ), changeVert defaultDelta) - , ((modMask, xK_k ), changeVert (negate defaultDelta)) + , ((modMask, xK_space ), switchLayout) + hunk ./Config.hs 75 - , ((modMask, xK_F10 ), changeSize sizeDelta (1%100)) - , ((modMask, xK_F9 ), changeSize (negate sizeDelta) (1%100)) + , ((modMask .|. shiftMask, xK_j ), changeVert defaultDelta) + , ((modMask .|. shiftMask, xK_k ), changeVert (negate defaultDelta)) + + , ((modMask, xK_Tab ), raise GT) + , ((modMask, xK_j ), raise GT) + , ((modMask, xK_k ), raise LT) + hunk ./Config.hs 84 - , ((modMask .|. shiftMask, xK_F12 ), io restart) - , ((modMask, xK_space ), switchLayout) + , ((modMask .|. shiftMask, xK_r ), io restart) + hunk ./Config.hs 87 + hunk ./Operations.hs 247 --- | promote. Make the focused window the master window in its workspace +-- | promote. Make the focused window the master window in its +-- workspace , in non-fullscreen mode. +-- +-- TODO: generic cycling clockwise and anticlockwise +-- hunk ./Operations.hs 44 - -- used to convert to the vertical case. - runRects :: Rectangle -> (Rectangle -> Rectangle) -> (Rational -> Disposition -> Disposition) + -- used to convert to the vertical case. The comments + -- speak in terms of the horizontal case. + runRects :: Rectangle -> (Rectangle -> Rectangle) + -> (Rational -> Disposition -> Disposition) hunk ./Operations.hs 88 - Horz -> runRects sc id (\r dp -> dp {horzFrac = r}) horzFrac (horzTileFrac fl) s - Vert -> runRects (flipRect sc) flipRect (\r dp -> dp {vertFrac = r}) vertFrac (vertTileFrac fl) s - _ -> error "Operations.refresh: the absurdly impossible happened. Please complain about this." + Horz -> (runRects sc + id + (\r dp -> dp {horzFrac = r}) + horzFrac + (horzTileFrac fl) + s) + Vert -> (runRects (flipRect sc) + flipRect + (\r dp -> dp {vertFrac = r}) + vertFrac + (vertTileFrac fl) + s) + _ -> error "Operations.refresh: the absurdly \ + \impossible happened. Please \ + \complain about this." hunk ./Operations.hs 105 --- | switchLayout. Switch to another layout scheme. Switches the current workspace. +-- | switchLayout. Switch to another layout scheme. Switches the +-- current workspace. hunk ./Operations.hs 115 - Vert -> layout $ \d -> d {vertTileFrac = min 1 $ max 0 $ vertTileFrac d + delta} + Vert -> layout $ \d -> d {vertTileFrac = min 1 $ + max 0 $ + vertTileFrac d + delta} hunk ./Operations.hs 125 - Horz -> layout $ \d -> d {horzTileFrac = min 1 $ max 0 $ horzTileFrac d + delta} + Horz -> layout $ \d -> d {horzTileFrac = min 1 $ + max 0 $ + horzTileFrac d + delta} hunk ./Operations.hs 136 - whenJust mw $ \w -> do - case l of -- This is always Just. + whenJust mw $ \w -> do -- This is always Just. + case l of hunk ./Operations.hs 139 - Horz -> disposeW w $ \d -> d {horzFrac = max mini $ horzFrac d + delta} - Vert -> disposeW w $ \d -> d {vertFrac = max mini $ vertFrac d + delta} -- hrm... + Horz -> disposeW w $ \d -> d {horzFrac = max mini $ + horzFrac d + delta} + Vert -> disposeW w $ \d -> d {vertFrac = max mini $ + vertFrac d + delta} -- hrm... hunk ./Operations.hs 145 --- | layout. Modify the current workspace's layout with a pure function and refresh. +-- | layout. Modify the current workspace's layout with a pure +-- function and refresh. hunk ./Config.hs 70 - , ((modMask .|. shiftMask, xK_F11 ), spawn "gmrun") + , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") hunk ./Config.hs 73 + , ((modMask, xK_Tab ), raise GT) + , ((modMask, xK_j ), raise GT) + , ((modMask, xK_k ), raise LT) + hunk ./Config.hs 82 - , ((modMask, xK_Tab ), raise GT) - , ((modMask, xK_j ), raise GT) - , ((modMask, xK_k ), raise LT) - hunk ./Config.hs 83 - , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) - , ((modMask .|. shiftMask, xK_r ), io restart) hunk ./Config.hs 84 + , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) + , ((modMask .|. shiftMask .|. controlMask, xK_q ), io restart) + + -- more focused window into master position in tiling mode. hunk ./Config.hs 91 - -- Keybindings to each workspace: + -- Keybindings to get to each workspace: hunk ./Config.hs 95 - -- Keybindings to each screen: + + -- Keybindings to each screen : + -- mod-wer (underneath 123) swtiches to physical/Xinerama screens 1 2 and 3 hunk ./Config.hs 100 - | (key, sc) <- zip [xK_e, xK_r, xK_t] [1..] + | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] hunk ./Config.hs 103 + hunk ./Operations.hs 347 +-- | Starts dmenu on the current screen. (Requires patches to dmenu for the -x +-- and -w options.) +dmenu :: X () +dmenu = do + xinesc <- gets xineScreens + ws <- gets workspace + ws2sc <- gets wsOnScreen + let curscreen = fromMaybe 0 (M.lookup (W.current ws) ws2sc) + sc = xinesc !! curscreen + spawn $ "exe=`dmenu_path | dmenu -x " ++ (show $ rect_x sc) ++ " -w " ++ (show $ rect_width sc) ++ "` && exec $exe" + hunk ./Config.hs 3 --- xmonad places each window into a "workspace." Each workspace can have any --- number of windows, which you can cycle though with mod-j and mod-k. Windows are --- either displayed full screen, or tiled. You can toggle the layout mode with --- mod-space. --- --- You can switch to workspace N with mod-N. For example, to switch to workspace --- 5, you would press mod-5. Similarly, you can move the current window to another --- workspace with mod-shift-N. --- --- When running with multiple monitors (Xinerama), each screen has exactly 1 --- workspace visible. When xmonad starts, workspace 1 is on screen 1, workspace 2 --- is on screen 2, etc. If you switch to a workspace which is currently visible on --- another screen, xmonad simply switches focus to that screen. If you switch to a --- workspace which is *not* visible, xmonad replaces the workspace on the --- *current* screen with the workspace you selected. --- --- For example, if you have the following configuration: --- --- Screen 1: Workspace 2 --- Screen 2: Workspace 5 (current workspace) --- --- and you wanted to view workspace 7 on screen 1, you would press: --- --- mod-2 (to select workspace 2, and make screen 1 the current screen) --- mod-7 (to select workspace 7) --- --- Since switching to the workspace currently visible on a given screen is such a --- common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace --- currently visible on screens 1, 2, and 3 respectively. Likewise, --- shift-mod-{w,e,r} moves the current window to the workspace on that screen. --- Using these keys, the above example would become mod-w mod-7. +{- +xmonad places each window into a "workspace." Each workspace can have any +number of windows, which you can cycle though with mod-j and mod-k. Windows are +either displayed full screen, or tiled. You can toggle the layout mode with +mod-space. + +You can switch to workspace N with mod-N. For example, to switch to workspace +5, you would press mod-5. Similarly, you can move the current window to another +workspace with mod-shift-N. + +When running with multiple monitors (Xinerama), each screen has exactly 1 +workspace visible. When xmonad starts, workspace 1 is on screen 1, workspace 2 +is on screen 2, etc. If you switch to a workspace which is currently visible on +another screen, xmonad simply switches focus to that screen. If you switch to a +workspace which is *not* visible, xmonad replaces the workspace on the +*current* screen with the workspace you selected. + +For example, if you have the following configuration: + +Screen 1: Workspace 2 +Screen 2: Workspace 5 (current workspace) + +and you wanted to view workspace 7 on screen 1, you would press: + +mod-2 (to select workspace 2, and make screen 1 the current screen) +mod-7 (to select workspace 7) + +Since switching to the workspace currently visible on a given screen is such a +common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace +currently visible on screens 1, 2, and 3 respectively. Likewise, +shift-mod-{w,e,r} moves the current window to the workspace on that screen. +Using these keys, the above example would become mod-w mod-7. +-} hunk ./Config.hs 99 - -- mod-wer (underneath 123) swtiches to physical/Xinerama screens 1 2 and 3 + -- mod-wer (underneath 123) switches to physical/Xinerama screens 1 2 and 3 hunk ./Main.hs 51 - , dimensions = (displayWidth dpy dflt, displayHeight dpy dflt) + -- fromIntegral needed for X11 versions that use Int instead of CInt. + , dimensions = (fromIntegral (displayWidth dpy dflt), + fromIntegral (displayHeight dpy dflt)) hunk ./Main.hs 6 --- +-- hunk ./Main.hs 33 --- +-- hunk ./Main.hs 124 --- +-- hunk ./Main.hs 175 - when (W.member w ws) $ -- already managed, reconfigure (see client:configure() + when (W.member w ws) $ -- already managed, reconfigure (see client:configure() hunk ./Operations.hs 43 - -- The code here is for a horizontal split, and tr is possibly + -- The code here is for a horizontal split, and tr is possibly hunk ./Operations.hs 61 - -- This is bad. Rational numbers might space leak each + -- This is bad. Rational numbers might space leak each hunk ./Operations.hs 106 --- current workspace. +-- current workspace. hunk ./Operations.hs 114 - case l of + case l of hunk ./Operations.hs 130 --- | changeSize. Changes the size of the window, except in Full mode, with the +-- | changeSize. Changes the size of the window, except in Full mode, with the hunk ./Operations.hs 146 --- function and refresh. +-- function and refresh. hunk ./README 9 - If the aim of dwm is to fit in under 2000 lines of C, the aim of + If the aim of dwm is to fit in under 2000 lines of C, the aim of hunk ./README 33 -Then add: +Then add: hunk ./StackSet.hs 6 --- +-- hunk ./StackSet.hs 92 --- | Push. Insert an element onto the top of the current stack. +-- | Push. Insert an element onto the top of the current stack. hunk ./XMonad.hs 6 --- +-- hunk ./Config.hs 49 --- modMask lets you easily change which modkey you use. The default is mod1Mask. --- ("alt") +-- modMask lets you easily change which modkey you use. The default is mod1Mask +-- ("left alt"). You may also consider using mod3mask ("right alt"), which +-- does not conflict with emacs keybindings. hunk ./Config.hs 64 -numlockMask :: KeySym +numlockMask :: KeyMask hunk ./Config.hs 67 +-- What layout to start in, and what the default proportion for the +-- left pane should be in the tiled layout. See LayoutDesc and +-- friends in XMonad.hs for options. +startingLayoutDesc :: LayoutDesc +startingLayoutDesc = + LayoutDesc { layoutType = Full + , tileFraction = 1%2 } hunk ./Config.hs 89 - , ((modMask .|. shiftMask, xK_j ), changeVert defaultDelta) - , ((modMask .|. shiftMask, xK_k ), changeVert (negate defaultDelta)) + -- Not implemented yet: + -- , ((modMask .|. shiftMask, xK_j ), changeVert defaultDelta) + -- , ((modMask .|. shiftMask, xK_k ), changeVert (negate defaultDelta)) hunk ./Main.hs 55 + , defaultLayoutDesc = startingLayoutDesc hunk ./Main.hs 57 - , dispositions = M.empty hunk ./Operations.hs 17 -import Data.Ratio hunk ./Operations.hs 33 - let move w (Rectangle p q r s) = io $ moveResizeWindow d w p q r s - flipRect (Rectangle p q r s) = Rectangle q p s r + dfltfl <- gets defaultLayoutDesc hunk ./Operations.hs 36 - fl = M.findWithDefault basicLayoutDesc n fls - l = layoutType fl - fullWindow w = move w sc >> io (raiseWindow d w) - - -- runRects draws the windows, figuring out their rectangles. - -- The code here is for a horizontal split, and tr is possibly - -- used to convert to the vertical case. The comments - -- speak in terms of the horizontal case. - runRects :: Rectangle -> (Rectangle -> Rectangle) - -> (Rational -> Disposition -> Disposition) - -> (Disposition -> Rational) -> Rational -> [Window] -> X () - runRects _ _ _ _ _ [] = return () -- impossible - runRects (Rectangle sx sy sw sh) tr dfix fracFn tf (w:s) = do - -- get the dispositions in the relevant direction (vert/horz) - -- as specified by fracFn. - ds <- mapM (liftM fracFn . gets . disposition) s - - -- do some math. - let lw = round (fromIntegral sw * tf) -- lhs width - rw = sw - fromIntegral lw -- rhs width - ns = map (/ sum ds) ds -- normalized ratios for rhs. - - -- Normalize dispositions while we have the opportunity. - -- This is bad. Rational numbers might space leak each - -- time we make an adjustment. Floating point numbers are - -- better here. I am being paranoid. - zipWithM_ (\ratio a -> disposeW a (dfix ratio)) ns s - - -- do some more math. - let ps = map (round . (* fromIntegral sh)) . scanl (+) 0 $ ns - -- ps are the vertical positions, [p1 = 0, p2, ..., pn, sh] - xs = map fromIntegral . zipWith (-) (tail ps) $ ps - -- xs are the heights of windows, [p2-p1,p3-p2,...,sh-pn] - rects = zipWith (\p q -> Rectangle (sx + lw) p rw q) ps xs - -- rects are the rectangles of our windows. - - -- Move our lhs window, the big main one. - move w (tr (Rectangle sx sy (fromIntegral lw) sh)) - - -- Move our rhs windows. - zipWithM_ (\r a -> move a (tr r)) rects s - - -- And raise this one, for good measure. - whenJust (W.peek ws) (io . raiseWindow d) - case l of - Full -> whenJust (W.peekStack n ws) fullWindow - _ -> case W.index n ws of - [] -> return () - [w] -> fullWindow w - s -> case l of - Horz -> (runRects sc - id - (\r dp -> dp {horzFrac = r}) - horzFrac - (horzTileFrac fl) - s) - Vert -> (runRects (flipRect sc) - flipRect - (\r dp -> dp {vertFrac = r}) - vertFrac - (vertTileFrac fl) - s) - _ -> error "Operations.refresh: the absurdly \ - \impossible happened. Please \ - \complain about this." + fl = M.findWithDefault dfltfl n fls + mapM_ (\(w, Rectangle a b c e) -> io $ moveResizeWindow d w a b c e) $ + case layoutType fl of + Full -> fmap (flip (,) sc) $ maybeToList $ W.peekStack n ws + Horz -> tile (tileFraction fl) sc $ W.index n ws + whenJust (W.peekStack n ws) (io . raiseWindow d) hunk ./Operations.hs 44 +tile :: Rational -> Rectangle -> [Window] -> [(Window, Rectangle)] +tile _ _ [] = [] +tile _ d [w] = [(w, d)] +tile r (Rectangle sx sy sw sh) (w:s) + = (w, Rectangle sx sy (fromIntegral lw) sh) : zipWith f [sy, sy + rh ..] s + where + lw = floor $ fromIntegral sw * r + rw = sw - fromIntegral lw + rh = fromIntegral sh `div` fromIntegral (length s) + f i a = (a, Rectangle (sx + lw) i rw (fromIntegral rh)) + hunk ./Operations.hs 60 --- | changeVert. Changes the vertical split, if it's visible. -changeVert :: Rational -> X () -changeVert delta = do - l <- gets (layoutType . currentDesc) - case l of - Vert -> layout $ \d -> d {vertTileFrac = min 1 $ - max 0 $ - vertTileFrac d + delta} - _ -> return () - --- | changeHorz. Changes the horizontal split, if it's visible. +-- | changeHorz. Changes the horizontal split. hunk ./Operations.hs 62 -changeHorz delta = do - l <- gets (layoutType . currentDesc) - case l of - Horz -> layout $ \d -> d {horzTileFrac = min 1 $ - max 0 $ - horzTileFrac d + delta} - _ -> return () - --- | changeSize. Changes the size of the window, except in Full mode, with the --- size remaining above the given mini-mum. -changeSize :: Rational -> Rational -> X () -changeSize delta mini = do - l <- gets (layoutType . currentDesc) - mw <- gets (W.peek . workspace) - whenJust mw $ \w -> do -- This is always Just. - case l of - Full -> return () - Horz -> disposeW w $ \d -> d {horzFrac = max mini $ - horzFrac d + delta} - Vert -> disposeW w $ \d -> d {vertFrac = max mini $ - vertFrac d + delta} -- hrm... - refresh +changeHorz delta = layout $ \fl -> + fl { tileFraction = min 1 (max 0 (tileFraction fl + delta)) } hunk ./Operations.hs 70 - let n = W.current . workspace $ s - fl = currentDesc s - in s { layoutDescs = M.insert n (f fl) (layoutDescs s) } + let fls = layoutDescs s + n = W.current . workspace $ s + fl = M.findWithDefault (defaultLayoutDesc s) n fls + in s { layoutDescs = M.insert n (f fl) fls } hunk ./Operations.hs 76 --- | disposeW. Changes the disposition of a particular window. -disposeW :: Window -> (Disposition -> Disposition) -> X () -disposeW w f = modify $ \s -> let d = f (disposition w s) - in s {dispositions = M.insert w d (dispositions s)} - -- NO refresh. Do not put refresh here. - -- refresh calls this function. - - hunk ./Operations.hs 183 --- workspace , in non-fullscreen mode. +-- workspace hunk ./XMonad.hs 18 - X, WorkSpace, XState(..), Layout(..), LayoutDesc(..), Disposition(..), - basicLayoutDesc, currentDesc, disposition, + X, WorkSpace, XState(..), Layout(..), LayoutDesc(..), hunk ./XMonad.hs 24 -import qualified StackSet as W -import Data.Ratio hunk ./XMonad.hs 46 + , defaultLayoutDesc :: {-# UNPACK #-} !LayoutDesc hunk ./XMonad.hs 48 - , dispositions :: {-# UNPACK #-} !(M.Map Window Disposition) hunk ./XMonad.hs 53 - --- --------------------------------------------------------------------- --- Display Positions and Layout - --- | Disposition. Short for 'Display Position,' it describes how much --- of the screen a window would like to occupy, when tiled with others. -data Disposition - = Disposition { vertFrac, horzFrac :: {-# UNPACK #-} !Rational } - -basicDisposition :: Disposition -basicDisposition = Disposition (1%3) (1%3) - hunk ./XMonad.hs 54 -data Layout = Full | Horz | Vert +data Layout = Full | Horz deriving (Enum, Bounded) hunk ./XMonad.hs 58 -rot Full = Horz -rot Horz = Vert -rot Vert = Full +rot x = toEnum $ (fromEnum x + 1) `mod` (fromEnum (maxBound `asTypeOf` x) + 1) hunk ./XMonad.hs 61 -data LayoutDesc = LayoutDesc { layoutType :: !Layout, - horzTileFrac :: !Rational, - vertTileFrac :: !Rational } +data LayoutDesc = LayoutDesc { layoutType :: !Layout + , tileFraction :: !Rational + } hunk ./XMonad.hs 65 -basicLayoutDesc :: LayoutDesc -basicLayoutDesc = LayoutDesc { layoutType = Full, - horzTileFrac = 1%2, - vertTileFrac = 1%2 } - --- | disposition. Gets the disposition of a particular window. -disposition :: Window -> XState -> Disposition -disposition w s = M.findWithDefault basicDisposition w (dispositions s) - --- | Gets the current layoutDesc. -currentDesc :: XState -> LayoutDesc -currentDesc s = M.findWithDefault basicLayoutDesc n (layoutDescs s) - where n = (W.current . workspace $ s) hunk ./XMonad.hs 89 - - hunk ./Operations.hs 44 +-- | tile. Compute the positions for windows in horizontal layout +-- mode. +-- +-- TODO generalize this to vertical layout +-- hunk ./XMonad.hs 68 --- | The X monad, a StateT transformer over IO encapuslating the window +-- | The X monad, a StateT transformer over IO encapsulating the window hunk ./Operations.hs 41 + Vert -> vtile (tileFraction fl) sc $ W.index n ws hunk ./Operations.hs 47 --- --- TODO generalize this to vertical layout --- hunk ./Operations.hs 58 +-- | vtile. Tile vertically. +vtile :: Rational -> Rectangle -> [Window] -> [(Window, Rectangle)] +vtile r rect ws = map (\(w, wr) -> (w, flipRect wr)) $ tile r (flipRect rect) ws + +flipRect :: Rectangle -> Rectangle +flipRect (Rectangle { rect_x = x, rect_y = y, rect_width = w, rect_height = h }) + = Rectangle { rect_x = y, rect_y = x, rect_width = h, rect_height = w } + hunk ./XMonad.hs 54 -data Layout = Full | Horz deriving (Enum, Bounded) +data Layout = Full | Horz | Vert deriving (Enum, Bounded) hunk ./TODO 30 +- Xinerama bugs: + - Closing the last window in a workspace moves focus to another Xinerama + screen. + - Focus goes to other Xinerama screen when changing to empty window and + create new window. + - Focus doesn't always follow mouse or mouse click across Xinerama screens; + sometimes focus will only switch with key command to switch to that + screen. + hunk ./Config.hs 98 - -- more focused window into master position in tiling mode. + -- Move focused window into master position in tiling mode. hunk ./TODO 24 + - windows slightly overlap on i386, do not overlap on amd64, + implies that it's not xmonad's fault? hunk ./Config.hs 87 - , ((modMask, xK_h ), changeHorz (negate defaultDelta)) - , ((modMask, xK_l ), changeHorz defaultDelta) - -- Not implemented yet: - -- , ((modMask .|. shiftMask, xK_j ), changeVert defaultDelta) - -- , ((modMask .|. shiftMask, xK_k ), changeVert (negate defaultDelta)) + , ((modMask, xK_h ), changeSplit (negate defaultDelta)) + , ((modMask, xK_l ), changeSplit defaultDelta) hunk ./Operations.hs 40 - Horz -> tile (tileFraction fl) sc $ W.index n ws - Vert -> vtile (tileFraction fl) sc $ W.index n ws + Tall -> tile (tileFraction fl) sc $ W.index n ws + Wide -> vtile (tileFraction fl) sc $ W.index n ws hunk ./Operations.hs 71 --- | changeHorz. Changes the horizontal split. -changeHorz :: Rational -> X () -changeHorz delta = layout $ \fl -> +-- | changeSplit. Changes the window split. +changeSplit :: Rational -> X () +changeSplit delta = layout $ \fl -> hunk ./XMonad.hs 54 -data Layout = Full | Horz | Vert deriving (Enum, Bounded) +data Layout = Full | Tall | Wide deriving (Enum, Bounded) hunk ./Main.hs 172 - dpy <- gets display - ws <- gets workspace + XState { display = dpy, workspace = ws } <- get hunk ./Operations.hs 28 - ws <- gets workspace - ws2sc <- gets wsOnScreen - xinesc <- gets xineScreens - d <- gets display - fls <- gets layoutDescs - dfltfl <- gets defaultLayoutDesc + XState {workspace = ws, wsOnScreen = ws2sc, xineScreens = xinesc + ,display = d ,layoutDescs = fls ,defaultLayoutDesc = dfltfl } <- get + hunk ./Operations.hs 156 - ws <- gets workspace - ws2sc <- gets wsOnScreen + XState { workspace = ws, wsOnScreen = ws2sc} <- get hunk ./Operations.hs 203 - wmdelt <- gets wmdelete - wmprot <- gets wmprotocols + XState {wmdelete = wmdelt, wmprotocols = wmprot} <- get hunk ./Operations.hs 225 - ws <- gets workspace - ws2sc <- gets wsOnScreen + XState { workspace = ws, wsOnScreen = ws2sc } <- get hunk ./Operations.hs 269 - xinesc <- gets xineScreens - ws <- gets workspace - ws2sc <- gets wsOnScreen + XState { xineScreens = xinesc, workspace = ws, wsOnScreen = ws2sc } <- get hunk ./Operations.hs 272 - spawn $ "exe=`dmenu_path | dmenu -x " ++ (show $ rect_x sc) ++ " -w " ++ (show $ rect_width sc) ++ "` && exec $exe" + spawn $ concat [ "exe=`dmenu_path | dmenu -x ", show (rect_x sc) + , " -w " , show (rect_width sc) , "` && exec $exe" ] hunk ./Config.hs 4 -xmonad places each window into a "workspace." Each workspace can have any -number of windows, which you can cycle though with mod-j and mod-k. Windows are -either displayed full screen, or tiled. You can toggle the layout mode with -mod-space. +xmonad bindings follow mostly the dwm/wmii conventions: hunk ./Config.hs 6 -You can switch to workspace N with mod-N. For example, to switch to workspace -5, you would press mod-5. Similarly, you can move the current window to another -workspace with mod-shift-N. + key combination action + + mod-shift-return new xterm + mod-p launch dmenu + mod-shift-p launch gmrun hunk ./Config.hs 12 -When running with multiple monitors (Xinerama), each screen has exactly 1 -workspace visible. When xmonad starts, workspace 1 is on screen 1, workspace 2 -is on screen 2, etc. If you switch to a workspace which is currently visible on -another screen, xmonad simply switches focus to that screen. If you switch to a -workspace which is *not* visible, xmonad replaces the workspace on the -*current* screen with the workspace you selected. + mod-space switch tiling mode + + mod-tab raise next window in stack + mod-j + mod-k + + mod-h resize currently focused window + mod-l + + mod-shift-c kill client + mod-shift-q exit window manager + mod-shift-ctrl-q restart window manager + + mod-return move currently focused window into master position + + mod-1..9 switch to workspace N + mod-shift-1..9 move client to workspace N + + mod-w,e,r switch to physical/Xinerama screen 1, 2 or 3. + +xmonad places each window into a "workspace." Each workspace can have +any number of windows, which you can cycle though with mod-j and mod-k. +Windows are either displayed full screen, tiled horizontally, or tiled +vertically. You can toggle the layout mode with mod-space, which will +cycle through the available modes. + +You can switch to workspace N with mod-N. For example, to switch to +workspace 5, you would press mod-5. Similarly, you can move the current +window to another workspace with mod-shift-N. + +When running with multiple monitors (Xinerama), each screen has exactly +1 workspace visible. When xmonad starts, workspace 1 is on screen 1, +workspace 2 is on screen 2, etc. If you switch to a workspace which is +currently visible on another screen, xmonad simply switches focus to +that screen. If you switch to a workspace which is *not* visible, xmonad +replaces the workspace on the *current* screen with the workspace you +selected. hunk ./Config.hs 60 -Since switching to the workspace currently visible on a given screen is such a -common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace -currently visible on screens 1, 2, and 3 respectively. Likewise, -shift-mod-{w,e,r} moves the current window to the workspace on that screen. -Using these keys, the above example would become mod-w mod-7. +Since switching to the workspace currently visible on a given screen is +such a common operation, shortcuts are provided: mod-{w,e,r} switch to +the workspace currently visible on screens 1, 2, and 3 respectively. +Likewise, shift-mod-{w,e,r} moves the current window to the workspace on +that screen. Using these keys, the above example would become mod-w +mod-7. + hunk ./Operations.hs 34 - mapM_ (\(w, Rectangle a b c e) -> io $ moveResizeWindow d w a b c e) $ + mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) $ hunk ./Operations.hs 116 +-- | moveWindowInside. Moves and resizes w such that it fits inside the given +-- rectangle, including its border. +moveWindowInside :: Display -> Window -> Rectangle -> IO () +moveWindowInside d w r = do + bw <- (fromIntegral . waBorderWidth) `liftM` getWindowAttributes d w + moveResizeWindow d w (rect_x r) (rect_y r) + (rect_width r - bw*2) + (rect_height r - bw*2) + hunk ./Operations.hs 47 -tile r (Rectangle sx sy sw sh) (w:s) +tile r (Rectangle sx sy sw sh) (w:s) hunk ./Operations.hs 60 -flipRect (Rectangle { rect_x = x, rect_y = y, rect_width = w, rect_height = h }) - = Rectangle { rect_x = y, rect_y = x, rect_width = h, rect_height = w } +flipRect (Rectangle { rect_x = rx, rect_y = ry, rect_width = rw, rect_height = rh }) + = Rectangle { rect_x = ry, rect_y = rx, rect_width = rh, rect_height = rw } hunk ./Operations.hs 127 --- --- When we start to manage a window, it gains focus. hunk ./Operations.hs 133 - setFocus w hunk ./XMonad.hs 36 - { display :: Display - , screen :: {-# UNPACK #-} !ScreenNumber - , xineScreens :: {-# UNPACK #-} ![Rectangle] + { display :: Display + , screen :: !ScreenNumber + + , xineScreens :: ![Rectangle] hunk ./XMonad.hs 41 - , wsOnScreen :: {-# UNPACK #-} !(M.Map Int Int) - , theRoot :: {-# UNPACK #-} !Window - , wmdelete :: {-# UNPACK #-} !Atom - , wmprotocols :: {-# UNPACK #-} !Atom - , dimensions :: {-# UNPACK #-} !(Int,Int) - , workspace :: {-# UNPACK #-} !WorkSpace -- ^ workspace list - , defaultLayoutDesc :: {-# UNPACK #-} !LayoutDesc - , layoutDescs :: {-# UNPACK #-} !(M.Map Int LayoutDesc) + + , wsOnScreen :: !(M.Map Int Int) + , theRoot :: !Window + , wmdelete :: !Atom + , wmprotocols :: !Atom + , dimensions :: !(Int,Int) + , workspace :: !WorkSpace -- ^ workspace list + , defaultLayoutDesc :: !LayoutDesc + , layoutDescs :: !(M.Map Int LayoutDesc) hunk ./xmonad.cabal 14 -ghc-options: -O2 -Wall -optl-Wl,-s +ghc-options: -funbox-strict-fields -O2 -Wall -optl-Wl,-s hunk ./XMonad.hs 36 - { display :: Display + { display :: Display -- ^ the X11 display hunk ./XMonad.hs 39 - , xineScreens :: ![Rectangle] - -- a mapping of workspaces to xinerama screen numbers + , xineScreens :: ![Rectangle] -- ^ dimensions of each screen hunk ./XMonad.hs 41 - , wsOnScreen :: !(M.Map Int Int) - , theRoot :: !Window - , wmdelete :: !Atom - , wmprotocols :: !Atom - , dimensions :: !(Int,Int) - , workspace :: !WorkSpace -- ^ workspace list - , defaultLayoutDesc :: !LayoutDesc - , layoutDescs :: !(M.Map Int LayoutDesc) - -- ^ mapping of workspaces to descriptions of their layouts + , wsOnScreen :: !(M.Map Int Int) -- ^ mapping of workspaces to xinerama screen numbers + , theRoot :: !Window -- ^ the root window + , wmdelete :: !Atom -- ^ window deletion atom + , wmprotocols :: !Atom -- ^ wm protocols atom + , dimensions :: !(Int,Int) -- ^ dimensions of the screen, used for hiding windows + , workspace :: !WorkSpace -- ^ workspace list + , defaultLayoutDesc :: !LayoutDesc -- ^ default layout + , layoutDescs :: !(M.Map Int LayoutDesc) -- ^ mapping of workspaces to descriptions of their layouts hunk ./Main.hs 45 - , screen = dflt hunk ./XMonad.hs 37 - , screen :: !ScreenNumber hunk ./Main.hs 46 - , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0..((length xinesc)-1)] + , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0.. length xinesc - 1] hunk ./TODO 29 - -* Tile vertically/ resize height. hunk ./TODO 23 - - Layout calculation: the current algorithm is crude, windows overlap - - windows slightly overlap on i386, do not overlap on amd64, - implies that it's not xmonad's fault? hunk ./TODO 24 - - change focus in the StackSet structure on EnterNotify hunk ./TODO 1 -- tasks before 0.1: - - Code clean up after tiling and StackSet changes - - Make sure the quickchecks make sense with the new StackSet +- Tasks blocking xmonad 0.1 + - Move the multi-screen handling from XState to StackSet + - Fix the missing windows on workspace switch bug + +- Clean up focus and mouse related issues. During 'refresh', xmonad should + ignore EnterNotify events (by changing selectInput for the duration). +- let mod+enter demote a master window + +- Xinerama bugs: + - Closing the last window in a workspace moves focus to another Xinerama + screen. + - Focus goes to other Xinerama screen when changing to empty window and + create new window. + - Focus doesn't always follow mouse or mouse click across Xinerama screens; + sometimes focus will only switch with key command to switch to that + screen. hunk ./TODO 35 -- tiling: - - make focus remain between workspace switches - - let mod+enter demote a master window - -- Xinerama bugs: - - Closing the last window in a workspace moves focus to another Xinerama - screen. - - Focus goes to other Xinerama screen when changing to empty window and - create new window. - - Focus doesn't always follow mouse or mouse click across Xinerama screens; - sometimes focus will only switch with key command to switch to that - screen. hunk ./XMonad.hs 53 -data Layout = Full | Tall | Wide deriving (Enum, Bounded) +data Layout = Full | Tall | Wide deriving (Enum, Bounded, Eq) hunk ./XMonad.hs 57 -rot x = toEnum $ (fromEnum x + 1) `mod` (fromEnum (maxBound `asTypeOf` x) + 1) +rot x = if x == maxBound then minBound else succ x hunk ./TODO 2 - - Move the multi-screen handling from XState to StackSet + - Move the multi-screen handling from XState to StackSet (see notes below) hunk ./TODO 35 +- Notes on new StackSet: + + The actors: screens, workspaces, windows + + Invariants: + - There is exactly one screen in focus at any given time. + - A screen views exactly one workspace. + - A workspace is visible on one or zero screens. + - A workspace has zero or more windows. + - A workspace has either one or zero windows in focus. Zero if the + workspace has no windows, one in all other cases. + - A window is a member of only one workspace. hunk ./Config.hs 139 - [((m .|. modMask, key), screenWS sc >>= f) - | (key, sc) <- zip [xK_w, xK_e, xK_r] [1..] + [((m .|. modMask, key), gets workspace >>= f . (+1) . fromMaybe 0 . W.workspace sc) + | (key, sc) <- zip [xK_s, xK_d, xK_f] [0..] hunk ./Main.hs 46 - , wsOnScreen = M.fromList $ map (\n -> (n,n)) [0.. length xinesc - 1] hunk ./Main.hs 52 - , workspace = W.empty workspaces + , workspace = W.empty workspaces (length xinesc) hunk ./Operations.hs 28 - XState {workspace = ws, wsOnScreen = ws2sc, xineScreens = xinesc + XState {workspace = ws, xineScreens = xinesc hunk ./Operations.hs 31 - flip mapM_ (M.assocs ws2sc) $ \(n, scn) -> do + flip mapM_ (M.assocs (W.screen2ws ws)) $ \(scn, n) -> do hunk ./Operations.hs 162 - XState { workspace = ws, wsOnScreen = ws2sc} <- get + ws <- gets workspace hunk ./Operations.hs 165 - flip mapM_ (M.keys ws2sc) $ \n -> do + flip mapM_ (W.visibleWorkspaces ws) $ \n -> do hunk ./Operations.hs 231 - XState { workspace = ws, wsOnScreen = ws2sc } <- get + ws <- gets workspace hunk ./Operations.hs 233 - -- is the workspace we want to switch to currently visible? - if M.member n ws2sc - then windows $ W.view n - else do - sc <- case M.lookup m ws2sc of - Nothing -> do - trace "Current workspace isn't visible! This should never happen!" - -- we don't know what screen to use, just use the first one. - return 0 - Just sc -> return sc - modify $ \s -> s { wsOnScreen = M.insert n sc (M.filter (/=sc) ws2sc) } - gets wsOnScreen >>= trace . show - windows $ W.view n - mapM_ hide (W.index m ws) + windows $ W.view n + ws' <- gets workspace + -- If the old workspace isn't visible anymore, we have to hide the windows + -- in case we're switching to an empty workspace. + when (m `notElem` (W.visibleWorkspaces ws')) (mapM_ hide (W.index m ws)) hunk ./Operations.hs 245 --- | screenWS. Returns the workspace currently visible on screen n -screenWS :: Int -> X Int -screenWS n = do - ws2sc <- gets wsOnScreen - -- FIXME: It's ugly to have to query this way. We need a different way to - -- keep track of screen <-> workspace mappings. - let ws = fmap fst $ find (\(_, scn) -> scn == (n-1)) (M.assocs ws2sc) - return $ (fromMaybe 0 ws) + 1 - hunk ./Operations.hs 257 - XState { xineScreens = xinesc, workspace = ws, wsOnScreen = ws2sc } <- get - let curscreen = fromMaybe 0 (M.lookup (W.current ws) ws2sc) + XState { xineScreens = xinesc, workspace = ws } <- get + let curscreen = fromMaybe 0 (M.lookup (W.current ws) (W.ws2screen ws)) hunk ./StackSet.hs 38 - { current:: {-# UNPACK #-} !Int -- ^ the currently visible stack - , stacks :: {-# UNPACK #-} !(M.Map Int [a]) -- ^ the separate stacks - , focus :: {-# UNPACK #-} !(M.Map Int a) -- ^ the window focused in each stack - , cache :: {-# UNPACK #-} !(M.Map a Int) -- ^ a cache of windows back to their stacks + { current :: !Int -- ^ the currently visible stack + , ws2screen:: !(M.Map Int Int) -- ^ workspace -> screen map + , screen2ws:: !(M.Map Int Int) -- ^ screen -> workspace + , stacks :: !(M.Map Int [a]) -- ^ the separate stacks + , focus :: !(M.Map Int a) -- ^ the window focused in each stack + , cache :: !(M.Map a Int) -- ^ a cache of windows back to their stacks hunk ./StackSet.hs 56 --- | /O(n)/. Create a new empty stacks of size 'n', indexed from 0. The --- 0-indexed stack will be current. -empty :: Int -> StackSet a -empty n = StackSet { current = 0 - , stacks = M.fromList (zip [0..n-1] (repeat [])) - , focus = M.empty - , cache = M.empty } - +-- | /O(n)/. Create a new empty stacks of size 'n', indexed from 0, with 'm' +-- screens. (also indexed from 0) The 0-indexed stack will be current. +empty :: Int -> Int -> StackSet a +empty n m = StackSet { current = 0 + , ws2screen = wsScreenAssn + , screen2ws = wsScreenAssn + , stacks = M.fromList (zip [0..n-1] (repeat [])) + , focus = M.empty + , cache = M.empty } + where wsScreenAssn = M.fromList $ map (\x -> (x,x)) [0..m-1] + hunk ./StackSet.hs 83 +-- FIXME: This always makes a StackSet with 1 screen. hunk ./StackSet.hs 92 - (empty (length xs)) (zip [0..] xs) + (empty (length xs) 1) (zip [0..] xs) hunk ./StackSet.hs 120 --- | /O(1)/. view. Set the stack specified by the Int argument as being the --- current StackSet. If the index is out of range an exception is thrown. +-- | view. Set the stack specified by the Int argument as being visible and the +-- current StackSet. If the stack wasn't previously visible, it will become +-- visible on the current screen. If the index is out of range an exception is +-- thrown. hunk ./StackSet.hs 125 -view n w | n >= 0 && n < M.size (stacks w) = w { current = n } +view n w | n >= 0 && n < M.size (stacks w) = if M.member n (ws2screen w) + then w { current = n } + else tweak (fromJust $ screen (current w) w) hunk ./StackSet.hs 129 + where + tweak sc = w { screen2ws = M.insert sc n (screen2ws w) + , ws2screen = M.insert n sc (M.filter (/=sc) (ws2screen w)) + , current = n + } + +-- | That screen that workspace 'n' is visible on, if any. +screen :: Int -> StackSet a -> Maybe Int +screen n w = M.lookup n (ws2screen w) hunk ./StackSet.hs 139 +-- | The workspace visible on screen 'sc'. Nothing if screen is out of bounds. +workspace :: Int -> StackSet a -> Maybe Int +workspace sc w = M.lookup sc $ ws2screen w + +-- | A list of the currently visible workspaces. +visibleWorkspaces :: StackSet a -> [Int] +visibleWorkspaces = M.keys . ws2screen + +-- hunk ./StackSet.hs 202 - Just i -> w { focus = M.insert i k (focus w), current = i } + Just i -> (view i w) { focus = M.insert i k (focus w) } hunk ./XMonad.hs 40 - , wsOnScreen :: !(M.Map Int Int) -- ^ mapping of workspaces to xinerama screen numbers hunk ./tests/Properties.hs 34 -prop_member1 i n = member i (push i x) - where x = empty n :: T +prop_member1 i n m = member i (push i x) + where x = empty n m :: T hunk ./tests/Properties.hs 40 -prop_member3 i n = member i (empty n :: T) == False +prop_member3 i n m = member i (empty n m :: T) == False hunk ./tests/Properties.hs 42 -prop_sizepush is n = n > 0 ==> size (foldr push x is ) == n - where x = empty n :: T +prop_sizepush is n m = n > 0 ==> size (foldr push x is ) == n + where x = empty n m :: T hunk ./tests/Properties.hs 45 -prop_currentpush is n = n > 0 ==> +prop_currentpush is n m = n > 0 ==> hunk ./tests/Properties.hs 49 - x = empty n :: T + x = empty n m :: T hunk ./tests/Properties.hs 89 +prop_currentwsvisible x = (current x) `elem` (visibleWorkspaces x) + where _ = x :: T + +prop_ws2screen_screen2ws x = (ws == ws') && (sc == sc') + where ws = sort . keys $ ws2screen x + ws' = sort . elems $ screen2ws x + sc = sort . keys $ screen2ws x + sc' = sort . elems $ ws2screen x + _ = x :: T + hunk ./tests/Properties.hs 123 + ,("currentwsvisible ", mytest prop_currentwsvisible) + ,("ws screen mapping", mytest prop_ws2screen_screen2ws) hunk ./Config.hs 139 - [((m .|. modMask, key), gets workspace >>= f . (+1) . fromMaybe 0 . W.workspace sc) + [((m .|. modMask, key), screenWorkspace sc >>= f) hunk ./Operations.hs 240 + +-- | 'screenWorkspace sc' returns the workspace number viewed by 'sc'. +screenWorkspace :: Int -> X Int +screenWorkspace sc = fmap (succ . fromMaybe 0 . W.workspace sc) (gets workspace) hunk ./Operations.hs 257 --- | Starts dmenu on the current screen. (Requires patches to dmenu for the -x --- and -w options.) -dmenu :: X () -dmenu = do - XState { xineScreens = xinesc, workspace = ws } <- get - let curscreen = fromMaybe 0 (M.lookup (W.current ws) (W.ws2screen ws)) - sc = xinesc !! curscreen - spawn $ concat [ "exe=`dmenu_path | dmenu -x ", show (rect_x sc) - , " -w " , show (rect_width sc) , "` && exec $exe" ] - hunk ./StackSet.hs 141 -workspace sc w = M.lookup sc $ ws2screen w +workspace sc w = M.lookup sc (screen2ws w) hunk ./StackSet.hs 83 --- FIXME: This always makes a StackSet with 1 screen. -fromList :: Ord a => (Int,[[a]]) -> StackSet a -fromList (_,[]) = error "Cannot build a StackSet from an empty list" +fromList :: Ord a => (Int,Int,[[a]]) -> StackSet a +fromList (_,_,[]) = error "Cannot build a StackSet from an empty list" hunk ./StackSet.hs 86 -fromList (n,xs) | n < 0 || n >= length xs +fromList (n,m,xs) | n < 0 || n >= length xs hunk ./StackSet.hs 88 + | m < 1 || m > length xs + = error $ "Can't have more screens than workspaces: " ++ show (m, length xs) hunk ./StackSet.hs 91 -fromList (o,xs) = view o $ foldr (\(i,ys) s -> - foldr (\a t -> insert a i t) s ys) - (empty (length xs) 1) (zip [0..] xs) +fromList (o,m,xs) = view o $ foldr (\(i,ys) s -> + foldr (\a t -> insert a i t) s ys) + (empty (length xs) m) (zip [0..] xs) hunk ./StackSet.hs 96 -toList :: StackSet a -> (Int,[[a]]) -toList x = (current x, map snd $ M.toList (stacks x)) +toList :: StackSet a -> (Int,Int,[[a]]) +toList x = (current x, M.size $ screen2ws x, map snd $ M.toList (stacks x)) hunk ./tests/Properties.hs 27 + sc <- choose (1,sz) hunk ./tests/Properties.hs 29 - return $ fromList (n,ls) + return $ fromList (n,sc,ls) hunk ./tests/Properties.hs 100 +prop_screenworkspace x = all test [0..((size x)-1)] + where test ws = case screen ws x of + Nothing -> True + Just sc -> workspace sc x == Just ws + _ = x :: T + hunk ./tests/Properties.hs 132 + ,("screen/workspace ", mytest prop_screenworkspace) hunk ./Config.hs 3 -{- -xmonad bindings follow mostly the dwm/wmii conventions: - - key combination action - - mod-shift-return new xterm - mod-p launch dmenu - mod-shift-p launch gmrun - - mod-space switch tiling mode - - mod-tab raise next window in stack - mod-j - mod-k - - mod-h resize currently focused window - mod-l - - mod-shift-c kill client - mod-shift-q exit window manager - mod-shift-ctrl-q restart window manager - - mod-return move currently focused window into master position - - mod-1..9 switch to workspace N - mod-shift-1..9 move client to workspace N - - mod-w,e,r switch to physical/Xinerama screen 1, 2 or 3. - -xmonad places each window into a "workspace." Each workspace can have -any number of windows, which you can cycle though with mod-j and mod-k. -Windows are either displayed full screen, tiled horizontally, or tiled -vertically. You can toggle the layout mode with mod-space, which will -cycle through the available modes. - -You can switch to workspace N with mod-N. For example, to switch to -workspace 5, you would press mod-5. Similarly, you can move the current -window to another workspace with mod-shift-N. - -When running with multiple monitors (Xinerama), each screen has exactly -1 workspace visible. When xmonad starts, workspace 1 is on screen 1, -workspace 2 is on screen 2, etc. If you switch to a workspace which is -currently visible on another screen, xmonad simply switches focus to -that screen. If you switch to a workspace which is *not* visible, xmonad -replaces the workspace on the *current* screen with the workspace you -selected. - -For example, if you have the following configuration: - -Screen 1: Workspace 2 -Screen 2: Workspace 5 (current workspace) - -and you wanted to view workspace 7 on screen 1, you would press: - -mod-2 (to select workspace 2, and make screen 1 the current screen) -mod-7 (to select workspace 7) - -Since switching to the workspace currently visible on a given screen is -such a common operation, shortcuts are provided: mod-{w,e,r} switch to -the workspace currently visible on screens 1, 2, and 3 respectively. -Likewise, shift-mod-{w,e,r} moves the current window to the workspace on -that screen. Using these keys, the above example would become mod-w -mod-7. - --} +-- +-- xmonad bindings follow mostly the dwm/wmii conventions: +-- +-- key combination action +-- +-- mod-shift-return new xterm +-- mod-p launch dmenu +-- mod-shift-p launch gmrun +-- +-- mod-space switch tiling mode +-- +-- mod-tab raise next window in stack +-- mod-j +-- mod-k +-- +-- mod-h resize currently focused window +-- mod-l +-- +-- mod-shift-c kill client +-- mod-shift-q exit window manager +-- mod-shift-ctrl-q restart window manager +-- +-- mod-return move currently focused window into master position +-- +-- mod-1..9 switch to workspace N +-- mod-shift-1..9 move client to workspace N +-- +-- mod-w,e,r switch to physical/Xinerama screen 1, 2 or 3. +-- +-- xmonad places each window into a "workspace." Each workspace can have +-- any number of windows, which you can cycle though with mod-j and mod-k. +-- Windows are either displayed full screen, tiled horizontally, or tiled +-- vertically. You can toggle the layout mode with mod-space, which will +-- cycle through the available modes. +-- +-- You can switch to workspace N with mod-N. For example, to switch to +-- workspace 5, you would press mod-5. Similarly, you can move the current +-- window to another workspace with mod-shift-N. +-- +-- When running with multiple monitors (Xinerama), each screen has exactly +-- 1 workspace visible. When xmonad starts, workspace 1 is on screen 1, +-- workspace 2 is on screen 2, etc. If you switch to a workspace which is +-- currently visible on another screen, xmonad simply switches focus to +-- that screen. If you switch to a workspace which is *not* visible, xmonad +-- replaces the workspace on the *current* screen with the workspace you +-- selected. +-- +-- For example, if you have the following configuration: +-- +-- Screen 1: Workspace 2 +-- Screen 2: Workspace 5 (current workspace) +-- +-- and you wanted to view workspace 7 on screen 1, you would press: +-- +-- mod-2 (to select workspace 2, and make screen 1 the current screen) +-- mod-7 (to select workspace 7) +-- +-- Since switching to the workspace currently visible on a given screen is +-- such a common operation, shortcuts are provided: mod-{w,e,r} switch to +-- the workspace currently visible on screens 1, 2, and 3 respectively. +-- Likewise, shift-mod-{w,e,r} moves the current window to the workspace on +-- that screen. Using these keys, the above example would become mod-w +-- mod-7. +-- hunk ./Config.hs 131 - [((m .|. modMask, xK_0 + fromIntegral i), f i) + [((m .|. modMask, xK_0 + fromIntegral i), f (fromIntegral (pred i))) -- index from 0. hunk ./Operations.hs 32 - let sc = xinesc !! scn + let sc = genericIndex xinesc scn -- temporary coercion! hunk ./Operations.hs 217 --- | tag. Move a window to a new workspace -tag :: Int -> X () -tag o = do +-- | tag. Move a window to a new workspace, 0 indexed. +tag :: W.WorkspaceId -> X () +tag n = do hunk ./Operations.hs 221 - let m = W.current ws + let m = W.current ws -- :: WorkspaceId hunk ./Operations.hs 226 - where n = o-1 hunk ./Operations.hs 227 --- | view. Change the current workspace to workspce at offset 'n-1'. -view :: Int -> X () -view o = do +-- | view. Change the current workspace to workspce at offset n (0 indexed). +view :: W.WorkspaceId -> X () +view n = do hunk ./Operations.hs 238 - where n = o-1 hunk ./Operations.hs 240 -screenWorkspace :: Int -> X Int -screenWorkspace sc = fmap (succ . fromMaybe 0 . W.workspace sc) (gets workspace) +screenWorkspace :: W.ScreenId -> X W.WorkspaceId +screenWorkspace sc = fmap (fromMaybe 0 . W.workspace sc) (gets workspace) hunk ./StackSet.hs 25 -import qualified Data.List as L (delete) +import qualified Data.List as L (delete,genericLength) hunk ./StackSet.hs 38 - { current :: !Int -- ^ the currently visible stack - , ws2screen:: !(M.Map Int Int) -- ^ workspace -> screen map - , screen2ws:: !(M.Map Int Int) -- ^ screen -> workspace - , stacks :: !(M.Map Int [a]) -- ^ the separate stacks - , focus :: !(M.Map Int a) -- ^ the window focused in each stack - , cache :: !(M.Map a Int) -- ^ a cache of windows back to their stacks + { current :: !WorkspaceId -- ^ the currently visible stack + , screen2ws:: !(M.Map ScreenId WorkspaceId) -- ^ screen -> workspace + , ws2screen:: !(M.Map WorkspaceId ScreenId) -- ^ workspace -> screen map + , stacks :: !(M.Map WorkspaceId [a]) -- ^ the separate stacks + , focus :: !(M.Map WorkspaceId a) -- ^ the window focused in each stack + , cache :: !(M.Map a WorkspaceId) -- ^ a cache of windows back to their stacks hunk ./StackSet.hs 46 +-- | Physical screen indicies +newtype ScreenId = S Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) + +-- | Virtual workspace indicies +newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) + hunk ./StackSet.hs 66 - , ws2screen = wsScreenAssn - , screen2ws = wsScreenAssn - , stacks = M.fromList (zip [0..n-1] (repeat [])) + , screen2ws = wsScrs2Works + + , ws2screen = wsWorks2Scrs + , stacks = M.fromList (zip [0..W n-1] (repeat [])) hunk ./StackSet.hs 72 - where wsScreenAssn = M.fromList $ map (\x -> (x,x)) [0..m-1] - + + where (scrs,wrks) = unzip $ map (\x -> (S x, W x)) [0..m-1] + wsScrs2Works = M.fromList (zip scrs wrks) + wsWorks2Scrs = M.fromList (zip wrks scrs) + hunk ./StackSet.hs 81 --- | /O(log n)/. Looks up the stack that x is in, if it is in the StackSet -lookup :: (Monad m, Ord a) => a -> StackSet a -> m Int +-- | /O(log n)/. Looks up the workspace that x is in, if it is in the StackSet +lookup :: (Monad m, Ord a) => a -> StackSet a -> m WorkspaceId hunk ./StackSet.hs 93 -fromList :: Ord a => (Int,Int,[[a]]) -> StackSet a -fromList (_,_,[]) = error "Cannot build a StackSet from an empty list" +-- FIXME: This always makes a StackSet with 1 screen. +fromList :: Ord a => (Int,[[a]]) -> StackSet a +fromList (_,[]) = error "Cannot build a StackSet from an empty list" hunk ./StackSet.hs 97 -fromList (n,m,xs) | n < 0 || n >= length xs +fromList (n,xs) | n < 0 || n >= length xs hunk ./StackSet.hs 107 -toList :: StackSet a -> (Int,Int,[[a]]) -toList x = (current x, M.size $ screen2ws x, map snd $ M.toList (stacks x)) +toList :: StackSet a -> (Int,[[a]]) +toList x = (current x, map snd $ M.toList (stacks x)) hunk ./StackSet.hs 124 -peekStack :: Int -> StackSet a -> Maybe a +peekStack :: WorkspaceId -> StackSet a -> Maybe a hunk ./StackSet.hs 129 -index :: Int -> StackSet a -> [a] +index :: WorkspaceId -> StackSet a -> [a] hunk ./StackSet.hs 132 --- | view. Set the stack specified by the Int argument as being visible and the +-- | view. Set the stack specified by the argument as being visible and the hunk ./StackSet.hs 136 -view :: Int -> StackSet a -> StackSet a -view n w | n >= 0 && n < M.size (stacks w) = if M.member n (ws2screen w) - then w { current = n } - else tweak (fromJust $ screen (current w) w) - | otherwise = error $ "view: index out of bounds: " ++ show n +view :: WorkspaceId -> StackSet a -> StackSet a +-- view n w | n >= 0 && n < fromIntegral (M.size (stacks w)) -- coerce + +view n w | M.member n (stacks w) + = if M.member n (ws2screen w) then w { current = n } + else tweak (fromJust $ screen (current w) w) + | otherwise = error $ "view: index out of bounds: " ++ show n hunk ./StackSet.hs 150 -screen :: Int -> StackSet a -> Maybe Int +screen :: WorkspaceId -> StackSet a -> Maybe ScreenId hunk ./StackSet.hs 154 -workspace :: Int -> StackSet a -> Maybe Int +workspace :: ScreenId -> StackSet a -> Maybe WorkspaceId hunk ./StackSet.hs 158 -visibleWorkspaces :: StackSet a -> [Int] +visibleWorkspaces :: StackSet a -> [WorkspaceId] hunk ./StackSet.hs 184 -shift :: Ord a => Int -> StackSet a -> StackSet a +shift :: Ord a => WorkspaceId -> StackSet a -> StackSet a hunk ./StackSet.hs 192 -insert :: Ord a => a -> Int -> StackSet a -> StackSet a +insert :: Ord a => a -> WorkspaceId -> StackSet a -> StackSet a hunk ./XMonad.hs 23 -import StackSet (StackSet) +import StackSet (StackSet,WorkspaceId) hunk ./XMonad.hs 46 - , layoutDescs :: !(M.Map Int LayoutDesc) -- ^ mapping of workspaces to descriptions of their layouts + , layoutDescs :: !(M.Map WorkspaceId LayoutDesc) -- ^ mapping of workspaces to descriptions of their layouts hunk ./XMonad.hs 63 - - - hunk ./StackSet.hs 91 --- | fromList. Build a new StackSet from a list of list of elements --- If there are duplicates in the list, the last occurence wins. --- FIXME: This always makes a StackSet with 1 screen. -fromList :: Ord a => (Int,[[a]]) -> StackSet a -fromList (_,[]) = error "Cannot build a StackSet from an empty list" +-- | fromList. Build a new StackSet from a list of list of elements, +-- keeping track of the currently focused workspace, and the total +-- number of workspaces. If there are duplicates in the list, the last +-- occurence wins. +fromList :: Ord a => (WorkspaceId, Int,[[a]]) -> StackSet a +fromList (_,_,[]) = error "Cannot build a StackSet from an empty list" hunk ./StackSet.hs 98 -fromList (n,xs) | n < 0 || n >= length xs +fromList (n,m,xs) | n < 0 || n >= L.genericLength xs hunk ./StackSet.hs 100 - | m < 1 || m > length xs + | m < 1 || m > L.genericLength xs hunk ./StackSet.hs 107 + hunk ./StackSet.hs 109 -toList :: StackSet a -> (Int,[[a]]) -toList x = (current x, map snd $ M.toList (stacks x)) +toList :: StackSet a -> (WorkspaceId,Int,[[a]]) +toList x = (current x, M.size $ screen2ws x, map snd $ M.toList (stacks x)) hunk ./XMonad.hs 36 - { display :: Display -- ^ the X11 display + { display :: Display -- ^ the X11 display hunk ./XMonad.hs 38 - , xineScreens :: ![Rectangle] -- ^ dimensions of each screen + , theRoot :: !Window -- ^ the root window + , wmdelete :: !Atom -- ^ window deletion atom + , wmprotocols :: !Atom -- ^ wm protocols atom + , dimensions :: !(Int,Int) -- ^ dimensions of the screen, + -- used for hiding windows + , workspace :: !WorkSpace -- ^ workspace list hunk ./XMonad.hs 45 - , theRoot :: !Window -- ^ the root window - , wmdelete :: !Atom -- ^ window deletion atom - , wmprotocols :: !Atom -- ^ wm protocols atom - , dimensions :: !(Int,Int) -- ^ dimensions of the screen, used for hiding windows - , workspace :: !WorkSpace -- ^ workspace list - , defaultLayoutDesc :: !LayoutDesc -- ^ default layout - , layoutDescs :: !(M.Map WorkspaceId LayoutDesc) -- ^ mapping of workspaces to descriptions of their layouts + , xineScreens :: ![Rectangle] -- ^ dimensions of each screen + , defaultLayoutDesc :: !LayoutDesc -- ^ default layout + , layoutDescs :: !(M.Map WorkspaceId LayoutDesc) -- ^ mapping of workspaces + -- to descriptions of their layouts hunk ./XMonad.hs 53 --- | The different layout modes -data Layout = Full | Tall | Wide deriving (Enum, Bounded, Eq) - --- | 'rot' for Layout. -rot :: Layout -> Layout -rot x = if x == maxBound then minBound else succ x - --- | A full description of a particular workspace's layout parameters. -data LayoutDesc = LayoutDesc { layoutType :: !Layout - , tileFraction :: !Rational - } +------------------------------------------------------------------------ hunk ./XMonad.hs 76 +------------------------------------------------------------------------ +-- Layout handling + +-- | The different layout modes +data Layout = Full | Tall | Wide deriving (Enum, Bounded, Eq) + +-- | 'rot' for Layout. +rot :: Layout -> Layout +rot x = if x == maxBound then minBound else succ x + +-- | A full description of a particular workspace's layout parameters. +data LayoutDesc = LayoutDesc { layoutType :: !Layout + , tileFraction :: !Rational + } + hunk ./Config.hs 126 - -- Move focused window into master position in tiling mode. + -- Cycle the current tiling order hunk ./Operations.hs 37 - Tall -> tile (tileFraction fl) sc $ W.index n ws + Tall -> tile (tileFraction fl) sc $ W.index n ws hunk ./Operations.hs 195 --- | promote. Make the focused window the master window in its --- workspace --- --- TODO: generic cycling clockwise and anticlockwise --- +-- | promote. Cycle the current tiling order clockwise. hunk ./Operations.hs 197 -promote = windows $ \w -> maybe w (\k -> W.promote k w) (W.peek w) +promote = windows W.promote hunk ./StackSet.hs 165 +-- Has the effect of rotating focus. In fullscreen mode this will cause +-- a new window to be visible. hunk ./StackSet.hs 182 - return (w { focus = M.insert (current w) ea (focus w) }) + return $ w { focus = M.insert (current w) ea (focus w) } hunk ./StackSet.hs 222 --- | Move a window to the top of its workspace. -promote :: Ord a => a -> StackSet a -> StackSet a -promote k w = case M.lookup k (cache w) of - Nothing -> w - Just i -> w { stacks = M.adjust (\ks -> k : filter (/= k) ks) i (stacks w) } +-- | Cycle the current stack ordering. In tiled mode has the effect of +-- moving a new window into the master position, without changing focus. +promote :: StackSet a -> StackSet a +promote w = w { stacks = M.adjust next (current w) (stacks w) } + where next [] = [] + next xs = last xs : init xs + +-- +-- case M.lookup k (cache w) of +-- Nothing -> w +-- Just i -> w { stacks = M.adjust (\ks -> k : filter (/= k) ks) i (stacks w) } +-- hunk ./Config.hs 25 --- mod-return move currently focused window into master position +-- mod-return cycle the current tiling order hunk ./Operations.hs 9 +import Control.Arrow hunk ./Operations.hs 45 +-- hunk ./Operations.hs 59 -vtile r rect ws = map (\(w, wr) -> (w, flipRect wr)) $ tile r (flipRect rect) ws +vtile r rect = map (second flipRect) . tile r (flipRect rect) hunk ./Operations.hs 61 +-- | Flip rectangles around hunk ./Operations.hs 63 -flipRect (Rectangle { rect_x = rx, rect_y = ry, rect_width = rw, rect_height = rh }) - = Rectangle { rect_x = ry, rect_y = rx, rect_width = rh, rect_height = rw } +flipRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) hunk ./Operations.hs 66 --- current workspace. +-- current workspace. By convention, a window set as master in Tall mode +-- remains as master in Wide mode. When switching from full screen to a +-- tiling mode, the currently focused window becomes a master. When +-- switching back , the focused window is uppermost. +-- +-- Note a current `feature' is that 'promote' cycles clockwise in Tall +-- mode, and counter clockwise in wide mode. This is a feature. +-- hunk ./Operations.hs 75 -switchLayout = layout $ \fl -> fl { layoutType = rot (layoutType fl) } +switchLayout = layout $ \fl -> fl { layoutType = rotateLayout (layoutType fl) } hunk ./XMonad.hs 20 - spawn, trace, whenJust, rot + spawn, trace, whenJust, rotateLayout hunk ./XMonad.hs 83 -rot :: Layout -> Layout -rot x = if x == maxBound then minBound else succ x +rotateLayout :: Layout -> Layout +rotateLayout x = if x == maxBound then minBound else succ x hunk ./Config.hs 1 +----------------------------------------------------------------------------- +-- | +-- Module : Config.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : stable +-- Portability : portable +-- +----------------------------------------------------------------------------- + hunk ./Operations.hs 1 +----------------------------------------------------------------------------- +-- | +-- Module : Operations.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : stable +-- Portability : portable +-- +----------------------------------------------------------------------------- + hunk ./StackSet.hs 1 +{-# OPTIONS -fglasgow-exts #-} hunk ./StackSet.hs 18 --- A StackSet provides a nice data structure for multiscreen --- window managers, where each screen has a stack of windows, and a window --- may be on only 1 screen at any given time. +-- A StackSet provides a nice data structure for window managers with +-- multiple physical screens, and multiple workspaces, where each screen +-- has a stack of windows, and a window may be on only 1 screen at any +-- given time. hunk ./StackSet.hs 32 --- --- N.B we probably want to think about strict 'adjust' and inserts on --- these data structures in the long run. --- - hunk ./StackSet.hs 226 --- --- case M.lookup k (cache w) of --- Nothing -> w --- Just i -> w { stacks = M.adjust (\ks -> k : filter (/= k) ks) i (stacks w) } --- - hunk ./tests/Properties.hs 1 +{-# OPTIONS -fglasgow-exts #-} hunk ./tests/Properties.hs 20 -height :: Int -> StackSet a -> Int +height :: WorkspaceId -> StackSet a -> Int hunk ./tests/Properties.hs 30 - return $ fromList (n,sc,ls) + return $ fromList (fromIntegral n,sc,ls) hunk ./tests/Properties.hs 77 - in view n (view i x) == x + in view n (view (fromIntegral i) x) == x hunk ./tests/Properties.hs 100 - -prop_screenworkspace x = all test [0..((size x)-1)] + +prop_screenworkspace x = all test [0..((fromIntegral $ size x)-1)] hunk ./Config.hs 151 - | (key, sc) <- zip [xK_s, xK_d, xK_f] [0..] + | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..] hunk ./TODO 2 - - Move the multi-screen handling from XState to StackSet (see notes below) - - Fix the missing windows on workspace switch bug + - more quickchecks (layout algorithm is one candidate) + - website, xmonad.org + - testing hunk ./Operations.hs 54 + clearEnterEvents + +-- | clearEnterEvents. Remove all window entry events from the event queue. +clearEnterEvents :: X () +clearEnterEvents = do + d <- gets display + io $ sync d False + io $ allocaXEvent $ \p -> fix $ \again -> do + more <- checkMaskEvent d enterWindowMask p + when more again hunk ./Operations.hs 264 + clearEnterEvents hunk ./Config.hs 30 --- mod-h resize currently focused window --- mod-l +-- mod-h decrease the size of the master area +-- mod-l increase the size of the master area hunk ./Config.hs 35 --- mod-shift-ctrl-q restart window manager +-- mod-shift-ctrl-q restart window manager ('xmonad' must be in $PATH) hunk ./Operations.hs 254 --- | view. Change the current workspace to workspce at offset n (0 indexed). +-- | view. Change the current workspace to workspace at offset n (0 indexed). hunk ./TODO 2 + * CRITICAL: fix killClient code. see for example, xclock. hunk ./TODO 7 + + hunk ./Config.hs 102 --- How much to change the size of a tiled window, by default. -sizeDelta :: Rational -sizeDelta = 3%100 - hunk ./Config.hs 93 --- ("left alt"). You may also consider using mod3mask ("right alt"), which --- does not conflict with emacs keybindings. +-- ("left alt"). You may also consider using mod3Mask ("right alt"), which +-- does not conflict with emacs keybindings. The "windows key" is usually +-- mod4Mask. hunk ./Operations.hs 25 +import System.Directory hunk ./Operations.hs 280 - prog <- getProgName - args <- getArgs - executeFile prog True args Nothing + prog <- getProgName + prog_path <- findExecutable prog + case prog_path of + Nothing -> return () -- silently fail + Just p -> do args <- getArgs + executeFile p True args Nothing hunk ./TODO 12 - -- Xinerama bugs: - - Closing the last window in a workspace moves focus to another Xinerama - screen. - - Focus goes to other Xinerama screen when changing to empty window and - create new window. - - Focus doesn't always follow mouse or mouse click across Xinerama screens; - sometimes focus will only switch with key command to switch to that - screen. addfile ./tests/loc.hs hunk ./tests/loc.hs 1 +import Control.Monad +import System.Exit + +main = do foo <- getContents + let actual_loc = filter isntcomment $ + map (dropWhile (==' ')) $ lines foo + loc = length actual_loc + putStrLn $ show loc + -- uncomment the following to check for mistakes in isntcomment + -- putStr $ unlines $ actual_loc + when (loc > 400) $ fail "Too many lines of code!" + +isntcomment "" = False +isntcomment ('-':'-':_) = False +isntcomment _ = True changepref test cd tests && ghc --make loc && cat ../StackSet.hs ../XMonad.hs ../Operations.hs ../Config.hs ../Main.hs | ./loc hunk ./README 10 - xmonad is to fit in under 400 lines of Haskell with similar functionality. + xmonad is to fit in under 500 lines of Haskell with similar functionality. hunk ./tests/loc.hs 11 - when (loc > 400) $ fail "Too many lines of code!" + when (loc > 500) $ fail "Too many lines of code!" hunk ./TODO 9 -- Clean up focus and mouse related issues. During 'refresh', xmonad should - ignore EnterNotify events (by changing selectInput for the duration). hunk ./xmonad.cabal 10 -build-depends: base>=1.0, X11>=1.1, X11-extras==0.0, mtl==1.0, unix>=1.0 +build-depends: base>=1.0, X11>=1.1, X11-extras>=0.0, mtl>=1.0, unix>=1.0 hunk ./xmonad.cabal 1 -name: xmonad -version: 0.0 -description: A lightweight X11 window manager. -synopsis: A lightweight X11 window manager. -category: System -license: BSD3 -license-file: LICENSE -author: Spencer Janssen -maintainer: sjanssen@cse.unl.edu -build-depends: base>=1.0, X11>=1.1, X11-extras>=0.0, mtl>=1.0, unix>=1.0 +name: xmonad +version: 0.0 +description: A lightweight X11 window manager. +synopsis: A lightweight X11 window manager. +category: System +license: BSD3 +license-file: LICENSE +author: Spencer Janssen +maintainer: sjanssen@cse.unl.edu +build-depends: base>=1.0, X11>=1.1, X11-extras>=0.0, mtl>=1.0, unix>=1.0 +extra-source-files: README hunk ./xmonad.cabal 13 -executable: xmonad -main-is: Main.hs -ghc-options: -funbox-strict-fields -O2 -Wall -optl-Wl,-s --- ghc-options: -O2 -Wall -optl-Wl,-s -prof -auto-all -extensions: GeneralizedNewtypeDeriving +executable: xmonad +main-is: Main.hs +other-modules: Config Operations StackSet XMonad +ghc-options: -funbox-strict-fields -O2 -Wall -optl-Wl,-s +ghc-prof-options: -prof -auto-all +extensions: GeneralizedNewtypeDeriving hunk ./xmonad.cabal 11 -extra-source-files: README +extra-source-files: README tests/loc.hs tests/Properties.hs hunk ./xmonad.cabal 11 -extra-source-files: README tests/loc.hs tests/Properties.hs +extra-source-files: README TODO tests/loc.hs tests/Properties.hs hunk ./Operations.hs 94 --- Note a current `feature' is that 'promote' cycles clockwise in Tall --- mode, and counter clockwise in wide mode. This is a feature. --- hunk ./Operations.hs 224 --- | promote. Cycle the current tiling order clockwise. +-- | promote. Move the currently focused window into the master frame hunk ./StackSet.hs 27 -import qualified Data.List as L (delete,genericLength) +import qualified Data.List as L (delete,genericLength,elemIndex) hunk ./StackSet.hs 219 --- | Cycle the current stack ordering. In tiled mode has the effect of --- moving a new window into the master position, without changing focus. -promote :: StackSet a -> StackSet a +-- | Swap the currently focused window with the master window (the +-- window on top of the stack). Focus moves to the master. +promote :: Ord a => StackSet a -> StackSet a +promote w = maybe w id $ do + a <- peek w -- fail if null + let w' = w { stacks = M.adjust (\s -> swap a (head s) s) (current w) (stacks w) } + return $ insert a (current w) w' -- and maintain focus + +-- +-- | Swap first occurences of 'a' and 'b' in list. +-- If both elements are not in the list, the list is unchanged. +-- +swap :: Eq a => a -> a -> [a] -> [a] +swap a b xs + | a == b = xs -- do nothing + | Just ai <- L.elemIndex a xs + , Just bi <- L.elemIndex b xs = insertAt bi a (insertAt ai b xs) + where + insertAt n x ys = as ++ x : tail bs + where (as,bs) = splitAt n ys + +swap _ _ xs = xs -- do nothing + +{- +-- cycling: hunk ./StackSet.hs 247 +-} hunk ./tests/Properties.hs 9 -import Test.QuickCheck +import Test.QuickCheck hiding (promote) hunk ./tests/Properties.hs 107 +prop_promote2 x = promote (promote x) == (promote x) + where _ = x :: T + +prop_promotefocus x = focus (promote x) == focus x -- focus doesn't change + where _ = x :: T + hunk ./tests/Properties.hs 140 + ,("promote idempotent", mytest prop_promote2) + ,("promote/focus", mytest prop_promotefocus) hunk ./StackSet.hs 242 -{- +-- hunk ./StackSet.hs 244 -promote w = w { stacks = M.adjust next (current w) (stacks w) } - where next [] = [] - next xs = last xs : init xs --} +-- promote w = w { stacks = M.adjust next (current w) (stacks w) } +-- where next [] = [] +-- next xs = last xs : init xs +-- hunk ./tests/loc.hs 5 - let actual_loc = filter isntcomment $ + let actual_loc = filter (not.null) $ filter isntcomment $ hunk ./tests/loc.hs 15 +isntcomment ('{':'-':_) = False -- pragmas hunk ./tests/Properties.hs 106 +------------------------------------------------------------------------ hunk ./tests/Properties.hs 108 +-- promote is idempotent hunk ./tests/Properties.hs 112 -prop_promotefocus x = focus (promote x) == focus x -- focus doesn't change +-- focus doesn't change +prop_promotefocus x = focus (promote x) == focus x + where _ = x :: T + +-- screen certainly should't change +prop_promotecurrent x = current (promote x) == current x hunk ./tests/Properties.hs 120 +-- promote doesn't mess with other windows +prop_promoterotate x b = focus (rotate dir (promote x)) == focus (rotate dir x) + where _ = x :: T + dir = if b then LT else GT + hunk ./tests/Properties.hs 152 + hunk ./tests/Properties.hs 154 - ,("promote/focus", mytest prop_promotefocus) + ,("promote focus", mytest prop_promotefocus) + ,("promote current", mytest prop_promotecurrent) + ,("promote only swaps", mytest prop_promoterotate) hunk ./Operations.hs 243 -tag :: W.WorkspaceId -> X () +tag :: WorkspaceId -> X () hunk ./Operations.hs 253 -view :: W.WorkspaceId -> X () +view :: WorkspaceId -> X () hunk ./Operations.hs 266 -screenWorkspace :: W.ScreenId -> X W.WorkspaceId +screenWorkspace :: ScreenId -> X WorkspaceId hunk ./StackSet.hs 24 -module StackSet where +module StackSet ( + StackSet(..), -- abstract + + screen, peekStack, index, empty, peek, push, delete, member, + raiseFocus, rotate, promote, shift, view, workspace, fromList, + toList, size, visibleWorkspaces + ) where hunk ./StackSet.hs 38 --- | The StackSet data structure. A table of stacks, with a current pointer -data StackSet a = +-- | The StackSet data structure. Multiple screens containing tables of +-- stacks, with a current pointer +data StackSet i j a = hunk ./StackSet.hs 42 - { current :: !WorkspaceId -- ^ the currently visible stack - , screen2ws:: !(M.Map ScreenId WorkspaceId) -- ^ screen -> workspace - , ws2screen:: !(M.Map WorkspaceId ScreenId) -- ^ workspace -> screen map - , stacks :: !(M.Map WorkspaceId [a]) -- ^ the separate stacks - , focus :: !(M.Map WorkspaceId a) -- ^ the window focused in each stack - , cache :: !(M.Map a WorkspaceId) -- ^ a cache of windows back to their stacks + { current :: !i -- ^ the currently visible stack + , screen2ws:: !(M.Map j i) -- ^ screen -> workspace + , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map + , stacks :: !(M.Map i [a]) -- ^ the separate stacks + , focus :: !(M.Map i a) -- ^ the window focused in each stack + , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks hunk ./StackSet.hs 50 --- | Physical screen indicies -newtype ScreenId = S Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) - --- | Virtual workspace indicies -newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) - -instance Show a => Show (StackSet a) where +instance (Show i, Show a) => Show (StackSet i j a) where hunk ./StackSet.hs 53 --- Ord a constraint on 'a' as we use it as a key. --- hunk ./StackSet.hs 60 -empty :: Int -> Int -> StackSet a +empty :: (Integral i, Integral j) => Int -> Int -> StackSet i j a hunk ./StackSet.hs 63 - hunk ./StackSet.hs 64 - , stacks = M.fromList (zip [0..W n-1] (repeat [])) + , stacks = M.fromList (zip [0..fromIntegral n-1] (repeat [])) hunk ./StackSet.hs 68 - where (scrs,wrks) = unzip $ map (\x -> (S x, W x)) [0..m-1] + where (scrs,wrks) = unzip $ map (\x -> (fromIntegral x, fromIntegral x)) [0..m-1] hunk ./StackSet.hs 73 -member :: Ord a => a -> StackSet a -> Bool +member :: Ord a => a -> StackSet i j a -> Bool hunk ./StackSet.hs 77 -lookup :: (Monad m, Ord a) => a -> StackSet a -> m WorkspaceId -lookup x w = M.lookup x (cache w) +-- lookup :: (Monad m, Ord a) => a -> StackSet i j a -> m i +-- lookup x w = M.lookup x (cache w) hunk ./StackSet.hs 81 -size :: StackSet a -> Int +size :: StackSet i j a -> Int hunk ./StackSet.hs 90 -fromList :: Ord a => (WorkspaceId, Int,[[a]]) -> StackSet a +fromList :: (Integral i, Integral j, Ord a) => (i, Int,[[a]]) -> StackSet i j a hunk ./StackSet.hs 104 -toList :: StackSet a -> (WorkspaceId,Int,[[a]]) +toList :: StackSet i j a -> (i,Int,[[a]]) hunk ./StackSet.hs 111 -push :: Ord a => a -> StackSet a -> StackSet a +push :: (Integral i, Ord a) => a -> StackSet i j a -> StackSet i j a hunk ./StackSet.hs 116 -peek :: StackSet a -> Maybe a +peek :: Integral i => StackSet i j a -> Maybe a hunk ./StackSet.hs 121 -peekStack :: WorkspaceId -> StackSet a -> Maybe a -peekStack n w = M.lookup n (focus w) +peekStack :: Integral i => i -> StackSet i j a -> Maybe a +peekStack i w = M.lookup i (focus w) hunk ./StackSet.hs 124 --- | /O(log s)/. Index. Extract the stack at index 'n'. +-- | /O(log s)/. Index. Extract the stack at workspace 'n'. hunk ./StackSet.hs 126 -index :: WorkspaceId -> StackSet a -> [a] +index :: Integral i => i -> StackSet i j a -> [a] hunk ./StackSet.hs 133 -view :: WorkspaceId -> StackSet a -> StackSet a +view :: (Integral i, Integral j) => i -> StackSet i j a -> StackSet i j a hunk ./StackSet.hs 147 -screen :: WorkspaceId -> StackSet a -> Maybe ScreenId +screen :: Integral i => i -> StackSet i j a -> Maybe j hunk ./StackSet.hs 151 -workspace :: ScreenId -> StackSet a -> Maybe WorkspaceId +workspace :: Integral j => j -> StackSet i j a -> Maybe i hunk ./StackSet.hs 155 -visibleWorkspaces :: StackSet a -> [WorkspaceId] +visibleWorkspaces :: StackSet i j a -> [i] hunk ./StackSet.hs 169 -rotate :: Eq a => Ordering -> StackSet a -> StackSet a +rotate :: (Integral i, Eq a) => Ordering -> StackSet i j a -> StackSet i j a hunk ./StackSet.hs 183 -shift :: Ord a => WorkspaceId -> StackSet a -> StackSet a +shift :: (Integral i, Ord a) => i -> StackSet i j a -> StackSet i j a hunk ./StackSet.hs 191 -insert :: Ord a => a -> WorkspaceId -> StackSet a -> StackSet a +insert :: (Integral i, Ord a) => a -> i -> StackSet i j a -> StackSet i j a hunk ./StackSet.hs 200 -delete :: Ord a => a -> StackSet a -> StackSet a +delete :: (Integral i, Ord a) => a -> StackSet i j a -> StackSet i j a hunk ./StackSet.hs 212 -raiseFocus :: Ord a => a -> StackSet a -> StackSet a +raiseFocus :: (Integral i, Integral j, Ord a) => a -> StackSet i j a -> StackSet i j a hunk ./StackSet.hs 219 -promote :: Ord a => StackSet a -> StackSet a +promote :: (Integral i, Ord a) => StackSet i j a -> StackSet i j a hunk ./StackSet.hs 247 --- | +-- | Find the element in the (circular) list after given element. hunk ./XMonad.hs 18 - X, WorkSpace, XState(..), Layout(..), LayoutDesc(..), - runX, io, withDisplay, isRoot, - spawn, trace, whenJust, rotateLayout + X, WorkSpace, WorkspaceId(..), ScreenId(..), XState(..), Layout(..), LayoutDesc(..), + runX, io, withDisplay, isRoot, spawn, trace, whenJust, rotateLayout hunk ./XMonad.hs 22 -import StackSet (StackSet,WorkspaceId) +import StackSet (StackSet) hunk ./XMonad.hs 50 -type WorkSpace = StackSet Window +type WorkSpace = StackSet WorkspaceId ScreenId Window + +-- | Virtual workspace indicies +newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) + +-- | Physical screen indicies +newtype ScreenId = S Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) hunk ./tests/Properties.hs 20 -height :: WorkspaceId -> StackSet a -> Int +height :: Int -> T -> Int hunk ./tests/Properties.hs 24 -instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where +instance (Integral i, Integral j, Ord a, Arbitrary a) => Arbitrary (StackSet i j a) where hunk ./tests/Properties.hs 61 -type T = StackSet Int +type T = StackSet Int Int Int hunk ./StackSet.hs 1 -{-# OPTIONS -fglasgow-exts #-} hunk ./Operations.hs 114 -windows :: (WorkSpace -> WorkSpace) -> X () +windows :: (WindowSet -> WindowSet) -> X () hunk ./XMonad.hs 18 - X, WorkSpace, WorkspaceId(..), ScreenId(..), XState(..), Layout(..), LayoutDesc(..), + X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), Layout(..), LayoutDesc(..), hunk ./XMonad.hs 42 - , workspace :: !WorkSpace -- ^ workspace list + , workspace :: !WindowSet -- ^ workspace list hunk ./XMonad.hs 50 -type WorkSpace = StackSet WorkspaceId ScreenId Window +type WindowSet = StackSet WorkspaceId ScreenId Window hunk ./Main.hs 88 - return $ not (waOverrideRedirect wa) - && waMapState wa == waIsViewable + return $ not (wa_override_redirect wa) + && wa_map_state wa == waIsViewable hunk ./Main.hs 127 -handle (KeyEvent {event_type = t, state = m, keycode = code}) +handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) hunk ./Main.hs 134 -handle (MapRequestEvent {window = w}) = withDisplay $ \dpy -> do +handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do hunk ./Main.hs 136 - when (not (waOverrideRedirect wa)) $ manage w + when (not (wa_override_redirect wa)) $ manage w hunk ./Main.hs 139 -handle (DestroyWindowEvent {window = w}) = do b <- isClient w; when b $ unmanage w +handle (DestroyWindowEvent {ev_window = w}) = do b <- isClient w; when b $ unmanage w hunk ./Main.hs 142 -handle (UnmapEvent {window = w}) = do b <- isClient w; when b $ unmanage w +handle (UnmapEvent {ev_window = w}) = do b <- isClient w; when b $ unmanage w hunk ./Main.hs 145 -handle e@(MappingNotifyEvent {window = w}) = do +handle e@(MappingNotifyEvent {ev_window = w}) = do hunk ./Main.hs 148 - let m = (request e, first_keycode e, fromIntegral $ count e) + let m = (ev_request e, ev_first_keycode e, fromIntegral $ ev_count e) hunk ./Main.hs 150 - when (request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w + when (ev_request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w hunk ./Main.hs 153 -handle (ButtonEvent {window = w, event_type = t}) +handle (ButtonEvent {ev_window = w, ev_event_type = t}) hunk ./Main.hs 158 -handle e@(CrossingEvent {window = w, event_type = t}) - | t == enterNotify && mode e == notifyNormal && detail e /= notifyInferior +handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) + | t == enterNotify && ev_mode e == notifyNormal && ev_detail e /= notifyInferior hunk ./Main.hs 163 -handle e@(CrossingEvent {event_type = t}) +handle e@(CrossingEvent {ev_event_type = t}) hunk ./Main.hs 166 - when (window e == rootw && not (same_screen e)) $ setFocus rootw + when (ev_window e == rootw && not (ev_same_screen e)) $ setFocus rootw hunk ./Main.hs 169 -handle e@(ConfigureRequestEvent {window = w}) = do +handle e@(ConfigureRequestEvent {ev_window = w}) = do hunk ./Main.hs 175 - io $ configureWindow dpy (window e) (value_mask e) $ WindowChanges - { wcX = x e - , wcY = y e - , wcWidth = width e - , wcHeight = height e - , wcBorderWidth = border_width e - , wcSibling = above e + io $ configureWindow dpy (ev_window e) (ev_value_mask e) $ WindowChanges + { wc_x = ev_x e + , wc_y = ev_y e + , wc_width = ev_width e + , wc_height = ev_height e + , wc_border_width = ev_border_width e + , wc_sibling = ev_above e hunk ./Main.hs 184 - , wcStackMode = fromIntegral $ detail e + , wc_stack_mode = fromIntegral $ ev_detail e hunk ./Operations.hs 149 - bw <- (fromIntegral . waBorderWidth) `liftM` getWindowAttributes d w + bw <- (fromIntegral . wa_border_width) `liftM` getWindowAttributes d w hunk ./StackSet.hs 28 - toList, size, visibleWorkspaces + toList, size, visibleWorkspaces, swap {- helper -} hunk ./StackSet.hs 222 - return $ insert a (current w) w' -- and maintain focus + return $ insert a (current w) w' -- and maintain focus (?) hunk ./StackSet.hs 228 +-- Given a set as a list (no duplicates) +-- +-- > swap a b . swap a b == id +-- hunk ./XMonad.hs 1 +{-# OPTIONS -fglasgow-exts #-} hunk ./tests/Properties.hs 4 +import Operations (tile,vtile) hunk ./tests/Properties.hs 6 +import Debug.Trace +import Data.Word +import Graphics.X11.Xlib.Types (Rectangle(..),Position,Dimension) +import Data.Ratio hunk ./tests/Properties.hs 66 +prop_peek_peekStack n x = + if current x == n then peekStack n x == peek x + else True -- so we don't exhaust + where _ = x :: T + +prop_notpeek_peekStack n x = current x /= n && isJust (peek x) ==> peekStack n x /= peek x + where _ = x :: T + +------------------------------------------------------------------------ + hunk ./tests/Properties.hs 81 +prop_delete_push i x = not (member i x) ==> delete i (push i x) == x + where _ = x :: T + hunk ./tests/Properties.hs 88 +prop_focus1 i x = member i x ==> peek (raiseFocus i x) == Just i + where _ = x :: T + hunk ./tests/Properties.hs 127 + +prop_swap a b xs = swap a b (swap a b ys) == ys + where ys = nub xs :: [Int] + hunk ./tests/Properties.hs 138 -prop_promotefocus x = focus (promote x) == focus x +prop_promotefocus x = focus (promote x) == focus x hunk ./tests/Properties.hs 142 -prop_promotecurrent x = current (promote x) == current x +prop_promotecurrent x = current (promote x) == current x + where _ = x :: T + +-- the physical screen doesn't change +prop_promotescreen n x = screen n (promote x) == screen n x hunk ./tests/Properties.hs 154 +------------------------------------------------------------------------ +-- some properties for layouts: + +-- 1 window should always be tiled fullscreen +prop_tile_fullscreen rect = tile pct rect [1] == [(1, rect)] + +prop_vtile_fullscreen rect = vtile pct rect [1] == [(1, rect)] + +-- multiple windows +prop_tile_non_overlap rect windows = noOverlaps (tile pct rect windows) + where _ = rect :: Rectangle + +prop_vtile_non_overlap rect windows = noOverlaps (vtile pct rect windows) + where _ = rect :: Rectangle + +pct = 3 % 100 + +noOverlaps [] = True +noOverlaps [_] = True +noOverlaps xs = and [ verts a `notOverlap` verts b + | (_,a) <- xs + , (_,b) <- filter (\(_,b) -> a /= b) xs + ] + where + verts (Rectangle a b w h) = (a,b,a + fromIntegral w - 1, b + fromIntegral h - 1) + + notOverlap (left1,bottom1,right1,top1) + (left2,bottom2,right2,top2) + = (top1 < bottom2 || top2 < bottom1) + || (right1 < left2 || right2 < left1) + + +------------------------------------------------------------------------ + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word8 where + arbitrary = choose (minBound,maxBound) + coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + +instance Arbitrary Position where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Dimension where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Rectangle where + arbitrary = do + sx <- arbitrary + sy <- arbitrary + sw <- arbitrary + sh <- arbitrary + return $ Rectangle sx sy sw sh + +instance Arbitrary Rational where + arbitrary = do + n <- arbitrary + d' <- arbitrary + let d = if d' == 0 then 1 else d' + return (n % d) + coarbitrary = undefined + hunk ./tests/Properties.hs 239 + hunk ./tests/Properties.hs 244 + hunk ./tests/Properties.hs 248 + + ,("peek/peekStack" , mytest prop_peek_peekStack) + ,("not . peek/peekStack", mytest prop_notpeek_peekStack) + hunk ./tests/Properties.hs 254 + ,("delete.push identity" , mytest prop_delete_push) + + ,("focus", mytest prop_focus1) + hunk ./tests/Properties.hs 259 + hunk ./tests/Properties.hs 270 + ,("promote/screen" , mytest prop_promotescreen) + + ,("swap", mytest prop_swap) + +------------------------------------------------------------------------ + + ,("tile 1 window fullsize", mytest prop_tile_fullscreen) + ,("vtile 1 window fullsize", mytest prop_vtile_fullscreen) + ,("vtiles never overlap", mytest prop_vtile_non_overlap ) + hunk ./TODO 2 - * CRITICAL: fix killClient code. see for example, xclock. - - more quickchecks (layout algorithm is one candidate) hunk ./TODO 3 - - testing + hunk ./tests/Properties.hs 194 + coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) + +instance Random Word64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word64 where + arbitrary = choose (minBound,maxBound) hunk ./TODO 6 - -- let mod+enter demote a master window hunk ./TODO 1 -- Tasks blocking xmonad 0.1 - - website, xmonad.org - - - - hunk ./xmonad.cabal 2 -version: 0.0 +version: 0.1 hunk ./README 16 + X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.0 + mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-1.0 hunk ./README 21 - - mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-1.0 - unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 (included with ghc) - - X11-extras: darcs get http://darcs.haskell.org/~sjanssen/X11-extras + unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 + (included with ghc) hunk ./README 42 + Jason Creigh hunk ./TODO 1 +- tasks for xmonad 0.2 + - fix the numlock issue once and for all + hunk ./TODO 3 + - man page + +- possibles: + - external statusbar + - floating layer/transients + - more example layout algorithms implemented via config.hs + - more work stabilising and documenting the api + - set up trac? + - get 'design and impl' TR done. + +- related: + - xcb bindings + - randr hunk ./TODO 34 + hunk ./README 42 - Jason Creigh + Jason Creighton hunk ./Operations.hs 162 + setWindowBorderWidth d w 1 hunk ./Main.hs 131 - whenJust (M.lookup (m,s) keys) id + whenJust (M.lookup (complement numlockMask .&. m,s) keys) id hunk ./Config.hs 104 +-- You can find the numlock modifier by running "xmodmap" and looking for a +-- modifier with Num_Lock bound to it. hunk ./Config.hs 107 -numlockMask = lockMask +numlockMask = mod2Mask hunk ./Main.hs 97 - mapM_ (grab kc) [mask, mask .|. numlockMask] -- note: no numlock + mapM_ (grab kc) [mask, mask .|. numlockMask, mask .|. lockMask, mask .|. numlockMask .|. lockMask] hunk ./Main.hs 131 - whenJust (M.lookup (complement numlockMask .&. m,s) keys) id + whenJust (M.lookup (complement (numlockMask .|. lockMask) .&. m,s) keys) id hunk ./StackSet.hs 28 - toList, size, visibleWorkspaces, swap {- helper -} + size, visibleWorkspaces, swap {- helper -} hunk ./StackSet.hs 47 - } deriving Eq - -instance (Show i, Show a) => Show (StackSet i j a) where - showsPrec p s r = showsPrec p (show . toList $ s) r + } deriving (Eq, Show) hunk ./StackSet.hs 99 --- | toList. Flatten a stackset to a list of lists -toList :: StackSet i j a -> (i,Int,[[a]]) -toList x = (current x, M.size $ screen2ws x, map snd $ M.toList (stacks x)) - hunk ./tests/Properties.hs 38 -prop_id x = fromList (toList x) == x - where _ = x :: T - hunk ./tests/Properties.hs 243 - [("read.show ", mytest prop_id) - - ,("member/push ", mytest prop_member1) + [("member/push ", mytest prop_member1) adddir ./man addfile ./man/xmonad.1 hunk ./man/xmonad.1 1 +./" man page created by David Lazar on April 24, 2007 +./" uses ``tmac.an'' macro set +.TH xmonad 1 "18 April 07" xmonad\-1.0 "xmonad manual" +.SH NAME +xmonad \- a tiling window manager +.SH DESCRIPTION +.PP +\fBxmonad\fR is a minimalist tiling window manager for X, written in Haskell. Windows are managed using automatic layout algorithms, which can be dynamically reconfigured. At any time windows are arranged so as to maximise the use of screen real estate. All features of the window manager are accessible purely from the keyboard: a mouse is entirely optional. \fBxmonad\fR is configured in Haskell, and custom layout algorithms may be implemented by the user in config files. A principle of \fBxmonad\fR is predictability: the user should know in advance precisely the window arrangement that will result from any action. +.PP +By default, \fBxmonad\fR provides three layout algorithms: tall, wide and fullscreen. In tall or wide mode, windows are tiled and arranged to prevent overlap and maximise screen use. Sets of windows are grouped together on virtual screens, and each screen retains its own layout, which may be reconfigured dynamically. Multiple physical monitors are supported via Xinerama, allowing simultaneous display of a number of screens. +.PP +By utilising the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 500 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. +.SH USAGE +.PP +\fBxmonad\fR places each window into a "workspace". Each workspace can have any number of windows, which you can cycle though with mod-j and mod-k. Windows are either displayed full screen, tiled horizontally, or tiled vertically. You can toggle the layout mode with mod-space, which will cycle through the available modes. +.PP +You can switch to workspace N with mod-N. For example, to switch to workspace 5, you would press mod-5. Similarly, you can move the current window to another workspace with mod-shift-N. +.PP +When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. If you switch to a workspace which is currently visible on another screen, \fBxmonad\fR simply switches focus to that screen. If you switch to a workspace which is *not* visible, \fBxmonad\fR replaces the workspace on the *current* screen with the workspace you selected. +.PP +For example, if you have the following configuration: +.RS +.PP +Screen 1: Workspace 2 +.PP +Screen 2: Workspace 5 (current workspace) +.RE +.PP +and you wanted to view workspace 7 on screen 1, you would press: +.RS +.PP +mod-2 (to select workspace 2, and make screen 1 the current screen) +.PP +mod-7 (to select workspace 7) +.RE +.PP +Since switching to the workspace currently visible on a given screen is such a common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace currently visible on screens 1, 2, and 3 respectively. Likewise, shift-mod-{w,e,r} moves the current window to the workspace on that screen. Using these keys, the above example would become mod-w mod-7. +.SS Default keyboard bindings +.IP \fBmod\-shift\-return\fR +Launch \fBxterm\fR. +.IP \fBmod\-p\fR +Launch \fBdmenu\fR. +.IP \fBmod\-shift\-p\fR +Launch \fBgmrun\fR. +.IP \fBmod\-space\fR +Switch tiling mode. +.IP "\fBmod\-j\fR or \fBmod\-tab\fR" +Focus next window in stack. +.IP \fBmod\-k\fR +Focus previous window in stack. +.IP \fBmod\-h\fR +Decrease the size of the master area. +.IP \fBmod\-l\fR +Increase the size of the master area. +.IP \fBmod\-shift\-c\fR +Kill client. +.IP \fBmod\-shift\-q\fR +Exit xmonad window manager. +.IP \fBmod\-shift\-ctrl\-q\fR +Restart xmonad window manager. +.IP \fBmod\-return\fR +Cycle the current tiling order. +.IP \fBmod\-[1..9]\fR +Switch to workspace N. +.IP \fBmod\-shift\-[1..9]\fR +Move client to workspace N. +.IP \fBmod\-[w,e,r]\fR +Switch to physical/Xinerama screen 1, 2 or 3. +.SH EXAMPLES +To use \fBxmonad\fR as your window manager add: +.RS +exec xmonad +.RE +to your \fI~/.xinitrc\fR file +.SH CUSTOMIZATION +\fBxmonad\fR is customized by creating a custom Config.hs and (re)compiling the source code. +.SH BUGS +NumLock handling is broken. hunk ./xmonad.cabal 11 -extra-source-files: README TODO tests/loc.hs tests/Properties.hs +extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1 hunk ./Config.hs 142 - [((m .|. modMask, xK_0 + fromIntegral i), f (fromIntegral (pred i))) -- index from 0. - | i <- [1 .. workspaces] + [((m .|. modMask, k), f (fromIntegral (pred i))) -- index from 0. + | (i, k) <- zip [1 .. workspaces] [xK_1 ..] hunk ./Config.hs 142 - [((m .|. modMask, k), f (fromIntegral (pred i))) -- index from 0. - | (i, k) <- zip [1 .. workspaces] [xK_1 ..] + [((m .|. modMask, k), f i) + | (i, k) <- zip [0 .. fromIntegral workspaces - 1] [xK_1 ..] hunk ./Main.hs 97 - mapM_ (grab kc) [mask, mask .|. numlockMask, mask .|. lockMask, mask .|. numlockMask .|. lockMask] + -- "If the specified KeySym is not defined for any KeyCode, + -- XKeysymToKeycode() returns zero." + when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) $ [0, numlockMask, lockMask, numlockMask .|. lockMask] hunk ./StackSet.hs 27 - raiseFocus, rotate, promote, shift, view, workspace, fromList, + raiseFocus, rotate, promote, shift, view, workspace, insert, hunk ./StackSet.hs 32 -import qualified Data.List as L (delete,genericLength,elemIndex) -import qualified Data.Map as M +import qualified Data.List as L (delete,elemIndex) +import qualified Data.Map as M hunk ./StackSet.hs 82 --- | fromList. Build a new StackSet from a list of list of elements, --- keeping track of the currently focused workspace, and the total --- number of workspaces. If there are duplicates in the list, the last --- occurence wins. -fromList :: (Integral i, Integral j, Ord a) => (i, Int,[[a]]) -> StackSet i j a -fromList (_,_,[]) = error "Cannot build a StackSet from an empty list" - -fromList (n,m,xs) | n < 0 || n >= L.genericLength xs - = error $ "Cursor index is out of range: " ++ show (n, length xs) - | m < 1 || m > L.genericLength xs - = error $ "Can't have more screens than workspaces: " ++ show (m, length xs) - -fromList (o,m,xs) = view o $ foldr (\(i,ys) s -> - foldr (\a t -> insert a i t) s ys) - (empty (length xs) m) (zip [0..] xs) - - hunk ./tests/Properties.hs 18 -import Data.List (nub,sort,group,sort,intersperse) +import Data.List (nub,sort,group,sort,intersperse,genericLength) hunk ./tests/Properties.hs 24 + +-- | fromList. Build a new StackSet from a list of list of elements, +-- keeping track of the currently focused workspace, and the total +-- number of workspaces. If there are duplicates in the list, the last +-- occurence wins. +fromList :: (Integral i, Integral j, Ord a) => (i, Int,[[a]]) -> StackSet i j a +fromList (_,_,[]) = error "Cannot build a StackSet from an empty list" + +fromList (n,m,xs) | n < 0 || n >= genericLength xs + = error $ "Cursor index is out of range: " ++ show (n, length xs) + | m < 1 || m > genericLength xs + = error $ "Can't have more screens than workspaces: " ++ show (m, length xs) + +fromList (o,m,xs) = view o $ foldr (\(i,ys) s -> + foldr (\a t -> insert a i t) s ys) + (empty (length xs) m) (zip [0..] xs) + +-- --------------------------------------------------------------------- + hunk ./xmonad.cabal 3 +homepage: http://xmonad.org hunk ./StackSet.hs 28 - size, visibleWorkspaces, swap {- helper -} + visibleWorkspaces, swap {- helper -} hunk ./StackSet.hs 54 --- | /O(n)/. Create a new empty stacks of size 'n', indexed from 0, with 'm' --- screens. (also indexed from 0) The 0-indexed stack will be current. +-- | /O(n)/. Create a new stackset, of empty stacks, of size 'n', +-- indexed from 0, with 'm' screens. (also indexed from 0) The 0-indexed +-- stack will be current. hunk ./StackSet.hs 78 -size :: StackSet i j a -> Int -size = M.size . stacks +-- size :: StackSet i j a -> Int +-- size = M.size . stacks hunk ./StackSet.hs 110 --- view n w | n >= 0 && n < fromIntegral (M.size (stacks w)) -- coerce - hunk ./StackSet.hs 117 - , current = n - } + , current = n } hunk ./tests/Properties.hs 20 +import qualified Data.Map as M hunk ./tests/Properties.hs 44 +-- | /O(n)/. Number of stacks +size :: T -> Int +size = M.size . stacks + hunk ./StackSet.hs 146 - ea <- case o of - EQ -> Nothing - GT -> elemAfter f s - LT -> elemAfter f (reverse s) + ea <- case o of EQ -> Nothing + _ -> elemAfter f (if o == GT then s else reverse s) hunk ./StackSet.hs 205 -swap a b xs - | a == b = xs -- do nothing - | Just ai <- L.elemIndex a xs - , Just bi <- L.elemIndex b xs = insertAt bi a (insertAt ai b xs) - where - insertAt n x ys = as ++ x : tail bs - where (as,bs) = splitAt n ys - +swap a b xs | a == b = xs -- do nothing + | Just ai <- L.elemIndex a xs + , Just bi <- L.elemIndex b xs = insertAt bi a (insertAt ai b xs) + where insertAt n x ys = as ++ x : tail bs + where (as,bs) = splitAt n ys hunk ./StackSet.hs 172 -delete k w = maybe w tweak (M.lookup k (cache w)) +delete k w = maybe w del (M.lookup k (cache w)) hunk ./StackSet.hs 174 - tweak i = w { cache = M.delete k (cache w) - , stacks = M.adjust (L.delete k) i (stacks w) - , focus = M.update (\k' -> if k == k' then elemAfter k (stacks w M.! i) - else Just k') i - (focus w) - } + del i = w { cache = M.delete k (cache w) + , stacks = M.adjust (L.delete k) i (stacks w) + , focus = M.update (\k' -> if k == k' then elemAfter k (stacks w M.! i) + else Just k') i (focus w) } hunk ./StackSet.hs 155 -shift n w = maybe w (\k -> insert k n (delete k w)) (peek w) +shift n w = maybe w (\k -> insert k n w) (peek w) hunk ./tests/Properties.hs 62 -prop_member1 i n m = member i (push i x) +prop_member1 i n m = n > 0 && m > 0 ==> member i (push i x) hunk ./Config.hs 109 +-- Border colors for unfocused and focused windows, respectively. +normalBorderColor, focusedBorderColor :: String +normalBorderColor = "#dddddd" +focusedBorderColor = "#ff0000" + hunk ./Main.hs 38 + initcolor c = fst `liftM` allocNamedColor dpy (defaultColormap dpy dflt) c + hunk ./Main.hs 44 + nbc <- initcolor normalBorderColor + fbc <- initcolor focusedBorderColor hunk ./Main.hs 59 + , normalBorder = nbc + , focusedBorder = fbc hunk ./Operations.hs 192 - ws <- gets workspace + XState { workspace = ws, display = dpy + , normalBorder = nbc, focusedBorder = fbc } <- get hunk ./Operations.hs 199 - setBorder otherw 0xdddddd + io $ setWindowBorder dpy otherw (color_pixel nbc) hunk ./Operations.hs 203 - setBorder w 0xff0000 -- make this configurable + io $ setWindowBorder dpy w (color_pixel fbc) hunk ./Operations.hs 217 --- | Set the border color for a particular window. -setBorder :: Window -> Pixel -> X () -setBorder w p = withDisplay $ \d -> io $ setWindowBorder d w p - hunk ./XMonad.hs 49 + , normalBorder :: !Color -- ^ border color of unfocused windows + , focusedBorder :: !Color -- ^ border color of the focused window hunk ./Operations.hs 21 -import Control.Arrow +import Control.Arrow (second) hunk ./Main.hs 24 +import Control.Monad.Reader hunk ./Main.hs 48 - let st = XState + let cf = XConf hunk ./Main.hs 57 - , workspace = W.empty workspaces (length xinesc) hunk ./Main.hs 58 - , layoutDescs = M.empty hunk ./Main.hs 61 + st = XState + { workspace = W.empty workspaces (length xinesc) + , layoutDescs = M.empty + } hunk ./Main.hs 79 - runX st $ do + runX cf st $ do hunk ./Main.hs 176 - = do rootw <- gets theRoot + = do rootw <- asks theRoot hunk ./Main.hs 181 - XState { display = dpy, workspace = ws } <- get + dpy <- asks display + ws <- gets workspace hunk ./Operations.hs 21 +import Control.Monad.Reader hunk ./Operations.hs 43 - XState {workspace = ws, xineScreens = xinesc - ,display = d ,layoutDescs = fls ,defaultLayoutDesc = dfltfl } <- get + XState { workspace = ws, layoutDescs = fls } <- get + XConf { xineScreens = xinesc, display = d, defaultLayoutDesc = dfltfl } <- ask hunk ./Operations.hs 61 - d <- gets display + d <- asks display hunk ./Operations.hs 107 + dfl <- asks defaultLayoutDesc hunk ./Operations.hs 111 - fl = M.findWithDefault (defaultLayoutDesc s) n fls + fl = M.findWithDefault dfl n fls hunk ./Operations.hs 126 - (sw,sh) <- gets dimensions + (sw,sh) <- asks dimensions hunk ./Operations.hs 194 - XState { workspace = ws, display = dpy - , normalBorder = nbc, focusedBorder = fbc } <- get + ws <- gets workspace + XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask hunk ./Operations.hs 217 - Nothing -> gets theRoot >>= setFocus + Nothing -> asks theRoot >>= setFocus hunk ./Operations.hs 234 - XState {wmdelete = wmdelt, wmprotocols = wmprot} <- get + XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask hunk ./XMonad.hs 19 - X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), Layout(..), LayoutDesc(..), - runX, io, withDisplay, isRoot, spawn, trace, whenJust, rotateLayout + X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), XConf(..), Layout(..), + LayoutDesc(..), runX, io, withDisplay, isRoot, spawn, trace, whenJust, rotateLayout hunk ./XMonad.hs 26 +import Control.Monad.Reader hunk ./XMonad.hs 37 + { workspace :: !WindowSet -- ^ workspace list + , layoutDescs :: !(M.Map WorkspaceId LayoutDesc) -- ^ mapping of workspaces + } + +data XConf = XConf hunk ./XMonad.hs 49 - , workspace :: !WindowSet -- ^ workspace list hunk ./XMonad.hs 52 - , layoutDescs :: !(M.Map WorkspaceId LayoutDesc) -- ^ mapping of workspaces hunk ./XMonad.hs 69 -newtype X a = X (StateT XState IO a) - deriving (Functor, Monad, MonadIO, MonadState XState) +newtype X a = X (ReaderT XConf (StateT XState IO) a) + deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf) hunk ./XMonad.hs 74 -runX :: XState -> X a -> IO () -runX st (X a) = runStateT a st >> return () +runX :: XConf -> XState -> X a -> IO () +runX c st (X a) = runStateT (runReaderT a c) st >> return () hunk ./XMonad.hs 82 -withDisplay f = gets display >>= f +withDisplay f = asks display >>= f hunk ./XMonad.hs 86 -isRoot w = liftM (w==) (gets theRoot) +isRoot w = liftM (w==) (asks theRoot) hunk ./tests/Properties.hs 175 +-- push shouldn't change anything but the current workspace +prop_push_local (x :: T) i = not (member i x) ==> hidden x == hidden (push i x) + where + hidden w = [ index n w | n <- [0 ..sz-1], n /= current w ] + sz = M.size (stacks x) + + hunk ./tests/Properties.hs 282 + ,("push is local" , mytest prop_push_local) hunk ./tests/Properties.hs 62 +-- empty StackSets have no windows in them +prop_empty n m = n > 0 && m > 0 ==> all null (M.elems (stacks x)) + where x = empty n m :: T + +-- empty StackSets always have focus on workspace 0 +prop_empty_current n m = n > 0 && m > 0 ==> current x == 0 + where x = empty n m :: T + + hunk ./tests/Properties.hs 283 - [("member/push ", mytest prop_member1) + [("empty is empty" , mytest prop_empty) + ,("empty / current" , mytest prop_empty_current) + + ,("member/push ", mytest prop_member1) hunk ./tests/Properties.hs 70 - hunk ./tests/Properties.hs 87 +prop_push_idem i (x :: T) = push i x == push i (push i x) + hunk ./tests/Properties.hs 296 + ,("idempotent push" , mytest prop_push_idem) hunk ./tests/Properties.hs 122 -prop_rotaterotate x = rotate LT (rotate GT x) == x - where _ = x :: T +-- rotation is reversible in two directions +prop_rotaterotate1 (x :: T) = rotate LT (rotate GT x) == x +prop_rotaterotate2 (x :: T) = rotate GT (rotate LT x) == x + +-- rotation through the height of a stack gets us back to the start +prop_rotate_all (x :: T) = foldr (\_ y -> rotate GT y) x [1..n] == x + where + n = height (current x) x + hunk ./tests/Properties.hs 140 +prop_view_idem (x :: T) r = + let i = fromIntegral $ r `mod` sz + sz = size x + in view i (view i x) == (view i x) + hunk ./tests/Properties.hs 319 - ,("rotate/rotate ", mytest prop_rotaterotate) + ,("rotate l >> rotate r", mytest prop_rotaterotate1) + ,("rotate r >> rotate l", mytest prop_rotaterotate2) + ,("rotate all", mytest prop_rotate_all) hunk ./tests/Properties.hs 324 + ,("view idem ", mytest prop_view_idem) + hunk ./tests/Properties.hs 145 -prop_shiftshift r x = - let n = current x - in shift n (shift r x) == x - where _ = x :: T +prop_shift_reversible r (x :: T) = + let i = fromIntegral $ r `mod` sz + sz = size x + n = current x + in height n x > 0 ==> (view n . shift n . view i . shift i) x == x + hunk ./tests/Properties.hs 328 + ,("shift reversible ", mytest prop_shift_reversible) + hunk ./XMonad.hs 39 + -- to descriptions of their layouts hunk ./XMonad.hs 53 - -- to descriptions of their layouts hunk ./XMonad.hs 43 - { display :: Display -- ^ the X11 display + { display :: Display -- ^ the X11 display hunk ./XMonad.hs 45 - , theRoot :: !Window -- ^ the root window - , wmdelete :: !Atom -- ^ window deletion atom - , wmprotocols :: !Atom -- ^ wm protocols atom - , dimensions :: !(Int,Int) -- ^ dimensions of the screen, - -- used for hiding windows + , theRoot :: !Window -- ^ the root window + , wmdelete :: !Atom -- ^ window deletion atom + , wmprotocols :: !Atom -- ^ wm protocols atom + , dimensions :: !(Int,Int) -- ^ dimensions of the screen, + -- used for hiding windows hunk ./XMonad.hs 51 - , xineScreens :: ![Rectangle] -- ^ dimensions of each screen - , defaultLayoutDesc :: !LayoutDesc -- ^ default layout - , normalBorder :: !Color -- ^ border color of unfocused windows - , focusedBorder :: !Color -- ^ border color of the focused window + , xineScreens :: ![Rectangle] -- ^ dimensions of each screen + , defaultLayoutDesc :: !LayoutDesc -- ^ default layout + , normalBorder :: !Color -- ^ border color of unfocused windows + , focusedBorder :: !Color -- ^ border color of the focused window hunk ./Config.hs 117 -startingLayoutDesc :: LayoutDesc -startingLayoutDesc = +defaultLayoutDesc :: LayoutDesc +defaultLayoutDesc = addfile ./Config.hs-boot hunk ./Config.hs-boot 1 +module Config where +import XMonad (LayoutDesc) +defaultLayoutDesc :: LayoutDesc hunk ./Main.hs 57 - , defaultLayoutDesc = startingLayoutDesc hunk ./Operations.hs 32 +import {-# SOURCE #-} Config hunk ./Operations.hs 45 - XConf { xineScreens = xinesc, display = d, defaultLayoutDesc = dfltfl } <- ask + XConf { xineScreens = xinesc, display = d } <- ask hunk ./Operations.hs 49 - fl = M.findWithDefault dfltfl n fls + fl = M.findWithDefault defaultLayoutDesc n fls hunk ./Operations.hs 108 - dfl <- asks defaultLayoutDesc hunk ./Operations.hs 111 - fl = M.findWithDefault dfl n fls + fl = M.findWithDefault defaultLayoutDesc n fls hunk ./XMonad.hs 52 - , defaultLayoutDesc :: !LayoutDesc -- ^ default layout hunk ./Config.hs 114 +-- Width of the window border in pixels +borderWidth :: Dimension +borderWidth = 1 + hunk ./Config.hs-boot 3 +import Graphics.X11.Xlib.Types (Dimension) hunk ./Config.hs-boot 5 +borderWidth :: Dimension hunk ./Operations.hs 164 - setWindowBorderWidth d w 1 + setWindowBorderWidth d w borderWidth hunk ./tests/Properties.hs 62 +-- Invariants: +-- +-- * no element should ever appear more than once in a StackSet +-- * the current index should always be valid +-- +-- All operations must preserve this. +-- +invariant (w :: T) = inBounds w && noDuplicates (concat $ M.elems (stacks w)) + where + noDuplicates ws = nub ws == ws + inBounds x = current x >= 0 && current x < sz where sz = M.size (stacks x) + +-- test generator +prop_invariant = invariant + + hunk ./tests/Properties.hs 314 - [("empty is empty" , mytest prop_empty) + [("StackSet invariants", mytest prop_invariant) + ,("empty is empty" , mytest prop_empty) hunk ./xmonad.cabal 17 -ghc-options: -funbox-strict-fields -O2 -Wall -optl-Wl,-s +ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s hunk ./xmonad.cabal 4 -description: A lightweight X11 window manager. hunk ./xmonad.cabal 5 +description: + Xmonad is a minimalist tiling window manager for X, written in + Haskell. Windows are managed using automatic layout algorithms, + which can be dynamically reconfigured. At any time windows are + arranged so as to maximise the use of screen real estate. All + features of the window manager are accessible purely from the + keyboard: a mouse is entirely optional. Xmonad is configured in + Haskell, and custom layout algorithms may be implemented by the user + in config files. A principle of Xmonad is predictability: the user + should know in advance precisely the window arrangement that will + result from any action. hunk ./README 16 - X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.0 + X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.1 hunk ./README 16 - X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.1 hunk ./README 20 + X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.1 hunk ./README 1 - xmonad : a lightweight X11 window manager. + xmonad : a lightweight X11 window manager. hunk ./README 3 -Motivation: + http://xmonad.org hunk ./README 5 - dwm is great, but we can do better, building a more robust, - more correct window manager in fewer lines of code, using strong - static typing. Enter Haskell. +About: hunk ./README 7 - If the aim of dwm is to fit in under 2000 lines of C, the aim of - xmonad is to fit in under 500 lines of Haskell with similar functionality. +Xmonad is a minimalist tiling window manager for X, written in Haskell. Windows +are managed using automatic layout algorithms, which can be dynamically +reconfigured. At any time windows are arranged so as to maximise the use of +screen real estate. All features of the window manager are accessible purely +from the keyboard: a mouse is entirely optional. Xmonad is configured in +Haskell, and custom layout algorithms may be implemented by the user in config +files. A principle of Xmonad is predictability: the user should know in advance +precisely the window arrangement that will result from any action. + +By default xmonad provides three layout algorithms: tall, wide and fullscreen. +In tall or wide mode, windows are tiled and arranged to prevent overlap and +maximise screen use. Sets of windows are grouped together on virtual screens, +and each screen retains its own layout, which may be reconfigured dynamically. +Multiple physical monitors are supported via Xinerama, allowing simultaneous +display of a number of screens. + +By utilising the expressivity of a modern functional language with a rich +static type system, Xmonad provides a complete, featureful window manager in +less than 500 lines of code, with an emphasis on correctness and robustness. +Internal properties of the window manager are checked using a combination of +static guarantees provided by the type system, and type-based automated +testing. A benefit of this is that the code is simple to understand, and easy +to modify. hunk ./README 33 - Get the dependencies +Get the dependencies hunk ./README 43 - dmenu 2.{5,6,7} http://www.suckless.org/download/dmenu-2.7.tar.gz + dmenu 2.* http://www.suckless.org/download/dmenu-2.7.tar.gz + (optional) hunk ./README 52 -Then add: +Finally, add: hunk ./StackSet.hs 41 - { current :: !i -- ^ the currently visible stack - , screen2ws:: !(M.Map j i) -- ^ screen -> workspace - , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map - , stacks :: !(M.Map i [a]) -- ^ the separate stacks - , focus :: !(M.Map i a) -- ^ the window focused in each stack - , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks + { current :: !i -- ^ the currently visible stack + , screen2ws:: !(M.Map j i) -- ^ screen -> workspace + , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map + , stacks :: !(M.Map i ([a], [a])) -- ^ screen -> (floating, normal) + , focus :: !(M.Map i a) -- ^ the window focused in each stack + , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks hunk ./StackSet.hs 61 - , stacks = M.fromList (zip [0..fromIntegral n-1] (repeat [])) + , stacks = M.fromList (zip [0..fromIntegral n-1] (repeat ([], []))) hunk ./StackSet.hs 103 -index k w = fromJust (M.lookup k (stacks w)) +index k w = uncurry (++) $ fromJust $ M.lookup k (stacks w) hunk ./StackSet.hs 145 - s <- M.lookup (current w) (stacks w) + s <- fmap (uncurry (++)) $ M.lookup (current w) (stacks w) hunk ./StackSet.hs 164 - , stacks = M.adjust (k:) n (stacks new) + , stacks = M.adjust (\(f, ks) -> (f, k:ks)) n (stacks new) hunk ./StackSet.hs 175 - , stacks = M.adjust (L.delete k) i (stacks w) - , focus = M.update (\k' -> if k == k' then elemAfter k (stacks w M.! i) + , stacks = M.adjust (\(xs, ys) -> (L.delete k xs, L.delete k ys)) i (stacks w) + , focus = M.update (\k' -> if k == k' then elemAfter k (index i w) hunk ./StackSet.hs 191 - let w' = w { stacks = M.adjust (\s -> swap a (head s) s) (current w) (stacks w) } + let w' = w { stacks = M.adjust (\(f, s) -> (f, swap a (head s) s)) (current w) (stacks w) } hunk ./StackSet.hs 194 --- hunk ./StackSet.hs 216 +-- | Returns true if the window is in the floating layer +isFloat :: (Ord a, Ord i) => a -> StackSet i j a -> Bool +isFloat k w = maybe False (elem k . fst . (stacks w M.!)) (M.lookup k (cache w)) + hunk ./tests/Properties.hs 170 - allvals = sort . concat . elems $ stacks x + allvals = sort . concat . map (uncurry (++)) . elems $ stacks x hunk ./tests/Properties.hs 69 -invariant (w :: T) = inBounds w && noDuplicates (concat $ M.elems (stacks w)) +invariant (w :: T) = inBounds w && noDuplicates allWindows hunk ./tests/Properties.hs 71 + allWindows = concatMap (uncurry (++)) . M.elems . stacks $ w hunk ./tests/Properties.hs 80 -prop_empty n m = n > 0 && m > 0 ==> all null (M.elems (stacks x)) +prop_empty n m = n > 0 && m > 0 ==> all (null . uncurry (++)) (M.elems (stacks x)) hunk ./Config.hs 133 + + -- 'nudge': resize viewed windows to the correct size. + , ((modMask, xK_n ), refresh) changepref test cd tests && ghc --make loc && cat ../StackSet.hs ../XMonad.hs ../Operations.hs ../Config.hs ../Main.hs | ./loc runghc tests/Properties.hs && cat *.hs | runghc tests/loc.hs hunk ./Main.hs 156 - -- this fromIntegral is only necessary with the old X11 version that uses - -- Int instead of CInt. TODO delete it when there is a new release of X11 - let m = (ev_request e, ev_first_keycode e, fromIntegral $ ev_count e) - withDisplay $ \d -> io $ refreshKeyboardMapping d m + io $ refreshKeyboardMapping e hunk ./Config.hs 11 ------------------------------------------------------------------------------ +------------------------------------------------------------------------ +-- +-- This module specifies configurable defaults for xmonad. If you change +-- values here, be sure to recompile and restart (mod-shift-ctrl-q) xmonad, +-- for the changes to take effect. +-- hunk ./Config.hs 30 +-- mod-n nudge current window into fullscreen mode hunk ./Config.hs 32 --- mod-tab raise next window in stack --- mod-j --- mod-k +-- mod-tab shift focus to next window in stack +-- mod-j shift focus to next window in stack +-- mod-k shift focus previous window in stack hunk ./Config.hs 43 --- mod-return cycle the current tiling order +-- mod-return swap focused window with master window hunk ./Config.hs 86 +-- +-- Useful imports +-- hunk ./Config.hs 97 --- The number of workspaces: +-- The number of workspaces (virtual screens) hunk ./Config.hs 101 --- modMask lets you easily change which modkey you use. The default is mod1Mask +-- modMask lets you specify which modkey you want to use. The default is mod1Mask hunk ./Config.hs 105 +-- hunk ./Config.hs 109 --- How much to change the horizontal/vertical split bar by defalut. +-- When resizing a window, this ratio specifies by what percent to +-- resize in a single step hunk ./Config.hs 114 +-- numlock handling: +-- hunk ./Config.hs 117 +-- hunk ./Config.hs 119 --- modifier with Num_Lock bound to it. +-- modifier with Num_Lock bound to it: +-- +-- $ xmodmap | grep Num +-- mod2 Num_Lock (0x4d) +-- hunk ./Config.hs 134 -borderWidth = 1 +borderWidth = 2 hunk ./Config.hs 136 --- What layout to start in, and what the default proportion for the --- left pane should be in the tiled layout. See LayoutDesc and --- friends in XMonad.hs for options. +-- A LayoutDesc specifies two things: +-- * what layout mode to use by default +-- * what default screen ratio of master/slave areas are used when tiling +-- +-- See LayoutDesc and friends in XMonad.hs for options. +-- hunk ./Config.hs 145 - , tileFraction = 1%2 } + , tileFraction = 2%3 } hunk ./Config.hs 147 --- The keys list. +-- +-- The key bindings list. +-- hunk ./tests/Properties.hs 295 + coarbitrary = undefined + hunk ./Operations.hs 45 - XConf { xineScreens = xinesc, display = d } <- ask + XConf { xineScreens = xinesc, display = d } <- ask -- neat, eh? hunk ./Operations.hs 51 + -- likely this should just dispatch on the current layout algo hunk ./Operations.hs 67 - when more again + when more again -- beautiful hunk ./Operations.hs 72 +-- Tiling algorithms in the core should satisify the constraint that +-- +-- * no windows overlap +-- * no gaps exist between windows. +-- hunk ./Operations.hs 126 - ws <- gets workspace - trace (show ws) -- log state changes to stderr + -- gets workspace >>= trace . show -- log state changes to stderr hunk ./XMonad.hs 68 +-- +-- Dynamic components may be retrieved with 'get', static components +-- with 'ask'. With newtype deriving we get readers and state monads +-- instantiated on XConf and XState automatically. +-- hunk ./XMonad.hs 104 - , tileFraction :: !Rational - } + , tileFraction :: !Rational } hunk ./Config.hs 136 --- A LayoutDesc specifies two things: --- * what layout mode to use by default --- * what default screen ratio of master/slave areas are used when tiling --- --- See LayoutDesc and friends in XMonad.hs for options. --- -defaultLayoutDesc :: LayoutDesc -defaultLayoutDesc = - LayoutDesc { layoutType = Full - , tileFraction = 2%3 } +-- The default set of Layouts: +defaultLayouts :: [Layout] +defaultLayouts = [ full, tall defaultDelta (2%3), wide defaultDelta (2%3) ] hunk ./Config.hs 157 - , ((modMask, xK_h ), changeSplit (negate defaultDelta)) - , ((modMask, xK_l ), changeSplit defaultDelta) + , ((modMask, xK_h ), layoutMsg Expand) + , ((modMask, xK_l ), layoutMsg Shrink) hunk ./Config.hs-boot 2 -import XMonad (LayoutDesc) +import XMonad (Layout) hunk ./Config.hs-boot 4 -defaultLayoutDesc :: LayoutDesc +defaultLayouts :: [Layout] hunk ./Main.hs 62 - , layoutDescs = M.empty + , layouts = M.empty hunk ./Operations.hs 1 +{-# OPTIONS -fglasgow-exts #-} hunk ./Operations.hs 19 +import Data.Dynamic ( Typeable, toDyn, fromDynamic ) hunk ./Operations.hs 46 - XState { workspace = ws, layoutDescs = fls } <- get + XState { workspace = ws, layouts = fls } <- get hunk ./Operations.hs 51 - fl = M.findWithDefault defaultLayoutDesc n fls - mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) $ - -- likely this should just dispatch on the current layout algo - case layoutType fl of - Full -> fmap (flip (,) sc) $ maybeToList $ W.peekStack n ws - Tall -> tile (tileFraction fl) sc $ W.index n ws - Wide -> vtile (tileFraction fl) sc $ W.index n ws + (l:_) = case M.findWithDefault defaultLayouts n fls of {[] -> defaultLayouts; l -> l} + mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) $ (doLayout l) sc $ W.index n ws hunk ./Operations.hs 100 -switchLayout = layout $ \fl -> fl { layoutType = rotateLayout (layoutType fl) } +switchLayout = layout rotateList where rotateList [] = [] + rotateList xs = last xs : init xs hunk ./Operations.hs 103 --- | changeSplit. Changes the window split. -changeSplit :: Rational -> X () -changeSplit delta = layout $ \fl -> - fl { tileFraction = min 1 (max 0 (tileFraction fl + delta)) } +data ShrinkOrExpand = Shrink | Expand deriving ( Typeable, Eq ) + +layoutMsg :: Typeable a => a -> X () -- FIXME: The below shouldn't refresh on Nothing +layoutMsg a = layout $ \(l:ls) -> case modifyLayout l (toDyn a) of Nothing -> l:ls + Just l' -> l':ls + +full :: Layout +full = Layout { doLayout = \sc -> map (\w -> (w,sc)), modifyLayout = const Nothing } + +tall, wide :: Rational -> Rational -> Layout +tall delta tileFrac = Layout { doLayout = \sc -> tile tileFrac sc + , modifyLayout = (fmap m) . fromDynamic } + where m Shrink = tall delta (tileFrac-delta) + m Expand = tall delta (tileFrac+delta) + +wide delta tileFrac = Layout { doLayout = \sc -> vtile tileFrac sc + , modifyLayout = (fmap m) . fromDynamic } + where m Shrink = wide delta (tileFrac-delta) + m Expand = wide delta (tileFrac+delta) hunk ./Operations.hs 125 -layout :: (LayoutDesc -> LayoutDesc) -> X () +layout :: ([Layout] -> [Layout]) -> X () hunk ./Operations.hs 128 - let fls = layoutDescs s - n = W.current . workspace $ s - fl = M.findWithDefault defaultLayoutDesc n fls - in s { layoutDescs = M.insert n (f fl) fls } + let n = W.current . workspace $ s + fl = M.findWithDefault defaultLayouts n $ layouts s + in s { layouts = M.insert n (f fl) (layouts s) } hunk ./XMonad.hs 20 - LayoutDesc(..), runX, io, withDisplay, isRoot, spawn, trace, whenJust, rotateLayout + runX, io, withDisplay, isRoot, spawn, trace, whenJust hunk ./XMonad.hs 31 +import Data.Dynamic ( Dynamic ) hunk ./XMonad.hs 39 - , layoutDescs :: !(M.Map WorkspaceId LayoutDesc) -- ^ mapping of workspaces + , layouts :: !(M.Map WorkspaceId [Layout]) -- ^ mapping of workspaces hunk ./XMonad.hs 97 -data Layout = Full | Tall | Wide deriving (Enum, Bounded, Eq) - --- | 'rot' for Layout. -rotateLayout :: Layout -> Layout -rotateLayout x = if x == maxBound then minBound else succ x - --- | A full description of a particular workspace's layout parameters. -data LayoutDesc = LayoutDesc { layoutType :: !Layout - , tileFraction :: !Rational } +data Layout = Layout { doLayout :: Rectangle -> [Window] -> [(Window, Rectangle)] + , modifyLayout :: Dynamic -> Maybe Layout } hunk ./Operations.hs 51 - (l:_) = case M.findWithDefault defaultLayouts n fls of {[] -> defaultLayouts; l -> l} + l = fromMaybe full (do (x:_) <- M.lookup n fls; return x) hunk ./StackSet.hs 1 +{-# OPTIONS -fglasgow-exts #-} + hunk ./Config.hs 134 -borderWidth = 2 +borderWidth = 1 hunk ./Config.hs 138 -defaultLayouts = [ full, tall defaultDelta (2%3), wide defaultDelta (2%3) ] +defaultLayouts = [ full, tall defaultDelta (1%2), wide defaultDelta (1%2) ] hunk ./Config.hs 157 - , ((modMask, xK_h ), layoutMsg Expand) - , ((modMask, xK_l ), layoutMsg Shrink) + , ((modMask, xK_h ), layoutMsg Shrink) + , ((modMask, xK_l ), layoutMsg Expand) hunk ./Operations.hs 100 -switchLayout = layout rotateList where rotateList [] = [] - rotateList xs = last xs : init xs +switchLayout = layout (\(x:xs) -> xs ++ [x]) hunk ./Operations.hs 85 --- | vtile. Tile vertically. -vtile :: Rational -> Rectangle -> [Window] -> [(Window, Rectangle)] -vtile r rect = map (second flipRect) . tile r (flipRect rect) +-- | Mirror a rectangle +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) hunk ./Operations.hs 89 --- | Flip rectangles around -flipRect :: Rectangle -> Rectangle -flipRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) +-- | Mirror a layout +mirrorLayout :: Layout -> Layout +mirrorLayout (Layout { doLayout = dl, modifyLayout = ml }) + = Layout { doLayout = (\sc ws -> map (second mirrorRect) $ dl (mirrorRect sc) ws) + , modifyLayout = fmap mirrorLayout . ml } hunk ./Operations.hs 119 -wide delta tileFrac = Layout { doLayout = \sc -> vtile tileFrac sc - , modifyLayout = (fmap m) . fromDynamic } - where m Shrink = wide delta (tileFrac-delta) - m Expand = wide delta (tileFrac+delta) +wide delta tileFrac = mirrorLayout (tall delta tileFrac) hunk ./tests/Properties.hs 4 -import Operations (tile,vtile) +import Operations (tile) hunk ./tests/Properties.hs 229 -prop_vtile_fullscreen rect = vtile pct rect [1] == [(1, rect)] - hunk ./tests/Properties.hs 233 -prop_vtile_non_overlap rect windows = noOverlaps (vtile pct rect windows) - where _ = rect :: Rectangle - hunk ./tests/Properties.hs 361 - ,("vtile 1 window fullsize", mytest prop_vtile_fullscreen) - ,("vtiles never overlap", mytest prop_vtile_non_overlap ) + ,("tiles never overlap", mytest prop_tile_non_overlap) hunk ./Main.hs 102 - ungrabKey dpy '\0' {-AnyKey-} anyModifier rootw + ungrabKey dpy anyKey anyModifier rootw hunk ./Operations.hs 66 --- | tile. Compute the positions for windows in horizontal layout --- mode. +------------------------------------------------------------------------ + +-- | switchLayout. Switch to another layout scheme. Switches the +-- layout of the current workspace. By convention, a window set as +-- master in Tall mode remains as master in Wide mode. When switching +-- from full screen to a tiling mode, the currently focused window +-- becomes a master. When switching back , the focused window is +-- uppermost. +-- +switchLayout :: X () +switchLayout = layout (\(x:xs) -> xs ++ [x]) -- TODO pattern match here might fail! + +-- +-- TODO, using Typeable for extensible stuff is a bit gunky. Check -- +-- 'extensible exceptions' paper for other ideas. +-- +-- Basically this thing specifies the basic operations that vary between +-- layouts. +-- +data ShrinkOrExpand = Shrink | Expand deriving (Typeable, Eq) + +layoutMsg :: Typeable a => a -> X () -- FIXME: The below shouldn't refresh on Nothing +layoutMsg a = layout $ \x@(l:ls) -> maybe x (:ls) (modifyLayout l (toDyn a)) + +-- +-- Standard layout algorithms: hunk ./Operations.hs 93 +-- fullscreen mode +-- tall mode +-- wide mode +-- +full :: Layout +tall, wide :: Rational -> Rational -> Layout + +full = Layout { doLayout = \sc ws -> [ (w,sc) | w <- ws ] + , modifyLayout = const Nothing } + +wide delta frac = mirrorLayout (tall delta frac) + +tall delta frac = Layout { doLayout = tile frac + , modifyLayout = fmap f . fromDynamic } + + where f s = tall delta ((op s) frac delta) + op Shrink = (-) ; op Expand = (+) + +-- | Mirror a rectangle +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) + +-- | Mirror a layout +mirrorLayout :: Layout -> Layout +mirrorLayout (Layout { doLayout = dl, modifyLayout = ml }) = + Layout { doLayout = \sc -> map (second mirrorRect) . dl (mirrorRect sc) + , modifyLayout = fmap mirrorLayout . ml } + +-- | tile. Compute the positions for windows in our default tiling modes hunk ./Operations.hs 130 -tile r (Rectangle sx sy sw sh) (w:s) - = (w, Rectangle sx sy (fromIntegral lw) sh) : zipWith f [sy, sy + rh ..] s +tile r (Rectangle sx sy sw sh) (w:s) = + (w, Rectangle sx sy (fromIntegral lw) sh) : zipWith f [sy, sy + rh ..] s hunk ./Operations.hs 138 --- | Mirror a rectangle -mirrorRect :: Rectangle -> Rectangle -mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) - --- | Mirror a layout -mirrorLayout :: Layout -> Layout -mirrorLayout (Layout { doLayout = dl, modifyLayout = ml }) - = Layout { doLayout = (\sc ws -> map (second mirrorRect) $ dl (mirrorRect sc) ws) - , modifyLayout = fmap mirrorLayout . ml } - --- | switchLayout. Switch to another layout scheme. Switches the --- current workspace. By convention, a window set as master in Tall mode --- remains as master in Wide mode. When switching from full screen to a --- tiling mode, the currently focused window becomes a master. When --- switching back , the focused window is uppermost. --- -switchLayout :: X () -switchLayout = layout (\(x:xs) -> xs ++ [x]) - -data ShrinkOrExpand = Shrink | Expand deriving ( Typeable, Eq ) - -layoutMsg :: Typeable a => a -> X () -- FIXME: The below shouldn't refresh on Nothing -layoutMsg a = layout $ \(l:ls) -> case modifyLayout l (toDyn a) of Nothing -> l:ls - Just l' -> l':ls - -full :: Layout -full = Layout { doLayout = \sc -> map (\w -> (w,sc)), modifyLayout = const Nothing } - -tall, wide :: Rational -> Rational -> Layout -tall delta tileFrac = Layout { doLayout = \sc -> tile tileFrac sc - , modifyLayout = (fmap m) . fromDynamic } - where m Shrink = tall delta (tileFrac-delta) - m Expand = tall delta (tileFrac+delta) - -wide delta tileFrac = mirrorLayout (tall delta tileFrac) +------------------------------------------------------------------------ hunk ./XMonad.hs 97 -data Layout = Layout { doLayout :: Rectangle -> [Window] -> [(Window, Rectangle)] +-- 'doLayout', a pure function to layout a Window set +-- 'modifyLayout', +data Layout = Layout { doLayout :: Rectangle -> [Window] -> [(Window, Rectangle)] hunk ./Main.hs 48 - let cf = XConf + let safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x, xs) + cf = XConf hunk ./Main.hs 63 - , layouts = M.empty + , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] hunk ./Operations.hs 50 - let sc = genericIndex xinesc scn -- temporary coercion! - l = fromMaybe full (do (x:_) <- M.lookup n fls; return x) + let sc = genericIndex xinesc scn -- temporary coercion! + (Just l) = fmap fst $ M.lookup n fls hunk ./Operations.hs 76 -switchLayout = layout (\(x:xs) -> xs ++ [x]) -- TODO pattern match here might fail! +switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] + in (head xs', tail xs')) hunk ./Operations.hs 89 -layoutMsg a = layout $ \x@(l:ls) -> maybe x (:ls) (modifyLayout l (toDyn a)) +layoutMsg a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (toDyn a)) hunk ./Operations.hs 143 -layout :: ([Layout] -> [Layout]) -> X () +layout :: ((Layout, [Layout]) -> (Layout, [Layout])) -> X () hunk ./Operations.hs 146 - let n = W.current . workspace $ s - fl = M.findWithDefault defaultLayouts n $ layouts s + let n = W.current . workspace $ s + (Just fl) = M.lookup n $ layouts s hunk ./XMonad.hs 39 - , layouts :: !(M.Map WorkspaceId [Layout]) -- ^ mapping of workspaces + , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) + -- ^ mapping of workspaces hunk ./Config.hs 157 - , ((modMask, xK_h ), layoutMsg Shrink) - , ((modMask, xK_l ), layoutMsg Expand) + , ((modMask, xK_h ), sendMessage Shrink) + , ((modMask, xK_l ), sendMessage Expand) hunk ./Operations.hs 19 -import Data.Dynamic ( Typeable, toDyn, fromDynamic ) hunk ./Operations.hs 75 -switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] - in (head xs', tail xs')) +switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] in (head xs', tail xs')) hunk ./Operations.hs 77 +-- | Throw an (extensible) message value to the current Layout scheme, +-- possibly modifying how we layout the windows, then refresh. hunk ./Operations.hs 80 --- TODO, using Typeable for extensible stuff is a bit gunky. Check -- --- 'extensible exceptions' paper for other ideas. +-- TODO, this will refresh on Nothing. hunk ./Operations.hs 82 --- Basically this thing specifies the basic operations that vary between --- layouts. --- -data ShrinkOrExpand = Shrink | Expand deriving (Typeable, Eq) - -layoutMsg :: Typeable a => a -> X () -- FIXME: The below shouldn't refresh on Nothing -layoutMsg a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (toDyn a)) +sendMessage :: Message a => a -> X () +sendMessage a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (SomeMessage a)) hunk ./Operations.hs 85 +------------------------------------------------------------------------ hunk ./Operations.hs 87 --- Standard layout algorithms: +-- Builtin layout algorithms: hunk ./Operations.hs 92 +-- +-- The latter algorithms support the following operations: hunk ./Operations.hs 95 -full :: Layout -tall, wide :: Rational -> Rational -> Layout +-- Shrink +-- Expand +-- + +data Resize = Shrink | Expand deriving (Typeable, Show) +instance Message Resize hunk ./Operations.hs 102 -full = Layout { doLayout = \sc ws -> [ (w,sc) | w <- ws ] - , modifyLayout = const Nothing } +full :: Layout +full = Layout { doLayout = \sc ws -> [ (w,sc) | w <- ws ] + , modifyLayout = const Nothing } -- no changes hunk ./Operations.hs 106 +tall, wide :: Rational -> Rational -> Layout hunk ./Operations.hs 110 - , modifyLayout = fmap f . fromDynamic } + , modifyLayout = fmap handler . fromMessage } hunk ./Operations.hs 112 - where f s = tall delta ((op s) frac delta) - op Shrink = (-) ; op Expand = (+) + where handler s = tall delta $ (case s of + Shrink -> (-) + Expand -> (+)) frac delta hunk ./XMonad.hs 20 + Typeable, Message, SomeMessage(..), fromMessage, hunk ./XMonad.hs 32 -import Data.Dynamic ( Dynamic ) +import Data.Typeable hunk ./XMonad.hs 40 - , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) - -- ^ mapping of workspaces - -- to descriptions of their layouts - } + , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) } + -- ^ mapping of workspaces to descriptions of their layouts hunk ./XMonad.hs 54 - , focusedBorder :: !Color -- ^ border color of the focused window - } + , focusedBorder :: !Color } -- ^ border color of the focused window hunk ./XMonad.hs 96 --- 'doLayout', a pure function to layout a Window set --- 'modifyLayout', +-- 'doLayout', a pure function to layout a Window set 'modifyLayout', +-- 'modifyLayout' can be considered a branch of an exception handler. +-- hunk ./XMonad.hs 100 - , modifyLayout :: Dynamic -> Maybe Layout } + , modifyLayout :: SomeMessage -> Maybe Layout } + +-- Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/, +-- Simon Marlow, 2006. Use extensible messages to the modifyLayout handler. +-- +-- User-extensible messages must be a member of this class: +-- +class (Typeable a, Show a) => Message a + +-- +-- A wrapped value of some type in the Message class. +-- +data SomeMessage = forall a. Message a => SomeMessage a + +-- +-- And now, unwrap a given, unknown Message type, performing a (dynamic) +-- type check on the result. +-- +fromMessage :: Message m => SomeMessage -> Maybe m +fromMessage (SomeMessage m) = cast m hunk ./Operations.hs 99 -data Resize = Shrink | Expand deriving (Typeable, Show) +data Resize = Shrink | Expand deriving Typeable hunk ./XMonad.hs 107 -class (Typeable a, Show a) => Message a +class Typeable a => Message a hunk ./tests/Properties.hs 307 - mapM_ (\(s,a) -> printf "%-25s: " s >> a n) tests + results <- mapM (\(s,a) -> printf "%-25s: " s >> a n) tests + when (not . and $ results) $ fail "Not all tests passed!" hunk ./tests/Properties.hs 368 -mytest :: Testable a => a -> Int -> IO () +mytest :: Testable a => a -> Int -> IO Bool hunk ./tests/Properties.hs 373 -mycheck :: Testable a => Config -> a -> IO () +mycheck :: Testable a => Config -> a -> IO Bool hunk ./tests/Properties.hs 378 -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO Bool hunk ./tests/Properties.hs 380 - | ntest == configMaxTest config = do done "OK," ntest stamps - | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | ntest == configMaxTest config = done "OK," ntest stamps >> return True + | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return True hunk ./tests/Properties.hs 394 - ) >> hFlush stdout + ) >> hFlush stdout >> return False hunk ./StackSet.hs 49 - } deriving (Eq, Show) + } deriving (Eq, Show, Read) hunk ./tests/Properties.hs 19 +import Data.Char (ord) hunk ./tests/Properties.hs 125 -type T = StackSet Int Int Int +type T = StackSet Int Int Char hunk ./tests/Properties.hs 253 +instance Arbitrary Char where + arbitrary = choose ('a','z') + coarbitrary n = coarbitrary (ord n) + hunk ./tests/Properties.hs 31 -fromList :: (Integral i, Integral j, Ord a) => (i, Int,[[a]]) -> StackSet i j a -fromList (_,_,[]) = error "Cannot build a StackSet from an empty list" +fromList :: (Integral i, Integral j, Ord a) => (i, Int, [Maybe a], [[a]]) -> StackSet i j a +fromList (_,_,_,[]) = error "Cannot build a StackSet from an empty list" hunk ./tests/Properties.hs 34 -fromList (n,m,xs) | n < 0 || n >= genericLength xs +fromList (n,m,fs,xs) | n < 0 || n >= genericLength xs hunk ./tests/Properties.hs 39 -fromList (o,m,xs) = view o $ foldr (\(i,ys) s -> - foldr (\a t -> insert a i t) s ys) - (empty (length xs) m) (zip [0..] xs) +-- 'o' random workspace +-- 'fs' random focused window on each workspace +-- +fromList (o,m,fs,xs) = + let s = view o $ + foldr (\(i,ys) s -> + foldr (\a t -> insert a i t) s ys) + (empty (length xs) m) (zip [0..] xs) + + in foldr (\f s -> case f of + Nothing -> s + Just w -> raiseFocus w s) s fs hunk ./tests/Properties.hs 63 +-- +-- StackSet +-- { current :: i +-- , screen2ws:: !(M.Map j i) -- ^ screen -> workspace +-- , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map +-- , stacks :: !(M.Map i ([a], [a])) -- ^ screen -> (floating, normal) +-- , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks +-- } +-- +-- Use 'raiseFocus' to bring focus to the front' +-- hunk ./tests/Properties.hs 80 - return $ fromList (fromIntegral n,sc,ls) + + -- pick a random element of each stack to focus. + fs <- sequence [ if null s then return Nothing + else liftM Just (elements s) + | s <- ls ] + + return $ fromList (fromIntegral n,sc,fs,ls) hunk ./StackSet.hs 1 -{-# OPTIONS -fglasgow-exts #-} - hunk ./StackSet.hs 9 --- Portability : portable, needs GHC 6.6 +-- Portability : portable hunk ./StackSet.hs 202 -swap a b xs | a == b = xs -- do nothing - | Just ai <- L.elemIndex a xs - , Just bi <- L.elemIndex b xs = insertAt bi a (insertAt ai b xs) +swap a b xs = head $ [insertAt bi a (insertAt ai b xs) | a /= b + ,Just ai <- [L.elemIndex a xs], Just bi <- [L.elemIndex b xs]] + ++ [xs] hunk ./StackSet.hs 207 -swap _ _ xs = xs -- do nothing hunk ./StackSet.hs 107 --- visible on the current screen. If the index is out of range an exception is --- thrown. +-- visible on the current screen. If the index is out of range 'view' returns +-- the initial 'StackSet' unchanged. hunk ./StackSet.hs 113 - | otherwise = error $ "view: index out of bounds: " ++ show n + | otherwise = w hunk ./Operations.hs 300 - when (m `notElem` (W.visibleWorkspaces ws')) (mapM_ hide (W.index m ws)) + when (m `notElem` W.visibleWorkspaces ws') (mapM_ hide (W.index m ws)) hunk ./StackSet.hs 202 -swap a b xs = head $ [insertAt bi a (insertAt ai b xs) | a /= b - ,Just ai <- [L.elemIndex a xs], Just bi <- [L.elemIndex b xs]] - ++ [xs] - where insertAt n x ys = as ++ x : tail bs +swap a b xs = maybe xs id $ do + ai <- L.elemIndex a xs + bi <- L.elemIndex b xs + return . insertAt bi a . insertAt ai b $ xs + where insertAt n x ys = as ++ x : drop 1 bs hunk ./Operations.hs 51 - mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) $ (doLayout l) sc $ W.index n ws + whenJust (W.index n ws) $ mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) . doLayout l sc hunk ./Operations.hs 238 - flip mapM_ (W.index n ws) $ \otherw -> do + flip mapM_ (fromMaybe [] $ W.index n ws) $ \otherw -> do hunk ./Operations.hs 300 - when (m `notElem` W.visibleWorkspaces ws') (mapM_ hide (W.index m ws)) + when (m `notElem` W.visibleWorkspaces ws') $ maybe (return ()) (mapM_ hide) $ W.index m ws hunk ./StackSet.hs 101 --- If the index is invalid, an exception is thrown. -index :: Integral i => i -> StackSet i j a -> [a] -index k w = uncurry (++) $ fromJust $ M.lookup k (stacks w) +-- If the index is invalid, returns Nothing. +index :: Integral i => i -> StackSet i j a -> Maybe [a] +index k w = fmap (uncurry (++)) $ M.lookup k (stacks w) hunk ./StackSet.hs 176 - , focus = M.update (\k' -> if k == k' then elemAfter k (index i w) + , focus = M.update (\k' -> if k == k' then elemAfter k =<< index i w hunk ./StackSet.hs 191 - let w' = w { stacks = M.adjust (\(f, s) -> (f, swap a (head s) s)) (current w) (stacks w) } + (f, xs@(x:_)) <- M.lookup (current w) (stacks w) + let w' = w { stacks = M.insert (current w) (f, swap a x xs) (stacks w) } hunk ./tests/Properties.hs 60 -height i w = length (index i w) +height i w = maybe 0 length (index i w) hunk ./StackSet.hs 65 - where (scrs,wrks) = unzip $ map (\x -> (fromIntegral x, fromIntegral x)) [0..m-1] + where scrs_wrks = unzip $ map (\x -> (fromIntegral x, fromIntegral x)) [0..m-1] + scrs = fst scrs_wrks + wrks = snd scrs_wrks addfile ./tests/Catch.hs hunk ./tests/Catch.hs 1 + +-- This is a test set for running with Catch +-- http://www-users.cs.york.ac.uk/~ndm/catch/ + +module Catch where + +import StackSet + +--------------------------------------------------------------------- +-- TESTING PROPERTIES + +main = + screen ||| peekStack ||| index ||| empty ||| peek ||| push ||| delete ||| member ||| + raiseFocus ||| rotate ||| promote ||| shift ||| view ||| workspace ||| insert ||| + visibleWorkspaces ||| swap {- helper -} + + +--------------------------------------------------------------------- +-- CATCH FIRST-ORDER LIBRARY + +-- this should be included with Catch by default +-- and will be (one day!) + +foreign import primitive any0 :: a +foreign import primitive anyEval1 :: a -> b +foreign import primitive anyEval2 :: a -> b -> c +foreign import primitive anyEval3 :: a -> b -> c -> d + + +class Test a where + test :: a -> Bool + + +instance Test b => Test (a -> b) where + test f = test (f any0) + +instance Test (Maybe a) where + test f = anyEval1 f + +instance Test [a] where + test f = anyEval1 f + +instance Test (StackSet a b c) where + test f = anyEval1 f + +instance Test (a,b) where + test f = anyEval1 f + +instance Test Bool where + test f = anyEval1 f + +instance Test Char where + test f = anyEval1 f + +instance Test (IO a) where + test f = anyEval1 (f >> return ()) + + +(|||) :: (Test a, Test b) => a -> b -> IO c +(|||) l r = anyEval2 (test l) (test r) hunk ./StackSet.hs 114 - else tweak (fromJust $ screen (current w) w) + else maybe w tweak (screen (current w) w) hunk ./tests/Properties.hs 156 +{- +TODO: enable this property when we have a better story about focus. + hunk ./tests/Properties.hs 161 +-} hunk ./tests/Properties.hs 368 - ,("delete.push identity" , mytest prop_delete_push) + -- disabled, for now ,("delete.push identity" , mytest prop_delete_push) hunk ./tests/Properties.hs 193 +{- +TODO: enable this property when we have a better story for focus. + hunk ./tests/Properties.hs 201 +-} hunk ./tests/Properties.hs 383 - ,("shift reversible ", mytest prop_shift_reversible) + -- disabled, for now ,("shift reversible ", mytest prop_shift_reversible) hunk ./tests/Properties.hs 247 -prop_promoterotate x b = focus (rotate dir (promote x)) == focus (rotate dir x) - where _ = x :: T - dir = if b then LT else GT +prop_promote_raise_id x b = (not . null . fromMaybe [] . flip index x . current $ x) ==> + (raiseFocus y . promote . raiseFocus z . promote) x == x + where _ = x :: T + dir = if b then LT else GT + (Just y) = peek x + (Just (z:_)) = flip index x . current $ x hunk ./tests/Properties.hs 396 - ,("promote only swaps", mytest prop_promoterotate) + ,("promote only swaps", mytest prop_promote_raise_id) hunk ./tests/loc.hs 11 - when (loc > 500) $ fail "Too many lines of code!" + when (loc > 550) $ fail "Too many lines of code!" hunk ./StackSet.hs 45 - , focus :: !(M.Map i a) -- ^ the window focused in each stack + , focus :: !(M.Map i [a]) -- ^ the stack of window focus in each stack hunk ./StackSet.hs 100 -peekStack i w = M.lookup i (focus w) +peekStack i w = M.lookup i (focus w) >>= maybeHead + +maybeHead :: [a] -> Maybe a +maybeHead (x:_) = Just x +maybeHead [] = Nothing + +-- | /O(log s)/. Set the focus for the given stack to the given element. +pushFocus :: (Eq a, Integral i) => i -> a -> StackSet i j a -> StackSet i j a +pushFocus i a w = w { focus = M.insert i ((a:) $ L.delete a $ M.findWithDefault [] i $ focus w) (focus w) } hunk ./StackSet.hs 110 +popFocus :: (Eq a, Integral i) => i -> a -> StackSet i j a -> StackSet i j a +popFocus i a w = w { focus = M.update upd i (focus w) } + where upd xs = case L.delete a xs of [] -> Nothing; xs' -> Just xs' + hunk ./StackSet.hs 158 - f <- M.lookup (current w) (focus w) + f <- peekStack (current w) w hunk ./StackSet.hs 162 - return $ w { focus = M.insert (current w) ea (focus w) } + return $ pushFocus (current w) ea w hunk ./StackSet.hs 177 -insert k n old = new { cache = M.insert k n (cache new) - , stacks = M.adjust (\(f, ks) -> (f, k:ks)) n (stacks new) - , focus = M.insert n k (focus new) } +insert k n old = pushFocus n k $ + new { cache = M.insert k n (cache new) + , stacks = M.adjust (\(f, ks) -> (f, k:ks)) n (stacks new) } hunk ./StackSet.hs 187 - where - del i = w { cache = M.delete k (cache w) - , stacks = M.adjust (\(xs, ys) -> (L.delete k xs, L.delete k ys)) i (stacks w) - , focus = M.update (\k' -> if k == k' then elemAfter k =<< index i w - else Just k') i (focus w) } + where del i = popFocus i k $ + w { cache = M.delete k (cache w) + , stacks = M.adjust (\(xs, ys) -> (L.delete k xs, L.delete k ys)) i (stacks w) } hunk ./StackSet.hs 194 -raiseFocus k w = case M.lookup k (cache w) of - Nothing -> w - Just i -> (view i w) { focus = M.insert i k (focus w) } +raiseFocus k w = maybe w (\i -> pushFocus i k $ view i w) $ M.lookup k (cache w) hunk ./tests/Properties.hs 163 +prop_delete_push i x = not (member i x) ==> delete i (push i x) == x + where _ = x :: T + hunk ./tests/Properties.hs 174 -prop_rotaterotate1 (x :: T) = rotate LT (rotate GT x) == x -prop_rotaterotate2 (x :: T) = rotate GT (rotate LT x) == x +prop_rotaterotate1 (x :: T) = rotate LT (rotate GT x') == x' + where x' = rotate LT x +prop_rotaterotate2 (x :: T) = rotate GT (rotate LT x') == x' + where x' = rotate GT x hunk ./tests/Properties.hs 180 -prop_rotate_all (x :: T) = foldr (\_ y -> rotate GT y) x [1..n] == x +prop_rotate_all (x :: T) = f (f x) == f x hunk ./tests/Properties.hs 183 + f x' = foldr (\_ y -> rotate GT y) x' [1..n] hunk ./tests/Properties.hs 253 -prop_promote_raise_id x b = (not . null . fromMaybe [] . flip index x . current $ x) ==> - (raiseFocus y . promote . raiseFocus z . promote) x == x +prop_promote_raise_id x = (not . null . fromMaybe [] . flip index x . current $ x) ==> + (promote . promote . promote) x == promote x hunk ./tests/Properties.hs 256 - dir = if b then LT else GT - (Just y) = peek x - (Just (z:_)) = flip index x . current $ x hunk ./tests/Properties.hs 378 - -- disabled, for now ,("delete.push identity" , mytest prop_delete_push) + ,("delete.push identity" , mytest prop_delete_push) hunk ./XMonad.hs 29 -import System.Posix.Process (executeFile, forkProcess, getProcessStatus) +import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession) hunk ./XMonad.hs 133 - forkProcess (executeFile "/bin/sh" False ["-c", x] Nothing) + forkProcess (createSession >> executeFile "/bin/sh" False ["-c", x] Nothing) hunk ./Operations.hs 51 - whenJust (W.index n ws) $ mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) . doLayout l sc + whenJust (W.index n ws) $ \winds -> + do wrects <- doLayout l sc winds :: X [(Window,Rectangle)] + mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) wrects hunk ./Operations.hs 105 -full = Layout { doLayout = \sc ws -> [ (w,sc) | w <- ws ] +full = Layout { doLayout = \sc ws -> return [ (w,sc) | w <- ws ] hunk ./Operations.hs 111 -tall delta frac = Layout { doLayout = tile frac +tall delta frac = Layout { doLayout = \a b -> return $ tile frac a b hunk ./Operations.hs 125 - Layout { doLayout = \sc -> map (second mirrorRect) . dl (mirrorRect sc) + Layout { doLayout = \sc w -> map (second mirrorRect) `fmap` dl (mirrorRect sc) w hunk ./XMonad.hs 99 -data Layout = Layout { doLayout :: Rectangle -> [Window] -> [(Window, Rectangle)] +data Layout = Layout { doLayout :: Rectangle -> [Window] -> X [(Window, Rectangle)] hunk ./Operations.hs 111 -tall delta frac = Layout { doLayout = \a b -> return $ tile frac a b +tall delta frac = Layout { doLayout = \r w -> return $ zip w $ tile frac r (length w) hunk ./Operations.hs 134 -tile :: Rational -> Rectangle -> [Window] -> [(Window, Rectangle)] -tile _ _ [] = [] -tile _ d [w] = [(w, d)] -tile r (Rectangle sx sy sw sh) (w:s) = - (w, Rectangle sx sy (fromIntegral lw) sh) : zipWith f [sy, sy + rh ..] s - where - lw = floor $ fromIntegral sw * r - rw = sw - fromIntegral lw - rh = fromIntegral sh `div` fromIntegral (length s) - f i a = (a, Rectangle (sx + lw) i rw (fromIntegral rh)) +tile :: Rational -> Rectangle -> Int -> [Rectangle] +tile _ d n | n < 2 = [d] +tile f r n = r1 : split_vertically (n-1) r2 + where (r1,r2) = split_horizontally_by f r + +split_vertically, split_horizontally :: Int -> Rectangle -> [Rectangle] +split_vertically n r | n < 2 = [r] +split_vertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : + split_vertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) + where smallh = sh `div` fromIntegral n +split_horizontally n r = map mirrorRect $ split_vertically n $ mirrorRect r + +split_horizontally_by, split_vertically_by :: Rational -> Rectangle -> (Rectangle, Rectangle) +split_horizontally_by 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 +split_vertically_by f r = (\(a,b)->(mirrorRect a,mirrorRect b)) $ split_horizontally_by f $ mirrorRect r hunk ./tests/Properties.hs 268 -prop_tile_fullscreen rect = tile pct rect [1] == [(1, rect)] +prop_tile_fullscreen rect = tile pct rect 1 == [rect] hunk ./tests/Properties.hs 279 - | (_,a) <- xs - , (_,b) <- filter (\(_,b) -> a /= b) xs + | a <- xs + , b <- filter (a /=) xs hunk ./Operations.hs 136 -tile f r n = r1 : split_vertically (n-1) r2 - where (r1,r2) = split_horizontally_by f r +tile f r n = r1 : splitVertically (n-1) r2 + where (r1,r2) = splitHorizontallyBy f r hunk ./Operations.hs 139 -split_vertically, split_horizontally :: Int -> Rectangle -> [Rectangle] -split_vertically n r | n < 2 = [r] -split_vertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : - split_vertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) +splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle] +splitVertically n r | n < 2 = [r] +splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : + splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) hunk ./Operations.hs 144 -split_horizontally n r = map mirrorRect $ split_vertically n $ mirrorRect r +splitHorizontally n r = map mirrorRect $ splitVertically n $ mirrorRect r hunk ./Operations.hs 146 -split_horizontally_by, split_vertically_by :: Rational -> Rectangle -> (Rectangle, Rectangle) -split_horizontally_by f (Rectangle sx sy sw sh) = +splitHorizontallyBy, splitVerticallyBy :: Rational -> Rectangle -> (Rectangle, Rectangle) +splitHorizontallyBy f (Rectangle sx sy sw sh) = hunk ./Operations.hs 150 -split_vertically_by f r = (\(a,b)->(mirrorRect a,mirrorRect b)) $ split_horizontally_by f $ mirrorRect r +splitVerticallyBy f r = (\(a,b)->(mirrorRect a,mirrorRect b)) $ splitHorizontallyBy f $ mirrorRect r hunk ./Config.hs 114 +-- The default number of windows in the master area +defaultWindowsInMaster :: Int +defaultWindowsInMaster = 1 + hunk ./Config.hs 142 -defaultLayouts = [ full, tall defaultDelta (1%2), wide defaultDelta (1%2) ] +defaultLayouts = [ full, + tall defaultWindowsInMaster defaultDelta (1%2), + wide defaultWindowsInMaster defaultDelta (1%2) ] hunk ./Config.hs 166 + , ((modMask .|. shiftMask, xK_j ), sendMessage (IncMasterN 1)) + , ((modMask .|. shiftMask, xK_k ), sendMessage (IncMasterN (-1))) + hunk ./Operations.hs 104 +data IncMasterN = IncMasterN Int deriving Typeable +instance Message IncMasterN + hunk ./Operations.hs 111 -tall, wide :: Rational -> Rational -> Layout -wide delta frac = mirrorLayout (tall delta frac) +tall, wide :: Int -> Rational -> Rational -> Layout +wide nmaster delta frac = mirrorLayout (tall nmaster delta frac) hunk ./Operations.hs 114 -tall delta frac = Layout { doLayout = \r w -> return $ zip w $ tile frac r (length w) - , modifyLayout = fmap handler . fromMessage } +tall nmaster delta frac = Layout { doLayout = \r w -> return $ zip w $ tile frac r nmaster (length w) + , modifyLayout = \m -> fmap resize (fromMessage m) `mplus` fmap incmastern (fromMessage m) } hunk ./Operations.hs 117 - where handler s = tall delta $ (case s of - Shrink -> (-) - Expand -> (+)) frac delta + where resize Shrink = tall nmaster delta (frac-delta) + resize Expand = tall nmaster delta (frac+delta) + incmastern (IncMasterN d) = tall (max 1 (nmaster+d)) delta frac hunk ./Operations.hs 137 -tile :: Rational -> Rectangle -> Int -> [Rectangle] -tile _ d n | n < 2 = [d] -tile f r n = r1 : splitVertically (n-1) r2 +tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle] +tile _ r nmaster n | n <= nmaster = splitVertically n r +tile f r nmaster n = splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 hunk ./tests/Properties.hs 268 -prop_tile_fullscreen rect = tile pct rect 1 == [rect] +prop_tile_fullscreen rect = tile pct rect 1 1 == [rect] hunk ./tests/Properties.hs 271 -prop_tile_non_overlap rect windows = noOverlaps (tile pct rect windows) +prop_tile_non_overlap rect windows nmaster = noOverlaps (tile pct rect nmaster windows) hunk ./StackSet.hs 47 - } deriving (Eq, Show, Read) + } deriving (Eq, Show) hunk ./Config.hs 89 +import XMonad +import Operations hunk ./Config.hs 92 -import Data.Bits +import Data.Bits ((.|.)) hunk ./Config.hs 96 -import XMonad -import Operations hunk ./Config.hs 159 - , ((modMask, xK_Tab ), raise GT) - , ((modMask, xK_j ), raise GT) - , ((modMask, xK_k ), raise LT) + , ((modMask, xK_Tab ), focusLeft) + , ((modMask, xK_j ), focusLeft) + , ((modMask, xK_k ), focusRight) hunk ./Config.hs 175 - , ((modMask, xK_Return), promote) + , ((modMask, xK_Return), swap) hunk ./Config.hs 181 - , (f, m) <- [(view, 0), (tag, shiftMask)]] + , (f, m) <- [(view, 0), (shift, shiftMask)]] hunk ./Config.hs 188 - , (f, m) <- [(view, 0), (tag, shiftMask)]] + , (f, m) <- [(view, 0), (shift, shiftMask)]] hunk ./Config.hs-boot 2 -import XMonad (Layout) hunk ./Config.hs-boot 3 -defaultLayouts :: [Layout] hunk ./Main.hs 13 --- xmonad, a minimal window manager for X11 +-- xmonad, a minimalist, tiling window manager for X11 hunk ./Main.hs 18 +import Control.Monad.Reader hunk ./Main.hs 22 -import Graphics.X11.Xinerama - -import Control.Monad.State -import Control.Monad.Reader - -import qualified StackSet as W +import Graphics.X11.Xinerama (getScreenInfo) hunk ./Main.hs 25 -import Operations hunk ./Main.hs 26 +import StackSet (new) +import Operations (manage, unmanage, focus, setFocusX, full, isClient) hunk ./Main.hs 59 - { workspace = W.empty workspaces (length xinesc) - , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] - } + { workspace = new (fromIntegral workspaces) (fromIntegral $ length xinesc) + , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] } hunk ./Main.hs 62 - xSetErrorHandler -- in C, I'm too lazy to write the binding + xSetErrorHandler -- in C, I'm too lazy to write the binding: dons hunk ./Main.hs 66 - selectInput dpy rootw $ substructureRedirectMask - .|. substructureNotifyMask - .|. enterWindowMask - .|. leaveWindowMask + selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask + .|. enterWindowMask .|. leaveWindowMask hunk ./Main.hs 75 - forever $ handle =<< xevent dpy e - where - xevent d e = io (nextEvent d e >> getEvent e) - forever a = a >> forever a + -- main loop, for all you HOF/recursion fans out there. + forever $ handle =<< io (nextEvent dpy e >> getEvent e) + where forever a = a >> forever a hunk ./Main.hs 101 - when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) $ [0, numlockMask, lockMask, numlockMask .|. lockMask] + when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) $ + [0, numlockMask, lockMask, numlockMask .|. lockMask] hunk ./Main.hs 107 --- Event handler --- --- | handle. Handle X events +-- | Event handler. Map X events onto calls into Operations.hs, which +-- modify our internal model of the window manager state. hunk ./Main.hs 116 --- Todo: seperate IO from X monad stuff. We want to be able to test the --- handler, and client functions, with dummy X interface ops, in QuickCheck --- --- Will require an abstract interpreter from Event -> X Action, which --- modifies the internal X state, and then produces an IO action to --- evaluate. --- --- XCreateWindowEvent(3X11) --- Window manager clients normally should ignore this window if the --- override_redirect member is True. --- hunk ./Main.hs 121 - | t == keyPress - = withDisplay $ \dpy -> do - s <- io $ keycodeToKeysym dpy code 0 + | t == keyPress = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 hunk ./Main.hs 131 -handle (DestroyWindowEvent {ev_window = w}) = do b <- isClient w; when b $ unmanage w - --- window gone, unmanage it -handle (UnmapEvent {ev_window = w}) = do b <- isClient w; when b $ unmanage w +-- window gone, unmanage it +handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w +handle (UnmapEvent {ev_window = w}) = whenX (isClient w) $ unmanage w hunk ./Main.hs 140 --- click on an unfocussed window -handle (ButtonEvent {ev_window = w, ev_event_type = t}) - | t == buttonPress - = safeFocus w +-- click on an unfocused window, makes it focused on this workspace +handle (ButtonEvent {ev_window = w, ev_event_type = t}) | t == buttonPress = focus w hunk ./Main.hs 143 --- entered a normal window +-- entered a normal window, makes this focused. hunk ./Main.hs 145 - | t == enterNotify && ev_mode e == notifyNormal && ev_detail e /= notifyInferior - = safeFocus w + | t == enterNotify && ev_mode e == notifyNormal + && ev_detail e /= notifyInferior = focus w hunk ./Main.hs 152 - when (ev_window e == rootw && not (ev_same_screen e)) $ setFocus rootw + when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw hunk ./Main.hs 155 -handle e@(ConfigureRequestEvent {ev_window = w}) = do - dpy <- asks display - ws <- gets workspace - - when (W.member w ws) $ -- already managed, reconfigure (see client:configure() - trace ("Reconfigure already managed window: " ++ show w) - +handle e@(ConfigureRequestEvent {}) = withDisplay $ \dpy -> do hunk ./Main.hs 165 - , wc_stack_mode = fromIntegral $ ev_detail e - } - + , wc_stack_mode = fromIntegral $ ev_detail e } hunk ./Main.hs 168 -handle e = trace (eventName e) -- ignoring +handle _ = return () -- trace (eventName e) -- ignoring hunk ./Operations.hs 9 --- Stability : stable --- Portability : portable +-- Stability : unstable +-- Portability : not portable, mtl, posix hunk ./Operations.hs 16 -import Data.List +import XMonad +import qualified StackSet as W +import {-# SOURCE #-} Config (borderWidth) + hunk ./Operations.hs 21 -import Data.Bits +import Data.List (genericIndex) +import Data.Bits ((.|.)) hunk ./Operations.hs 25 +import System.Mem hunk ./Operations.hs 28 -import Control.Arrow (second) - -import System.Posix.Process -import System.Environment -import System.Directory +import Control.Arrow hunk ./Operations.hs 33 -import XMonad -import {-# SOURCE #-} Config +-- --------------------------------------------------------------------- +-- Window manager operations hunk ./Operations.hs 36 -import qualified StackSet as W +-- | manage. Add a new window to be managed in the current workspace. +-- Bring it into focus. If the window is already managed, nothing happens. +-- +manage :: Window -> X () +manage w = do + withDisplay $ \d -> io $ do + selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + mapWindow d w + setWindowBorderWidth d w borderWidth + windows $ W.insertLeft w + +-- | unmanage. A window no longer exists, remove it from the window +-- list, on whatever workspace it is. +unmanage :: Window -> X () +unmanage = windows . W.delete + +-- | focus. focus window to the left or right. +focusLeft, focusRight :: X () +focusLeft = windows W.focusLeft +focusRight = windows W.focusRight + +-- | swap. Move the currently focused window into the master frame +swap :: X () +swap = windows W.swap hunk ./Operations.hs 61 +-- | shift. Move a window to a new workspace, 0 indexed. +shift :: WorkspaceId -> X () +shift n = withFocused hide >> windows (W.shift n) + -- refresh will raise it if we didn't need to move it. + +-- | view. Change the current workspace to workspace at offset n (0 indexed). +view :: WorkspaceId -> X () +view n = withWorkspace $ \w -> when (n /= (W.tag (W.current w))) $ do + windows $ W.view n -- move in new workspace first, to avoid flicker + mapM_ hide (W.index w) -- now just hide the old workspace + clearEnterEvents -- better clear any events from the old workspace + +-- | Kill the currently focused client. 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) +-- +kill :: X () +kill = withDisplay $ \d -> withFocused $ \w -> do + XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask + protocols <- io $ getWMProtocols d w + io $ if wmdelt `elem` protocols + then allocaXEvent $ \ev -> do + setEventType ev clientMessage + setClientMessageEvent ev w wmprot 32 wmdelt 0 + sendEvent d w False noEventMask ev + else killClient d w >> return () hunk ./Operations.hs 93 --- | refresh. Refresh the currently focused window. Resizes to full --- screen and raises the window. +-- | windows. Modify the current window list with a pure function, and refresh +windows :: (WindowSet -> WindowSet) -> X () +windows f = modify (\s -> s { workspace = f (workspace s) }) >> refresh + +-- | hide. Hide a window by moving it off screen. +hide :: Window -> X () +hide w = withDisplay $ \d -> do + (sw,sh) <- asks dimensions + io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) + +-- | refresh. Render the currently visible workspaces, as determined by +-- the StackSet. Also, set focus to the focused window. +-- +-- This is our 'view' operation (MVC), in that it pretty prints our model +-- with X calls. +-- hunk ./Operations.hs 111 - XState { workspace = ws, layouts = fls } <- get - XConf { xineScreens = xinesc, display = d } <- ask -- neat, eh? + XState { workspace = ws, layouts = fls } <- get + XConf { xineScreens = xinesc, display = d } <- ask + + -- for each workspace, layout the currently visible workspaces + flip mapM_ (M.assocs (W.screens ws)) $ \(n, scn) -> do + let this = W.view n ws + Just l = fmap fst $ M.lookup n fls + -- now tile the windows on this workspace + rs <- doLayout l (genericIndex xinesc scn) (W.index this) + mapM_ (\(w,rect) -> io (tileWindow d w rect)) rs + + -- and raise the focused window if there is one. + whenJust (W.peek this) $ io . raiseWindow d hunk ./Operations.hs 125 - flip mapM_ (M.assocs (W.screen2ws ws)) $ \(scn, n) -> do - let sc = genericIndex xinesc scn -- temporary coercion! - (Just l) = fmap fst $ M.lookup n fls - whenJust (W.index n ws) $ \winds -> - do wrects <- doLayout l sc winds :: X [(Window,Rectangle)] - mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) wrects - whenJust (W.peekStack n ws) (io . raiseWindow d) - whenJust (W.peek ws) setFocus + setTopFocus hunk ./Operations.hs 127 + io performGC -- really helps hunk ./Operations.hs 131 -clearEnterEvents = do - d <- asks display - io $ sync d False - io $ allocaXEvent $ \p -> fix $ \again -> do +clearEnterEvents = withDisplay $ \d -> io $ do + sync d False + allocaXEvent $ \p -> fix $ \again -> do hunk ./Operations.hs 137 ------------------------------------------------------------------------- +-- | tileWindow. Moves and resizes w such that it fits inside the given +-- rectangle, including its border. +tileWindow :: Display -> Window -> Rectangle -> IO () +tileWindow d w r = do + bw <- (fromIntegral . wa_border_width) `liftM` getWindowAttributes d w + moveResizeWindow d w (rect_x r) (rect_y r) + (rect_width r - bw*2) (rect_height r - bw*2) + +-- --------------------------------------------------------------------- + +buttonsToGrab :: [Button] +buttonsToGrab = [button1, button2, button3] + +-- | setButtonGrab. Tell whether or not to intercept clicks on a given window +setButtonGrab :: Bool -> Window -> X () +setButtonGrab True w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab $ \b -> + grabButton d b anyModifier w False (buttonPressMask .|. buttonReleaseMask) + grabModeAsync grabModeSync none none + +setButtonGrab False w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab $ \b -> + ungrabButton d b anyModifier w + +-- --------------------------------------------------------------------- +-- Setting keyboard focus + +-- | Set the focus to the window on top of the stack, or root +setTopFocus :: X () +setTopFocus = withWorkspace $ \ws -> maybe (asks theRoot >>= setFocusX) setFocusX (W.peek ws) + +-- | Set focus explicitly to window 'w' if it is managed by us, or root. +focus :: Window -> X () +focus w = withWorkspace $ \s -> do + if W.member w s then do modify $ \st -> st { workspace = W.focusWindow w s } -- avoid 'refresh' + setFocusX w + else whenX (isRoot w) $ setFocusX w + +-- | Call X to set the keyboard focus details. +setFocusX :: Window -> X () +setFocusX w = withWorkspace $ \ws -> do + XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask + + -- clear mouse button grab and border on other windows + (`mapM_` (M.keys . W.screens $ ws)) $ \n -> do + (`mapM_` (W.index (W.view n ws))) $ \otherw -> do + setButtonGrab True otherw + io $ setWindowBorder dpy otherw (color_pixel nbc) + + withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 + setButtonGrab False w + io $ setWindowBorder dpy w (color_pixel fbc) + +-- --------------------------------------------------------------------- +-- Managing layout hunk ./Operations.hs 209 ------------------------------------------------------------------------- hunk ./Operations.hs 283 - let n = W.current . workspace $ s + let n = W.tag . W.current . workspace $ s hunk ./Operations.hs 288 --- | windows. Modify the current window list with a pure function, and refresh -windows :: (WindowSet -> WindowSet) -> X () -windows f = do - modify $ \s -> s { workspace = f (workspace s) } - refresh - -- gets workspace >>= trace . show -- log state changes to stderr - --- | hide. Hide a window by moving it offscreen. -hide :: Window -> X () -hide w = withDisplay $ \d -> do - (sw,sh) <- asks dimensions - io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) - --- --------------------------------------------------------------------- --- Window operations - --- | setButtonGrab. Tell whether or not to intercept clicks on a given window -buttonsToGrab :: [Button] -buttonsToGrab = [button1, button2, button3] - -setButtonGrab :: Bool -> Window -> X () -setButtonGrab True w = withDisplay $ \d -> io $ - flip mapM_ buttonsToGrab $ \b -> - grabButton d b anyModifier w False - (buttonPressMask .|. buttonReleaseMask) - grabModeAsync grabModeSync none none - -setButtonGrab False w = withDisplay $ \d -> io $ - flip mapM_ buttonsToGrab $ \b -> - ungrabButton d b anyModifier w - --- | moveWindowInside. Moves and resizes w such that it fits inside the given --- rectangle, including its border. -moveWindowInside :: Display -> Window -> Rectangle -> IO () -moveWindowInside d w r = do - bw <- (fromIntegral . wa_border_width) `liftM` getWindowAttributes d w - moveResizeWindow d w (rect_x r) (rect_y r) - (rect_width r - bw*2) - (rect_height r - bw*2) - --- | manage. Add a new window to be managed in the current workspace. Bring it into focus. --- If the window is already under management, it is just raised. --- -manage :: Window -> X () -manage w = do - withDisplay $ \d -> io $ do - selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask - mapWindow d w - setWindowBorderWidth d w borderWidth - windows $ W.push w - --- | unmanage. A window no longer exists, remove it from the window --- list, on whatever workspace it is. -unmanage :: Window -> X () -unmanage w = do - windows $ W.delete w - withServerX $ do - setTopFocus - withDisplay $ \d -> io (sync d False) - -- TODO, everything operates on the current display, so wrap it up. - --- | Grab the X server (lock it) from the X monad -withServerX :: X () -> X () -withServerX f = withDisplay $ \dpy -> do - io $ grabServer dpy - f - io $ ungrabServer dpy - -safeFocus :: Window -> X () -safeFocus w = do ws <- gets workspace - if W.member w ws - then setFocus w - else do b <- isRoot w - when b setTopFocus - --- | Explicitly set the keyboard focus to the given window -setFocus :: Window -> X () -setFocus w = do - ws <- gets workspace - XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask - - -- clear mouse button grab and border on other windows - flip mapM_ (W.visibleWorkspaces ws) $ \n -> do - flip mapM_ (fromMaybe [] $ W.index n ws) $ \otherw -> do - setButtonGrab True otherw - io $ setWindowBorder dpy otherw (color_pixel nbc) - - withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 - setButtonGrab False w - io $ setWindowBorder dpy w (color_pixel fbc) - - -- This does not use 'windows' intentionally. 'windows' calls refresh, - -- which means infinite loops. - modify $ \s -> s { workspace = W.raiseFocus w (workspace s) } - --- | Set the focus to the window on top of the stack, or root -setTopFocus :: X () -setTopFocus = do - ws <- gets workspace - case W.peek ws of - Just new -> setFocus new - Nothing -> asks theRoot >>= setFocus - --- | raise. focus to window at offset 'n' in list. --- The currently focused window is always the head of the list -raise :: Ordering -> X () -raise = windows . W.rotate - --- | promote. Move the currently focused window into the master frame -promote :: X () -promote = windows W.promote - --- | Kill the currently focused client -kill :: X () -kill = withDisplay $ \d -> do - ws <- gets workspace - whenJust (W.peek ws) $ \w -> do - protocols <- io $ getWMProtocols d w - XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask - if wmdelt `elem` protocols - then io $ allocaXEvent $ \ev -> do - setEventType ev clientMessage - setClientMessageEvent ev w wmprot 32 wmdelt 0 - sendEvent d w False noEventMask ev - else io (killClient d w) >> return () - --- | tag. Move a window to a new workspace, 0 indexed. -tag :: WorkspaceId -> X () -tag n = do - ws <- gets workspace - let m = W.current ws -- :: WorkspaceId - when (n /= m) $ - whenJust (W.peek ws) $ \w -> do - hide w - windows $ W.shift n - --- | view. Change the current workspace to workspace at offset n (0 indexed). -view :: WorkspaceId -> X () -view n = do - ws <- gets workspace - let m = W.current ws - windows $ W.view n - ws' <- gets workspace - -- If the old workspace isn't visible anymore, we have to hide the windows - -- in case we're switching to an empty workspace. - when (m `notElem` W.visibleWorkspaces ws') $ maybe (return ()) (mapM_ hide) $ W.index m ws - clearEnterEvents - setTopFocus +------------------------------------------------------------------------ +-- Utilities hunk ./Operations.hs 291 --- | 'screenWorkspace sc' returns the workspace number viewed by 'sc'. +-- | Return workspace visible on screen 'sc', or 0. hunk ./Operations.hs 293 -screenWorkspace sc = fmap (fromMaybe 0 . W.workspace sc) (gets workspace) +screenWorkspace sc = withWorkspace $ return . fromMaybe 0 . W.lookupWorkspace sc + +-- | Apply an X operation to the currently focused window, if there is one. +withFocused :: (Window -> X ()) -> X () +withFocused f = withWorkspace $ \w -> whenJust (W.peek w) f hunk ./Operations.hs 301 -isClient w = liftM (W.member w) (gets workspace) - --- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has --- to be in PATH for this to work. -restart :: IO () -restart = do - prog <- getProgName - prog_path <- findExecutable prog - case prog_path of - Nothing -> return () -- silently fail - Just p -> do args <- getArgs - executeFile p True args Nothing +isClient w = withWorkspace $ return . W.member w hunk ./StackSet.hs 8 --- Stability : stable --- Portability : portable +-- Stability : experimental +-- Portability : portable, Haskell 98 hunk ./StackSet.hs 13 --- The 'StackSet' data type encodes a set of stacks. A given stack in the --- set is always current. Elements may appear only once in the entire --- stack set. +-- ** Introduction hunk ./StackSet.hs 15 --- A StackSet provides a nice data structure for window managers with --- multiple physical screens, and multiple workspaces, where each screen --- has a stack of windows, and a window may be on only 1 screen at any --- given time. +-- The 'StackSet' data type encodes a window manager abstraction. The +-- window manager is a set of virtual workspaces. On each workspace is a +-- stack of windows. A given workspace is always current, and a given +-- window on each workspace has focus. The focused window on the current +-- workspace is the one which will take user input. It can be visualised +-- as follows: hunk ./StackSet.hs 22 +-- Workspace { 0*} { 1 } { 2 } { 3 } { 4 } +-- +-- Windows [1 [] [3* [6*] [] +-- ,2*] ,4 +-- ,5] +-- +-- Note that workspaces are indexed from 0, windows are numbered +-- uniquely. A '*' indicates the window on each workspace that has +-- focus, and which workspace is current. +-- +-- ** Zipper +-- +-- We encode all the focus tracking directly in the data structure, with a 'zipper': +-- +-- A Zipper is essentially an `updateable' and yet pure functional +-- cursor into a data structure. Zipper is also a delimited +-- continuation reified as a data structure. +-- +-- The Zipper lets us replace an item deep in a complex data +-- structure, e.g., a tree or a term, without an mutation. The +-- resulting data structure will share as much of its components with +-- the old structure as possible. +-- +-- Oleg Kiselyov, 27 Apr 2005, haskell@, "Zipper as a delimited continuation" +-- +-- We use the zipper to keep track of the focused workspace and the +-- focused window on each workspace, allowing us to have correct focus +-- by construction. We closely follow Huet's original implementation: +-- +-- G. Huet, /Functional Pearl: The Zipper/, +-- 1997, J. Functional Programming 75(5):549-554. +-- and: +-- R. Hinze and J. Jeuring, /Functional Pearl: The Web/. +-- +-- and Conor McBride's zipper differentiation paper. +-- Another good reference is: +-- +-- The Zipper, Haskell wikibook +-- +-- ** Xinerama support: +-- +-- Xinerama in X11 lets us view multiple virtual workspaces +-- simultaneously. While only one will ever be in focus (i.e. will +-- receive keyboard events), other workspaces may be passively viewable. +-- We thus need to track which virtual workspaces are associated +-- (viewed) on which physical screens. We use a simple Map Workspace +-- Screen for this. +-- +-- ** Master and Focus +-- +-- Each stack tracks a focused item, and for tiling purposes also tracks +-- a 'master' position. The connection between 'master' and 'focus' +-- needs to be well defined. Particular in relation to 'insert' and +-- 'delete'. +-- +module StackSet where {- all top level functions -} hunk ./StackSet.hs 79 -module StackSet ( - StackSet(..), -- abstract - - screen, peekStack, index, empty, peek, push, delete, member, - raiseFocus, rotate, promote, shift, view, workspace, insert, - visibleWorkspaces, swap {- helper -} - ) where +import qualified Data.Map as M +import Data.Maybe (listToMaybe) hunk ./StackSet.hs 82 -import Data.Maybe -import qualified Data.List as L (delete,elemIndex) -import qualified Data.Map as M hunk ./StackSet.hs 83 +-- API changes from xmonad 0.1: +-- StackSet constructor arguments changed. StackSet workspace window screen +-- new, -- was: empty +-- view, +-- index, +-- peek, -- was: peek/peekStack +-- focusLeft, focusRight, -- was: rotate +-- focus -- was: raiseFocus +-- insertLeft, -- was: insert/push +-- delete, +-- swap, -- was: promote +-- member, +-- shift, +-- lookupWorkspace, -- was: workspace +-- visibleWorkspaces -- gone. +-- hunk ./StackSet.hs 101 --- | The StackSet data structure. Multiple screens containing tables of --- stacks, with a current pointer -data StackSet i j a = - StackSet - { current :: !i -- ^ the currently visible stack - , screen2ws:: !(M.Map j i) -- ^ screen -> workspace - , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map - , stacks :: !(M.Map i ([a], [a])) -- ^ screen -> (floating, normal) - , focus :: !(M.Map i [a]) -- ^ the stack of window focus in each stack - , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks - } deriving (Eq, Show) +-- +-- A cursor into a non-empty list of workspaces. +-- +data StackSet i a screen = + StackSet { size :: !i -- number of workspaces + , current :: !(Workspace i a) -- currently focused workspace + , prev :: [Workspace i a] -- workspaces to the left + , next :: [Workspace i a] -- workspaces to the right + , screens :: M.Map i screen -- a map of visible workspaces to their screens + } deriving (Show, Eq) hunk ./StackSet.hs 112 --- The cache is used to check on insertion that we don't already have --- this window managed on another stack +-- +-- A workspace is just a tag - its index - and a stack +-- +data Workspace i a = Workspace { tag :: !i, stack :: Stack a } + deriving (Show, Eq) hunk ./StackSet.hs 118 ------------------------------------------------------------------------- +-- TODO an unmanaged floating layer would go in here somewhere (a 2nd stack?) hunk ./StackSet.hs 120 --- | /O(n)/. Create a new stackset, of empty stacks, of size 'n', --- indexed from 0, with 'm' screens. (also indexed from 0) The 0-indexed --- stack will be current. -empty :: (Integral i, Integral j) => Int -> Int -> StackSet i j a -empty n m = StackSet { current = 0 - , screen2ws = wsScrs2Works - , ws2screen = wsWorks2Scrs - , stacks = M.fromList (zip [0..fromIntegral n-1] (repeat ([], []))) - , focus = M.empty - , cache = M.empty } +-- +-- A stack is a cursor onto a (possibly empty) window list. +-- The data structure tracks focus by construction, and we follow the +-- master separately (since the wrapping behaviour of focusLeft/Right +-- reorders the window distribution, so we can't rely on the left most +-- window remaining as master (TODO double check this)). +-- +-- A 'Stack' can be viewed as a list with a hole punched in it to make +-- the focused position. Under the zipper/calculus view of such +-- structures, it is the differentiation of a [a], and integrating it +-- back has a natural implementation used in 'index'. +-- +data Stack a = Empty + | Node { focus :: !a -- focused thing in this set + , left :: [a] -- clowns to the left + , right :: [a] } -- jokers to the right + deriving (Show, Eq) hunk ./StackSet.hs 138 - where scrs_wrks = unzip $ map (\x -> (fromIntegral x, fromIntegral x)) [0..m-1] - scrs = fst scrs_wrks - wrks = snd scrs_wrks - wsScrs2Works = M.fromList (zip scrs wrks) - wsWorks2Scrs = M.fromList (zip wrks scrs) +-- --------------------------------------------------------------------- +-- Construction hunk ./StackSet.hs 141 --- | /O(log w)/. True if x is somewhere in the StackSet -member :: Ord a => a -> StackSet i j a -> Bool -member a w = M.member a (cache w) +-- | /O(n)/. Create a new stackset, of empty stacks, of size 'n', with +-- 'm' physical screens. 'm' should be less than or equal to 'n'. +-- The workspace with index '0' will be current. +-- +-- Xinerama: Virtual workspaces are assigned to physical screens, starting at 0. +-- +new :: (Integral i, Integral s) => i -> s -> StackSet i a s +new n m | n > 0 && m > 0 = StackSet n h [] ts xine + | otherwise = error "non-positive arguments to StackSet.new" + where (h:ts) = Workspace 0 Empty : [ Workspace i Empty | i <- [1 ..n-1]] + xine = M.fromList [ (fromIntegral s, s) | s <- [0 .. m-1] ] hunk ./StackSet.hs 153 --- | /O(log n)/. Looks up the workspace that x is in, if it is in the StackSet --- lookup :: (Monad m, Ord a) => a -> StackSet i j a -> m i --- lookup x w = M.lookup x (cache w) +-- +-- /O(w)/. Set focus to the workspace with index 'i'. +-- If the index is out of range, return the original StackSet. +-- +-- Xinerama: If the workspace is not visible on any Xinerama screen, it +-- is raised on the current screen. If it is already visible, focus is +-- just moved. +-- +view :: Integral i => i -> StackSet i a s -> StackSet i a s +view i s@(StackSet sz (Workspace n _) _ _ scrs) + | i >= 0 && i < sz + = setCurrent $ if M.member i scrs + then s -- already visisble. just set current. + else case M.lookup n scrs of -- TODO current should always be valid + Nothing -> error "xmonad:view: No physical screen" + Just sc -> s { screens = M.insert i sc (M.delete n scrs) } + | otherwise = s hunk ./StackSet.hs 171 --- | /O(n)/. Number of stacks --- size :: StackSet i j a -> Int --- size = M.size . stacks + -- actually moving focus is easy: + where setCurrent x = foldr traverse x [1..abs (i-n)] hunk ./StackSet.hs 174 ------------------------------------------------------------------------- + -- work out which direction to move + traverse _ = if signum (i-n) >= 0 then viewRight else viewLeft hunk ./StackSet.hs 177 --- | Push. Insert an element onto the top of the current stack. --- If the element is already in the current stack, it is moved to the top. --- If the element is managed on another stack, it is removed from that --- stack first. -push :: (Integral i, Ord a) => a -> StackSet i j a -> StackSet i j a -push k w = insert k (current w) w + -- /O(1)/. Move workspace focus left or right one node, a la Huet. + viewLeft (StackSet m t (l:ls) rs sc) = StackSet m l ls (t:rs) sc + viewLeft t = t + viewRight (StackSet m t ls (r:rs) sc) = StackSet m r (t:ls) rs sc + viewRight t = t hunk ./StackSet.hs 183 --- | /O(log s)/. Extract the element on the top of the current stack. If no such --- element exists, Nothing is returned. -peek :: Integral i => StackSet i j a -> Maybe a -peek w = peekStack (current w) w +-- --------------------------------------------------------------------- +-- Xinerama operations hunk ./StackSet.hs 186 --- | /O(log s)/. Extract the element on the top of the given stack. If no such --- element exists, Nothing is returned. -peekStack :: Integral i => i -> StackSet i j a -> Maybe a -peekStack i w = M.lookup i (focus w) >>= maybeHead +-- | Find the tag of the workspace visible on Xinerama screen 'sc'. +-- Nothing if screen is out of bounds. +lookupWorkspace :: Eq s => s -> StackSet i a s -> Maybe i +lookupWorkspace sc w = listToMaybe [ i | (i,s) <- M.assocs (screens w), s == sc ] hunk ./StackSet.hs 191 -maybeHead :: [a] -> Maybe a -maybeHead (x:_) = Just x -maybeHead [] = Nothing +-- --------------------------------------------------------------------- +-- Operations on the current stack hunk ./StackSet.hs 194 --- | /O(log s)/. Set the focus for the given stack to the given element. -pushFocus :: (Eq a, Integral i) => i -> a -> StackSet i j a -> StackSet i j a -pushFocus i a w = w { focus = M.insert i ((a:) $ L.delete a $ M.findWithDefault [] i $ focus w) (focus w) } +-- +-- The 'with' function takes a default value, a function, and a +-- StackSet. If the current stack is Empty, 'with' returns the +-- default value. Otherwise, it applies the function to the stack, +-- returning the result. It is like 'maybe' for the focused workspace. +-- +with :: b -> (Stack a -> b) -> StackSet i a s -> b +with dflt f s = case stack (current s) of Empty -> dflt; v -> f v + -- TODO: ndm: a 'catch' proof here that 'f' only gets Node + -- constructors, hence all 'f's are safe below? hunk ./StackSet.hs 205 -popFocus :: (Eq a, Integral i) => i -> a -> StackSet i j a -> StackSet i j a -popFocus i a w = w { focus = M.update upd i (focus w) } - where upd xs = case L.delete a xs of [] -> Nothing; xs' -> Just xs' +-- +-- Apply a function, and a default value for Empty, to modify the current stack. +-- +modify :: Stack a -> (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s +modify d f s = s { current = (current s) { stack = with d f s } } hunk ./StackSet.hs 211 --- | /O(log s)/. Index. Extract the stack at workspace 'n'. --- If the index is invalid, returns Nothing. -index :: Integral i => i -> StackSet i j a -> Maybe [a] -index k w = fmap (uncurry (++)) $ M.lookup k (stacks w) +-- +-- /O(1)/. Extract the focused element of the current stack. +-- Return Just that element, or Nothing for an empty stack. +-- +peek :: StackSet i a s -> Maybe a +peek = with Nothing (return . focus) hunk ./StackSet.hs 218 --- | view. Set the stack specified by the argument as being visible and the --- current StackSet. If the stack wasn't previously visible, it will become --- visible on the current screen. If the index is out of range 'view' returns --- the initial 'StackSet' unchanged. -view :: (Integral i, Integral j) => i -> StackSet i j a -> StackSet i j a -view n w | M.member n (stacks w) - = if M.member n (ws2screen w) then w { current = n } - else maybe w tweak (screen (current w) w) - | otherwise = w - where - tweak sc = w { screen2ws = M.insert sc n (screen2ws w) - , ws2screen = M.insert n sc (M.filter (/=sc) (ws2screen w)) - , current = n } +-- +-- /O(s)/. Extract the stack on the current workspace, as a list. +-- The order of the stack is determined by the master window -- it will be +-- the head of the list. The implementation is given by the natural +-- integration of a one-hole list cursor, back to a list. +-- +index :: Eq a => StackSet i a s -> [a] +index = with [] $ \(Node t l r) -> reverse l ++ t : r hunk ./StackSet.hs 227 --- | That screen that workspace 'n' is visible on, if any. -screen :: Integral i => i -> StackSet i j a -> Maybe j -screen n w = M.lookup n (ws2screen w) +-- let is = t : r ++ reverse l in take (length is) (dropWhile (/= m) (cycle is)) hunk ./StackSet.hs 229 --- | The workspace visible on screen 'sc'. Nothing if screen is out of bounds. -workspace :: Integral j => j -> StackSet i j a -> Maybe i -workspace sc w = M.lookup sc (screen2ws w) +-- +-- /O(1), O(w) on the wrapping case/. Move the window focus left or +-- right, wrapping if we reach the end. The wrapping should model a +-- 'cycle' on the current stack. The 'master' window, and window order, +-- are unaffected by movement of focus. +-- +focusLeft, focusRight :: StackSet i a s -> StackSet i a s +focusLeft = modify Empty $ \c -> case c of + Node _ [] [] -> c + Node t (l:ls) rs -> Node l ls (t:rs) + Node t [] rs -> Node x (xs ++ [t]) [] where (x:xs) = reverse rs hunk ./StackSet.hs 241 --- | A list of the currently visible workspaces. -visibleWorkspaces :: StackSet i j a -> [i] -visibleWorkspaces = M.keys . ws2screen +focusRight = modify Empty $ \c -> case c of + Node _ [] [] -> c + Node t ls (r:rs) -> Node r (t:ls) rs + Node t ls [] -> Node x [] (xs ++ [t]) where (x:xs) = reverse ls hunk ./StackSet.hs 247 --- | /O(log n)/. rotate. cycle the current window list up or down. --- Has the effect of rotating focus. In fullscreen mode this will cause --- a new window to be visible. --- --- rotate EQ --> [5,6,7,8,1,2,3,4] --- rotate GT --> [6,7,8,1,2,3,4,5] --- rotate LT --> [4,5,6,7,8,1,2,3] +-- | /O(1) on current window, O(n) in general/. Focus the window 'w' on +-- the current workspace. If 'w' isn't on the current workspace, leave +-- the StackSet unmodified. hunk ./StackSet.hs 251 --- where xs = [5..8] ++ [1..4] +-- TODO: focusWindow give focus to any window on visible workspace hunk ./StackSet.hs 253 -rotate :: (Integral i, Eq a) => Ordering -> StackSet i j a -> StackSet i j a -rotate o w = maybe w id $ do - f <- peekStack (current w) w - s <- fmap (uncurry (++)) $ M.lookup (current w) (stacks w) - ea <- case o of EQ -> Nothing - _ -> elemAfter f (if o == GT then s else reverse s) - return $ pushFocus (current w) ea w +focusWindow :: (Integral i, Eq a) => a -> StackSet i a s -> StackSet i a s +focusWindow w s | Just w == peek s = s + | otherwise = maybe s id $ do + n <- findIndex w s -- TODO, needs to check visible workspaces + if n /= tag (current s) then Nothing -- not on this screen + else return $ until ((Just w ==) . peek) focusLeft s hunk ./StackSet.hs 260 --- | /O(log n)/. shift. move the client on top of the current stack to --- the top of stack 'n'. If the stack to move to is not valid, and --- exception is thrown. --- -shift :: (Integral i, Ord a) => i -> StackSet i j a -> StackSet i j a -shift n w = maybe w (\k -> insert k n w) (peek w) hunk ./StackSet.hs 261 --- | /O(log n)/. Insert an element onto the top of stack 'n'. --- If the element is already in the stack 'n', it is moved to the top. --- If the element exists on another stack, it is removed from that stack. --- If the index is wrong an exception is thrown. hunk ./StackSet.hs 262 -insert :: (Integral i, Ord a) => a -> i -> StackSet i j a -> StackSet i j a -insert k n old = pushFocus n k $ - new { cache = M.insert k n (cache new) - , stacks = M.adjust (\(f, ks) -> (f, k:ks)) n (stacks new) } - where new = delete k old +-- Finding if a window is in the stackset is a little tedious. We could +-- keep a cache :: Map a i, but with more bookkeeping. +-- hunk ./StackSet.hs 266 --- | /O(log n)/. Delete an element entirely from from the StackSet. --- This can be used to ensure that a given element is not managed elsewhere. --- If the element doesn't exist, the original StackSet is returned unmodified. -delete :: (Integral i, Ord a) => a -> StackSet i j a -> StackSet i j a -delete k w = maybe w del (M.lookup k (cache w)) - where del i = popFocus i k $ - w { cache = M.delete k (cache w) - , stacks = M.adjust (\(xs, ys) -> (L.delete k xs, L.delete k ys)) i (stacks w) } +-- | /O(n)/. Is a window in the StackSet. +member :: Eq a => a -> StackSet i a s -> Bool +member a s = maybe False (const True) (findIndex a s) hunk ./StackSet.hs 270 --- | /O(log n)/. If the given window is contained in a workspace, make it the --- focused window of that workspace, and make that workspace the current one. -raiseFocus :: (Integral i, Integral j, Ord a) => a -> StackSet i j a -> StackSet i j a -raiseFocus k w = maybe w (\i -> pushFocus i k $ view i w) $ M.lookup k (cache w) +-- | /O(1) on current window, O(n) in general/. +-- Return Just the workspace index of the given window, or Nothing +-- if the window is not in the StackSet. +findIndex :: Eq a => a -> StackSet i a s -> Maybe i +findIndex a s = listToMaybe [ tag w | w <- current s : prev s ++ next s, has a (stack w) ] + where has _ Empty = False + has x (Node t l r) = x `elem` (t : l ++ r) hunk ./StackSet.hs 278 --- | Swap the currently focused window with the master window (the --- window on top of the stack). Focus moves to the master. -promote :: (Integral i, Ord a) => StackSet i j a -> StackSet i j a -promote w = maybe w id $ do - a <- peek w -- fail if null - (f, xs@(x:_)) <- M.lookup (current w) (stacks w) - let w' = w { stacks = M.insert (current w) (f, swap a x xs) (stacks w) } - return $ insert a (current w) w' -- and maintain focus (?) +-- --------------------------------------------------------------------- +-- Modifying the stackset hunk ./StackSet.hs 281 --- | Swap first occurences of 'a' and 'b' in list. --- If both elements are not in the list, the list is unchanged. hunk ./StackSet.hs 282 --- Given a set as a list (no duplicates) +-- /O(n)/. (Complexity due to duplicate check). Insert a new element into +-- the stack, to the left of the currently focused element. +-- +-- The new element is given focus, and is set as the master window. +-- The previously focused element is moved to the right. The previously +-- 'master' element is forgotten. (Thus, 'insert' will cause a retiling). hunk ./StackSet.hs 289 --- > swap a b . swap a b == id +-- If the element is already in the stackset, the original stackset is +-- returned unmodified. hunk ./StackSet.hs 292 -swap :: Eq a => a -> a -> [a] -> [a] -swap a b xs = maybe xs id $ do - ai <- L.elemIndex a xs - bi <- L.elemIndex b xs - return . insertAt bi a . insertAt ai b $ xs - where insertAt n x ys = as ++ x : drop 1 bs - where (as,bs) = splitAt n ys +-- Semantics in Huet's paper is that insert doesn't move the cursor. +-- However, we choose to insert to the left, and move the focus. +-- +insertLeft :: Eq a => a -> StackSet i a s -> StackSet i a s +insertLeft a s = if member a s then s else insert + where insert = modify (Node a [] []) (\(Node t l r) -> Node a l (t:r)) s + +-- insertRight :: a -> StackSet i a s -> StackSet i a s +-- insertRight a = modify (Node a [] []) $ \(Node t l r) -> Node a (t:l) r +-- Old semantics, from Huet. +-- > w { right = a : right w } hunk ./StackSet.hs 305 --- cycling: --- promote w = w { stacks = M.adjust next (current w) (stacks w) } --- where next [] = [] --- next xs = last xs : init xs +-- /O(1) on current window, O(n) in general/. Delete window 'w' if it exists. +-- There are 4 cases to consider: +-- +-- * delete on an Empty workspace leaves it Empty +-- * otherwise, try to move focus to the right +-- * otherwise, try to move focus to the left +-- * otherwise, you've got an empty workspace, becomes Empty +-- +-- Behaviour with respect to the master: +-- +-- * deleting the master window resets it to the newly focused window +-- * otherwise, delete doesn't affect the master. +-- +delete :: (Integral i, Eq a) => a -> StackSet i a s -> StackSet i a s +delete w s | Just w == peek s = remove s -- common case. + | otherwise = maybe s (removeWindow . tag . current $ s) (findIndex w s) + where + -- find and remove window script + removeWindow o n = foldr ($) s [view o,remove ,until ((Just w ==) . peek) focusLeft,view n] + + -- actual removal logic, and focus/master logic: + remove = modify Empty $ \c -> case c of + Node _ ls (r:rs) -> Node r ls rs -- try right first + Node _ (l:ls) [] -> Node l ls [] -- else left. + Node _ [] [] -> Empty + +------------------------------------------------------------------------ +-- Setting the master window + +-- /O(s)/. Set the master window to the focused window. +-- The old master window is swapped in the tiling order with the focused window. +-- Focus stays with the item moved. +swap :: StackSet i a s -> StackSet i a s +swap = modify Empty $ \c -> case c of + Node _ [] _ -> c -- already master. + Node t ls rs -> Node t [] (ys ++ x : rs) where (x:ys) = reverse ls + + -- natural! keep focus, move current to furthest left, move furthest +-- left to current position. + +-- --------------------------------------------------------------------- +-- Composite operations hunk ./StackSet.hs 349 --- | Returns true if the window is in the floating layer -isFloat :: (Ord a, Ord i) => a -> StackSet i j a -> Bool -isFloat k w = maybe False (elem k . fst . (stacks w M.!)) (M.lookup k (cache w)) +-- /O(w)/. shift. Move the focused element of the current stack to stack +-- 'n', leaving it as the focused element on that stack. The item is +-- inserted to the left of the currently focused element on that +-- workspace. The actual focused workspace doesn't change. If there is +-- no element on the current stack, the original stackSet is returned. +-- +shift :: (Eq a, Integral i) => i -> StackSet i a s -> StackSet i a s +shift n s = if and [n >= 0,n < size s,n /= tag (current s)] then maybe s go (peek s) else s + where go w = foldr ($) s [view (tag (current s)),insertLeft w,view n,delete w] + -- ^^ poor man's state monad :-) hunk ./StackSet.hs 360 --- | Find the element in the (circular) list after given element. -elemAfter :: Eq a => a -> [a] -> Maybe a -elemAfter w ws = listToMaybe . filter (/= w) . dropWhile (/= w) $ ws ++ ws hunk ./XMonad.hs 21 - runX, io, withDisplay, isRoot, spawn, trace, whenJust + runX, io, withDisplay, withWorkspace, isRoot, spawn, restart, trace, whenJust, whenX hunk ./XMonad.hs 31 +import System.Environment +import System.Directory hunk ./XMonad.hs 58 -type WindowSet = StackSet WorkspaceId ScreenId Window +type WindowSet = StackSet WorkspaceId Window ScreenId hunk ./XMonad.hs 90 +-- | Run a monadic action with the current workspace +withWorkspace :: (WindowSet -> X a) -> X a +withWorkspace f = gets workspace >>= f + hunk ./XMonad.hs 128 --- Utilities +-- General utilities hunk ./XMonad.hs 133 -{-# INLINE io #-} hunk ./XMonad.hs 144 +-- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has +-- to be in PATH for this to work. +restart :: IO () +restart = do + prog <- getProgName + prog_path <- findExecutable prog + case prog_path of + Nothing -> return () -- silently fail + Just p -> do args <- getArgs + executeFile p True args Nothing + hunk ./XMonad.hs 159 +-- | Conditionally run an action, using a X event to decide +whenX :: X Bool -> X () -> X () +whenX a f = a >>= \b -> when b f + +-- | Grab the X server (lock it) from the X monad +-- withServerX :: X () -> X () +-- withServerX f = withDisplay $ \dpy -> do +-- io $ grabServer dpy +-- f +-- io $ ungrabServer dpy + hunk ./tests/Properties.hs 16 -import System.Random +import System.Random hiding (next) hunk ./tests/Properties.hs 18 -import Data.List (nub,sort,group,sort,intersperse,genericLength) +import Data.List (nub,sort,sortBy,group,sort,intersperse,genericLength) +import qualified Data.List as L hunk ./tests/Properties.hs 27 +-- Some general hints for creating StackSet properties: +-- +-- * ops that mutate the StackSet are usually local +-- * most ops on StackSet should either be trivially reversible, or +-- idempotent, or both. + +-- +-- The all important Arbitrary instance for StackSet. +-- +instance (Integral i, Integral s, Eq a, Arbitrary a) => Arbitrary (StackSet i a s) where + arbitrary = do + sz <- choose (1,10) -- number of workspaces + n <- choose (0,sz-1) -- pick one to be in focus + sc <- choose (1,sz) -- a number of physical screens + ls <- vector sz -- a vector of sz workspaces + + -- pick a random item in each stack to focus + fs <- sequence [ if null s then return Nothing + else liftM Just (choose ((-1),length s-1)) + | s <- ls ] + + return $ fromList (fromIntegral n, fromIntegral sc,fs,ls) + coarbitrary = error "no coarbitrary for StackSet" + hunk ./tests/Properties.hs 56 -fromList :: (Integral i, Integral j, Ord a) => (i, Int, [Maybe a], [[a]]) -> StackSet i j a +-- +-- 'o' random workspace +-- 'm' number of physical screens +-- 'fs' random focused window on each workspace +-- 'xs' list of list of windows +-- +fromList :: (Integral i, Integral s, Eq a) => (i, s, [Maybe Int], [[a]]) -> StackSet i a s hunk ./tests/Properties.hs 70 --- 'o' random workspace --- 'fs' random focused window on each workspace --- hunk ./tests/Properties.hs 73 - foldr (\a t -> insert a i t) s ys) - (empty (length xs) m) (zip [0..] xs) - - in foldr (\f s -> case f of - Nothing -> s - Just w -> raiseFocus w s) s fs - --- --------------------------------------------------------------------- + foldr insertLeft (view i s) ys) + (new (genericLength xs) m) (zip [0..] xs) + in foldr (\f t -> case f of + Nothing -> t + Just i -> foldr (const focusLeft) t [0..i] ) s fs hunk ./tests/Properties.hs 79 --- | /O(n)/. Number of stacks -size :: T -> Int -size = M.size . stacks - --- | Height of stack 'n' -height :: Int -> T -> Int -height i w = maybe 0 length (index i w) +------------------------------------------------------------------------ hunk ./tests/Properties.hs 81 --- build (non-empty) StackSets with between 1 and 100 stacks hunk ./tests/Properties.hs 82 --- StackSet --- { current :: i --- , screen2ws:: !(M.Map j i) -- ^ screen -> workspace --- , ws2screen:: !(M.Map i j) -- ^ workspace -> screen map --- , stacks :: !(M.Map i ([a], [a])) -- ^ screen -> (floating, normal) --- , cache :: !(M.Map a i) -- ^ a cache of windows back to their stacks --- } +-- Just generate StackSets with Char elements. hunk ./tests/Properties.hs 84 --- Use 'raiseFocus' to bring focus to the front' --- -instance (Integral i, Integral j, Ord a, Arbitrary a) => Arbitrary (StackSet i j a) where - arbitrary = do - sz <- choose (1,20) - n <- choose (0,sz-1) - sc <- choose (1,sz) - ls <- vector sz +type T = StackSet Int Char Int hunk ./tests/Properties.hs 86 - -- pick a random element of each stack to focus. - fs <- sequence [ if null s then return Nothing - else liftM Just (elements s) - | s <- ls ] - - return $ fromList (fromIntegral n,sc,fs,ls) - coarbitrary = error "no coarbitrary for StackSet" +-- Useful operation, the non-local workspaces +hidden x = [ w | w <- prev x ++ next x ] -- the hidden workspaces hunk ./tests/Properties.hs 89 --- Invariants: +-- Basic data invariants of the StackSet hunk ./tests/Properties.hs 91 --- * no element should ever appear more than once in a StackSet --- * the current index should always be valid +-- With the new zipper-based StackSet, tracking focus is no longer an +-- issue: the data structure enforces focus by construction. hunk ./tests/Properties.hs 94 --- All operations must preserve this. +-- But we still need to ensure there are no duplicates, and master/and +-- the xinerama mapping aren't checked by the data structure at all. hunk ./tests/Properties.hs 97 -invariant (w :: T) = inBounds w && noDuplicates allWindows - where - allWindows = concatMap (uncurry (++)) . M.elems . stacks $ w - noDuplicates ws = nub ws == ws - inBounds x = current x >= 0 && current x < sz where sz = M.size (stacks x) +-- * no element should ever appear more than once in a StackSet +-- * the xinerama screen map should be: +-- -- keys should always index valid workspaces +-- -- monotonically ascending in the elements +-- * the current workspace should be a member of the xinerama screens +-- +invariant (s :: T) = and + -- no duplicates + [ noDuplicates hunk ./tests/Properties.hs 107 --- test generator -prop_invariant = invariant + -- all this xinerama stuff says we don't have the right structure + , currentIsVisible + , validScreens + , validWorkspaces + , inBounds + ] hunk ./tests/Properties.hs 114 + where + ws = [ focus t : left t ++ right t + | w <- current s : prev s ++ next s, let t = stack w, t /= Empty ] + noDuplicates = nub ws == ws hunk ./tests/Properties.hs 119 --- empty StackSets have no windows in them -prop_empty n m = n > 0 && m > 0 ==> all (null . uncurry (++)) (M.elems (stacks x)) - where x = empty n m :: T + -- xinerama invariants: hunk ./tests/Properties.hs 121 --- empty StackSets always have focus on workspace 0 -prop_empty_current n m = n > 0 && m > 0 ==> current x == 0 - where x = empty n m :: T + currentIsVisible = M.member (tag (current s)) (screens s) hunk ./tests/Properties.hs 123 -prop_member1 i n m = n > 0 && m > 0 ==> member i (push i x) - where x = empty n m :: T + validScreens = monotonic . sort . M.elems . screens $ s hunk ./tests/Properties.hs 125 -prop_member2 i x = not (member i (delete i x)) - where _ = x :: T + validWorkspaces = and [ w `elem` allworkspaces | w <- (M.keys . screens) s ] + where allworkspaces = map tag $ current s : prev s ++ next s hunk ./tests/Properties.hs 128 -prop_member3 i n m = member i (empty n m :: T) == False + inBounds = and [ w >=0 && w < size s | (w,sc) <- M.assocs (screens s) ] hunk ./tests/Properties.hs 130 -prop_sizepush is n m = n > 0 ==> size (foldr push x is ) == n - where x = empty n m :: T +monotonic [] = True +monotonic (x:[]) = True +monotonic (x:y:zs) | x == y-1 = monotonic (y:zs) + | otherwise = False hunk ./tests/Properties.hs 135 -prop_currentpush is n m = n > 0 ==> - height (current x) (foldr push x js) == length js - where - js = nub is - x = empty n m :: T +prop_invariant = invariant hunk ./tests/Properties.hs 137 -prop_push_idem i (x :: T) = push i x == push i (push i x) +-- and check other ops preserve invariants +prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m -> + invariant $ new (fromIntegral n) m hunk ./tests/Properties.hs 141 -prop_pushpeek x is = not (null is) ==> fromJust (peek (foldr push x is)) == head is - where _ = x :: T +prop_view_I (n :: NonNegative Int) (x :: T) = + fromIntegral n < size x ==> invariant $ view (fromIntegral n) x hunk ./tests/Properties.hs 144 -prop_peekmember x = case peek x of - Just w -> member w x - Nothing -> True {- then we don't know anything -} - where _ = x :: T +prop_focusLeft_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const focusLeft) x [1..n] +prop_focusRight_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const focusRight) x [1..n] hunk ./tests/Properties.hs 149 -prop_peek_peekStack n x = - if current x == n then peekStack n x == peek x - else True -- so we don't exhaust - where _ = x :: T +prop_focus_I (n :: NonNegative Int) (x :: T) = + case peek x of + Nothing -> True + Just _ -> let w = focus . stack . current $ foldr (const focusLeft) x [1..n] + in invariant $ focusWindow w x hunk ./tests/Properties.hs 155 -prop_notpeek_peekStack n x = current x /= n && isJust (peek x) ==> peekStack n x /= peek x - where _ = x :: T +prop_insertLeft_I n (x :: T) = invariant $ insertLeft n x hunk ./tests/Properties.hs 157 ------------------------------------------------------------------------- +prop_delete_I (x :: T) = invariant $ + case peek x of + Nothing -> x + Just i -> delete i x hunk ./tests/Properties.hs 162 -type T = StackSet Int Int Char +prop_swap_I (x :: T) = invariant $ swap x hunk ./tests/Properties.hs 164 -prop_delete_uniq i x = not (member i x) ==> delete i x == x - where _ = x :: T +prop_shift_I (n :: NonNegative Int) (x :: T) = + fromIntegral n < size x ==> invariant $ shift (fromIntegral n) x hunk ./tests/Properties.hs 167 -{- -TODO: enable this property when we have a better story about focus. hunk ./tests/Properties.hs 168 -prop_delete_push i x = not (member i x) ==> delete i (push i x) == x - where _ = x :: T --} +-- --------------------------------------------------------------------- +-- 'new' hunk ./tests/Properties.hs 171 -prop_delete_push i x = not (member i x) ==> delete i (push i x) == x - where _ = x :: T +-- empty StackSets have no windows in them +prop_empty (n :: Positive Int) + (m :: Positive Int) = + all (== Empty) [ stack w | w <- current x : prev x ++ next x ] hunk ./tests/Properties.hs 176 -prop_delete2 i x = - delete i x == delete i (delete i x) - where _ = x :: T + where x = new (fromIntegral n) (fromIntegral m) :: T hunk ./tests/Properties.hs 178 -prop_focus1 i x = member i x ==> peek (raiseFocus i x) == Just i - where _ = x :: T +-- empty StackSets always have focus on workspace 0 +prop_empty_current (n :: Positive Int) + (m :: Positive Int) = tag (current x) == 0 + where x = new (fromIntegral n) (fromIntegral m) :: T hunk ./tests/Properties.hs 183 --- rotation is reversible in two directions -prop_rotaterotate1 (x :: T) = rotate LT (rotate GT x') == x' - where x' = rotate LT x -prop_rotaterotate2 (x :: T) = rotate GT (rotate LT x') == x' - where x' = rotate GT x +-- no windows will be a member of an empty workspace +prop_member_empty i (n :: Positive Int) (m :: Positive Int) + = member i (new (fromIntegral n) (fromIntegral m) :: T) == False hunk ./tests/Properties.hs 187 --- rotation through the height of a stack gets us back to the start -prop_rotate_all (x :: T) = f (f x) == f x - where - n = height (current x) x - f x' = foldr (\_ y -> rotate GT y) x' [1..n] +-- --------------------------------------------------------------------- +-- viewing workspaces hunk ./tests/Properties.hs 190 +-- view sets the current workspace to 'n' +prop_view_current (x :: T) (n :: NonNegative Int) = i < size x ==> + tag (current (view i x)) == i + where + i = fromIntegral n hunk ./tests/Properties.hs 196 -prop_viewview r x = - let n = current x - sz = size x - i = r `mod` sz - in view n (view (fromIntegral i) x) == x +-- view *only* sets the current workspace, and touches Xinerama. +-- no workspace contents will be changed. +prop_view_local (x :: T) (n :: NonNegative Int) = i < size x ==> + workspaces x == workspaces (view i x) + where + workspaces a = sortBy (\s t -> tag s `compare` tag t) $ + current a : prev a ++ next a + i = fromIntegral n hunk ./tests/Properties.hs 205 - where _ = x :: T +-- view should result in a visible xinerama screen +prop_view_xinerama (x :: T) (n :: NonNegative Int) = i < size x ==> + M.member i (screens (view i x)) + where + i = fromIntegral n hunk ./tests/Properties.hs 211 +-- view is idempotent hunk ./tests/Properties.hs 217 -{- -TODO: enable this property when we have a better story for focus. +-- view is reversible +prop_view_reversible r (x :: T) = view n (view i x) == x + where n = tag (current x) + sz = size x + i = fromIntegral $ r `mod` sz hunk ./tests/Properties.hs 223 -prop_shift_reversible r (x :: T) = - let i = fromIntegral $ r `mod` sz - sz = size x - n = current x - in height n x > 0 ==> (view n . shift n . view i . shift i) x == x --} +-- --------------------------------------------------------------------- +-- Xinerama + +-- every screen should yield a valid workspace +prop_lookupWorkspace (n :: NonNegative Int) (x :: T) = + s < M.size (screens x) ==> + fromJust (lookupWorkspace s x) `elem` (map tag $ current x : prev x ++ next x) + where + s = fromIntegral n hunk ./tests/Properties.hs 233 +-- --------------------------------------------------------------------- +-- peek/index hunk ./tests/Properties.hs 236 -prop_fullcache x = cached == allvals where - cached = sort . keys $ cache x - allvals = sort . concat . map (uncurry (++)) . elems $ stacks x - _ = x :: T +-- peek either yields nothing on the Empty workspace, or Just a valid window +prop_member_peek (x :: T) = + case peek x of + Nothing -> True {- then we don't know anything -} + Just i -> member i x hunk ./tests/Properties.hs 242 -prop_currentwsvisible x = (current x) `elem` (visibleWorkspaces x) - where _ = x :: T +-- --------------------------------------------------------------------- +-- index hunk ./tests/Properties.hs 245 -prop_ws2screen_screen2ws x = (ws == ws') && (sc == sc') - where ws = sort . keys $ ws2screen x - ws' = sort . elems $ screen2ws x - sc = sort . keys $ screen2ws x - sc' = sort . elems $ ws2screen x - _ = x :: T +-- the list returned by index should be the same length as the actual +-- windows kept in the zipper +prop_index_length (x :: T) = + case it of + Empty -> length (index x) == 0 + Node {} -> length (index x) == length list + where + it = stack . current $ x + list = focus it : left it ++ right it hunk ./tests/Properties.hs 255 -prop_screenworkspace x = all test [0..((fromIntegral $ size x)-1)] - where test ws = case screen ws x of - Nothing -> True - Just sc -> workspace sc x == Just ws - _ = x :: T +-- --------------------------------------------------------------------- +-- rotating focus +-- +-- Unfortunately, in the presence of wrapping of focus, we don't have a +-- simple identity where focusLeft . focusRight == id, as the focus +-- operations repartition the structure on wrapping. +-- +-- Note the issue with equality on Stacks given the wrapping semantics. +-- +-- [1,2,3] ++ [4] ++ [5] +-- +-- should be equivalent to: +-- +-- [] ++ [4] ++ [5,1,2,3] +-- +-- However, we can simply normalise the list, taking focus as the head, +-- and the items should be the same. hunk ./tests/Properties.hs 273 -prop_swap a b xs = swap a b (swap a b ys) == ys - where ys = nub xs :: [Int] +-- So we normalise the stack on the current workspace. +-- We normalise by moving everything to the 'left' of the focused item, +-- to the right. +-- normal (x :: T) = modify Empty (\c -> case c of +-- Node t ls rs -> Node t [] (rs ++ reverse ls)) x +normal = id hunk ./tests/Properties.hs 280 ------------------------------------------------------------------------- +-- master/focus +-- +-- The tiling order, and master window, of a stack is unaffected by focus changes. +-- +prop_focus_left_master (n :: NonNegative Int) (x::T) = + index (foldr (const focusLeft) x [1..n]) == index x +prop_focus_right_master (n :: NonNegative Int) (x::T) = + index (foldr (const focusRight) x [1..n]) == index x +prop_focusWindow_master (n :: NonNegative Int) (x :: T) = + case peek x of + Nothing -> True + Just _ -> let s = index x + i = fromIntegral n `mod` length s + in index (focusWindow (s !! i) x) == index x + +-- shifting focus is trivially reversible +prop_focus_left (x :: T) = normal (focusLeft (focusRight x)) == normal x +prop_focus_right (x :: T) = normal (focusRight (focusLeft x)) == normal x hunk ./tests/Properties.hs 299 --- promote is idempotent -prop_promote2 x = promote (promote x) == (promote x) - where _ = x :: T +-- focusWindow actually leaves the window focused... +prop_focusWindow_works (n :: NonNegative Int) (x :: T) = + case peek x of + Nothing -> True + Just _ -> let s = index x + i = fromIntegral n `mod` length s + in (focus . stack . current) (focusWindow (s !! i) x) == (s !! i) hunk ./tests/Properties.hs 307 --- focus doesn't change -prop_promotefocus x = focus (promote x) == focus x - where _ = x :: T +-- rotation through the height of a stack gets us back to the start +prop_focus_all_l (x :: T) = normal (foldr (const focusLeft) x [1..n]) == normal x + where n = length (index x) +prop_focus_all_r (x :: T) = normal (foldr (const focusRight) x [1..n]) == normal x + where n = length (index x) hunk ./tests/Properties.hs 313 --- screen certainly should't change -prop_promotecurrent x = current (promote x) == current x - where _ = x :: T +-- prop_rotate_all (x :: T) = f (f x) == f x +-- f x' = foldr (\_ y -> rotate GT y) x' [1..n] hunk ./tests/Properties.hs 316 --- the physical screen doesn't change -prop_promotescreen n x = screen n (promote x) == screen n x - where _ = x :: T +-- focus is local to the current workspace +prop_focus_local (x :: T) = hidden (focusRight x) == hidden x hunk ./tests/Properties.hs 319 --- promote doesn't mess with other windows -prop_promote_raise_id x = (not . null . fromMaybe [] . flip index x . current $ x) ==> - (promote . promote . promote) x == promote x - where _ = x :: T +prop_focusWindow_local (n :: NonNegative Int) (x::T ) = + case peek x of + Nothing -> True + Just _ -> let s = index x + i = fromIntegral n `mod` length s + in hidden (focusWindow (s !! i) x) == hidden x + +-- --------------------------------------------------------------------- +-- member/findIndex + +-- +-- For all windows in the stackSet, findIndex should identify the +-- correct workspace +-- +prop_findIndex (x :: T) = + and [ tag w == fromJust (findIndex i x) + | w <- current x : prev x ++ next x + , let t = stack w + , t /= Empty + , i <- focus (stack w) : left (stack w) ++ right (stack w) + ] + +-- --------------------------------------------------------------------- +-- 'insert' + +-- inserting a item into an empty stackset means that item is now a member +prop_insert_empty i (n :: Positive Int) (m :: Positive Int) = member i (insertLeft i x) + where x = new (fromIntegral n) (fromIntegral m) :: T + +-- insert should be idempotent +prop_insert_idem i (x :: T) = insertLeft i x == insertLeft i (insertLeft i x) + +-- insert when an item is a member should leave the stackset unchanged +prop_insert_duplicate i (x :: T) = member i x ==> insertLeft i x == x hunk ./tests/Properties.hs 355 -prop_push_local (x :: T) i = not (member i x) ==> hidden x == hidden (push i x) +prop_insert_local (x :: T) i = not (member i x) ==> hidden x == hidden (insertLeft i x) + +-- Inserting a (unique) list of items into an empty stackset should +-- result in the last inserted element having focus. +prop_insert_peek (n :: Positive Int) (m :: Positive Int) (NonEmptyNubList is) = + peek (foldr insertLeft x is) == Just (head is) + where + x = new (fromIntegral n) (fromIntegral m) :: T + +-- insert >> delete is the identity, when i `notElem` . +-- Except for the 'master', which is reset on insert and delete. +-- +prop_insert_delete n x = not (member n x) ==> delete n (insertLeft n y) == (y :: T) + where + y = swap x -- sets the master window to the current focus. + -- otherwise, we don't have a rule for where master goes. + +-- inserting n elements increases current stack size by n +prop_size_insert is (n :: Positive Int) (m :: Positive Int) = + size (foldr insertLeft x ws ) == (length ws) hunk ./tests/Properties.hs 376 - hidden w = [ index n w | n <- [0 ..sz-1], n /= current w ] - sz = M.size (stacks x) + ws = nub is + x = new (fromIntegral n) (fromIntegral m) :: T + size = length . index + + +-- --------------------------------------------------------------------- +-- 'delete' + +-- deleting the current item removes it. +prop_delete x = + case peek x of + Nothing -> True + Just i -> not (member i (delete i x)) + where _ = x :: T + +-- delete is reversible with 'insert'. +-- It is the identiy, except for the 'master', which is reset on insert and delete. +-- +prop_delete_insert (x :: T) = + case peek x of + Nothing -> True + Just n -> insertLeft n (delete n y) == y + where + y = swap x + +-- delete should be local +prop_delete_local (x :: T) = + case peek x of + Nothing -> True + Just i -> hidden x == hidden (delete i x) + +-- --------------------------------------------------------------------- +-- swap: setting the master window hunk ./tests/Properties.hs 410 +-- prop_swap_reversible a b xs = swap a b (swap a b ys) == ys +-- where ys = nub xs :: [Int] + +-- swap doesn't change focus +prop_swap_focus (x :: T) + = case peek x of + Nothing -> True + Just f -> focus (stack (current (swap x))) == f + +-- swap is local +prop_swap_local (x :: T) = hidden x == hidden (swap x) + +-- TODO swap is reversible +-- swap is reversible, but involves moving focus back the window with +-- master on it. easy to do with a mouse... +{- +prop_promote_reversible x b = (not . null . fromMaybe [] . flip index x . current $ x) ==> + (raiseFocus y . promote . raiseFocus z . promote) x == x + where _ = x :: T + dir = if b then LT else GT + (Just y) = peek x + (Just (z:_)) = flip index x . current $ x +-} + +prop_swap_idempotent (x :: T) = swap (swap x) == swap x + +-- --------------------------------------------------------------------- +-- shift + +-- shift is fully reversible on current window, when focus and master +-- are the same. otherwise, master may move. +prop_shift_reversible (r :: Int) (x :: T) = + let i = fromIntegral $ r `mod` sz + sz = size y + n = tag (current y) + in case peek y of + Nothing -> True + Just _ -> (view n . shift n . view i . shift i) y == y + where + y = swap x hunk ./tests/Properties.hs 455 +{- hunk ./tests/Properties.hs 478 - ------------------------------------------------------------------------- - -instance Arbitrary Char where - arbitrary = choose ('a','z') - coarbitrary n = coarbitrary (ord n) - -instance Random Word8 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -instance Arbitrary Word8 where - arbitrary = choose (minBound,maxBound) - coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) - -instance Random Word64 where - randomR = integralRandomR - random = randomR (minBound,maxBound) - -instance Arbitrary Word64 where - arbitrary = choose (minBound,maxBound) - coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) - -integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) -integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, - fromIntegral b :: Integer) g of - (x,g) -> (fromIntegral x, g) - -instance Arbitrary Position where - arbitrary = do n <- arbitrary :: Gen Word8 - return (fromIntegral n) - coarbitrary = undefined - -instance Arbitrary Dimension where - arbitrary = do n <- arbitrary :: Gen Word8 - return (fromIntegral n) - coarbitrary = undefined - -instance Arbitrary Rectangle where - arbitrary = do - sx <- arbitrary - sy <- arbitrary - sw <- arbitrary - sh <- arbitrary - return $ Rectangle sx sy sw sh - coarbitrary = undefined - - -instance Arbitrary Rational where - arbitrary = do - n <- arbitrary - d' <- arbitrary - let d = if d' == 0 then 1 else d' - return (n % d) - coarbitrary = undefined +-} hunk ./tests/Properties.hs 486 - results <- mapM (\(s,a) -> printf "%-25s: " s >> a n) tests + (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-25s: " s >> a n) tests + printf "Passed %d tests!\n" (sum passed) hunk ./tests/Properties.hs 490 - n = 100 hunk ./tests/Properties.hs 492 - [("StackSet invariants", mytest prop_invariant) - ,("empty is empty" , mytest prop_empty) - ,("empty / current" , mytest prop_empty_current) - - ,("member/push ", mytest prop_member1) - ,("member/peek ", mytest prop_peekmember) - ,("member/delete ", mytest prop_member2) - ,("member/empty ", mytest prop_member3) + [("StackSet invariants" , mytest prop_invariant) hunk ./tests/Properties.hs 494 - ,("size/push ", mytest prop_sizepush) - ,("height/push ", mytest prop_currentpush) - ,("push/peek ", mytest prop_pushpeek) - ,("push is local" , mytest prop_push_local) - ,("idempotent push" , mytest prop_push_idem) + ,("empty: invariant" , mytest prop_empty_I) + ,("empty is empty" , mytest prop_empty) + ,("empty / current" , mytest prop_empty_current) + ,("empty / member" , mytest prop_member_empty) hunk ./tests/Properties.hs 499 - ,("peek/peekStack" , mytest prop_peek_peekStack) - ,("not . peek/peekStack", mytest prop_notpeek_peekStack) + ,("view : invariant" , mytest prop_view_I) + ,("view sets current" , mytest prop_view_current) + ,("view idempotent" , mytest prop_view_idem) + ,("view reviersible" , mytest prop_view_reversible) + ,("view / xinerama" , mytest prop_view_xinerama) + ,("view is local" , mytest prop_view_local) hunk ./tests/Properties.hs 506 - ,("delete/not.member", mytest prop_delete_uniq) - ,("delete idempotent", mytest prop_delete2) - ,("delete.push identity" , mytest prop_delete_push) + ,("valid workspace xinerama", mytest prop_lookupWorkspace) hunk ./tests/Properties.hs 508 - ,("focus", mytest prop_focus1) + ,("peek/member " , mytest prop_member_peek) hunk ./tests/Properties.hs 510 - ,("rotate l >> rotate r", mytest prop_rotaterotate1) - ,("rotate r >> rotate l", mytest prop_rotaterotate2) - ,("rotate all", mytest prop_rotate_all) + ,("index/length" , mytest prop_index_length) hunk ./tests/Properties.hs 512 - ,("view/view ", mytest prop_viewview) - ,("view idem ", mytest prop_view_idem) + ,("focus left : invariant", mytest prop_focusLeft_I) + ,("focus right: invariant", mytest prop_focusRight_I) + ,("focusWindow: invariant", mytest prop_focus_I) + ,("focus left/master" , mytest prop_focus_left_master) + ,("focus right/master" , mytest prop_focus_right_master) + ,("focusWindow master" , mytest prop_focusWindow_master) + ,("focus left/right" , mytest prop_focus_left) + ,("focus right/left" , mytest prop_focus_right) + ,("focus all left " , mytest prop_focus_all_l) + ,("focus all right " , mytest prop_focus_all_r) + ,("focus is local" , mytest prop_focus_local) + ,("focusWindow is local", mytest prop_focusWindow_local) + ,("focusWindow works" , mytest prop_focusWindow_works) hunk ./tests/Properties.hs 526 - -- disabled, for now ,("shift reversible ", mytest prop_shift_reversible) + ,("findIndex" , mytest prop_findIndex) hunk ./tests/Properties.hs 528 - ,("fullcache ", mytest prop_fullcache) - ,("currentwsvisible ", mytest prop_currentwsvisible) - ,("ws screen mapping", mytest prop_ws2screen_screen2ws) - ,("screen/workspace ", mytest prop_screenworkspace) + ,("insert: invariant" , mytest prop_insertLeft_I) + ,("insert/new" , mytest prop_insert_empty) + ,("insert is idempotent", mytest prop_insert_idem) + ,("insert is reversible", mytest prop_insert_delete) + ,("insert is local" , mytest prop_insert_local) + ,("insert duplicates" , mytest prop_insert_duplicate) + ,("insert/peek " , mytest prop_insert_peek) + ,("insert/size" , mytest prop_size_insert) hunk ./tests/Properties.hs 537 - ,("promote idempotent", mytest prop_promote2) - ,("promote focus", mytest prop_promotefocus) - ,("promote current", mytest prop_promotecurrent) - ,("promote only swaps", mytest prop_promote_raise_id) - ,("promote/screen" , mytest prop_promotescreen) + ,("delete: invariant" , mytest prop_delete_I) + ,("delete/empty" , mytest prop_empty) + ,("delete/member" , mytest prop_delete) + ,("delete is reversible", mytest prop_delete_insert) + ,("delete is local" , mytest prop_delete_local) hunk ./tests/Properties.hs 543 - ,("swap", mytest prop_swap) + ,("swap: invariant " , mytest prop_swap_I) + ,("swap id on focus" , mytest prop_swap_focus) + ,("swap is idempotent" , mytest prop_swap_idempotent) + ,("swap is local" , mytest prop_swap_local) hunk ./tests/Properties.hs 548 ------------------------------------------------------------------------- + ,("shift: invariant" , mytest prop_shift_I) + ,("shift is reversible" , mytest prop_shift_reversible) hunk ./tests/Properties.hs 551 +{- hunk ./tests/Properties.hs 554 +-} hunk ./tests/Properties.hs 558 +------------------------------------------------------------------------ +-- +-- QC driver +-- + hunk ./tests/Properties.hs 565 -mytest :: Testable a => a -> Int -> IO Bool +mytest :: Testable a => a -> Int -> IO (Bool, Int) hunk ./tests/Properties.hs 568 - , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] } a + -- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a hunk ./tests/Properties.hs 571 -mycheck :: Testable a => Config -> a -> IO Bool +mycheck :: Testable a => Config -> a -> IO (Bool, Int) hunk ./tests/Properties.hs 576 -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO Bool +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int) hunk ./tests/Properties.hs 578 - | ntest == configMaxTest config = done "OK," ntest stamps >> return True - | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return True + | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest) + | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest) hunk ./tests/Properties.hs 592 - ) >> hFlush stdout >> return False + ) >> hFlush stdout >> return (False, ntest) hunk ./tests/Properties.hs 623 +instance Arbitrary Char where + arbitrary = choose ('a','z') + coarbitrary n = coarbitrary (ord n) + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word8 where + arbitrary = choose (minBound,maxBound) + coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) + +instance Random Word64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word64 where + arbitrary = choose (minBound,maxBound) + coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + +instance Arbitrary Position where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Dimension where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Rectangle where + arbitrary = do + sx <- arbitrary + sy <- arbitrary + sw <- arbitrary + sh <- arbitrary + return $ Rectangle sx sy sw sh + coarbitrary = undefined + +instance Arbitrary Rational where + arbitrary = do + n <- arbitrary + d' <- arbitrary + let d = if d' == 0 then 1 else d' + return (n % d) + coarbitrary = undefined + +------------------------------------------------------------------------ +-- QC 2 + +-- from QC2 +-- | NonEmpty xs: guarantees that xs is non-empty. +newtype NonEmptyList a = NonEmpty [a] + deriving ( Eq, Ord, Show, Read ) + +instance Arbitrary a => Arbitrary (NonEmptyList a) where + arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) + coarbitrary = undefined + +newtype NonEmptyNubList a = NonEmptyNubList [a] + deriving ( Eq, Ord, Show, Read ) + +instance (Eq a, Arbitrary a) => Arbitrary (NonEmptyNubList a) where + arbitrary = NonEmptyNubList `fmap` ((liftM nub arbitrary) `suchThat` (not . null)) + coarbitrary = undefined + + +type Positive a = NonZero (NonNegative a) + +newtype NonZero a = NonZero a + deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read ) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonZero a) where + arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) + coarbitrary = undefined + +newtype NonNegative a = NonNegative a + deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read ) + +instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where + arbitrary = + frequency + [ (5, (NonNegative . abs) `fmap` arbitrary) + , (1, return 0) + ] + coarbitrary = undefined + +-- | Generates a value that satisfies a predicate. +suchThat :: Gen a -> (a -> Bool) -> Gen a +gen `suchThat` p = + do mx <- gen `suchThatMaybe` p + case mx of + Just x -> return x + Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) + +-- | Tries to generate a value that satisfies a predicate. +suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) +gen `suchThatMaybe` p = sized (try 0 . max 1) + where + try _ 0 = return Nothing + try k n = do x <- resize (2*k+n) gen + if p x then return (Just x) else try (k+1) (n-1) + hunk ./Operations.hs 25 -import System.Mem +import System.Mem (performGC) hunk ./Config.hs 159 - , ((modMask, xK_Tab ), focusLeft) - , ((modMask, xK_j ), focusLeft) - , ((modMask, xK_k ), focusRight) + , ((modMask, xK_Tab ), focusRight) + , ((modMask, xK_j ), focusRight) + , ((modMask, xK_k ), focusLeft) hunk ./Operations.hs 70 - mapM_ hide (W.index w) -- now just hide the old workspace + -- Hide the old workspace if it is no longer visible + oldWsNotVisible <- (not . M.member (W.tag . W.current $ w) . W.screens) `liftM` gets workspace + when oldWsNotVisible $ mapM_ hide (W.index w) hunk ./StackSet.hs 122 --- The data structure tracks focus by construction, and we follow the --- master separately (since the wrapping behaviour of focusLeft/Right --- reorders the window distribution, so we can't rely on the left most --- window remaining as master (TODO double check this)). +-- The data structure tracks focus by construction, and +-- the master window is by convention the left most item. +-- Focus operations will not reorder the list that results from +-- flattening the cursor. hunk ./StackSet.hs 77 -module StackSet where {- all top level functions -} +module StackSet ( + StackSet(..), Workspace(..), Stack(..), + new, view, lookupWorkspace, peek, index, focusLeft, focusRight, + focusWindow, member, findIndex, insertLeft, delete, swap, shift + ) where hunk ./StackSet.hs 251 --- | /O(1) on current window, O(n) in general/. Focus the window 'w' on --- the current workspace. If 'w' isn't on the current workspace, leave --- the StackSet unmodified. --- --- TODO: focusWindow give focus to any window on visible workspace +-- | /O(1) on current window, O(n) in general/. Focus the window 'w'. If the +-- workspace 'w' is on is not visible, 'view' that workspace first. hunk ./StackSet.hs 257 - n <- findIndex w s -- TODO, needs to check visible workspaces - if n /= tag (current s) then Nothing -- not on this screen - else return $ until ((Just w ==) . peek) focusLeft s - + n <- findIndex w s + return $ until ((Just w ==) . peek) focusLeft (view n s) hunk ./Main.hs 59 - { workspace = new (fromIntegral workspaces) (fromIntegral $ length xinesc) + { windowset = new (fromIntegral workspaces) (fromIntegral $ length xinesc) hunk ./Operations.hs 71 - oldWsNotVisible <- (not . M.member (W.tag . W.current $ w) . W.screens) `liftM` gets workspace + oldWsNotVisible <- (not . M.member (W.tag . W.current $ w) . W.screens) `liftM` gets windowset hunk ./Operations.hs 97 -windows f = modify (\s -> s { workspace = f (workspace s) }) >> refresh +windows f = modify (\s -> s { windowset = f (windowset s) }) >> refresh hunk ./Operations.hs 113 - XState { workspace = ws, layouts = fls } <- get + XState { windowset = ws, layouts = fls } <- get hunk ./Operations.hs 171 - if W.member w s then do modify $ \st -> st { workspace = W.focusWindow w s } -- avoid 'refresh' + if W.member w s then do modify $ \st -> st { windowset = W.focusWindow w s } -- avoid 'refresh' hunk ./Operations.hs 285 - let n = W.tag . W.current . workspace $ s + let n = W.tag . W.current . windowset $ s hunk ./XMonad.hs 41 - { workspace :: !WindowSet -- ^ workspace list + { windowset :: !WindowSet -- ^ workspace list hunk ./XMonad.hs 92 -withWorkspace f = gets workspace >>= f +withWorkspace f = gets windowset >>= f hunk ./Operations.hs 68 -view n = withWorkspace $ \w -> when (n /= (W.tag (W.current w))) $ do +view n = withWorkspace $ \old -> when (n /= (W.tag (W.workspace (W.current old)))) $ do hunk ./Operations.hs 70 + hunk ./Operations.hs 72 - oldWsNotVisible <- (not . M.member (W.tag . W.current $ w) . W.screens) `liftM` gets windowset - when oldWsNotVisible $ mapM_ hide (W.index w) + oldWsNotVisible <- liftM (notElem (W.current old)) (gets (W.visible . windowset)) + when oldWsNotVisible $ mapM_ hide (W.index old) hunk ./Operations.hs 118 - flip mapM_ (M.assocs (W.screens ws)) $ \(n, scn) -> do - let this = W.view n ws + (`mapM_` (W.current ws : W.visible ws)) $ \w -> do + let n = W.tag (W.workspace w) + this = W.view n ws hunk ./Operations.hs 123 - rs <- doLayout l (genericIndex xinesc scn) (W.index this) - mapM_ (\(w,rect) -> io (tileWindow d w rect)) rs + rs <- doLayout l (genericIndex xinesc (W.screen w)) (W.index this) + mapM_ (\(win,rect) -> io (tileWindow d win rect)) rs hunk ./Operations.hs 183 - (`mapM_` (M.keys . W.screens $ ws)) $ \n -> do - (`mapM_` (W.index (W.view n ws))) $ \otherw -> do + (`mapM_` (W.current ws : W.visible ws)) $ \wk -> do + (`mapM_` (W.index (W.view (W.tag (W.workspace wk)) ws))) $ \otherw -> do hunk ./Operations.hs 287 - let n = W.tag . W.current . windowset $ s + let n = W.tag . W.workspace . W.current . windowset $ s hunk ./StackSet.hs 78 - StackSet(..), Workspace(..), Stack(..), + StackSet(..), Workspace(..), Screen(..), Stack(..), hunk ./StackSet.hs 83 -import qualified Data.Map as M hunk ./StackSet.hs 84 +import qualified Data.List as L (delete,find,genericSplitAt) hunk ./StackSet.hs 106 --- A cursor into a non-empty list of workspaces. +-- A cursor into a non-empty list of workspaces. +-- We puncture the workspace list, producing a hole in the structure +-- used to track the currently focused workspace. The two other lists +-- that are produced are used to track those workspaces visible as +-- Xinerama screens, and those workspaces not visible anywhere. hunk ./StackSet.hs 112 -data StackSet i a screen = - StackSet { size :: !i -- number of workspaces - , current :: !(Workspace i a) -- currently focused workspace - , prev :: [Workspace i a] -- workspaces to the left - , next :: [Workspace i a] -- workspaces to the right - , screens :: M.Map i screen -- a map of visible workspaces to their screens - } deriving (Show, Eq) +data StackSet i a sid = + StackSet { size :: !i -- number of workspaces + , current :: !(Screen i a sid) -- currently focused workspace + , visible :: [Screen i a sid] -- non-focused workspaces, visible in xinerama + , hidden :: [Workspace i a] -- workspaces not visible anywhere + } deriving (Show, Eq) + +-- Visible workspaces, and their Xinerama screens. +data Screen i a sid = Screen { workspace :: !(Workspace i a), screen :: !sid } + deriving (Show, Eq) hunk ./StackSet.hs 129 --- TODO an unmanaged floating layer would go in here somewhere (a 2nd stack?) - hunk ./StackSet.hs 157 -new n m | n > 0 && m > 0 = StackSet n h [] ts xine +new n m | n > 0 && m > 0 = StackSet n cur visi unseen hunk ./StackSet.hs 159 - where (h:ts) = Workspace 0 Empty : [ Workspace i Empty | i <- [1 ..n-1]] - xine = M.fromList [ (fromIntegral s, s) | s <- [0 .. m-1] ] + + where (seen,unseen) = L.genericSplitAt m $ Workspace 0 Empty : [ Workspace i Empty | i <- [1 ..n-1]] + (cur:visi) = [ Screen i s | (i,s) <- zip seen [0..] ] + -- now zip up visibles with their screen id hunk ./StackSet.hs 169 --- is raised on the current screen. If it is already visible, focus is +-- becomes the current screen. If it is in the visible list, it becomes +-- current. + +-- is raised to the current screen. If it is already visible, focus is hunk ./StackSet.hs 175 -view :: Integral i => i -> StackSet i a s -> StackSet i a s -view i s@(StackSet sz (Workspace n _) _ _ scrs) - | i >= 0 && i < sz - = setCurrent $ if M.member i scrs - then s -- already visisble. just set current. - else case M.lookup n scrs of -- TODO current should always be valid - Nothing -> error "xmonad:view: No physical screen" - Just sc -> s { screens = M.insert i sc (M.delete n scrs) } - | otherwise = s +view :: (Eq i, Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s +view i s + | i < 0 && i >= size s || i == tag (workspace (current s)) = s -- out of bounds or current + + | Just x <- L.find ((i==).tag.workspace) (visible s) + -- if it is visible, it is just raised + = s { current = x, visible = current s : L.delete x (visible s) } hunk ./StackSet.hs 183 - -- actually moving focus is easy: - where setCurrent x = foldr traverse x [1..abs (i-n)] + | Just x <- L.find ((i==).tag) (hidden s) + -- if it was hidden, it is raised on the xine screen currently used + = s { current = Screen x (screen (current s)) + , hidden = workspace (current s) : L.delete x (hidden s) } hunk ./StackSet.hs 188 - -- work out which direction to move - traverse _ = if signum (i-n) >= 0 then viewRight else viewLeft + | otherwise = error "Inconsistent StackSet: workspace not found" hunk ./StackSet.hs 190 - -- /O(1)/. Move workspace focus left or right one node, a la Huet. - viewLeft (StackSet m t (l:ls) rs sc) = StackSet m l ls (t:rs) sc - viewLeft t = t - viewRight (StackSet m t ls (r:rs) sc) = StackSet m r (t:ls) rs sc - viewRight t = t + -- 'Catch'ing this might be hard. Relies on monotonically increasing + -- workspace tags defined in 'new' hunk ./StackSet.hs 199 -lookupWorkspace sc w = listToMaybe [ i | (i,s) <- M.assocs (screens w), s == sc ] +lookupWorkspace sc w = listToMaybe [ tag i | Screen i s <- current w : visible w, s == sc ] hunk ./StackSet.hs 211 -with dflt f s = case stack (current s) of Empty -> dflt; v -> f v +with dflt f s = case stack (workspace (current s)) of Empty -> dflt; v -> f v hunk ./StackSet.hs 219 -modify d f s = s { current = (current s) { stack = with d f s } } +modify d f s = s { current = (current s) + { workspace = (workspace (current s)) { stack = with d f s }}} hunk ./StackSet.hs 258 --- | /O(1) on current window, O(n) in general/. Focus the window 'w'. If the --- workspace 'w' is on is not visible, 'view' that workspace first. +-- | /O(1) on current window, O(n) in general/. Focus the window 'w', +-- and set its workspace as current. hunk ./StackSet.hs 261 -focusWindow :: (Integral i, Eq a) => a -> StackSet i a s -> StackSet i a s +focusWindow :: (Integral i, Eq s, Eq a) => a -> StackSet i a s -> StackSet i a s hunk ./StackSet.hs 280 -findIndex a s = listToMaybe [ tag w | w <- current s : prev s ++ next s, has a (stack w) ] +findIndex a s = listToMaybe + [ tag w | w <- workspace (current s) : map workspace (visible s) ++ hidden s, has a (stack w) ] hunk ./StackSet.hs 325 -delete :: (Integral i, Eq a) => a -> StackSet i a s -> StackSet i a s +delete :: (Integral i, Eq a, Eq s) => a -> StackSet i a s -> StackSet i a s hunk ./StackSet.hs 327 - | otherwise = maybe s (removeWindow . tag . current $ s) (findIndex w s) + | otherwise = maybe s (removeWindow.tag.workspace.current $ s) (findIndex w s) hunk ./StackSet.hs 362 -shift :: (Eq a, Integral i) => i -> StackSet i a s -> StackSet i a s -shift n s = if and [n >= 0,n < size s,n /= tag (current s)] then maybe s go (peek s) else s - where go w = foldr ($) s [view (tag (current s)),insertLeft w,view n,delete w] +shift :: (Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s +shift n s = if and [n >= 0,n < size s,n /= tag (workspace (current s))] + then maybe s go (peek s) else s + where go w = foldr ($) s [view (tag (workspace (current s))),insertLeft w,view n,delete w] hunk ./tests/Properties.hs 87 -hidden x = [ w | w <- prev x ++ next x ] -- the hidden workspaces +hidden_spaces x = map workspace (visible x) ++ hidden x hunk ./tests/Properties.hs 108 - , currentIsVisible - , validScreens - , validWorkspaces - , inBounds +-- , validScreens +-- , validWorkspaces +-- , inBounds hunk ./tests/Properties.hs 115 - | w <- current s : prev s ++ next s, let t = stack w, t /= Empty ] + | w <- workspace (current s) : map workspace (visible s) ++ hidden s + , let t = stack w, t /= Empty ] hunk ./tests/Properties.hs 119 - -- xinerama invariants: +-- validScreens = monotonic . sort . M. . (W.current s : W.visible : W$ s hunk ./tests/Properties.hs 121 - currentIsVisible = M.member (tag (current s)) (screens s) +-- validWorkspaces = and [ w `elem` allworkspaces | w <- (M.keys . screens) s ] +-- where allworkspaces = map tag $ current s : prev s ++ next s hunk ./tests/Properties.hs 124 - validScreens = monotonic . sort . M.elems . screens $ s - - validWorkspaces = and [ w `elem` allworkspaces | w <- (M.keys . screens) s ] - where allworkspaces = map tag $ current s : prev s ++ next s - - inBounds = and [ w >=0 && w < size s | (w,sc) <- M.assocs (screens s) ] +-- inBounds = and [ w >=0 && w < size s | (w,sc) <- M.assocs (screens s) ] hunk ./tests/Properties.hs 148 - Just _ -> let w = focus . stack . current $ foldr (const focusLeft) x [1..n] + Just _ -> let w = focus . stack . workspace . current $ foldr (const focusLeft) x [1..n] hunk ./tests/Properties.hs 170 - all (== Empty) [ stack w | w <- current x : prev x ++ next x ] + all (== Empty) [ stack w | w <- workspace (current x) + : map workspace (visible x) ++ hidden x ] hunk ./tests/Properties.hs 177 - (m :: Positive Int) = tag (current x) == 0 + (m :: Positive Int) = tag (workspace $ current x) == 0 hunk ./tests/Properties.hs 189 - tag (current (view i x)) == i + tag (workspace $ current (view i x)) == i hunk ./tests/Properties.hs 199 - current a : prev a ++ next a + workspace (current a) + : map workspace (visible a) ++ hidden a hunk ./tests/Properties.hs 204 -prop_view_xinerama (x :: T) (n :: NonNegative Int) = i < size x ==> - M.member i (screens (view i x)) - where - i = fromIntegral n +-- prop_view_xinerama (x :: T) (n :: NonNegative Int) = i < size x ==> +-- M.member i (screens (view i x)) +-- where +-- i = fromIntegral n hunk ./tests/Properties.hs 215 --- view is reversible -prop_view_reversible r (x :: T) = view n (view i x) == x - where n = tag (current x) +-- view is reversible, though shuffles the order of hidden/visible +prop_view_reversible r (x :: T) = normal (view n (view i x)) == normal x + where n = tag (workspace $ current x) hunk ./tests/Properties.hs 221 +-- normalise workspace list +normal s = s { hidden = sortBy g (hidden s), visible = sortBy f (visible s) } + where + f = \a b -> tag (workspace a) `compare` tag (workspace b) + g = \a b -> tag a `compare` tag b + hunk ./tests/Properties.hs 231 -prop_lookupWorkspace (n :: NonNegative Int) (x :: T) = - s < M.size (screens x) ==> - fromJust (lookupWorkspace s x) `elem` (map tag $ current x : prev x ++ next x) - where - s = fromIntegral n +-- prop_lookupWorkspace (n :: NonNegative Int) (x :: T) = +-- s < M.size (screens x) ==> +-- fromJust (lookupWorkspace s x) `elem` (map tag $ current x : prev x ++ next x) +-- where +-- s = fromIntegral n hunk ./tests/Properties.hs 256 - it = stack . current $ x + it = stack . workspace . current $ x hunk ./tests/Properties.hs 262 --- Unfortunately, in the presence of wrapping of focus, we don't have a --- simple identity where focusLeft . focusRight == id, as the focus --- operations repartition the structure on wrapping. --- --- Note the issue with equality on Stacks given the wrapping semantics. --- --- [1,2,3] ++ [4] ++ [5] --- --- should be equivalent to: --- --- [] ++ [4] ++ [5,1,2,3] --- --- However, we can simply normalise the list, taking focus as the head, --- and the items should be the same. - --- So we normalise the stack on the current workspace. --- We normalise by moving everything to the 'left' of the focused item, --- to the right. --- normal (x :: T) = modify Empty (\c -> case c of --- Node t ls rs -> Node t [] (rs ++ reverse ls)) x -normal = id hunk ./tests/Properties.hs 279 -prop_focus_left (x :: T) = normal (focusLeft (focusRight x)) == normal x -prop_focus_right (x :: T) = normal (focusRight (focusLeft x)) == normal x +prop_focus_left (x :: T) = (focusLeft (focusRight x)) == x +prop_focus_right (x :: T) = (focusRight (focusLeft x)) == x hunk ./tests/Properties.hs 288 - in (focus . stack . current) (focusWindow (s !! i) x) == (s !! i) + in (focus . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i) hunk ./tests/Properties.hs 291 -prop_focus_all_l (x :: T) = normal (foldr (const focusLeft) x [1..n]) == normal x +prop_focus_all_l (x :: T) = (foldr (const focusLeft) x [1..n]) == x hunk ./tests/Properties.hs 293 -prop_focus_all_r (x :: T) = normal (foldr (const focusRight) x [1..n]) == normal x +prop_focus_all_r (x :: T) = (foldr (const focusRight) x [1..n]) == x hunk ./tests/Properties.hs 300 -prop_focus_local (x :: T) = hidden (focusRight x) == hidden x +prop_focus_local (x :: T) = hidden_spaces (focusRight x) == hidden_spaces x hunk ./tests/Properties.hs 307 - in hidden (focusWindow (s !! i) x) == hidden x + in hidden_spaces (focusWindow (s !! i) x) == hidden_spaces x hunk ./tests/Properties.hs 318 - | w <- current x : prev x ++ next x + | w <- workspace (current x) : map workspace (visible x) ++ hidden x hunk ./tests/Properties.hs 338 -prop_insert_local (x :: T) i = not (member i x) ==> hidden x == hidden (insertLeft i x) +prop_insert_local (x :: T) i = not (member i x) ==> hidden_spaces x == hidden_spaces (insertLeft i x) hunk ./tests/Properties.hs 388 - Just i -> hidden x == hidden (delete i x) + Just i -> hidden_spaces x == hidden_spaces (delete i x) hunk ./tests/Properties.hs 400 - Just f -> focus (stack (current (swap x))) == f + Just f -> focus (stack (workspace $ current (swap x))) == f hunk ./tests/Properties.hs 403 -prop_swap_local (x :: T) = hidden x == hidden (swap x) +prop_swap_local (x :: T) = hidden_spaces x == hidden_spaces (swap x) hunk ./tests/Properties.hs 427 - n = tag (current y) + n = tag (workspace $ current y) hunk ./tests/Properties.hs 430 - Just _ -> (view n . shift n . view i . shift i) y == y + Just _ -> normal ((view n . shift n . view i . shift i) y) == normal y hunk ./tests/Properties.hs 485 - ,("view reviersible" , mytest prop_view_reversible) - ,("view / xinerama" , mytest prop_view_xinerama) + ,("view reversible" , mytest prop_view_reversible) +-- ,("view / xinerama" , mytest prop_view_xinerama) hunk ./tests/Properties.hs 489 - ,("valid workspace xinerama", mytest prop_lookupWorkspace) +-- ,("valid workspace xinerama", mytest prop_lookupWorkspace) hunk ./StackSet.hs 80 - focusWindow, member, findIndex, insertLeft, delete, swap, shift + focusWindow, member, findIndex, insertLeft, delete, swap, shift, + modify -- needed by users hunk ./Main.hs 48 - , xineScreens = xinesc hunk ./Main.hs 52 - , dimensions = (fromIntegral (displayWidth dpy dflt), - fromIntegral (displayHeight dpy dflt)) hunk ./Main.hs 57 - , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] } + , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] + , xineScreens = xinesc + , dimensions = (fromIntegral (displayWidth dpy dflt), + fromIntegral (displayHeight dpy dflt)) } hunk ./Operations.hs 103 - (sw,sh) <- asks dimensions + (sw,sh) <- gets dimensions hunk ./Operations.hs 114 - XState { windowset = ws, layouts = fls } <- get - XConf { xineScreens = xinesc, display = d } <- ask + XState { windowset = ws, layouts = fls, xineScreens = xinesc } <- get + d <- asks display hunk ./XMonad.hs 42 + , xineScreens :: ![Rectangle] -- ^ dimensions of each screen + , dimensions :: !(Int,Int) -- ^ dimensions of the screen, + -- used for hiding windows hunk ./XMonad.hs 54 - , dimensions :: !(Int,Int) -- ^ dimensions of the screen, - -- used for hiding windows hunk ./XMonad.hs 55 - , xineScreens :: ![Rectangle] -- ^ dimensions of each screen hunk ./XMonad.hs 41 - { windowset :: !WindowSet -- ^ workspace list - , xineScreens :: ![Rectangle] -- ^ dimensions of each screen - , dimensions :: !(Int,Int) -- ^ dimensions of the screen, - -- used for hiding windows + { windowset :: !WindowSet -- ^ workspace list + , xineScreens :: ![Rectangle] -- ^ dimensions of each screen + , dimensions :: !(Position,Position) -- ^ dimensions of the screen, + -- used for hiding windows hunk ./Operations.hs 104 - io $ moveWindow d w (2*fromIntegral sw) (2*fromIntegral sh) + io $ moveWindow d w (2*sw) (2*sh) hunk ./StackSet.hs 118 - } deriving (Show, Eq) + } deriving (Show, Read, Eq) hunk ./StackSet.hs 122 - deriving (Show, Eq) + deriving (Show, Read, Eq) hunk ./StackSet.hs 128 - deriving (Show, Eq) + deriving (Show, Read, Eq) hunk ./StackSet.hs 146 - deriving (Show, Eq) + deriving (Show, Read, Eq) hunk ./XMonad.hs 61 -newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) +newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) hunk ./XMonad.hs 64 -newtype ScreenId = S Int deriving (Eq,Ord,Show,Enum,Num,Integral,Real) +newtype ScreenId = S Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) hunk ./Config.hs 172 - , ((modMask .|. shiftMask .|. controlMask, xK_q ), io restart) + , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart) hunk ./XMonad.hs 146 -restart :: IO () -restart = do +restart :: X () +restart = io $ do hunk ./XMonad.hs 32 -import System.Directory hunk ./XMonad.hs 148 - prog_path <- findExecutable prog - case prog_path of - Nothing -> return () -- silently fail - Just p -> do args <- getArgs - executeFile p True args Nothing + args <- getArgs + catch (executeFile prog True args Nothing) (const $ return ()) hunk ./Config.hs 172 - , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart) + , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart Nothing False) hunk ./Main.hs 20 +import System.Environment (getArgs) + hunk ./Main.hs 46 + args <- getArgs hunk ./Main.hs 48 - let safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x, xs) + let winset | ("--resume" : s : _) <- args + , [(x, "")] <- reads s = x + | otherwise = new (fromIntegral workspaces) (fromIntegral $ length xinesc) + safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x, xs) hunk ./Main.hs 62 - { windowset = new (fromIntegral workspaces) (fromIntegral $ length xinesc) + { windowset = winset hunk ./XMonad.hs 143 --- | Restart xmonad by exec()'ing self. This doesn't save state and xmonad has --- to be in PATH for this to work. -restart :: X () -restart = io $ do - prog <- getProgName - args <- getArgs - catch (executeFile prog True args Nothing) (const $ return ()) +-- | Restart xmonad via exec(). +-- +-- If the first parameter is 'Just name', restart will attempt to execute the +-- program corresponding to 'name'. Otherwise, xmonad will attempt to execute +-- the name of the current program. +-- +-- When the second parameter is 'True', xmonad will attempt to resume with the +-- current window state. +restart :: Maybe String -> Bool -> X () +restart mprog resume = do + prog <- maybe (io $ getProgName) return mprog + args <- io $ getArgs + args' <- if resume then gets (("--resume":) . return . show . windowset) else return [] + io $ catch (executeFile prog True (args ++ args') Nothing) + (const $ return ()) -- ignore executable not found exception hunk ./Operations.hs 21 -import Data.List (genericIndex) +import Data.List (genericIndex, intersectBy) hunk ./Operations.hs 68 -view n = withWorkspace $ \old -> when (n /= (W.tag (W.workspace (W.current old)))) $ do - windows $ W.view n -- move in new workspace first, to avoid flicker - - -- Hide the old workspace if it is no longer visible - oldWsNotVisible <- liftM (notElem (W.current old)) (gets (W.visible . windowset)) - when oldWsNotVisible $ mapM_ hide (W.index old) - clearEnterEvents -- better clear any events from the old workspace +view = windows . W.view hunk ./Operations.hs 92 -windows f = modify (\s -> s { windowset = f (windowset s) }) >> refresh +windows f = do + oldws <- gets windowset + let news = f oldws + modify (\s -> s { windowset = news }) + refresh + -- TODO: this requires too much mucking about with StackSet internals + mapM_ hide . concatMap (integrate . W.stack) $ + intersectBy (\w x -> W.tag w == W.tag x) (map W.workspace $ W.current oldws : W.visible oldws) (W.hidden news) + -- intersection of previously visible with currently hidden + clearEnterEvents + where + -- TODO: move this into StackSet. This isn't exactly the usual integrate. + integrate W.Empty = [] + integrate (W.Node x l r) = x : l ++ r hunk ./XMonad.hs 156 - io $ catch (executeFile prog True (args ++ args') Nothing) + io $ catch (executeFile prog True (args' ++ args) Nothing) hunk ./Operations.hs 111 - io $ moveWindow d w (2*sw) (2*sh) + io $ moveWindow d w sw sh hunk ./tests/Catch.hs 13 - screen ||| peekStack ||| index ||| empty ||| peek ||| push ||| delete ||| member ||| - raiseFocus ||| rotate ||| promote ||| shift ||| view ||| workspace ||| insert ||| - visibleWorkspaces ||| swap {- helper -} + new + ||| view + ||| lookupWorkspace + ||| modify + ||| peek + ||| index + ||| focusLeft + ||| focusRight + ||| focusWindow + ||| member + ||| findIndex + ||| insertLeft + ||| delete + ||| swap + ||| shift hunk ./Main.hs 29 -import Operations (manage, unmanage, focus, setFocusX, full, isClient) +import Operations (manage, unmanage, focus, setFocusX, full, isClient, rescreen) hunk ./Main.hs 73 - .|. enterWindowMask .|. leaveWindowMask + .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask hunk ./Main.hs 174 +-- the root may have configured +handle e@(ConfigureEvent {ev_window = w}) = do + r <- asks theRoot + when (r == w) rescreen + hunk ./Operations.hs 31 +import Graphics.X11.Xinerama (getScreenInfo) hunk ./Operations.hs 157 +-- --------------------------------------------------------------------- + +-- | rescreen. The screen configuration may have changed, update the state and +-- refresh the screen. +rescreen :: X () +rescreen = do + dpy <- asks display + xinesc <- io $ getScreenInfo dpy + -- TODO: This stuff is necessary because Xlib apparently caches screen + -- width/height. Find a better solution later. I hate Xlib. + let sx = maximum $ map (\r -> rect_x r + fromIntegral (rect_width r)) xinesc + sy = maximum $ map (\r -> rect_y r + fromIntegral (rect_height r)) xinesc + modify (\s -> s { xineScreens = xinesc, dimensions = (sx, sy) }) + windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) -> + let (x:xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs + in ws { W.current = W.Screen x 0 + , W.visible = zipWith W.Screen xs [1 ..] + , W.hidden = ys } + hunk ./Main.hs 175 -handle e@(ConfigureEvent {ev_window = w}) = do - r <- asks theRoot - when (r == w) rescreen +handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen hunk ./XMonad.hs 86 -withDisplay :: (Display -> X ()) -> X () +withDisplay :: (Display -> X a) -> X a hunk ./Operations.hs 163 - dpy <- asks display - xinesc <- io $ getScreenInfo dpy + xinesc <- withDisplay (io . getScreenInfo) hunk ./XMonad.hs 153 - prog <- maybe (io $ getProgName) return mprog - args <- io $ getArgs - args' <- if resume then gets (("--resume":) . return . show . windowset) else return [] - io $ catch (executeFile prog True (args' ++ args) Nothing) + prog <- maybe (io $ getProgName) return mprog + args <- if resume then gets (("--resume":) . return . show . windowset) else return [] + io $ catch (executeFile prog True args Nothing) hunk ./Config.hs 163 + , ((modMask, xK_Left ), swapLeft) + , ((modMask, xK_Right ), swapRight) + hunk ./Config.hs 178 - , ((modMask, xK_Return), swap) + , ((modMask, xK_Return), swapMaster) hunk ./Operations.hs 54 -focusLeft, focusRight :: X () +focusLeft, focusRight, swapLeft, swapRight :: X () hunk ./Operations.hs 57 +swapLeft = windows W.swapLeft +swapRight = windows W.swapRight hunk ./Operations.hs 60 --- | swap. Move the currently focused window into the master frame -swap :: X () -swap = windows W.swap +-- | swapMaster. Move the currently focused window into the master frame +swapMaster :: X () +swapMaster = windows W.swapMaster hunk ./StackSet.hs 80 - focusWindow, member, findIndex, insertLeft, delete, swap, shift, - modify -- needed by users + focusWindow, member, findIndex, insertLeft, delete, shift, + swapMaster, swapLeft, swapRight, modify -- needed by users hunk ./StackSet.hs 95 +-- swapLeft, swapRight hunk ./StackSet.hs 99 --- swap, -- was: promote +-- swapMaster, -- was: promote/swap hunk ./StackSet.hs 243 --- /O(1), O(w) on the wrapping case/. Move the window focus left or +-- /O(1), O(w) on the wrapping case/. +-- +-- focusLeft, focusRight. Move the window focus left or hunk ./StackSet.hs 250 -focusLeft, focusRight :: StackSet i a s -> StackSet i a s +-- swapLeft, swapRight. Swap the focused window with its left or right +-- neighbour in the stack ordering, wrapping if we reach the end. Again +-- the wrapping model should 'cycle' on the current stack. +-- +focusLeft, focusRight, swapLeft, swapRight :: StackSet i a s -> StackSet i a s hunk ./StackSet.hs 265 +swapLeft = modify Empty $ \c -> case c of + Node _ [] [] -> c + Node t (l:ls) rs -> Node t ls (l:rs) + Node t [] rs -> Node t (reverse rs) [] + +swapRight = modify Empty $ \c -> case c of + Node _ [] [] -> c + Node t ls (r:rs) -> Node t (r:ls) rs + Node t ls [] -> Node t [] (reverse ls) + hunk ./StackSet.hs 362 -swap :: StackSet i a s -> StackSet i a s -swap = modify Empty $ \c -> case c of +swapMaster :: StackSet i a s -> StackSet i a s +swapMaster = modify Empty $ \c -> case c of hunk ./tests/Properties.hs 158 -prop_swap_I (x :: T) = invariant $ swap x +prop_swap_master_I (x :: T) = invariant $ swapMaster x + +prop_swap_left_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const swapLeft ) x [1..n] +prop_swap_right_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const swapRight) x [1..n] hunk ./tests/Properties.hs 357 - y = swap x -- sets the master window to the current focus. - -- otherwise, we don't have a rule for where master goes. + y = swapMaster x -- sets the master window to the current focus. + -- otherwise, we don't have a rule for where master goes. hunk ./tests/Properties.hs 387 - y = swap x + y = swapMaster x hunk ./tests/Properties.hs 396 --- swap: setting the master window - --- prop_swap_reversible a b xs = swap a b (swap a b ys) == ys --- where ys = nub xs :: [Int] - --- swap doesn't change focus -prop_swap_focus (x :: T) - = case peek x of - Nothing -> True - Just f -> focus (stack (workspace $ current (swap x))) == f - --- swap is local -prop_swap_local (x :: T) = hidden_spaces x == hidden_spaces (swap x) +-- swapLeft, swapRight, swapMaster: reordiring windows hunk ./tests/Properties.hs 398 +-- swap is trivially reversible +prop_swap_left (x :: T) = (swapLeft (swapRight x)) == x +prop_swap_right (x :: T) = (swapRight (swapLeft x)) == x hunk ./tests/Properties.hs 413 -prop_swap_idempotent (x :: T) = swap (swap x) == swap x +-- swap doesn't change focus +prop_swap_master_focus (x :: T) = peek x == (peek $ swapMaster x) +-- = case peek x of +-- Nothing -> True +-- Just f -> focus (stack (workspace $ current (swap x))) == f +prop_swap_left_focus (x :: T) = peek x == (peek $ swapLeft x) +prop_swap_right_focus (x :: T) = peek x == (peek $ swapRight x) + +-- swap is local +prop_swap_master_local (x :: T) = hidden_spaces x == hidden_spaces (swapMaster x) +prop_swap_left_local (x :: T) = hidden_spaces x == hidden_spaces (swapLeft x) +prop_swap_right_local (x :: T) = hidden_spaces x == hidden_spaces (swapRight x) + +-- rotation through the height of a stack gets us back to the start +prop_swap_all_l (x :: T) = (foldr (const swapLeft) x [1..n]) == x + where n = length (index x) +prop_swap_all_r (x :: T) = (foldr (const swapRight) x [1..n]) == x + where n = length (index x) + +prop_swap_master_idempotent (x :: T) = swapMaster (swapMaster x) == swapMaster x hunk ./tests/Properties.hs 447 - y = swap x + y = swapMaster x hunk ./tests/Properties.hs 541 - ,("swap: invariant " , mytest prop_swap_I) - ,("swap id on focus" , mytest prop_swap_focus) - ,("swap is idempotent" , mytest prop_swap_idempotent) - ,("swap is local" , mytest prop_swap_local) + ,("swapMaster: invariant", mytest prop_swap_master_I) + ,("swapLeft: invariant" , mytest prop_swap_left_I) + ,("swapRight: invariant", mytest prop_swap_right_I) + ,("swapMaster id on focus", mytest prop_swap_master_focus) + ,("swapLeft id on focus", mytest prop_swap_left_focus) + ,("swapRight id on focus", mytest prop_swap_right_focus) + ,("swapMaster is idempotent", mytest prop_swap_master_idempotent) + ,("swap all left " , mytest prop_swap_all_l) + ,("swap all right " , mytest prop_swap_all_r) + ,("swapMaster is local" , mytest prop_swap_master_local) + ,("swapLeft is local" , mytest prop_swap_left_local) + ,("swapRight is local" , mytest prop_swap_right_local) hunk ./Config.hs 175 - , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart Nothing False) + , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart Nothing True) hunk ./StackSet.hs 348 - removeWindow o n = foldr ($) s [view o,remove ,until ((Just w ==) . peek) focusLeft,view n] + removeWindow o n = foldr ($) s [view o,remove,view n] hunk ./StackSet.hs 351 - remove = modify Empty $ \c -> case c of + remove = modify Empty $ \c -> + if focus c == w + then case c of hunk ./StackSet.hs 357 + else c { left = w `L.delete` left c, right = w `L.delete` right c } hunk ./README 34 + + It is likely that you already have some of these dependencies. To check + whether you've got a package run 'ghc-pkg list some_package_name' hunk ./tests/Properties.hs 114 - ws = [ focus t : left t ++ right t - | w <- workspace (current s) : map workspace (visible s) ++ hidden s - , let t = stack w, t /= Empty ] + ws = concat [ focus t : left t ++ right t + | w <- workspace (current s) : map workspace (visible s) ++ hidden s + , let t = stack w, t /= Empty ] :: [Char] hunk ./tests/Properties.hs 395 +-- delete should not affect focus unless the focused element is what is being deleted +prop_delete_focus n (x :: T) = member n x && Just n /= peek x ==> peek (delete n x) == peek x + hunk ./tests/Properties.hs 543 + ,("delete/focus" , mytest prop_delete_focus) hunk ./Config.hs 142 -defaultLayouts = [ full, - tall defaultWindowsInMaster defaultDelta (1%2), - wide defaultWindowsInMaster defaultDelta (1%2) ] +defaultLayouts = [ full + , tall defaultWindowsInMaster defaultDelta (1%2) + , wide defaultWindowsInMaster defaultDelta (1%2) ] hunk ./tests/Properties.hs 106 + , accurateSize hunk ./tests/Properties.hs 119 + calculatedSize = length (visible s) + length (hidden s) + 1 -- +1 is for current + accurateSize = calculatedSize == size s hunk ./TODO 2 - - fix the numlock issue once and for all - - man page - + - generate man page from Config.hs + - screenshots/web page + - testing/ more QC + - check build systems for X11-extras/X11. + hunk ./TODO 8 - - external statusbar - - floating layer/transients - - more example layout algorithms implemented via config.hs - - more work stabilising and documenting the api - - set up trac? - - get 'design and impl' TR done. + - use more constrained type in StackSet to avoid pattern match warnings hunk ./TODO 14 -- think about the statusbar/multithreading. - Three shared TVars: - windowTitle :: TVar String - workspace :: TVar Int - statusText :: TVar String - Three threads: - Main thread, handles all of the events that it handles now. When - necessary, it writes to workspace or windowTitle - - Status IO thread, the algorithm is something like this: - forever $ do - s <- getLine - atomic (writeTVar statusText s) - - Statusbar drawing thread, waits for changes in all three TVars, and - redraws whenever it finds a change. - - -- Notes on new StackSet: - - The actors: screens, workspaces, windows - - Invariants: - - There is exactly one screen in focus at any given time. - - A screen views exactly one workspace. - - A workspace is visible on one or zero screens. - - A workspace has zero or more windows. - - A workspace has either one or zero windows in focus. Zero if the - workspace has no windows, one in all other cases. - - A window is a member of only one workspace. hunk ./tests/Catch.hs 1 - --- This is a test set for running with Catch --- http://www-users.cs.york.ac.uk/~ndm/catch/ - -module Catch where - -import StackSet - ---------------------------------------------------------------------- --- TESTING PROPERTIES - -main = - new - ||| view - ||| lookupWorkspace - ||| modify - ||| peek - ||| index - ||| focusLeft - ||| focusRight - ||| focusWindow - ||| member - ||| findIndex - ||| insertLeft - ||| delete - ||| swap - ||| shift - - ---------------------------------------------------------------------- --- CATCH FIRST-ORDER LIBRARY - --- this should be included with Catch by default --- and will be (one day!) - -foreign import primitive any0 :: a -foreign import primitive anyEval1 :: a -> b -foreign import primitive anyEval2 :: a -> b -> c -foreign import primitive anyEval3 :: a -> b -> c -> d - - -class Test a where - test :: a -> Bool - - -instance Test b => Test (a -> b) where - test f = test (f any0) - -instance Test (Maybe a) where - test f = anyEval1 f - -instance Test [a] where - test f = anyEval1 f - -instance Test (StackSet a b c) where - test f = anyEval1 f - -instance Test (a,b) where - test f = anyEval1 f - -instance Test Bool where - test f = anyEval1 f - -instance Test Char where - test f = anyEval1 f - -instance Test (IO a) where - test f = anyEval1 (f >> return ()) - - -(|||) :: (Test a, Test b) => a -> b -> IO c -(|||) l r = anyEval2 (test l) (test r) rmfile ./tests/Catch.hs hunk ./StackSet.hs 149 + +-- this function indicates to catch that an error is expected +abort x = error x + hunk ./StackSet.hs 164 - | otherwise = error "non-positive arguments to StackSet.new" + | otherwise = abort "non-positive arguments to StackSet.new" hunk ./StackSet.hs 194 - | otherwise = error "Inconsistent StackSet: workspace not found" + | otherwise = abort "Inconsistent StackSet: workspace not found" hunk ./StackSet.hs 150 --- this function indicates to catch that an error is expected -abort x = error x +-- | this function indicates to catch that an error is expected +abort :: String -> a +abort x = error $ "xmonad: StackSet: " ++ x hunk ./Config.hs 151 + -- launching and killing programs hunk ./Config.hs 155 + , ((modMask .|. shiftMask, xK_c ), kill) + + -- rotate through the available layout algorithms hunk ./Config.hs 163 - , ((modMask, xK_Tab ), focusRight) - , ((modMask, xK_j ), focusRight) - , ((modMask, xK_k ), focusLeft) + -- move focus up or down the window stack + , ((modMask, xK_Tab ), focusDown) + , ((modMask, xK_j ), focusDown) + , ((modMask, xK_k ), focusUp) hunk ./Config.hs 168 - , ((modMask, xK_Left ), swapLeft) - , ((modMask, xK_Right ), swapRight) + -- modifying the window order + , ((modMask, xK_Return), swapMaster) + , ((modMask .|. shiftMask, xK_j ), swapDown) + , ((modMask .|. shiftMask, xK_k ), swapUp) hunk ./Config.hs 173 + -- resizing the master/slave ratio hunk ./Config.hs 177 - , ((modMask .|. shiftMask, xK_j ), sendMessage (IncMasterN 1)) - , ((modMask .|. shiftMask, xK_k ), sendMessage (IncMasterN (-1))) - - , ((modMask .|. shiftMask, xK_c ), kill) + -- increase or decrease number of windows in the master area + , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) + , ((modMask , xK_period), sendMessage (IncMasterN (-1))) hunk ./Config.hs 181 + -- quit, or restart hunk ./Config.hs 185 - -- Cycle the current tiling order - , ((modMask, xK_Return), swapMaster) - hunk ./Operations.hs 46 - windows $ W.insertLeft w + windows $ W.insertUp w hunk ./Operations.hs 54 -focusLeft, focusRight, swapLeft, swapRight :: X () -focusLeft = windows W.focusLeft -focusRight = windows W.focusRight -swapLeft = windows W.swapLeft -swapRight = windows W.swapRight +focusUp, focusDown, swapUp, swapDown :: X () +focusUp = windows W.focusUp +focusDown = windows W.focusDown +swapUp = windows W.swapUp +swapDown = windows W.swapDown hunk ./StackSet.hs 79 - new, view, lookupWorkspace, peek, index, focusLeft, focusRight, - focusWindow, member, findIndex, insertLeft, delete, shift, - swapMaster, swapLeft, swapRight, modify -- needed by users + new, view, lookupWorkspace, peek, index, focusUp, focusDown, + focusWindow, member, findIndex, insertUp, delete, shift, + swapMaster, swapUp, swapDown, modify -- needed by users hunk ./StackSet.hs 94 --- focusLeft, focusRight, -- was: rotate --- swapLeft, swapRight +-- focusUp, focusDown, -- was: rotate +-- swapUp, swapDown hunk ./StackSet.hs 97 --- insertLeft, -- was: insert/push +-- insertUp, -- was: insert/push hunk ./StackSet.hs 134 --- the master window is by convention the left most item. +-- the master window is by convention the top-most item. hunk ./StackSet.hs 136 --- flattening the cursor. +-- flattening the cursor. The structure can be envisaged as: +-- +-- +-- master: < '7' > +-- up | [ '2' ] +-- +--------- [ '3' ] +-- focus: < '4' > +-- dn +----------- [ '8' ] hunk ./StackSet.hs 151 - , left :: [a] -- clowns to the left - , right :: [a] } -- jokers to the right + , up :: [a] -- clowns to the left + , down :: [a] } -- jokers to the right hunk ./StackSet.hs 256 --- focusLeft, focusRight. Move the window focus left or --- right, wrapping if we reach the end. The wrapping should model a --- 'cycle' on the current stack. The 'master' window, and window order, +-- focusUp, focusDown. Move the window focus up or down the stack, +-- wrapping if we reach the end. The wrapping should model a -- 'cycle' +-- on the current stack. The 'master' window, and window order, hunk ./StackSet.hs 261 --- swapLeft, swapRight. Swap the focused window with its left or right --- neighbour in the stack ordering, wrapping if we reach the end. Again --- the wrapping model should 'cycle' on the current stack. +-- swapUp, swapDown, swap the neighbour in the stack ordering, wrapping +-- if we reach the end. Again the wrapping model should 'cycle' on +-- the current stack. hunk ./StackSet.hs 265 -focusLeft, focusRight, swapLeft, swapRight :: StackSet i a s -> StackSet i a s -focusLeft = modify Empty $ \c -> case c of +focusUp, focusDown, swapUp, swapDown :: StackSet i a s -> StackSet i a s +focusUp = modify Empty $ \c -> case c of hunk ./StackSet.hs 271 -focusRight = modify Empty $ \c -> case c of +focusDown = modify Empty $ \c -> case c of hunk ./StackSet.hs 276 -swapLeft = modify Empty $ \c -> case c of +swapUp = modify Empty $ \c -> case c of hunk ./StackSet.hs 281 -swapRight = modify Empty $ \c -> case c of +swapDown = modify Empty $ \c -> case c of hunk ./StackSet.hs 294 - return $ until ((Just w ==) . peek) focusLeft (view n s) + return $ until ((Just w ==) . peek) focusUp (view n s) hunk ./StackSet.hs 319 --- the stack, to the left of the currently focused element. +-- the stack, above the currently focused element. hunk ./StackSet.hs 322 --- The previously focused element is moved to the right. The previously +-- The previously focused element is moved down. The previously hunk ./StackSet.hs 329 --- However, we choose to insert to the left, and move the focus. +-- However, we choose to insert above, and move the focus. hunk ./StackSet.hs 331 -insertLeft :: Eq a => a -> StackSet i a s -> StackSet i a s -insertLeft a s = if member a s then s else insert +insertUp :: Eq a => a -> StackSet i a s -> StackSet i a s +insertUp a s = if member a s then s else insert hunk ./StackSet.hs 335 --- insertRight :: a -> StackSet i a s -> StackSet i a s --- insertRight a = modify (Node a [] []) $ \(Node t l r) -> Node a (t:l) r +-- insertDown :: a -> StackSet i a s -> StackSet i a s +-- insertDown a = modify (Node a [] []) $ \(Node t l r) -> Node a (t:l) r hunk ./StackSet.hs 338 --- > w { right = a : right w } +-- > w { down = a : down w } hunk ./StackSet.hs 345 --- * otherwise, try to move focus to the right --- * otherwise, try to move focus to the left +-- * otherwise, try to move focus to the down +-- * otherwise, try to move focus to the up hunk ./StackSet.hs 362 - remove = modify Empty $ \c -> - if focus c == w + remove = modify Empty $ \c -> + if focus c == w hunk ./StackSet.hs 365 - Node _ ls (r:rs) -> Node r ls rs -- try right first - Node _ (l:ls) [] -> Node l ls [] -- else left. + Node _ ls (r:rs) -> Node r ls rs -- try down first + Node _ (l:ls) [] -> Node l ls [] -- else up hunk ./StackSet.hs 368 - else c { left = w `L.delete` left c, right = w `L.delete` right c } + else c { up = w `L.delete` up c, down = w `L.delete` down c } hunk ./StackSet.hs 381 - -- natural! keep focus, move current to furthest left, move furthest --- left to current position. + -- natural! keep focus, move current to the top, move top to current. hunk ./StackSet.hs 389 --- inserted to the left of the currently focused element on that --- workspace. The actual focused workspace doesn't change. If there is --- no element on the current stack, the original stackSet is returned. +-- inserted above the currently focused element on that workspace. -- +-- The actual focused workspace doesn't change. If there is -- no +-- element on the current stack, the original stackSet is returned. hunk ./StackSet.hs 396 - where go w = foldr ($) s [view (tag (workspace (current s))),insertLeft w,view n,delete w] + where go w = foldr ($) s [view (tag (workspace (current s))),insertUp w,view n,delete w] hunk ./tests/Properties.hs 73 - foldr insertLeft (view i s) ys) + foldr insertUp (view i s) ys) hunk ./tests/Properties.hs 77 - Just i -> foldr (const focusLeft) t [0..i] ) s fs + Just i -> foldr (const focusUp) t [0..i] ) s fs hunk ./tests/Properties.hs 115 - ws = concat [ focus t : left t ++ right t + ws = concat [ focus t : up t ++ down t hunk ./tests/Properties.hs 143 -prop_focusLeft_I (n :: NonNegative Int) (x :: T) = - invariant $ foldr (const focusLeft) x [1..n] -prop_focusRight_I (n :: NonNegative Int) (x :: T) = - invariant $ foldr (const focusRight) x [1..n] +prop_focusUp_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const focusUp) x [1..n] +prop_focusDown_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const focusDown) x [1..n] hunk ./tests/Properties.hs 151 - Just _ -> let w = focus . stack . workspace . current $ foldr (const focusLeft) x [1..n] + Just _ -> let w = focus . stack . workspace . current $ foldr (const focusUp) x [1..n] hunk ./tests/Properties.hs 154 -prop_insertLeft_I n (x :: T) = invariant $ insertLeft n x +prop_insertUp_I n (x :: T) = invariant $ insertUp n x hunk ./tests/Properties.hs 164 - invariant $ foldr (const swapLeft ) x [1..n] + invariant $ foldr (const swapUp ) x [1..n] hunk ./tests/Properties.hs 166 - invariant $ foldr (const swapRight) x [1..n] + invariant $ foldr (const swapDown) x [1..n] hunk ./tests/Properties.hs 265 - list = focus it : left it ++ right it + list = focus it : up it ++ down it hunk ./tests/Properties.hs 276 - index (foldr (const focusLeft) x [1..n]) == index x + index (foldr (const focusUp) x [1..n]) == index x hunk ./tests/Properties.hs 278 - index (foldr (const focusRight) x [1..n]) == index x + index (foldr (const focusDown) x [1..n]) == index x hunk ./tests/Properties.hs 287 -prop_focus_left (x :: T) = (focusLeft (focusRight x)) == x -prop_focus_right (x :: T) = (focusRight (focusLeft x)) == x +prop_focus_left (x :: T) = (focusUp (focusDown x)) == x +prop_focus_right (x :: T) = (focusDown (focusUp x)) == x hunk ./tests/Properties.hs 299 -prop_focus_all_l (x :: T) = (foldr (const focusLeft) x [1..n]) == x +prop_focus_all_l (x :: T) = (foldr (const focusUp) x [1..n]) == x hunk ./tests/Properties.hs 301 -prop_focus_all_r (x :: T) = (foldr (const focusRight) x [1..n]) == x +prop_focus_all_r (x :: T) = (foldr (const focusDown) x [1..n]) == x hunk ./tests/Properties.hs 308 -prop_focus_local (x :: T) = hidden_spaces (focusRight x) == hidden_spaces x +prop_focus_local (x :: T) = hidden_spaces (focusDown x) == hidden_spaces x hunk ./tests/Properties.hs 329 - , i <- focus (stack w) : left (stack w) ++ right (stack w) + , i <- focus (stack w) : up (stack w) ++ down (stack w) hunk ./tests/Properties.hs 336 -prop_insert_empty i (n :: Positive Int) (m :: Positive Int) = member i (insertLeft i x) +prop_insert_empty i (n :: Positive Int) (m :: Positive Int) = member i (insertUp i x) hunk ./tests/Properties.hs 340 -prop_insert_idem i (x :: T) = insertLeft i x == insertLeft i (insertLeft i x) +prop_insert_idem i (x :: T) = insertUp i x == insertUp i (insertUp i x) hunk ./tests/Properties.hs 343 -prop_insert_duplicate i (x :: T) = member i x ==> insertLeft i x == x +prop_insert_duplicate i (x :: T) = member i x ==> insertUp i x == x hunk ./tests/Properties.hs 346 -prop_insert_local (x :: T) i = not (member i x) ==> hidden_spaces x == hidden_spaces (insertLeft i x) +prop_insert_local (x :: T) i = not (member i x) ==> hidden_spaces x == hidden_spaces (insertUp i x) hunk ./tests/Properties.hs 351 - peek (foldr insertLeft x is) == Just (head is) + peek (foldr insertUp x is) == Just (head is) hunk ./tests/Properties.hs 358 -prop_insert_delete n x = not (member n x) ==> delete n (insertLeft n y) == (y :: T) +prop_insert_delete n x = not (member n x) ==> delete n (insertUp n y) == (y :: T) hunk ./tests/Properties.hs 365 - size (foldr insertLeft x ws ) == (length ws) + size (foldr insertUp x ws ) == (length ws) hunk ./tests/Properties.hs 388 - Just n -> insertLeft n (delete n y) == y + Just n -> insertUp n (delete n y) == y hunk ./tests/Properties.hs 402 --- swapLeft, swapRight, swapMaster: reordiring windows +-- swapUp, swapDown, swapMaster: reordiring windows hunk ./tests/Properties.hs 405 -prop_swap_left (x :: T) = (swapLeft (swapRight x)) == x -prop_swap_right (x :: T) = (swapRight (swapLeft x)) == x +prop_swap_left (x :: T) = (swapUp (swapDown x)) == x +prop_swap_right (x :: T) = (swapDown (swapUp x)) == x hunk ./tests/Properties.hs 424 -prop_swap_left_focus (x :: T) = peek x == (peek $ swapLeft x) -prop_swap_right_focus (x :: T) = peek x == (peek $ swapRight x) +prop_swap_left_focus (x :: T) = peek x == (peek $ swapUp x) +prop_swap_right_focus (x :: T) = peek x == (peek $ swapDown x) hunk ./tests/Properties.hs 429 -prop_swap_left_local (x :: T) = hidden_spaces x == hidden_spaces (swapLeft x) -prop_swap_right_local (x :: T) = hidden_spaces x == hidden_spaces (swapRight x) +prop_swap_left_local (x :: T) = hidden_spaces x == hidden_spaces (swapUp x) +prop_swap_right_local (x :: T) = hidden_spaces x == hidden_spaces (swapDown x) hunk ./tests/Properties.hs 433 -prop_swap_all_l (x :: T) = (foldr (const swapLeft) x [1..n]) == x +prop_swap_all_l (x :: T) = (foldr (const swapUp) x [1..n]) == x hunk ./tests/Properties.hs 435 -prop_swap_all_r (x :: T) = (foldr (const swapRight) x [1..n]) == x +prop_swap_all_r (x :: T) = (foldr (const swapDown) x [1..n]) == x hunk ./tests/Properties.hs 516 - ,("focus left : invariant", mytest prop_focusLeft_I) - ,("focus right: invariant", mytest prop_focusRight_I) + ,("focus left : invariant", mytest prop_focusUp_I) + ,("focus right: invariant", mytest prop_focusDown_I) hunk ./tests/Properties.hs 532 - ,("insert: invariant" , mytest prop_insertLeft_I) + ,("insert: invariant" , mytest prop_insertUp_I) hunk ./tests/Properties.hs 549 - ,("swapLeft: invariant" , mytest prop_swap_left_I) - ,("swapRight: invariant", mytest prop_swap_right_I) + ,("swapUp: invariant" , mytest prop_swap_left_I) + ,("swapDown: invariant", mytest prop_swap_right_I) hunk ./tests/Properties.hs 552 - ,("swapLeft id on focus", mytest prop_swap_left_focus) - ,("swapRight id on focus", mytest prop_swap_right_focus) + ,("swapUp id on focus", mytest prop_swap_left_focus) + ,("swapDown id on focus", mytest prop_swap_right_focus) hunk ./tests/Properties.hs 558 - ,("swapLeft is local" , mytest prop_swap_left_local) - ,("swapRight is local" , mytest prop_swap_right_local) + ,("swapUp is local" , mytest prop_swap_left_local) + ,("swapDown is local" , mytest prop_swap_right_local) hunk ./README 53 - runhaskell Setup.lhs install + runhaskell Setup.lhs install --user adddir ./util hunk ./Config.hs 20 --- --- xmonad bindings follow mostly the dwm/wmii conventions: --- --- key combination action --- --- mod-shift-return new xterm --- mod-p launch dmenu --- mod-shift-p launch gmrun --- --- mod-space switch tiling mode --- mod-n nudge current window into fullscreen mode --- --- mod-tab shift focus to next window in stack --- mod-j shift focus to next window in stack --- mod-k shift focus previous window in stack --- --- mod-h decrease the size of the master area --- mod-l increase the size of the master area --- --- mod-shift-c kill client --- mod-shift-q exit window manager --- mod-shift-ctrl-q restart window manager ('xmonad' must be in $PATH) --- --- mod-return swap focused window with master window --- --- mod-1..9 switch to workspace N --- mod-shift-1..9 move client to workspace N --- --- mod-w,e,r switch to physical/Xinerama screen 1, 2 or 3. --- --- xmonad places each window into a "workspace." Each workspace can have --- any number of windows, which you can cycle though with mod-j and mod-k. --- Windows are either displayed full screen, tiled horizontally, or tiled --- vertically. You can toggle the layout mode with mod-space, which will --- cycle through the available modes. --- --- You can switch to workspace N with mod-N. For example, to switch to --- workspace 5, you would press mod-5. Similarly, you can move the current --- window to another workspace with mod-shift-N. --- --- When running with multiple monitors (Xinerama), each screen has exactly --- 1 workspace visible. When xmonad starts, workspace 1 is on screen 1, --- workspace 2 is on screen 2, etc. If you switch to a workspace which is --- currently visible on another screen, xmonad simply switches focus to --- that screen. If you switch to a workspace which is *not* visible, xmonad --- replaces the workspace on the *current* screen with the workspace you --- selected. --- --- For example, if you have the following configuration: --- --- Screen 1: Workspace 2 --- Screen 2: Workspace 5 (current workspace) --- --- and you wanted to view workspace 7 on screen 1, you would press: --- --- mod-2 (to select workspace 2, and make screen 1 the current screen) --- mod-7 (to select workspace 7) --- --- Since switching to the workspace currently visible on a given screen is --- such a common operation, shortcuts are provided: mod-{w,e,r} switch to --- the workspace currently visible on screens 1, 2, and 3 respectively. --- Likewise, shift-mod-{w,e,r} moves the current window to the workspace on --- that screen. Using these keys, the above example would become mod-w --- mod-7. --- - hunk ./Config.hs 86 - [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") - , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") - , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") - , ((modMask .|. shiftMask, xK_c ), kill) + [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- @@ Launch an xterm + , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") -- @@ Launch dmenu + , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") -- @@ Launch gmrun + , ((modMask .|. shiftMask, xK_c ), kill) -- @@ Close the focused window hunk ./Config.hs 91 - -- rotate through the available layout algorithms - , ((modMask, xK_space ), switchLayout) + , ((modMask, xK_space ), switchLayout) -- @@ Rotate through the available layout algorithms hunk ./Config.hs 93 - -- 'nudge': resize viewed windows to the correct size. - , ((modMask, xK_n ), refresh) + , ((modMask, xK_n ), refresh) -- 'nudge': resize viewed windows to the correct size hunk ./Config.hs 96 - , ((modMask, xK_Tab ), focusDown) - , ((modMask, xK_j ), focusDown) - , ((modMask, xK_k ), focusUp) + , ((modMask, xK_Tab ), focusDown) -- @@ Move focus to the next window + , ((modMask, xK_j ), focusDown) -- @@ Move focus to the next window + , ((modMask, xK_k ), focusUp ) -- @@ Move focus to the previous window hunk ./Config.hs 101 - , ((modMask, xK_Return), swapMaster) - , ((modMask .|. shiftMask, xK_j ), swapDown) - , ((modMask .|. shiftMask, xK_k ), swapUp) + , ((modMask, xK_Return), swapMaster) -- @@ Swap the focused window and the master window + , ((modMask .|. shiftMask, xK_j ), swapDown ) -- @@ Swap the focused window with the next window + , ((modMask .|. shiftMask, xK_k ), swapUp ) -- @@ Swap the focused window with the previous window hunk ./Config.hs 106 - , ((modMask, xK_h ), sendMessage Shrink) - , ((modMask, xK_l ), sendMessage Expand) + , ((modMask, xK_h ), sendMessage Shrink) -- @@ Shrink the master area + , ((modMask, xK_l ), sendMessage Expand) -- @@ Expand the master area hunk ./Config.hs 110 - , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) - , ((modMask , xK_period), sendMessage (IncMasterN (-1))) + , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) -- @@ Increment the number of windows in the master area + , ((modMask , xK_period), sendMessage (IncMasterN (-1))) -- @@ Deincrement the number of windows in the master area hunk ./Config.hs 114 - , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess) - , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart Nothing True) + , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad + , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart Nothing True) -- @@ Restart xmonad hunk ./Config.hs 118 - -- Keybindings to get to each workspace: + -- mod-[1..9] @@ Switch to workspace N + -- mod-shift-[1..9] @@ Move client to workspace N hunk ./Config.hs 124 - -- Keybindings to each screen : - -- mod-wer (underneath 123) switches to physical/Xinerama screens 1 2 and 3 + -- mod-{w,e,r} @@ Switch to physical/Xinerama screens 1, 2, or 3 + -- mod-shift-{w,e,r} @@ Move client to screen 1, 2, or 3 hunk ./Config.hs 131 - hunk ./TODO 2 - - generate man page from Config.hs hunk ./man/xmonad.1 1 -./" man page created by David Lazar on April 24, 2007 -./" uses ``tmac.an'' macro set -.TH xmonad 1 "18 April 07" xmonad\-1.0 "xmonad manual" -.SH NAME -xmonad \- a tiling window manager -.SH DESCRIPTION -.PP -\fBxmonad\fR is a minimalist tiling window manager for X, written in Haskell. Windows are managed using automatic layout algorithms, which can be dynamically reconfigured. At any time windows are arranged so as to maximise the use of screen real estate. All features of the window manager are accessible purely from the keyboard: a mouse is entirely optional. \fBxmonad\fR is configured in Haskell, and custom layout algorithms may be implemented by the user in config files. A principle of \fBxmonad\fR is predictability: the user should know in advance precisely the window arrangement that will result from any action. -.PP -By default, \fBxmonad\fR provides three layout algorithms: tall, wide and fullscreen. In tall or wide mode, windows are tiled and arranged to prevent overlap and maximise screen use. Sets of windows are grouped together on virtual screens, and each screen retains its own layout, which may be reconfigured dynamically. Multiple physical monitors are supported via Xinerama, allowing simultaneous display of a number of screens. -.PP -By utilising the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 500 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. -.SH USAGE -.PP -\fBxmonad\fR places each window into a "workspace". Each workspace can have any number of windows, which you can cycle though with mod-j and mod-k. Windows are either displayed full screen, tiled horizontally, or tiled vertically. You can toggle the layout mode with mod-space, which will cycle through the available modes. -.PP -You can switch to workspace N with mod-N. For example, to switch to workspace 5, you would press mod-5. Similarly, you can move the current window to another workspace with mod-shift-N. -.PP -When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. If you switch to a workspace which is currently visible on another screen, \fBxmonad\fR simply switches focus to that screen. If you switch to a workspace which is *not* visible, \fBxmonad\fR replaces the workspace on the *current* screen with the workspace you selected. -.PP -For example, if you have the following configuration: -.RS -.PP -Screen 1: Workspace 2 -.PP -Screen 2: Workspace 5 (current workspace) -.RE -.PP -and you wanted to view workspace 7 on screen 1, you would press: -.RS -.PP -mod-2 (to select workspace 2, and make screen 1 the current screen) -.PP -mod-7 (to select workspace 7) -.RE -.PP -Since switching to the workspace currently visible on a given screen is such a common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace currently visible on screens 1, 2, and 3 respectively. Likewise, shift-mod-{w,e,r} moves the current window to the workspace on that screen. Using these keys, the above example would become mod-w mod-7. -.SS Default keyboard bindings -.IP \fBmod\-shift\-return\fR -Launch \fBxterm\fR. -.IP \fBmod\-p\fR -Launch \fBdmenu\fR. -.IP \fBmod\-shift\-p\fR -Launch \fBgmrun\fR. -.IP \fBmod\-space\fR -Switch tiling mode. -.IP "\fBmod\-j\fR or \fBmod\-tab\fR" -Focus next window in stack. -.IP \fBmod\-k\fR -Focus previous window in stack. -.IP \fBmod\-h\fR -Decrease the size of the master area. -.IP \fBmod\-l\fR -Increase the size of the master area. -.IP \fBmod\-shift\-c\fR -Kill client. -.IP \fBmod\-shift\-q\fR -Exit xmonad window manager. -.IP \fBmod\-shift\-ctrl\-q\fR -Restart xmonad window manager. -.IP \fBmod\-return\fR -Cycle the current tiling order. -.IP \fBmod\-[1..9]\fR -Switch to workspace N. -.IP \fBmod\-shift\-[1..9]\fR -Move client to workspace N. -.IP \fBmod\-[w,e,r]\fR -Switch to physical/Xinerama screen 1, 2 or 3. -.SH EXAMPLES -To use \fBxmonad\fR as your window manager add: -.RS -exec xmonad -.RE -to your \fI~/.xinitrc\fR file -.SH CUSTOMIZATION -\fBxmonad\fR is customized by creating a custom Config.hs and (re)compiling the source code. -.SH BUGS -NumLock handling is broken. rmfile ./man/xmonad.1 addfile ./man/xmonad.1.in hunk ./man/xmonad.1.in 1 +./" man page created by David Lazar on April 24, 2007 +./" uses ``tmac.an'' macro set +.TH xmonad 1 "18 April 07" xmonad\-1.0 "xmonad manual" +.SH NAME +xmonad \- a tiling window manager +.SH DESCRIPTION +.PP +\fBxmonad\fR is a minimalist tiling window manager for X, written in Haskell. Windows are managed using automatic layout algorithms, which can be dynamically reconfigured. At any time windows are arranged so as to maximise the use of screen real estate. All features of the window manager are accessible purely from the keyboard: a mouse is entirely optional. \fBxmonad\fR is configured in Haskell, and custom layout algorithms may be implemented by the user in config files. A principle of \fBxmonad\fR is predictability: the user should know in advance precisely the window arrangement that will result from any action. +.PP +By default, \fBxmonad\fR provides three layout algorithms: tall, wide and fullscreen. In tall or wide mode, windows are tiled and arranged to prevent overlap and maximise screen use. Sets of windows are grouped together on virtual screens, and each screen retains its own layout, which may be reconfigured dynamically. Multiple physical monitors are supported via Xinerama, allowing simultaneous display of a number of screens. +.PP +By utilising the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 500 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. +.SH USAGE +.PP +\fBxmonad\fR places each window into a "workspace". Each workspace can have any number of windows, which you can cycle though with mod-j and mod-k. Windows are either displayed full screen, tiled horizontally, or tiled vertically. You can toggle the layout mode with mod-space, which will cycle through the available modes. +.PP +You can switch to workspace N with mod-N. For example, to switch to workspace 5, you would press mod-5. Similarly, you can move the current window to another workspace with mod-shift-N. +.PP +When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. If you switch to a workspace which is currently visible on another screen, \fBxmonad\fR simply switches focus to that screen. If you switch to a workspace which is *not* visible, \fBxmonad\fR replaces the workspace on the *current* screen with the workspace you selected. +.PP +For example, if you have the following configuration: +.RS +.PP +Screen 1: Workspace 2 +.PP +Screen 2: Workspace 5 (current workspace) +.RE +.PP +and you wanted to view workspace 7 on screen 1, you would press: +.RS +.PP +mod-2 (to select workspace 2, and make screen 1 the current screen) +.PP +mod-7 (to select workspace 7) +.RE +.PP +Since switching to the workspace currently visible on a given screen is such a common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace currently visible on screens 1, 2, and 3 respectively. Likewise, shift-mod-{w,e,r} moves the current window to the workspace on that screen. Using these keys, the above example would become mod-w mod-7. +.SS Default keyboard bindings +___KEYBINDINGS___ +.SH EXAMPLES +To use \fBxmonad\fR as your window manager add: +.RS +exec xmonad +.RE +to your \fI~/.xinitrc\fR file +.SH CUSTOMIZATION +\fBxmonad\fR is customized by creating a custom Config.hs and (re)compiling the source code. +.SH BUGS +NumLock handling is broken. addfile ./util/GenerateManpage.hs hunk ./util/GenerateManpage.hs 1 +-- +-- Generates man/xmonad.1 from man/xmonad.1.in by filling the list of +-- keybindings with values scraped from Config.hs +-- +-- Format for the docstrings in Config.hs takes the following form: +-- +-- -- mod-x @@ Frob the whatsit +-- +-- "Frob the whatsit" will be used as the description for keybinding "mod-x" +-- +-- If the keybinding name is omitted, it will try to guess from the rest of the +-- line. For example: +-- +-- [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- @@ Launch an xterm +-- +-- Here, mod-shift-return will be used as the keybinding name. +-- +import Control.Monad +import Text.Regex.Posix +import Data.Char +import Data.List + +trim :: String -> String +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +guessKeys line = concat $ intersperse "-" (modifiers ++ [map toLower key]) + where modifiers = map (!!1) (line =~ "(mod|shift|control)Mask") + (_, _, _, [key]) = line =~ "xK_(\\w+)" :: (String, String, String, [String]) + +binding :: [String] -> (String, String) +binding [ _, bindingLine, "", desc ] = (guessKeys bindingLine, desc) +binding [ _, _, keyCombo, desc ] = (keyCombo, desc) + +allBindings :: String -> [(String, String)] +allBindings xs = map (binding . map trim) (xs =~ "(.*)--(.*)@@(.*)") + +-- FIXME: What escaping should we be doing on these strings? +troff :: (String, String) -> String +troff (key, desc) = ".IP \\fB" ++ key ++ "\\fR\n" ++ desc ++ "\n" + +replace :: Eq a => a -> a -> [a] -> [a] +replace x y = map (\a -> if a == x then y else a) + +main = do + troffBindings <- (concatMap troff . allBindings) `liftM` readFile "./Config.hs" + let sed = unlines . replace "___KEYBINDINGS___" troffBindings . lines + readFile "./man/xmonad.1.in" >>= return . sed >>= writeFile "./man/xmonad.1" hunk ./TODO 2 - - screenshots/web page hunk ./Main.hs 83 + hunk ./Main.hs 95 - where - ok w = do wa <- getWindowAttributes dpy w - return $ not (wa_override_redirect wa) - && wa_map_state wa == waIsViewable + + where ok w = do wa <- getWindowAttributes dpy w + return $ not (wa_override_redirect wa) + && wa_map_state wa == waIsViewable hunk ./Main.hs 110 - where - grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync + + where grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync hunk ./Operations.hs 53 --- | focus. focus window to the left or right. -focusUp, focusDown, swapUp, swapDown :: X () -focusUp = windows W.focusUp -focusDown = windows W.focusDown -swapUp = windows W.swapUp -swapDown = windows W.swapDown - --- | swapMaster. Move the currently focused window into the master frame -swapMaster :: X () +-- | focus. focus window up or down. or swap various windows. +focusUp, focusDown, swapUp, swapDown, swapMaster :: X () +focusUp = windows W.focusUp +focusDown = windows W.focusDown +swapUp = windows W.swapUp +swapDown = windows W.swapDown hunk ./Operations.hs 93 - oldws <- gets windowset - let news = f oldws - modify (\s -> s { windowset = news }) + old <- gets windowset + let new = f old + modify (\s -> s { windowset = new }) hunk ./Operations.hs 97 - -- TODO: this requires too much mucking about with StackSet internals + + -- We now go to some effort to compute the minimal set of windows to hide. + -- The minimal set being only those windows which weren't previously hidden, + -- which is the intersection of previously visible windows with those now hidden hunk ./Operations.hs 102 - intersectBy (\w x -> W.tag w == W.tag x) (map W.workspace $ W.current oldws : W.visible oldws) (W.hidden news) - -- intersection of previously visible with currently hidden + intersectBy (\w x -> W.tag w == W.tag x) + (map W.workspace $ W.current old : W.visible old) + (W.hidden new) + hunk ./Operations.hs 107 - where + hunk ./Operations.hs 109 - integrate W.Empty = [] - integrate (W.Node x l r) = x : l ++ r + where integrate W.Empty = [] + integrate (W.Node x l r) = x : l ++ r hunk ./Operations.hs 163 --- | rescreen. The screen configuration may have changed, update the state and --- refresh the screen. +-- | rescreen. The screen configuration may have changed (due to +-- xrandr), update the state and refresh the screen. hunk ./Operations.hs 168 + hunk ./Operations.hs 173 + hunk ./Operations.hs 175 + hunk ./Operations.hs 189 -setButtonGrab True w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab $ \b -> - grabButton d b anyModifier w False (buttonPressMask .|. buttonReleaseMask) - grabModeAsync grabModeSync none none - -setButtonGrab False w = withDisplay $ \d -> io $ flip mapM_ buttonsToGrab $ \b -> - ungrabButton d b anyModifier w +setButtonGrab grab w = withDisplay $ \d -> io $ (`mapM_` buttonsToGrab) $ \b -> + if grab then grabButton d b anyModifier w False (buttonPressMask .|. buttonReleaseMask) + grabModeAsync grabModeSync none none + else ungrabButton d b anyModifier w hunk ./Operations.hs 199 -setTopFocus = withWorkspace $ \ws -> maybe (asks theRoot >>= setFocusX) setFocusX (W.peek ws) +setTopFocus = withWorkspace $ maybe (setFocusX =<< asks theRoot) setFocusX . W.peek hunk ./Operations.hs 270 -tall nmaster delta frac = Layout { doLayout = \r w -> return $ zip w $ tile frac r nmaster (length w) - , modifyLayout = \m -> fmap resize (fromMessage m) `mplus` fmap incmastern (fromMessage m) } +tall nmaster delta frac = + Layout { doLayout = \r -> return . ap zip (tile frac r nmaster . length) + , modifyLayout = \m -> fmap resize (fromMessage m) `mplus` + fmap incmastern (fromMessage m) } hunk ./Operations.hs 296 -tile _ r nmaster n | n <= nmaster = splitVertically n r -tile f r nmaster n = splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 +tile f r nmaster n | n <= nmaster = splitVertically n r + | otherwise = splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 hunk ./XMonad.hs 139 - return () hunk ./Operations.hs 25 -import System.Mem (performGC) +-- import System.Mem (performGC) hunk ./Operations.hs 143 - io performGC -- really helps +-- io performGC -- really helps hunk ./xmonad.cabal 27 -ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s +ghc-options: -funbox-strict-fields -O -fasm -Wall -optl-Wl,-s hunk ./Operations.hs 219 - withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0 + io $ do setInputFocus dpy w revertToPointerRoot 0 + raiseWindow dpy w hunk ./Config.hs 51 + +-- Default width of gap at top of screen for a menu bar (e.g. 16) +defaultMenuGap :: Int +defaultMenuGap = 0 hunk ./Config.hs-boot 4 +defaultMenuGap :: Int hunk ./Operations.hs 18 -import {-# SOURCE #-} Config (borderWidth) +import {-# SOURCE #-} Config (borderWidth,defaultMenuGap) hunk ./Operations.hs 134 + Rectangle sx sy sw sh = genericIndex xinesc (W.screen w) hunk ./Operations.hs 136 - rs <- doLayout l (genericIndex xinesc (W.screen w)) (W.index this) + rs <- doLayout l (Rectangle sx (sy + fromIntegral defaultMenuGap) + sw (sh - fromIntegral defaultMenuGap)) (W.index this) hunk ./Config.hs 52 --- Default width of gap at top of screen for a menu bar (e.g. 16) -defaultMenuGap :: Int -defaultMenuGap = 0 +-- Default height of gap at top of screen for a menu bar (e.g. 15) +defaultStatusGap :: Int +defaultStatusGap = 0 -- 15 for default dzen hunk ./Config.hs 117 + -- toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\n -> if n == 0 then defaultStatusGap else 0)) -- @@ Toggle the status bar gap + hunk ./Config.hs-boot 4 -defaultMenuGap :: Int hunk ./Main.hs 64 + , statusGap = defaultStatusGap hunk ./Operations.hs 18 -import {-# SOURCE #-} Config (borderWidth,defaultMenuGap) +import {-# SOURCE #-} Config (borderWidth) hunk ./Operations.hs 70 +-- | Modify the size of the status gap at the top of the screen +modifyGap :: (Int -> Int) -> X () +modifyGap f = do modify $ \s -> s { statusGap = max 0 (f (statusGap s)) } + refresh + + hunk ./Operations.hs 132 - XState { windowset = ws, layouts = fls, xineScreens = xinesc } <- get + XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGap = gap } <- get hunk ./Operations.hs 142 - rs <- doLayout l (Rectangle sx (sy + fromIntegral defaultMenuGap) - sw (sh - fromIntegral defaultMenuGap)) (W.index this) + rs <- doLayout l (Rectangle sx (sy + fromIntegral gap) + sw (sh - fromIntegral gap)) (W.index this) hunk ./XMonad.hs 43 + , statusGap :: !Int -- ^ width of status bar addfile ./util/gapcalc.c hunk ./util/gapcalc.c 1 +/* gapcalc - calculate height of given font + * Copyright (C) 2007 by Robert Manea + * + * Compile with: cc -lX11 -o gapcalc gapcalc.c + */ + +#include +#include +#include +#include +#include + +void +eprint(const char *errstr, ...) { + va_list ap; + + va_start(ap, errstr); + vfprintf(stderr, errstr, ap); + va_end(ap); + exit(EXIT_FAILURE); +} + + +int +main(int argc, char *argv[]) { + Display *dpy; + XFontStruct *xfont; + XFontSet set; + char *def, **missing; + char *fontstr; + int i, n, ascent, descent; + + if(argc < 2) + eprint("Usage: gapcalc \n"); + + if(!(dpy = XOpenDisplay(0))) + eprint("fatal: cannot open display\n"); + + fontstr = argv[1]; + missing = NULL; + + set = XCreateFontSet(dpy, fontstr, &missing, &n, &def); + if(missing) + XFreeStringList(missing); + if(set) { + XFontSetExtents *font_extents; + XFontStruct **xfonts; + char **font_names; + ascent = descent = 0; + font_extents = XExtentsOfFontSet(set); + n = XFontsOfFontSet(set, &xfonts, &font_names); + for(i = 0, ascent = 0, descent = 0; i < n; i++) { + if(ascent < (*xfonts)->ascent) + ascent = (*xfonts)->ascent; + if(descent < (*xfonts)->descent) + descent = (*xfonts)->descent; + xfonts++; + } + } else if(!set && (xfont = XLoadQueryFont(dpy, fontstr))) { + ascent = xfont->ascent; + descent = xfont->descent; + } else + eprint("fatal: cannot find specified font\n"); + + printf("%d\n", ascent + descent + 2); + + + return EXIT_SUCCESS; +} + hunk ./Operations.hs 228 - raiseWindow dpy w + -- raiseWindow dpy w hunk ./TODO 4 + - audit for events handled in dwm. hunk ./TODO 5 + - decide if the gap should be on all visible screens, or just the + current screen hunk ./Operations.hs 140 - Rectangle sx sy sw sh = genericIndex xinesc (W.screen w) - -- now tile the windows on this workspace - rs <- doLayout l (Rectangle sx (sy + fromIntegral gap) - sw (sh - fromIntegral gap)) (W.index this) + r@(Rectangle sx sy sw sh) = genericIndex xinesc (W.screen w) + + -- now tile the windows on this workspace, and set gap maybe on current + rs <- doLayout l (if w == W.current ws + then Rectangle sx (sy + fromIntegral gap) + sw (sh - fromIntegral gap) + else r) (W.index this) hunk ./Operations.hs 216 - setFocusX w + refresh -- and set gap -- was: setFocusX w hunk ./Operations.hs 218 + -- XXX a focus change could be caused by switching workspaces in xinerama. + -- if so, and the gap is in use, the gap should probably follow the + -- cursor to the new screen. + -- + -- to get the gap though, you need to trigger a refresh. hunk ./Operations.hs 213 +-- This happens if X notices we've moved the mouse (and perhaps moved +-- the mouse to a new screen). hunk ./Operations.hs 220 + -- we could refresh here, moving gap too. hunk ./Operations.hs 72 -modifyGap f = do modify $ \s -> s { statusGap = max 0 (f (statusGap s)) } - refresh - +modifyGap f = modify (\s -> s { statusGap = max 0 (f (statusGap s)) }) >> refresh hunk ./Operations.hs 142 - then Rectangle sx (sy + fromIntegral gap) - sw (sh - fromIntegral gap) - else r) (W.index this) + then Rectangle sx (sy + fromIntegral gap) sw (sh - fromIntegral gap) + else r) (W.index this) hunk ./Operations.hs 214 - if W.member w s then do modify $ \st -> st { windowset = W.focusWindow w s } -- avoid 'refresh' - refresh -- and set gap -- was: setFocusX w - else whenX (isRoot w) $ setFocusX w - -- we could refresh here, moving gap too. + if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> refresh + else whenX (isRoot w) $ setFocusX w -- we could refresh here, moving gap too. hunk ./xmonad.cabal 22 -extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1 +extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1.in hunk ./xmonad.cabal 23 + Config.hs-boot util/GenerateManpage.hs util/gapcalc.c hunk ./Config.hs 52 --- Default height of gap at top of screen for a menu bar (e.g. 15) -defaultStatusGap :: Int -defaultStatusGap = 0 -- 15 for default dzen +-- Default offset of drawable screen boundary from physical screen. +-- Anything non-zero here will leave a gap of that many pixels on the +-- given edge. A useful gap at top of screen for a menu bar (e.g. 15) +-- +-- Fields are: top, bottom, left, right. +-- +defaultGap :: (Int,Int,Int,Int) +defaultGap = (0,0,0,0) -- 15 for default dzen hunk ./Config.hs 123 - , ((modMask , xK_b ), modifyGap (\n -> if n == 0 then defaultStatusGap else 0)) -- @@ Toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\n -> if n == defaultGap then (0,0,0,0) else defaultGap)) -- @@ Toggle the status bar gap hunk ./Main.hs 64 - , statusGap = defaultStatusGap + , statusGap = defaultGap hunk ./Operations.hs 71 -modifyGap :: (Int -> Int) -> X () -modifyGap f = modify (\s -> s { statusGap = max 0 (f (statusGap s)) }) >> refresh +modifyGap :: ((Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X () +modifyGap f = modify (\s -> s { statusGap = f (statusGap s) }) >> refresh hunk ./Operations.hs 130 - XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGap = gap } <- get + XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGap = (gt,gb,gl,gr) } <- get hunk ./Operations.hs 142 - then Rectangle sx (sy + fromIntegral gap) sw (sh - fromIntegral gap) + then Rectangle (sx + fromIntegral gl) + (sy + fromIntegral gt) + (sw - fromIntegral (gl + gr)) + (sh - fromIntegral (gt + gb)) hunk ./XMonad.hs 40 - { windowset :: !WindowSet -- ^ workspace list - , xineScreens :: ![Rectangle] -- ^ dimensions of each screen - , dimensions :: !(Position,Position) -- ^ dimensions of the screen, - , statusGap :: !Int -- ^ width of status bar - -- used for hiding windows - , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) } + { windowset :: !WindowSet -- ^ workspace list + , xineScreens :: ![Rectangle] -- ^ dimensions of each screen + , dimensions :: !(Position,Position) -- ^ dimensions of the screen, + , statusGap :: !(Int,Int,Int,Int) -- ^ width of status bar + , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) } hunk ./XMonad.hs 48 - { display :: Display -- ^ the X11 display - - , theRoot :: !Window -- ^ the root window - , wmdelete :: !Atom -- ^ window deletion atom - , wmprotocols :: !Atom -- ^ wm protocols atom - - , normalBorder :: !Color -- ^ border color of unfocused windows - , focusedBorder :: !Color } -- ^ border color of the focused window + { display :: Display -- ^ the X11 display + , theRoot :: !Window -- ^ the root window + , wmdelete :: !Atom -- ^ window deletion atom + , wmprotocols :: !Atom -- ^ wm protocols atom + , normalBorder :: !Color -- ^ border color of unfocused windows + , focusedBorder :: !Color } -- ^ border color of the focused window hunk ./Config.hs 52 --- Default offset of drawable screen boundary from physical screen. +-- Default offset of drawable screen boundaries from each physical screen. hunk ./Config.hs 54 --- given edge. A useful gap at top of screen for a menu bar (e.g. 15) +-- given edge, on the that screen. A useful gap at top of screen for a menu bar (e.g. 15) hunk ./Config.hs 58 -defaultGap :: (Int,Int,Int,Int) -defaultGap = (0,0,0,0) -- 15 for default dzen +defaultGaps :: [(Int,Int,Int,Int)] +defaultGaps = [(0,0,0,0)] -- 15 for default dzen hunk ./Config.hs 123 - , ((modMask , xK_b ), modifyGap (\n -> if n == defaultGap then (0,0,0,0) else defaultGap)) -- @@ Toggle the status bar gap + , ((modMask , xK_b ), + modifyGap (\i n -> let x = defaultGaps !! i in if n == x then (0,0,0,0) else x)) -- @@ Toggle the status bar gap hunk ./Main.hs 64 - , statusGap = defaultGap + , statusGaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0) hunk ./Operations.hs 70 --- | Modify the size of the status gap at the top of the screen -modifyGap :: ((Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X () -modifyGap f = modify (\s -> s { statusGap = f (statusGap s) }) >> refresh +-- | Modify the size of the status gap at the top of the current screen +-- Taking a function giving the current screen, and current geometry. +modifyGap :: (Int -> (Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X () +modifyGap f = do + XState { windowset = ws, statusGaps = gaps } <- get + let n = fromIntegral $ W.screen (W.current ws) + (a,i:b) = splitAt n gaps + modify $ \s -> s { statusGaps = a ++ f n i : b } + refresh hunk ./Operations.hs 136 - XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGap = (gt,gb,gl,gr) } <- get + XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGaps = gaps } <- get hunk ./Operations.hs 145 + (gt,gb,gl,gr) = genericIndex gaps (W.screen w) hunk ./XMonad.hs 43 - , statusGap :: !(Int,Int,Int,Int) -- ^ width of status bar + , statusGaps :: ![(Int,Int,Int,Int)] -- ^ width of status bar on each screen hunk ./Main.hs 66 - , dimensions = (fromIntegral (displayWidth dpy dflt), + , dimensions = (fromIntegral (displayWidth dpy dflt), hunk ./Operations.hs 182 --- xrandr), update the state and refresh the screen. +-- xrandr), update the state and refresh the screen, and reset the gap. hunk ./Operations.hs 192 - modify (\s -> s { xineScreens = xinesc, dimensions = (sx, sy) }) + modify (\s -> s { xineScreens = xinesc , dimensions = (sx, sy) + , statusGaps = take (length xinesc) $ (statusGaps s) ++ repeat (0,0,0,0) }) hunk ./Config.hs 102 - , ((modMask, xK_n ), refresh) -- 'nudge': resize viewed windows to the correct size + , ((modMask, xK_n ), refresh) -- @@ 'nudge': resize viewed windows to the correct size hunk ./TODO 4 - - audit for events handled in dwm. - - decide if the gap should be on all visible screens, or just the - current screen hunk ./TODO 7 + - audit for events handled in dwm. hunk ./Config.hs 123 - , ((modMask , xK_b ), - modifyGap (\i n -> let x = defaultGaps !! i in if n == x then (0,0,0,0) else x)) -- @@ Toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\i n -> let x = defaultGaps !! i in if n == x then (0,0,0,0) else x)) -- @@ Toggle the status bar gap hunk ./xmonad.cabal 23 - Config.hs-boot util/GenerateManpage.hs util/gapcalc.c + Config.hs-boot util/GenerateManpage.hs man/xmonad.1 hunk ./util/gapcalc.c 1 -/* gapcalc - calculate height of given font - * Copyright (C) 2007 by Robert Manea - * - * Compile with: cc -lX11 -o gapcalc gapcalc.c - */ - -#include -#include -#include -#include -#include - -void -eprint(const char *errstr, ...) { - va_list ap; - - va_start(ap, errstr); - vfprintf(stderr, errstr, ap); - va_end(ap); - exit(EXIT_FAILURE); -} - - -int -main(int argc, char *argv[]) { - Display *dpy; - XFontStruct *xfont; - XFontSet set; - char *def, **missing; - char *fontstr; - int i, n, ascent, descent; - - if(argc < 2) - eprint("Usage: gapcalc \n"); - - if(!(dpy = XOpenDisplay(0))) - eprint("fatal: cannot open display\n"); - - fontstr = argv[1]; - missing = NULL; - - set = XCreateFontSet(dpy, fontstr, &missing, &n, &def); - if(missing) - XFreeStringList(missing); - if(set) { - XFontSetExtents *font_extents; - XFontStruct **xfonts; - char **font_names; - ascent = descent = 0; - font_extents = XExtentsOfFontSet(set); - n = XFontsOfFontSet(set, &xfonts, &font_names); - for(i = 0, ascent = 0, descent = 0; i < n; i++) { - if(ascent < (*xfonts)->ascent) - ascent = (*xfonts)->ascent; - if(descent < (*xfonts)->descent) - descent = (*xfonts)->descent; - xfonts++; - } - } else if(!set && (xfont = XLoadQueryFont(dpy, fontstr))) { - ascent = xfont->ascent; - descent = xfont->descent; - } else - eprint("fatal: cannot find specified font\n"); - - printf("%d\n", ascent + descent + 2); - - - return EXIT_SUCCESS; -} - rmfile ./util/gapcalc.c hunk ./Operations.hs 144 - r@(Rectangle sx sy sw sh) = genericIndex xinesc (W.screen w) - (gt,gb,gl,gr) = genericIndex gaps (W.screen w) + (Rectangle sx sy sw sh) = genericIndex xinesc (W.screen w) + (gt,gb,gl,gr) = genericIndex gaps (W.screen w) hunk ./Operations.hs 147 - -- now tile the windows on this workspace, and set gap maybe on current - rs <- doLayout l (if w == W.current ws - then Rectangle (sx + fromIntegral gl) - (sy + fromIntegral gt) - (sw - fromIntegral (gl + gr)) - (sh - fromIntegral (gt + gb)) - else r) (W.index this) + -- now tile the windows on this workspace, modified by the gap + rs <- doLayout l (Rectangle (sx + fromIntegral gl) + (sy + fromIntegral gt) + (sw - fromIntegral (gl + gr)) + (sh - fromIntegral (gt + gb))) (W.index this) hunk ./util/GenerateManpage.hs 39 -troff (key, desc) = ".IP \\fB" ++ key ++ "\\fR\n" ++ desc ++ "\n" +troff (key, desc) = ".IP\n \\fB" ++ key ++ "\\fR\n" ++ desc ++ "\n" hunk ./xmonad.cabal 23 - Config.hs-boot util/GenerateManpage.hs man/xmonad.1 + Config.hs-boot util/GenerateManpage.hs man/xmonad.1 man/xmonad.html hunk ./README 1 - xmonad : a lightweight X11 window manager. + xmonad : a lightweight X11 window manager. hunk ./README 3 - http://xmonad.org + http://xmonad.org + +------------------------------------------------------------------------ hunk ./README 9 -Xmonad is a minimalist tiling window manager for X, written in Haskell. Windows -are managed using automatic layout algorithms, which can be dynamically -reconfigured. At any time windows are arranged so as to maximise the use of -screen real estate. All features of the window manager are accessible purely -from the keyboard: a mouse is entirely optional. Xmonad is configured in -Haskell, and custom layout algorithms may be implemented by the user in config -files. A principle of Xmonad is predictability: the user should know in advance -precisely the window arrangement that will result from any action. + Xmonad is a tiling window manager for X. Windows are managed using + automatic tiling algorithms, which can be dynamically configured. + Windows are arranged so as to tile the screen without gaps, maximising + screen use. All features of the window manager are accessible + from the keyboard: a mouse is strictly optional. Xmonad is written + and extensible in Haskell, and custom layout algorithms may be + implemented by the user in config files. A guiding principle of the + user interface is predictability: users should know in + advance precisely the window arrangement that will result from any + action, leading to an intuitive user interface. + + Xmonad provides three tiling algorithms by default: tall, wide and + fullscreen. In tall or wide mode, all windows are visible and tiled + to fill the plane without gaps. In fullscreen mode only the focused + window is visible, filling the screen. Alternative tiling + algorithms are provided as extensions. Sets of windows are grouped + together on virtual workspaces and each workspace retains its own + layout. Multiple physical monitors are supported via Xinerama, + allowing simultaneous display of several workspaces. hunk ./README 29 -By default xmonad provides three layout algorithms: tall, wide and fullscreen. -In tall or wide mode, windows are tiled and arranged to prevent overlap and -maximise screen use. Sets of windows are grouped together on virtual screens, -and each screen retains its own layout, which may be reconfigured dynamically. -Multiple physical monitors are supported via Xinerama, allowing simultaneous -display of a number of screens. + Adhering to a minimalist philosophy of doing one job, and doing it + well, the entire code base remains tiny, and is written to be simple + to understand and modify. By using Haskell as a configuration + language arbitrarily complex extensions may be implemented by the + user using a powerful `scripting' language, without needing to + modify the window manager directly. For example, users may write + their own tiling algorithms. hunk ./README 37 -By utilising the expressivity of a modern functional language with a rich -static type system, Xmonad provides a complete, featureful window manager in -less than 500 lines of code, with an emphasis on correctness and robustness. -Internal properties of the window manager are checked using a combination of -static guarantees provided by the type system, and type-based automated -testing. A benefit of this is that the code is simple to understand, and easy -to modify. +------------------------------------------------------------------------ hunk ./README 47 + unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 + hunk ./README 52 + hunk ./README 54 - unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 hunk ./README 56 - dmenu 2.* http://www.suckless.org/download/dmenu-2.7.tar.gz - (optional) - hunk ./README 62 -Finally, add: +------------------------------------------------------------------------ + +Running xmonad: + + Add: hunk ./README 70 - to the last line of your .xsession file + to the last line of your .xsession file. + +------------------------------------------------------------------------ + +Other useful programs: + + For a program dispatch menu: + + dmenu http://www.suckless.org/download/ + or + gmrun (in your package system) + + For custom status bars: + + dzen http://gotmor.googlepages.com/dzen + + A nicer xterm replacment, that supports resizing better: + + urxvt http://software.schmorp.de/pkg/rxvt-unicode.html hunk ./README 70 - to the last line of your .xsession file. + to the last line of your .xsession or .xinitrc file. hunk ./Config.hs 123 - , ((modMask , xK_b ), modifyGap (\i n -> let x = defaultGaps !! i in if n == x then (0,0,0,0) else x)) -- @@ Toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- @@ Toggle the status bar gap hunk ./Operations.hs 223 - if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> refresh + if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) -- >> refresh hunk ./Operations.hs 223 - if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) -- >> refresh + if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> setFocusX w -- >> refresh hunk ./README 47 + (Included with GHC) + hunk ./README 50 + (Included with GHC) hunk ./README 53 + (Included with GHC) hunk ./README 58 - (included with ghc) hunk ./Config.hs 85 -defaultLayouts = [ full - , tall defaultWindowsInMaster defaultDelta (1%2) - , wide defaultWindowsInMaster defaultDelta (1%2) ] +defaultLayouts = [ tall defaultWindowsInMaster defaultDelta (1%2) + , wide defaultWindowsInMaster defaultDelta (1%2) + , full ] hunk ./man/xmonad.1.in 49 -NumLock handling is broken. +Probably. If you find any, please report them: http://code.google.com/p/xmonad/issues/list hunk ./Config.hs 102 - , ((modMask, xK_n ), refresh) -- @@ 'nudge': resize viewed windows to the correct size + , ((modMask, xK_n ), refresh) -- @@ Resize viewed windows to the correct size hunk ./Config.hs 126 - , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad + , ((modMask , xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad hunk ./Config.hs 126 - , ((modMask , xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad + , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad hunk ./Config.hs 127 - , ((modMask .|. shiftMask .|. controlMask, xK_q ), restart Nothing True) -- @@ Restart xmonad + , ((modMask , xK_q ), restart Nothing True) -- @@ Restart xmonad hunk ./man/xmonad.1.in 47 -\fBxmonad\fR is customized by creating a custom Config.hs and (re)compiling the source code. +\fBxmonad\fR is customized by creating a custom Config.hs and (re)compiling the source code. After recompiling, 'restart' is used to fork the new version, with changes reflected immediately. hunk ./README 52 - X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2 + X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2.2 hunk ./README 54 - (Unfortunately X11-1.2 does not work correctly on AMD64. The latest - darcs version from http://darcs.haskell.org/packages/X11 does.) hunk ./xmonad.cabal 21 -build-depends: base>=1.0, X11>=1.1, X11-extras>=0.0, mtl>=1.0, unix>=1.0 +build-depends: base>=1.0, X11>=1.2.1, X11-extras>=0.0, mtl>=1.0, unix>=1.0 hunk ./README 55 - X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.1 + X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.2 hunk ./xmonad.cabal 21 -build-depends: base>=1.0, X11>=1.2.1, X11-extras>=0.0, mtl>=1.0, unix>=1.0 +build-depends: base>=1.0, X11>=1.2.1, X11-extras>=0.2, mtl>=1.0, unix>=1.0 hunk ./XMonad.hs 153 - (const $ return ()) -- ignore executable not found exception + ( (hPutStrLn stderr). show ) -- print executable not found exception hunk ./XMonad.hs 153 - ( (hPutStrLn stderr). show ) -- print executable not found exception + (hPutStrLn stderr . show) -- print executable not found exception hunk ./xmonad.cabal 2 -version: 0.1 +version: 0.2 hunk ./TODO 1 -- tasks for xmonad 0.2 - - testing/ more QC - - check build systems for X11-extras/X11. - hunk ./tests/loc.hs 11 - when (loc > 550) $ fail "Too many lines of code!" hunk ./Config.hs 117 + + , ((modMask, xK_t ), withFocused clearFloating) -- @@ Make floating window tiled hunk ./Config.hs-boot 3 +import Graphics.X11.Xlib (KeyMask) hunk ./Config.hs-boot 5 +modMask :: KeyMask hunk ./Main.hs 29 -import Operations (manage, unmanage, focus, setFocusX, full, isClient, rescreen) +import Operations (manage, unmanage, focus, setFocusX, full, isClient, rescreen, makeFloating, swapMaster) hunk ./Main.hs 114 +cleanMask :: KeyMask -> KeyMask +cleanMask = (complement (numlockMask .|. lockMask) .&.) + +mouseDrag :: (XMotionEvent -> IO ()) -> X () +mouseDrag f = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) grabModeAsync grabModeAsync none none currentTime + + io $ allocaXEvent $ \p -> fix $ \again -> do + maskEvent d (buttonReleaseMask .|. pointerMotionMask) p + et <- get_EventType p + when (et == motionNotify) $ get_MotionEvent p >>= f >> again + + io $ ungrabPointer d currentTime + +mouseMoveWindow :: Window -> X () +mouseMoveWindow w = withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + (_, _, _, ox, oy, _, _, _) <- io $ queryPointer d w + mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> + moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) + + makeFloating w + +mouseResizeWindow :: Window -> X () +mouseResizeWindow w = withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa)) + mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> + resizeWindow d w (fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))) (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))) + + makeFloating w + hunk ./Main.hs 166 - whenJust (M.lookup (complement (numlockMask .|. lockMask) .&. m,s) keys) id + whenJust (M.lookup (cleanMask m,s) keys) id hunk ./Main.hs 184 -handle (ButtonEvent {ev_window = w, ev_event_type = t}) | t == buttonPress = focus w +handle (ButtonEvent {ev_window = w, ev_event_type = t, ev_state = m, ev_button = b }) + | t == buttonPress && cleanMask m == modMask && b == button1 = mouseMoveWindow w + | t == buttonPress && cleanMask m == modMask && b == button2 = focus w >> swapMaster + | t == buttonPress && cleanMask m == modMask && b == button3 = mouseResizeWindow w + | t == buttonPress = focus w hunk ./Operations.hs 18 -import {-# SOURCE #-} Config (borderWidth) +import {-# SOURCE #-} Config (borderWidth, modMask) hunk ./Operations.hs 21 -import Data.List (genericIndex, intersectBy) +import Data.List (genericIndex, intersectBy, partition, delete) hunk ./Operations.hs 23 +import Data.Ratio hunk ./Operations.hs 42 -manage w = do - withDisplay $ \d -> io $ do - selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask - mapWindow d w - setWindowBorderWidth d w borderWidth - windows $ W.insertUp w +manage w = withDisplay $ \d -> do + io $ selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + io $ mapWindow d w + io $ setWindowBorderWidth d w borderWidth + + -- FIXME: This is pretty awkward. We can't can't let "refresh" happen + -- before the call to makeFloating, because that will resize the window and + -- lose the default sizing. + isTransient <- isJust `liftM` (io $ getTransientForHint d w) + if isTransient + then do + modify $ \s -> s { windowset = W.insertUp w (windowset s) } + makeFloating w + else windows $ W.insertUp w hunk ./Operations.hs 59 +-- +-- FIXME: clearFloating should be taken care of in W.delete, but if we do it +-- there, floating status is lost when moving windows between workspaces, +-- because W.shift calls W.delete. hunk ./Operations.hs 64 -unmanage = windows . W.delete +unmanage w = windows $ W.clearFloating w . W.delete w hunk ./Operations.hs 157 + (float, tiled) = partition (flip M.member (W.floating ws)) (W.index this) hunk ./Operations.hs 165 - (sh - fromIntegral (gt + gb))) (W.index this) + (sh - fromIntegral (gt + gb))) tiled hunk ./Operations.hs 168 - -- and raise the focused window if there is one. - whenJust (W.peek this) $ io . raiseWindow d + -- move/resize the floating windows + (`mapM_` float) $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ \(W.RationalRect rx ry rw rh) -> do + let Rectangle px py pw ph = genericIndex xinesc (W.screen w) + io $ tileWindow d fw (Rectangle (px + floor (toRational pw*rx)) (py + floor (toRational ph*ry)) (floor (toRational pw*rw)) (floor (toRational ph*rh))) + + -- urgh. This is required because the fullscreen layout assumes that + -- the focused window will be raised. + let tiled' = maybe tiled (\x -> if x `elem` tiled then x : delete x tiled else tiled) (W.peek this) + + io $ restackWindows d (float ++ tiled') hunk ./Operations.hs 223 -buttonsToGrab :: [Button] -buttonsToGrab = [button1, button2, button3] - hunk ./Operations.hs 225 -setButtonGrab grab w = withDisplay $ \d -> io $ (`mapM_` buttonsToGrab) $ \b -> - if grab then grabButton d b anyModifier w False (buttonPressMask .|. buttonReleaseMask) - grabModeAsync grabModeSync none none - else ungrabButton d b anyModifier w +setButtonGrab grab w = withDisplay $ \d -> io $ do + when (not grab) $ ungrabButton d anyButton anyModifier w + grabButton d anyButton mask w False (buttonPressMask .|. buttonReleaseMask) + grabModeAsync grabModeSync none none + where mask = if grab then anyModifier else modMask hunk ./Operations.hs 262 - io $ do setInputFocus dpy w revertToPointerRoot 0 - -- raiseWindow dpy w - setButtonGrab False w - io $ setWindowBorder dpy w (color_pixel fbc) + whenX (not `liftM` isRoot w) $ do + io $ do setInputFocus dpy w revertToPointerRoot 0 + -- raiseWindow dpy w + setButtonGrab False w + io $ setWindowBorder dpy w (color_pixel fbc) hunk ./Operations.hs 385 +-- | Make a floating window tiled +clearFloating :: Window -> X () +clearFloating = windows . W.clearFloating + +-- | Make a tiled window floating +makeFloating :: Window -> X () +makeFloating w = withDisplay $ \d -> do + xinesc <- gets xineScreens + sc <- (genericIndex xinesc . W.screen . W.current) `liftM` gets windowset + wa <- io $ getWindowAttributes d w + let bw = fI . wa_border_width $ wa + windows $ W.makeFloating w + (W.RationalRect ((fI (wa_x wa) - fI (rect_x sc)) % fI (rect_width sc)) + ((fI (wa_y wa) - fI (rect_y sc)) % fI (rect_height sc)) + (fI (wa_width wa + bw*2) % fI (rect_width sc)) + (fI (wa_height wa + bw*2) % fI (rect_height sc))) + where fI x = fromIntegral x + hunk ./StackSet.hs 78 - StackSet(..), Workspace(..), Screen(..), Stack(..), + StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), hunk ./StackSet.hs 81 - swapMaster, swapUp, swapDown, modify -- needed by users + swapMaster, swapUp, swapDown, modify, makeFloating, clearFloating -- needed by users hunk ./StackSet.hs 86 - +import qualified Data.Map as M (Map,insert,delete,empty) hunk ./StackSet.hs 115 - StackSet { size :: !i -- number of workspaces - , current :: !(Screen i a sid) -- currently focused workspace - , visible :: [Screen i a sid] -- non-focused workspaces, visible in xinerama - , hidden :: [Workspace i a] -- workspaces not visible anywhere + StackSet { size :: !i -- number of workspaces + , current :: !(Screen i a sid) -- currently focused workspace + , visible :: [Screen i a sid] -- non-focused workspaces, visible in xinerama + , hidden :: [Workspace i a] -- workspaces not visible anywhere + , floating :: M.Map a RationalRect -- floating windows hunk ./StackSet.hs 132 +data RationalRect = RationalRect Rational Rational Rational Rational + deriving (Show, Read, Eq) + hunk ./StackSet.hs 174 -new n m | n > 0 && m > 0 = StackSet n cur visi unseen +new n m | n > 0 && m > 0 = StackSet n cur visi unseen M.empty hunk ./StackSet.hs 358 -delete :: (Integral i, Eq a, Eq s) => a -> StackSet i a s -> StackSet i a s +delete :: (Integral i, Ord a, Eq s) => a -> StackSet i a s -> StackSet i a s hunk ./StackSet.hs 374 +makeFloating :: Ord a => a -> RationalRect -> StackSet i a s -> StackSet i a s +makeFloating w r s = s { floating = M.insert w r (floating s) } + +clearFloating :: Ord a => a -> StackSet i a s -> StackSet i a s +clearFloating w s = s { floating = M.delete w (floating s) } + hunk ./StackSet.hs 403 -shift :: (Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s +shift :: (Ord a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s hunk ./Config.hs 77 -focusedBorderColor = "#ff0000" +focusedBorderColor = "#5fbf77" hunk ./Config.hs 118 - , ((modMask, xK_t ), withFocused clearFloating) -- @@ Make floating window tiled + , ((modMask, xK_t ), withFocused sink) -- @@ Push window back into tiling hunk ./Config.hs 128 - , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad + , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad hunk ./Main.hs 29 -import Operations (manage, unmanage, focus, setFocusX, full, isClient, rescreen, makeFloating, swapMaster) +import Operations hunk ./Main.hs 117 +------------------------------------------------------------------------ +-- mouse handling + +-- | Accumulate mouse motion events hunk ./Main.hs 124 - io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) grabModeAsync grabModeAsync none none currentTime - - io $ allocaXEvent $ \p -> fix $ \again -> do + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) + grabModeAsync grabModeAsync none none currentTime + io $ allocaXEvent $ \p -> fix $ \again -> do -- event loop hunk ./Main.hs 130 - hunk ./Main.hs 138 - moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) - - makeFloating w + moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) + (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) + float w hunk ./Main.hs 146 - io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa)) + io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) + (fromIntegral (wa_height wa)) hunk ./Main.hs 149 - resizeWindow d w (fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))) (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))) - - makeFloating w + resizeWindow d w (fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))) + (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))) + float w hunk ./Operations.hs 48 - -- before the call to makeFloating, because that will resize the window and + -- before the call to float, because that will resize the window and hunk ./Operations.hs 50 - isTransient <- isJust `liftM` (io $ getTransientForHint d w) + + isTransient <- isJust `liftM` io (getTransientForHint d w) hunk ./Operations.hs 53 - then do - modify $ \s -> s { windowset = W.insertUp w (windowset s) } - makeFloating w + then do modify $ \s -> s { windowset = W.insertUp w (windowset s) } + float w -- ^^ now go the refresh. hunk ./Operations.hs 64 -unmanage w = windows $ W.clearFloating w . W.delete w +unmanage w = windows $ W.sink w . W.delete w hunk ./Operations.hs 157 - (float, tiled) = partition (flip M.member (W.floating ws)) (W.index this) + (flt, tiled) = partition (flip M.member (W.floating ws)) (W.index this) hunk ./Operations.hs 161 + -- just the tiled windows: hunk ./Operations.hs 169 - -- move/resize the floating windows - (`mapM_` float) $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ \(W.RationalRect rx ry rw rh) -> do + -- now the floating windows: + -- move/resize the floating windows, if there are any + (`mapM_` flt) $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ + \(W.RationalRect rx ry rw rh) -> do hunk ./Operations.hs 174 - io $ tileWindow d fw (Rectangle (px + floor (toRational pw*rx)) (py + floor (toRational ph*ry)) (floor (toRational pw*rw)) (floor (toRational ph*rh))) + io $ tileWindow d fw (Rectangle (px + floor (toRational pw*rx)) + (py + floor (toRational ph*ry)) + (floor (toRational pw*rw)) + (floor (toRational ph*rh))) hunk ./Operations.hs 179 - -- urgh. This is required because the fullscreen layout assumes that - -- the focused window will be raised. - let tiled' = maybe tiled (\x -> if x `elem` tiled then x : delete x tiled else tiled) (W.peek this) + -- TODO seems fishy? + -- Urgh. This is required because the fullscreen layout assumes that + -- the focused window will be raised. Hmm. This is a reordering. + let tiled' = case W.peek this of + Just x | x `elem` tiled -> x : delete x tiled + _ -> tiled hunk ./Operations.hs 186 - io $ restackWindows d (float ++ tiled') + io $ restackWindows d (flt ++ tiled') hunk ./Operations.hs 394 +------------------------------------------------------------------------ +-- | Floating layer support + hunk ./Operations.hs 398 -clearFloating :: Window -> X () -clearFloating = windows . W.clearFloating +sink :: Window -> X () +sink = windows . W.sink hunk ./Operations.hs 401 --- | Make a tiled window floating -makeFloating :: Window -> X () -makeFloating w = withDisplay $ \d -> do +-- | Make a tiled window floating, using its suggested rectangle +float :: Window -> X () +float w = withDisplay $ \d -> do hunk ./Operations.hs 407 - let bw = fI . wa_border_width $ wa - windows $ W.makeFloating w - (W.RationalRect ((fI (wa_x wa) - fI (rect_x sc)) % fI (rect_width sc)) - ((fI (wa_y wa) - fI (rect_y sc)) % fI (rect_height sc)) - (fI (wa_width wa + bw*2) % fI (rect_width sc)) - (fI (wa_height wa + bw*2) % fI (rect_height sc))) - where fI x = fromIntegral x + let bw = fi . wa_border_width $ wa + windows $ W.float w + (W.RationalRect ((fi (wa_x wa) - fi (rect_x sc)) % fi (rect_width sc)) + ((fi (wa_y wa) - fi (rect_y sc)) % fi (rect_height sc)) + (fi (wa_width wa + bw*2) % fi (rect_width sc)) + (fi (wa_height wa + bw*2) % fi (rect_height sc))) + where fi x = fromIntegral x + +-- | Toggle floating bit +-- +-- TODO not useful unless we remember the original size +-- +-- toggleFloating :: Window -> X () +-- toggleFloating w = gets windowset >>= \ws -> if M.member w (W.floating ws) then sink w else float w hunk ./StackSet.hs 81 - swapMaster, swapUp, swapDown, modify, makeFloating, clearFloating -- needed by users + swapMaster, swapUp, swapDown, modify, float, sink -- needed by users hunk ./StackSet.hs 374 -makeFloating :: Ord a => a -> RationalRect -> StackSet i a s -> StackSet i a s -makeFloating w r s = s { floating = M.insert w r (floating s) } +-- | Given a window, and its preferred rectangle, set it as floating +-- A floating window should already be managed by the StackSet. +float :: Ord a => a -> RationalRect -> StackSet i a s -> StackSet i a s +float w r s = s { floating = M.insert w r (floating s) } hunk ./StackSet.hs 379 -clearFloating :: Ord a => a -> StackSet i a s -> StackSet i a s -clearFloating w s = s { floating = M.delete w (floating s) } +-- | Clear the floating status of a window +sink :: Ord a => a -> StackSet i a s -> StackSet i a s +sink w s = s { floating = M.delete w (floating s) } hunk ./Operations.hs 182 + + -- This really doesn't work with fullscreen mode, where + -- focus is used to find the raised window. moving the floating + -- layer will move focus there, so we now have forgotten the + -- window on the top of the fullscreen + -- + -- I think the solution must be to track the floating layer separately + -- in its own zipper, on each workspace. And from there to + -- handle pushing between the two. + -- hunk ./Config.hs 77 -focusedBorderColor = "#5fbf77" +focusedBorderColor = "#ff0000" replace ./Operations.hs [A-Za-z_0-9] withWorkspace withWindowSet hunk ./XMonad.hs 87 --- | Run a monadic action with the current workspace +-- | Run a monadic action with the current stack set replace ./XMonad.hs [A-Za-z_0-9] withWorkspace withWindowSet hunk ./Operations.hs 262 - if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> setFocusX w -- >> refresh + if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> refresh hunk ./Config.hs-boot 6 +numlockMask :: KeyMask hunk ./Main.hs 109 - when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) $ - [0, numlockMask, lockMask, numlockMask .|. lockMask] + when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) extraModifiers hunk ./Operations.hs 18 -import {-# SOURCE #-} Config (borderWidth, modMask) +import {-# SOURCE #-} Config (borderWidth, modMask, numlockMask) hunk ./Operations.hs 242 +extraModifiers :: [KeyMask] +extraModifiers = [0, numlockMask, lockMask, numlockMask .|. lockMask ] + hunk ./Operations.hs 247 -setButtonGrab grab w = withDisplay $ \d -> io $ do - when (not grab) $ ungrabButton d anyButton anyModifier w - grabButton d anyButton mask w False (buttonPressMask .|. buttonReleaseMask) - grabModeAsync grabModeSync none none - where mask = if grab then anyModifier else modMask +setButtonGrab grabAll w = withDisplay $ \d -> io $ do + when (not grabAll) $ ungrabButton d anyButton anyModifier w + mapM_ (grab d) masks + where masks = if grabAll then [anyModifier] else map (modMask .|.) extraModifiers + grab d m = grabButton d anyButton m w False (buttonPressMask .|. buttonReleaseMask) + grabModeAsync grabModeSync none none hunk ./Operations.hs 26 --- import System.Mem (performGC) hunk ./Operations.hs 30 +import System.IO hunk ./Operations.hs 200 + -- withWindowSet (io . hPrint stderr) -- logging state changes! hunk ./Config.hs 145 +mouseBindings :: M.Map (KeyMask, Button) (Window -> X ()) +mouseBindings = M.fromList $ + [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w)) + , ((modMask, button2), (\w -> focus w >> swapMaster)) + , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) + ] + hunk ./Config.hs-boot 3 -import Graphics.X11.Xlib (KeyMask) hunk ./Config.hs-boot 4 -modMask :: KeyMask -numlockMask :: KeyMask hunk ./Main.hs 76 + grabButtons dpy rootw + hunk ./Main.hs 115 -cleanMask :: KeyMask -> KeyMask -cleanMask = (complement (numlockMask .|. lockMask) .&.) - ------------------------------------------------------------------------- --- mouse handling +grabButtons :: Display -> Window -> IO () +grabButtons dpy rootw = do + ungrabButton dpy anyButton anyModifier rootw + mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) extraModifiers) (M.keys mouseBindings) + where grab button mask = grabButton dpy button mask rootw False buttonPressMask + grabModeAsync grabModeSync none none hunk ./Main.hs 122 --- | Accumulate mouse motion events -mouseDrag :: (XMotionEvent -> IO ()) -> X () -mouseDrag f = do - XConf { theRoot = root, display = d } <- ask - io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) - grabModeAsync grabModeAsync none none currentTime - io $ allocaXEvent $ \p -> fix $ \again -> do -- event loop - maskEvent d (buttonReleaseMask .|. pointerMotionMask) p - et <- get_EventType p - when (et == motionNotify) $ get_MotionEvent p >>= f >> again - io $ ungrabPointer d currentTime +extraModifiers :: [KeyMask] +extraModifiers = [0, numlockMask, lockMask, numlockMask .|. lockMask ] hunk ./Main.hs 125 -mouseMoveWindow :: Window -> X () -mouseMoveWindow w = withDisplay $ \d -> do - io $ raiseWindow d w - wa <- io $ getWindowAttributes d w - (_, _, _, ox, oy, _, _, _) <- io $ queryPointer d w - mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> - moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) - (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) - float w - -mouseResizeWindow :: Window -> X () -mouseResizeWindow w = withDisplay $ \d -> do - io $ raiseWindow d w - wa <- io $ getWindowAttributes d w - io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) - (fromIntegral (wa_height wa)) - mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> - resizeWindow d w (fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))) - (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))) - float w +cleanMask :: KeyMask -> KeyMask +cleanMask = (complement (numlockMask .|. lockMask) .&.) hunk ./Main.hs 163 -handle (ButtonEvent {ev_window = w, ev_event_type = t, ev_state = m, ev_button = b }) - | t == buttonPress && cleanMask m == modMask && b == button1 = mouseMoveWindow w - | t == buttonPress && cleanMask m == modMask && b == button2 = focus w >> swapMaster - | t == buttonPress && cleanMask m == modMask && b == button3 = mouseResizeWindow w - | t == buttonPress = focus w +handle (ButtonEvent { ev_window = w, ev_subwindow = subw, ev_event_type = t, ev_state = m, ev_button = b }) + | t == buttonPress = do isr <- isRoot w + -- If it's the root window, then it's something we + -- grabbed in grabButtons. Otherwise, it's + -- click-to-focus. + if isr + then whenJust (M.lookup (cleanMask m, b) mouseBindings) ($ subw) + else focus w hunk ./Operations.hs 18 -import {-# SOURCE #-} Config (borderWidth, modMask, numlockMask) +import {-# SOURCE #-} Config (borderWidth) hunk ./Operations.hs 243 -extraModifiers :: [KeyMask] -extraModifiers = [0, numlockMask, lockMask, numlockMask .|. lockMask ] - hunk ./Operations.hs 245 -setButtonGrab grabAll w = withDisplay $ \d -> io $ do - when (not grabAll) $ ungrabButton d anyButton anyModifier w - mapM_ (grab d) masks - where masks = if grabAll then [anyModifier] else map (modMask .|.) extraModifiers - grab d m = grabButton d anyButton m w False (buttonPressMask .|. buttonReleaseMask) - grabModeAsync grabModeSync none none +setButtonGrab grab w = withDisplay $ \d -> io $ + if grab + then grabButton d anyButton anyModifier w False buttonPressMask + grabModeAsync grabModeSync none none + else ungrabButton d anyButton anyModifier w hunk ./Operations.hs 433 +------------------------------------------------------------------------ +-- mouse handling + +-- | Accumulate mouse motion events +mouseDrag :: (XMotionEvent -> IO ()) -> X () +mouseDrag f = do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) + grabModeAsync grabModeAsync none none currentTime + io $ allocaXEvent $ \p -> fix $ \again -> do -- event loop + maskEvent d (buttonReleaseMask .|. pointerMotionMask) p + et <- get_EventType p + when (et == motionNotify) $ get_MotionEvent p >>= f >> again + io $ ungrabPointer d currentTime + +mouseMoveWindow :: Window -> X () +mouseMoveWindow w = withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + (_, _, _, ox, oy, _, _, _) <- io $ queryPointer d w + mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> + moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) + (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) + float w + +mouseResizeWindow :: Window -> X () +mouseResizeWindow w = withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) + (fromIntegral (wa_height wa)) + mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> + resizeWindow d w (fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))) + (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))) + float w + hunk ./Operations.hs 247 - then grabButton d anyButton anyModifier w False buttonPressMask - grabModeAsync grabModeSync none none + then flip mapM_ [button1, button2, button3] $ \b -> + grabButton d b anyModifier w False buttonPressMask + grabModeAsync grabModeSync none none hunk ./Config.hs 14 --- values here, be sure to recompile and restart (mod-shift-ctrl-q) xmonad, +-- values here, be sure to recompile and restart (mod-q) xmonad, hunk ./xmonad.cabal 21 -build-depends: base>=1.0, X11>=1.2.1, X11-extras>=0.2, mtl>=1.0, unix>=1.0 +build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.2, mtl>=1.0, unix>=1.0 hunk ./xmonad.cabal 28 -ghc-options: -funbox-strict-fields -O -fasm -Wall -optl-Wl,-s +ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s hunk ./Config.hs 31 --- The number of workspaces (virtual screens) +-- +-- The number of workspaces (virtual screens, or window groups) +-- hunk ./Config.hs 37 --- modMask lets you specify which modkey you want to use. The default is mod1Mask --- ("left alt"). You may also consider using mod3Mask ("right alt"), which --- does not conflict with emacs keybindings. The "windows key" is usually --- mod4Mask. +-- +-- modMask lets you specify which modkey you want to use. The default is +-- mod1Mask ("left alt"). You may also consider using mod3Mask ("right +-- alt"), which does not conflict with emacs keybindings. The "windows +-- key" is usually mod4Mask. hunk ./Config.hs 46 --- When resizing a window, this ratio specifies by what percent to --- resize in a single step -defaultDelta :: Rational -defaultDelta = 3%100 - --- The default number of windows in the master area -defaultWindowsInMaster :: Int -defaultWindowsInMaster = 1 - +-- hunk ./Config.hs 49 --- given edge, on the that screen. A useful gap at top of screen for a menu bar (e.g. 15) +-- given edge, on the that screen. A useful gap at top of screen for a +-- menu bar (e.g. 15) hunk ./Config.hs 57 +-- hunk ./Config.hs 71 +-- hunk ./Config.hs 73 +-- hunk ./Config.hs 78 +-- hunk ./Config.hs 80 +-- hunk ./Config.hs 84 --- The default set of Layouts: +-- +-- The default set of tiling algorithms +-- hunk ./Config.hs 88 -defaultLayouts = [ tall defaultWindowsInMaster defaultDelta (1%2) - , wide defaultWindowsInMaster defaultDelta (1%2) - , full ] +defaultLayouts = [ tiled , mirror tiled , full ] + where + -- default tiling algorithm partitions the screen into two panes + tiled = tall nmaster delta ratio + + -- The default number of windows in the master pane + nmaster = 1 + + -- Default proportion of screen occupied by master pane + ratio = 1%2 + + -- Percent of screen to increment by when resizing panes + delta = 3%100 hunk ./Config.hs 104 +-- +-- The unusual comment format is used to generate the documentation +-- automatically. hunk ./Config.hs 161 +-- +-- default actions bound to mouse events +-- hunk ./Config.hs 168 - , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) - ] + , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) ] hunk ./Operations.hs 315 --- wide mode +-- wide mode (a mirror of tall mode) hunk ./Operations.hs 329 +-- simple fullscreen mode, just render all windows fullscreen. hunk ./Operations.hs 334 -tall, wide :: Int -> Rational -> Rational -> Layout -wide nmaster delta frac = mirrorLayout (tall nmaster delta frac) +-- the true tiling mode of xmonad. +-- +-- the screen is divided (currently) into two panes. all clients are +-- then partioned between these two panes. one pane, the `master', by +-- convention has the least number of windows in it (by default, 1). +-- the variable `nmaster' controls how many windows are rendered in the +-- master pane. +-- +-- `delta' specifies the ratio of the screen to resize by. +-- +-- 'frac' specifies what proportion of the screen to devote to the +-- master area. +-- +-- hunk ./Operations.hs 349 +tall :: Int -> Rational -> Rational -> Layout hunk ./Operations.hs 363 --- | Mirror a layout -mirrorLayout :: Layout -> Layout -mirrorLayout (Layout { doLayout = dl, modifyLayout = ml }) = +-- | Mirror a layout, compute its 90 degree rotated form. +mirror :: Layout -> Layout +mirror (Layout { doLayout = dl, modifyLayout = ml }) = hunk ./Operations.hs 367 - , modifyLayout = fmap mirrorLayout . ml } + , modifyLayout = fmap mirror . ml } hunk ./Operations.hs 380 +-- divide a rectangle, computing a number of subrectangles. hunk ./Operations.hs 28 -import Control.Arrow +import Control.Arrow ((***), second) hunk ./Operations.hs 163 - rs <- doLayout l (Rectangle (sx + fromIntegral gl) - (sy + fromIntegral gt) - (sw - fromIntegral (gl + gr)) - (sh - fromIntegral (gt + gb))) tiled + rs <- doLayout l (Rectangle + (sx + fromIntegral gl) (sy + fromIntegral gt) + (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb))) tiled hunk ./Operations.hs 173 - io $ tileWindow d fw (Rectangle (px + floor (toRational pw*rx)) - (py + floor (toRational ph*ry)) - (floor (toRational pw*rw)) - (floor (toRational ph*rh))) + io $ tileWindow d fw $ Rectangle + (px + floor (toRational pw*rx)) (py + floor (toRational ph*ry)) + (floor (toRational pw*rw)) (floor (toRational ph*rh)) hunk ./Operations.hs 321 -data Resize = Shrink | Expand deriving Typeable +data Resize = Shrink | Expand deriving Typeable +data IncMasterN = IncMasterN Int deriving Typeable hunk ./Operations.hs 324 - -data IncMasterN = IncMasterN Int deriving Typeable hunk ./Operations.hs 327 +-- a plea for tuple sections: map . (,sc) hunk ./Operations.hs 332 --- the true tiling mode of xmonad. --- --- the screen is divided (currently) into two panes. all clients are --- then partioned between these two panes. one pane, the `master', by --- convention has the least number of windows in it (by default, 1). --- the variable `nmaster' controls how many windows are rendered in the --- master pane. --- --- `delta' specifies the ratio of the screen to resize by. hunk ./Operations.hs 333 --- 'frac' specifies what proportion of the screen to devote to the --- master area. +-- The tiling mode of xmonad, and its operations. hunk ./Operations.hs 335 --- - hunk ./Operations.hs 343 - incmastern (IncMasterN d) = tall (max 1 (nmaster+d)) delta frac + incmastern (IncMasterN d) = tall (max 0 (nmaster+d)) delta frac hunk ./Operations.hs 352 - Layout { doLayout = \sc w -> map (second mirrorRect) `fmap` dl (mirrorRect sc) w - , modifyLayout = fmap mirror . ml } + Layout { doLayout = \sc w -> map (second mirrorRect) `fmap` dl (mirrorRect sc) w + , modifyLayout = fmap mirror . ml } hunk ./Operations.hs 355 --- | tile. Compute the positions for windows in our default tiling modes --- Tiling algorithms in the core should satisify the constraint that +-- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. hunk ./Operations.hs 357 --- * no windows overlap --- * no gaps exist between windows. +-- The screen is divided (currently) into two panes. all clients are +-- then partioned between these two panes. one pane, the `master', by +-- convention has the least number of windows in it (by default, 1). +-- the variable `nmaster' controls how many windows are rendered in the +-- master pane. +-- +-- `delta' specifies the ratio of the screen to resize by. hunk ./Operations.hs 365 +-- 'frac' specifies what proportion of the screen to devote to the +-- master area. +-- hunk ./Operations.hs 369 -tile f r nmaster n | n <= nmaster = splitVertically n r - | otherwise = splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 - where (r1,r2) = splitHorizontallyBy f r +tile f r nmaster n = if n <= nmaster || nmaster == 0 + then splitVertically n r + else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns + where (r1,r2) = splitHorizontallyBy f r hunk ./Operations.hs 374 --- divide a rectangle, computing a number of subrectangles. +-- +-- Divide the screen vertically into n subrectangles +-- hunk ./Operations.hs 381 - where smallh = sh `div` fromIntegral n -splitHorizontally n r = map mirrorRect $ splitVertically n $ mirrorRect r + where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. hunk ./Operations.hs 383 +splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect + +-- Divide the screen into two rectangles, using a rational to specify the ratio hunk ./Operations.hs 388 - (Rectangle sx sy leftw sh, Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) - where leftw = floor $ fromIntegral sw * f -splitVerticallyBy f r = (\(a,b)->(mirrorRect a,mirrorRect b)) $ splitHorizontallyBy f $ mirrorRect r + ( Rectangle sx sy leftw sh + , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) + where leftw = floor $ fromIntegral sw * f + +splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect hunk ./Operations.hs 470 - moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) - (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) + moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) + (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) hunk ./Operations.hs 478 - io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) - (fromIntegral (wa_height wa)) + io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa)) hunk ./Operations.hs 483 +-- + +-- generic handler, but too complex: +-- +-- mouseModifyWindow f g w = withDisplay $ \d -> do +-- io $ raiseWindow d w +-- wa <- io $ getWindowAttributes d w +-- x <- f d w wa +-- mouseDrag $ \(_,_,_,ex,ey,_,_,_,_,_) -> g x ex ey d w wa +-- float w hunk ./Main.hs 19 +import Control.Monad.State hunk ./Main.hs 29 -import StackSet (new) +import StackSet (new, floating) hunk ./Main.hs 185 -handle e@(ConfigureRequestEvent {}) = withDisplay $ \dpy -> do - io $ configureWindow dpy (ev_window e) (ev_value_mask e) $ WindowChanges - { wc_x = ev_x e - , wc_y = ev_y e - , wc_width = ev_width e - , wc_height = ev_height e - , wc_border_width = ev_border_width e - , wc_sibling = ev_above e - -- this fromIntegral is only necessary with the old X11 version that uses - -- Int instead of CInt. TODO delete it when there is a new release of X11 - , wc_stack_mode = fromIntegral $ ev_detail e } +handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + floating <- gets $ M.member w . floating . windowset + rootw <- asks theRoot + wa <- io $ getWindowAttributes dpy w + + if floating + then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges + { wc_x = ev_x e + , wc_y = ev_y e + , wc_width = ev_width e + , wc_height = ev_height e + , wc_border_width = fromIntegral borderWidth + , wc_sibling = ev_above e + , wc_stack_mode = ev_detail e } + float w + else io $ allocaXEvent $ \ev -> do + setEventType ev configureNotify + setConfigureEvent ev w w + (wa_x wa) (wa_y wa) (wa_width wa) (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) + sendEvent dpy w False 0 ev hunk ./Main.hs 186 - floating <- gets $ M.member w . floating . windowset - rootw <- asks theRoot - wa <- io $ getWindowAttributes dpy w + f <- gets $ M.member w . floating . windowset + wa <- io $ getWindowAttributes dpy w hunk ./Main.hs 189 - if floating + if f hunk ./Main.hs 29 -import StackSet (new, floating) +import StackSet (new, floating, member) hunk ./Main.hs 186 - f <- gets $ M.member w . floating . windowset + ws <- gets windowset hunk ./Main.hs 189 - if f + if M.member w (floating ws) || not (member w ws) hunk ./Main.hs 198 - float w + when (member w ws) (float w) hunk ./Main.hs 42 - wmdelt <- internAtom dpy "WM_DELETE_WINDOW" False - wmprot <- internAtom dpy "WM_PROTOCOLS" False hunk ./Main.hs 54 - , wmdelete = wmdelt - , wmprotocols = wmprot hunk ./Operations.hs 101 - XConf {wmdelete = wmdelt, wmprotocols = wmprot} <- ask + wmdelt <- atom_WM_DELETE_WINDOW ; wmprot <- atom_WM_PROTOCOLS + hunk ./XMonad.hs 20 - Typeable, Message, SomeMessage(..), fromMessage, + Typeable, Message, SomeMessage(..), fromMessage, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, hunk ./XMonad.hs 29 +import System.IO.Unsafe (unsafePerformIO) hunk ./XMonad.hs 51 - , wmdelete :: !Atom -- ^ window deletion atom - , wmprotocols :: !Atom -- ^ wm protocols atom hunk ./XMonad.hs 94 +-- | Wrapper for the common case of atom internment +getAtom :: String -> X Atom +getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False + +-- | Common non-predefined atoms +atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW :: X Atom +atom_WM_PROTOCOLS = getAtom "WM_PROTOCOLS" +atom_WM_DELETE_WINDOW = getAtom "WM_DELETE_WINDOW" + hunk ./XMonad.hs 29 -import System.IO.Unsafe (unsafePerformIO) hunk ./XMonad.hs 83 -withDisplay f = asks display >>= f +withDisplay f = asks display >>= f hunk ./XMonad.hs 99 -atom_WM_PROTOCOLS = getAtom "WM_PROTOCOLS" -atom_WM_DELETE_WINDOW = getAtom "WM_DELETE_WINDOW" +atom_WM_PROTOCOLS = getAtom "WM_PROTOCOLS" +atom_WM_DELETE_WINDOW = getAtom "WM_DELETE_WINDOW" hunk ./Main.hs 160 -handle (ButtonEvent { ev_window = w, ev_subwindow = subw, ev_event_type = t, ev_state = m, ev_button = b }) - | t == buttonPress = do isr <- isRoot w - -- If it's the root window, then it's something we - -- grabbed in grabButtons. Otherwise, it's - -- click-to-focus. - if isr - then whenJust (M.lookup (cleanMask m, b) mouseBindings) ($ subw) - else focus w +handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) + | t == buttonPress = do + isr <- isRoot w + if isr then whenJust (M.lookup (cleanMask (ev_state e), b) mouseBindings) ($ ev_subwindow e) + else focus w + -- If it's the root window, then it's something we + -- grabbed in grabButtons. Otherwise, it's click-to-focus. hunk ./Main.hs 197 - (wa_x wa) (wa_y wa) (wa_width wa) (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) + (wa_x wa) (wa_y wa) (wa_width wa) + (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) hunk ./Main.hs 147 - when (not (wa_override_redirect wa)) $ manage w + -- need to ignore mapping requests by managed windows not on the current workspace + managed <- isClient w + when (not (wa_override_redirect wa) && not managed) $ do manage w hunk ./Main.hs 154 -handle (UnmapEvent {ev_window = w}) = whenX (isClient w) $ unmanage w + +-- We only handle synthetic unmap events, because real events are confusable +-- with the events produced by 'hide'. ICCCM says that all clients should send +-- synthetic unmap events immediately after unmapping, and later describes +-- clients that do not follow the rule as "obsolete". For now, we make the +-- simplifying assumption that nobody uses clients that were already obsolete +-- in 1994. Note that many alternative methods for resolving the hide/withdraw +-- ambiguity are racy. + +handle (UnmapEvent {ev_window = w, ev_send_event = True}) = whenX (isClient w) $ unmanage w hunk ./Operations.hs 64 -unmanage w = windows $ W.sink w . W.delete w +unmanage w = setWMState w 0{-withdrawn-} >> windows (W.sink w . W.delete w) hunk ./Operations.hs 136 --- | hide. Hide a window by moving it off screen. +-- | setWMState. set the WM_STATE property +setWMState :: Window -> Int -> X () +setWMState w v = withDisplay $ \dpy -> do + a <- atom_WM_STATE + io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none] + +-- | hide. Hide a window by unmapping it. +-- +-- If you call this on a window that is marked as visible, very bad things will +-- happen (currently unmanaging, but don't count on it). hunk ./Operations.hs 148 - (sw,sh) <- gets dimensions - io $ moveWindow d w sw sh + io $ unmapWindow d w + setWMState w 3 --iconic hunk ./Operations.hs 176 - mapM_ (\(win,rect) -> io (tileWindow d win rect)) rs + mapM_ (\(win,rect) -> tileWindow win rect) rs hunk ./Operations.hs 183 - io $ tileWindow d fw $ Rectangle + tileWindow fw $ Rectangle hunk ./Operations.hs 221 -tileWindow :: Display -> Window -> Rectangle -> IO () -tileWindow d w r = do - bw <- (fromIntegral . wa_border_width) `liftM` getWindowAttributes d w - moveResizeWindow d w (rect_x r) (rect_y r) - (rect_width r - bw*2) (rect_height r - bw*2) +tileWindow :: Window -> Rectangle -> X () +tileWindow w r = withDisplay $ \d -> do + bw <- (fromIntegral . wa_border_width) `liftM` io (getWindowAttributes d w) + io $ moveResizeWindow d w (rect_x r) (rect_y r) + (rect_width r - bw*2) (rect_height r - bw*2) + -- this is harmless if the window was already visible + setWMState w 1 --normal + io $ mapWindow d w hunk ./XMonad.hs 21 - runX, io, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX + runX, io, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, + atom_WM_STATE hunk ./XMonad.hs 99 -atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW :: X Atom +atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, atom_WM_STATE :: X Atom hunk ./XMonad.hs 102 +atom_WM_STATE = getAtom "WM_STATE" hunk ./Main.hs 62 - , xineScreens = xinesc - , dimensions = (fromIntegral (displayWidth dpy dflt), - fromIntegral (displayHeight dpy dflt)) } + , xineScreens = xinesc } hunk ./Operations.hs 238 - -- TODO: This stuff is necessary because Xlib apparently caches screen - -- width/height. Find a better solution later. I hate Xlib. - let sx = maximum $ map (\r -> rect_x r + fromIntegral (rect_width r)) xinesc - sy = maximum $ map (\r -> rect_y r + fromIntegral (rect_height r)) xinesc - - modify (\s -> s { xineScreens = xinesc , dimensions = (sx, sy) + modify (\s -> s { xineScreens = xinesc hunk ./XMonad.hs 43 - , dimensions :: !(Position,Position) -- ^ dimensions of the screen, hunk ./Main.hs 102 - flip mapM_ (M.keys keys) $ \(mask,sym) -> do + forM_ (M.keys keys) $ \(mask,sym) -> do hunk ./Operations.hs 163 - (`mapM_` (W.current ws : W.visible ws)) $ \w -> do + forM_ (W.current ws : W.visible ws) $ \w -> do hunk ./Operations.hs 180 - (`mapM_` flt) $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ + forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ hunk ./Operations.hs 253 - then flip mapM_ [button1, button2, button3] $ \b -> + then forM_ [button1, button2, button3] $ \b -> hunk ./Operations.hs 284 - (`mapM_` (W.current ws : W.visible ws)) $ \wk -> do - (`mapM_` (W.index (W.view (W.tag (W.workspace wk)) ws))) $ \otherw -> do + forM_ (W.current ws : W.visible ws) $ \wk -> do + forM_ (W.index (W.view (W.tag (W.workspace wk)) ws)) $ \otherw -> do hunk ./Operations.hs 143 --- --- If you call this on a window that is marked as visible, very bad things will --- happen (currently unmanaging, but don't count on it). hunk ./Operations.hs 268 - else whenX (isRoot w) $ setFocusX w -- we could refresh here, moving gap too. - -- XXX a focus change could be caused by switching workspaces in xinerama. - -- if so, and the gap is in use, the gap should probably follow the - -- cursor to the new screen. - -- - -- to get the gap though, you need to trigger a refresh. + else whenX (isRoot w) $ setFocusX w hunk ./StackSet.hs 79 - new, view, lookupWorkspace, peek, index, focusUp, focusDown, + new, view, lookupWorkspace, peek, index, integrate, focusUp, focusDown, hunk ./StackSet.hs 246 +-- +-- /O(n)/. Flatten a Stack into a list. +-- +integrate :: Stack a -> [a] +integrate Empty = [] +integrate (Node x l r) = reverse l ++ x : r + hunk ./Operations.hs 125 - mapM_ hide . concatMap (integrate . W.stack) $ + mapM_ hide . concatMap (W.integrate . W.stack) $ hunk ./Operations.hs 133 - where integrate W.Empty = [] - integrate (W.Node x l r) = x : l ++ r hunk ./StackSet.hs 260 -index = with [] $ \(Node t l r) -> reverse l ++ t : r +index = with [] integrate hunk ./Operations.hs 117 - old <- gets windowset - let new = f old - modify (\s -> s { windowset = new }) - refresh - - -- We now go to some effort to compute the minimal set of windows to hide. - -- The minimal set being only those windows which weren't previously hidden, - -- which is the intersection of previously visible windows with those now hidden - mapM_ hide . concatMap (W.integrate . W.stack) $ - intersectBy (\w x -> W.tag w == W.tag x) - (map W.workspace $ W.current old : W.visible old) - (W.hidden new) - - clearEnterEvents - - -- TODO: move this into StackSet. This isn't exactly the usual integrate. - --- | setWMState. set the WM_STATE property -setWMState :: Window -> Int -> X () -setWMState w v = withDisplay $ \dpy -> do - a <- atom_WM_STATE - io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none] - --- | hide. Hide a window by unmapping it. -hide :: Window -> X () -hide w = withDisplay $ \d -> do - io $ unmapWindow d w - setWMState w 3 --iconic - --- | refresh. Render the currently visible workspaces, as determined by --- the StackSet. Also, set focus to the focused window. --- --- This is our 'view' operation (MVC), in that it pretty prints our model --- with X calls. --- -refresh :: X () -refresh = do - XState { windowset = ws, layouts = fls, xineScreens = xinesc, statusGaps = gaps } <- get + XState { windowset = old, layouts = fls, xineScreens = xinesc, statusGaps = gaps } <- get + let ws = f old + modify (\s -> s { windowset = ws }) hunk ./Operations.hs 167 - clearEnterEvents hunk ./Operations.hs 168 --- io performGC -- really helps + -- io performGC -- really helps + + -- We now go to some effort to compute the minimal set of windows to hide. + -- The minimal set being only those windows which weren't previously hidden, + -- which is the intersection of previously visible windows with those now hidden + mapM_ hide . concatMap (W.integrate . W.stack) $ + intersectBy (\w x -> W.tag w == W.tag x) + (map W.workspace $ W.current old : W.visible old) + (W.hidden ws) + + clearEnterEvents + + -- TODO: move this into StackSet. This isn't exactly the usual integrate. + +-- | setWMState. set the WM_STATE property +setWMState :: Window -> Int -> X () +setWMState w v = withDisplay $ \dpy -> do + a <- atom_WM_STATE + io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none] + +-- | hide. Hide a window by unmapping it. +hide :: Window -> X () +hide w = withDisplay $ \d -> do + io $ unmapWindow d w + setWMState w 3 --iconic + +-- | refresh. Render the currently visible workspaces, as determined by +-- the StackSet. Also, set focus to the focused window. +-- +-- This is our 'view' operation (MVC), in that it pretty prints our model +-- with X calls. +-- +refresh :: X () +refresh = windows id hunk ./Operations.hs 142 - let Rectangle px py pw ph = genericIndex xinesc (W.screen w) hunk ./Operations.hs 143 - (px + floor (toRational pw*rx)) (py + floor (toRational ph*ry)) - (floor (toRational pw*rw)) (floor (toRational ph*rh)) + (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry)) + (floor (toRational sw*rw)) (floor (toRational sh*rh)) hunk ./Main.hs 79 + -- withWindowSet (io . hPrint stderr) -- uncomment for state logging + hunk ./StackSet.hs 188 - --- is raised to the current screen. If it is already visible, focus is --- just moved. hunk ./StackSet.hs 189 -view :: (Eq i, Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s +view :: (Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s hunk ./StackSet.hs 275 - Node _ [] [] -> c hunk ./StackSet.hs 276 - Node t [] rs -> Node x (xs ++ [t]) [] where (x:xs) = reverse rs + Node t [] rs -> Node x xs [] where (x:xs) = reverse (t:rs) hunk ./StackSet.hs 279 - Node _ [] [] -> c hunk ./StackSet.hs 280 - Node t ls [] -> Node x [] (xs ++ [t]) where (x:xs) = reverse ls + Node t ls [] -> Node x [] xs where (x:xs) = reverse (t:ls) hunk ./StackSet.hs 274 -focusUp = modify Empty $ \c -> case c of - Node t (l:ls) rs -> Node l ls (t:rs) - Node t [] rs -> Node x xs [] where (x:xs) = reverse (t:rs) +focusUp = modify Empty focusUp' hunk ./StackSet.hs 276 -focusDown = modify Empty $ \c -> case c of - Node t ls (r:rs) -> Node r (t:ls) rs - Node t ls [] -> Node x [] xs where (x:xs) = reverse (t:ls) +focusUp' (Node t (l:ls) rs) = Node l ls (t:rs) +focusUp' (Node t [] rs) = Node x xs [] where (x:xs) = reverse (t:rs) + +focusDown = modify Empty (reverseStack . focusUp' . reverseStack) hunk ./StackSet.hs 291 +-- reverse a stack: up becomes down and down becomes up. +reverseStack (Node t ls rs) = Node t rs ls +reverseStack x = x + hunk ./StackSet.hs 282 - Node _ [] [] -> c hunk ./StackSet.hs 286 - Node _ [] [] -> c hunk ./StackSet.hs 281 -swapUp = modify Empty $ \c -> case c of - Node t (l:ls) rs -> Node t ls (l:rs) - Node t [] rs -> Node t (reverse rs) [] +swapUp = modify Empty swapUp' hunk ./StackSet.hs 283 -swapDown = modify Empty $ \c -> case c of - Node t ls (r:rs) -> Node t (r:ls) rs - Node t ls [] -> Node t [] (reverse ls) +swapUp' (Node t (l:ls) rs) = Node t ls (l:rs) +swapUp' (Node t [] rs) = Node t (reverse rs) [] + +swapDown = modify Empty (reverseStack . swapUp' . reverseStack) hunk ./StackSet.hs 197 - | Just x <- L.find ((i==).tag) (hidden s) + | Just x <- L.find ((i==).tag) (hidden s) hunk ./Operations.hs 261 - if W.member w s then modify (\st -> st { windowset = W.focusWindow w s }) >> refresh + if W.member w s then windows (W.focusWindow w) hunk ./Main.hs 54 - -- fromIntegral needed for X11 versions that use Int instead of CInt. hunk ./Operations.hs 179 - -- TODO: move this into StackSet. This isn't exactly the usual integrate. - hunk ./Operations.hs 486 + +------------------------------------------------------------------------ +-- size hints + +-- | Reduce the dimensions if needed to comply to the given SizeHints. +applySizeHints :: SizeHints -> (Dimension, Dimension) -> (Dimension, Dimension) +applySizeHints sh = + maybe id applyMaxSizeHint (sh_max_size sh) . + maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size sh) . + maybe id applyResizeIncHint (sh_resize_inc sh) . + maybe id applyAspectHint (sh_aspect sh) . + maybe id (\(bw, bh) (w, h) -> (w-bw, h-bh)) (sh_base_size sh) + +-- | Reduce the dimensions so their aspect ratio falls between the two given aspect ratios. +applyAspectHint :: ((Dimension, Dimension), (Dimension, Dimension)) -> (Dimension, Dimension) -> (Dimension, Dimension) +applyAspectHint ((minx, miny), (maxx, maxy)) (w, h) + | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = (w, h) + | w * maxy > h * maxx = (h * maxx `div` maxy, h) + | w * miny < h * minx = (w, w * miny `div` minx) + | otherwise = (w, h) + +-- | Reduce the dimensions so they are a multiple of the size increments. +applyResizeIncHint :: (Dimension, Dimension) -> (Dimension, Dimension) -> (Dimension, Dimension) +applyResizeIncHint (iw, ih) (w, h) + | iw > 0 && ih > 0 = (w - w `mod` iw, h - h `mod` ih) + | otherwise = (w, h) + +-- | Reduce the dimensions if they exceed the given maximum dimensions. +applyMaxSizeHint :: (Dimension, Dimension) -> (Dimension, Dimension) -> (Dimension, Dimension) +applyMaxSizeHint (maxw, maxh) (w, h) + | maxw > 0 && maxh > 0 = (min w maxw, min h maxh) + | otherwise = (w, h) + hunk ./Operations.hs 470 + sh <- io $ getWMNormalHints d w hunk ./Operations.hs 473 - resizeWindow d w (fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))) - (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))) + resizeWindow d w `uncurry` + applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))), + (fromIntegral (max 1 (ey - fromIntegral (wa_y wa))))) hunk ./StackSet.hs 276 -focusUp' (Node t (l:ls) rs) = Node l ls (t:rs) -focusUp' (Node t [] rs) = Node x xs [] where (x:xs) = reverse (t:rs) - hunk ./StackSet.hs 280 +swapDown = modify Empty (reverseStack . swapUp' . reverseStack) + +focusUp', swapUp' :: Stack a -> Stack a + +focusUp' (Node t (l:ls) rs) = Node l ls (t:rs) +focusUp' (Node t [] rs) = Node x xs [] where (x:xs) = reverse (t:rs) + hunk ./StackSet.hs 290 -swapDown = modify Empty (reverseStack . swapUp' . reverseStack) - hunk ./StackSet.hs 291 +reverseStack :: Stack a -> Stack a hunk ./Operations.hs 64 -unmanage w = setWMState w 0{-withdrawn-} >> windows (W.sink w . W.delete w) +unmanage w = setWMState w 0 {-withdrawn-} >> windows (W.sink w . W.delete w) hunk ./Operations.hs 77 - -- refresh will raise it if we didn't need to move it. +-- TODO: get rid of the above hide. 'windows' should handle all hiding and +-- revealing of windows hunk ./StackSet.hs 274 -focusUp = modify Empty focusUp' - +focusUp = modify Empty focusUp' hunk ./StackSet.hs 277 -swapUp = modify Empty swapUp' - -swapDown = modify Empty (reverseStack . swapUp' . reverseStack) +swapUp = modify Empty swapUp' +swapDown = modify Empty (reverseStack . swapUp' . reverseStack) hunk ./StackSet.hs 281 - hunk ./StackSet.hs 284 -swapUp' (Node t (l:ls) rs) = Node t ls (l:rs) -swapUp' (Node t [] rs) = Node t (reverse rs) [] +swapUp' (Node t (l:ls) rs) = Node t ls (l:rs) +swapUp' (Node t [] rs) = Node t (reverse rs) [] hunk ./StackSet.hs 376 +------------------------------------------------------------------------ + hunk ./Main.hs 30 +import qualified StackSet as W hunk ./Main.hs 33 +import System.IO + hunk ./Main.hs 53 + hunk ./Main.hs 78 - ws <- scan dpy rootw + ws <- scan dpy rootw -- on the resume case, will pick up new windows hunk ./Main.hs 81 - mapM_ manage ws + + -- walk workspace, resetting X states/mask for windows + -- TODO, general iterators for these lists. + sequence_ [ setInitialProperties w >> reveal w + | wk <- map W.workspace (W.current winset : W.visible winset) + , w <- W.integrate (W.stack wk) ] + + sequence_ [ setInitialProperties w >> hide w + | wk <- W.hidden winset + , w <- W.integrate (W.stack wk) ] + + mapM_ manage ws -- find new windows hunk ./Main.hs 96 - forever $ handle =<< io (nextEvent dpy e >> getEvent e) + forever $ do x <- io (nextEvent dpy e >> getEvent e) + io (hPrint stderr (eventName x, x)) + handle x hunk ./Main.hs 106 --- | scan for any initial windows to manage +-- | scan for any new windows to manage. If they're already managed, +-- this should be idempotent. hunk ./Main.hs 112 - hunk ./Operations.hs 39 --- Bring it into focus. If the window is already managed, nothing happens. +-- Bring it into focus. +-- +-- Whether the window is already managed, or not, it is mapped, has its +-- border set, and its event mask set. hunk ./Operations.hs 46 - io $ selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask - io $ mapWindow d w - io $ setWindowBorderWidth d w borderWidth + setInitialProperties w >> reveal w hunk ./Operations.hs 64 +-- +-- should also unmap? +-- hunk ./Operations.hs 190 --- | hide. Hide a window by unmapping it. +-- | hide. Hide a window by unmapping it, and setting Iconified. hunk ./Operations.hs 192 -hide w = withDisplay $ \d -> do +hide w = withDisplay $ \d -> do hunk ./Operations.hs 196 +-- | reveal. Show a window by mapping it and setting Normal +-- this is harmless if the window was already visible +reveal :: Window -> X () +reveal w = withDisplay $ \d -> do + setWMState w 1 --normal + io $ mapWindow d w + +-- | Set some properties when we initially gain control of a window +setInitialProperties :: Window -> X () +setInitialProperties w = withDisplay $ \d -> io $ do + selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + setWindowBorderWidth d w borderWidth + hunk ./Operations.hs 233 - -- this is harmless if the window was already visible - setWMState w 1 --normal - io $ mapWindow d w + reveal w hunk ./Main.hs 54 - safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x, xs) + safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x,xs) hunk ./Main.hs 59 - , focusedBorder = fbc - } + , focusedBorder = fbc } hunk ./Main.hs 95 - forever $ do x <- io (nextEvent dpy e >> getEvent e) - io (hPrint stderr (eventName x, x)) - handle x + forever $ handle =<< io (nextEvent dpy e >> getEvent e) hunk ./Config.hs 102 +-- +-- Enable logging of state changes to stdout. +-- The internal state of the window manager is 'shown' in Haskell data format +-- +logging :: Bool +logging = False + hunk ./Config.hs-boot 4 +logging :: Bool hunk ./Main.hs 48 + hSetBuffering stdout NoBuffering hunk ./Main.hs 93 - -- withWindowSet (io . hPrint stderr) -- uncomment for state logging + when logging $ withWindowSet (io . hPrint stdout) hunk ./Operations.hs 18 -import {-# SOURCE #-} Config (borderWidth) +import {-# SOURCE #-} Config (borderWidth,logging) hunk ./Operations.hs 171 - -- withWindowSet (io . hPrint stderr) -- logging state changes! - -- io performGC -- really helps + when logging $ withWindowSet (io . hPrint stdout) + -- io performGC -- really helps, but seems to trigger GC bugs? hunk ./Operations.hs 505 ------------------------------------------------------------------------- --- size hints +-- --------------------------------------------------------------------- +-- | Support for window size hints + +type D = (Dimension, Dimension) hunk ./Operations.hs 511 -applySizeHints :: SizeHints -> (Dimension, Dimension) -> (Dimension, Dimension) +applySizeHints :: SizeHints -> D -> D hunk ./Operations.hs 513 - maybe id applyMaxSizeHint (sh_max_size sh) . - maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size sh) . - maybe id applyResizeIncHint (sh_resize_inc sh) . - maybe id applyAspectHint (sh_aspect sh) . - maybe id (\(bw, bh) (w, h) -> (w-bw, h-bh)) (sh_base_size sh) + maybe id applyMaxSizeHint (sh_max_size sh) + . maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size sh) + . maybe id applyResizeIncHint (sh_resize_inc sh) + . maybe id applyAspectHint (sh_aspect sh) + . maybe id (\(bw,bh) (w,h) -> (w-bw, h-bh)) (sh_base_size sh) -- TODO hunk ./Operations.hs 520 -applyAspectHint :: ((Dimension, Dimension), (Dimension, Dimension)) -> (Dimension, Dimension) -> (Dimension, Dimension) -applyAspectHint ((minx, miny), (maxx, maxy)) (w, h) - | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = (w, h) - | w * maxy > h * maxx = (h * maxx `div` maxy, h) - | w * miny < h * minx = (w, w * miny `div` minx) - | otherwise = (w, h) +applyAspectHint :: (D, D) -> D -> D +applyAspectHint ((minx, miny), (maxx, maxy)) x@(w,h) + | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = x + | w * maxy > h * maxx = (h * maxx `div` maxy, h) + | w * miny < h * minx = (w, w * miny `div` minx) + | otherwise = x hunk ./Operations.hs 528 -applyResizeIncHint :: (Dimension, Dimension) -> (Dimension, Dimension) -> (Dimension, Dimension) -applyResizeIncHint (iw, ih) (w, h) - | iw > 0 && ih > 0 = (w - w `mod` iw, h - h `mod` ih) - | otherwise = (w, h) +applyResizeIncHint :: D -> D -> D +applyResizeIncHint (iw,ih) x@(w,h) = + if iw > 0 && ih > 0 then (w - w `mod` iw, h - h `mod` ih) else x hunk ./Operations.hs 533 -applyMaxSizeHint :: (Dimension, Dimension) -> (Dimension, Dimension) -> (Dimension, Dimension) -applyMaxSizeHint (maxw, maxh) (w, h) - | maxw > 0 && maxh > 0 = (min w maxw, min h maxh) - | otherwise = (w, h) +applyMaxSizeHint :: D -> D -> D +applyMaxSizeHint (mw,mh) x@(w,h) = + if mw > 0 && mh > 0 then (min w mw,min h mh) else x hunk ./Operations.hs 450 --- | Toggle floating bit --- --- TODO not useful unless we remember the original size --- --- toggleFloating :: Window -> X () --- toggleFloating w = gets windowset >>= \ws -> if M.member w (W.floating ws) then sink w else float w - ------------------------------------------------------------------------- --- mouse handling +-- --------------------------------------------------------------------- +-- Mouse handling hunk ./Operations.hs 483 - applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))), - (fromIntegral (max 1 (ey - fromIntegral (wa_y wa))))) + applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))), + (fromIntegral (max 1 (ey - fromIntegral (wa_y wa))))) hunk ./Operations.hs 486 --- - --- generic handler, but too complex: --- --- mouseModifyWindow f g w = withDisplay $ \d -> do --- io $ raiseWindow d w --- wa <- io $ getWindowAttributes d w --- x <- f d w wa --- mouseDrag $ \(_,_,_,ex,ey,_,_,_,_,_) -> g x ex ey d w wa --- float w - hunk ./Operations.hs 499 - . maybe id (\(bw,bh) (w,h) -> (w-bw, h-bh)) (sh_base_size sh) -- TODO + . maybe id (\(bw,bh) (w,h) -> (w-bw, h-bh)) (sh_base_size sh) hunk ./Operations.hs 2 ------------------------------------------------------------------------------ +-- ^^ deriving Typeable +-- -------------------------------------------------------------------------- hunk ./Operations.hs 11 --- Portability : not portable, mtl, posix +-- Portability : not portable, Typeable deriving, mtl, posix hunk ./xmonad.cabal 31 +-- Also requires deriving Typeable hunk ./Operations.hs 142 - mapM_ (\(win,rect) -> tileWindow win rect) rs + mapM_ (uncurry tileWindow) rs hunk ./Main.hs 177 -handle (UnmapEvent {ev_window = w, ev_send_event = True}) = whenX (isClient w) $ unmanage w +handle (UnmapEvent {ev_window = w, ev_send_event = True}) = whenX (isClient w) $ unmanage w hunk ./Operations.hs 152 - -- TODO seems fishy? - -- Urgh. This is required because the fullscreen layout assumes that - -- the focused window will be raised. Hmm. This is a reordering. - - -- This really doesn't work with fullscreen mode, where - -- focus is used to find the raised window. moving the floating - -- layer will move focus there, so we now have forgotten the - -- window on the top of the fullscreen + -- TODO temporary work around! hunk ./Operations.hs 154 - -- I think the solution must be to track the floating layer separately - -- in its own zipper, on each workspace. And from there to - -- handle pushing between the two. + -- fullscreen mode requires that the focused window in + -- the tiled layer is raised to the top, just under the floating + -- layer. now we don't get 'real unmap' events, unfortunately we + -- get a focus enter event if we delete a window. in fullscreen + -- mode, this will move focus to the next window down in the + -- stack order hunk ./Operations.hs 161 - let tiled' = case W.peek this of - Just x | x `elem` tiled -> x : delete x tiled - _ -> tiled - - io $ restackWindows d (flt ++ tiled') + -- the 'true' solution is to hide windows not visible on the + -- screen, so they don't get enter events. + -- to do that, doLayout needs to return a list of windows to + -- raise, and a list to hide. + -- + -- and the only way to remember where focus is on the tiled + -- layer appears to be to track the floating and tiled layers as + -- separate stacks. + -- + whenJust (W.peek this) $ io . raiseWindow d + io $ mapM_ (raiseWindow d) (reverse flt) + -- + -- this code will cause a delete on the raiseWindow to + -- pass to the last tiled window that had focus. + -- urgh : not our delete policy, but close. hunk ./Config.hs-boot 3 +import Graphics.X11.Xlib (KeyMask) hunk ./Config.hs-boot 6 +numlockMask :: KeyMask hunk ./Main.hs 132 - -extraModifiers :: [KeyMask] -extraModifiers = [0, numlockMask, lockMask, numlockMask .|. lockMask ] - -cleanMask :: KeyMask -> KeyMask -cleanMask = (complement (numlockMask .|. lockMask) .&.) hunk ./Operations.hs 19 -import {-# SOURCE #-} Config (borderWidth,logging) +import {-# SOURCE #-} Config (borderWidth,logging,numlockMask) hunk ./Operations.hs 23 -import Data.Bits ((.|.)) +import Data.Bits ((.|.), (.&.), complement) hunk ./Operations.hs 436 +-- | Combinations of extra modifier masks we need to grab keys/buttons for. +-- (numlock and capslock) +extraModifiers :: [KeyMask] +extraModifiers = [0, numlockMask, lockMask, numlockMask .|. lockMask ] + +-- | Strip numlock/capslock from a mask +cleanMask :: KeyMask -> KeyMask +cleanMask = (complement (numlockMask .|. lockMask) .&.) + hunk ./Operations.hs 22 -import Data.List (genericIndex, intersectBy, partition, delete) +import Data.List (genericIndex, intersectBy, partition) hunk ./Main.hs 18 +import qualified Data.Set as S hunk ./Main.hs 21 +import Data.Maybe (fromMaybe) hunk ./Main.hs 67 - , xineScreens = xinesc } + , xineScreens = xinesc + , mapped = S.empty + , waitingUnmap = M.empty } hunk ./Main.hs 167 --- We only handle synthetic unmap events, because real events are confusable --- with the events produced by 'hide'. ICCCM says that all clients should send --- synthetic unmap events immediately after unmapping, and later describes --- clients that do not follow the rule as "obsolete". For now, we make the --- simplifying assumption that nobody uses clients that were already obsolete --- in 1994. Note that many alternative methods for resolving the hide/withdraw --- ambiguity are racy. - -handle (UnmapEvent {ev_window = w, ev_send_event = True}) = whenX (isClient w) $ unmanage w +-- We track expected unmap events in waitingUnmap. We ignore this event unless +-- it is synthetic or we are not expecting an unmap notification from a window. +handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do + e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) + if (synthetic || e == 0) + then unmanage w + else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) hunk ./Operations.hs 26 +import qualified Data.Set as S hunk ./Operations.hs 70 -unmanage w = setWMState w 0 {-withdrawn-} >> windows (W.sink w . W.delete w) +unmanage w = do + setWMState w 0 {-withdrawn-} + windows (W.sink w . W.delete w) + modify (\s -> s {mapped = S.delete w (mapped s), waitingUnmap = M.delete w (waitingUnmap s)}) hunk ./Operations.hs 203 -hide w = withDisplay $ \d -> do - io $ unmapWindow d w +hide w = whenX (gets (S.member w . mapped)) $ withDisplay $ \d -> do + io $ do selectInput d w (clientMask .&. complement structureNotifyMask) + unmapWindow d w + selectInput d w clientMask hunk ./Operations.hs 208 + -- this part is key: we increment the waitingUnmap counter to distinguish + -- between client and xmonad initiated unmaps. + modify (\s -> s { waitingUnmap = M.insertWith (+) w 1 (waitingUnmap s) + , mapped = S.delete w (mapped s) }) hunk ./Operations.hs 219 + modify (\s -> s { mapped = S.insert w (mapped s) }) + +-- | The client events that xmonad is interested in +clientMask :: EventMask +clientMask = structureNotifyMask .|. enterWindowMask .|. propertyChangeMask hunk ./Operations.hs 228 - selectInput d w $ structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + selectInput d w $ clientMask hunk ./XMonad.hs 37 +import qualified Data.Set as S hunk ./XMonad.hs 42 - { windowset :: !WindowSet -- ^ workspace list - , xineScreens :: ![Rectangle] -- ^ dimensions of each screen - , statusGaps :: ![(Int,Int,Int,Int)] -- ^ width of status bar on each screen - , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) } + { windowset :: !WindowSet -- ^ workspace list + , xineScreens :: ![Rectangle] -- ^ dimensions of each screen + , statusGaps :: ![(Int,Int,Int,Int)] -- ^ width of status bar on each screen + , mapped :: !(S.Set Window) -- ^ the Set of mapped windows + , waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents + , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) } hunk ./XMonad.hs 49 - hunk ./README 64 + +Notes for using the darcs version + + If you're building the darcs version of xmonad, be sure to also + use the darcs version of X11-extras, which is developed concurrently + with xmonad. + + Not using X11-extras from darcs, is the most common reason for the + darcs version of xmonad to fail to build. + +------------------------------------------------------------------------ hunk ./Main.hs 97 - when logging $ withWindowSet (io . hPrint stdout) + when logging $ withWindowSet (io . putStrLn . serial) hunk ./Operations.hs 182 - when logging $ withWindowSet (io . hPrint stdout) + when logging $ withWindowSet (io . putStrLn . serial) hunk ./StackSet.hs 416 - hunk ./XMonad.hs 21 - runX, io, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, + runX, io, serial, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, hunk ./XMonad.hs 25 -import StackSet (StackSet) +import StackSet hunk ./XMonad.hs 35 +import Data.List (intersperse,sortBy) +import Text.PrettyPrint hunk ./XMonad.hs 187 +-- --------------------------------------------------------------------- +-- Serialise a StackSet in a simple format +-- +-- 4|1:16777220:16777220,2:18874372:18874372,3::,4::,5::,6::,7::,8::,9:: +-- + +infixl 6 <:>, <|> +(<:>), (<|>) :: Doc -> Doc -> Doc +p <:> q = p <> char ':' <> q +p <|> q = p <> char '|' <> q + +serial :: WindowSet -> String +serial = render . ppr + +newtype Windows = Windows [Window] + +class Pretty a where ppr :: a -> Doc + +instance Pretty Window where ppr = text . show + +instance Pretty a => Pretty [a] where + ppr = hcat . intersperse (char ',') . map ppr + +instance Pretty Windows where + ppr (Windows s) = hcat . intersperse (char ';') . map ppr $ s + +instance Pretty WindowSet where + ppr s = int (1 + fromIntegral (tag . workspace . current $ s)) <|> + ppr (sortBy (\a b -> tag a `compare` tag b) + (map workspace (current s : visible s) ++ hidden s)) + +instance Pretty (Workspace WorkspaceId Window) where + ppr (Workspace i s) = + int (1 + fromIntegral i) + <:> (case s of Empty -> empty ; _ -> ppr (focus s)) + <:> ppr (Windows (integrate s)) + + hunk ./Main.hs 31 -import StackSet (new, floating, member) hunk ./Main.hs 54 - | otherwise = new (fromIntegral workspaces) (fromIntegral $ length xinesc) + | otherwise = W.new (fromIntegral workspaces) (fromIntegral $ length xinesc) hunk ./Main.hs 82 + -- We mark the initial state as having all workspaces visible to + -- defeat the delta code in refresh. hunk ./Main.hs 85 - runX cf st $ do - - -- walk workspace, resetting X states/mask for windows - -- TODO, general iterators for these lists. - sequence_ [ setInitialProperties w >> reveal w - | wk <- map W.workspace (W.current winset : W.visible winset) - , w <- W.integrate (W.stack wk) ] - - sequence_ [ setInitialProperties w >> hide w - | wk <- W.hidden winset - , w <- W.integrate (W.stack wk) ] - + runX cf st{ windowset = allVisible winset } $ do + windows $ \_st -> winset hunk ./Main.hs 94 + allVisible ss = ss{ W.hidden=[], W.visible = W.visible ss ++ [ W.Screen s (S 0) | s <- W.hidden ss ] } hunk ./Main.hs 197 - if M.member w (floating ws) || not (member w ws) + if M.member w (W.floating ws) || not (W.member w ws) hunk ./Main.hs 206 - when (member w ws) (float w) + when (W.member w ws) (float w) hunk ./Operations.hs 48 - setInitialProperties w >> reveal w + setInitialProperties w -- we need this so that the modify below will not capture the wrong border size... hunk ./Operations.hs 204 + setInitialProperties w hunk ./Operations.hs 218 + setInitialProperties w hunk ./Operations.hs 218 - setInitialProperties w hunk ./Operations.hs 204 - setInitialProperties w hunk ./Operations.hs 48 - setInitialProperties w -- we need this so that the modify below will not capture the wrong border size... + setInitialProperties w >> reveal w hunk ./Main.hs 206 - when (W.member w ws) (float w) + when (member w ws) (float w) hunk ./Main.hs 197 - if M.member w (W.floating ws) || not (W.member w ws) + if M.member w (floating ws) || not (member w ws) hunk ./Main.hs 94 - allVisible ss = ss{ W.hidden=[], W.visible = W.visible ss ++ [ W.Screen s (S 0) | s <- W.hidden ss ] } hunk ./Main.hs 85 - runX cf st{ windowset = allVisible winset } $ do - windows $ \_st -> winset + runX cf st $ do + + -- walk workspace, resetting X states/mask for windows + -- TODO, general iterators for these lists. + sequence_ [ setInitialProperties w >> reveal w + | wk <- map W.workspace (W.current winset : W.visible winset) + , w <- W.integrate (W.stack wk) ] + + sequence_ [ setInitialProperties w >> hide w + | wk <- W.hidden winset + , w <- W.integrate (W.stack wk) ] + hunk ./Main.hs 82 - -- We mark the initial state as having all workspaces visible to - -- defeat the delta code in refresh. hunk ./Main.hs 54 - | otherwise = W.new (fromIntegral workspaces) (fromIntegral $ length xinesc) + | otherwise = new (fromIntegral workspaces) (fromIntegral $ length xinesc) hunk ./Main.hs 31 +import StackSet (new, floating, member) hunk ./Operations.hs 140 + viewrect = Rectangle (sx + fromIntegral gl) (sy + fromIntegral gt) + (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb)) hunk ./Operations.hs 145 - rs <- doLayout l (Rectangle - (sx + fromIntegral gl) (sy + fromIntegral gt) - (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb))) tiled + rs <- doLayout l viewrect tiled -- `mplus` doLayout full viewrect tiled hunk ./Operations.hs 343 --- wide mode (a mirror of tall mode) hunk ./XMonad.hs 190 --- 4|1:16777220:16777220,2:18874372:18874372,3::,4::,5::,6::,7::,8::,9:: +-- 432|1:16777220:16777220,2:18874372:18874372,3::,4::,5::,6::,7::,8::,9:: +-- +-- format, roughly,: +-- +-- fmt := current visible '|' workspaces +-- +-- current := int +-- visible := int* | epsilon +-- +-- workspaces := workspace ',' workspaces0 +-- workspaces0 := workspace ',' workspaces0 | epsilon +-- +-- workspace := tag ':' focus* ':' clients +-- clients := epsilon | client ';' clients +-- +-- tag := int +-- focus := client +-- +-- client = int+ +-- int := 0 .. 9 hunk ./XMonad.hs 211 - -infixl 6 <:>, <|> -(<:>), (<|>) :: Doc -> Doc -> Doc -p <:> q = p <> char ':' <> q -p <|> q = p <> char '|' <> q hunk ./XMonad.hs 214 + where + ppr s = pprtag (current s) <> hcat (map pprtag (visible s)) + <|> (hcat . intersperse (char ',') . map pprWorkspace $ + (sortBy (\a b -> tag a `compare` tag b) + (map workspace (current s : visible s) ++ hidden s))) + where infixl 6 <|> + p <|> q = p <> char '|' <> q hunk ./XMonad.hs 222 -newtype Windows = Windows [Window] - -class Pretty a where ppr :: a -> Doc - -instance Pretty Window where ppr = text . show - -instance Pretty a => Pretty [a] where - ppr = hcat . intersperse (char ',') . map ppr - -instance Pretty Windows where - ppr (Windows s) = hcat . intersperse (char ';') . map ppr $ s - -instance Pretty WindowSet where - ppr s = int (1 + fromIntegral (tag . workspace . current $ s)) <|> - ppr (sortBy (\a b -> tag a `compare` tag b) - (map workspace (current s : visible s) ++ hidden s)) + pprtag = int . (+1) . fromIntegral . tag . workspace hunk ./XMonad.hs 224 -instance Pretty (Workspace WorkspaceId Window) where - ppr (Workspace i s) = - int (1 + fromIntegral i) - <:> (case s of Empty -> empty ; _ -> ppr (focus s)) - <:> ppr (Windows (integrate s)) + pprWorkspace (Workspace i s) = int (1 + fromIntegral i) + <:> (if s == Empty then empty else text (show (focus s))) + <:> pprWindows (integrate s) + where p <:> q = p <> char ':' <> q hunk ./XMonad.hs 229 + pprWindows = hcat . intersperse (char ';') . map (text.show) hunk ./Config.hs 103 --- Enable logging of state changes to stdout. --- The internal state of the window manager is 'shown' in Haskell data format +-- Perform an arbitrary action on each state change. +-- Examples include: +-- * do nothing +-- * log the state to stdout hunk ./Config.hs 108 -logging :: Bool -logging = False +logHook :: X () +logHook = return () hunk ./Config.hs-boot 4 +import XMonad hunk ./Config.hs-boot 6 -logging :: Bool +logHook :: X () hunk ./Main.hs 97 - when logging $ withWindowSet (io . putStrLn . serial) + logHook hunk ./Operations.hs 19 -import {-# SOURCE #-} Config (borderWidth,logging,numlockMask) +import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask) hunk ./Operations.hs 182 - when logging $ withWindowSet (io . putStrLn . serial) + logHook hunk ./XMonad.hs 20 - Typeable, Message, SomeMessage(..), fromMessage, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, - runX, io, serial, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, - atom_WM_STATE + Typeable, Message, SomeMessage(..), fromMessage, + runX, io, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, + atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW hunk ./XMonad.hs 35 -import Data.List (intersperse,sortBy) -import Text.PrettyPrint hunk ./XMonad.hs 185 --- --------------------------------------------------------------------- --- Serialise a StackSet in a simple format --- --- 432|1:16777220:16777220,2:18874372:18874372,3::,4::,5::,6::,7::,8::,9:: --- --- format, roughly,: --- --- fmt := current visible '|' workspaces --- --- current := int --- visible := int* | epsilon --- --- workspaces := workspace ',' workspaces0 --- workspaces0 := workspace ',' workspaces0 | epsilon --- --- workspace := tag ':' focus* ':' clients --- clients := epsilon | client ';' clients --- --- tag := int --- focus := client --- --- client = int+ --- int := 0 .. 9 --- - -serial :: WindowSet -> String -serial = render . ppr - where - ppr s = pprtag (current s) <> hcat (map pprtag (visible s)) - <|> (hcat . intersperse (char ',') . map pprWorkspace $ - (sortBy (\a b -> tag a `compare` tag b) - (map workspace (current s : visible s) ++ hidden s))) - where infixl 6 <|> - p <|> q = p <> char '|' <> q - - pprtag = int . (+1) . fromIntegral . tag . workspace - - pprWorkspace (Workspace i s) = int (1 + fromIntegral i) - <:> (if s == Empty then empty else text (show (focus s))) - <:> pprWindows (integrate s) - where p <:> q = p <> char ':' <> q - - pprWindows = hcat . intersperse (char ';') . map (text.show) - hunk ./Config.hs 10 --- ------------------------------------------------------------------------- +-- hunk ./Config.hs 15 --- +-- +------------------------------------------------------------------------ hunk ./Config.hs 37 --- +-- | hunk ./Config.hs 46 --- +-- | hunk ./Config.hs 57 --- +-- | hunk ./Config.hs 71 --- +-- | hunk ./Config.hs 78 --- +-- | hunk ./Config.hs 84 --- +-- | hunk ./Config.hs 102 --- +-- | hunk ./Config.hs 111 --- +-- | hunk ./Config.hs 170 --- +-- | hunk ./Main.hs 11 ------------------------------------------------------------------------------ --- hunk ./Main.hs 12 --- +-- +----------------------------------------------------------------------------- + +module Main where hunk ./Main.hs 38 --- +-- | hunk ./Operations.hs 2 --- ^^ deriving Typeable +-- \^^ deriving Typeable hunk ./Operations.hs 13 +-- Operations. +-- hunk ./Operations.hs 40 +-- | hunk ./Operations.hs 42 - --- | manage. Add a new window to be managed in the current workspace. +-- manage. Add a new window to be managed in the current workspace. hunk ./Operations.hs 59 - float w -- ^^ now go the refresh. + float w -- \^^ now go the refresh. hunk ./Operations.hs 452 --- | Combinations of extra modifier masks we need to grab keys/buttons for. +-- | Combinations of extra modifier masks we need to grab keys\/buttons for. hunk ./Operations.hs 457 --- | Strip numlock/capslock from a mask +-- | Strip numlock\/capslock from a mask hunk ./StackSet.hs 11 ------------------------------------------------------------------------------ --- --- ** Introduction +-- Introduction hunk ./StackSet.hs 19 --- --- Workspace { 0*} { 1 } { 2 } { 3 } { 4 } --- --- Windows [1 [] [3* [6*] [] --- ,2*] ,4 --- ,5] --- +-- +-- > Workspace { 0*} { 1 } { 2 } { 3 } { 4 } +-- > +-- > Windows [1 [] [3* [6*] [] +-- > ,2*] ,4 +-- > ,5] +-- hunk ./StackSet.hs 30 --- ** Zipper +-- Zipper hunk ./StackSet.hs 43 --- Oleg Kiselyov, 27 Apr 2005, haskell@, "Zipper as a delimited continuation" +-- Oleg Kiselyov, 27 Apr 2005, haskell\@, "Zipper as a delimited continuation" hunk ./StackSet.hs 59 --- ** Xinerama support: +-- Xinerama support: hunk ./StackSet.hs 68 --- ** Master and Focus +-- Master and Focus hunk ./StackSet.hs 75 + hunk ./StackSet.hs 87 +-- | hunk ./StackSet.hs 90 --- new, -- was: empty --- view, --- index, --- peek, -- was: peek/peekStack --- focusUp, focusDown, -- was: rotate --- swapUp, swapDown --- focus -- was: raiseFocus --- insertUp, -- was: insert/push --- delete, --- swapMaster, -- was: promote/swap --- member, --- shift, --- lookupWorkspace, -- was: workspace --- visibleWorkspaces -- gone. hunk ./StackSet.hs 91 ------------------------------------------------------------------------- - +-- * new, -- was: empty +-- +-- * view, +-- +-- * index, +-- +-- * peek, -- was: peek\/peekStack hunk ./StackSet.hs 99 +-- * focusUp, focusDown, -- was: rotate +-- +-- * swapUp, swapDown +-- +-- * focus -- was: raiseFocus +-- +-- * insertUp, -- was: insert\/push +-- +-- * delete, +-- +-- * swapMaster, -- was: promote\/swap +-- +-- * member, +-- +-- * shift, +-- +-- * lookupWorkspace, -- was: workspace +-- +-- * visibleWorkspaces -- gone. +-- +------------------------------------------------------------------------ +-- | hunk ./StackSet.hs 122 +-- hunk ./StackSet.hs 127 --- + hunk ./StackSet.hs 129 - StackSet { size :: !i -- number of workspaces - , current :: !(Screen i a sid) -- currently focused workspace - , visible :: [Screen i a sid] -- non-focused workspaces, visible in xinerama - , hidden :: [Workspace i a] -- workspaces not visible anywhere - , floating :: M.Map a RationalRect -- floating windows + StackSet { size :: !i -- ^ number of workspaces + , current :: !(Screen i a sid) -- ^ currently focused workspace + , visible :: [Screen i a sid] -- ^ non-focused workspaces, visible in xinerama + , hidden :: [Workspace i a] -- ^ workspaces not visible anywhere + , floating :: M.Map a RationalRect -- ^ floating windows hunk ./StackSet.hs 136 --- Visible workspaces, and their Xinerama screens. +-- | Visible workspaces, and their Xinerama screens. hunk ./StackSet.hs 140 --- +-- | hunk ./StackSet.hs 149 --- +-- | hunk ./StackSet.hs 156 --- +-- master: < '7' > --- up | [ '2' ] --- +--------- [ '3' ] --- focus: < '4' > --- dn +----------- [ '8' ] +-- > +-- master: < '7' > +-- > up | [ '2' ] +-- > +--------- [ '3' ] +-- > focus: < '4' > +-- > dn +----------- [ '8' ] hunk ./StackSet.hs 163 --- the focused position. Under the zipper/calculus view of such +-- the focused position. Under the zipper\/calculus view of such hunk ./StackSet.hs 179 --- Construction +-- | Construction hunk ./StackSet.hs 195 --- --- /O(w)/. Set focus to the workspace with index 'i'. +-- | +-- /O(w)/. Set focus to the workspace with index \'i\'. hunk ./StackSet.hs 202 --- + hunk ./StackSet.hs 222 --- Xinerama operations +-- | Xinerama operations hunk ./StackSet.hs 232 --- +-- | hunk ./StackSet.hs 243 --- +-- | hunk ./StackSet.hs 250 --- +-- | hunk ./StackSet.hs 257 --- +-- | hunk ./StackSet.hs 264 --- +-- | hunk ./StackSet.hs 275 --- +-- | hunk ./StackSet.hs 301 --- reverse a stack: up becomes down and down becomes up. +-- | reverse a stack: up becomes down and down becomes up. hunk ./StackSet.hs 316 --- +-- | hunk ./StackSet.hs 335 --- Modifying the stackset +-- | Modifying the stackset hunk ./StackSet.hs 337 --- +-- | hunk ./StackSet.hs 360 --- +-- | hunk ./StackSet.hs 402 --- Setting the master window - +-- | Setting the master window +-- hunk ./StackSet.hs 412 - -- natural! keep focus, move current to the top, move top to current. - +-- natural! keep focus, move current to the top, move top to current. +-- hunk ./StackSet.hs 415 --- Composite operations +-- | Composite operations hunk ./StackSet.hs 417 - hunk ./StackSet.hs 427 - -- ^^ poor man's state monad :-) + -- ^^ poor man's state monad :-) hunk ./XMonad.hs 12 ------------------------------------------------------------------------------ --- hunk ./XMonad.hs 15 +----------------------------------------------------------------------------- hunk ./Main.hs 227 -handle _ = return () -- trace (eventName e) -- ignoring +handle e = sendMessage e -- trace (eventName e) -- ignoring + +instance Message Event hunk ./Operations.hs 338 -sendMessage a = layout $ \x@(l, ls) -> maybe x (flip (,) ls) (modifyLayout l (SomeMessage a)) +sendMessage a = do n <- (W.tag . W.workspace . W.current) `fmap` gets windowset + Just (l,ls) <- M.lookup n `fmap` gets layouts + ml' <- modifyLayout l (SomeMessage a) + whenJust ml' $ \l' -> do modify $ \s -> s { layouts = M.insert n (l',ls) (layouts s) } + refresh hunk ./Operations.hs 365 - , modifyLayout = const Nothing } -- no changes + , modifyLayout = const (return Nothing) } -- no changes hunk ./Operations.hs 373 - , modifyLayout = \m -> fmap resize (fromMessage m) `mplus` - fmap incmastern (fromMessage m) } + , modifyLayout = \m -> return $ msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] } hunk ./Operations.hs 388 - , modifyLayout = fmap mirror . ml } + , modifyLayout = fmap (fmap mirror) . ml } hunk ./XMonad.hs 112 - , modifyLayout :: SomeMessage -> Maybe Layout } + , modifyLayout :: SomeMessage -> X (Maybe Layout) } hunk ./Operations.hs 126 +data ModifyWindows = ModifyWindows deriving Typeable +instance Message ModifyWindows + hunk ./Operations.hs 132 + sendMessage ModifyWindows hunk ./Main.hs 189 + sendMessage e -- Always send button events. hunk ./Main.hs 230 -instance Message Event - hunk ./Operations.hs 126 -data ModifyWindows = ModifyWindows deriving Typeable +data ModifyWindows = ModifyWindows deriving ( Typeable, Eq ) hunk ./Operations.hs 348 +instance Message Event + hunk ./Operations.hs 441 + sendMessage ModifyWindows hunk ./Main.hs 184 + -- If it's the root window, then it's something we + -- grabbed in grabButtons. Otherwise, it's click-to-focus. hunk ./Main.hs 189 - -- If it's the root window, then it's something we - -- grabbed in grabButtons. Otherwise, it's click-to-focus. hunk ./Operations.hs 382 - where resize Shrink = tall nmaster delta (frac-delta) - resize Expand = tall nmaster delta (frac+delta) + where resize Shrink = tall nmaster delta (max 0 $ frac-delta) + resize Expand = tall nmaster delta (min 1 $ frac+delta) hunk ./Operations.hs 259 + -- give all windows at least 1x1 pixels + let least x | x <= bw*2 = 1 + | otherwise = x - bw*2 hunk ./Operations.hs 263 - (rect_width r - bw*2) (rect_height r - bw*2) + (least $ rect_width r) (least $ rect_height r) hunk ./XMonad.hs 20 - runX, io, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, + runX, io, safeIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, hunk ./XMonad.hs 140 +safeIO :: IO () -> X () +safeIO f = liftIO (f `catch` \e -> do hPutStrLn stderr (show e); hFlush stderr) + hunk ./XMonad.hs 20 - runX, io, safeIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, + runX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, hunk ./XMonad.hs 140 -safeIO :: IO () -> X () -safeIO f = liftIO (f `catch` \e -> do hPutStrLn stderr (show e); hFlush stderr) +-- | Lift an IO action into the X monad. If the action results in an IO +-- exception, log the exception to stderr and continue normal execution. +catchIO :: IO () -> X () +catchIO f = liftIO (f `catch` \e -> do hPutStrLn stderr (show e); hFlush stderr) hunk ./XMonad.hs 166 - io $ catch (executeFile prog True args Nothing) - (hPutStrLn stderr . show) -- print executable not found exception + catchIO (executeFile prog True args Nothing) hunk ./StackSet.hs 79 - focusWindow, member, findIndex, insertUp, delete, shift, + focusWindow, member, findIndex, insertUp, delete, shift, filter, hunk ./StackSet.hs 83 +import Prelude hiding (filter) hunk ./StackSet.hs 85 -import qualified Data.List as L (delete,find,genericSplitAt) +import qualified Data.List as L (delete,find,genericSplitAt,filter) hunk ./StackSet.hs 265 +-- | +-- /O(n)/. 'filter p s' returns the elements of 's' such that 'p' evaluates to +-- True. Order is preserved, and focus moves to the next node to the right (if +-- necessary). +filter :: (a -> Bool) -> Stack a -> Stack a +filter p Empty = Empty +filter p (Node f ls rs) = case L.filter p (f:rs) of + (f':rs') -> Node f' (L.filter p ls) rs' + [] -> case reverse $ L.filter p ls of + [] -> Empty + (f':rs') -> Node f' [] rs' + hunk ./tests/Properties.hs 3 -import StackSet +import StackSet hiding (filter) hunk ./StackSet.hs 270 -filter p Empty = Empty +filter _ Empty = Empty hunk ./Operations.hs 143 - (flt, tiled) = partition (flip M.member (W.floating ws)) (W.index this) + flt = filter (flip M.member (W.floating ws)) (W.index this) + tiled = W.filter (not . flip M.member (W.floating ws)) . W.stack . W.workspace . W.current $ this hunk ./Operations.hs 374 -full = Layout { doLayout = \sc ws -> return [ (w,sc) | w <- ws ] +full = Layout { doLayout = \sc ws -> return $ case ws of + W.Empty -> [] + (W.Node f _ _) -> [(f, sc)] hunk ./Operations.hs 384 - Layout { doLayout = \r -> return . ap zip (tile frac r nmaster . length) + Layout { doLayout = \r -> return . ap zip (tile frac r nmaster . length) . W.integrate hunk ./XMonad.hs 111 -data Layout = Layout { doLayout :: Rectangle -> [Window] -> X [(Window, Rectangle)] +data Layout = Layout { doLayout :: Rectangle -> Stack Window -> X [(Window, Rectangle)] hunk ./Operations.hs 24 -import Data.List (genericIndex, intersectBy, partition) +import Data.List (genericIndex, intersectBy) hunk ./Operations.hs 24 -import Data.List (genericIndex, intersectBy) +import Data.List (genericIndex, intersectBy, nub, (\\)) hunk ./Operations.hs 87 -shift n = withFocused hide >> windows (W.shift n) --- TODO: get rid of the above hide. 'windows' should handle all hiding and --- revealing of windows +shift n = windows (W.shift n) hunk ./Operations.hs 132 - let ws = f old + let oldvisible = concatMap (W.integrate . W.stack . W.workspace) $ W.current old : W.visible old + ws = f old hunk ./Operations.hs 138 - forM_ (W.current ws : W.visible ws) $ \w -> do + visible <- fmap concat $ forM (W.current ws : W.visible ws) $ \w -> do hunk ./Operations.hs 187 + -- return the visible windows for this workspace: + return (map fst rs ++ flt) + hunk ./Operations.hs 194 - -- We now go to some effort to compute the minimal set of windows to hide. - -- The minimal set being only those windows which weren't previously hidden, - -- which is the intersection of previously visible windows with those now hidden - mapM_ hide . concatMap (W.integrate . W.stack) $ - intersectBy (\w x -> W.tag w == W.tag x) - (map W.workspace $ W.current old : W.visible old) - (W.hidden ws) + -- hide every window that was potentially visible before, but is not + -- given a position by a layout now. + mapM_ hide (nub oldvisible \\ visible) hunk ./Operations.hs 338 --- | Throw an (extensible) message value to the current Layout scheme, --- possibly modifying how we layout the windows, then refresh. --- --- TODO, this will refresh on Nothing. +-- | Throw a message to the current Layout possibly modifying how we +-- layout the windows, then refresh. hunk ./Operations.hs 24 -import Data.List (genericIndex, intersectBy, nub, (\\)) +import Data.List (genericIndex, nub, (\\)) hunk ./Operations.hs 336 -switchLayout = layout (\(x, xs) -> let xs' = xs ++ [x] in (head xs', tail xs')) +switchLayout = do + sendMessage ModifyWindows + n <- gets (W.tag . W.workspace . W.current . windowset) + modify $ \s -> s { layouts = M.adjust switch n (layouts s) } + refresh + where switch (x, xs) = let xs' = xs ++ [x] in (head xs', tail xs') hunk ./Operations.hs 442 ------------------------------------------------------------------------- - --- | layout. Modify the current workspace's layout with a pure --- function and refresh. -layout :: ((Layout, [Layout]) -> (Layout, [Layout])) -> X () -layout f = do - sendMessage ModifyWindows - modify $ \s -> - let n = W.tag . W.workspace . W.current . windowset $ s - (Just fl) = M.lookup n $ layouts s - in s { layouts = M.insert n (f fl) (layouts s) } - refresh - hunk ./Operations.hs 73 - setWMState w 0 {-withdrawn-} hunk ./Operations.hs 74 + setWMState w 0 {-withdrawn-} hunk ./Main.hs 115 + -- TODO: scan for windows that are either 'IsViewable' or where WM_STATE == + -- Iconic hunk ./Operations.hs 39 +import qualified Data.Traversable as T + hunk ./Operations.hs 355 +-- | Send a message to all visible layouts, without necessarily refreshing. +-- This is how we implement the hooks, such as ModifyWindows. +broadcastMessage :: Message a => a -> X () +broadcastMessage a = do + ol <- gets layouts + nl <- T.forM ol $ \ (l,ls) -> maybe (l,ls) (flip (,) ls) `fmap` modifyLayout l (SomeMessage a) + modify $ \s -> s { layouts = nl } + hunk ./Operations.hs 132 - sendMessage ModifyWindows + -- Notify visible layouts to remove decorations etc + -- We cannot use sendMessage because this must not call refresh ever, + -- and must be called on all visible workspaces. + broadcastMessage ModifyWindows hunk ./Operations.hs 146 - Just l = fmap fst $ M.lookup n fls + Just (l,ls) = M.lookup n fls hunk ./Operations.hs 154 + hunk ./Operations.hs 341 +-- Note that the new layout's deconstructor will be called, so it should be +-- idempotent. hunk ./Operations.hs 345 - sendMessage ModifyWindows + broadcastMessage ModifyWindows -- calling refresh now would defeat the point of deconstruction replace ./Operations.hs [A-Za-z_0-9] ModifyWindows UnDoLayout hunk ./Operations.hs 146 - Just (l,ls) = M.lookup n fls + Just l = fmap fst $ M.lookup n fls hunk ./Operations.hs 148 - tiled = W.filter (not . flip M.member (W.floating ws)) . W.stack . W.workspace . W.current $ this + tiled = W.filter (not . flip M.member (W.floating ws)) + . W.stack . W.workspace . W.current $ this hunk ./Operations.hs 155 - hunk ./StackSet.hs 217 - | otherwise = abort "Inconsistent StackSet: workspace not found" + | otherwise = s hunk ./StackSet.hs 78 - new, view, lookupWorkspace, peek, index, integrate, focusUp, focusDown, + new, view, lookupWorkspace, peek, index, integrate, differentiate, focusUp, focusDown, hunk ./StackSet.hs 265 +-- | +-- /O(n)/. Texture a list. +-- +differentiate :: [a] -> Stack a +differentiate [] = Empty +differentiate (x:xs) = Node x [] xs + hunk ./Main.hs 91 - , w <- W.integrate (W.stack wk) ] + , w <- W.integrate' (W.stack wk) ] hunk ./Main.hs 95 - , w <- W.integrate (W.stack wk) ] + , w <- W.integrate' (W.stack wk) ] hunk ./Operations.hs 137 - let oldvisible = concatMap (W.integrate . W.stack . W.workspace) $ W.current old : W.visible old + let oldvisible = concatMap (W.integrate' . W.stack . W.workspace) $ W.current old : W.visible old hunk ./Operations.hs 148 - tiled = W.filter (not . flip M.member (W.floating ws)) - . W.stack . W.workspace . W.current $ this + tiled = W.filter (not . flip M.member (W.floating ws)) . W.stack . W.workspace . W.current $ this hunk ./Operations.hs 156 - rs <- doLayout l viewrect tiled -- `mplus` doLayout full viewrect tiled + rs <- runLayout l viewrect tiled -- `mplus` doLayout full viewrect tiled hunk ./Operations.hs 390 -full = Layout { doLayout = \sc ws -> return $ case ws of - W.Empty -> [] - (W.Node f _ _) -> [(f, sc)] +full = Layout { doLayout = \sc (W.Stack f _ _) -> return [(f, sc)] hunk ./StackSet.hs 77 - StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), - new, view, lookupWorkspace, peek, index, integrate, differentiate, focusUp, focusDown, + StackSet(..), Workspace(..), Screen(..), StackOrNot, Stack(..), RationalRect(..), + new, view, lookupWorkspace, peek, index, integrate, integrate', differentiate, + focusUp, focusDown, hunk ./StackSet.hs 81 - swapMaster, swapUp, swapDown, modify, float, sink -- needed by users + swapMaster, swapUp, swapDown, modify, modify', float, sink -- needed by users hunk ./StackSet.hs 145 -data Workspace i a = Workspace { tag :: !i, stack :: Stack a } +data Workspace i a = Workspace { tag :: !i, stack :: StackOrNot a } hunk ./StackSet.hs 169 -data Stack a = Empty - | Node { focus :: !a -- focused thing in this set - , up :: [a] -- clowns to the left - , down :: [a] } -- jokers to the right +type StackOrNot a = Maybe (Stack a) + +data Stack a = Stack { focus :: !a -- focused thing in this set + , up :: [a] -- clowns to the left + , down :: [a] } -- jokers to the right hunk ./StackSet.hs 194 - where (seen,unseen) = L.genericSplitAt m $ Workspace 0 Empty : [ Workspace i Empty | i <- [1 ..n-1]] + where (seen,unseen) = L.genericSplitAt m $ Workspace 0 Nothing : [ Workspace i Nothing | i <- [1 ..n-1]] hunk ./StackSet.hs 237 --- StackSet. If the current stack is Empty, 'with' returns the +-- StackSet. If the current stack is Nothing, 'with' returns the hunk ./StackSet.hs 242 -with dflt f s = case stack (workspace (current s)) of Empty -> dflt; v -> f v - -- TODO: ndm: a 'catch' proof here that 'f' only gets Node - -- constructors, hence all 'f's are safe below? +with dflt f = maybe dflt f . stack . workspace . current hunk ./StackSet.hs 245 --- Apply a function, and a default value for Empty, to modify the current stack. +-- Apply a function, and a default value for Nothing, to modify the current stack. hunk ./StackSet.hs 247 -modify :: Stack a -> (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s +modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i a s -> StackSet i a s hunk ./StackSet.hs 251 +-- | +-- Apply a function to modify the current stack if it isn't empty, and we don't +-- want to empty it. +-- +modify' :: (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s +modify' f = modify Nothing (Just . f) + hunk ./StackSet.hs 269 -integrate Empty = [] -integrate (Node x l r) = reverse l ++ x : r +integrate (Stack x l r) = reverse l ++ x : r + +integrate' :: StackOrNot a -> [a] +integrate' = maybe [] integrate hunk ./StackSet.hs 277 -differentiate :: [a] -> Stack a -differentiate [] = Empty -differentiate (x:xs) = Node x [] xs +differentiate :: [a] -> StackOrNot a +differentiate [] = Nothing +differentiate (x:xs) = Just $ Stack x [] xs hunk ./StackSet.hs 285 -filter :: (a -> Bool) -> Stack a -> Stack a -filter _ Empty = Empty -filter p (Node f ls rs) = case L.filter p (f:rs) of - (f':rs') -> Node f' (L.filter p ls) rs' - [] -> case reverse $ L.filter p ls of - [] -> Empty - (f':rs') -> Node f' [] rs' +filter :: (a -> Bool) -> Stack a -> StackOrNot a +filter p (Stack f ls rs) = case L.filter p (f:rs) of + (f':rs') -> Just $ Stack f' (L.filter p ls) rs' + [] -> do f':rs' <- return $ reverse $ L.filter p ls + Just $ Stack f' [] rs' hunk ./StackSet.hs 315 -focusUp = modify Empty focusUp' -focusDown = modify Empty (reverseStack . focusUp' . reverseStack) +focusUp = modify' focusUp' +focusDown = modify' (reverseStack . focusUp' . reverseStack) hunk ./StackSet.hs 318 -swapUp = modify Empty swapUp' -swapDown = modify Empty (reverseStack . swapUp' . reverseStack) +swapUp = modify' swapUp' +swapDown = modify' (reverseStack . swapUp' . reverseStack) hunk ./StackSet.hs 322 -focusUp' (Node t (l:ls) rs) = Node l ls (t:rs) -focusUp' (Node t [] rs) = Node x xs [] where (x:xs) = reverse (t:rs) +focusUp' (Stack t (l:ls) rs) = Stack l ls (t:rs) +focusUp' (Stack t [] rs) = Stack x xs [] where (x:xs) = reverse (t:rs) hunk ./StackSet.hs 325 -swapUp' (Node t (l:ls) rs) = Node t ls (l:rs) -swapUp' (Node t [] rs) = Node t (reverse rs) [] +swapUp' (Stack t (l:ls) rs) = Stack t ls (l:rs) +swapUp' (Stack t [] rs) = Stack t (reverse rs) [] hunk ./StackSet.hs 330 -reverseStack (Node t ls rs) = Node t rs ls -reverseStack x = x +reverseStack (Stack t ls rs) = Stack t rs ls hunk ./StackSet.hs 357 - where has _ Empty = False - has x (Node t l r) = x `elem` (t : l ++ r) + where has _ Nothing = False + has x (Just (Stack t l r)) = x `elem` (t : l ++ r) hunk ./StackSet.hs 379 - where insert = modify (Node a [] []) (\(Node t l r) -> Node a l (t:r)) s + where insert = modify (Just $ Stack a [] []) (\(Stack t l r) -> Just $ Stack a l (t:r)) s hunk ./StackSet.hs 382 --- insertDown a = modify (Node a [] []) $ \(Node t l r) -> Node a (t:l) r +-- insertDown a = modify (Stack a [] []) $ \(Stack t l r) -> Stack a (t:l) r hunk ./StackSet.hs 390 --- * delete on an Empty workspace leaves it Empty +-- * delete on an Nothing workspace leaves it Nothing hunk ./StackSet.hs 393 --- * otherwise, you've got an empty workspace, becomes Empty +-- * otherwise, you've got an empty workspace, becomes Nothing hunk ./StackSet.hs 408 - remove = modify Empty $ \c -> + remove = modify Nothing $ \c -> hunk ./StackSet.hs 411 - Node _ ls (r:rs) -> Node r ls rs -- try down first - Node _ (l:ls) [] -> Node l ls [] -- else up - Node _ [] [] -> Empty - else c { up = w `L.delete` up c, down = w `L.delete` down c } + Stack _ ls (r:rs) -> Just $ Stack r ls rs -- try down first + Stack _ (l:ls) [] -> Just $ Stack l ls [] -- else up + Stack _ [] [] -> Nothing + else Just $ c { up = w `L.delete` up c, down = w `L.delete` down c } hunk ./StackSet.hs 434 -swapMaster = modify Empty $ \c -> case c of - Node _ [] _ -> c -- already master. - Node t ls rs -> Node t [] (ys ++ x : rs) where (x:ys) = reverse ls +swapMaster = modify' $ \c -> case c of + Stack _ [] _ -> c -- already master. + Stack t ls rs -> Stack t [] (ys ++ x : rs) where (x:ys) = reverse ls hunk ./XMonad.hs 19 - Typeable, Message, SomeMessage(..), fromMessage, + Typeable, Message, SomeMessage(..), fromMessage, runLayout, hunk ./XMonad.hs 114 +runLayout :: Layout -> Rectangle -> StackOrNot Window -> X [(Window, Rectangle)] +runLayout l r = maybe (return []) (doLayout l r) + hunk ./tests/Properties.hs 117 - , let t = stack w, t /= Empty ] :: [Char] + , t <- maybeToList (stack w)] :: [Char] hunk ./tests/Properties.hs 151 - Just _ -> let w = focus . stack . workspace . current $ foldr (const focusUp) x [1..n] + Just _ -> let w = focus . fromJust . stack . workspace . current $ foldr (const focusUp) x [1..n] hunk ./tests/Properties.hs 178 - all (== Empty) [ stack w | w <- workspace (current x) + all (== Nothing) [ stack w | w <- workspace (current x) hunk ./tests/Properties.hs 260 - case it of - Empty -> length (index x) == 0 - Node {} -> length (index x) == length list - where - it = stack . workspace . current $ x - list = focus it : up it ++ down it + case stack . workspace . current $ x of + Nothing -> length (index x) == 0 + Just it -> length (index x) == length (focus it : up it ++ down it) hunk ./tests/Properties.hs 293 - in (focus . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i) + in (focus . fromJust . stack . workspace . current) (focusWindow (s !! i) x) == (s !! i) hunk ./tests/Properties.hs 324 - , let t = stack w - , t /= Empty - , i <- focus (stack w) : up (stack w) ++ down (stack w) + , t <- maybeToList (stack w) + , i <- focus t : up t ++ down t hunk ./Operations.hs 156 - rs <- runLayout l viewrect tiled -- `mplus` doLayout full viewrect tiled + rs <- runLayout l viewrect tiled `catchX` runLayout full viewrect tiled hunk ./Operations.hs 356 - ml' <- modifyLayout l (SomeMessage a) + ml' <- modifyLayout l (SomeMessage a) `catchX` return (Just l) hunk ./Operations.hs 365 - nl <- T.forM ol $ \ (l,ls) -> maybe (l,ls) (flip (,) ls) `fmap` modifyLayout l (SomeMessage a) + nl <- T.forM ol $ \ (l,ls) -> maybe (l,ls) (flip (,) ls) `fmap` + (modifyLayout l (SomeMessage a) `catchX` return (Just l)) hunk ./XMonad.hs 20 - runX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, + runX, catchX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, hunk ./XMonad.hs 79 +-- | Run in the X monad, and in case of exception, and catch it and log it +-- to stderr, and run the error case. +catchX :: X a -> X a -> X a +catchX (X job) (X errcase) = + do st <- get + c <- ask + (a,s') <- io ((runStateT (runReaderT job c) st) `catch` + \e -> (do hPutStrLn stderr (show e); runStateT (runReaderT errcase c) st)) + put s' + return a + hunk ./Operations.hs 148 - tiled = W.filter (not . flip M.member (W.floating ws)) . W.stack . W.workspace . W.current $ this + tiled = (W.stack . W.workspace . W.current $ this) + >>= W.filter (not . flip M.member (W.floating ws)) hunk ./Operations.hs 325 - whenX (not `liftM` isRoot w) $ do - io $ do setInputFocus dpy w revertToPointerRoot 0 - -- raiseWindow dpy w - setButtonGrab False w - io $ setWindowBorder dpy w (color_pixel fbc) + -- If we ungrab buttons on the root window, we lose our mouse bindings. + whenX (not `liftM` isRoot w) $ setButtonGrab False w + io $ do setInputFocus dpy w revertToPointerRoot 0 + -- raiseWindow dpy w + io $ setWindowBorder dpy w (color_pixel fbc) hunk ./XMonad.hs 82 -catchX (X job) (X errcase) = - do st <- get - c <- ask - (a,s') <- io ((runStateT (runReaderT job c) st) `catch` - \e -> (do hPutStrLn stderr (show e); runStateT (runReaderT errcase c) st)) - put s' - return a +catchX (X job) (X errcase) = do + st <- get + c <- ask + (a,s') <- io ((runStateT (runReaderT job c) st) `catch` + \e -> (do hPutStrLn stderr (show e); runStateT (runReaderT errcase c) st)) + put s' + return a hunk ./XMonad.hs 116 --- Layout handling +-- | Layout handling hunk ./XMonad.hs 118 --- | The different layout modes +-- The different layout modes hunk ./XMonad.hs 128 --- Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/, +-- | Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/, hunk ./XMonad.hs 131 --- User-extensible messages must be a member of this class: +-- User-extensible messages must be a member of this class. hunk ./XMonad.hs 135 --- +-- | hunk ./XMonad.hs 140 --- +-- | hunk ./XMonad.hs 148 --- General utilities - --- | Lift an IO action into the X monad +-- | General utilities +-- +-- Lift an IO action into the X monad hunk ./XMonad.hs 190 --- | Grab the X server (lock it) from the X monad +-- Grab the X server (lock it) from the X monad hunk ./Main.hs 45 - initcolor c = fst `liftM` allocNamedColor dpy (defaultColormap dpy dflt) c hunk ./Main.hs 48 - nbc <- initcolor normalBorderColor - fbc <- initcolor focusedBorderColor + nbc <- initColor dpy normalBorderColor + fbc <- initColor dpy focusedBorderColor hunk ./Operations.hs 323 - io $ setWindowBorder dpy otherw (color_pixel nbc) + io $ setWindowBorder dpy otherw nbc hunk ./Operations.hs 329 - io $ setWindowBorder dpy w (color_pixel fbc) + io $ setWindowBorder dpy w fbc hunk ./Operations.hs 481 +-- | Get the Pixel value for a named color +initColor :: Display -> String -> IO Pixel +initColor dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c + where colormap = defaultColormap dpy (defaultScreen dpy) + hunk ./XMonad.hs 51 - , normalBorder :: !Color -- ^ border color of unfocused windows - , focusedBorder :: !Color } -- ^ border color of the focused window + , normalBorder :: !Pixel -- ^ border color of unfocused windows + , focusedBorder :: !Pixel } -- ^ border color of the focused window hunk ./StackSet.hs 11 --- Introduction + +module StackSet ( + -- * Introduction + -- $intro + StackSet(..), Workspace(..), Screen(..), StackOrNot, Stack(..), RationalRect(..), + -- * Construction + -- $construction + new, view, + -- * Xinerama operations + -- $xinerama + lookupWorkspace, + -- * Operations on the current stack + -- $stackOperations + peek, index, integrate, integrate', differentiate, + focusUp, focusDown, + focusWindow, member, findIndex, + -- * Modifying the stackset + -- $modifyStackset + insertUp, delete, filter, + -- * Setting the master window + -- $settingMW + swapMaster, swapUp, swapDown, modify, modify', float, sink, -- needed by users + -- * Composite operations + -- $composite + shift + ) where + +import Prelude hiding (filter) +import Data.Maybe (listToMaybe) +import qualified Data.List as L (delete,find,genericSplitAt,filter) +import qualified Data.Map as M (Map,insert,delete,empty) + +-- $intro hunk ./StackSet.hs 107 - -module StackSet ( - StackSet(..), Workspace(..), Screen(..), StackOrNot, Stack(..), RationalRect(..), - new, view, lookupWorkspace, peek, index, integrate, integrate', differentiate, - focusUp, focusDown, - focusWindow, member, findIndex, insertUp, delete, shift, filter, - swapMaster, swapUp, swapDown, modify, modify', float, sink -- needed by users - ) where - -import Prelude hiding (filter) -import Data.Maybe (listToMaybe) -import qualified Data.List as L (delete,find,genericSplitAt,filter) -import qualified Data.Map as M (Map,insert,delete,empty) - --- | hunk ./StackSet.hs 108 --- StackSet constructor arguments changed. StackSet workspace window screen +-- StackSet constructor arguments changed. StackSet workspace window screen hunk ./StackSet.hs 199 --- | Construction +-- $construction hunk ./StackSet.hs 242 --- | Xinerama operations +-- $xinerama hunk ./StackSet.hs 250 --- Operations on the current stack +-- $stackOperations hunk ./StackSet.hs 378 --- | Modifying the stackset - +-- $modifyStackset + hunk ./StackSet.hs 445 --- | Setting the master window --- --- /O(s)/. Set the master window to the focused window. +-- $settingMW + +-- | /O(s)/. Set the master window to the focused window. hunk ./StackSet.hs 458 --- | Composite operations --- --- /O(w)/. shift. Move the focused element of the current stack to stack +-- $composite + +-- | /O(w)/. shift. Move the focused element of the current stack to stack hunk ./Operations.hs 168 - -- TODO temporary work around! - -- - -- fullscreen mode requires that the focused window in - -- the tiled layer is raised to the top, just under the floating - -- layer. now we don't get 'real unmap' events, unfortunately we - -- get a focus enter event if we delete a window. in fullscreen - -- mode, this will move focus to the next window down in the - -- stack order - -- - -- the 'true' solution is to hide windows not visible on the - -- screen, so they don't get enter events. - -- to do that, doLayout needs to return a list of windows to - -- raise, and a list to hide. - -- - -- and the only way to remember where focus is on the tiled - -- layer appears to be to track the floating and tiled layers as - -- separate stacks. - -- hunk ./Operations.hs 169 - io $ mapM_ (raiseWindow d) (reverse flt) - -- - -- this code will cause a delete on the raiseWindow to - -- pass to the last tiled window that had focus. - -- urgh : not our delete policy, but close. hunk ./Operations.hs 24 -import Data.List (genericIndex, nub, (\\)) +import Data.List (delete, genericIndex, nub, (\\)) hunk ./Operations.hs 168 - whenJust (W.peek this) $ io . raiseWindow d + io $ restackWindows d (flt ++ + maybe [] (\s@(W.Stack f _ _) -> f : delete f (W.integrate s)) tiled) hunk ./Main.hs 55 - | otherwise = new (fromIntegral workspaces) (fromIntegral $ length xinesc) + | otherwise = new [0..fromIntegral workspaces-1] (fromIntegral $ length xinesc) hunk ./StackSet.hs 26 - focusWindow, member, findIndex, + focusWindow, tagMember, member, findIndex, hunk ./StackSet.hs 107 + +import Prelude hiding (filter) +import Data.Maybe (listToMaybe) +import qualified Data.List as L (delete,find,genericSplitAt,filter) +import qualified Data.Map as M (Map,insert,delete,empty) + +-- | hunk ./StackSet.hs 155 - StackSet { size :: !i -- ^ number of workspaces - , current :: !(Screen i a sid) -- ^ currently focused workspace + StackSet { current :: !(Screen i a sid) -- ^ currently focused workspace hunk ./StackSet.hs 207 --- | /O(n)/. Create a new stackset, of empty stacks, of size 'n', with --- 'm' physical screens. 'm' should be less than or equal to 'n'. --- The workspace with index '0' will be current. +-- | /O(n)/. Create a new stackset, of empty stacks, with given tags, with +-- 'm' physical screens. 'm' should be less than or equal to the number of +-- workspace tags. The first workspace in the list will be current. hunk ./StackSet.hs 213 -new :: (Integral i, Integral s) => i -> s -> StackSet i a s -new n m | n > 0 && m > 0 = StackSet n cur visi unseen M.empty - | otherwise = abort "non-positive arguments to StackSet.new" - - where (seen,unseen) = L.genericSplitAt m $ Workspace 0 Nothing : [ Workspace i Nothing | i <- [1 ..n-1]] +new :: Integral s => [i] -> s -> StackSet i a s +new (wid:wids) m | m > 0 = StackSet cur visi unseen M.empty + where (seen,unseen) = L.genericSplitAt m $ Workspace wid Nothing : [ Workspace i Nothing | i <- wids] hunk ./StackSet.hs 218 +new _ _ = abort "non-positive argument to StackSet.new" + + hunk ./StackSet.hs 230 -view :: (Eq a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s +view :: (Eq a, Eq s, Eq i) => i -> StackSet i a s -> StackSet i a s hunk ./StackSet.hs 232 - | i < 0 && i >= size s || i == tag (workspace (current s)) = s -- out of bounds or current + | not (elem i $ map tag $ workspaces s) + || i == tag (workspace (current s)) = s -- out of bounds or current hunk ./StackSet.hs 367 + + +-- | Get a list of all workspaces in the StackSet. +workspaces :: StackSet i a s -> [Workspace i a] +workspaces s = workspace (current s) : map workspace (visible s) ++ hidden s + +-- | Is the given tag present in the StackSet? +tagMember :: Eq i => i -> StackSet i a s -> Bool +tagMember t = elem t . map tag . workspaces + hunk ./StackSet.hs 391 - [ tag w | w <- workspace (current s) : map workspace (visible s) ++ hidden s, has a (stack w) ] + [ tag w | w <- workspaces s, has a (stack w) ] hunk ./StackSet.hs 485 -shift n s = if and [n >= 0,n < size s,n /= tag (workspace (current s))] +shift n s = if and [n >= 0,n `tagMember` s, n /= tag (workspace (current s))] hunk ./tests/Properties.hs 74 - (new (genericLength xs) m) (zip [0..] xs) + (new [0..genericLength xs-1] m) (zip [0..] xs) hunk ./tests/Properties.hs 84 -type T = StackSet Int Char Int +type T = StackSet (NonNegative Int) Char Int hunk ./tests/Properties.hs 106 - , accurateSize hunk ./tests/Properties.hs 118 - calculatedSize = length (visible s) + length (hidden s) + 1 -- +1 is for current - accurateSize = calculatedSize == size s hunk ./tests/Properties.hs 135 - invariant $ new (fromIntegral n) m + invariant $ new [0..fromIntegral n-1] m hunk ./tests/Properties.hs 138 - fromIntegral n < size x ==> invariant $ view (fromIntegral n) x + n `tagMember` x ==> invariant $ view (fromIntegral n) x hunk ./tests/Properties.hs 166 - fromIntegral n < size x ==> invariant $ shift (fromIntegral n) x + n `tagMember` x ==> invariant $ shift (fromIntegral n) x hunk ./tests/Properties.hs 173 -prop_empty (n :: Positive Int) - (m :: Positive Int) = +prop_empty (NonEmptyNubList ns) (m :: Positive Int) = hunk ./tests/Properties.hs 177 - where x = new (fromIntegral n) (fromIntegral m) :: T + where x = new ns (fromIntegral m) :: T hunk ./tests/Properties.hs 179 --- empty StackSets always have focus on workspace 0 -prop_empty_current (n :: Positive Int) - (m :: Positive Int) = tag (workspace $ current x) == 0 - where x = new (fromIntegral n) (fromIntegral m) :: T +-- empty StackSets always have focus on first workspace +prop_empty_current (NonEmptyNubList ns) (m :: Positive Int) = tag (workspace $ current x) == head ns + where x = new ns (fromIntegral m) :: T hunk ./tests/Properties.hs 184 -prop_member_empty i (n :: Positive Int) (m :: Positive Int) - = member i (new (fromIntegral n) (fromIntegral m) :: T) == False +prop_member_empty i (NonEmptyNubList ns) (m :: Positive Int) + = member i (new ns (fromIntegral m) :: T) == False hunk ./tests/Properties.hs 191 -prop_view_current (x :: T) (n :: NonNegative Int) = i < size x ==> +prop_view_current (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> hunk ./tests/Properties.hs 198 -prop_view_local (x :: T) (n :: NonNegative Int) = i < size x ==> +prop_view_local (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> hunk ./tests/Properties.hs 207 --- prop_view_xinerama (x :: T) (n :: NonNegative Int) = i < size x ==> +-- prop_view_xinerama (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> hunk ./tests/Properties.hs 213 -prop_view_idem (x :: T) r = - let i = fromIntegral $ r `mod` sz - sz = size x - in view i (view i x) == (view i x) +prop_view_idem (x :: T) (i :: NonNegative Int) = i `tagMember` x ==> view i (view i x) == (view i x) hunk ./tests/Properties.hs 216 -prop_view_reversible r (x :: T) = normal (view n (view i x)) == normal x +prop_view_reversible (i :: NonNegative Int) (x :: T) = + i `tagMember` x ==> normal (view n (view i x)) == normal x hunk ./tests/Properties.hs 219 - sz = size x - i = fromIntegral $ r `mod` sz hunk ./tests/Properties.hs 323 -prop_insert_empty i (n :: Positive Int) (m :: Positive Int) = member i (insertUp i x) - where x = new (fromIntegral n) (fromIntegral m) :: T +prop_insert_empty i (NonEmptyNubList ns) (m :: Positive Int) = member i (insertUp i x) + where x = new ns (fromIntegral m) :: T hunk ./tests/Properties.hs 337 -prop_insert_peek (n :: Positive Int) (m :: Positive Int) (NonEmptyNubList is) = +prop_insert_peek (NonEmptyNubList ns) (m :: Positive Int) (NonEmptyNubList is) = hunk ./tests/Properties.hs 339 - where - x = new (fromIntegral n) (fromIntegral m) :: T + where x = new ns (fromIntegral m) :: T hunk ./tests/Properties.hs 350 -prop_size_insert is (n :: Positive Int) (m :: Positive Int) = +prop_size_insert is (NonEmptyNubList ns) (m :: Positive Int) = hunk ./tests/Properties.hs 354 - x = new (fromIntegral n) (fromIntegral m) :: T + x = new ns (fromIntegral m) :: T hunk ./tests/Properties.hs 431 -prop_shift_reversible (r :: Int) (x :: T) = - let i = fromIntegral $ r `mod` sz - sz = size y - n = tag (workspace $ current y) - in case peek y of - Nothing -> True - Just _ -> normal ((view n . shift n . view i . shift i) y) == normal y +prop_shift_reversible i (x :: T) = + i `tagMember` x ==> case peek y of + Nothing -> True + Just _ -> normal ((view n . shift n . view i . shift i) y) == normal y hunk ./tests/Properties.hs 437 + n = tag (workspace $ current y) hunk ./tests/Properties.hs 691 - hunk ./Operations.hs 1 -{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fno-warn-orphans -fglasgow-exts #-} hunk ./Operations.hs 169 - maybe [] (\s@(W.Stack f _ _) -> f : delete f (W.integrate s)) tiled) + maybe [] (\s@(W.Stack foc _ _) -> foc : delete foc (W.integrate s)) tiled) hunk ./StackSet.hs 18 - new, view, + new, view, hunk ./StackSet.hs 108 -import Prelude hiding (filter) -import Data.Maybe (listToMaybe) -import qualified Data.List as L (delete,find,genericSplitAt,filter) -import qualified Data.Map as M (Map,insert,delete,empty) - hunk ./README 80 - exec /home/dons/bin/xmonad + /home/dons/bin/xmonad hunk ./man/xmonad.1.in 43 -exec xmonad +xmonad hunk ./Operations.hs 58 + sh <- io $ getWMNormalHints d w + let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh hunk ./Operations.hs 61 - if isTransient + if isFixedSize || isTransient hunk ./Config.hs 87 -defaultLayouts :: [Layout] +defaultLayouts :: [Layout Window] hunk ./Operations.hs 371 -full :: Layout +full :: Layout a hunk ./Operations.hs 378 -tall :: Int -> Rational -> Rational -> Layout +tall :: Int -> Rational -> Rational -> Layout a hunk ./Operations.hs 393 -mirror :: Layout -> Layout +mirror :: Layout a -> Layout a hunk ./XMonad.hs 46 - , layouts :: !(M.Map WorkspaceId (Layout, [Layout])) } + , layouts :: !(M.Map WorkspaceId (Layout Window, [Layout Window])) } hunk ./XMonad.hs 122 -data Layout = Layout { doLayout :: Rectangle -> Stack Window -> X [(Window, Rectangle)] - , modifyLayout :: SomeMessage -> X (Maybe Layout) } +data Layout a = Layout { doLayout :: Rectangle -> Stack a -> X [(a, Rectangle)] + , modifyLayout :: SomeMessage -> X (Maybe (Layout a)) } hunk ./XMonad.hs 125 -runLayout :: Layout -> Rectangle -> StackOrNot Window -> X [(Window, Rectangle)] +runLayout :: Layout a -> Rectangle -> StackOrNot a -> X [(a, Rectangle)] hunk ./README 47 - (Included with GHC) - hunk ./README 48 - (Included with GHC) - hunk ./README 49 - (Included with GHC) - hunk ./Operations.hs 170 - io $ restackWindows d (flt ++ - maybe [] (\s@(W.Stack foc _ _) -> foc : delete foc (W.integrate s)) tiled) - + let vs = flt ++ map fst rs + io $ restackWindows d vs hunk ./Operations.hs 173 - return (map fst rs ++ flt) + return vs hunk ./Operations.hs 24 -import Data.List (delete, genericIndex, nub, (\\)) +import Data.List (genericIndex, nub, (\\)) hunk ./XMonad.hs 119 --- 'doLayout', a pure function to layout a Window set 'modifyLayout', --- 'modifyLayout' can be considered a branch of an exception handler. +-- 'doLayout': given a Rectangle and a Stack, layout the stack elements +-- inside the given Rectangle. If an element is not given a Rectangle +-- by 'doLayout', then it is not shown on screen. Windows are restacked +-- according to the order they are returned by 'doLayout'. +-- +-- 'modifyLayout' performs message handling for that layout. If +-- 'modifyLayout' returns Nothing, then the layout did not respond to +-- that message and the screen is not refreshed. Otherwise, 'modifyLayout' +-- returns an updated 'Layout' and the screen is refreshed. hunk ./Operations.hs 502 -mouseMoveWindow w = withDisplay $ \d -> do +mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do hunk ./Operations.hs 512 -mouseResizeWindow w = withDisplay $ \d -> do +mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do hunk ./Operations.hs 102 - let n = fromIntegral $ W.screen (W.current ws) + let n = fromIntegral . W.screen $ W.current ws hunk ./XMonad.hs 185 - prog <- maybe (io $ getProgName) return mprog + prog <- maybe (io getProgName) return mprog hunk ./StackSet.hs 306 -filter p (Stack f ls rs) = case L.filter p (f:rs) of - (f':rs') -> Just $ Stack f' (L.filter p ls) rs' - [] -> do f':rs' <- return $ reverse $ L.filter p ls - Just $ Stack f' [] rs' +filter p (Stack f ls rs) = Just $ case L.filter p (f:rs) of + (f':rs') -> Stack f' (L.filter p ls) rs' + _ -> Stack f' [] rs' + where (f':rs') = reverse (L.filter p ls) hunk ./StackSet.hs 305 +-- +-- Note, this isn't the same as the 'remove' semantics, as focus +-- won't move 'left' on the end of list. +-- hunk ./StackSet.hs 310 -filter p (Stack f ls rs) = Just $ case L.filter p (f:rs) of - (f':rs') -> Stack f' (L.filter p ls) rs' - _ -> Stack f' [] rs' - where (f':rs') = reverse (L.filter p ls) +filter p (Stack f ls rs) = case L.filter p (f:rs) of + f':rs' -> Just $ Stack f' (L.filter p ls) rs' -- maybe move focus down + [] -> case L.filter p (reverse ls) of -- filter back up + f':rs' -> Just $ Stack f' [] rs' -- else up + [] -> Nothing hunk ./tests/Properties.hs 379 -prop_delete_local (x :: T) = +prop_delete_local (x :: T) = hunk ./tests/Properties.hs 387 +-- focus movement in the presence of delete: +-- when the last window in the stack set is focused, focus moves `up'. +-- usual case is that it moves 'down'. +prop_delete_focus_end (x :: T) = + length (index x) > 1 + ==> + peek (delete n y) == peek (focusUp y) + where + n = last (index x) + y = focusWindow n x -- focus last window in stack + +-- focus movement in the presence of delete: +-- when not in the last item in the stack, focus moves down +prop_delete_focus_not_end (x :: T) = + length (index x) > 1 && + n /= last (index x) + ==> + peek (delete n x) == peek (focusDown x) + where + Just n = peek x + hunk ./tests/Properties.hs 552 + ,("delete last/focus up", mytest prop_delete_focus_end) + ,("delete ~last/focus down", mytest prop_delete_focus_not_end) hunk ./Main.hs 229 -handle e = sendMessage e -- trace (eventName e) -- ignoring +handle e = broadcastMessage e -- trace (eventName e) -- ignoring hunk ./StackSet.hs 291 +-- | +-- /O(n)/ Flatten a possibly empty stack into a list. hunk ./Operations.hs 32 -import Control.Arrow ((***), second) +import Control.Arrow ((***), first, second) hunk ./Operations.hs 159 - rs <- runLayout l viewrect tiled `catchX` runLayout full viewrect tiled + (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout full viewrect tiled hunk ./Operations.hs 161 + whenJust ml' $ \l' -> modify $ \ss -> + ss { layouts = M.adjust (first (const l')) n (layouts ss) } hunk ./Operations.hs 373 -full = Layout { doLayout = \sc (W.Stack f _ _) -> return [(f, sc)] +full = Layout { doLayout = \sc (W.Stack f _ _) -> return ([(f, sc)],Nothing) hunk ./Operations.hs 381 - Layout { doLayout = \r -> return . ap zip (tile frac r nmaster . length) . W.integrate + Layout { doLayout = \r -> return . (\x->(x,Nothing)) . + ap zip (tile frac r nmaster . length) . W.integrate hunk ./Operations.hs 397 - Layout { doLayout = \sc w -> map (second mirrorRect) `fmap` dl (mirrorRect sc) w + Layout { doLayout = \sc w -> do (wrs, ml') <- dl (mirrorRect sc) w + return (map (second mirrorRect) wrs, mirror `fmap` ml') hunk ./XMonad.hs 129 -data Layout a = Layout { doLayout :: Rectangle -> Stack a -> X [(a, Rectangle)] +data Layout a = Layout { doLayout :: Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Layout a)) hunk ./XMonad.hs 132 -runLayout :: Layout a -> Rectangle -> StackOrNot a -> X [(a, Rectangle)] -runLayout l r = maybe (return []) (doLayout l r) +runLayout :: Layout a -> Rectangle -> StackOrNot a -> X ([(a, Rectangle)], Maybe (Layout a)) +runLayout l r = maybe (return ([], Nothing)) (doLayout l r) hunk ./Operations.hs 24 -import Data.List (genericIndex, nub, (\\)) +import Data.List (genericIndex, nub, (\\), findIndex) hunk ./Operations.hs 479 - xinesc <- gets xineScreens - sc <- (genericIndex xinesc . W.screen . W.current) `liftM` gets windowset - wa <- io $ getWindowAttributes d w - let bw = fi . wa_border_width $ wa - windows $ W.float w + XState { xineScreens = xinesc, windowset = ws } <- get + wa <- io $ getWindowAttributes d w + + let sid = fromMaybe (W.screen . W.current $ ws) (fmap fi $ findIndex (pointWithin (fi (wa_x wa)) (fi (wa_y wa))) xinesc) + sc = genericIndex xinesc sid + bw = fi . wa_border_width $ wa + + wid <- screenWorkspace sid + + windows $ W.shift wid . W.focusWindow w . W.float w hunk ./Operations.hs 494 + pointWithin :: Integer -> Integer -> Rectangle -> Bool + pointWithin x y r = x >= fi (rect_x r) && + x < fi (rect_x r) + fi (rect_width r) && + y >= fi (rect_y r) && + y < fi (rect_y r) + fi (rect_height r) hunk ./Main.hs 55 - | otherwise = new [0..fromIntegral workspaces-1] (fromIntegral $ length xinesc) + | otherwise = new [0..fromIntegral workspaces-1] $ zipWith SD xinesc gaps + gaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0) hunk ./Main.hs 67 - , statusGaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0) - , xineScreens = xinesc hunk ./Operations.hs 24 -import Data.List (genericIndex, nub, (\\), findIndex) +import Data.List (nub, (\\), find) hunk ./Operations.hs 101 - XState { windowset = ws, statusGaps = gaps } <- get - let n = fromIntegral . W.screen $ W.current ws - (a,i:b) = splitAt n gaps - modify $ \s -> s { statusGaps = a ++ f n i : b } - refresh + windows $ \ws@(W.StackSet { W.current = c@(W.Screen { W.screenDetail = sd }) }) -> + let n = fromIntegral . W.screen $ c + g = f n . statusGap $ sd + in ws { W.current = c { W.screenDetail = sd { statusGap = g } } } hunk ./Operations.hs 137 - XState { windowset = old, layouts = fls, xineScreens = xinesc, statusGaps = gaps } <- get + XState { windowset = old, layouts = fls } <- get hunk ./Operations.hs 151 - (Rectangle sx sy sw sh) = genericIndex xinesc (W.screen w) - (gt,gb,gl,gr) = genericIndex gaps (W.screen w) + (SD (Rectangle sx sy sw sh) + (gt,gb,gl,gr)) = W.screenDetail w hunk ./Operations.hs 259 - modify (\s -> s { xineScreens = xinesc - , statusGaps = take (length xinesc) $ (statusGaps s) ++ repeat (0,0,0,0) }) - hunk ./Operations.hs 260 - let (x:xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs - in ws { W.current = W.Screen x 0 - , W.visible = zipWith W.Screen xs [1 ..] + let (xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs + (a:as) = zipWith3 W.Screen xs [1..] $ zipWith SD xinesc gs + sgs = map (statusGap . W.screenDetail) (v:vs) + gs = take (length xinesc) (sgs ++ repeat (0,0,0,0)) + in ws { W.current = a + , W.visible = as hunk ./Operations.hs 478 - XState { xineScreens = xinesc, windowset = ws } <- get + ws <- gets windowset hunk ./Operations.hs 481 - let sid = fromMaybe (W.screen . W.current $ ws) (fmap fi $ findIndex (pointWithin (fi (wa_x wa)) (fi (wa_y wa))) xinesc) - sc = genericIndex xinesc sid + let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.current ws : W.visible ws + sr = screenRect . W.screenDetail $ sc + sw = W.tag . W.workspace $ sc hunk ./Operations.hs 486 - wid <- screenWorkspace sid - - windows $ W.shift wid . W.focusWindow w . W.float w - (W.RationalRect ((fi (wa_x wa) - fi (rect_x sc)) % fi (rect_width sc)) - ((fi (wa_y wa) - fi (rect_y sc)) % fi (rect_height sc)) - (fi (wa_width wa + bw*2) % fi (rect_width sc)) - (fi (wa_height wa + bw*2) % fi (rect_height sc))) + windows $ W.shift sw . W.focusWindow w . W.float w + (W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) + ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) + (fi (wa_width wa + bw*2) % fi (rect_width sr)) + (fi (wa_height wa + bw*2) % fi (rect_height sr))) hunk ./StackSet.hs 40 -import qualified Data.List as L (delete,find,genericSplitAt,filter) +import qualified Data.List as L (delete,deleteBy,find,splitAt,filter) hunk ./StackSet.hs 149 -data StackSet i a sid = - StackSet { current :: !(Screen i a sid) -- ^ currently focused workspace - , visible :: [Screen i a sid] -- ^ non-focused workspaces, visible in xinerama +data StackSet i a sid sd = + StackSet { current :: !(Screen i a sid sd) -- ^ currently focused workspace + , visible :: [Screen i a sid sd] -- ^ non-focused workspaces, visible in xinerama hunk ./StackSet.hs 157 -data Screen i a sid = Screen { workspace :: !(Workspace i a), screen :: !sid } +data Screen i a sid sd = Screen { workspace :: !(Workspace i a) + , screen :: !sid + , screenDetail :: !sd } hunk ./StackSet.hs 210 -new :: Integral s => [i] -> s -> StackSet i a s -new (wid:wids) m | m > 0 = StackSet cur visi unseen M.empty - where (seen,unseen) = L.genericSplitAt m $ Workspace wid Nothing : [ Workspace i Nothing | i <- wids] - (cur:visi) = [ Screen i s | (i,s) <- zip seen [0..] ] +new :: (Integral s) => [i] -> [sd] -> StackSet i a s sd +new wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty + where (seen,unseen) = L.splitAt (length m) $ map (flip Workspace Nothing) wids + (cur:visi) = [ Screen i s sd | (i, s, sd) <- zip3 seen [0..] m ] hunk ./StackSet.hs 227 -view :: (Eq a, Eq s, Eq i) => i -> StackSet i a s -> StackSet i a s +view :: (Eq a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 234 - = s { current = x, visible = current s : L.delete x (visible s) } + = s { current = x, visible = current s : L.deleteBy screenEq x (visible s) } hunk ./StackSet.hs 238 - = s { current = Screen x (screen (current s)) + = s { current = (current s) { workspace = x } hunk ./StackSet.hs 242 + where screenEq x y = screen x == screen y hunk ./StackSet.hs 252 -lookupWorkspace :: Eq s => s -> StackSet i a s -> Maybe i -lookupWorkspace sc w = listToMaybe [ tag i | Screen i s <- current w : visible w, s == sc ] +lookupWorkspace :: Eq s => s -> StackSet i a s sd -> Maybe i +lookupWorkspace sc w = listToMaybe [ tag i | Screen i s _ <- current w : visible w, s == sc ] hunk ./StackSet.hs 264 -with :: b -> (Stack a -> b) -> StackSet i a s -> b +with :: b -> (Stack a -> b) -> StackSet i a s sd -> b hunk ./StackSet.hs 270 -modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i a s -> StackSet i a s +modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 278 -modify' :: (Stack a -> Stack a) -> StackSet i a s -> StackSet i a s +modify' :: (Stack a -> Stack a) -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 285 -peek :: StackSet i a s -> Maybe a +peek :: StackSet i a s sd -> Maybe a hunk ./StackSet.hs 327 -index :: Eq a => StackSet i a s -> [a] +index :: Eq a => StackSet i a s sd -> [a] hunk ./StackSet.hs 344 -focusUp, focusDown, swapUp, swapDown :: StackSet i a s -> StackSet i a s +focusUp, focusDown, swapUp, swapDown :: StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 366 -focusWindow :: (Integral i, Eq s, Eq a) => a -> StackSet i a s -> StackSet i a s +focusWindow :: (Integral i, Eq s, Eq a) => a -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 375 -workspaces :: StackSet i a s -> [Workspace i a] +workspaces :: StackSet i a s sd -> [Workspace i a] hunk ./StackSet.hs 379 -tagMember :: Eq i => i -> StackSet i a s -> Bool +tagMember :: Eq i => i -> StackSet i a s sd -> Bool hunk ./StackSet.hs 388 -member :: Eq a => a -> StackSet i a s -> Bool +member :: Eq a => a -> StackSet i a s sd -> Bool hunk ./StackSet.hs 394 -findIndex :: Eq a => a -> StackSet i a s -> Maybe i +findIndex :: Eq a => a -> StackSet i a s sd -> Maybe i hunk ./StackSet.hs 417 -insertUp :: Eq a => a -> StackSet i a s -> StackSet i a s +insertUp :: Eq a => a -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 421 --- insertDown :: a -> StackSet i a s -> StackSet i a s +-- insertDown :: a -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 440 -delete :: (Integral i, Ord a, Eq s) => a -> StackSet i a s -> StackSet i a s +delete :: (Integral i, Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 460 -float :: Ord a => a -> RationalRect -> StackSet i a s -> StackSet i a s +float :: Ord a => a -> RationalRect -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 464 -sink :: Ord a => a -> StackSet i a s -> StackSet i a s +sink :: Ord a => a -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 473 -swapMaster :: StackSet i a s -> StackSet i a s +swapMaster :: StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 489 -shift :: (Ord a, Eq s, Integral i) => i -> StackSet i a s -> StackSet i a s +shift :: (Ord a, Eq s, Integral i) => i -> StackSet i a s sd -> StackSet i a s sd hunk ./XMonad.hs 18 - X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), XConf(..), Layout(..), + X, WindowSet, WorkspaceId(..), ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), hunk ./XMonad.hs 33 +-- for Read instance +import Graphics.X11.Xlib.Extras () hunk ./XMonad.hs 44 - , xineScreens :: ![Rectangle] -- ^ dimensions of each screen - , statusGaps :: ![(Int,Int,Int,Int)] -- ^ width of status bar on each screen hunk ./XMonad.hs 54 -type WindowSet = StackSet WorkspaceId Window ScreenId +type WindowSet = StackSet WorkspaceId Window ScreenId ScreenDetail hunk ./XMonad.hs 62 +data ScreenDetail = SD { screenRect :: !Rectangle + , statusGap :: !(Int,Int,Int,Int) -- ^ width of status bar on the screen + } deriving (Eq,Show, Read) + hunk ./tests/Properties.hs 36 -instance (Integral i, Integral s, Eq a, Arbitrary a) => Arbitrary (StackSet i a s) where +instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary sd) + => Arbitrary (StackSet i a s sd) where hunk ./tests/Properties.hs 41 - sc <- choose (1,sz) -- a number of physical screens + sc <- choose (1,sz) -- a number of physical screens + sds <- replicateM sc arbitrary hunk ./tests/Properties.hs 50 - return $ fromList (fromIntegral n, fromIntegral sc,fs,ls) + return $ fromList (fromIntegral n, sds,fs,ls) hunk ./tests/Properties.hs 64 -fromList :: (Integral i, Integral s, Eq a) => (i, s, [Maybe Int], [[a]]) -> StackSet i a s +fromList :: (Integral i, Integral s, Eq a) => (i, [sd], [Maybe Int], [[a]]) -> StackSet i a s sd hunk ./tests/Properties.hs 67 -fromList (n,m,fs,xs) | n < 0 || n >= genericLength xs - = error $ "Cursor index is out of range: " ++ show (n, length xs) - | m < 1 || m > genericLength xs - = error $ "Can't have more screens than workspaces: " ++ show (m, length xs) - hunk ./tests/Properties.hs 81 -type T = StackSet (NonNegative Int) Char Int +type T = StackSet (NonNegative Int) Char Int Int hunk ./tests/Properties.hs 131 -prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m -> - invariant $ new [0..fromIntegral n-1] m +prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m -> + forAll (vector m) $ \ms -> + invariant $ new [0..fromIntegral n-1] ms hunk ./tests/Properties.hs 171 -prop_empty (NonEmptyNubList ns) (m :: Positive Int) = - all (== Nothing) [ stack w | w <- workspace (current x) +prop_empty (EmptyStackSet x) = + all (== Nothing) [ stack w | w <- workspace (current x) hunk ./tests/Properties.hs 175 - where x = new ns (fromIntegral m) :: T - hunk ./tests/Properties.hs 176 -prop_empty_current (NonEmptyNubList ns) (m :: Positive Int) = tag (workspace $ current x) == head ns - where x = new ns (fromIntegral m) :: T +prop_empty_current (NonEmptyNubList ns) (NonEmptyNubList sds) = + -- TODO, this is ugly + length sds <= length ns ==> + tag (workspace $ current x) == head ns + where x = new ns sds :: T hunk ./tests/Properties.hs 183 -prop_member_empty i (NonEmptyNubList ns) (m :: Positive Int) - = member i (new ns (fromIntegral m) :: T) == False +prop_member_empty i (EmptyStackSet x) + = member i x == False hunk ./tests/Properties.hs 322 -prop_insert_empty i (NonEmptyNubList ns) (m :: Positive Int) = member i (insertUp i x) - where x = new ns (fromIntegral m) :: T +prop_insert_empty i (EmptyStackSet x)= member i (insertUp i x) hunk ./tests/Properties.hs 335 -prop_insert_peek (NonEmptyNubList ns) (m :: Positive Int) (NonEmptyNubList is) = +prop_insert_peek (EmptyStackSet x) (NonEmptyNubList is) = hunk ./tests/Properties.hs 337 - where x = new ns (fromIntegral m) :: T hunk ./tests/Properties.hs 347 -prop_size_insert is (NonEmptyNubList ns) (m :: Positive Int) = +prop_size_insert is (EmptyStackSet x) = hunk ./tests/Properties.hs 351 - x = new ns (fromIntegral m) :: T hunk ./tests/Properties.hs 730 +newtype EmptyStackSet = EmptyStackSet T deriving Show + +instance Arbitrary EmptyStackSet where + arbitrary = do + (NonEmptyNubList ns) <- arbitrary + (NonEmptyNubList sds) <- arbitrary + -- there cannot be more screens than workspaces: + return . EmptyStackSet . new ns $ take (min (length ns) (length sds)) sds + hunk ./Main.hs 116 + a <- internAtom dpy "WM_STATE" False + p <- getWindowProperty32 dpy a w + let ic = case p of + Just (3:_) -> True -- 3 for iconified + _ -> False hunk ./Main.hs 122 - && wa_map_state wa == waIsViewable + && (wa_map_state wa == waIsViewable || ic) hunk ./Operations.hs 51 -manage w = withDisplay $ \d -> do +manage w = whenX (fmap not $ isClient w) $ withDisplay $ \d -> do hunk ./Main.hs 96 - logHook + refresh hunk ./Main.hs 32 -import StackSet (new, floating, member) +import StackSet (new, floating, member, findIndex, workspace, tag, current, visible) hunk ./Main.hs 212 - if M.member w (floating ws) || not (member w ws) + -- TODO temporary workaround for some bugs in float. Don't call 'float' on + -- windows that aren't visible, because it changes the focused screen + let vis = any ((== findIndex w ws) . Just . tag . workspace) (current ws : visible ws) + if (M.member w (floating ws) && vis) + || not (member w ws) hunk ./Operations.hs 476 +-- +-- TODO: float changes the set of visible workspaces when we call it for an +-- invisible window -- this should not happen. See 'temporary workaround' in +-- the handler for ConfigureRequestEvent also. hunk ./Operations.hs 261 - (a:as) = zipWith3 W.Screen xs [1..] $ zipWith SD xinesc gs + (a:as) = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs hunk ./Config.hs 166 - [((m .|. modMask, key), screenWorkspace sc >>= f) + [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust f) hunk ./Operations.hs 442 --- | Return workspace visible on screen 'sc', or 0. -screenWorkspace :: ScreenId -> X WorkspaceId -screenWorkspace sc = withWindowSet $ return . fromMaybe 0 . W.lookupWorkspace sc +-- | Return workspace visible on screen 'sc', or Nothing. +screenWorkspace :: ScreenId -> X (Maybe WorkspaceId) +screenWorkspace sc = withWindowSet $ return . W.lookupWorkspace sc hunk ./Operations.hs 490 - windows $ W.shift sw . W.focusWindow w . W.float w + windows $ maybe id W.focusWindow (W.peek ws) . W.shift sw . W.focusWindow w . W.float w hunk ./Config.hs 121 - , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && exec $exe") -- @@ Launch dmenu + , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- @@ Launch dmenu hunk ./README 53 - runhaskell Setup.lhs configure --prefix=/home/dons + runhaskell Setup.lhs configure --prefix=$HOME hunk ./README 74 - /home/dons/bin/xmonad + $HOME/bin/xmonad hunk ./StackSet.hs 490 -shift n s = if and [n >= 0,n `tagMember` s, n /= tag (workspace (current s))] - then maybe s go (peek s) else s - where go w = foldr ($) s [view (tag (workspace (current s))),insertUp w,view n,delete w] - -- ^^ poor man's state monad :-) +shift n s = if n >= 0 && n `tagMember` s && n /= curtag + then maybe s go (peek s) else s + where go w = view curtag . insertUp w . view n . delete w $ s + curtag = tag (workspace (current s)) hunk ./StackSet.hs 490 -shift n s = if n >= 0 && n `tagMember` s && n /= curtag +shift n s = if n `tagMember` s && n /= curtag hunk ./StackSet.hs 308 --- True. Order is preserved, and focus moves to the next node to the right (if --- necessary). --- --- Note, this isn't the same as the 'remove' semantics, as focus --- won't move 'left' on the end of list. +-- True. Order is preserved, and focus moves as described for 'delete'. hunk ./StackSet.hs 313 - [] -> case L.filter p (reverse ls) of -- filter back up - f':rs' -> Just $ Stack f' [] rs' -- else up + [] -> case L.filter p ls of -- filter back up + f':rs' -> Just $ Stack f' [] (reverse rs') -- else up hunk ./StackSet.hs 436 -delete :: (Integral i, Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd -delete w s | Just w == peek s = remove s -- common case. - | otherwise = maybe s (removeWindow.tag.workspace.current $ s) (findIndex w s) - where - -- find and remove window script - removeWindow o n = foldr ($) s [view o,remove,view n] - - -- actual removal logic, and focus/master logic: - remove = modify Nothing $ \c -> - if focus c == w - then case c of - Stack _ ls (r:rs) -> Just $ Stack r ls rs -- try down first - Stack _ (l:ls) [] -> Just $ Stack l ls [] -- else up - Stack _ [] [] -> Nothing - else Just $ c { up = w `L.delete` up c, down = w `L.delete` down c } +delete :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd +delete w s = s { current = removeFromScreen (current s) + , visible = map removeFromScreen (visible s) + , hidden = map removeFromWorkspace (hidden s) } + where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) } + removeFromScreen scr = scr { workspace = removeFromWorkspace (workspace scr) } hunk ./StackSet.hs 362 -focusWindow :: (Integral i, Eq s, Eq a) => a -> StackSet i a s sd -> StackSet i a s sd +focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 476 -shift :: (Ord a, Eq s, Integral i) => i -> StackSet i a s sd -> StackSet i a s sd +shift :: (Ord a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 477 -shift n s = if n `tagMember` s && n /= curtag - then maybe s go (peek s) else s +shift n s | n `tagMember` s && n /= curtag = maybe s go (peek s) + | otherwise = s hunk ./StackSet.hs 314 - f':rs' -> Just $ Stack f' [] (reverse rs') -- else up + f':ls' -> Just $ Stack f' ls' [] -- else up hunk ./tests/Properties.hs 4 +import qualified StackSet as S (filter) hunk ./tests/Properties.hs 405 +-- --------------------------------------------------------------------- +-- filter + +-- preserve order +prop_filter_order (x :: T) = + case stack $ workspace $ current x of + Nothing -> True + Just s@(Stack i _ _) -> integrate' (S.filter (/= i) s) == filter (/= i) (integrate' (Just s)) + hunk ./tests/Properties.hs 561 + ,("filter preserves order", mytest prop_filter_order) + hunk ./Config.hs-boot 8 +workspaces :: Int hunk ./StackSet.hs 398 - + hunk ./StackSet.hs 456 - + hunk ./StackSet.hs 323 -index :: Eq a => StackSet i a s sd -> [a] +index :: StackSet i a s sd -> [a] hunk ./Operations.hs 95 -view = windows . W.view +view = windows . W.greedyView hunk ./StackSet.hs 18 - new, view, + new, view, greedyView, hunk ./StackSet.hs 247 +-- | +-- Set focus to the given workspace. If that workspace does not exist +-- in the stackset, the original workspace is returned. If that workspace is +-- 'hidden', then display that workspace on the current screen, and move the +-- current workspace to 'hidden'. If that workspace is 'visible' on another +-- screen, the workspaces of the current screen and the other screen are +-- swapped. + +greedyView :: (Eq a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +greedyView w ws + | any wTag (hidden ws) = view w ws + | (Just s) <- L.find (wTag . workspace) (visible ws) + = ws { current = (current ws) { workspace = workspace s } + , visible = s { workspace = workspace (current ws) } + : L.filter (not . wTag . workspace) (visible ws) } + | otherwise = ws + where + wTag = (w == ) . tag + hunk ./tests/Properties.hs 139 +prop_greedyView_I (n :: NonNegative Int) (x :: T) = + n `tagMember` x ==> invariant $ view (fromIntegral n) x + hunk ./tests/Properties.hs 223 +-- --------------------------------------------------------------------- +-- greedyViewing workspaces + +-- greedyView sets the current workspace to 'n' +prop_greedyView_current (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> + tag (workspace $ current (greedyView i x)) == i + where + i = fromIntegral n + +-- greedyView *only* sets the current workspace, and touches Xinerama. +-- no workspace contents will be changed. +prop_greedyView_local (x :: T) (n :: NonNegative Int) = i `tagMember` x ==> + workspaces x == workspaces (greedyView i x) + where + workspaces a = sortBy (\s t -> tag s `compare` tag t) $ + workspace (current a) + : map workspace (visible a) ++ hidden a + i = fromIntegral n + +-- greedyView is idempotent +prop_greedyView_idem (x :: T) (i :: NonNegative Int) = i `tagMember` x ==> greedyView i (greedyView i x) == (greedyView i x) + +-- greedyView is reversible, though shuffles the order of hidden/visible +prop_greedyView_reversible (i :: NonNegative Int) (x :: T) = + i `tagMember` x ==> normal (greedyView n (greedyView i x)) == normal x + where n = tag (workspace $ current x) + hunk ./tests/Properties.hs 551 + ,("greedyView : invariant" , mytest prop_greedyView_I) + ,("greedyView sets current" , mytest prop_greedyView_current) + ,("greedyView idempotent" , mytest prop_greedyView_idem) + ,("greedyView reversible" , mytest prop_greedyView_reversible) + ,("greedyView is local" , mytest prop_greedyView_local) +-- hunk ./Operations.hs 144 - visible <- fmap concat $ forM (W.current ws : W.visible ws) $ \w -> do + let allscreens = W.current ws : W.visible ws + each_visible = map (W.integrate' . W.stack . W.workspace) allscreens + summed_visible = reverse $ foldl (\ (x:xs) y -> ((x++y):x:xs)) [[]] each_visible + visible <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do hunk ./Operations.hs 154 + >>= W.filter (not . (`elem` vis)) hunk ./Main.hs 68 - , waitingUnmap = M.empty } + , waitingUnmap = M.empty + , dragging = Nothing } hunk ./Main.hs 187 +-- handle button release, which may finish dragging. +handle e@(ButtonEvent {ev_event_type = t}) + | t == buttonRelease = do + drag <- gets dragging + case drag of + Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f + -- we're done dragging and have released the mouse + Nothing -> broadcastMessage e + +-- handle motionNotify event, which may mean we are dragging. +handle e@(MotionEvent {ev_event_type = t, ev_x = x, ev_y = y}) = do + drag <- gets dragging + case drag of + Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging + Nothing -> broadcastMessage e + hunk ./Operations.hs 510 -mouseDrag :: (XMotionEvent -> IO ()) -> X () -mouseDrag f = do - XConf { theRoot = root, display = d } <- ask - io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) - grabModeAsync grabModeAsync none none currentTime - io $ allocaXEvent $ \p -> fix $ \again -> do -- event loop - maskEvent d (buttonReleaseMask .|. pointerMotionMask) p - et <- get_EventType p - when (et == motionNotify) $ get_MotionEvent p >>= f >> again - io $ ungrabPointer d currentTime +mouseDrag :: (Position -> Position -> X ()) -> X () -> X () +mouseDrag f done = do + drag <- gets dragging + case drag of + Just _ -> return () -- error case? we're already dragging + Nothing -> do XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) + grabModeAsync grabModeAsync none none currentTime + let cleanup = do io $ ungrabPointer d currentTime + modify $ \s -> s { dragging = Nothing } + done + modify $ \s -> s { dragging = Just (f, cleanup) } hunk ./Operations.hs 527 - (_, _, _, ox, oy, _, _, _) <- io $ queryPointer d w - mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> - moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) - (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))) - float w + (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w + let ox = fromIntegral ox' + oy = fromIntegral oy' + mouseDrag (\ex ey -> do + io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) + (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) + (float w) hunk ./Operations.hs 541 - mouseDrag $ \(_, _, _, ex, ey, _, _, _, _, _) -> - resizeWindow d w `uncurry` - applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))), - (fromIntegral (max 1 (ey - fromIntegral (wa_y wa))))) - float w + mouseDrag (\ex ey -> do + io $ resizeWindow d w `uncurry` + applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))), + (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))))) + (float w) hunk ./XMonad.hs 46 - , layouts :: !(M.Map WorkspaceId (Layout Window, [Layout Window])) } + , layouts :: !(M.Map WorkspaceId (Layout Window, [Layout Window])) + , dragging :: !(Maybe (Position -> Position -> X (), X ())) } hunk ./Main.hs 192 - Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f - -- we're done dragging and have released the mouse - Nothing -> broadcastMessage e + -- we're done dragging and have released the mouse: + Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f + Nothing -> broadcastMessage e hunk ./Main.hs 200 - Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging - Nothing -> broadcastMessage e + Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging + Nothing -> broadcastMessage e hunk ./Operations.hs 514 - Just _ -> return () -- error case? we're already dragging - Nothing -> do XConf { theRoot = root, display = d } <- ask - io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) - grabModeAsync grabModeAsync none none currentTime - let cleanup = do io $ ungrabPointer d currentTime - modify $ \s -> s { dragging = Nothing } - done - modify $ \s -> s { dragging = Just (f, cleanup) } + Just _ -> return () -- error case? we're already dragging + Nothing -> do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) + grabModeAsync grabModeAsync none none currentTime + modify $ \s -> s { dragging = Just (f, cleanup) } + where + cleanup = do + withDisplay $ io . flip ungrabPointer currentTime + modify $ \s -> s { dragging = Nothing } + done hunk ./Operations.hs 144 - let allscreens = W.current ws : W.visible ws - each_visible = map (W.integrate' . W.stack . W.workspace) allscreens - summed_visible = reverse $ foldl (\ (x:xs) y -> ((x++y):x:xs)) [[]] each_visible + let allscreens = W.current ws : W.visible ws + summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.workspace) allscreens hunk ./Config.hs 34 -workspaces :: Int -workspaces = 9 +workspaces :: [WorkspaceId] +workspaces = [0..8] hunk ./Config.hs 160 - | (i, k) <- zip [0 .. fromIntegral workspaces - 1] [xK_1 ..] + | (i, k) <- zip workspaces [xK_1 ..] hunk ./Config.hs-boot 8 -workspaces :: Int +workspaces :: [WorkspaceId] hunk ./Main.hs 55 - | otherwise = new [0..fromIntegral workspaces-1] $ zipWith SD xinesc gaps + | otherwise = new workspaces $ zipWith SD xinesc gaps hunk ./Main.hs 66 - , layouts = M.fromList [(w, safeLayouts) | w <- [0 .. W workspaces - 1]] + , layouts = M.fromList [(w, safeLayouts) | w <- workspaces] hunk ./StackSet.hs 229 - | not (elem i $ map tag $ workspaces s) + | not (i `tagMember` s) hunk ./XMonad.hs 47 - , dragging :: !(Maybe (Position -> Position -> X (), X ())) } hunk ./XMonad.hs 48 + , dragging :: !(Maybe (Position -> Position -> X (), X ())) } hunk ./Main.hs 197 -handle e@(MotionEvent {ev_event_type = t, ev_x = x, ev_y = y}) = do +handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do hunk ./Config.hs 25 +import qualified StackSet as W hunk ./Config.hs 169 - , (f, m) <- [(view, 0), (shift, shiftMask)]] + , (f, m) <- [(windows . W.view, 0), (shift, shiftMask)]] hunk ./Operations.hs 434 -splitHorizontallyBy, splitVerticallyBy :: Rational -> Rectangle -> (Rectangle, Rectangle) +splitHorizontallyBy, splitVerticallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle) hunk ./Operations.hs 532 - mouseDrag (\ex ey -> do - io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) - (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) + mouseDrag (\ex ey -> io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) + (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) hunk ./Operations.hs 187 - clearEnterEvents + clearEvents enterWindowMask hunk ./Operations.hs 234 --- | clearEnterEvents. Remove all window entry events from the event queue. -clearEnterEvents :: X () -clearEnterEvents = withDisplay $ \d -> io $ do +-- | clearEvents. Remove all events of a given type from the event queue. +clearEvents :: EventMask -> X () +clearEvents mask = withDisplay $ \d -> io $ do hunk ./Operations.hs 239 - more <- checkMaskEvent d enterWindowMask p + more <- checkMaskEvent d mask p hunk ./Operations.hs 513 - Just _ -> return () -- error case? we're already dragging - Nothing -> do - XConf { theRoot = root, display = d } <- ask - io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) - grabModeAsync grabModeAsync none none currentTime - modify $ \s -> s { dragging = Just (f, cleanup) } - where - cleanup = do - withDisplay $ io . flip ungrabPointer currentTime - modify $ \s -> s { dragging = Nothing } - done + Just _ -> return () -- error case? we're already dragging + Nothing -> do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) + grabModeAsync grabModeAsync none none currentTime + modify $ \s -> s { dragging = Just (motion, cleanup) } + where + cleanup = do + withDisplay $ io . flip ungrabPointer currentTime + modify $ \s -> s { dragging = Nothing } + done + motion x y = do z <- f x y + clearEvents pointerMotionMask + return z hunk ./Operations.hs 294 - if W.member w s then windows (W.focusWindow w) + if W.member w s then when (W.peek s /= Just w) $ windows (W.focusWindow w) hunk ./Config.hs 52 +-- +-- An example, to set a top gap on monitor 1, and a gap on the bottom of +-- monitor 2, you'd use a list of geometries like so: +-- +-- > defaultGaps = [(18,0,0,0),(0,18,0,0)] -- 2 gaps on 2 monitors hunk ./TODO 1 +0.3 release: + * stable contrib repo tarball + * haddocks for core and contribs on xmonad.org + * tag xmonad + * tag X11-extras + * tag X11 + * more QC tests + + hunk ./Config.hs 181 + -- mod-button1 @@ Set the window to floating mode and move by dragging hunk ./Config.hs 183 + -- mod-button2 @@ Raise the window to the top of the stack hunk ./Config.hs 185 + -- mod-button3 @@ Set the window to floating mode and resize by dragging hunk ./README 64 + + darcs get http://darcs.haskell.org/~sjanssen/X11-extras hunk ./xmonad.cabal 21 -build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.2, mtl>=1.0, unix>=1.0 +build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.3, mtl>=1.0, unix>=1.0 hunk ./README 49 - X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.2 + X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.3 hunk ./README 81 + +XMonadContrib + + There are various contributed modules that can be used with xmonad. + Examples include a ion3-like tabbed layout, a prompt/program launcher, + and various other useful modules. XMonadContrib is available at: + + 0.3 release: http://www.xmonad.org/XMonadContrib-0.3.tar.gz + + darcs version: darcs get http://darcs.haskell.org/~sjanssen/XMonadContrib + +------------------------------------------------------------------------ hunk ./xmonad.cabal 2 -version: 0.2 +version: 0.3 hunk ./README 85 - Examples include a ion3-like tabbed layout, a prompt/program launcher, + Examples include an ion3-like tabbed layout, a prompt/program launcher, hunk ./TODO 1 -0.3 release: - * stable contrib repo tarball - * haddocks for core and contribs on xmonad.org - * tag xmonad - * tag X11-extras - * tag X11 - * more QC tests - hunk ./TODO 3 + * more QC tests hunk ./Config.hs 94 -defaultLayouts = [ tiled , mirror tiled , full ] +defaultLayouts = [ tiled + , mirror tiled + , full + + -- Extension-provided layouts + ] hunk ./Config.hs 166 + -- Extension-provided key bindings hunk ./Config.hs 192 - , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) ] + , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) + -- Extension-provided mouse bindings + ] hunk ./Config.hs 36 -workspaces = [0..8] +workspaces = map (:"") ['1'..'9'] hunk ./XMonad.hs 18 - X, WindowSet, WorkspaceId(..), ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), + X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), hunk ./XMonad.hs 58 -newtype WorkspaceId = W Int deriving (Eq,Ord,Show,Read,Enum,Num,Integral,Real) +type WorkspaceId = String hunk ./Config.hs 36 -workspaces = map (:"") ['1'..'9'] +workspaces = map show [1 .. 9 :: Int] hunk ./XMonad.hs 20 - runX, catchX, io, catchIO, withDisplay, withWindowSet, isRoot, spawn, restart, trace, whenJust, whenX, + runX, catchX, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX, hunk ./Operations.hs 547 - applySizeHints sh ((fromIntegral (max 1 (ex - fromIntegral (wa_x wa)))), - (fromIntegral (max 1 (ey - fromIntegral (wa_y wa)))))) + applySizeHints sh (ex - fromIntegral (wa_x wa), + ey - fromIntegral (wa_y wa))) hunk ./Operations.hs 557 -applySizeHints :: SizeHints -> D -> D -applySizeHints sh = +applySizeHints :: Integral a => SizeHints -> (a,a) -> D +applySizeHints sh (w,h) = applySizeHints' sh (fromIntegral $ max 1 w, + fromIntegral $ max 1 h) + +applySizeHints' :: SizeHints -> D -> D +applySizeHints' sh = hunk ./Config.hs 32 +-- Extension-provided imports + hunk ./Config.hs 168 - -- Extension-provided key bindings hunk ./Config.hs 169 - ] ++ + -- Extension-provided key bindings + ] + ++ hunk ./Config.hs 177 - + ++ hunk ./Config.hs 180 - ++ hunk ./Config.hs 183 + -- Extension-provided key bindings lists hunk ./Config.hs 199 +-- Extension-provided definitions + hunk ./Operations.hs 52 - setInitialProperties w >> reveal w + setInitialProperties w hunk ./Operations.hs 91 -shift n = windows (W.shift n) +shift = windows . W.shift hunk ./xmonad.cabal 6 - Xmonad is a minimalist tiling window manager for X, written in - Haskell. Windows are managed using automatic layout algorithms, - which can be dynamically reconfigured. At any time windows are - arranged so as to maximise the use of screen real estate. All - features of the window manager are accessible purely from the - keyboard: a mouse is entirely optional. Xmonad is configured in - Haskell, and custom layout algorithms may be implemented by the user - in config files. A principle of Xmonad is predictability: the user - should know in advance precisely the window arrangement that will - result from any action. + xmonad is a tiling window manager for X. Windows are arranged + automatically to tile the screen without gaps or overlap, maximising + screen use. All features of the window manager are accessible from + the keyboard: a mouse is strictly optional. xmonad is written and + extensible in Haskell. Custom layout algorithms, and other + extensions, may be written by the user in config files. Layouts are + applied dynamically, and different layouts may be used on each + workspace. Xinerama is fully supported, allowing windows to be tiled + on several screens. hunk ./Operations.hs 69 --- FIXME: clearFloating should be taken care of in W.delete, but if we do it --- there, floating status is lost when moving windows between workspaces, --- because W.shift calls W.delete. --- hunk ./Operations.hs 73 - windows (W.sink w . W.delete w) + windows (W.delete w) hunk ./StackSet.hs 29 - insertUp, delete, filter, + insertUp, delete, delete', filter, hunk ./StackSet.hs 456 -delete w s = s { current = removeFromScreen (current s) - , visible = map removeFromScreen (visible s) - , hidden = map removeFromWorkspace (hidden s) } +delete w = sink w . delete' w + +-- only temporarily remove the window from the stack, thereby not destroying special +-- information saved in the Stackset +delete' :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd +delete' w s = s { current = removeFromScreen (current s) + , visible = map removeFromScreen (visible s) + , hidden = map removeFromWorkspace (hidden s) } hunk ./StackSet.hs 503 - where go w = view curtag . insertUp w . view n . delete w $ s + where go w = view curtag . insertUp w . view n . delete' w $ s hunk ./Main.hs 32 -import StackSet (new, floating, member, findIndex, workspace, tag, current, visible) +import StackSet (new, floating, member) hunk ./Main.hs 229 - -- TODO temporary workaround for some bugs in float. Don't call 'float' on - -- windows that aren't visible, because it changes the focused screen - let vis = any ((== findIndex w ws) . Just . tag . workspace) (current ws : visible ws) - if (M.member w (floating ws) && vis) + if M.member w (floating ws) hunk ./Operations.hs 475 --- --- TODO: float changes the set of visible workspaces when we call it for an --- invisible window -- this should not happen. See 'temporary workaround' in --- the handler for ConfigureRequestEvent also. hunk ./Operations.hs 484 + rr = (W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) + ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) + (fi (wa_width wa + bw*2) % fi (rect_width sr)) + (fi (wa_height wa + bw*2) % fi (rect_height sr))) hunk ./Operations.hs 489 - windows $ maybe id W.focusWindow (W.peek ws) . W.shift sw . W.focusWindow w . W.float w - (W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) - ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) - (fi (wa_width wa + bw*2) % fi (rect_width sr)) - (fi (wa_height wa + bw*2) % fi (rect_height sr))) + if maybe False (`elem` (map W.tag . W.hidden $ ws)) (W.findIndex w ws) + then windows $ W.float w rr + else windows $ maybe id W.focusWindow (W.peek ws) . W.shiftWin sw w . W.float w rr hunk ./StackSet.hs 35 - shift + shift, shiftWin hunk ./StackSet.hs 39 -import Data.Maybe (listToMaybe) +import Data.Maybe (listToMaybe,fromJust) hunk ./StackSet.hs 506 +shiftWin :: (Ord a, Eq a, Eq s, Eq i) => i -> a -> StackSet i a s sd -> StackSet i a s sd +shiftWin n w s | from == Nothing = s + | n `tagMember` s && (Just n) /= from = go + | otherwise = s + where go = on n (insertUp w) . on (fromJust from) (delete' w) $ s + curtag = tag (workspace (current s)) + from = findIndex w s + on i f = view curtag . f . view i + hunk ./tests/Properties.hs 170 +prop_shift_win_I (n :: NonNegative Int) (w :: Char) (x :: T) = + n `tagMember` x && w `member` x ==> invariant $ shiftWin (fromIntegral n) w x + hunk ./tests/Properties.hs 499 +-- --------------------------------------------------------------------- +-- shiftWin + +-- shiftWin on current window is the same as shift +prop_shift_win_focus i (x :: T) = + i `tagMember` x ==> case peek x of + Nothing -> True + Just w -> shiftWin i w x == shift i x + +-- shiftWin leaves the current screen as it is, if neither i is the tag +-- of the current workspace nor w on the current workspace +prop_shift_win_fix_current i w (x :: T) = + i `tagMember` x && w `member` x && i /= n && findIndex w x /= Just n + ==> (current $ x) == (current $ shiftWin i w x) + where + n = tag (workspace $ current x) + hunk ./tests/Properties.hs 634 + ,("shiftWin: invariant" , mytest prop_shift_win_I) + ,("shiftWin is shift on focus" , mytest prop_shift_win_focus) + ,("shiftWin fix current" , mytest prop_shift_win_fix_current) hunk ./StackSet.hs 458 --- only temporarily remove the window from the stack, thereby not destroying special +-- | Only temporarily remove the window from the stack, thereby not destroying special hunk ./Config.hs 133 - [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- @@ Launch an xterm - , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- @@ Launch dmenu - , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") -- @@ Launch gmrun - , ((modMask .|. shiftMask, xK_c ), kill) -- @@ Close the focused window + [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- %! Launch an xterm + , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! Launch dmenu + , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") -- %! Launch gmrun + , ((modMask .|. shiftMask, xK_c ), kill) -- %! Close the focused window hunk ./Config.hs 138 - , ((modMask, xK_space ), switchLayout) -- @@ Rotate through the available layout algorithms + , ((modMask, xK_space ), switchLayout) -- %! Rotate through the available layout algorithms hunk ./Config.hs 140 - , ((modMask, xK_n ), refresh) -- @@ Resize viewed windows to the correct size + , ((modMask, xK_n ), refresh) -- %! Resize viewed windows to the correct size hunk ./Config.hs 143 - , ((modMask, xK_Tab ), focusDown) -- @@ Move focus to the next window - , ((modMask, xK_j ), focusDown) -- @@ Move focus to the next window - , ((modMask, xK_k ), focusUp ) -- @@ Move focus to the previous window + , ((modMask, xK_Tab ), focusDown) -- %! Move focus to the next window + , ((modMask, xK_j ), focusDown) -- %! Move focus to the next window + , ((modMask, xK_k ), focusUp ) -- %! Move focus to the previous window hunk ./Config.hs 148 - , ((modMask, xK_Return), swapMaster) -- @@ Swap the focused window and the master window - , ((modMask .|. shiftMask, xK_j ), swapDown ) -- @@ Swap the focused window with the next window - , ((modMask .|. shiftMask, xK_k ), swapUp ) -- @@ Swap the focused window with the previous window + , ((modMask, xK_Return), swapMaster) -- %! Swap the focused window and the master window + , ((modMask .|. shiftMask, xK_j ), swapDown ) -- %! Swap the focused window with the next window + , ((modMask .|. shiftMask, xK_k ), swapUp ) -- %! Swap the focused window with the previous window hunk ./Config.hs 153 - , ((modMask, xK_h ), sendMessage Shrink) -- @@ Shrink the master area - , ((modMask, xK_l ), sendMessage Expand) -- @@ Expand the master area + , ((modMask, xK_h ), sendMessage Shrink) -- %! Shrink the master area + , ((modMask, xK_l ), sendMessage Expand) -- %! Expand the master area hunk ./Config.hs 156 - , ((modMask, xK_t ), withFocused sink) -- @@ Push window back into tiling + , ((modMask, xK_t ), withFocused sink) -- %! Push window back into tiling hunk ./Config.hs 159 - , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) -- @@ Increment the number of windows in the master area - , ((modMask , xK_period), sendMessage (IncMasterN (-1))) -- @@ Deincrement the number of windows in the master area + , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) -- %! Increment the number of windows in the master area + , ((modMask , xK_period), sendMessage (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area hunk ./Config.hs 163 - , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- @@ Toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap hunk ./Config.hs 166 - , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- @@ Quit xmonad - , ((modMask , xK_q ), restart Nothing True) -- @@ Restart xmonad + , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) -- %! Quit xmonad + , ((modMask , xK_q ), restart Nothing True) -- %! Restart xmonad hunk ./Config.hs 172 - -- mod-[1..9] @@ Switch to workspace N - -- mod-shift-[1..9] @@ Move client to workspace N + -- mod-[1..9] %! Switch to workspace N + -- mod-shift-[1..9] %! Move client to workspace N hunk ./Config.hs 178 - -- mod-{w,e,r} @@ Switch to physical/Xinerama screens 1, 2, or 3 - -- mod-shift-{w,e,r} @@ Move client to screen 1, 2, or 3 + -- mod-{w,e,r} %! Switch to physical/Xinerama screens 1, 2, or 3 + -- mod-shift-{w,e,r} %! Move client to screen 1, 2, or 3 hunk ./Config.hs 190 - -- mod-button1 @@ Set the window to floating mode and move by dragging + -- mod-button1 %! Set the window to floating mode and move by dragging hunk ./Config.hs 192 - -- mod-button2 @@ Raise the window to the top of the stack + -- mod-button2 %! Raise the window to the top of the stack hunk ./Config.hs 194 - -- mod-button3 @@ Set the window to floating mode and resize by dragging + -- mod-button3 %! Set the window to floating mode and resize by dragging hunk ./util/GenerateManpage.hs 7 --- -- mod-x @@ Frob the whatsit +-- -- mod-x %! Frob the whatsit hunk ./util/GenerateManpage.hs 14 --- [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- @@ Launch an xterm +-- [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- %! Launch an xterm hunk ./util/GenerateManpage.hs 35 -allBindings xs = map (binding . map trim) (xs =~ "(.*)--(.*)@@(.*)") +allBindings xs = map (binding . map trim) (xs =~ "(.*)--(.*)%!(.*)") hunk ./Config.hs 143 - , ((modMask, xK_Tab ), focusDown) -- %! Move focus to the next window - , ((modMask, xK_j ), focusDown) -- %! Move focus to the next window - , ((modMask, xK_k ), focusUp ) -- %! Move focus to the previous window + , ((modMask, xK_Tab ), windows W.focusDown) -- %! Move focus to the next window + , ((modMask, xK_j ), windows W.focusDown) -- %! Move focus to the next window + , ((modMask, xK_k ), windows W.focusUp ) -- %! Move focus to the previous window hunk ./Config.hs 148 - , ((modMask, xK_Return), swapMaster) -- %! Swap the focused window and the master window - , ((modMask .|. shiftMask, xK_j ), swapDown ) -- %! Swap the focused window with the next window - , ((modMask .|. shiftMask, xK_k ), swapUp ) -- %! Swap the focused window with the previous window + , ((modMask, xK_Return), windows W.swapMaster) -- %! Swap the focused window and the master window + , ((modMask .|. shiftMask, xK_j ), windows W.swapDown ) -- %! Swap the focused window with the next window + , ((modMask .|. shiftMask, xK_k ), windows W.swapUp ) -- %! Swap the focused window with the previous window hunk ./Config.hs 174 - [((m .|. modMask, k), f i) + [((m .|. modMask, k), windows $ f i) hunk ./Config.hs 176 - , (f, m) <- [(view, 0), (shift, shiftMask)]] + , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] hunk ./Config.hs 180 - [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust f) + [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust (windows . f)) hunk ./Config.hs 182 - , (f, m) <- [(windows . W.view, 0), (shift, shiftMask)]] + , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]] hunk ./Config.hs 193 - , ((modMask, button2), (\w -> focus w >> swapMaster)) + , ((modMask, button2), (\w -> focus w >> windows W.swapMaster)) hunk ./Operations.hs 76 - --- | focus. focus window up or down. or swap various windows. -focusUp, focusDown, swapUp, swapDown, swapMaster :: X () -focusUp = windows W.focusUp -focusDown = windows W.focusDown -swapUp = windows W.swapUp -swapDown = windows W.swapDown -swapMaster = windows W.swapMaster - --- | shift. Move a window to a new workspace, 0 indexed. -shift :: WorkspaceId -> X () -shift = windows . W.shift - --- | view. Change the current workspace to workspace at offset n (0 indexed). -view :: WorkspaceId -> X () -view = windows . W.greedyView hunk ./Config.hs 156 - , ((modMask, xK_t ), withFocused sink) -- %! Push window back into tiling + , ((modMask, xK_t ), withFocused $ windows . W.sink) -- %! Push window back into tiling hunk ./Operations.hs 453 - --- | Make a floating window tiled -sink :: Window -> X () -sink = windows . W.sink hunk ./StackSet.hs 506 +-- TODO how does this duplicate 'shift's behaviour? hunk ./StackSet.hs 511 - where go = on n (insertUp w) . on (fromJust from) (delete' w) $ s + where go = on n (insertUp w) . on (fromJust from) (delete' w) $ s hunk ./StackSet.hs 513 - from = findIndex w s + from = findIndex w s hunk ./StackSet.hs 22 + screens, workspaces, hunk ./StackSet.hs 390 +-- | Get a list of all screens in the StackSet. +screens :: StackSet i a s sd -> [Screen i a s sd] +screens s = current s : visible s + hunk ./Operations.hs 124 - let allscreens = W.current ws : W.visible ws + let allscreens = W.screens ws hunk ./Operations.hs 454 --- | Make a tiled window floating, using its suggested rectangle -float :: Window -> X () -float w = withDisplay $ \d -> do +-- | Given a window, find the screen it is located on, and compute +-- the geometry of that window wrt. that screen. +floatLocation :: Window -> X (ScreenId, W.RationalRect) +floatLocation w = withDisplay $ \d -> do hunk ./Operations.hs 461 - let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.current ws : W.visible ws + let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.screens ws hunk ./Operations.hs 463 - sw = W.tag . W.workspace $ sc hunk ./Operations.hs 469 - if maybe False (`elem` (map W.tag . W.hidden $ ws)) (W.findIndex w ws) - then windows $ W.float w rr - else windows $ maybe id W.focusWindow (W.peek ws) . W.shiftWin sw w . W.float w rr + return (W.screen $ sc, rr) hunk ./Operations.hs 477 +-- | Make a tiled window floating, using its suggested rectangle +float :: Window -> X () +float w = do + (sc, rr) <- floatLocation w + windows $ \ws -> W.float w rr . fromMaybe ws $ do + i <- W.findIndex w ws + guard $ i `elem` map (W.tag . W.workspace) (W.screens ws) + f <- W.peek ws + sw <- W.lookupWorkspace sc ws + return (W.focusWindow f . W.shiftWin sw w $ ws) + hunk ./XMonad.hs 169 -catchIO f = liftIO (f `catch` \e -> do hPutStrLn stderr (show e); hFlush stderr) +catchIO f = liftIO (f `catch` \e -> hPrint stderr e >> hFlush stderr) hunk ./Config.hs 146 + , ((modMask, xK_m ), windows W.focusMaster ) -- %! Move focus to the master window + hunk ./StackSet.hs 26 - focusUp, focusDown, + focusUp, focusDown, focusMaster, hunk ./StackSet.hs 33 - swapMaster, swapUp, swapDown, modify, modify', float, sink, -- needed by users + swapUp, swapDown, swapMaster, modify, modify', float, sink, -- needed by users hunk ./StackSet.hs 466 -delete' w s = s { current = removeFromScreen (current s) - , visible = map removeFromScreen (visible s) - , hidden = map removeFromWorkspace (hidden s) } +delete' w s = s { current = removeFromScreen (current s) + , visible = map removeFromScreen (visible s) + , hidden = map removeFromWorkspace (hidden s) } hunk ./StackSet.hs 470 - removeFromScreen scr = scr { workspace = removeFromWorkspace (workspace scr) } + removeFromScreen scr = scr { workspace = removeFromWorkspace (workspace scr) } hunk ./StackSet.hs 492 - Stack t ls rs -> Stack t [] (ys ++ x : rs) where (x:ys) = reverse ls + Stack t ls rs -> Stack t [] (xs ++ x : rs) where (x:xs) = reverse ls hunk ./StackSet.hs 495 + +-- | /O(s)/. Set focus to the master window. +focusMaster :: StackSet i a s sd -> StackSet i a s sd +focusMaster = modify' $ \c -> case c of + Stack _ [] _ -> c + Stack t ls rs -> Stack x [] (xs ++ t : rs) where (x:xs) = reverse ls + hunk ./xmonad.cabal 30 --- Also requires deriving Typeable +-- Also requires deriving Typeable, PatternGuards hunk ./LICENSE 17 -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND hunk ./tests/Properties.hs 144 +prop_focusMaster_I (n :: NonNegative Int) (x :: T) = + invariant $ foldr (const focusMaster) x [1..n] hunk ./tests/Properties.hs 302 +prop_focus_master_master (n :: NonNegative Int) (x::T) = + index (foldr (const focusMaster) x [1..n]) == index x + hunk ./tests/Properties.hs 316 +-- focus master is idempotent +prop_focusMaster_idem (x :: T) = focusMaster x == focusMaster (focusMaster x) + hunk ./tests/Properties.hs 337 -prop_focus_local (x :: T) = hidden_spaces (focusDown x) == hidden_spaces x +prop_focus_down_local (x :: T) = hidden_spaces (focusDown x) == hidden_spaces x +prop_focus_up_local (x :: T) = hidden_spaces (focusUp x) == hidden_spaces x + +prop_focus_master_local (x :: T) = hidden_spaces (focusMaster x) == hidden_spaces x hunk ./tests/Properties.hs 595 + ,("focus master : invariant", mytest prop_focusMaster_I) hunk ./tests/Properties.hs 600 + ,("focus master/master" , mytest prop_focus_master_master) hunk ./tests/Properties.hs 606 - ,("focus is local" , mytest prop_focus_local) + ,("focus down is local" , mytest prop_focus_down_local) + ,("focus up is local" , mytest prop_focus_up_local) + ,("focus master is local" , mytest prop_focus_master_local) + ,("focus master idemp" , mytest prop_focusMaster_idem) + hunk ./tests/Properties.hs 527 +------------------------------------------------------------------------ +-- properties for the floating layer: + +prop_float_reversible n (x :: T) = + n `member` x ==> sink n (float n geom x) == x + where + geom = RationalRect 100 100 100 100 + +------------------------------------------------------------------------ + +prop_screens (x :: T) = n `elem` screens x + where + n = current x + + hunk ./tests/Properties.hs 670 + ,("floating is reversible" , mytest prop_float_reversible) + ,("screens includes current", mytest prop_screens) + hunk ./StackSet.hs 518 +-- | /O(n)/. shiftWin. Searches for the specified window 'w' on all workspaces +-- of the stackSet and moves it to stack 'n', leaving it as the focused +-- element on that stack. The item is inserted above the currently +-- focused element on that workspace. +-- The actual focused workspace doesn't change. If the window is not +-- found in the stackSet, the original stackSet is returned. hunk ./tests/Properties.hs 541 +prop_differentiate xs = + if null xs then differentiate xs == Nothing + else focus (fromJust (differentiate xs)) == head xs + where _ = xs :: [Int] hunk ./tests/Properties.hs 676 + ,("differentiate works", mytest prop_differentiate) hunk ./Config.hs 95 -defaultLayouts :: [Layout Window] -defaultLayouts = [ tiled - , mirror tiled - , full +defaultLayouts :: [SomeLayout Window] +defaultLayouts = [ SomeLayout tiled + , SomeLayout $ mirror tiled + , SomeLayout full hunk ./Main.hs 58 - safeLayouts = case defaultLayouts of [] -> (full, []); (x:xs) -> (x,xs) + safeLayouts = case defaultLayouts of [] -> (SomeLayout full, []); (x:xs) -> (x,xs) hunk ./Operations.hs 141 - (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout full viewrect tiled + (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (SomeLayout full) viewrect tiled hunk ./Operations.hs 354 -full :: Layout a -full = Layout { doLayout = \sc (W.Stack f _ _) -> return ([(f, sc)],Nothing) - , modifyLayout = const (return Nothing) } -- no changes +full :: OldLayout a +full = OldLayout { doLayout' = \sc (W.Stack f _ _) -> return ([(f, sc)],Nothing) + , modifyLayout' = const (return Nothing) } -- no changes hunk ./Operations.hs 361 -tall :: Int -> Rational -> Rational -> Layout a +tall :: Int -> Rational -> Rational -> OldLayout a hunk ./Operations.hs 363 - Layout { doLayout = \r -> return . (\x->(x,Nothing)) . + OldLayout { doLayout' = \r -> return . (\x->(x,Nothing)) . hunk ./Operations.hs 365 - , modifyLayout = \m -> return $ msum [fmap resize (fromMessage m) - ,fmap incmastern (fromMessage m)] } + , modifyLayout' = \m -> return $ msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] } hunk ./Operations.hs 377 -mirror :: Layout a -> Layout a -mirror (Layout { doLayout = dl, modifyLayout = ml }) = - Layout { doLayout = \sc w -> do (wrs, ml') <- dl (mirrorRect sc) w +mirror :: Layout l a => l a -> OldLayout a +mirror l = + OldLayout { doLayout' = \sc w -> do (wrs, ml') <- doLayout l (mirrorRect sc) w hunk ./Operations.hs 381 - , modifyLayout = fmap (fmap mirror) . ml } + , modifyLayout' = fmap (fmap mirror) . modifyLayout l } hunk ./XMonad.hs 18 - X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), + X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), OldLayout(..), SomeLayout(..), hunk ./XMonad.hs 46 - , layouts :: !(M.Map WorkspaceId (Layout Window, [Layout Window])) + , layouts :: !(M.Map WorkspaceId (SomeLayout Window, [SomeLayout Window])) hunk ./XMonad.hs 134 -data Layout a = Layout { doLayout :: Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (Layout a)) - , modifyLayout :: SomeMessage -> X (Maybe (Layout a)) } +data OldLayout a = + OldLayout { doLayout' :: Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (OldLayout a)) + , modifyLayout' :: SomeMessage -> X (Maybe (OldLayout a)) } hunk ./XMonad.hs 138 -runLayout :: Layout a -> Rectangle -> StackOrNot a -> X ([(a, Rectangle)], Maybe (Layout a)) +data SomeLayout a = forall l. Layout l a => SomeLayout (l a) + +class Layout layout a where + doLayout :: layout a -> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a)) + modifyLayout :: layout a -> SomeMessage -> X (Maybe (layout a)) + +instance Layout OldLayout a where + doLayout = doLayout' + modifyLayout = modifyLayout' + +instance Layout SomeLayout a where + doLayout (SomeLayout l) r s = do (ars, ml') <- doLayout l r s + return (ars, SomeLayout `fmap` ml' ) + modifyLayout (SomeLayout l) m = do ml' <- modifyLayout l m + return (SomeLayout `fmap` ml') + +runLayout :: Layout l a => l a -> Rectangle -> StackOrNot a -> X ([(a, Rectangle)], Maybe (l a)) hunk ./Config.hs 97 - , SomeLayout $ mirror tiled - , SomeLayout full + , SomeLayout $ Mirror tiled + , SomeLayout Full hunk ./Config.hs 104 - tiled = tall nmaster delta ratio + tiled = Tall nmaster delta ratio hunk ./Main.hs 58 - safeLayouts = case defaultLayouts of [] -> (SomeLayout full, []); (x:xs) -> (x,xs) + safeLayouts = case defaultLayouts of [] -> (SomeLayout Full, []); (x:xs) -> (x,xs) hunk ./Operations.hs 141 - (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (SomeLayout full) viewrect tiled + (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (SomeLayout Full) viewrect tiled hunk ./Operations.hs 354 -full :: OldLayout a -full = OldLayout { doLayout' = \sc (W.Stack f _ _) -> return ([(f, sc)],Nothing) - , modifyLayout' = const (return Nothing) } -- no changes - +data Full a = Full +instance Layout Full a where + doLayout Full sc (W.Stack f _ _) = return ([(f, sc)], Nothing) + modifyLayout Full _ = return Nothing -- no changes hunk ./Operations.hs 361 -tall :: Int -> Rational -> Rational -> OldLayout a -tall nmaster delta frac = - OldLayout { doLayout' = \r -> return . (\x->(x,Nothing)) . - ap zip (tile frac r nmaster . length) . W.integrate - , modifyLayout' = \m -> return $ msum [fmap resize (fromMessage m) - ,fmap incmastern (fromMessage m)] } - - where resize Shrink = tall nmaster delta (max 0 $ frac-delta) - resize Expand = tall nmaster delta (min 1 $ frac+delta) - incmastern (IncMasterN d) = tall (max 0 (nmaster+d)) delta frac +data Tall a = Tall Int Rational Rational +instance Layout Tall a where + doLayout (Tall nmaster _ frac) r = + return . (\x->(x,Nothing)) . + ap zip (tile frac r nmaster . length) . W.integrate + modifyLayout (Tall nmaster delta frac) m = + return $ msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] + where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) + resize Expand = Tall nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac hunk ./Operations.hs 378 -mirror :: Layout l a => l a -> OldLayout a -mirror l = - OldLayout { doLayout' = \sc w -> do (wrs, ml') <- doLayout l (mirrorRect sc) w - return (map (second mirrorRect) wrs, mirror `fmap` ml') - , modifyLayout' = fmap (fmap mirror) . modifyLayout l } +data Mirror a = forall l. Layout l a => Mirror (l a) +instance Layout Mirror a where + doLayout (Mirror l) r s = do (wrs, ml') <- doLayout l (mirrorRect r) s + return (map (second mirrorRect) wrs, Mirror `fmap` ml') + modifyLayout (Mirror l) = fmap (fmap Mirror) . modifyLayout l hunk ./XMonad.hs 18 - X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), OldLayout(..), SomeLayout(..), + X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), SomeLayout(..), hunk ./XMonad.hs 134 -data OldLayout a = - OldLayout { doLayout' :: Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (OldLayout a)) - , modifyLayout' :: SomeMessage -> X (Maybe (OldLayout a)) } - hunk ./XMonad.hs 140 -instance Layout OldLayout a where - doLayout = doLayout' - modifyLayout = modifyLayout' - hunk ./Operations.hs 354 -data Full a = Full +data Full a = Full deriving Show hunk ./Operations.hs 361 -data Tall a = Tall Int Rational Rational +data Tall a = Tall Int Rational Rational deriving Show hunk ./Operations.hs 379 +instance Show (Mirror a) where + show (Mirror l) = "Mirror "++show l hunk ./XMonad.hs 135 +instance Show (SomeLayout a) where + show (SomeLayout l) = show l hunk ./XMonad.hs 138 -class Layout layout a where +class Show (layout a) => Layout layout a where hunk ./Operations.hs 354 -data Full a = Full deriving Show +data Full a = Full deriving ( Show, Read ) hunk ./Operations.hs 361 -data Tall a = Tall Int Rational Rational deriving Show +data Tall a = Tall Int Rational Rational deriving ( Show, Read ) hunk ./Operations.hs 378 -data Mirror a = forall l. Layout l a => Mirror (l a) -instance Show (Mirror a) where +data Mirror l a = Layout l a => Mirror (l a) +instance Layout l a => Show (Mirror l a) where hunk ./Operations.hs 381 -instance Layout Mirror a where +instance Layout l a => Read (Mirror l a) where + readsPrec _ s = case take (length "Mirror ") s of + "Mirror " -> map (\ (l,s') -> (Mirror l,s')) $ reads $ drop (length "Mirror ") s + _ -> [] + +instance Layout l a => Layout (Mirror l) a where hunk ./XMonad.hs 137 +instance Read (SomeLayout a) where + readsPrec _ _ = [] -- We can't read an existential type!!! hunk ./XMonad.hs 140 -class Show (layout a) => Layout layout a where +class (Show (layout a), Read (layout a)) => Layout layout a where hunk ./XMonad.hs 18 - X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), SomeLayout(..), + X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), SomeLayout(..), readLayout, hunk ./XMonad.hs 140 +readLayout :: [SomeLayout a] -> String -> [(SomeLayout a, String)] +readLayout ls s = concatMap rl ls + where rl (SomeLayout x) = map (\(l,s') -> (SomeLayout l,s')) $ rl' x + rl' :: Layout l a => l a -> [(l a,String)] + rl' _ = reads s + hunk ./Operations.hs 378 -data Mirror l a = Layout l a => Mirror (l a) -instance Layout l a => Show (Mirror l a) where - show (Mirror l) = "Mirror "++show l -instance Layout l a => Read (Mirror l a) where - readsPrec _ s = case take (length "Mirror ") s of - "Mirror " -> map (\ (l,s') -> (Mirror l,s')) $ reads $ drop (length "Mirror ") s - _ -> [] +data Mirror l a = Mirror (l a) deriving (Show, Read) hunk ./Operations.hs 381 - doLayout (Mirror l) r s = do (wrs, ml') <- doLayout l (mirrorRect r) s - return (map (second mirrorRect) wrs, Mirror `fmap` ml') + doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror) + `fmap` doLayout l (mirrorRect r) s hunk ./XMonad.hs 151 - doLayout (SomeLayout l) r s = do (ars, ml') <- doLayout l r s - return (ars, SomeLayout `fmap` ml' ) - modifyLayout (SomeLayout l) m = do ml' <- modifyLayout l m - return (SomeLayout `fmap` ml') + doLayout (SomeLayout l) r s = fmap (fmap $ fmap SomeLayout) $ doLayout l r s + modifyLayout (SomeLayout l) = fmap (fmap SomeLayout) . modifyLayout l hunk ./StackSet.hs 41 -import qualified Data.List as L (delete,deleteBy,find,splitAt,filter) +import qualified Data.List as L (deleteBy,find,splitAt,filter) hunk ./StackSet.hs 228 -view :: (Eq a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +view :: (Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 240 - , hidden = workspace (current s) : L.delete x (hidden s) } + , hidden = workspace (current s) : L.deleteBy tagEq x (hidden s) } hunk ./StackSet.hs 244 + tagEq x y = tag x == tag y hunk ./StackSet.hs 257 -greedyView :: (Eq a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +greedyView :: (Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd hunk ./StackSet.hs 466 -delete' :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd +delete' :: (Eq a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd hunk ./Main.hs 55 - | otherwise = new workspaces $ zipWith SD xinesc gaps + | otherwise = new (fst safeLayouts) workspaces $ zipWith SD xinesc gaps hunk ./StackSet.hs 150 -data StackSet i a sid sd = - StackSet { current :: !(Screen i a sid sd) -- ^ currently focused workspace - , visible :: [Screen i a sid sd] -- ^ non-focused workspaces, visible in xinerama - , hidden :: [Workspace i a] -- ^ workspaces not visible anywhere +data StackSet i l a sid sd = + StackSet { current :: !(Screen i l a sid sd) -- ^ currently focused workspace + , visible :: [Screen i l a sid sd] -- ^ non-focused workspaces, visible in xinerama + , hidden :: [Workspace i l a] -- ^ workspaces not visible anywhere hunk ./StackSet.hs 158 -data Screen i a sid sd = Screen { workspace :: !(Workspace i a) - , screen :: !sid - , screenDetail :: !sd } +data Screen i l a sid sd = Screen { workspace :: !(Workspace i l a) + , screen :: !sid + , screenDetail :: !sd } hunk ./StackSet.hs 166 -data Workspace i a = Workspace { tag :: !i, stack :: StackOrNot a } +data Workspace i l a = Workspace { tag :: !i, layout :: l, stack :: StackOrNot a } hunk ./StackSet.hs 211 -new :: (Integral s) => [i] -> [sd] -> StackSet i a s sd -new wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty - where (seen,unseen) = L.splitAt (length m) $ map (flip Workspace Nothing) wids +new :: (Integral s) => l -> [i] -> [sd] -> StackSet i l a s sd +new l wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty + where (seen,unseen) = L.splitAt (length m) $ map (\i -> Workspace i l Nothing) wids hunk ./StackSet.hs 216 -new _ _ = abort "non-positive argument to StackSet.new" +new _ _ _ = abort "non-positive argument to StackSet.new" hunk ./StackSet.hs 228 -view :: (Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +view :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 257 -greedyView :: (Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +greedyView :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 273 -lookupWorkspace :: Eq s => s -> StackSet i a s sd -> Maybe i +lookupWorkspace :: Eq s => s -> StackSet i l a s sd -> Maybe i hunk ./StackSet.hs 285 -with :: b -> (Stack a -> b) -> StackSet i a s sd -> b +with :: b -> (Stack a -> b) -> StackSet i l a s sd -> b hunk ./StackSet.hs 291 -modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i a s sd -> StackSet i a s sd +modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 299 -modify' :: (Stack a -> Stack a) -> StackSet i a s sd -> StackSet i a s sd +modify' :: (Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 306 -peek :: StackSet i a s sd -> Maybe a +peek :: StackSet i l a s sd -> Maybe a hunk ./StackSet.hs 344 -index :: StackSet i a s sd -> [a] +index :: StackSet i l a s sd -> [a] hunk ./StackSet.hs 361 -focusUp, focusDown, swapUp, swapDown :: StackSet i a s sd -> StackSet i a s sd +focusUp, focusDown, swapUp, swapDown :: StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 383 -focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i a s sd -> StackSet i a s sd +focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 396 -workspaces :: StackSet i a s sd -> [Workspace i a] +workspaces :: StackSet i l a s sd -> [Workspace i l a] hunk ./StackSet.hs 400 -tagMember :: Eq i => i -> StackSet i a s sd -> Bool +tagMember :: Eq i => i -> StackSet i l a s sd -> Bool hunk ./StackSet.hs 409 -member :: Eq a => a -> StackSet i a s sd -> Bool +member :: Eq a => a -> StackSet i l a s sd -> Bool hunk ./StackSet.hs 415 -findIndex :: Eq a => a -> StackSet i a s sd -> Maybe i +findIndex :: Eq a => a -> StackSet i l a s sd -> Maybe i hunk ./StackSet.hs 438 -insertUp :: Eq a => a -> StackSet i a s sd -> StackSet i a s sd +insertUp :: Eq a => a -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 442 --- insertDown :: a -> StackSet i a s sd -> StackSet i a s sd +-- insertDown :: a -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 461 -delete :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd +delete :: (Ord a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 466 -delete' :: (Eq a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd +delete' :: (Eq a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 477 -float :: Ord a => a -> RationalRect -> StackSet i a s sd -> StackSet i a s sd +float :: Ord a => a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 481 -sink :: Ord a => a -> StackSet i a s sd -> StackSet i a s sd +sink :: Ord a => a -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 490 -swapMaster :: StackSet i a s sd -> StackSet i a s sd +swapMaster :: StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 513 -shift :: (Ord a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +shift :: (Ord a, Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 526 -shiftWin :: (Ord a, Eq a, Eq s, Eq i) => i -> a -> StackSet i a s sd -> StackSet i a s sd +shiftWin :: (Ord a, Eq a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd hunk ./XMonad.hs 55 -type WindowSet = StackSet WorkspaceId Window ScreenId ScreenDetail +type WindowSet = StackSet WorkspaceId (SomeLayout Window) Window ScreenId ScreenDetail hunk ./tests/Properties.hs 37 -instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary sd) - => Arbitrary (StackSet i a s sd) where +instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary l, Arbitrary sd) + => Arbitrary (StackSet i l a s sd) where hunk ./tests/Properties.hs 43 + lay <- arbitrary -- pick any layout hunk ./tests/Properties.hs 52 - return $ fromList (fromIntegral n, sds,fs,ls) + return $ fromList (fromIntegral n, sds,fs,ls,lay) hunk ./tests/Properties.hs 66 -fromList :: (Integral i, Integral s, Eq a) => (i, [sd], [Maybe Int], [[a]]) -> StackSet i a s sd -fromList (_,_,_,[]) = error "Cannot build a StackSet from an empty list" +fromList :: (Integral i, Integral s, Eq a) => (i, [sd], [Maybe Int], [[a]], l) -> StackSet i l a s sd +fromList (_,_,_,[],_) = error "Cannot build a StackSet from an empty list" hunk ./tests/Properties.hs 69 -fromList (o,m,fs,xs) = +fromList (o,m,fs,xs,l) = hunk ./tests/Properties.hs 73 - (new [0..genericLength xs-1] m) (zip [0..] xs) + (new l [0..genericLength xs-1] m) (zip [0..] xs) hunk ./tests/Properties.hs 83 -type T = StackSet (NonNegative Int) Char Int Int +type T = StackSet (NonNegative Int) Int Char Int Int hunk ./tests/Properties.hs 133 -prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m -> - forAll (vector m) $ \ms -> - invariant $ new [0..fromIntegral n-1] ms +prop_empty_I (n :: Positive Int) l = forAll (choose (1,fromIntegral n)) $ \m -> + forAll (vector m) $ \ms -> + invariant $ new l [0..fromIntegral n-1] ms hunk ./tests/Properties.hs 186 -prop_empty_current (NonEmptyNubList ns) (NonEmptyNubList sds) = +prop_empty_current (NonEmptyNubList ns) (NonEmptyNubList sds) l = hunk ./tests/Properties.hs 190 - where x = new ns sds :: T + where x = new l ns sds :: T hunk ./tests/Properties.hs 848 + l <- arbitrary hunk ./tests/Properties.hs 850 - return . EmptyStackSet . new ns $ take (min (length ns) (length sds)) sds + return . EmptyStackSet . new l ns $ take (min (length ns) (length sds)) sds hunk ./Main.hs 66 - , layouts = M.fromList [(w, safeLayouts) | w <- workspaces] hunk ./Operations.hs 32 -import Control.Arrow ((***), first, second) +import Control.Arrow ((***), second) hunk ./Operations.hs 39 -import qualified Data.Traversable as T - hunk ./Operations.hs 115 - XState { windowset = old, layouts = fls } <- get + XState { windowset = old } <- get hunk ./Operations.hs 127 - Just l = fmap fst $ M.lookup n fls + l = W.layout (W.workspace w) hunk ./Operations.hs 141 - whenJust ml' $ \l' -> modify $ \ss -> - ss { layouts = M.adjust (first (const l')) n (layouts ss) } + whenJust ml' $ \l' -> runOnWorkspaces (\ww -> if W.tag ww == n + then return $ ww { W.layout = l'} + else return ww) hunk ./Operations.hs 306 -switchLayout = do - broadcastMessage UnDoLayout -- calling refresh now would defeat the point of deconstruction - n <- gets (W.tag . W.workspace . W.current . windowset) - modify $ \s -> s { layouts = M.adjust switch n (layouts s) } - refresh - where switch (x, xs) = let xs' = xs ++ [x] in (head xs', tail xs') +switchLayout = return () hunk ./Operations.hs 312 -sendMessage a = do n <- (W.tag . W.workspace . W.current) `fmap` gets windowset - Just (l,ls) <- M.lookup n `fmap` gets layouts - ml' <- modifyLayout l (SomeMessage a) `catchX` return (Just l) - whenJust ml' $ \l' -> do modify $ \s -> s { layouts = M.insert n (l',ls) (layouts s) } - refresh +sendMessage a = do w <- (W.workspace . W.current) `fmap` gets windowset + ml' <- modifyLayout (W.layout w) (SomeMessage a) `catchX` return Nothing + whenJust ml' $ \l' -> + do windows $ \ws -> ws { W.current = (W.current ws) + { W.workspace = (W.workspace $ W.current ws) + { W.layout = l' }}} hunk ./Operations.hs 322 -broadcastMessage a = do - ol <- gets layouts - nl <- T.forM ol $ \ (l,ls) -> maybe (l,ls) (flip (,) ls) `fmap` - (modifyLayout l (SomeMessage a) `catchX` return (Just l)) - modify $ \s -> s { layouts = nl } +broadcastMessage a = runOnWorkspaces modw + where modw w = do ml' <- modifyLayout (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } + +runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X () +runOnWorkspaces job = do ws <- gets windowset + h <- mapM job $ W.hidden ws + c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s)) + $ W.current ws : W.visible ws + modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } } hunk ./XMonad.hs 18 - X, WindowSet, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), SomeLayout(..), readLayout, + X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), SomeLayout(..), readLayout, hunk ./XMonad.hs 46 - , layouts :: !(M.Map WorkspaceId (SomeLayout Window, [SomeLayout Window])) - -- ^ mapping of workspaces to descriptions of their layouts hunk ./XMonad.hs 54 +type WindowSpace = Workspace WorkspaceId (SomeLayout Window) Window hunk ./Config.hs-boot 3 -import Graphics.X11.Xlib (KeyMask) +import Graphics.X11.Xlib (KeyMask,Window) hunk ./Config.hs-boot 9 +defaultLayouts :: [SomeLayout Window] hunk ./Operations.hs 21 -import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask) +import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask,defaultLayouts) hunk ./Operations.hs 108 +instance Read (SomeLayout Window) where + readsPrec _ = readLayout defaultLayouts +instance Layout SomeLayout Window where + doLayout (SomeLayout l) r s = fmap (fmap $ fmap SomeLayout) $ doLayout l r s + modifyLayout (SomeLayout l) = fmap (fmap SomeLayout) . modifyLayout l + hunk ./XMonad.hs 134 + hunk ./XMonad.hs 137 -instance Read (SomeLayout a) where - readsPrec _ _ = [] -- We can't read an existential type!!! hunk ./XMonad.hs 147 - -instance Layout SomeLayout a where - doLayout (SomeLayout l) r s = fmap (fmap $ fmap SomeLayout) $ doLayout l r s - modifyLayout (SomeLayout l) = fmap (fmap SomeLayout) . modifyLayout l hunk ./Config.hs 95 -defaultLayouts :: [SomeLayout Window] -defaultLayouts = [ SomeLayout tiled - , SomeLayout $ Mirror tiled - , SomeLayout Full +defaultLayouts :: [(String, SomeLayout Window)] +defaultLayouts = [("tall", SomeLayout tiled) + ,("wide", SomeLayout $ Mirror tiled) + ,("full", SomeLayout Full) hunk ./Config.hs 138 - , ((modMask, xK_space ), switchLayout) -- %! Rotate through the available layout algorithms + , ((modMask, xK_space ), sendMessage NextLayout) -- %! Rotate through the available layout algorithms hunk ./Config.hs-boot 9 -defaultLayouts :: [SomeLayout Window] +defaultLayouts :: [(String, SomeLayout Window)] hunk ./Main.hs 55 - | otherwise = new (fst safeLayouts) workspaces $ zipWith SD xinesc gaps + | otherwise = new (SomeLayout $ LayoutSelection safeLayouts) + workspaces $ zipWith SD xinesc gaps hunk ./Main.hs 59 - safeLayouts = case defaultLayouts of [] -> (SomeLayout Full, []); (x:xs) -> (x,xs) + safeLayouts = if null defaultLayouts then [("full",SomeLayout Full)] else defaultLayouts hunk ./Operations.hs 24 -import Data.List (nub, (\\), find) +import Data.List (nub, (\\), find, partition) hunk ./Operations.hs 108 -instance Read (SomeLayout Window) where - readsPrec _ = readLayout defaultLayouts -instance Layout SomeLayout Window where - doLayout (SomeLayout l) r s = fmap (fmap $ fmap SomeLayout) $ doLayout l r s - modifyLayout (SomeLayout l) = fmap (fmap SomeLayout) . modifyLayout l hunk ./Operations.hs 294 --- --------------------------------------------------------------------- --- Managing layout - --- | switchLayout. Switch to another layout scheme. Switches the --- layout of the current workspace. By convention, a window set as --- master in Tall mode remains as master in Wide mode. When switching --- from full screen to a tiling mode, the currently focused window --- becomes a master. When switching back , the focused window is --- uppermost. --- --- Note that the new layout's deconstructor will be called, so it should be --- idempotent. -switchLayout :: X () -switchLayout = return () - hunk ./Operations.hs 321 +-- Layout selection manager + +-- This is a layout that allows users to switch between various layout +-- options. This layout accepts three Messages, NextLayout, PrevLayout and +-- JumpToLayout. + +data ChangeLayout = NextLayout | PrevLayout | JumpToLayout String + deriving ( Eq, Show, Typeable ) +instance Message ChangeLayout + +instance ReadableSomeLayout Window where + defaults = map snd defaultLayouts + +data LayoutSelection a = LayoutSelection [(String, SomeLayout a)] + deriving ( Show, Read ) + +instance ReadableSomeLayout a => Layout LayoutSelection a where + doLayout (LayoutSelection ((n,l):ls)) r s = + do (x,ml') <- doLayout l r s + return (x, (\l' -> LayoutSelection ((n,l'):ls)) `fmap` ml') + doLayout (LayoutSelection []) r s = do (x,_) <- doLayout Full r s + return (x,Nothing) + -- respond to messages only when there's an actual choice: + modifyLayout (LayoutSelection ((n,l):ls@(_:_))) m + | Just NextLayout <- fromMessage m = switchl rls + | Just PrevLayout <- fromMessage m = switchl rls' + | Just (JumpToLayout x) <- fromMessage m = switchl (j x) + where rls (x:xs) = xs ++ [x] + rls [] = [] + rls' = reverse . rls . reverse + j s zs = case partition (\z -> s == fst z) zs of + (xs,ys) -> xs++ys + switchl f = do ml' <- modifyLayout l (SomeMessage UnDoLayout) + return $ Just (LayoutSelection $ f $ (n,fromMaybe l ml'):ls) + -- otherwise, or if we don't understand the message, pass it along to the real + -- layout: + modifyLayout (LayoutSelection ((n,l):ls)) m + = do ml' <- modifyLayout l m + return $ (\l' -> LayoutSelection ((n,l'):ls)) `fmap` ml' + -- Unless there is no layout... + modifyLayout (LayoutSelection []) _ = return Nothing hunk ./XMonad.hs 18 - X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), SomeLayout(..), readLayout, + X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), Layout(..), SomeLayout(..), ReadableSomeLayout(..), hunk ./XMonad.hs 135 +class ReadableSomeLayout a where + defaults :: [SomeLayout a] +instance ReadableSomeLayout a => Read (SomeLayout a) where + readsPrec _ = readLayout defaults +instance ReadableSomeLayout a => Layout SomeLayout a where + doLayout (SomeLayout l) r s = fmap (fmap $ fmap SomeLayout) $ doLayout l r s + modifyLayout (SomeLayout l) = fmap (fmap SomeLayout) . modifyLayout l + hunk ./Operations.hs 384 - modifyLayout Full _ = return Nothing -- no changes hunk ./XMonad.hs 155 + modifyLayout _ _ = return Nothing hunk ./StackSet.hs 392 -screens :: StackSet i a s sd -> [Screen i a s sd] +screens :: StackSet i l a s sd -> [Screen i l a s sd] hunk ./Operations.hs 105 -data UnDoLayout = UnDoLayout deriving ( Typeable, Eq ) -instance Message UnDoLayout +data LayoutMessages = Hide | ReleaseResources deriving ( Typeable, Eq ) +instance Message LayoutMessages hunk ./Operations.hs 112 - -- Notify visible layouts to remove decorations etc - -- We cannot use sendMessage because this must not call refresh ever, - -- and must be called on all visible workspaces. - broadcastMessage UnDoLayout hunk ./Operations.hs 118 + -- notify non visibility + let oldvistags = map (W.tag . W.workspace) $ W.current old : W.visible old + gottenHidden = filter (\w -> elem w oldvistags) $ map W.tag $ W.hidden ws + sendMessageToWorkspaces Hide gottenHidden + hunk ./Operations.hs 306 +-- | Send a message to a list of workspaces' layouts, without necessarily refreshing. +sendMessageToWorkspaces :: Message a => a -> [WorkspaceId] -> X () +sendMessageToWorkspaces a l = runOnWorkspaces modw + where modw w = if W.tag w `elem` l + then do ml' <- modifyLayout (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } + else return w + hunk ./Operations.hs 362 - switchl f = do ml' <- modifyLayout l (SomeMessage UnDoLayout) + switchl f = do ml' <- modifyLayout l (SomeMessage Hide) hunk ./Config.hs 169 - , ((modMask , xK_q ), restart Nothing True) -- %! Restart xmonad + , ((modMask , xK_q ), broadcastMessage ReleaseResources >> restart Nothing True) -- %! Restart xmonad hunk ./Config.hs 95 -defaultLayouts :: [(String, SomeLayout Window)] -defaultLayouts = [("tall", SomeLayout tiled) - ,("wide", SomeLayout $ Mirror tiled) - ,("full", SomeLayout Full) +defaultLayouts :: [SomeLayout Window] +defaultLayouts = [SomeLayout tiled + ,SomeLayout $ Mirror tiled + ,SomeLayout Full hunk ./Config.hs-boot 9 -defaultLayouts :: [(String, SomeLayout Window)] +defaultLayouts :: [SomeLayout Window] hunk ./Main.hs 59 - safeLayouts = if null defaultLayouts then [("full",SomeLayout Full)] else defaultLayouts + safeLayouts = if null defaultLayouts then [SomeLayout Full] else defaultLayouts hunk ./Operations.hs 341 - defaults = map snd defaultLayouts + defaults = SomeLayout (LayoutSelection defaultLayouts) : + SomeLayout Full : SomeLayout (Tall 1 0.1 0.5) : + SomeLayout (Mirror $ Tall 1 0.1 0.5) : defaultLayouts hunk ./Operations.hs 345 -data LayoutSelection a = LayoutSelection [(String, SomeLayout a)] +data LayoutSelection a = LayoutSelection [SomeLayout a] hunk ./Operations.hs 349 - doLayout (LayoutSelection ((n,l):ls)) r s = + doLayout (LayoutSelection (l:ls)) r s = hunk ./Operations.hs 351 - return (x, (\l' -> LayoutSelection ((n,l'):ls)) `fmap` ml') + return (x, (\l' -> LayoutSelection (l':ls)) `fmap` ml') hunk ./Operations.hs 355 - modifyLayout (LayoutSelection ((n,l):ls@(_:_))) m + modifyLayout (LayoutSelection (l:ls@(_:_))) m hunk ./Operations.hs 362 - j s zs = case partition (\z -> s == fst z) zs of + j s zs = case partition (\z -> s == description z) zs of hunk ./Operations.hs 365 - return $ Just (LayoutSelection $ f $ (n,fromMaybe l ml'):ls) + return $ Just (LayoutSelection $ f $ fromMaybe l ml':ls) hunk ./Operations.hs 368 - modifyLayout (LayoutSelection ((n,l):ls)) m + modifyLayout (LayoutSelection (l:ls)) m hunk ./Operations.hs 370 - return $ (\l' -> LayoutSelection ((n,l'):ls)) `fmap` ml' + return $ (\l' -> LayoutSelection (l':ls)) `fmap` ml' hunk ./Operations.hs 409 + description _ = "Tall" hunk ./Operations.hs 422 + description (Mirror l) = "Mirror "++ description l hunk ./XMonad.hs 156 + description :: layout a -> String + description = show hunk ./Operations.hs 393 -instance Layout Full a where - doLayout Full sc (W.Stack f _ _) = return ([(f, sc)], Nothing) +instance Layout Full a hunk ./XMonad.hs 154 + doLayout l r s = return (pureLayout l r s, Nothing) + pureLayout :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)] + pureLayout _ r s = [(focus s, r)] + replace ./Operations.hs [A-Za-z_0-9] modifyLayout handleMessage replace ./XMonad.hs [A-Za-z_0-9] modifyLayout handleMessage hunk ./Config.hs 95 +otherPossibleLayouts :: [SomeLayout Window] +otherPossibleLayouts = [SomeLayout $ Tall 1 1 1 + ,SomeLayout $ Mirror $ Tall 1 1 1 + ,SomeLayout Full + -- Extension-provided layouts + ] + hunk ./Config.hs-boot 9 -defaultLayouts :: [SomeLayout Window] +defaultLayouts, otherPossibleLayouts :: [SomeLayout Window] hunk ./Operations.hs 21 -import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask,defaultLayouts) +import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask,defaultLayouts,otherPossibleLayouts) hunk ./Operations.hs 343 - SomeLayout (Mirror $ Tall 1 0.1 0.5) : defaultLayouts + SomeLayout (Mirror $ Tall 1 0.1 0.5) : + defaultLayouts ++ otherPossibleLayouts hunk ./XMonad.hs 147 -readLayout ls s = concatMap rl ls +readLayout ls s = case concatMap rl ls of + (x:_) -> [x] + [] -> [] hunk ./XMonad.hs 147 -readLayout ls s = case concatMap rl ls of - (x:_) -> [x] - [] -> [] +readLayout ls s = take 1 $ concatMap rl ls + -- We take the first parse only, because multiple matches + -- indicate a bad parse. hunk ./Operations.hs 360 + | Just ReleaseResources <- fromMessage m = + do mlls' <- mapM (\ll -> handleMessage ll m) (l:ls) + let lls' = zipWith (\x mx -> maybe x id mx) (l:ls) mlls' + return $ Just $ LayoutSelection lls' hunk ./Operations.hs 52 - -- FIXME: This is pretty awkward. We can't can't let "refresh" happen - -- before the call to float, because that will resize the window and - -- lose the default sizing. - hunk ./Operations.hs 53 + hunk ./Operations.hs 56 - if isFixedSize || isTransient - then do modify $ \s -> s { windowset = W.insertUp w (windowset s) } - float w -- \^^ now go the refresh. - else windows $ W.insertUp w + + (sc, rr) <- floatLocation w + let f ws | isFixedSize || isTransient = W.float w rr . W.insertUp w . W.view i $ ws + | otherwise = W.insertUp w ws + where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws + windows f hunk ./StackSet.hs 498 -focusMaster :: StackSet i a s sd -> StackSet i a s sd +focusMaster :: StackSet i l a s sd -> StackSet i l a s sd hunk ./Config.hs 95 -otherPossibleLayouts :: [SomeLayout Window] -otherPossibleLayouts = [SomeLayout $ Tall 1 1 1 - ,SomeLayout $ Mirror $ Tall 1 1 1 - ,SomeLayout Full - -- Extension-provided layouts - ] - hunk ./Config.hs 115 +otherPossibleLayouts :: [SomeLayout Window] +otherPossibleLayouts = [] + hunk ./Config.hs 96 -defaultLayouts = [SomeLayout tiled - ,SomeLayout $ Mirror tiled - ,SomeLayout Full +defaultLayouts = [ SomeLayout tiled + , SomeLayout $ Mirror tiled + , SomeLayout Full hunk ./Config.hs 115 +-- | +-- A list of layouts which, in addition to the defaultLayouts, xmonad can +-- deserialize. hunk ./Config.hs 145 + , ((modMask .|. shiftMask, xK_space ), setLayout $ SomeLayout $ LayoutSelection defaultLayouts) -- %! Reset the layouts on the current workspace to default hunk ./Operations.hs 328 + +-- | Set the layout of the currently viewed workspace +setLayout :: SomeLayout Window -> X () +setLayout l = do + sendMessage ReleaseResources + windows $ \ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) + -> ss {W.current = c { W.workspace = ws { W.layout = l } } } hunk ./Operations.hs 332 - sendMessage ReleaseResources - windows $ \ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) - -> ss {W.current = c { W.workspace = ws { W.layout = l } } } + ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) <- gets windowset + handleMessage (W.layout ws) (SomeMessage ReleaseResources) + windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = l } } } hunk ./Operations.hs 58 - let f ws | isFixedSize || isTransient = W.float w rr . W.insertUp w . W.view i $ ws + -- ensure that float windows don't go over the edge of the screen + let adjust (W.RationalRect x y wid h) | x + wid >= 1 || y + wid >= 1 || x <= 0 || y <= 0 + = W.RationalRect (0.5 - wid/2) (0.5 - h/2) wid h + adjust r = r + + let f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws hunk ./Operations.hs 520 - rr = (W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) - ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) - (fi (wa_width wa + bw*2) % fi (rect_width sr)) - (fi (wa_height wa + bw*2) % fi (rect_height sr))) + rr = W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) + ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) + (fi (wa_width wa + bw*2) % fi (rect_width sr)) + (fi (wa_height wa + bw*2) % fi (rect_height sr)) hunk ./Operations.hs 389 + + description (LayoutSelection (x:_)) = description x + description _ = "default" hunk ./XMonad.hs 142 + description (SomeLayout l) = description l hunk ./Main.hs 54 - , [(x, "")] <- reads s = x - | otherwise = new (SomeLayout $ LayoutSelection safeLayouts) - workspaces $ zipWith SD xinesc gaps + , [(x, "")] <- reads s = W.ensureTags defaultLayout workspaces x + | otherwise = new defaultLayout workspaces $ zipWith SD xinesc gaps + defaultLayout = SomeLayout $ LayoutSelection safeLayouts hunk ./StackSet.hs 27 - focusWindow, tagMember, member, findIndex, + focusWindow, tagMember, renameTag, ensureTags, member, findIndex, hunk ./StackSet.hs 42 +import Data.List ( (\\) ) hunk ./StackSet.hs 404 +-- | Rename a given tag if present in the StackSet. +renameTag :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd +renameTag o n s = s { current = rs $ current s + , visible = map rs $ visible s + , hidden = map rw $ hidden s } + where rs scr = scr { workspace = rw $ workspace scr } + rw w = if tag w == o then w { tag = n } else w + +-- | Ensure that a given set of tags is present. +ensureTags :: Eq i => l -> [i] -> StackSet i l a s sd -> StackSet i l a s sd +ensureTags l allt st = et allt (map tag (workspaces st) \\ allt) st + where et [] _ s = s + et (i:is) rn s | i `tagMember` s = et is rn s + et (i:is) [] s = et is [] (s { hidden = Workspace i l Nothing : hidden s }) + et (i:is) (r:rs) s = et is rs $ renameTag r i s + hunk ./Operations.hs 1 -{-# OPTIONS -fno-warn-orphans -fglasgow-exts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} + hunk ./XMonad.hs 1 -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE FlexibleInstances #-} + hunk ./StackSet.hs 170 +-- | A structure for window geometries hunk ./StackSet.hs 220 - - hunk ./StackSet.hs 243 - where screenEq x y = screen x == screen y - tagEq x y = tag x == tag y + where screenEq x y = screen x == screen y + tagEq x y = tag x == tag y hunk ./StackSet.hs 259 - | any wTag (hidden ws) = view w ws - | (Just s) <- L.find (wTag . workspace) (visible ws) - = ws { current = (current ws) { workspace = workspace s } - , visible = s { workspace = workspace (current ws) } - : L.filter (not . wTag . workspace) (visible ws) } - | otherwise = ws - where - wTag = (w == ) . tag + | any wTag (hidden ws) = view w ws + | (Just s) <- L.find (wTag . workspace) (visible ws) + = ws { current = (current ws) { workspace = workspace s } + , visible = s { workspace = workspace (current ws) } + : L.filter (not . wTag . workspace) (visible ws) } + | otherwise = ws + where wTag = (w == ) . tag hunk ./StackSet.hs 323 -differentiate [] = Nothing +differentiate [] = Nothing hunk ./StackSet.hs 388 - - hunk ./StackSet.hs 400 --- | Rename a given tag if present in the StackSet. -renameTag :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd -renameTag o n s = s { current = rs $ current s - , visible = map rs $ visible s - , hidden = map rw $ hidden s } - where rs scr = scr { workspace = rw $ workspace scr } - rw w = if tag w == o then w { tag = n } else w - --- | Ensure that a given set of tags is present. -ensureTags :: Eq i => l -> [i] -> StackSet i l a s sd -> StackSet i l a s sd -ensureTags l allt st = et allt (map tag (workspaces st) \\ allt) st - where et [] _ s = s - et (i:is) rn s | i `tagMember` s = et is rn s - et (i:is) [] s = et is [] (s { hidden = Workspace i l Nothing : hidden s }) - et (i:is) (r:rs) s = et is rs $ renameTag r i s - hunk ./StackSet.hs 36 - shift, shiftWin + shift, shiftWin, + + -- for testing + abort hunk ./StackSet.hs 238 - = s { current = x, visible = current s : L.deleteBy screenEq x (visible s) } + = s { current = x, visible = current s : L.deleteBy (equating screen) x (visible s) } hunk ./StackSet.hs 243 - , hidden = workspace (current s) : L.deleteBy tagEq x (hidden s) } + , hidden = workspace (current s) : L.deleteBy (equating tag) x (hidden s) } hunk ./StackSet.hs 245 - | otherwise = s - where screenEq x y = screen x == screen y - tagEq x y = tag x == tag y + | otherwise = s -- can't happen? + where equating f = \x y -> f x == f y hunk ./StackSet.hs 250 + -- + -- and now tags are not monotonic, what happens here? hunk ./tests/Properties.hs 14 +import qualified Control.Exception as C hunk ./tests/Properties.hs 17 +import System.IO.Unsafe hunk ./tests/Properties.hs 549 +-- looking up the tag of the current workspace should always produce a tag. +prop_lookup_current (x :: T) = lookupWorkspace scr x == Just tg + where + (Screen (Workspace tg _ _) scr _) = current x + +-- --------------------------------------------------------------------- +-- testing for failure + +-- and help out hpc +prop_abort x = unsafePerformIO $ C.catch (abort "fail") + (\e -> return $ show e == "xmonad: StackSet: fail" ) + where + _ = x :: Int + +-- new should fail with an abort +prop_new_abort x = unsafePerformIO $ C.catch f + (\e -> return $ show e == "xmonad: StackSet: non-positive argument to StackSet.new" ) + where + f = new undefined{-layout-} [] [] `seq` return False + + _ = x :: Int + hunk ./tests/Properties.hs 702 + ,("lookupTagOnScreen", mytest prop_lookup_current) + + -- testing for failure: + ,("abort fails", mytest prop_abort) + ,("new fails with abort", mytest prop_new_abort) hunk ./StackSet.hs 240 - | Just x <- L.find ((i==).tag) (hidden s) + | Just x <- L.find ((i==).tag) (hidden s) -- must be hidden then hunk ./StackSet.hs 245 - | otherwise = s -- can't happen? +-- | otherwise = s -- can't happen: all workspaces are either invalid, current, visible, or hidden + hunk ./StackSet.hs 529 -shiftWin n w s | from == Nothing = s +shiftWin n w s | from == Nothing = s -- not found hunk ./StackSet.hs 532 - where go = on n (insertUp w) . on (fromJust from) (delete' w) $ s + where from = findIndex w s + + go = on n (insertUp w) . on (fromJust from) (delete' w) $ s hunk ./StackSet.hs 536 - from = findIndex w s hunk ./StackSet.hs 538 + hunk ./tests/Properties.hs 522 +-- shiftWin on a non-existant window is identity +prop_shift_win_indentity i w (x :: T) = + i `tagMember` x && not (w `member` x) ==> shiftWin i w x == x + hunk ./tests/Properties.hs 575 +-- prop_view_should_fail = view {- with some bogus data -} + hunk ./tests/Properties.hs 711 - ,("abort fails", mytest prop_abort) - ,("new fails with abort", mytest prop_new_abort) + ,("abort fails", mytest prop_abort) + ,("new fails with abort", mytest prop_new_abort) + ,("shiftWin identity", mytest prop_shift_win_indentity) hunk ./StackSet.hs 405 --- | --- Finding if a window is in the stackset is a little tedious. We could --- keep a cache :: Map a i, but with more bookkeeping. --- +-- | Rename a given tag if present in the StackSet. +renameTag :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd +renameTag o n s = s { current = rs $ current s + , visible = map rs $ visible s + , hidden = map rw $ hidden s } + where rs scr = scr { workspace = rw $ workspace scr } + rw w = if tag w == o then w { tag = n } else w + +-- | Ensure that a given set of tags is present. +ensureTags :: Eq i => l -> [i] -> StackSet i l a s sd -> StackSet i l a s sd +ensureTags l allt st = et allt (map tag (workspaces st) \\ allt) st + where et [] _ s = s + et (i:is) rn s | i `tagMember` s = et is rn s + et (i:is) [] s = et is [] (s { hidden = Workspace i l Nothing : hidden s }) + et (i:is) (r:rs) s = et is rs $ renameTag r i s changepref test runghc tests/Properties.hs && cat *.hs | runghc tests/loc.hs echo main | ghci -v0 -fglasgow-exts tests/Properties.hs && cat *.hs | runhaskell tests/loc.hs hunk ./Config.hs 93 --- The default set of tiling algorithms +-- A list of layouts which, in addition to the defaultLayouts, xmonad can +-- deserialize. +possibleLayouts :: [SomeLayout Window] +possibleLayouts = [defaultLayout + -- Extension-provided layouts + ] ++ defaultLayouts + +-- | +-- The default tiling algorithm hunk ./Config.hs 103 +defaultLayout :: SomeLayout Window +defaultLayout = SomeLayout $ LayoutSelection defaultLayouts + hunk ./Config.hs 156 - , ((modMask .|. shiftMask, xK_space ), setLayout $ SomeLayout $ LayoutSelection defaultLayouts) -- %! Reset the layouts on the current workspace to default + , ((modMask .|. shiftMask, xK_space ), setLayout defaultLayout) -- %! Reset the layouts on the current workspace to default hunk ./Config.hs-boot 9 -defaultLayouts, otherPossibleLayouts :: [SomeLayout Window] +possibleLayouts :: [SomeLayout Window] hunk ./Main.hs 56 - defaultLayout = SomeLayout $ LayoutSelection safeLayouts hunk ./Main.hs 58 - safeLayouts = if null defaultLayouts then [SomeLayout Full] else defaultLayouts hunk ./Operations.hs 23 -import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask,defaultLayouts,otherPossibleLayouts) +import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask,possibleLayouts) hunk ./Operations.hs 354 - defaults = SomeLayout (LayoutSelection defaultLayouts) : + defaults = SomeLayout (LayoutSelection []) : hunk ./Operations.hs 357 - defaultLayouts ++ otherPossibleLayouts + possibleLayouts hunk ./StackSet.hs 1 +{-# LANGUAGE PatternGuards #-} + hunk ./Operations.hs 125 - let oldvistags = map (W.tag . W.workspace) $ W.current old : W.visible old - gottenHidden = filter (\w -> elem w oldvistags) $ map W.tag $ W.hidden ws - sendMessageToWorkspaces Hide gottenHidden + let tags_oldvisible = map (W.tag . W.workspace) $ W.current old : W.visible old + gottenhidden = filter (`elem` tags_oldvisible) $ map W.tag $ W.hidden ws + sendMessageToWorkspaces Hide gottenhidden hunk ./Main.hs 181 -handle e@(MappingNotifyEvent {ev_window = w}) = do +handle e@(MappingNotifyEvent {}) = do hunk ./Main.hs 183 - when (ev_request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w + when (ev_request e == mappingKeyboard) $ withDisplay $ \dpy -> do + rootw <- asks theRoot + io $ grabKeys dpy rootw hunk ./tests/Properties.hs 558 +-- looking at a visible tag +prop_lookup_visible (x :: T) = + visible x /= [] ==> + fromJust (lookupWorkspace scr x) `elem` tags + where + tags = [ tag (workspace y) | y <- visible x ] + scr = last [ screen y | y <- visible x ] + + hunk ./tests/Properties.hs 718 + ,("lookupTagOnVisbleScreen", mytest prop_lookup_visible) hunk ./tests/Properties.hs 586 +-- screens makes sense +prop_screens_works (x :: T) = screens x == current x : visible x + +------------------------------------------------------------------------ +-- renaming tags + +-- | Rename a given tag if present in the StackSet. +-- 408 renameTag :: Eq i => i -> i -> StackSet i l a s sd -> StackSet i l a s sd + +prop_rename1 (x::T) o n = o `tagMember` x && not (n `tagMember` x) ==> + let y = renameTag o n x + in n `tagMember` y + +prop_ensure (x :: T) l xs = let y = ensureTags l xs x + in and [ n `tagMember` y | n <- xs ] + hunk ./tests/Properties.hs 735 + ,("screens works", mytest prop_screens_works) + ,("renaming works", mytest prop_rename1) + ,("ensure works", mytest prop_ensure) hunk ./tests/Properties.hs 744 + -- renaming + hunk ./tests/Properties.hs 550 - else focus (fromJust (differentiate xs)) == head xs + else (differentiate xs) == Just (Stack (head xs) [] (tail xs)) hunk ./Operations.hs 121 + XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask + whenJust (W.peek old) $ \otherw -> io $ setWindowBorder d otherw nbc hunk ./Operations.hs 124 - d <- asks display hunk ./Operations.hs 167 + whenJust (W.peek ws) $ \w -> io $ setWindowBorder d w fbc hunk ./Operations.hs 289 - XConf { display = dpy , normalBorder = nbc, focusedBorder = fbc } <- ask + dpy <- asks display hunk ./Operations.hs 295 - io $ setWindowBorder dpy otherw nbc hunk ./Operations.hs 300 - io $ setWindowBorder dpy w fbc hunk ./StackSet.hs 24 - screens, workspaces, + screens, workspaces, allWindows, hunk ./StackSet.hs 46 -import qualified Data.List as L (deleteBy,find,splitAt,filter) +import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) hunk ./StackSet.hs 403 +-- | Get a list of all windows in the StackSet in no particular order +allWindows :: Eq a => StackSet i l a s sd -> [a] +allWindows = L.nub . concatMap (integrate' . stack) . workspaces + hunk ./tests/Properties.hs 366 +prop_allWindowsMember w (x :: T) = (w `elem` allWindows x) ==> member w x + hunk ./tests/Properties.hs 692 + ,("allWindows/member" , mytest prop_allWindowsMember) hunk ./Config.hs 64 + +manageHook :: Window -> X (WindowSet -> WindowSet) +manageHook _ = return id hunk ./Config.hs-boot 10 +manageHook :: Window -> X (WindowSet -> WindowSet) hunk ./Operations.hs 23 -import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask,possibleLayouts) +import {-# SOURCE #-} Config (borderWidth,logHook,manageHook,numlockMask,possibleLayouts) hunk ./Operations.hs 52 - setInitialProperties w - hunk ./Operations.hs 63 - let f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws + f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws hunk ./Operations.hs 66 - windows f + g <- manageHook w + windows (g . f) hunk ./Operations.hs 121 + mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) hunk ./Main.hs 53 - let winset | ("--resume" : s : _) <- args + let initialWinset = new defaultLayout workspaces $ zipWith SD xinesc gaps + + winset | ("--resume" : s : _) <- args hunk ./Main.hs 57 - | otherwise = new defaultLayout workspaces $ zipWith SD xinesc gaps + | otherwise = initialWinset hunk ./Main.hs 66 - { windowset = winset + { windowset = initialWinset hunk ./Main.hs 82 - ws <- scan dpy rootw -- on the resume case, will pick up new windows hunk ./Main.hs 85 - -- walk workspace, resetting X states/mask for windows - -- TODO, general iterators for these lists. - sequence_ [ setInitialProperties w >> reveal w - | wk <- map W.workspace (W.current winset : W.visible winset) - , w <- W.integrate' (W.stack wk) ] - - sequence_ [ setInitialProperties w >> hide w - | wk <- W.hidden winset - , w <- W.integrate' (W.stack wk) ] + -- bootstrap the windowset, Operations.windows will identify all + -- the windows in winset as new and set initial properties for + -- those windows + windows (const winset) hunk ./Main.hs 90 - mapM_ manage ws -- find new windows - refresh + -- scan for all top-level windows, add the unmanaged ones to the + -- windowset + ws <- io $ scan dpy rootw + mapM_ manage ws hunk ./Config.hs 31 +import Graphics.X11.Xlib.Extras (ClassHint(..)) hunk ./Config.hs 66 -manageHook :: Window -> X (WindowSet -> WindowSet) -manageHook _ = return id +manageHook :: Window -> ClassHint -> X (WindowSet -> WindowSet) +manageHook _ _ = return id hunk ./Config.hs-boot 4 +import Graphics.X11.Xlib.Extras (ClassHint) hunk ./Config.hs-boot 11 -manageHook :: Window -> X (WindowSet -> WindowSet) +manageHook :: Window -> ClassHint -> X (WindowSet -> WindowSet) hunk ./Operations.hs 66 - g <- manageHook w + g <- manageHook w =<< io (getClassHint d w) hunk ./Config.hs 66 -manageHook :: Window -> ClassHint -> X (WindowSet -> WindowSet) +-- | manageHook. Execute arbitrary actions and WindowSet manipulations when +-- managing a new window. +manageHook :: Window -> (String, String, String) -> X (WindowSet -> WindowSet) hunk ./Config.hs-boot 11 -manageHook :: Window -> ClassHint -> X (WindowSet -> WindowSet) +manageHook :: Window -> (String, String, String) -> X (WindowSet -> WindowSet) hunk ./Operations.hs 66 - g <- manageHook w =<< io (getClassHint d w) + + n <- fmap (fromMaybe "") $ io $ fetchName d w + (ClassHint rn rc) <- io $ getClassHint d w + g <- manageHook w (n, rn, rc) hunk ./Config.hs 69 +-- Don't manage Gnome's panel or KDE's kicker: +manageHook w (_, "gnome-panel", _) = reveal w >> return (W.delete w) +manageHook w (_, "kicker", _) = reveal w >> return (W.delete w) +-- The default rule, do not edit this line. hunk ./Config.hs 72 +-- Float mplayer windows: +manageHook w (_, _, "MPlayer") = do (_, rr) <- floatLocation w; return (W.float w rr) hunk ./Config.hs 69 --- Don't manage Gnome's panel or KDE's kicker: -manageHook w (_, "gnome-panel", _) = reveal w >> return (W.delete w) -manageHook w (_, "kicker", _) = reveal w >> return (W.delete w) + hunk ./Config.hs 72 + +-- Don't manage various panels and desktop windows: +manageHook w (_, c, _) | c `elem` ignore = reveal w >> return (W.delete w) + where ignore = ["gnome-panel", "kicker", "desktop_window"] + hunk ./Config.hs 75 - where ignore = ["gnome-panel", "kicker", "desktop_window"] + where ignore = ["gnome-panel", "desktop_window", "kicker", "kdesktop"] replace ./Config.hs [A-Za-z_0-9] SomeLayout Layout replace ./Config.hs-boot [A-Za-z_0-9] SomeLayout Layout replace ./Operations.hs [A-Za-z_0-9] Layout LayoutClass replace ./Operations.hs [A-Za-z_0-9] ReadableSomeLayout ReadableLayout replace ./Operations.hs [A-Za-z_0-9] SomeLayout Layout replace ./XMonad.hs [A-Za-z_0-9] Layout LayoutClass replace ./XMonad.hs [A-Za-z_0-9] ReadableSomeLayout ReadableLayout replace ./XMonad.hs [A-Za-z_0-9] SomeLayout Layout hunk ./Config.hs 108 --- A list of layouts which, in addition to the defaultLayouts, xmonad can --- deserialize. +-- A list of layouts which xmonad can deserialize. hunk ./Config.hs 140 --- | --- A list of layouts which, in addition to the defaultLayouts, xmonad can --- deserialize. -otherPossibleLayouts :: [Layout Window] -otherPossibleLayouts = [] - hunk ./Config.hs 115 --- The default tiling algorithm +-- The default Layout, a selector between the layouts listed below in +-- defaultLayouts. hunk ./Config.hs 121 +-- | +-- The list of selectable layouts hunk ./Config.hs 107 --- | --- A list of layouts which xmonad can deserialize. -possibleLayouts :: [Layout Window] -possibleLayouts = [defaultLayout - -- Extension-provided layouts - ] ++ defaultLayouts - hunk ./Config.hs 136 +-- | +-- A list of layouts which xmonad can deserialize. +possibleLayouts :: [Layout Window] +possibleLayouts = [defaultLayout + -- Extension-provided layouts + ] ++ defaultLayouts + hunk ./Config.hs 70 --- Float mplayer windows: -manageHook w (_, _, "MPlayer") = do (_, rr) <- floatLocation w; return (W.float w rr) +-- Float various windows: +manageHook w (_, _, c) | c `elem` floats = do (_, rr) <- floatLocation w; return (W.float w rr) + where floats = ["MPlayer", "Gimp"] hunk ./Config.hs 31 -import Graphics.X11.Xlib.Extras (ClassHint(..)) hunk ./Config.hs-boot 4 -import Graphics.X11.Xlib.Extras (ClassHint) hunk ./Config.hs 70 -manageHook w (_, _, c) | c `elem` floats = do (_, rr) <- floatLocation w; return (W.float w rr) +manageHook w (_, _, c) | c `elem` floats = fmap (W.float w . snd) (floatLocation w) hunk ./Config.hs 65 --- | manageHook. Execute arbitrary actions and WindowSet manipulations when +-- | +-- Execute arbitrary actions and WindowSet manipulations when hunk ./Config.hs 68 -manageHook :: Window -> (String, String, String) -> X (WindowSet -> WindowSet) +manageHook :: Window -- ^ the new window to manage + -> String -- ^ window title + -> String -- ^ window resource name + -> String -- ^ window resource class + -> X (WindowSet -> WindowSet) hunk ./Config.hs 75 -manageHook w (_, _, c) | c `elem` floats = fmap (W.float w . snd) (floatLocation w) +manageHook w _ _ c | c `elem` floats = fmap (W.float w . snd) (floatLocation w) hunk ./Config.hs 79 -manageHook w (_, c, _) | c `elem` ignore = reveal w >> return (W.delete w) +manageHook w _ n _ | n `elem` ignore = reveal w >> return (W.delete w) hunk ./Config.hs 83 -manageHook _ _ = return id +manageHook _ _ _ _ = return id hunk ./Config.hs-boot 10 -manageHook :: Window -> (String, String, String) -> X (WindowSet -> WindowSet) +manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) hunk ./Operations.hs 69 - g <- manageHook w (n, rn, rc) + g <- manageHook w n rn rc hunk ./XMonad.hs 232 --- Grab the X server (lock it) from the X monad --- withServerX :: X () -> X () --- withServerX f = withDisplay $ \dpy -> do --- io $ grabServer dpy --- f --- io $ ungrabServer dpy - addfile ./tests/Main.hs hunk ./tests/Main.hs 1 +module Main where + +import qualified Properties + +-- This will run all of the QC files for xmonad core. Currently, that's just +-- Properties. If any more get added, sequence the main actions together. +main = do + Properties.main hunk ./tests/Properties.hs 2 +module Properties where hunk ./StackSet.hs 28 - focusUp, focusDown, focusMaster, - focusWindow, tagMember, renameTag, ensureTags, member, findIndex, + focusUp, focusDown, focusMaster, focusWindow, + tagMember, renameTag, ensureTags, member, findIndex, mapLayout, hunk ./StackSet.hs 427 +mapLayout :: (l -> l') -> StackSet i l a s sd -> StackSet i l' a s sd +mapLayout f (StackSet v vs hs m) = StackSet (fScreen v) (map fScreen vs) (map fWorkspace hs) m + where + fScreen (Screen ws s sd) = Screen (fWorkspace ws) s sd + fWorkspace (Workspace t l s) = Workspace t (f l) s + hunk ./tests/Properties.hs 605 +prop_mapLayoutId (x::T) = x == mapLayout id x + +prop_mapLayoutInverse (x::T) = x == mapLayout pred (mapLayout succ x) + hunk ./tests/Properties.hs 747 + ,("mapLayout id", mytest prop_mapLayoutId) + ,("mapLayout inverse", mytest prop_mapLayoutInverse) + hunk ./Main.hs 55 - winset | ("--resume" : s : _) <- args - , [(x, "")] <- reads s = W.ensureTags defaultLayout workspaces x - | otherwise = initialWinset + maybeRead s = case reads s of + [(x, "")] -> Just x + _ -> Nothing + + winset = fromMaybe initialWinset $ do + ("--resume" : s : _) <- return args + ws <- maybeRead s + return . W.ensureTags defaultLayout workspaces + $ W.mapLayout (fromMaybe defaultLayout . maybeRead) ws + hunk ./XMonad.hs 221 - args <- if resume then gets (("--resume":) . return . show . windowset) else return [] + args <- if resume then gets (("--resume":) . return . showWs . windowset) else return [] hunk ./XMonad.hs 223 + where showWs = show . mapLayout show hunk ./Main.hs 84 - grabKeys dpy rootw - grabButtons dpy rootw - - sync dpy False hunk ./Main.hs 88 + grabKeys + grabButtons + + io $ sync dpy False + hunk ./Main.hs 130 -grabKeys :: Display -> Window -> IO () -grabKeys dpy rootw = do - ungrabKey dpy anyKey anyModifier rootw +grabKeys :: X () +grabKeys = do + XConf { display = dpy, theRoot = rootw } <- ask + let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync + io $ ungrabKey dpy anyKey anyModifier rootw hunk ./Main.hs 136 - kc <- keysymToKeycode dpy sym + kc <- io $ keysymToKeycode dpy sym hunk ./Main.hs 141 - where grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync hunk ./Main.hs 142 -grabButtons :: Display -> Window -> IO () -grabButtons dpy rootw = do - ungrabButton dpy anyButton anyModifier rootw +grabButtons :: X () +grabButtons = do + XConf { display = dpy, theRoot = rootw } <- ask + let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask + grabModeAsync grabModeSync none none + io $ ungrabButton dpy anyButton anyModifier rootw hunk ./Main.hs 149 - where grab button mask = grabButton dpy button mask rootw False buttonPressMask - grabModeAsync grabModeSync none none hunk ./Main.hs 191 - when (ev_request e == mappingKeyboard) $ withDisplay $ \dpy -> do - rootw <- asks theRoot - io $ grabKeys dpy rootw + when (ev_request e == mappingKeyboard) grabKeys hunk ./Main.hs 254 --- the root may have configured +-- configuration changes in the root may mean display settings have changed hunk ./README 42 + + Firstly, you'll need the C X11 library headers. On many platforms, + these come pre-installed. For others, such as Debian, you can get + them from your package manager: + + apt-get install libx11-dev hunk ./tests/Properties.hs 544 + +-- check rectanges were set +prop_float_sets_geometry n (x :: T) = + n `member` x ==> let y = float n geom x in M.lookup y (floating x) == Just geom + where + geom = RationalRect 100 100 100 100 hunk ./tests/Properties.hs 546 +{- hunk ./tests/Properties.hs 551 +-} hunk ./StackSet.hs 413 -renameTag o n s = s { current = rs $ current s - , visible = map rs $ visible s - , hidden = map rw $ hidden s } - where rs scr = scr { workspace = rw $ workspace scr } - rw w = if tag w == o then w { tag = n } else w +renameTag o n = mapWorkspace rename + where rename w = if tag w == o then w { tag = n } else w hunk ./StackSet.hs 424 +-- | Map a function on all the workspaces in the StackSet. +mapWorkspace :: (Workspace i l a -> Workspace i l a) -> StackSet i l a s sd -> StackSet i l a s sd +mapWorkspace f s = s { current = updScr $ current s + , visible = map updScr $ visible s + , hidden = map f $ hidden s } + where updScr scr = scr { workspace = f $ workspace scr } + +-- | Map a function on all the layouts in the StackSet. changepref test echo main | ghci -v0 -fglasgow-exts tests/Properties.hs && cat *.hs | runhaskell tests/loc.hs echo main | ghci -v0 -fglasgow-exts -itests tests/Main.hs && cat *.hs | runhaskell tests/loc.hs hunk ./StackSet.hs 29 - tagMember, renameTag, ensureTags, member, findIndex, mapLayout, + tagMember, renameTag, ensureTags, member, findIndex, mapWorkspace, mapLayout, hunk ./StackSet.hs 426 -mapWorkspace f s = s { current = updScr $ current s - , visible = map updScr $ visible s - , hidden = map f $ hidden s } - where updScr scr = scr { workspace = f $ workspace scr } +mapWorkspace f s = s { current = updScr (current s) + , visible = map updScr (visible s) + , hidden = map f (hidden s) } + where updScr scr = scr { workspace = f (workspace scr) } hunk ./Operations.hs 426 - handleMessage (Tall nmaster delta frac) m = - return $ msum [fmap resize (fromMessage m) - ,fmap incmastern (fromMessage m)] + pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] hunk ./XMonad.hs 163 - handleMessage _ _ = return Nothing + handleMessage l = return . pureMessage l + pureMessage :: layout a -> SomeMessage -> Maybe (layout a) + pureMessage _ _ = Nothing hunk ./Main.hs 104 - forever $ handle =<< io (nextEvent dpy e >> getEvent e) + forever_ $ handle =<< io (nextEvent dpy e >> getEvent e) hunk ./Main.hs 106 - where forever a = a >> forever a + where forever_ a = a >> forever_ a hunk ./XMonad.hs 123 --- The different layout modes +data Layout a = forall l. LayoutClass l a => Layout (l a) + +-- | Comment me. +class ReadableLayout a where + defaults :: [Layout a] + +-- | The different layout modes hunk ./XMonad.hs 140 -data Layout a = forall l. LayoutClass l a => Layout (l a) +class (Show (layout a), Read (layout a)) => LayoutClass layout a where + doLayout :: layout a -> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a)) + doLayout l r s = return (pureLayout l r s, Nothing) + + pureLayout :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)] + pureLayout _ r s = [(focus s, r)] + + handleMessage :: layout a -> SomeMessage -> X (Maybe (layout a)) + handleMessage l = return . pureMessage l + + pureMessage :: layout a -> SomeMessage -> Maybe (layout a) + pureMessage _ _ = Nothing + + description :: layout a -> String + description = show hunk ./XMonad.hs 156 -class ReadableLayout a where - defaults :: [Layout a] hunk ./XMonad.hs 158 + hunk ./XMonad.hs 160 - doLayout (Layout l) r s = fmap (fmap $ fmap Layout) $ doLayout l r s + doLayout (Layout l) r s = fmap (fmap $ fmap Layout) $ doLayout l r s hunk ./XMonad.hs 162 - description (Layout l) = description l + description (Layout l) = description l hunk ./XMonad.hs 175 -class (Show (layout a), Read (layout a)) => LayoutClass layout a where - doLayout :: layout a -> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a)) - doLayout l r s = return (pureLayout l r s, Nothing) - pureLayout :: layout a -> Rectangle -> Stack a -> [(a, Rectangle)] - pureLayout _ r s = [(focus s, r)] - - handleMessage :: layout a -> SomeMessage -> X (Maybe (layout a)) - handleMessage l = return . pureMessage l - pureMessage :: layout a -> SomeMessage -> Maybe (layout a) - pureMessage _ _ = Nothing - description :: layout a -> String - description = show - hunk ./StackSet.hs 9 --- Maintainer : dons@cse.unsw.edu.au +-- Maintainer : dons@galois.com hunk ./tests/Properties.hs 613 +prop_mapWorkspaceId (x::T) = x == mapWorkspace id x + +prop_mapWorkspaceInverse (x::T) = x == mapWorkspace predTag (mapWorkspace succTag x) + where predTag w = w { tag = pred $ tag w } + succTag w = w { tag = succ $ tag w } + hunk ./tests/Properties.hs 761 + ,("mapWorkspace id", mytest prop_mapWorkspaceId) + ,("mapWorkspace inverse", mytest prop_mapWorkspaceInverse) hunk ./XMonad.hs 54 -type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail +type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail hunk ./XMonad.hs 63 +-- | TODO Comment me hunk ./XMonad.hs 124 +-- | XXX Comment me. hunk ./XMonad.hs 127 --- | Comment me. +-- | XXX Comment me. hunk ./XMonad.hs 137 --- 'handleMessage' performs message handling for that layout. If --- 'handleMessage' returns Nothing, then the layout did not respond to --- that message and the screen is not refreshed. Otherwise, 'handleMessage' --- returns an updated 'LayoutClass' and the screen is refreshed. --- + hunk ./XMonad.hs 139 + + -- | XXX Comment me. hunk ./XMonad.hs 144 + -- | XXX Comment me. hunk ./XMonad.hs 148 + -- | 'handleMessage' performs message handling for that layout. If + -- 'handleMessage' returns Nothing, then the layout did not respond to + -- that message and the screen is not refreshed. Otherwise, 'handleMessage' + -- returns an updated 'LayoutClass' and the screen is refreshed. + -- hunk ./XMonad.hs 156 + -- | XXX Comment me. hunk ./XMonad.hs 160 + -- | XXX Comment me. hunk ./XMonad.hs 175 +-- | XXX Comment me. hunk ./XMonad.hs 184 +-- | XXX Comment me. hunk ./Operations.hs 114 -instance Message LayoutMessages hunk ./Operations.hs 115 +instance Message LayoutMessages hunk ./Operations.hs 330 +-- | XXX comment me hunk ./Operations.hs 355 + hunk ./Operations.hs 412 -data IncMasterN = IncMasterN Int deriving Typeable + +data IncMasterN = IncMasterN Int deriving Typeable + hunk ./Operations.hs 421 + hunk ./Operations.hs 427 + hunk ./Operations.hs 489 +-- | XXX comment me hunk ./Operations.hs 531 + -- | XXX horrible hunk ./Operations.hs 582 +-- | XXX comment me hunk ./Operations.hs 594 +-- | XXX comment me hunk ./Operations.hs 617 +-- | XXX comment me hunk ./README 71 - darcs get http://darcs.haskell.org/~sjanssen/X11-extras + darcs get http://code.haskell.org/X11-extras hunk ./README 96 - darcs version: darcs get http://darcs.haskell.org/~sjanssen/XMonadContrib + darcs version: darcs get http://code.haskell.org/XMonadContrib hunk ./Main.hs 256 + +-- property notify +handle PropertyEvent { ev_event_type = t, ev_atom = a } + | t == propertyNotify && a == wM_NAME = do logHook hunk ./tests/loc.hs 12 -isntcomment "" = False hunk ./Operations.hs 2 -{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} hunk ./Operations.hs 5 --- \^^ deriving Typeable hunk ./XMonad.hs 1 -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} hunk ./Operations.hs 59 - let adjust (W.RationalRect x y wid h) | x + wid >= 1 || y + wid >= 1 || x <= 0 || y <= 0 + let adjust (W.RationalRect x y wid h) | x + wid > 1 || y + h > 1 || x < 0 || y < 0 hunk ./xmonad.cabal 20 -build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.3, mtl>=1.0, unix>=1.0 +build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.3.1, mtl>=1.0, unix>=1.0 hunk ./Operations.hs 213 -setInitialProperties w = withDisplay $ \d -> io $ do +setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> io $ do hunk ./Operations.hs 216 + -- we must initially set the color of new windows, to maintain invariants + -- required by the border setting in 'windows' + setWindowBorder d w nb hunk ./TODO 1 - -- possibles: - * more QC tests - - use more constrained type in StackSet to avoid pattern match warnings - - audit for events handled in dwm. - -- related: - - xcb bindings - - randr - + - Write down invariants for the window life cycle, especially: + - When are borders set? Prove that the current handling is sufficient. hunk ./XMonad.hs 124 --- | XXX Comment me. +-- | And existential class that can hold any object that is in +-- the LayoutClass. hunk ./XMonad.hs 128 --- | XXX Comment me. +-- | This class defines a set of layout types (held in Layout +-- objects) that are used when trying to read an existential +-- Layout. hunk ./XMonad.hs 143 - -- | XXX Comment me. + -- | Given a Rectangle in which to place the windows, and a Stack of + -- windows, return a list of windows and their corresponding Rectangles. + -- The order of windows in this list should be the desired stacking order. + -- Also return a modified layout, if this layout needs to be modified + -- (e.g. if we keep track of the windows we have displayed). hunk ./XMonad.hs 151 - -- | XXX Comment me. + -- | This is a pure version of doLayout, for cases where we don't need + -- access to the X monad to determine how to layou out the windows, and + -- we don't need to modify our layout itself. hunk ./XMonad.hs 165 - -- | XXX Comment me. + -- | Respond to a message by (possibly) changing our layout, but taking + -- no other action. If the layout changes, the screen will be refreshed. hunk ./XMonad.hs 170 - -- | XXX Comment me. + -- | This should be a human-readable string that is used when selecting + -- layouts by name. hunk ./XMonad.hs 176 - readsPrec _ = readLayout defaults + readsPrec _ s = take 1 $ concatMap rl defaults + -- We take the first parse only, because multiple matches + -- indicate a bad parse. + where rl (Layout x) = map (\(l,s') -> (Layout l,s')) $ rl' x + rl' :: LayoutClass l a => l a -> [(l a,String)] + rl' _ = reads s hunk ./XMonad.hs 191 --- | XXX Comment me. -readLayout :: [Layout a] -> String -> [(Layout a, String)] -readLayout ls s = take 1 $ concatMap rl ls - -- We take the first parse only, because multiple matches - -- indicate a bad parse. - where rl (Layout x) = map (\(l,s') -> (Layout l,s')) $ rl' x - rl' :: LayoutClass l a => l a -> [(l a,String)] - rl' _ = reads s - --- | XXX Comment me. +-- | This calls doLayout if there are any windows to be laid out. hunk ./Operations.hs 333 --- | XXX comment me +-- | This is basically a map function, running a function in the X monad on +-- each workspace with the output of that function being the modified workspace. hunk ./Main.hs 1 ------------------------------------------------------------------------------ +---------------------------------------------------------------------------- hunk ./Main.hs 141 - +-- | XXX comment me hunk ./Main.hs 259 - | t == propertyNotify && a == wM_NAME = do logHook + | t == propertyNotify && a == wM_NAME = logHook `catchX` return () hunk ./XMonad.hs 27 +import Prelude hiding ( catch ) +import Control.Exception ( catch ) hunk ./Main.hs 168 + `catchX` return () hunk ./Main.hs 217 + `catchX` return () hunk ./Operations.hs 69 - g <- manageHook w n rn rc + g <- manageHook w n rn rc `catchX` return id hunk ./Operations.hs 172 - logHook + logHook `catchX` return () hunk ./Main.hs 167 - whenJust (M.lookup (cleanMask m,s) keys) id - `catchX` return () + userCode $ whenJust (M.lookup (cleanMask m,s) keys) id hunk ./Main.hs 215 - if isr then whenJust (M.lookup (cleanMask (ev_state e), b) mouseBindings) ($ ev_subwindow e) - `catchX` return () + if isr then userCode $ whenJust (M.lookup (cleanMask (ev_state e), b) mouseBindings) ($ ev_subwindow e) hunk ./Main.hs 259 - | t == propertyNotify && a == wM_NAME = logHook `catchX` return () + | t == propertyNotify && a == wM_NAME = userCode logHook hunk ./Operations.hs 172 - logHook `catchX` return () + userCode logHook hunk ./XMonad.hs 21 - runX, catchX, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX, + runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX, hunk ./XMonad.hs 98 +-- | Execute the argument, catching all exceptions. Either this function or +-- catchX should be used at all callsites of user customized code. +userCode :: X () -> X () +userCode a = catchX a (return ()) + hunk ./Operations.hs 535 - -- | XXX horrible + -- XXX horrible hunk ./XMonad.hs 101 -userCode a = catchX a (return ()) +userCode a = catchX (a >> return ()) (return ()) hunk ./XMonad.hs 84 -runX :: XConf -> XState -> X a -> IO () -runX c st (X a) = runStateT (runReaderT a c) st >> return () +runX :: XConf -> XState -> X a -> IO (a, XState) +runX c st (X a) = runStateT (runReaderT a c) st hunk ./Main.hs 106 + return () hunk ./XMonad.hs 28 -import Control.Exception ( catch ) +import Control.Exception (catch, throw, Exception(ExitException)) hunk ./XMonad.hs 90 -catchX (X job) (X errcase) = do +catchX job errcase = do hunk ./XMonad.hs 93 - (a,s') <- io ((runStateT (runReaderT job c) st) `catch` - \e -> (do hPutStrLn stderr (show e); runStateT (runReaderT errcase c) st)) + (a, s') <- io $ runX c st job `catch` + \e -> case e of + ExitException {} -> throw e + _ -> do hPrint stderr e; runX c st errcase hunk ./xmonad.cabal 20 -build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.3.1, mtl>=1.0, unix>=1.0 +build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.4, mtl>=1.0, unix>=1.0 hunk ./StackSet.hs 247 --- | otherwise = s -- can't happen: all workspaces are either invalid, current, visible, or hidden + | otherwise = s -- can't happen: all workspaces are either invalid, current, visible, or hidden hunk ./Config.hs 82 --- The default rule, do not edit this line. +-- The default rule: return the WindowSet unmodified. You typically do not +-- want to modify this line. hunk ./Config.hs 81 + +-- Automatically send Firefox windows to the "web" workspace: +-- If a workspace named "web" doesn't exist, the window will appear on the +-- current workspace. +manageHook _ _ "Gecko" _ = return $ W.shift "web" hunk ./Config.hs 118 --- | --- The default Layout, a selector between the layouts listed below in --- defaultLayouts. --- -defaultLayout :: Layout Window -defaultLayout = Layout $ LayoutSelection defaultLayouts - --- | --- The list of selectable layouts -defaultLayouts :: [Layout Window] -defaultLayouts = [ Layout tiled - , Layout $ Mirror tiled - , Layout Full - - -- Extension-provided layouts - ] +-- | The list of possible layouts. Add your custom layouts to this list. +layouts :: [Layout Window] +layouts = [ Layout tiled + , Layout $ Mirror tiled + , Layout Full + -- Add extra layouts you want to use here: + ] hunk ./Config.hs 139 --- A list of layouts which xmonad can deserialize. -possibleLayouts :: [Layout Window] -possibleLayouts = [defaultLayout - -- Extension-provided layouts - ] ++ defaultLayouts +-- The top level layout switcher. By default, we simply switch between +-- the layouts listed in `layouts', but you may program your own selection +-- behaviour here. Layout transformers would be hooked in here. +-- +layoutHook :: Layout Window +layoutHook = Layout $ Select layouts + +-- | +-- The default Layout, a selector between the layouts listed below in +-- defaultLayouts. +-- +-- defaultLayout :: Layout Window +-- defaultLayout = Layout $ LayoutSelection defaultLayouts + +-- | Register with xmonad a list of layouts whose state we can preserve over restarts. +-- There is typically no need to modify this list, the defaults are fine. +serialisedLayouts :: [Layout Window] +serialisedLayouts = layoutHook : layouts hunk ./Config.hs 182 - , ((modMask .|. shiftMask, xK_space ), setLayout defaultLayout) -- %! Reset the layouts on the current workspace to default + , ((modMask .|. shiftMask, xK_space ), setLayout layoutHook) -- %! Reset the layouts on the current workspace to default hunk ./Config.hs-boot 6 -logHook :: X () hunk ./Config.hs-boot 8 -possibleLayouts :: [Layout Window] +logHook :: X () hunk ./Config.hs-boot 10 +serialisedLayouts :: [Layout Window] hunk ./Main.hs 53 - let initialWinset = new defaultLayout workspaces $ zipWith SD xinesc gaps + let initialWinset = new layoutHook workspaces $ zipWith SD xinesc gaps hunk ./Main.hs 62 - return . W.ensureTags defaultLayout workspaces - $ W.mapLayout (fromMaybe defaultLayout . maybeRead) ws + return . W.ensureTags layoutHook workspaces + $ W.mapLayout (fromMaybe layoutHook . maybeRead) ws hunk ./Operations.hs 23 -import {-# SOURCE #-} Config (borderWidth,logHook,manageHook,numlockMask,possibleLayouts) +import {-# SOURCE #-} Config (borderWidth,logHook,manageHook,numlockMask,serialisedLayouts) hunk ./Operations.hs 363 - defaults = Layout (LayoutSelection []) : + defaults = Layout (Select []) : hunk ./Operations.hs 366 - possibleLayouts + serialisedLayouts hunk ./Operations.hs 368 -data LayoutSelection a = LayoutSelection [Layout a] - deriving ( Show, Read ) +data Select a = Select [Layout a] deriving (Show, Read) + +instance ReadableLayout a => LayoutClass Select a where + doLayout (Select (l:ls)) r s = do + (x,ml') <- doLayout l r s + return (x, (\l' -> Select (l':ls)) `fmap` ml') + + doLayout (Select []) r s = do + (x,_) <- doLayout Full r s + return (x,Nothing) hunk ./Operations.hs 379 -instance ReadableLayout a => LayoutClass LayoutSelection a where - doLayout (LayoutSelection (l:ls)) r s = - do (x,ml') <- doLayout l r s - return (x, (\l' -> LayoutSelection (l':ls)) `fmap` ml') - doLayout (LayoutSelection []) r s = do (x,_) <- doLayout Full r s - return (x,Nothing) hunk ./Operations.hs 380 - handleMessage (LayoutSelection (l:ls@(_:_))) m + handleMessage (Select (l:ls@(_:_))) m hunk ./Operations.hs 387 - return $ Just $ LayoutSelection lls' + return $ Just $ Select lls' hunk ./Operations.hs 391 - j s zs = case partition (\z -> s == description z) zs of - (xs,ys) -> xs++ys + j s zs = case partition ((s ==) . description) zs of (xs,ys) -> xs++ys + hunk ./Operations.hs 394 - return $ Just (LayoutSelection $ f $ fromMaybe l ml':ls) - -- otherwise, or if we don't understand the message, pass it along to the real - -- layout: - handleMessage (LayoutSelection (l:ls)) m - = do ml' <- handleMessage l m - return $ (\l' -> LayoutSelection (l':ls)) `fmap` ml' + return $ Just (Select $ f $ fromMaybe l ml':ls) + + -- otherwise, or if we don't understand the message, pass it along to the real layout: + handleMessage (Select (l:ls)) m = do + ml' <- handleMessage l m + return $ (\l' -> Select (l':ls)) `fmap` ml' + hunk ./Operations.hs 402 - handleMessage (LayoutSelection []) _ = return Nothing + handleMessage (Select []) _ = return Nothing hunk ./Operations.hs 404 - description (LayoutSelection (x:_)) = description x - description _ = "default" + description (Select (x:_)) = description x + description _ = "default" hunk ./Config.hs 7 --- Maintainer : dons@cse.unsw.edu.au +-- Maintainer : dons@galois.com hunk ./Config.hs 11 --- hunk ./Config.hs 33 +-- | The default number of workspaces (virtual screens) and their names. +-- By default we use numeric strings, but any string may be used as a +-- workspace name. The number of workspaces is determined by the length +-- of this list. +-- +-- A tagging example: hunk ./Config.hs 40 --- The number of workspaces (virtual screens, or window groups) +-- > workspaces = ["web", "irc", "code" ] ++ map show [5..9] hunk ./Config.hs 45 --- | --- modMask lets you specify which modkey you want to use. The default is --- mod1Mask ("left alt"). You may also consider using mod3Mask ("right --- alt"), which does not conflict with emacs keybindings. The "windows --- key" is usually mod4Mask. +-- | modMask lets you specify which modkey you want to use. The default +-- is mod1Mask ("left alt"). You may also consider using mod3Mask +-- ("right alt"), which does not conflict with emacs keybindings. The +-- "windows key" is usually mod4Mask. hunk ./Config.hs 53 --- | --- Default offset of drawable screen boundaries from each physical screen. --- Anything non-zero here will leave a gap of that many pixels on the --- given edge, on the that screen. A useful gap at top of screen for a --- menu bar (e.g. 15) +-- | numlock handling. The mask for the numlock key. You may need to +-- change this on some systems. +-- +-- You can find the numlock modifier by running "xmodmap" and looking for a +-- modifier with Num_Lock bound to it: +-- +-- > $ xmodmap | grep Num +-- > mod2 Num_Lock (0x4d) +-- +numlockMask :: KeyMask +numlockMask = mod2Mask + +-- | Width of the window border in pixels. +-- +borderWidth :: Dimension +borderWidth = 1 + +-- | Border colors for unfocused and focused windows, respectively. +-- +normalBorderColor, focusedBorderColor :: String +normalBorderColor = "#dddddd" +focusedBorderColor = "#ff0000" + +-- | Default offset of drawable screen boundaries from each physical +-- screen. Anything non-zero here will leave a gap of that many pixels +-- on the given edge, on the that screen. A useful gap at top of screen +-- for a menu bar (e.g. 15) hunk ./Config.hs 89 -defaultGaps = [(0,0,0,0)] -- 15 for default dzen +defaultGaps = [(0,0,0,0)] -- 15 for default dzen font hunk ./Config.hs 91 --- | --- Execute arbitrary actions and WindowSet manipulations when --- managing a new window. +------------------------------------------------------------------------ +-- Window rules + +-- | Execute arbitrary actions and WindowSet manipulations when managing +-- a new window. You can use this to, for example, always float a +-- particular program, or have a client always appear on a particular +-- workspace. +-- hunk ./Config.hs 105 --- Float various windows: +-- Always float various programs: hunk ./Config.hs 109 --- Don't manage various panels and desktop windows: +-- Desktop panels and dock apps should be ignored by xmonad: hunk ./Config.hs 118 --- The default rule: return the WindowSet unmodified. You typically do not --- want to modify this line. +-- The default rule, do not edit this line. hunk ./Config.hs 121 --- | --- numlock handling: --- --- The mask for the numlock key. You may need to change this on some systems. --- --- You can find the numlock modifier by running "xmodmap" and looking for a --- modifier with Num_Lock bound to it: --- --- $ xmodmap | grep Num --- mod2 Num_Lock (0x4d) --- -numlockMask :: KeyMask -numlockMask = mod2Mask - --- | --- Border colors for unfocused and focused windows, respectively. --- -normalBorderColor, focusedBorderColor :: String -normalBorderColor = "#dddddd" -focusedBorderColor = "#ff0000" - --- | --- Width of the window border in pixels --- -borderWidth :: Dimension -borderWidth = 1 +------------------------------------------------------------------------ +-- Extensible layouts hunk ./Config.hs 144 --- | --- The top level layout switcher. By default, we simply switch between --- the layouts listed in `layouts', but you may program your own selection --- behaviour here. Layout transformers would be hooked in here. +-- | The top level layout switcher. Most users will not need to modify this binding. +-- +-- By default, we simply switch between the layouts listed in `layouts' +-- above, but you may program your own selection behaviour here. Layout +-- transformers, for example, would be hooked in here. hunk ./Config.hs 153 --- | --- The default Layout, a selector between the layouts listed below in --- defaultLayouts. --- --- defaultLayout :: Layout Window --- defaultLayout = Layout $ LayoutSelection defaultLayouts - hunk ./Config.hs 155 +-- hunk ./Config.hs 159 --- | --- Perform an arbitrary action on each state change. +------------------------------------------------------------------------ +-- Logging + +-- | Perform an arbitrary action on each internal state change or X event. hunk ./Config.hs 167 +-- See the 'DynamicLog' extension for examples. +-- hunk ./Config.hs 172 --- | --- The key bindings list. +------------------------------------------------------------------------ +-- Key bindings: + +-- | The xmonad key bindings. Add, modify or remove key bindings here. hunk ./Config.hs 177 --- The unusual comment format is used to generate the documentation --- automatically. +-- (The comment formatting character is used when generating the manpage) hunk ./Config.hs 198 - hunk ./Config.hs 207 + -- floating layer support hunk ./Config.hs 237 --- | --- default actions bound to mouse events +-- | Mouse bindings: default actions bound to mouse events hunk ./Config.hs 247 - -- Extension-provided mouse bindings + -- you may also bind events to the mouse scroll wheel (button4 and button5) hunk ./Config.hs 250 --- Extension-provided definitions hunk ./Config.hs 118 --- The default rule, do not edit this line. +-- The default rule: return the WindowSet unmodified. You typically do not +-- want to modify this line. hunk ./Config.hs 31 --- Extension-provided imports +-- % Extension-provided imports hunk ./Config.hs 131 + -- % Extension-provided layouts hunk ./Config.hs 223 - -- Extension-provided key bindings + -- % Extension-provided key bindings hunk ./Config.hs 237 - -- Extension-provided key bindings lists + + -- % Extension-provided key bindings lists hunk ./Config.hs 251 + + -- % Extension-provided mouse bindings hunk ./Config.hs 255 +-- % Extension-provided definitions hunk ./Operations.hs 2 -{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable hunk ./Operations.hs 307 +------------------------------------------------------------------------ +-- Message handling + hunk ./Operations.hs 312 --- hunk ./Operations.hs 313 -sendMessage a = do w <- (W.workspace . W.current) `fmap` gets windowset - ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - whenJust ml' $ \l' -> - do windows $ \ws -> ws { W.current = (W.current ws) - { W.workspace = (W.workspace $ W.current ws) - { W.layout = l' }}} +sendMessage a = do + w <- (W.workspace . W.current) `fmap` gets windowset + ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + whenJust ml' $ \l' -> do + windows $ \ws -> ws { W.current = (W.current ws) + { W.workspace = (W.workspace $ W.current ws) + { W.layout = l' }}} hunk ./Operations.hs 323 -sendMessageToWorkspaces a l = runOnWorkspaces modw - where modw w = if W.tag w `elem` l - then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - return $ w { W.layout = maybe (W.layout w) id ml' } - else return w +sendMessageToWorkspaces a l = runOnWorkspaces $ \w -> + if W.tag w `elem` l + then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } + else return w hunk ./Operations.hs 332 -broadcastMessage a = runOnWorkspaces modw - where modw w = do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - return $ w { W.layout = maybe (W.layout w) id ml' } +broadcastMessage a = runOnWorkspaces $ \w -> do + ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } hunk ./Operations.hs 339 -runOnWorkspaces job = do ws <- gets windowset - h <- mapM job $ W.hidden ws - c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s)) - $ W.current ws : W.visible ws - modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } } - -instance Message Event +runOnWorkspaces job =do + ws <- gets windowset + h <- mapM job $ W.hidden ws + c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s)) + $ W.current ws : W.visible ws + modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } } hunk ./Operations.hs 353 --- LayoutClass selection manager +-- | X Events are valid Messages +instance Message Event hunk ./Operations.hs 356 --- This is a layout that allows users to switch between various layout --- options. This layout accepts three Messages, NextLayout, PrevLayout and --- JumpToLayout. +------------------------------------------------------------------------ +-- LayoutClass selection manager hunk ./Operations.hs 359 +-- | A layout that allows users to switch between various layout options. +-- This layout accepts three Messages: +-- +-- > NextLayout +-- > PrevLayout +-- > JumpToLayout. +-- hunk ./Operations.hs 367 - deriving ( Eq, Show, Typeable ) + deriving (Eq, Show, Typeable) hunk ./Operations.hs 380 - doLayout (Select (l:ls)) r s = do - (x,ml') <- doLayout l r s - return (x, (\l' -> Select (l':ls)) `fmap` ml') - - doLayout (Select []) r s = do - (x,_) <- doLayout Full r s - return (x,Nothing) + doLayout (Select (l:ls)) r s = + second (fmap (Select . (:ls))) `fmap` doLayout l r s + doLayout (Select []) r s = + second (const Nothing) `fmap` doLayout Full r s hunk ./Operations.hs 387 - | Just NextLayout <- fromMessage m = switchl rls - | Just PrevLayout <- fromMessage m = switchl rls' - | Just (JumpToLayout x) <- fromMessage m = switchl (j x) - | Just ReleaseResources <- fromMessage m = - do mlls' <- mapM (\ll -> handleMessage ll m) (l:ls) - let lls' = zipWith (\x mx -> maybe x id mx) (l:ls) mlls' - return $ Just $ Select lls' - where rls (x:xs) = xs ++ [x] - rls [] = [] + | Just NextLayout <- fromMessage m = switchl rls + | Just PrevLayout <- fromMessage m = switchl rls' + | Just (JumpToLayout x) <- fromMessage m = switchl (j x) + | Just ReleaseResources <- fromMessage m = do -- each branch has a different type + mlls' <- mapM (flip handleMessage m) (l:ls) + let lls' = zipWith (flip maybe id) (l:ls) mlls' + return (Just (Select lls')) + + where rls [] = [] + rls (x:xs) = xs ++ [x] hunk ./Operations.hs 398 + hunk ./Operations.hs 405 - handleMessage (Select (l:ls)) m = do - ml' <- handleMessage l m - return $ (\l' -> Select (l':ls)) `fmap` ml' + handleMessage (Select (l:ls)) m = + fmap (Select . (:ls)) `fmap` handleMessage l m hunk ./Operations.hs 413 + hunk ./Operations.hs 415 --- Builtin layout algorithms: +-- | Builtin layout algorithms: hunk ./Operations.hs 417 --- fullscreen mode --- tall mode +-- > fullscreen mode +-- > tall mode hunk ./Operations.hs 422 --- Shrink --- Expand +-- > Shrink +-- > Expand hunk ./Operations.hs 425 - hunk ./Operations.hs 427 +-- | You can also increase the number of clients in the master pane hunk ./Operations.hs 433 --- simple fullscreen mode, just render all windows fullscreen. --- a plea for tuple sections: map . (,sc) -data Full a = Full deriving ( Show, Read ) +-- | Simple fullscreen mode, just render all windows fullscreen. +data Full a = Full deriving (Show, Read) hunk ./Operations.hs 437 --- --- The tiling mode of xmonad, and its operations. --- -data Tall a = Tall Int Rational Rational deriving ( Show, Read ) + +-- | The inbuilt tiling mode of xmonad, and its operations. +data Tall a = Tall Int Rational Rational deriving (Show, Read) hunk ./Operations.hs 443 - return . (\x->(x,Nothing)) . + return . (flip (,) Nothing) . hunk ./Operations.hs 445 + hunk ./Operations.hs 627 -applySizeHints :: Integral a => SizeHints -> (a,a) -> D +applySizeHints :: Integral a => SizeHints -> (a,a) -> D hunk ./XMonad.hs 31 +import Control.Arrow (first) hunk ./XMonad.hs 132 --- | LayoutClass handling +-- | LayoutClass handling. See particular instances in Operations.hs hunk ./XMonad.hs 134 --- | And existential class that can hold any object that is in --- the LayoutClass. +-- | An existential type that can hold any object that is in the LayoutClass. hunk ./XMonad.hs 138 --- objects) that are used when trying to read an existential --- Layout. +-- objects) that are used when trying to read an existentially wrapped Layout. hunk ./XMonad.hs 143 +-- hunk ./XMonad.hs 149 - hunk ./XMonad.hs 187 - where rl (Layout x) = map (\(l,s') -> (Layout l,s')) $ rl' x + where rl (Layout x) = map (first Layout) $ rl' x hunk ./XMonad.hs 192 - doLayout (Layout l) r s = fmap (fmap $ fmap Layout) $ doLayout l r s + doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s hunk ./TODO 4 += Release management = + +* build and typecheck all XMC +* generate haddocks for core and XMC, upload to xmonad.org +* regenerate man page +* document, with photos, any new layouts +* double check README build instructions +* test core with 6.6 and 6.8 +* upload X11/X11-extras/xmonad to hacakge +* check examples/text in use-facing Config.hs +* check tour.html and intro.html are up to date, and mention all core bindings + hunk ./TODO 8 -* regenerate man page +* generate manpage, generate html manpage hunk ./TODO 15 +* bump xmonad.cabal version hunk ./Config.hs 40 --- > workspaces = ["web", "irc", "code" ] ++ map show [5..9] +-- > workspaces = ["web", "irc", "code" ] ++ map show [4..9] hunk ./Operations.hs 372 - defaults = Layout (Select []) : - Layout Full : Layout (Tall 1 0.1 0.5) : - Layout (Mirror $ Tall 1 0.1 0.5) : - serialisedLayouts + readTypes = Layout (Select []) : + Layout Full : Layout (Tall 1 0.1 0.5) : + Layout (Mirror $ Tall 1 0.1 0.5) : + serialisedLayouts hunk ./XMonad.hs 137 + hunk ./XMonad.hs 141 - defaults :: [Layout a] + readTypes :: [Layout a] hunk ./XMonad.hs 184 +-- Here's the magic for parsing serialised state of existentially +-- wrapped layouts: attempt to parse using the Read instance from each +-- type in our list of types, if any suceed, take the first one. hunk ./XMonad.hs 188 - readsPrec _ s = take 1 $ concatMap rl defaults - -- We take the first parse only, because multiple matches - -- indicate a bad parse. - where rl (Layout x) = map (first Layout) $ rl' x - rl' :: LayoutClass l a => l a -> [(l a,String)] - rl' _ = reads s + + -- We take the first parse only, because multiple matches indicate a bad parse. + readsPrec _ s = take 1 $ concatMap readLayout readTypes + where + readLayout (Layout x) = map (first Layout) $ readAsType x + + -- the type indicates which Read instance to dispatch to. + -- That is, read asTypeOf the argument from the readTypes. + readAsType :: LayoutClass l a => l a -> [(l a, String)] + readAsType _ = reads s hunk ./XMonad.hs 204 -instance Show (Layout a) where - show (Layout l) = show l +instance Show (Layout a) where show (Layout l) = show l hunk ./xmonad.cabal 2 -version: 0.3 +version: 0.4 hunk ./Config.hs 6 --- +-- hunk ./Config.hs 10 --- +-- hunk ./Config.hs 14 --- +-- hunk ./Config.hs 19 --- +-- hunk ./Config.hs 147 --- +-- hunk ./Config.hs 162 --- Logging +-- Logging hunk ./Config.hs 178 --- +-- hunk ./Config.hs 53 --- | numlock handling. The mask for the numlock key. You may need to --- change this on some systems. +-- | The mask for the numlock key. Numlock status is "masked" from the +-- current modifier status, so the keybindings will work with numlock on or +-- off. You may need to change this on some systems. hunk ./Config.hs 63 +-- Set numlockMask = 0 if you don't have a numlock key, or want to treat +-- numlock status separately. +-- hunk ./Config.hs 69 --- | Width of the window border in pixels. +-- | Width of the window border in pixels. hunk ./Config.hs 84 --- +-- hunk ./Main.hs 12 --- +-- hunk ./Operations.hs 10 --- +-- hunk ./Operations.hs 419 --- +-- hunk ./Operations.hs 470 --- convention has the least number of windows in it (by default, 1). +-- convention has the least number of windows in it (by default, 1). hunk ./Operations.hs 472 --- master pane. +-- master pane. hunk ./Operations.hs 478 --- +-- hunk ./StackSet.hs 58 --- +-- hunk ./StackSet.hs 60 --- > +-- > hunk ./StackSet.hs 64 --- +-- hunk ./StackSet.hs 69 --- Zipper +-- Zipper hunk ./StackSet.hs 80 --- the old structure as possible. +-- the old structure as possible. hunk ./StackSet.hs 97 --- +-- hunk ./StackSet.hs 115 --- | +-- | hunk ./StackSet.hs 139 --- * member, +-- * member, hunk ./StackSet.hs 149 --- A cursor into a non-empty list of workspaces. --- +-- A cursor into a non-empty list of workspaces. +-- hunk ./StackSet.hs 226 --- /O(w)/. Set focus to the workspace with index \'i\'. +-- /O(w)/. Set focus to the workspace with index \'i\'. hunk ./StackSet.hs 309 --- /O(1)/. Extract the focused element of the current stack. +-- /O(1)/. Extract the focused element of the current stack. hunk ./StackSet.hs 356 --- /O(1), O(w) on the wrapping case/. +-- /O(1), O(w) on the wrapping case/. hunk ./StackSet.hs 366 --- +-- hunk ./StackSet.hs 386 --- | /O(1) on current window, O(n) in general/. Focus the window 'w', +-- | /O(1) on current window, O(n) in general/. Focus the window 'w', hunk ./StackSet.hs 533 --- +-- hunk ./XMonad.hs 212 --- +-- hunk ./tests/Properties.hs 34 --- * most ops on StackSet should either be trivially reversible, or +-- * most ops on StackSet should either be trivially reversible, or hunk ./tests/Properties.hs 94 --- issue: the data structure enforces focus by construction. +-- issue: the data structure enforces focus by construction. hunk ./tests/Properties.hs 184 -prop_empty (EmptyStackSet x) = +prop_empty (EmptyStackSet x) = hunk ./tests/Properties.hs 208 --- view *only* sets the current workspace, and touches Xinerama. +-- view *only* sets the current workspace, and touches Xinerama. hunk ./tests/Properties.hs 241 --- greedyView *only* sets the current workspace, and touches Xinerama. +-- greedyView *only* sets the current workspace, and touches Xinerama. hunk ./tests/Properties.hs 299 --- +-- hunk ./tests/Properties.hs 461 - Nothing -> True + Nothing -> True hunk ./tests/Properties.hs 532 - i `tagMember` x && w `member` x && i /= n && findIndex w x /= Just n + i `tagMember` x && w `member` x && i /= n && findIndex w x /= Just n hunk ./tests/Properties.hs 570 -prop_lookup_visible (x :: T) = +prop_lookup_visible (x :: T) = hunk ./tests/Properties.hs 630 --- multiple windows +-- multiple windows hunk ./tests/Properties.hs 706 - + hunk ./StackSet.hs 359 --- wrapping if we reach the end. The wrapping should model a -- 'cycle' +-- wrapping if we reach the end. The wrapping should model a 'cycle' hunk ./StackSet.hs 539 --- inserted above the currently focused element on that workspace. -- --- The actual focused workspace doesn't change. If there is -- no +-- inserted above the currently focused element on that workspace. +-- The actual focused workspace doesn't change. If there is no hunk ./README 54 - X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2.2 - X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.3 + X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2.3 + X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.4 hunk ./README 94 - 0.3 release: http://www.xmonad.org/XMonadContrib-0.3.tar.gz + 0.4 release: http://www.xmonad.org/XMonadContrib-0.4.tar.gz hunk ./Operations.hs 142 - >>= W.filter (not . flip M.member (W.floating ws)) - >>= W.filter (not . (`elem` vis)) + >>= W.filter (`M.notMember` W.floating ws) + >>= W.filter (`notElem` vis) hunk ./StackSet.hs 17 - StackSet(..), Workspace(..), Screen(..), StackOrNot, Stack(..), RationalRect(..), + StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..), hunk ./StackSet.hs 172 -data Workspace i l a = Workspace { tag :: !i, layout :: l, stack :: StackOrNot a } +data Workspace i l a = Workspace { tag :: !i, layout :: l, stack :: Maybe (Stack a) } hunk ./StackSet.hs 197 -type StackOrNot a = Maybe (Stack a) - hunk ./StackSet.hs 295 -modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i l a s sd -> StackSet i l a s sd +modify :: Maybe (Stack a) -> (Stack a -> Maybe (Stack a)) -> StackSet i l a s sd -> StackSet i l a s sd hunk ./StackSet.hs 321 -integrate' :: StackOrNot a -> [a] +integrate' :: Maybe (Stack a) -> [a] hunk ./StackSet.hs 327 -differentiate :: [a] -> StackOrNot a +differentiate :: [a] -> Maybe (Stack a) hunk ./StackSet.hs 335 -filter :: (a -> Bool) -> Stack a -> StackOrNot a +filter :: (a -> Bool) -> Stack a -> Maybe (Stack a) hunk ./XMonad.hs 207 -runLayout :: LayoutClass l a => l a -> Rectangle -> StackOrNot a -> X ([(a, Rectangle)], Maybe (l a)) +runLayout :: LayoutClass l a => l a -> Rectangle -> Maybe (Stack a) -> X ([(a, Rectangle)], Maybe (l a)) hunk ./Operations.hs 80 - setWMState w 0 {-withdrawn-} + setWMState w withdrawnState hunk ./Operations.hs 193 - setWMState w 3 --iconic + setWMState w iconicState hunk ./Operations.hs 203 - setWMState w 1 --normal + setWMState w normalState hunk ./Operations.hs 241 - bw <- (fromIntegral . wa_border_width) `liftM` io (getWindowAttributes d w) + bw <- (fromIntegral . wa_border_width) `fmap` io (getWindowAttributes d w) hunk ./Operations.hs 144 - (SD (Rectangle sx sy sw sh) + (SD sr@(Rectangle sx sy sw sh) hunk ./Operations.hs 159 - forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ - \(W.RationalRect rx ry rw rh) -> do - tileWindow fw $ Rectangle - (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry)) - (floor (toRational sw*rw)) (floor (toRational sh*rh)) + forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ floatWindow sr fw hunk ./Operations.hs 245 +-- | tileWindow. Moves and resizes w such that it fits inside the given +-- RationalRect with respect to the reference Rectangle +floatWindow :: Rectangle -> Window -> W.RationalRect -> X () +floatWindow (Rectangle sx sy sw sh) w (W.RationalRect rx ry rw rh) = do + d <- asks display + bw <- fmap wa_border_width $ io (getWindowAttributes d w) + -- Position and Dimension are incompatible types, so we must fromIntegral + -- twice + let bwp = fromIntegral bw :: Position + bwd = fromIntegral bw :: Dimension + tileWindow w $ Rectangle + (sx + floor (toRational sw*rx) - bwp) (sy + floor (toRational sh*ry) - bwp) + (floor (toRational sw*rw) + 2*bwd) (floor (toRational sh*rh) + 2*bwd) + hunk ./Operations.hs 561 - (fi (wa_width wa + bw*2) % fi (rect_width sr)) - (fi (wa_height wa + bw*2) % fi (rect_height sr)) + (fi (wa_width wa - bw*2) % fi (rect_width sr)) + (fi (wa_height wa - bw*2) % fi (rect_height sr)) hunk ./Config.hs 233 - | (i, k) <- zip workspaces [xK_1 ..] + | (i, k) <- zip workspaces [xK_1 .. xK_9] hunk ./Operations.hs 561 - (fi (wa_width wa - bw*2) % fi (rect_width sr)) - (fi (wa_height wa - bw*2) % fi (rect_height sr)) + (fi (wa_width wa + bw*2) % fi (rect_width sr)) + (fi (wa_height wa + bw*2) % fi (rect_height sr)) hunk ./Operations.hs 245 --- | tileWindow. Moves and resizes w such that it fits inside the given --- RationalRect with respect to the reference Rectangle -floatWindow :: Rectangle -> Window -> W.RationalRect -> X () -floatWindow (Rectangle sx sy sw sh) w (W.RationalRect rx ry rw rh) = do - d <- asks display - bw <- fmap wa_border_width $ io (getWindowAttributes d w) - -- Position and Dimension are incompatible types, so we must fromIntegral - -- twice - let bwp = fromIntegral bw :: Position - bwd = fromIntegral bw :: Dimension - tileWindow w $ Rectangle - (sx + floor (toRational sw*rx) - bwp) (sy + floor (toRational sh*ry) - bwp) - (floor (toRational sw*rw) + 2*bwd) (floor (toRational sh*rh) + 2*bwd) - hunk ./Operations.hs 159 - forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ floatWindow sr fw + forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ + \(W.RationalRect rx ry rw rh) -> do + tileWindow fw $ Rectangle + (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry)) + (floor (toRational sw*rw)) (floor (toRational sh*rh)) hunk ./Operations.hs 144 - (SD sr@(Rectangle sx sy sw sh) + (SD (Rectangle sx sy sw sh) hunk ./Operations.hs 124 - mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) hunk ./Operations.hs 169 + mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) + hunk ./Operations.hs 169 - mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) - hunk ./Operations.hs 124 + mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) hunk ./Operations.hs 442 - doLayout (Tall nmaster _ frac) r = - return . (flip (,) Nothing) . - ap zip (tile frac r nmaster . length) . W.integrate + pureLayout (Tall nmaster _ frac) r s = zip ws rs + where ws = W.integrate s + rs = tile frac r nmaster (length ws) hunk ./Operations.hs 392 - let lls' = zipWith (flip maybe id) (l:ls) mlls' + let lls' = zipWith fromMaybe (l:ls) mlls' addfile ./STYLE hunk ./STYLE 1 + +== Coding guidelines for contributing to +== xmonad and the xmonad contributed extensions + +* Comment every top level function, and provide a type signature, using + haddock syntax. + +* Follow the coding style of already existing modules + +* Code should be compiled with -Wall and emit no errors + +* Partial functions should be avoided: the window manager should not + crash, so do not call `error` or `undefined` + +* Tabs are illegal. Use 4 spaces for indenting + +* Any pure function added to the core should have a QuickCheck property + defining its behaviour + +* New modules should identify the author, and have are submitted under + the xmonad BSD3 license. hunk ./STYLE 3 -== xmonad and the xmonad contributed extensions +== XMonad and the XMonad contributed extensions hunk ./STYLE 5 -* Comment every top level function, and provide a type signature, using - haddock syntax. +* Comment every top level function (particularly exported funtions), and + provide a type signature; use Haddock syntax in the comments. hunk ./STYLE 8 -* Follow the coding style of already existing modules +* Follow the coding style of the other modules. hunk ./STYLE 10 -* Code should be compiled with -Wall and emit no errors +* Code should be compilable with -Wall -Werror. There should be no warnings. hunk ./STYLE 15 -* Tabs are illegal. Use 4 spaces for indenting +* Tabs are illegal. Use 4 spaces for indenting. hunk ./STYLE 17 -* Any pure function added to the core should have a QuickCheck property - defining its behaviour +* Any pure function added to the core should have QuickCheck properties + precisely defining its behaviour. hunk ./STYLE 20 -* New modules should identify the author, and have are submitted under - the xmonad BSD3 license. +* New modules should identify the author, and be submitted under + the same license as XMonad (BSD3 license or freer). hunk ./STYLE 3 -== XMonad and the XMonad contributed extensions +== xmonad and the xmonad contributed extensions hunk ./STYLE 21 - the same license as XMonad (BSD3 license or freer). + the same license as xmonad (BSD3 license or freer). hunk ./README 43 - Firstly, you'll need the C X11 library headers. On many platforms, - these come pre-installed. For others, such as Debian, you can get - them from your package manager: + You first need a Haskell compiler. Your distribution's package + system will have binaries of GHC (the Glasgow Haskell Compiler), the + system we use, so install that. If your distro doesn't provide a + binary, you can find them here: + + http://haskell.org/ghc + + For example, in Debian you would install GHC with: + + apt-get install ghc6 + + Since you're building an X application, you'll need the C X11 + library headers. On many platforms, these come pre-installed. For + others, such as Debian, you can get them from your package manager: hunk ./README 60 - It is likely that you already have some of these dependencies. To check - whether you've got a package run 'ghc-pkg list some_package_name' + Finally, you need the Haskell libraries xmonad depends on. Since + you've a working GHC installation now, most of these will be + provided. To check whether you've got a package run 'ghc-pkg list + some_package_name'. You will need the following packages: hunk ./README 70 -And then build with Cabal: +And then build xmonad with Cabal as follows (the same goes for the other +Haskell libraries): hunk ./Config.hs 181 +-- | The preferred terminal program, which is used in a binding below and by +-- certain contrib modules. +terminal :: String +terminal = "xterm" + hunk ./Config.hs 193 - [ ((modMask .|. shiftMask, xK_Return), spawn "xterm") -- %! Launch an xterm + [ ((modMask .|. shiftMask, xK_Return), spawn terminal) -- %! Launch terminal hunk ./Config.hs-boot 11 +terminal :: String hunk ./StackSet.hs 102 --- receive keyboard events), other workspaces may be passively viewable. --- We thus need to track which virtual workspaces are associated --- (viewed) on which physical screens. We use a simple Map Workspace --- Screen for this. +-- receive keyboard events), other workspaces may be passively +-- viewable. We thus need to track which virtual workspaces are +-- associated (viewed) on which physical screens. To keep track of +-- this, StackSet keeps separate lists of visible but non-focused +-- workspaces, and non-visible workspaces. hunk ./StackSet.hs 112 --- needs to be well defined. Particular in relation to 'insert' and +-- needs to be well defined, particularly in relation to 'insert' and hunk ./StackSet.hs 128 --- * focusUp, focusDown, -- was: rotate +-- * focusUp, focusDown, -- was: rotate hunk ./StackSet.hs 134 --- * insertUp, -- was: insert\/push +-- * insertUp, -- was: insert\/push hunk ./StackSet.hs 160 - , hidden :: [Workspace i l a] -- ^ workspaces not visible anywhere - , floating :: M.Map a RationalRect -- ^ floating windows + , hidden :: [Workspace i l a] -- ^ workspaces not visible anywhere + , floating :: M.Map a RationalRect -- ^ floating windows hunk ./StackSet.hs 211 --- | /O(n)/. Create a new stackset, of empty stacks, with given tags, with --- 'm' physical screens. 'm' should be less than or equal to the number of --- workspace tags. The first workspace in the list will be current. +-- | /O(n)/. Create a new stackset, of empty stacks, with given tags, +-- with physical screens whose descriptions are given by 'm'. The +-- number of physical screens (@length 'm'@) should be less than or +-- equal to the number of workspace tags. The first workspace in the +-- list will be current. hunk ./StackSet.hs 327 --- | --- /O(n)/. Texture a list. --- +-- | +-- /O(n)/. Turn a list into a possibly empty stack (i.e., a zipper): +-- the first element of the list is current, and the rest of the list +-- is down. hunk ./StackSet.hs 354 - --- let is = t : r ++ reverse l in take (length is) (dropWhile (/= m) (cycle is)) hunk ./StackSet.hs 416 --- | Ensure that a given set of tags is present. +-- | Ensure that a given set of workspace tags is present by renaming +-- existing workspaces and/or creating new hidden workspaces as +-- necessary. replace ./Config.hs [A-Za-z_0-9] findIndex findTag replace ./Main.hs [A-Za-z_0-9] findIndex findTag replace ./Operations.hs [A-Za-z_0-9] findIndex findTag hunk ./StackSet.hs 445 --- Return Just the workspace index of the given window, or Nothing +-- Return Just the workspace tag of the given window, or Nothing replace ./StackSet.hs [A-Za-z_0-9] findIndex findTag replace ./XMonad.hs [A-Za-z_0-9] findIndex findTag replace ./tests/Main.hs [A-Za-z_0-9] findIndex findTag replace ./tests/Properties.hs [A-Za-z_0-9] findIndex findTag replace ./tests/loc.hs [A-Za-z_0-9] findIndex findTag hunk ./StackSet.hs 457 --- /O(n)/. (Complexity due to duplicate check). Insert a new element into --- the stack, above the currently focused element. --- --- The new element is given focus, and is set as the master window. --- The previously focused element is moved down. The previously --- 'master' element is forgotten. (Thus, 'insert' will cause a retiling). +-- /O(n)/. (Complexity due to duplicate check). Insert a new element +-- into the stack, above the currently focused element. The new +-- element is given focus; the previously focused element is moved +-- down. hunk ./Config.hs 128 +-- +-- You can specify and transform your layouts by modifying these values. +-- If you change layout bindings be sure to use 'mod-shift-space' after +-- restarting (with 'mod-q') to reset your layout state to the new +-- defaults, as xmonad preserves your old layout settings by default. +-- hunk ./Config.hs 103 +-- To find the property name associated with a program, use +-- xprop | grep WM_CLASS +-- and click on the client you're interested in. +-- hunk ./Operations.hs 213 -setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> io $ do - selectInput d w $ clientMask - setWindowBorderWidth d w borderWidth +setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do + setWMState w iconicState + io $ selectInput d w $ clientMask + io $ setWindowBorderWidth d w borderWidth hunk ./Operations.hs 219 - setWindowBorder d w nb + io $ setWindowBorder d w nb hunk ./Operations.hs 549 - bw = fi . wa_border_width $ wa + bw = fi borderWidth hunk ./README 65 - mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-1.0 - unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 - X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2.3 - X11-extras: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-extras-0.4 + mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-1.0 + unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 + X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.3.0 hunk ./README 81 - use the darcs version of X11-extras, which is developed concurrently - with xmonad. + use the darcs version of the X11 library, which is developed + concurrently with xmonad. hunk ./README 84 - darcs get http://code.haskell.org/X11-extras + darcs get http://darcs.haskell.org/X11 hunk ./README 86 - Not using X11-extras from darcs, is the most common reason for the + Not using X11 from darcs is the most common reason for the hunk ./xmonad.cabal 20 -build-depends: base>=2.0, X11>=1.2.1, X11-extras>=0.4, mtl>=1.0, unix>=1.0 +build-depends: base>=2.0, X11>=1.3.0, mtl>=1.0, unix>=1.0 hunk ./TODO 4 + - current floating layer handling is unoptimal. FocusUp should raise, + for example + + - Issues still with stacking order. + hunk ./TODO 17 -* upload X11/X11-extras/xmonad to hacakge +* upload X11/xmonad to hacakge hunk ./xmonad.cabal 20 -build-depends: base>=2.0, X11>=1.3.0, mtl>=1.0, unix>=1.0 +build-depends: base>=2.0, mtl, unix, X11==1.3.0 move ./Config.hs ./config.hs move ./Main.hs ./EventLoop.hs hunk ./EventLoop.hs 15 -module Main where +module EventLoop ( makeMain ) where hunk ./EventLoop.hs 31 -import Config hunk ./EventLoop.hs 40 -main :: IO () -main = do +makeMain :: String -> String -> Layout Window -> [String] -> [(Int,Int,Int,Int)] + -> M.Map (ButtonMask,KeySym) (X ()) -> M.Map (ButtonMask, Button) (Window -> X ()) + -> Int -> X () -> IO () +makeMain normalBorderColor focusedBorderColor layoutHook workspaces + defaultGaps keys mouseBindings borderWidth logHook = do hunk ./EventLoop.hs 90 - grabKeys - grabButtons + grabKeys keys + grabButtons mouseBindings hunk ./EventLoop.hs 111 + -- --------------------------------------------------------------------- + -- | Event handler. Map X events onto calls into Operations.hs, which + -- modify our internal model of the window manager state. + -- + -- Events dwm handles that we don't: + -- + -- [ButtonPress] = buttonpress, + -- [Expose] = expose, + -- [PropertyNotify] = propertynotify, + -- + handle :: Event -> X () + + -- run window manager command + handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) + | t == keyPress = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 + userCode $ whenJust (M.lookup (cleanMask m,s) keys) id + + -- manage a new window + handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + wa <- io $ getWindowAttributes dpy w -- ignore override windows + -- need to ignore mapping requests by managed windows not on the current workspace + managed <- isClient w + when (not (wa_override_redirect wa) && not managed) $ do manage w + + -- window destroyed, unmanage it + -- window gone, unmanage it + handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w + + -- We track expected unmap events in waitingUnmap. We ignore this event unless + -- it is synthetic or we are not expecting an unmap notification from a window. + handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do + e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) + if (synthetic || e == 0) + then unmanage w + else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) + + -- set keyboard mapping + handle e@(MappingNotifyEvent {}) = do + io $ refreshKeyboardMapping e + when (ev_request e == mappingKeyboard) (grabKeys keys) + + -- handle button release, which may finish dragging. + handle e@(ButtonEvent {ev_event_type = t}) + | t == buttonRelease = do + drag <- gets dragging + case drag of + -- we're done dragging and have released the mouse: + Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f + Nothing -> broadcastMessage e + + -- handle motionNotify event, which may mean we are dragging. + handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do + drag <- gets dragging + case drag of + Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging + Nothing -> broadcastMessage e + + -- click on an unfocused window, makes it focused on this workspace + handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) + | t == buttonPress = do + -- If it's the root window, then it's something we + -- grabbed in grabButtons. Otherwise, it's click-to-focus. + isr <- isRoot w + if isr then userCode $ whenJust (M.lookup (cleanMask (ev_state e), b) mouseBindings) ($ ev_subwindow e) + else focus w + sendMessage e -- Always send button events. + + -- entered a normal window, makes this focused. + handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) + | t == enterNotify && ev_mode e == notifyNormal + && ev_detail e /= notifyInferior = focus w + + -- left a window, check if we need to focus root + handle e@(CrossingEvent {ev_event_type = t}) + | t == leaveNotify + = do rootw <- asks theRoot + when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw + + -- configure a window + handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + ws <- gets windowset + wa <- io $ getWindowAttributes dpy w + + if M.member w (floating ws) + || not (member w ws) + then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges + { wc_x = ev_x e + , wc_y = ev_y e + , wc_width = ev_width e + , wc_height = ev_height e + , wc_border_width = fromIntegral borderWidth + , wc_sibling = ev_above e + , wc_stack_mode = ev_detail e } + when (member w ws) (float w) + else io $ allocaXEvent $ \ev -> do + setEventType ev configureNotify + setConfigureEvent ev w w + (wa_x wa) (wa_y wa) (wa_width wa) + (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) + sendEvent dpy w False 0 ev + io $ sync dpy False + + -- configuration changes in the root may mean display settings have changed + handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen + + -- property notify + handle PropertyEvent { ev_event_type = t, ev_atom = a } + | t == propertyNotify && a == wM_NAME = userCode logHook + + handle e = broadcastMessage e -- trace (eventName e) -- ignoring + + hunk ./EventLoop.hs 246 -grabKeys :: X () -grabKeys = do +grabKeys :: M.Map (ButtonMask,KeySym) (X ()) -> X () +grabKeys keys = do hunk ./EventLoop.hs 258 -grabButtons :: X () -grabButtons = do +grabButtons :: M.Map (ButtonMask, Button) (Window -> X ()) -> X () +grabButtons mouseBindings = do hunk ./EventLoop.hs 266 --- --------------------------------------------------------------------- --- | Event handler. Map X events onto calls into Operations.hs, which --- modify our internal model of the window manager state. --- --- Events dwm handles that we don't: --- --- [ButtonPress] = buttonpress, --- [Expose] = expose, --- [PropertyNotify] = propertynotify, --- - -handle :: Event -> X () - --- run window manager command -handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) - | t == keyPress = withDisplay $ \dpy -> do - s <- io $ keycodeToKeysym dpy code 0 - userCode $ whenJust (M.lookup (cleanMask m,s) keys) id - --- manage a new window -handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - wa <- io $ getWindowAttributes dpy w -- ignore override windows - -- need to ignore mapping requests by managed windows not on the current workspace - managed <- isClient w - when (not (wa_override_redirect wa) && not managed) $ do manage w - --- window destroyed, unmanage it --- window gone, unmanage it -handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w - --- We track expected unmap events in waitingUnmap. We ignore this event unless --- it is synthetic or we are not expecting an unmap notification from a window. -handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do - e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) - if (synthetic || e == 0) - then unmanage w - else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) - --- set keyboard mapping -handle e@(MappingNotifyEvent {}) = do - io $ refreshKeyboardMapping e - when (ev_request e == mappingKeyboard) grabKeys - --- handle button release, which may finish dragging. -handle e@(ButtonEvent {ev_event_type = t}) - | t == buttonRelease = do - drag <- gets dragging - case drag of - -- we're done dragging and have released the mouse: - Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f - Nothing -> broadcastMessage e - --- handle motionNotify event, which may mean we are dragging. -handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do - drag <- gets dragging - case drag of - Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging - Nothing -> broadcastMessage e - --- click on an unfocused window, makes it focused on this workspace -handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) - | t == buttonPress = do - -- If it's the root window, then it's something we - -- grabbed in grabButtons. Otherwise, it's click-to-focus. - isr <- isRoot w - if isr then userCode $ whenJust (M.lookup (cleanMask (ev_state e), b) mouseBindings) ($ ev_subwindow e) - else focus w - sendMessage e -- Always send button events. - --- entered a normal window, makes this focused. -handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) - | t == enterNotify && ev_mode e == notifyNormal - && ev_detail e /= notifyInferior = focus w - --- left a window, check if we need to focus root -handle e@(CrossingEvent {ev_event_type = t}) - | t == leaveNotify - = do rootw <- asks theRoot - when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw - --- configure a window -handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - ws <- gets windowset - wa <- io $ getWindowAttributes dpy w - - if M.member w (floating ws) - || not (member w ws) - then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges - { wc_x = ev_x e - , wc_y = ev_y e - , wc_width = ev_width e - , wc_height = ev_height e - , wc_border_width = fromIntegral borderWidth - , wc_sibling = ev_above e - , wc_stack_mode = ev_detail e } - when (member w ws) (float w) - else io $ allocaXEvent $ \ev -> do - setEventType ev configureNotify - setConfigureEvent ev w w - (wa_x wa) (wa_y wa) (wa_width wa) - (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) - sendEvent dpy w False 0 ev - io $ sync dpy False - --- configuration changes in the root may mean display settings have changed -handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen - --- property notify -handle PropertyEvent { ev_event_type = t, ev_atom = a } - | t == propertyNotify && a == wM_NAME = userCode logHook - -handle e = broadcastMessage e -- trace (eventName e) -- ignoring - hunk ./config.hs 17 -module Config where +module Main ( main ) where hunk ./config.hs 30 +import EventLoop hunk ./config.hs 277 + +-- % The main function + +main = makeMain normalBorderColor focusedBorderColor layoutHook workspaces + defaultGaps keys mouseBindings borderWidth logHook + hunk ./xmonad.cabal 25 -main-is: Main.hs -other-modules: Config Operations StackSet XMonad +main-is: config.hs +other-modules: EventLoop Operations StackSet XMonad move ./Config.hs-boot ./Main.hs-boot move ./config.hs ./Main.hs hunk ./EventLoop.hs 42 - -> Int -> X () -> IO () + -> Dimension -> X () -> IO () hunk ./Main.hs 17 -module Main ( main ) where +module Main where hunk ./Main.hs 280 +main :: IO () hunk ./Main.hs-boot 1 -module Config where +module Main where hunk ./Operations.hs 23 -import {-# SOURCE #-} Config (borderWidth,logHook,manageHook,numlockMask,serialisedLayouts) hunk ./Operations.hs 40 +import {-# SOURCE #-} Main (borderWidth,logHook,manageHook,numlockMask,serialisedLayouts) + hunk ./xmonad.cabal 25 -main-is: config.hs +main-is: Main.hs hunk ./Operations.hs 349 -setLayout :: Layout Window -> X () +setLayout :: LayoutClass l Window => l Window -> X () hunk ./Operations.hs 353 - windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = l } } } + windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = Layout l } } } hunk ./EventLoop.hs 15 -module EventLoop ( makeMain ) where +module EventLoop ( makeMain, XMonadConfig(..) ) where hunk ./EventLoop.hs 30 -import XMonad +import XMonad hiding ( logHook, borderWidth ) +import qualified XMonad ( logHook, borderWidth ) hunk ./EventLoop.hs 38 +data XMonadConfig l = XMonadConfig { normalBorderColor :: !String + , focusedBorderColor :: !String + , defaultTerminal :: !String + , layoutHook :: !(l Window) + , workspaces :: ![String] + , defaultGaps :: ![(Int,Int,Int,Int)] + , keys :: !(M.Map (ButtonMask,KeySym) (X ())) + , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) + , borderWidth :: !Dimension + , logHook :: !(X ()) + } + hunk ./EventLoop.hs 53 -makeMain :: String -> String -> Layout Window -> [String] -> [(Int,Int,Int,Int)] - -> M.Map (ButtonMask,KeySym) (X ()) -> M.Map (ButtonMask, Button) (Window -> X ()) - -> Dimension -> X () -> IO () -makeMain normalBorderColor focusedBorderColor layoutHook workspaces - defaultGaps keys mouseBindings borderWidth logHook = do +makeMain :: LayoutClass l Window => XMonadConfig l -> IO () +makeMain xmc = do hunk ./EventLoop.hs 60 - nbc <- initColor dpy normalBorderColor - fbc <- initColor dpy focusedBorderColor + nbc <- initColor dpy $ normalBorderColor xmc + fbc <- initColor dpy $ focusedBorderColor xmc hunk ./EventLoop.hs 65 - let initialWinset = new layoutHook workspaces $ zipWith SD xinesc gaps + let initialWinset = new (Layout $ layoutHook xmc) (workspaces xmc) $ zipWith SD xinesc gaps hunk ./EventLoop.hs 74 - return . W.ensureTags layoutHook workspaces - $ W.mapLayout (fromMaybe layoutHook . maybeRead) ws + return . W.ensureTags (Layout $ layoutHook xmc) (workspaces xmc) + $ W.mapLayout (fromMaybe (Layout $ layoutHook xmc) . maybeRead) ws hunk ./EventLoop.hs 77 - gaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0) + gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0) hunk ./EventLoop.hs 81 + , XMonad.logHook = logHook xmc + , XMonad.borderWidth = borderWidth xmc + , terminal = defaultTerminal xmc hunk ./EventLoop.hs 103 - grabKeys keys - grabButtons mouseBindings + grabKeys xmc + grabButtons xmc hunk ./EventLoop.hs 140 - userCode $ whenJust (M.lookup (cleanMask m,s) keys) id + userCode $ whenJust (M.lookup (cleanMask m,s) (keys xmc)) id hunk ./EventLoop.hs 164 - when (ev_request e == mappingKeyboard) (grabKeys keys) + when (ev_request e == mappingKeyboard) (grabKeys xmc) hunk ./EventLoop.hs 188 - if isr then userCode $ whenJust (M.lookup (cleanMask (ev_state e), b) mouseBindings) ($ ev_subwindow e) + if isr then userCode $ whenJust (M.lookup (cleanMask (ev_state e), b) $ mouseBindings xmc) ($ ev_subwindow e) hunk ./EventLoop.hs 215 - , wc_border_width = fromIntegral borderWidth + , wc_border_width = fromIntegral (borderWidth xmc) hunk ./EventLoop.hs 232 - | t == propertyNotify && a == wM_NAME = userCode logHook + | t == propertyNotify && a == wM_NAME = userCode $ logHook xmc hunk ./EventLoop.hs 259 -grabKeys :: M.Map (ButtonMask,KeySym) (X ()) -> X () -grabKeys keys = do +grabKeys :: XMonadConfig l -> X () +grabKeys xmc = do hunk ./EventLoop.hs 264 - forM_ (M.keys keys) $ \(mask,sym) -> do + forM_ (M.keys $ keys xmc) $ \(mask,sym) -> do hunk ./EventLoop.hs 271 -grabButtons :: M.Map (ButtonMask, Button) (Window -> X ()) -> X () -grabButtons mouseBindings = do +grabButtons :: XMonadConfig l -> X () +grabButtons xmc = do hunk ./EventLoop.hs 277 - mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) extraModifiers) (M.keys mouseBindings) + mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) extraModifiers) (M.keys $ mouseBindings xmc) hunk ./Main.hs 22 -import XMonad +import Control.Monad.Reader ( asks ) +import XMonad hiding ( logHook, borderWidth ) hunk ./Main.hs 31 -import EventLoop +import EventLoop hiding ( workspaces ) +import qualified EventLoop ( workspaces ) hunk ./Main.hs 72 --- | Width of the window border in pixels. --- -borderWidth :: Dimension -borderWidth = 1 - --- | Border colors for unfocused and focused windows, respectively. --- -normalBorderColor, focusedBorderColor :: String -normalBorderColor = "#dddddd" -focusedBorderColor = "#ff0000" - hunk ./Main.hs 84 -defaultGaps :: [(Int,Int,Int,Int)] -defaultGaps = [(0,0,0,0)] -- 15 for default dzen font +--defaultGaps :: [(Int,Int,Int,Int)] + hunk ./Main.hs 152 --- | The top level layout switcher. Most users will not need to modify this binding. --- --- By default, we simply switch between the layouts listed in `layouts' --- above, but you may program your own selection behaviour here. Layout --- transformers, for example, would be hooked in here. --- -layoutHook :: Layout Window -layoutHook = Layout $ Select layouts - hunk ./Main.hs 156 -serialisedLayouts = layoutHook : layouts - ------------------------------------------------------------------------- --- Logging - --- | Perform an arbitrary action on each internal state change or X event. --- Examples include: --- * do nothing --- * log the state to stdout --- --- See the 'DynamicLog' extension for examples. --- -logHook :: X () -logHook = return () +serialisedLayouts = Layout (layoutHook defaultConfig) : layouts hunk ./Main.hs 161 --- | The preferred terminal program, which is used in a binding below and by --- certain contrib modules. -terminal :: String -terminal = "xterm" - hunk ./Main.hs 168 - [ ((modMask .|. shiftMask, xK_Return), spawn terminal) -- %! Launch terminal + [ ((modMask .|. shiftMask, xK_Return), asks terminal >>= spawn) -- %! Launch terminal hunk ./Main.hs 174 - , ((modMask .|. shiftMask, xK_space ), setLayout layoutHook) -- %! Reset the layouts on the current workspace to default + , ((modMask .|. shiftMask, xK_space ), setLayout $ layoutHook defaultConfig) -- %! Reset the layouts on the current workspace to default hunk ./Main.hs 201 - , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps defaultConfig ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap hunk ./Main.hs 241 +defaultConfig :: XMonadConfig Select +defaultConfig = XMonadConfig { borderWidth = 1 -- Width of the window border in pixels. + , EventLoop.workspaces = workspaces + , defaultGaps = [(0,0,0,0)] -- 15 for default dzen font + -- | The top level layout switcher. Most users will not need to modify this binding. + -- + -- By default, we simply switch between the layouts listed in `layouts' + -- above, but you may program your own selection behaviour here. Layout + -- transformers, for example, would be hooked in here. + -- + , layoutHook = Select layouts + , defaultTerminal = "xterm" -- The preferred terminal program. + , normalBorderColor = "#dddddd" -- Border color for unfocused windows. + , focusedBorderColor = "#ff0000" -- Border color for focused windows. + , EventLoop.keys = Main.keys + , EventLoop.mouseBindings = Main.mouseBindings + -- | Perform an arbitrary action on each internal state change or X event. + -- Examples include: + -- * do nothing + -- * log the state to stdout + -- + -- See the 'DynamicLog' extension for examples. + , logHook = return () + } hunk ./Main.hs 269 -main = makeMain normalBorderColor focusedBorderColor layoutHook workspaces - defaultGaps keys mouseBindings borderWidth logHook +main = makeMain defaultConfig hunk ./Main.hs-boot 2 -import Graphics.X11.Xlib.Types (Dimension) hunk ./Main.hs-boot 4 -borderWidth :: Dimension hunk ./Main.hs-boot 6 -logHook :: X () hunk ./Main.hs-boot 8 -terminal :: String hunk ./Operations.hs 40 -import {-# SOURCE #-} Main (borderWidth,logHook,manageHook,numlockMask,serialisedLayouts) +import {-# SOURCE #-} Main (manageHook,numlockMask,serialisedLayouts) hunk ./Operations.hs 173 - userCode logHook + asks logHook >>= userCode hunk ./Operations.hs 217 - io $ setWindowBorderWidth d w borderWidth + bw <- asks borderWidth + io $ setWindowBorderWidth d w bw hunk ./Operations.hs 547 + bw <- fi `fmap` asks borderWidth hunk ./Operations.hs 552 - bw = fi borderWidth hunk ./XMonad.hs 53 + , logHook :: !(X ()) -- ^ the loghook function + , terminal :: !String -- ^ the user's preferred terminal hunk ./XMonad.hs 56 + , borderWidth :: !Dimension -- ^ the preferred border width hunk ./EventLoop.hs 1 +{-# LANGUAGE MultiParamTypeClasses #-} hunk ./EventLoop.hs 39 -data XMonadConfig l = XMonadConfig { normalBorderColor :: !String - , focusedBorderColor :: !String - , defaultTerminal :: !String - , layoutHook :: !(l Window) - , workspaces :: ![String] - , defaultGaps :: ![(Int,Int,Int,Int)] - , keys :: !(M.Map (ButtonMask,KeySym) (X ())) - , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) - , borderWidth :: !Dimension - , logHook :: !(X ()) - } +data XMonadConfig = forall l. (LayoutClass l Window, Read (l Window)) => + XMonadConfig { normalBorderColor :: !String + , focusedBorderColor :: !String + , defaultTerminal :: !String + , layoutHook :: !(l Window) + , workspaces :: ![String] + , defaultGaps :: ![(Int,Int,Int,Int)] + , keys :: !(M.Map (ButtonMask,KeySym) (X ())) + , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) + , borderWidth :: !Dimension + , logHook :: !(X ()) + } hunk ./EventLoop.hs 55 -makeMain :: LayoutClass l Window => XMonadConfig l -> IO () +makeMain :: XMonadConfig -> IO () hunk ./EventLoop.hs 67 - let initialWinset = new (Layout $ layoutHook xmc) (workspaces xmc) $ zipWith SD xinesc gaps + let (layout, lreads) = case xmc of XMonadConfig {layoutHook = lh } -> (Layout lh, \s -> [(Layout (x `asTypeOf` lh), s') | (x, s') <- reads s]) + initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps hunk ./EventLoop.hs 70 - maybeRead s = case reads s of - [(x, "")] -> Just x - _ -> Nothing + maybeRead reads' s = case reads' s of + [(x, "")] -> Just x + _ -> Nothing hunk ./EventLoop.hs 76 - ws <- maybeRead s - return . W.ensureTags (Layout $ layoutHook xmc) (workspaces xmc) - $ W.mapLayout (fromMaybe (Layout $ layoutHook xmc) . maybeRead) ws + ws <- maybeRead reads s + return . W.ensureTags layout (workspaces xmc) + $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws hunk ./EventLoop.hs 262 -grabKeys :: XMonadConfig l -> X () +grabKeys :: XMonadConfig -> X () hunk ./EventLoop.hs 274 -grabButtons :: XMonadConfig l -> X () +grabButtons :: XMonadConfig -> X () addfile ./Layouts.hs hunk ./Layouts.hs 1 +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +-- -------------------------------------------------------------------------- +-- | +-- Module : Layouts.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, Typeable deriving, mtl, posix +-- +-- The collection of core layouts. +-- +----------------------------------------------------------------------------- + +module Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), + Full(..), Tall(..), Mirror(..), splitVertically, + splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where + +import XMonad + +import Graphics.X11 (Rectangle(..)) +import qualified StackSet as W +import Control.Arrow ((***), second) +import Control.Monad +import Data.Maybe (fromMaybe) + + +------------------------------------------------------------------------ +-- LayoutClass selection manager + +-- | A layout that allows users to switch between various layout options. + +-- | Messages to change the current layout. +data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) + +instance Message ChangeLayout + +-- | The layout choice combinator +(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a +(|||) = flip SLeft +infixr 5 ||| + +data Choose l r a = SLeft (r a) (l a) + | SRight (l a) (r a) deriving (Read, Show) + +data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) +instance Message NextNoWrap + +-- This has lots of pseudo duplicated code, we must find a better way +instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where + doLayout (SLeft r l) = (fmap (second . fmap $ SLeft r) .) . doLayout l + doLayout (SRight l r) = (fmap (second . fmap $ SRight l) .) . doLayout r + + description (SLeft _ l) = description l + description (SRight _ r) = description r + + handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of + SLeft {} -> return Nothing + SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) $ handleMessage r m + + handleMessage lr m | Just NextLayout <- fromMessage m = do + mlr <- handleMessage lr $ SomeMessage NextNoWrap + maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr + + handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do + handleMessage l (SomeMessage Hide) + mr <- handleMessage r (SomeMessage FirstLayout) + return . Just . SRight l $ fromMaybe r mr + + -- The default cases for left and right: + handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m + handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m + +-- +-- | Builtin layout algorithms: +-- +-- > fullscreen mode +-- > tall mode +-- +-- The latter algorithms support the following operations: +-- +-- > Shrink +-- > Expand +-- +data Resize = Shrink | Expand deriving Typeable + +-- | You can also increase the number of clients in the master pane +data IncMasterN = IncMasterN Int deriving Typeable + +instance Message Resize +instance Message IncMasterN + +-- | Simple fullscreen mode, just render all windows fullscreen. +data Full a = Full deriving (Show, Read) + +instance LayoutClass Full a + +-- | The inbuilt tiling mode of xmonad, and its operations. +data Tall a = Tall Int Rational Rational deriving (Show, Read) + +instance LayoutClass Tall a where + pureLayout (Tall nmaster _ frac) r s = zip ws rs + where ws = W.integrate s + rs = tile frac r nmaster (length ws) + + pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] + where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) + resize Expand = Tall nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac + description _ = "Tall" + +-- | Mirror a rectangle +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) + +-- | Mirror a layout, compute its 90 degree rotated form. +data Mirror l a = Mirror (l a) deriving (Show, Read) + +instance LayoutClass l a => LayoutClass (Mirror l) a where + doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror) + `fmap` doLayout l (mirrorRect r) s + handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l + description (Mirror l) = "Mirror "++ description l + +-- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. +-- +-- The screen is divided (currently) into two panes. all clients are +-- then partioned between these two panes. one pane, the `master', by +-- convention has the least number of windows in it (by default, 1). +-- the variable `nmaster' controls how many windows are rendered in the +-- master pane. +-- +-- `delta' specifies the ratio of the screen to resize by. +-- +-- 'frac' specifies what proportion of the screen to devote to the +-- master area. +-- +tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle] +tile f r nmaster n = if n <= nmaster || nmaster == 0 + then splitVertically n r + else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns + where (r1,r2) = splitHorizontallyBy f r + +-- +-- Divide the screen vertically into n subrectangles +-- +splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle] +splitVertically n r | n < 2 = [r] +splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : + splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) + where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. + +splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect + +-- Divide the screen into two rectangles, using a rational to specify the ratio +splitHorizontallyBy, splitVerticallyBy :: 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 + +splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect hunk ./Main.hs 24 +import Layouts hunk ./Main.hs 132 --- | The list of possible layouts. Add your custom layouts to this list. -layouts :: [Layout Window] -layouts = [ Layout tiled - , Layout $ Mirror tiled - , Layout Full - -- Add extra layouts you want to use here: - -- % Extension-provided layouts - ] +-- | The available layouts. Note that each layout is separated by |||, which +-- denotes layout choice. +layout = tiled ||| Mirror tiled ||| Full + -- Add extra layouts you want to use here: + -- % Extension-provided layouts hunk ./Main.hs 150 --- | Register with xmonad a list of layouts whose state we can preserve over restarts. --- There is typically no need to modify this list, the defaults are fine. --- -serialisedLayouts :: [Layout Window] -serialisedLayouts = Layout (layoutHook defaultConfig) : layouts - hunk ./Main.hs 166 - , ((modMask .|. shiftMask, xK_space ), setLayout $ layoutHook defaultConfig) -- %! Reset the layouts on the current workspace to default + , ((modMask .|. shiftMask, xK_space ), setLayout $ Layout layout) -- %! Reset the layouts on the current workspace to default hunk ./Main.hs 233 -defaultConfig :: XMonadConfig Select +defaultConfig :: XMonadConfig hunk ./Main.hs 242 - -- - , layoutHook = Select layouts + -- + , layoutHook = layout hunk ./Main.hs-boot 7 -serialisedLayouts :: [Layout Window] hunk ./Operations.hs 22 +import Layouts (Full(..)) hunk ./Operations.hs 41 -import {-# SOURCE #-} Main (manageHook,numlockMask,serialisedLayouts) +import {-# SOURCE #-} Main (manageHook,numlockMask) hunk ./Operations.hs 115 -data LayoutMessages = Hide | ReleaseResources deriving ( Typeable, Eq ) - -instance Message LayoutMessages - hunk ./Operations.hs 353 --- | X Events are valid Messages -instance Message Event - ------------------------------------------------------------------------- --- LayoutClass selection manager - --- | A layout that allows users to switch between various layout options. --- This layout accepts three Messages: --- --- > NextLayout --- > PrevLayout --- > JumpToLayout. --- -data ChangeLayout = NextLayout | PrevLayout | JumpToLayout String - deriving (Eq, Show, Typeable) - -instance Message ChangeLayout - -instance ReadableLayout Window where - readTypes = Layout (Select []) : - Layout Full : Layout (Tall 1 0.1 0.5) : - Layout (Mirror $ Tall 1 0.1 0.5) : - serialisedLayouts - -data Select a = Select [Layout a] deriving (Show, Read) - -instance ReadableLayout a => LayoutClass Select a where - doLayout (Select (l:ls)) r s = - second (fmap (Select . (:ls))) `fmap` doLayout l r s - doLayout (Select []) r s = - second (const Nothing) `fmap` doLayout Full r s - - -- respond to messages only when there's an actual choice: - handleMessage (Select (l:ls@(_:_))) m - | Just NextLayout <- fromMessage m = switchl rls - | Just PrevLayout <- fromMessage m = switchl rls' - | Just (JumpToLayout x) <- fromMessage m = switchl (j x) - | Just ReleaseResources <- fromMessage m = do -- each branch has a different type - mlls' <- mapM (flip handleMessage m) (l:ls) - let lls' = zipWith fromMaybe (l:ls) mlls' - return (Just (Select lls')) - - where rls [] = [] - rls (x:xs) = xs ++ [x] - rls' = reverse . rls . reverse - - j s zs = case partition ((s ==) . description) zs of (xs,ys) -> xs++ys - - switchl f = do ml' <- handleMessage l (SomeMessage Hide) - return $ Just (Select $ f $ fromMaybe l ml':ls) - - -- otherwise, or if we don't understand the message, pass it along to the real layout: - handleMessage (Select (l:ls)) m = - fmap (Select . (:ls)) `fmap` handleMessage l m - - -- Unless there is no layout... - handleMessage (Select []) _ = return Nothing - - description (Select (x:_)) = description x - description _ = "default" - --- --- | Builtin layout algorithms: --- --- > fullscreen mode --- > tall mode --- --- The latter algorithms support the following operations: --- --- > Shrink --- > Expand --- -data Resize = Shrink | Expand deriving Typeable - --- | You can also increase the number of clients in the master pane -data IncMasterN = IncMasterN Int deriving Typeable - -instance Message Resize -instance Message IncMasterN - --- | Simple fullscreen mode, just render all windows fullscreen. -data Full a = Full deriving (Show, Read) - -instance LayoutClass Full a - --- | The inbuilt tiling mode of xmonad, and its operations. -data Tall a = Tall Int Rational Rational deriving (Show, Read) - -instance LayoutClass Tall a where - pureLayout (Tall nmaster _ frac) r s = zip ws rs - where ws = W.integrate s - rs = tile frac r nmaster (length ws) - - pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m) - ,fmap incmastern (fromMessage m)] - where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) - resize Expand = Tall nmaster delta (min 1 $ frac+delta) - incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac - description _ = "Tall" - --- | Mirror a rectangle -mirrorRect :: Rectangle -> Rectangle -mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) - --- | Mirror a layout, compute its 90 degree rotated form. -data Mirror l a = Mirror (l a) deriving (Show, Read) - -instance LayoutClass l a => LayoutClass (Mirror l) a where - doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror) - `fmap` doLayout l (mirrorRect r) s - handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l - description (Mirror l) = "Mirror "++ description l - --- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. --- --- The screen is divided (currently) into two panes. all clients are --- then partioned between these two panes. one pane, the `master', by --- convention has the least number of windows in it (by default, 1). --- the variable `nmaster' controls how many windows are rendered in the --- master pane. --- --- `delta' specifies the ratio of the screen to resize by. --- --- 'frac' specifies what proportion of the screen to devote to the --- master area. --- -tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle] -tile f r nmaster n = if n <= nmaster || nmaster == 0 - then splitVertically n r - else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns - where (r1,r2) = splitHorizontallyBy f r - --- --- Divide the screen vertically into n subrectangles --- -splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle] -splitVertically n r | n < 2 = [r] -splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : - splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) - where smallh = sh `div` fromIntegral n --hmm, this is a fold or map. - -splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect - --- Divide the screen into two rectangles, using a rational to specify the ratio -splitHorizontallyBy, splitVerticallyBy :: 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 - --- | XXX comment me -splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect - hunk ./XMonad.hs 19 - X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), LayoutClass(..), Layout(..), ReadableLayout(..), - Typeable, Message, SomeMessage(..), fromMessage, runLayout, + X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), LayoutClass(..), Layout(..), + Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), hunk ./XMonad.hs 31 -import Control.Arrow (first) hunk ./XMonad.hs 36 --- for Read instance -import Graphics.X11.Xlib.Extras () +import Graphics.X11.Xlib.Extras (Event) hunk ./XMonad.hs 50 - { display :: Display -- ^ the X11 display - , logHook :: !(X ()) -- ^ the loghook function - , terminal :: !String -- ^ the user's preferred terminal - , theRoot :: !Window -- ^ the root window - , borderWidth :: !Dimension -- ^ the preferred border width - , normalBorder :: !Pixel -- ^ border color of unfocused windows - , focusedBorder :: !Pixel } -- ^ border color of the focused window + { display :: Display -- ^ the X11 display + , logHook :: !(X ()) -- ^ the loghook function + , terminal :: !String -- ^ the user's preferred terminal + , theRoot :: !Window -- ^ the root window + , borderWidth :: !Dimension -- ^ the preferred border width + , normalBorder :: !Pixel -- ^ border color of unfocused windows + , focusedBorder :: !Pixel } -- ^ border color of the focused window hunk ./XMonad.hs 136 -data Layout a = forall l. LayoutClass l a => Layout (l a) +data Layout a = forall l. (LayoutClass l a) => Layout (l a) hunk ./XMonad.hs 139 --- | This class defines a set of layout types (held in Layout --- objects) that are used when trying to read an existentially wrapped Layout. -class ReadableLayout a where - readTypes :: [Layout a] - hunk ./XMonad.hs 146 -class (Show (layout a), Read (layout a)) => LayoutClass layout a where +class Show (layout a) => LayoutClass layout a where hunk ./XMonad.hs 180 --- Here's the magic for parsing serialised state of existentially --- wrapped layouts: attempt to parse using the Read instance from each --- type in our list of types, if any suceed, take the first one. -instance ReadableLayout a => Read (Layout a) where - - -- We take the first parse only, because multiple matches indicate a bad parse. - readsPrec _ s = take 1 $ concatMap readLayout readTypes - where - readLayout (Layout x) = map (first Layout) $ readAsType x - - -- the type indicates which Read instance to dispatch to. - -- That is, read asTypeOf the argument from the readTypes. - readAsType :: LayoutClass l a => l a -> [(l a, String)] - readAsType _ = reads s - -instance ReadableLayout a => LayoutClass Layout a where +instance LayoutClass Layout Window where hunk ./XMonad.hs 210 +-- | X Events are valid Messages +instance Message Event + +-- | LayoutMessages are core messages that all layouts (especially stateful +-- layouts) should consider handling. +data LayoutMessages = Hide -- ^ sent when a layout becomes non-visible + | ReleaseResources -- ^ sent when xmonad is exiting or restarting + deriving (Typeable, Eq) + +instance Message LayoutMessages + hunk ./tests/Properties.hs 6 -import Operations (tile) hunk ./xmonad.cabal 26 -other-modules: EventLoop Operations StackSet XMonad +other-modules: EventLoop Layouts Operations StackSet XMonad hunk ./EventLoop.hs 16 -module EventLoop ( makeMain, XMonadConfig(..) ) where +module EventLoop (makeMain) where hunk ./EventLoop.hs 31 -import XMonad hiding ( logHook, borderWidth ) -import qualified XMonad ( logHook, borderWidth ) +import XMonad hunk ./EventLoop.hs 38 -data XMonadConfig = forall l. (LayoutClass l Window, Read (l Window)) => - XMonadConfig { normalBorderColor :: !String - , focusedBorderColor :: !String - , defaultTerminal :: !String - , layoutHook :: !(l Window) - , workspaces :: ![String] - , defaultGaps :: ![(Int,Int,Int,Int)] - , keys :: !(M.Map (ButtonMask,KeySym) (X ())) - , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) - , borderWidth :: !Dimension - , logHook :: !(X ()) - } - hunk ./EventLoop.hs 41 -makeMain :: XMonadConfig -> IO () +makeMain :: XConfig -> IO () hunk ./EventLoop.hs 53 - let (layout, lreads) = case xmc of XMonadConfig {layoutHook = lh } -> (Layout lh, \s -> [(Layout (x `asTypeOf` lh), s') | (x, s') <- reads s]) + let (layout, lreads) = case xmc of XConfig {layoutHook = lh } -> (Layout lh, \s -> [(Layout (x `asTypeOf` lh), s') | (x, s') <- reads s]) hunk ./EventLoop.hs 70 - , XMonad.logHook = logHook xmc - , XMonad.borderWidth = borderWidth xmc + , config = xmc hunk ./EventLoop.hs 247 -grabKeys :: XMonadConfig -> X () +grabKeys :: XConfig -> X () hunk ./EventLoop.hs 259 -grabButtons :: XMonadConfig -> X () +grabButtons :: XConfig -> X () hunk ./Main.hs 23 -import XMonad hiding ( logHook, borderWidth ) +import XMonad hiding (workspaces) +import qualified XMonad (workspaces) hunk ./Main.hs 33 -import EventLoop hiding ( workspaces ) -import qualified EventLoop ( workspaces ) +import EventLoop hunk ./Main.hs 233 -defaultConfig :: XMonadConfig -defaultConfig = XMonadConfig { borderWidth = 1 -- Width of the window border in pixels. - , EventLoop.workspaces = workspaces - , defaultGaps = [(0,0,0,0)] -- 15 for default dzen font - -- | The top level layout switcher. Most users will not need to modify this binding. - -- - -- By default, we simply switch between the layouts listed in `layouts' - -- above, but you may program your own selection behaviour here. Layout - -- transformers, for example, would be hooked in here. - -- - , layoutHook = layout - , defaultTerminal = "xterm" -- The preferred terminal program. - , normalBorderColor = "#dddddd" -- Border color for unfocused windows. - , focusedBorderColor = "#ff0000" -- Border color for focused windows. - , EventLoop.keys = Main.keys - , EventLoop.mouseBindings = Main.mouseBindings - -- | Perform an arbitrary action on each internal state change or X event. - -- Examples include: - -- * do nothing - -- * log the state to stdout - -- - -- See the 'DynamicLog' extension for examples. - , logHook = return () - } +defaultConfig :: XConfig +defaultConfig = XConfig { borderWidth = 1 -- Width of the window border in pixels. + , XMonad.workspaces = workspaces + , defaultGaps = [(0,0,0,0)] -- 15 for default dzen font + -- | The top level layout switcher. Most users will not need to modify this binding. + -- + -- By default, we simply switch between the layouts listed in `layouts' + -- above, but you may program your own selection behaviour here. Layout + -- transformers, for example, would be hooked in here. + -- + , layoutHook = layout + , defaultTerminal = "xterm" -- The preferred terminal program. + , normalBorderColor = "#dddddd" -- Border color for unfocused windows. + , focusedBorderColor = "#ff0000" -- Border color for focused windows. + , XMonad.keys = Main.keys + , XMonad.mouseBindings = Main.mouseBindings + -- | Perform an arbitrary action on each internal state change or X event. + -- Examples include: + -- * do nothing + -- * log the state to stdout + -- + -- See the 'DynamicLog' extension for examples. + , logHook = return () + } hunk ./Operations.hs 170 - asks logHook >>= userCode + asks (logHook . config) >>= userCode hunk ./Operations.hs 214 - bw <- asks borderWidth + bw <- asks (borderWidth . config) hunk ./Operations.hs 391 - bw <- fi `fmap` asks borderWidth + bw <- fi `fmap` asks (borderWidth . config) hunk ./XMonad.hs 19 - X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), LayoutClass(..), Layout(..), + X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), XConfig(..), LayoutClass(..), Layout(..), hunk ./XMonad.hs 49 + hunk ./XMonad.hs 52 - , logHook :: !(X ()) -- ^ the loghook function + , config :: !XConfig -- ^ initial user configuration hunk ./XMonad.hs 55 - , borderWidth :: !Dimension -- ^ the preferred border width hunk ./XMonad.hs 58 +-- todo, better name +data XConfig = forall l. (LayoutClass l Window, Read (l Window)) => + XConfig { normalBorderColor :: !String + , focusedBorderColor :: !String + , defaultTerminal :: !String + , layoutHook :: !(l Window) + , workspaces :: ![String] + , defaultGaps :: ![(Int,Int,Int,Int)] + , keys :: !(M.Map (ButtonMask,KeySym) (X ())) + , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) + , borderWidth :: !Dimension + , logHook :: !(X ()) + } + hunk ./EventLoop.hs 71 - , terminal = defaultTerminal xmc hunk ./Main.hs 160 - [ ((modMask .|. shiftMask, xK_Return), asks terminal >>= spawn) -- %! Launch terminal + [ ((modMask .|. shiftMask, xK_Return), asks (terminal . config) >>= spawn) -- %! Launch terminal hunk ./Main.hs 244 - , defaultTerminal = "xterm" -- The preferred terminal program. + , terminal = "xterm" -- The preferred terminal program. hunk ./XMonad.hs 53 - , terminal :: !String -- ^ the user's preferred terminal hunk ./XMonad.hs 61 - , defaultTerminal :: !String + , terminal :: !String hunk ./Operations.hs 26 -import Data.List (nub, (\\), find, partition) +import Data.List (nub, (\\), find) hunk ./Operations.hs 34 -import Control.Arrow ((***), second) hunk ./Main.hs-boot 5 -workspaces :: [WorkspaceId] hunk ./Main.hs 23 -import XMonad hiding (workspaces) -import qualified XMonad (workspaces) +import XMonad hiding (workspaces, manageHook) +import qualified XMonad (workspaces, manageHook) hunk ./Main.hs 256 + , XMonad.manageHook = manageHook hunk ./Main.hs-boot 5 -manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) hunk ./Operations.hs 40 -import {-# SOURCE #-} Main (manageHook,numlockMask) +import {-# SOURCE #-} Main (numlockMask) hunk ./Operations.hs 70 - g <- manageHook w n rn rc `catchX` return id + mh <- asks (manageHook . config) + g <- mh w n rn rc `catchX` return id hunk ./XMonad.hs 63 + , manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) hunk ./EventLoop.hs 127 - userCode $ whenJust (M.lookup (cleanMask m,s) (keys xmc)) id + mClean <- cleanMask m + userCode $ whenJust (M.lookup (mClean, s) (keys xmc)) id hunk ./EventLoop.hs 176 - if isr then userCode $ whenJust (M.lookup (cleanMask (ev_state e), b) $ mouseBindings xmc) ($ ev_subwindow e) + m <- cleanMask $ ev_state e + if isr then userCode $ whenJust (M.lookup (m, b) $ mouseBindings xmc) ($ ev_subwindow e) hunk ./EventLoop.hs 257 - when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) extraModifiers + when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers hunk ./EventLoop.hs 266 - mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) extraModifiers) (M.keys $ mouseBindings xmc) + ems <- extraModifiers + mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ mouseBindings xmc) hunk ./Main.hs 23 -import XMonad hiding (workspaces, manageHook) -import qualified XMonad (workspaces, manageHook) +import XMonad hiding (workspaces, manageHook, numlockMask) +import qualified XMonad (workspaces, manageHook, numlockMask) hunk ./Main.hs 247 + , XMonad.numlockMask = numlockMask hunk ./Main.hs-boot 1 -module Main where -import Graphics.X11.Xlib (KeyMask,Window) -import XMonad -numlockMask :: KeyMask rmfile ./Main.hs-boot hunk ./Operations.hs 40 -import {-# SOURCE #-} Main (numlockMask) - hunk ./Operations.hs 368 -extraModifiers :: [KeyMask] -extraModifiers = [0, numlockMask, lockMask, numlockMask .|. lockMask ] +extraModifiers :: X [KeyMask] +extraModifiers = do + nlm <- asks (numlockMask . config) + return [0, nlm, lockMask, nlm .|. lockMask ] hunk ./Operations.hs 374 -cleanMask :: KeyMask -> KeyMask -cleanMask = (complement (numlockMask .|. lockMask) .&.) +cleanMask :: KeyMask -> X KeyMask +cleanMask km = do + nlm <- asks (numlockMask . config) + return (complement (nlm .|. lockMask) .&. km) hunk ./XMonad.hs 66 + , numlockMask :: KeyMask hunk ./EventLoop.hs 53 - let (layout, lreads) = case xmc of XConfig {layoutHook = lh } -> (Layout lh, \s -> [(Layout (x `asTypeOf` lh), s') | (x, s') <- reads s]) + let layout = layoutHook xmc + lreads = readsLayout layout hunk ./Main.hs 243 - , layoutHook = layout + , layoutHook = Layout layout hunk ./Operations.hs 345 -setLayout :: LayoutClass l Window => l Window -> X () +setLayout :: Layout Window -> X () hunk ./Operations.hs 349 - windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = Layout l } } } + windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = l } } } hunk ./XMonad.hs 19 - X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), XConfig(..), LayoutClass(..), Layout(..), - Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), + X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), XConfig(..), LayoutClass(..), Layout(..), readsLayout, Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), hunk ./XMonad.hs 57 -data XConfig = forall l. (LayoutClass l Window, Read (l Window)) => - XConfig { normalBorderColor :: !String - , focusedBorderColor :: !String - , terminal :: !String - , layoutHook :: !(l Window) - , manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) - , workspaces :: ![String] - , defaultGaps :: ![(Int,Int,Int,Int)] - , numlockMask :: KeyMask - , keys :: !(M.Map (ButtonMask,KeySym) (X ())) - , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) - , borderWidth :: !Dimension - , logHook :: !(X ()) - } +data XConfig = XConfig { normalBorderColor :: !String + , focusedBorderColor :: !String + , terminal :: !String + , layoutHook :: !(Layout Window) + , manageHook :: !(Window -> String -> String -> String -> X (WindowSet -> WindowSet)) + , workspaces :: ![String] + , defaultGaps :: ![(Int,Int,Int,Int)] + , numlockMask :: KeyMask + , keys :: !(M.Map (ButtonMask,KeySym) (X ())) + , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) + , borderWidth :: !Dimension + , logHook :: !(X ()) } hunk ./XMonad.hs 147 --- | An existential type that can hold any object that is in the LayoutClass. -data Layout a = forall l. (LayoutClass l a) => Layout (l a) +-- | An existential type that can hold any object that is in Read and LayoutClass. +data Layout a = forall l. (LayoutClass l a, Read (l a)) => Layout (l a) hunk ./XMonad.hs 150 +-- | Using the 'Layout' as a witness, parse existentially wrapped windows +-- from a 'String' +readsLayout :: Layout a -> String -> [(Layout a, String)] +readsLayout (Layout l) s = [(Layout (asTypeOf x l), rs) | (x, rs) <- reads s] hunk ./Main.hs 17 -module Main where +module Main (main) where hunk ./Layouts.hs 19 - Full(..), Tall(..), Mirror(..), splitVertically, + Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, hunk ./Layouts.hs 62 - SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) $ handleMessage r m + SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) + $ handleMessage r (SomeMessage Hide) hunk ./Layouts.hs 73 + + handleMessage lr m | Just ReleaseResources <- fromMessage m = + liftM2 ((Just .) . cons) + (fmap (fromMaybe l) $ handleMessage l m) + (fmap (fromMaybe r) $ handleMessage r m) + where (cons, l, r) = case lr of + (SLeft r l) -> (flip SLeft, l, r) + (SRight l r) -> (SRight, l, r) move ./Main.hs ./DefaultConfig.hs hunk ./DefaultConfig.hs 17 -module Main (main) where +module DefaultConfig (defaultConfig) where hunk ./DefaultConfig.hs 248 - , XMonad.keys = Main.keys - , XMonad.mouseBindings = Main.mouseBindings + , XMonad.keys = DefaultConfig.keys + , XMonad.mouseBindings = DefaultConfig.mouseBindings hunk ./DefaultConfig.hs 260 --- % The main function - -main :: IO () -main = makeMain defaultConfig - hunk ./EventLoop.hs 4 --- Module : Main.hs +-- Module : EventLoop.hs addfile ./Main.hs hunk ./Main.hs 1 +---------------------------------------------------------------------------- +-- | +-- Module : Main.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, uses mtl, X11, posix +-- +-- xmonad, a minimalist, tiling window manager for X11 +-- +----------------------------------------------------------------------------- + +module Main (main) where + +import EventLoop (makeMain) +import DefaultConfig (defaultConfig) + +import Control.Exception (handle) +import System.IO +import System.Process +import System.Directory +import System.Environment +import System.Exit +import System.Posix.Process (executeFile) + +-- | Build "~/.xmonad/Main.hs" with ghc, then execute it. If there are no +-- errors, this function does not return. An exception is raised in any of +-- these cases: +-- * ghc missing +-- * ~/.xmonad/Main.hs missing +-- * Main.hs fails to compile +-- * Missing xmonad/XMonadContrib modules due to ghc upgrade +-- +buildLaunch :: IO () +buildLaunch = do + dir <- fmap (++ "/.xmonad") getHomeDirectory + pid <- runProcess "ghc" ["--make", "Main.hs"] (Just dir) + Nothing Nothing Nothing Nothing + ExitSuccess <- waitForProcess pid + + args <- getArgs + executeFile (dir ++ "/Main") False args Nothing + return () + +main :: IO () +main = do + handle (hPrint stderr) buildLaunch + -- if buildLaunch returns, execute the trusted core + makeMain defaultConfig adddir ./XMonad move ./DefaultConfig.hs ./XMonad/DefaultConfig.hs move ./EventLoop.hs ./XMonad/EventLoop.hs move ./Layouts.hs ./XMonad/Layouts.hs move ./Operations.hs ./XMonad/Operations.hs move ./StackSet.hs ./XMonad/StackSet.hs hunk ./Main.hs 17 -import EventLoop (makeMain) -import DefaultConfig (defaultConfig) +import XMonad.EventLoop (makeMain) +import XMonad.DefaultConfig (defaultConfig) hunk ./XMonad.hs 24 -import StackSet +import XMonad.StackSet hunk ./XMonad/DefaultConfig.hs 3 --- Module : Config.hs +-- Module : DefaultConfig.hs hunk ./XMonad/DefaultConfig.hs 17 -module DefaultConfig (defaultConfig) where +module XMonad.DefaultConfig (defaultConfig) where hunk ./XMonad/DefaultConfig.hs 25 -import Layouts -import Operations -import qualified StackSet as W +import XMonad.Layouts +import XMonad.Operations +import qualified XMonad.StackSet as W hunk ./XMonad/DefaultConfig.hs 33 -import EventLoop hunk ./XMonad/DefaultConfig.hs 247 - , XMonad.keys = DefaultConfig.keys - , XMonad.mouseBindings = DefaultConfig.mouseBindings + , XMonad.keys = XMonad.DefaultConfig.keys + , XMonad.mouseBindings = XMonad.DefaultConfig.mouseBindings hunk ./XMonad/EventLoop.hs 16 -module EventLoop (makeMain) where +module XMonad.EventLoop (makeMain) where hunk ./XMonad/EventLoop.hs 32 -import StackSet (new, floating, member) -import qualified StackSet as W -import Operations +import XMonad.StackSet (new, floating, member) +import qualified XMonad.StackSet as W +import XMonad.Operations hunk ./XMonad/Layouts.hs 18 -module Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), +module XMonad.Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), hunk ./XMonad/Layouts.hs 25 -import qualified StackSet as W +import qualified XMonad.StackSet as W hunk ./XMonad/Operations.hs 19 -module Operations where +module XMonad.Operations where hunk ./XMonad/Operations.hs 22 -import Layouts (Full(..)) -import qualified StackSet as W +import XMonad.Layouts (Full(..)) +import qualified XMonad.StackSet as W hunk ./XMonad/StackSet.hs 14 -module StackSet ( +module XMonad.StackSet ( hunk ./tests/Properties.hs 4 -import StackSet hiding (filter) -import qualified StackSet as S (filter) +import XMonad.StackSet hiding (filter) +import qualified XMonad.StackSet as S (filter) hunk ./xmonad.cabal 22 - Config.hs-boot util/GenerateManpage.hs man/xmonad.1 man/xmonad.html + util/GenerateManpage.hs man/xmonad.1 man/xmonad.html hunk ./xmonad.cabal 26 -other-modules: EventLoop Layouts Operations StackSet XMonad +other-modules: XMonad.EventLoop XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad hunk ./xmonad.cabal 23 +exposed-modules: XMonad + XMonad.DefaultConfig + XMonad.EventLoop + XMonad.Layouts + XMonad.Operations + XMonad.StackSet hunk ./XMonad/DefaultConfig.hs 192 - , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps defaultConfig ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap + , ((modMask , xK_b ), do gs <- asks (defaultGaps . config) + modifyGap (\i n -> let x = (gs ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap hunk ./XMonad/DefaultConfig.hs 197 - , ((modMask , xK_q ), broadcastMessage ReleaseResources >> restart Nothing True) -- %! Restart xmonad + , ((modMask , xK_q ), broadcastMessage ReleaseResources >> restart (Just "xmonad") True) -- %! Restart xmonad hunk ./XMonad/DefaultConfig.hs 53 -modMask :: KeyMask -modMask = mod1Mask +defaultModMask :: KeyMask +defaultModMask = mod1Mask hunk ./XMonad/DefaultConfig.hs 156 -keys :: M.Map (KeyMask, KeySym) (X ()) -keys = M.fromList $ +keys :: XConfig -> M.Map (KeyMask, KeySym) (X ()) +keys conf@(XConfig {modMask = modMask}) = M.fromList $ hunk ./XMonad/DefaultConfig.hs 159 - [ ((modMask .|. shiftMask, xK_Return), asks (terminal . config) >>= spawn) -- %! Launch terminal + [ ((modMask .|. shiftMask, xK_Return), spawn $ terminal conf) -- %! Launch terminal hunk ./XMonad/DefaultConfig.hs 192 - , ((modMask , xK_b ), do gs <- asks (defaultGaps . config) - modifyGap (\i n -> let x = (gs ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps conf ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap hunk ./XMonad/DefaultConfig.hs 217 -mouseBindings :: M.Map (KeyMask, Button) (Window -> X ()) -mouseBindings = M.fromList $ +mouseBindings :: XConfig -> M.Map (KeyMask, Button) (Window -> X ()) +mouseBindings (XConfig {modMask = modMask}) = M.fromList $ hunk ./XMonad/DefaultConfig.hs 247 + , modMask = defaultModMask hunk ./XMonad/EventLoop.hs 74 - , focusedBorder = fbc } + , focusedBorder = fbc + , keyActions = keys xmc xmc + , buttonActions = mouseBindings xmc xmc } hunk ./XMonad/EventLoop.hs 93 - grabKeys xmc - grabButtons xmc + grabKeys + grabButtons hunk ./XMonad/EventLoop.hs 114 - -- --------------------------------------------------------------------- - -- | Event handler. Map X events onto calls into Operations.hs, which - -- modify our internal model of the window manager state. - -- - -- Events dwm handles that we don't: - -- - -- [ButtonPress] = buttonpress, - -- [Expose] = expose, - -- [PropertyNotify] = propertynotify, - -- - handle :: Event -> X () hunk ./XMonad/EventLoop.hs 115 - -- run window manager command - handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) - | t == keyPress = withDisplay $ \dpy -> do - s <- io $ keycodeToKeysym dpy code 0 - mClean <- cleanMask m - userCode $ whenJust (M.lookup (mClean, s) (keys xmc)) id +-- --------------------------------------------------------------------- +-- | Event handler. Map X events onto calls into Operations.hs, which +-- modify our internal model of the window manager state. +-- +-- Events dwm handles that we don't: +-- +-- [ButtonPress] = buttonpress, +-- [Expose] = expose, +-- [PropertyNotify] = propertynotify, +-- +handle :: Event -> X () + +-- run window manager command +handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code}) + | t == keyPress = withDisplay $ \dpy -> do + s <- io $ keycodeToKeysym dpy code 0 + mClean <- cleanMask m + ks <- asks keyActions + userCode $ whenJust (M.lookup (mClean, s) ks) id + +-- manage a new window +handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + wa <- io $ getWindowAttributes dpy w -- ignore override windows + -- need to ignore mapping requests by managed windows not on the current workspace + managed <- isClient w + when (not (wa_override_redirect wa) && not managed) $ do manage w hunk ./XMonad/EventLoop.hs 142 - -- manage a new window - handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - wa <- io $ getWindowAttributes dpy w -- ignore override windows - -- need to ignore mapping requests by managed windows not on the current workspace - managed <- isClient w - when (not (wa_override_redirect wa) && not managed) $ do manage w +-- window destroyed, unmanage it +-- window gone, unmanage it +handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w hunk ./XMonad/EventLoop.hs 146 - -- window destroyed, unmanage it - -- window gone, unmanage it - handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w +-- We track expected unmap events in waitingUnmap. We ignore this event unless +-- it is synthetic or we are not expecting an unmap notification from a window. +handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do + e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) + if (synthetic || e == 0) + then unmanage w + else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) hunk ./XMonad/EventLoop.hs 154 - -- We track expected unmap events in waitingUnmap. We ignore this event unless - -- it is synthetic or we are not expecting an unmap notification from a window. - handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do - e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap) - if (synthetic || e == 0) - then unmanage w - else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) +-- set keyboard mapping +handle e@(MappingNotifyEvent {}) = do + io $ refreshKeyboardMapping e + when (ev_request e == mappingKeyboard) grabKeys hunk ./XMonad/EventLoop.hs 159 - -- set keyboard mapping - handle e@(MappingNotifyEvent {}) = do - io $ refreshKeyboardMapping e - when (ev_request e == mappingKeyboard) (grabKeys xmc) +-- handle button release, which may finish dragging. +handle e@(ButtonEvent {ev_event_type = t}) + | t == buttonRelease = do + drag <- gets dragging + case drag of + -- we're done dragging and have released the mouse: + Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f + Nothing -> broadcastMessage e hunk ./XMonad/EventLoop.hs 168 - -- handle button release, which may finish dragging. - handle e@(ButtonEvent {ev_event_type = t}) - | t == buttonRelease = do - drag <- gets dragging - case drag of - -- we're done dragging and have released the mouse: - Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f - Nothing -> broadcastMessage e +-- handle motionNotify event, which may mean we are dragging. +handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do + drag <- gets dragging + case drag of + Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging + Nothing -> broadcastMessage e hunk ./XMonad/EventLoop.hs 175 - -- handle motionNotify event, which may mean we are dragging. - handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do - drag <- gets dragging - case drag of - Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging - Nothing -> broadcastMessage e +-- click on an unfocused window, makes it focused on this workspace +handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) + | t == buttonPress = do + -- If it's the root window, then it's something we + -- grabbed in grabButtons. Otherwise, it's click-to-focus. + isr <- isRoot w + m <- cleanMask $ ev_state e + ba <- asks buttonActions + if isr then userCode $ whenJust (M.lookup (m, b) ba) ($ ev_subwindow e) + else focus w + sendMessage e -- Always send button events. hunk ./XMonad/EventLoop.hs 187 - -- click on an unfocused window, makes it focused on this workspace - handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b }) - | t == buttonPress = do - -- If it's the root window, then it's something we - -- grabbed in grabButtons. Otherwise, it's click-to-focus. - isr <- isRoot w - m <- cleanMask $ ev_state e - if isr then userCode $ whenJust (M.lookup (m, b) $ mouseBindings xmc) ($ ev_subwindow e) - else focus w - sendMessage e -- Always send button events. +-- entered a normal window, makes this focused. +handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) + | t == enterNotify && ev_mode e == notifyNormal + && ev_detail e /= notifyInferior = focus w hunk ./XMonad/EventLoop.hs 192 - -- entered a normal window, makes this focused. - handle e@(CrossingEvent {ev_window = w, ev_event_type = t}) - | t == enterNotify && ev_mode e == notifyNormal - && ev_detail e /= notifyInferior = focus w +-- left a window, check if we need to focus root +handle e@(CrossingEvent {ev_event_type = t}) + | t == leaveNotify + = do rootw <- asks theRoot + when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw hunk ./XMonad/EventLoop.hs 198 - -- left a window, check if we need to focus root - handle e@(CrossingEvent {ev_event_type = t}) - | t == leaveNotify - = do rootw <- asks theRoot - when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw +-- configure a window +handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do + ws <- gets windowset + wa <- io $ getWindowAttributes dpy w hunk ./XMonad/EventLoop.hs 203 - -- configure a window - handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do - ws <- gets windowset - wa <- io $ getWindowAttributes dpy w + bw <- asks (borderWidth . config) hunk ./XMonad/EventLoop.hs 205 - if M.member w (floating ws) - || not (member w ws) - then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges - { wc_x = ev_x e - , wc_y = ev_y e - , wc_width = ev_width e - , wc_height = ev_height e - , wc_border_width = fromIntegral (borderWidth xmc) - , wc_sibling = ev_above e - , wc_stack_mode = ev_detail e } - when (member w ws) (float w) - else io $ allocaXEvent $ \ev -> do - setEventType ev configureNotify - setConfigureEvent ev w w - (wa_x wa) (wa_y wa) (wa_width wa) - (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) - sendEvent dpy w False 0 ev - io $ sync dpy False + if M.member w (floating ws) + || not (member w ws) + then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges + { wc_x = ev_x e + , wc_y = ev_y e + , wc_width = ev_width e + , wc_height = ev_height e + , wc_border_width = fromIntegral bw + , wc_sibling = ev_above e + , wc_stack_mode = ev_detail e } + when (member w ws) (float w) + else io $ allocaXEvent $ \ev -> do + setEventType ev configureNotify + setConfigureEvent ev w w + (wa_x wa) (wa_y wa) (wa_width wa) + (wa_height wa) (ev_border_width e) none (wa_override_redirect wa) + sendEvent dpy w False 0 ev + io $ sync dpy False hunk ./XMonad/EventLoop.hs 224 - -- configuration changes in the root may mean display settings have changed - handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen +-- configuration changes in the root may mean display settings have changed +handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen hunk ./XMonad/EventLoop.hs 227 - -- property notify - handle PropertyEvent { ev_event_type = t, ev_atom = a } - | t == propertyNotify && a == wM_NAME = userCode $ logHook xmc +-- property notify +handle PropertyEvent { ev_event_type = t, ev_atom = a } + | t == propertyNotify && a == wM_NAME = userCode =<< asks (logHook . config) hunk ./XMonad/EventLoop.hs 231 - handle e = broadcastMessage e -- trace (eventName e) -- ignoring +handle e = broadcastMessage e -- trace (eventName e) -- ignoring hunk ./XMonad/EventLoop.hs 256 -grabKeys :: XConfig -> X () -grabKeys xmc = do +grabKeys :: X () +grabKeys = do hunk ./XMonad/EventLoop.hs 261 - forM_ (M.keys $ keys xmc) $ \(mask,sym) -> do + ks <- asks keyActions + forM_ (M.keys ks) $ \(mask,sym) -> do hunk ./XMonad/EventLoop.hs 269 -grabButtons :: XConfig -> X () -grabButtons xmc = do +grabButtons :: X () +grabButtons = do hunk ./XMonad/EventLoop.hs 276 - mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ mouseBindings xmc) + ba <- asks buttonActions + mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba) hunk ./XMonad.hs 54 - , focusedBorder :: !Pixel } -- ^ border color of the focused window + , focusedBorder :: !Pixel -- ^ border color of the focused window + , keyActions :: !(M.Map (KeyMask, KeySym) (X ())) + -- ^ a mapping of key presses to actions + , buttonActions :: !(M.Map (KeyMask, Button) (Window -> X ())) + -- ^ a mapping of button presses to actions + } hunk ./XMonad.hs 69 - , numlockMask :: KeyMask - , keys :: !(M.Map (ButtonMask,KeySym) (X ())) - , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) + , numlockMask :: !KeyMask + , modMask :: !KeyMask + , keys :: !(XConfig -> M.Map (ButtonMask,KeySym) (X ())) + , mouseBindings :: !(XConfig -> M.Map (ButtonMask, Button) (Window -> X ())) hunk ./XMonad/DefaultConfig.hs 165 - , ((modMask .|. shiftMask, xK_space ), setLayout $ Layout layout) -- %! Reset the layouts on the current workspace to default + , ((modMask .|. shiftMask, xK_space ), setLayout $ layoutHook conf) -- %! Reset the layouts on the current workspace to default hunk ./XMonad/DefaultConfig.hs 204 - | (i, k) <- zip workspaces [xK_1 .. xK_9] + | (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9] hunk ./XMonad.hs 1 -{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, TypeSynonymInstances #-} +-- required for deriving Typeable +{-# OPTIONS_GHC -fglasgow-exts #-} hunk ./XMonad.hs 65 -data XConfig = XConfig { normalBorderColor :: !String - , focusedBorderColor :: !String - , terminal :: !String - , layoutHook :: !(Layout Window) - , manageHook :: !(Window -> String -> String -> String -> X (WindowSet -> WindowSet)) - , workspaces :: ![String] - , defaultGaps :: ![(Int,Int,Int,Int)] - , numlockMask :: !KeyMask - , modMask :: !KeyMask - , keys :: !(XConfig -> M.Map (ButtonMask,KeySym) (X ())) - , mouseBindings :: !(XConfig -> M.Map (ButtonMask, Button) (Window -> X ())) - , borderWidth :: !Dimension - , logHook :: !(X ()) } +data XConfig = XConfig + { normalBorderColor :: !String + , focusedBorderColor :: !String + , terminal :: !String + , layoutHook :: !(Layout Window) + , manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) + , workspaces :: [String] + , defaultGaps :: [(Int,Int,Int,Int)] + , numlockMask :: !KeyMask + , modMask :: !KeyMask + , keys :: XConfig -> M.Map (ButtonMask,KeySym) (X ()) + , mouseBindings :: XConfig -> M.Map (ButtonMask, Button) (Window -> X ()) + , borderWidth :: !Dimension + , logHook :: X () + } hunk ./XMonad.hs 118 - (a, s') <- io $ runX c st job `catch` - \e -> case e of + (a, s') <- io $ runX c st job `catch` \e -> case e of hunk ./XMonad/DefaultConfig.hs 1 +{-# OPTIONS -fno-warn-missing-signatures #-} hunk ./XMonad/DefaultConfig.hs 12 --- This module specifies configurable defaults for xmonad. If you change --- values here, be sure to recompile and restart (mod-q) xmonad, --- for the changes to take effect. +-- This module specifies the default configuration values for xmonad. +-- Users will typically use record syntax to override particular fields +-- they disagree with, in the defaultConfig structure. hunk ./XMonad/DefaultConfig.hs 23 -import Control.Monad.Reader ( asks ) -import XMonad hiding (workspaces, manageHook, numlockMask) -import qualified XMonad (workspaces, manageHook, numlockMask) +import XMonad hiding + (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings + ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) +import qualified XMonad + (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings + ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) + hunk ./XMonad/DefaultConfig.hs 77 +-- | Width of the window border in pixels. +-- +borderWidth :: Dimension +borderWidth = 1 + +-- | Border colors for unfocused and focused windows, respectively. +-- +normalBorderColor, focusedBorderColor :: String +normalBorderColor = "#dddddd" +focusedBorderColor = "#ff0000" + hunk ./XMonad/DefaultConfig.hs 100 ---defaultGaps :: [(Int,Int,Int,Int)] - +defaultGaps :: [(Int,Int,Int,Int)] +defaultGaps = [(0,0,0,0)] -- 15 for default dzen font hunk ./XMonad/DefaultConfig.hs 138 +------------------------------------------------------------------------ +-- Logging + +-- | Perform an arbitrary action on each internal state change or X event. +-- Examples include: +-- * do nothing +-- * log the state to stdout +-- +-- See the 'DynamicLog' extension for examples. +-- +logHook :: X () +logHook = return () + hunk ./XMonad/DefaultConfig.hs 181 +-- | The preferred terminal program, which is used in a binding below and by +-- certain contrib modules. +terminal :: String +terminal = "xterm" + hunk ./XMonad/DefaultConfig.hs 191 -keys conf@(XConfig {modMask = modMask}) = M.fromList $ +keys conf@(XConfig {XMonad.modMask = modMask}) = M.fromList $ hunk ./XMonad/DefaultConfig.hs 193 - [ ((modMask .|. shiftMask, xK_Return), spawn $ terminal conf) -- %! Launch terminal + [ ((modMask .|. shiftMask, xK_Return), spawn $ XMonad.terminal conf) -- %! Launch terminal hunk ./XMonad/DefaultConfig.hs 199 - , ((modMask .|. shiftMask, xK_space ), setLayout $ layoutHook conf) -- %! Reset the layouts on the current workspace to default + , ((modMask .|. shiftMask, xK_space ), setLayout $ XMonad.layoutHook conf) -- %! Reset the layouts on the current workspace to default hunk ./XMonad/DefaultConfig.hs 226 - , ((modMask , xK_b ), modifyGap (\i n -> let x = (defaultGaps conf ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap + , ((modMask , xK_b ), modifyGap (\i n -> let x = (XMonad.defaultGaps conf ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap hunk ./XMonad/DefaultConfig.hs 252 -mouseBindings (XConfig {modMask = modMask}) = M.fromList $ +mouseBindings (XConfig {XMonad.modMask = modMask}) = M.fromList $ hunk ./XMonad/DefaultConfig.hs 266 +-- | And, finally, the default set of configuration values itself hunk ./XMonad/DefaultConfig.hs 268 -defaultConfig = XConfig { borderWidth = 1 -- Width of the window border in pixels. - , XMonad.workspaces = workspaces - , defaultGaps = [(0,0,0,0)] -- 15 for default dzen font - -- | The top level layout switcher. Most users will not need to modify this binding. - -- - -- By default, we simply switch between the layouts listed in `layouts' - -- above, but you may program your own selection behaviour here. Layout - -- transformers, for example, would be hooked in here. - -- - , layoutHook = Layout layout - , terminal = "xterm" -- The preferred terminal program. - , normalBorderColor = "#dddddd" -- Border color for unfocused windows. - , focusedBorderColor = "#ff0000" -- Border color for focused windows. - , XMonad.numlockMask = numlockMask - , modMask = defaultModMask - , XMonad.keys = XMonad.DefaultConfig.keys - , XMonad.mouseBindings = XMonad.DefaultConfig.mouseBindings - -- | Perform an arbitrary action on each internal state change or X event. - -- Examples include: - -- * do nothing - -- * log the state to stdout - -- - -- See the 'DynamicLog' extension for examples. - , logHook = return () - , XMonad.manageHook = manageHook - } +defaultConfig = XConfig + { XMonad.borderWidth = borderWidth + , XMonad.workspaces = workspaces + , XMonad.defaultGaps = defaultGaps + , XMonad.layoutHook = Layout layout + , XMonad.terminal = terminal + , XMonad.normalBorderColor = normalBorderColor + , XMonad.focusedBorderColor = focusedBorderColor + , XMonad.numlockMask = numlockMask + , XMonad.modMask = defaultModMask + , XMonad.keys = keys + , XMonad.logHook = logHook + , XMonad.mouseBindings = mouseBindings + , XMonad.manageHook = manageHook } move ./XMonad/DefaultConfig.hs ./XMonad/Config.hs move ./XMonad/EventLoop.hs ./XMonad/Core.hs hunk ./Main.hs 17 -import XMonad.EventLoop (makeMain) -import XMonad.DefaultConfig (defaultConfig) +import XMonad.Core +import XMonad.Config hunk ./Main.hs 28 +-- | The entry point into xmonad. Attempts to compile any custom main +-- for xmonad, and if it doesn't find one, just launches the default. +main :: IO () +main = do + handle (hPrint stderr) buildLaunch + -- if buildLaunch returns, execute the trusted core + makeMain defaultConfig + hunk ./Main.hs 55 -main :: IO () -main = do - handle (hPrint stderr) buildLaunch - -- if buildLaunch returns, execute the trusted core - makeMain defaultConfig - hunk ./XMonad/Config.hs 4 --- Module : DefaultConfig.hs +-- Module : XMonad.Config hunk ./XMonad/Config.hs 18 -module XMonad.DefaultConfig (defaultConfig) where +module XMonad.Config (defaultConfig) where hunk ./XMonad/Core.hs 4 --- Module : EventLoop.hs +-- Module : Core.hs hunk ./XMonad/Core.hs 16 -module XMonad.EventLoop (makeMain) where +module XMonad.Core (makeMain) where hunk ./xmonad.cabal 24 - XMonad.DefaultConfig - XMonad.EventLoop + XMonad.Config + XMonad.Core hunk ./xmonad.cabal 32 -other-modules: XMonad.EventLoop XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad +other-modules: XMonad.Core XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad hunk ./xmonad.cabal 29 +ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s +ghc-prof-options: -prof -auto-all hunk ./XMonad/Layouts.hs 79 - (SLeft r l) -> (flip SLeft, l, r) - (SRight l r) -> (SRight, l, r) + (SLeft r' l') -> (flip SLeft, l', r') + (SRight l' r') -> (SRight, l', r') hunk ./Main.hs 34 - makeMain defaultConfig + xmonad defaultConfig hunk ./Main.hs 55 + hunk ./XMonad/Core.hs 16 -module XMonad.Core (makeMain) where +module XMonad.Core (xmonad) where hunk ./XMonad/Core.hs 41 -makeMain :: XConfig -> IO () -makeMain xmc = do +xmonad :: XConfig -> IO () +xmonad xmc = do hunk ./Main.hs 33 - -- if buildLaunch returns, execute the trusted core - xmonad defaultConfig + xmonad defaultConfig -- if buildLaunch returns, execute the trusted core hunk ./Main.hs 35 --- | Build "~/.xmonad/Main.hs" with ghc, then execute it. If there are no +-- | Build "~/.xmonad/xmonad.hs" with ghc, then execute it. If there are no hunk ./Main.hs 38 --- * ghc missing --- * ~/.xmonad/Main.hs missing --- * Main.hs fails to compile --- * Missing xmonad/XMonadContrib modules due to ghc upgrade +-- * ghc missing +-- * ~/.xmonad/xmonad.hs missing +-- * xmonad.hs fails to compile +-- ** wrong ghc in path (fails to compile) +-- ** type error, syntax error, .. +-- * Missing xmonad/XMonadContrib modules due to ghc upgrade hunk ./Main.hs 48 - pid <- runProcess "ghc" ["--make", "Main.hs"] (Just dir) + pid <- runProcess "ghc" ["--make", "xmonad.hs"] (Just dir) hunk ./Main.hs 51 - hunk ./Main.hs 52 - executeFile (dir ++ "/Main") False args Nothing + executeFile (dir ++ "/xmonad") False args Nothing hunk ./Main.hs 55 - hunk ./xmonad.cabal 20 -build-depends: base>=2.0, mtl, unix, X11==1.3.0 hunk ./xmonad.cabal 22 -exposed-modules: XMonad - XMonad.Config - XMonad.Core - XMonad.Layouts - XMonad.Operations - XMonad.StackSet -ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s -ghc-prof-options: -prof -auto-all +cabal-version: >= 1.2 hunk ./xmonad.cabal 24 -executable: xmonad -main-is: Main.hs -other-modules: XMonad.Core XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad -ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s -ghc-prof-options: -prof -auto-all -extensions: GeneralizedNewtypeDeriving +flag small_base + description: Choose the new smaller, split-up base package. + +library + exposed-modules: XMonad + XMonad.Config + XMonad.Core + XMonad.Layouts + XMonad.Operations + XMonad.StackSet + ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s + ghc-prof-options: -prof -auto-all + + if flag(small_base) + build-depends: base >= 3, containers, directory, process + else + build-depends: base < 3 + + build-depends: X11==1.3.0, mtl, unix + + + +executable xmonad + main-is: Main.hs + other-modules: XMonad.Core XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad + ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s + ghc-prof-options: -prof -auto-all + extensions: GeneralizedNewtypeDeriving hunk ./xmonad.cabal 51 - extensions: GeneralizedNewtypeDeriving hunk ./xmonad.cabal 34 - ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s + ghc-options: -funbox-strict-fields -O2 -fasm -Wall -Werror -optl-Wl,-s hunk ./xmonad.cabal 49 - ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s + ghc-options: -funbox-strict-fields -O2 -fasm -Wall -Werror -optl-Wl,-s changepref test echo main | ghci -v0 -fglasgow-exts -itests tests/Main.hs && cat *.hs | runhaskell tests/loc.hs runghc Setup.lhs configure --disable-optimization --user && runghc Setup.lhs build && runghc -itests tests/Main.hs && cat *.hs XMonad/*.hs | runghc tests/loc.hs hunk ./xmonad.cabal 34 - ghc-options: -funbox-strict-fields -O2 -fasm -Wall -Werror -optl-Wl,-s + ghc-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s hunk ./xmonad.cabal 49 - ghc-options: -funbox-strict-fields -O2 -fasm -Wall -Werror -optl-Wl,-s + ghc-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s hunk ./xmonad.cabal 51 --- Also requires deriving Typeable, PatternGuards changepref test runghc Setup.lhs configure --disable-optimization --user && runghc Setup.lhs build && runghc -itests tests/Main.hs && cat *.hs XMonad/*.hs | runghc tests/loc.hs runghc Setup.lhs configure --disable-optimization --user && runghc Setup.lhs build && runghc -itests tests/Main.hs 50 && cat *.hs XMonad/*.hs | runghc tests/loc.hs addfile ./CONFIG hunk ./CONFIG 1 +xmonad is configure by creating and editing the file: + + ~/.xmonad/xmonad.hs + +which is a Haskell source file. Here is an example, + + -- + -- An example, simple ~/.xmonad/xmonad.hs file. + -- It overrides a few basic settings, reusing all the other defaults, + -- and also uses the DynamicLog extension. + -- + + import XMonad + import XMonad.Core + import XMonad.Config + + main = xmonad $ defaultConfig + { borderWidth = 2 + , normalBorderColor = "#cccccc" + , focusedBorderColor = "#cd8b00" } + + +You may typecheck this file, or develop it in ghci, as you see fit. + +To have xmonad pick up your defaults, try mod-q. xmonad will attempt to +compile this file, and run it. If it is unable to, the defaults are +used. hunk ./README 5 ------------------------------------------------------------------------- - -About: - - Xmonad is a tiling window manager for X. Windows are managed using - automatic tiling algorithms, which can be dynamically configured. - Windows are arranged so as to tile the screen without gaps, maximising - screen use. All features of the window manager are accessible - from the keyboard: a mouse is strictly optional. Xmonad is written - and extensible in Haskell, and custom layout algorithms may be - implemented by the user in config files. A guiding principle of the - user interface is predictability: users should know in - advance precisely the window arrangement that will result from any - action, leading to an intuitive user interface. - - Xmonad provides three tiling algorithms by default: tall, wide and - fullscreen. In tall or wide mode, all windows are visible and tiled - to fill the plane without gaps. In fullscreen mode only the focused - window is visible, filling the screen. Alternative tiling - algorithms are provided as extensions. Sets of windows are grouped - together on virtual workspaces and each workspace retains its own - layout. Multiple physical monitors are supported via Xinerama, - allowing simultaneous display of several workspaces. - - Adhering to a minimalist philosophy of doing one job, and doing it - well, the entire code base remains tiny, and is written to be simple - to understand and modify. By using Haskell as a configuration - language arbitrarily complex extensions may be implemented by the - user using a powerful `scripting' language, without needing to - modify the window manager directly. For example, users may write - their own tiling algorithms. - ------------------------------------------------------------------------- + xmonad is a tiling window manager for X. Windows are arranged + automatically to tile the screen without gaps or overlap, maximising + screen use. Window manager features are accessible from + the keyboard: a mouse is optional. xmonad is written, configured and + extensible in Haskell. Custom layout algorithms, key bindings and + other extensions may be written by the user in config files. Layouts + are applied dynamically, and different layouts may be used on each + workspace. Xinerama is fully supported, allowing windows to be tiled + on several physical screens. hunk ./README 17 -Get the dependencies + Get the dependencies hunk ./README 48 - runhaskell Setup.lhs configure --prefix=$HOME + runhaskell Setup.lhs configure --user --prefix=$HOME hunk ./README 52 +And you're done. + hunk ./Main.hs 25 -import System.Exit hunk ./Main.hs 49 - ExitSuccess <- waitForProcess pid + waitForProcess pid hunk ./XMonad/StackSet.hs 417 --- existing workspaces and/or creating new hidden workspaces as +-- existing workspaces and\/or creating new hidden workspaces as hunk ./CONFIG 29 +The default configuration values are defined in the source file: + + XMonad/Config.hs + +the XConfig data structure itself is defined in: + + XMonad.hs + move ./XMonad.hs ./XMonad/Types.hs move ./XMonad/Core.hs ./XMonad/Main.hs move ./XMonad/Types.hs ./XMonad/Core.hs hunk ./Main.hs 17 -import XMonad.Core +import XMonad.Main addfile ./XMonad.hs hunk ./XMonad.hs 1 +module XMonad ( + + module XMonad.Main, + module XMonad.Core, + module XMonad.Config + + ) where + +import XMonad.Main +import XMonad.Core +import XMonad.Config +-- import XMonad.StackSet -- conflicts with 'workspaces' defined in XMonad.hs hunk ./XMonad/Config.hs 23 -import XMonad hiding +import XMonad.Core as XMonad hiding hunk ./XMonad/Config.hs 26 -import qualified XMonad +import qualified XMonad.Core as XMonad hunk ./XMonad/Core.hs 8 --- Module : XMonad.hs +-- Module : XMonad/Core.hs hunk ./XMonad/Core.hs 21 -module XMonad ( +module XMonad.Core ( hunk ./XMonad/Layouts.hs 22 -import XMonad +import XMonad.Core hunk ./XMonad/Main.hs 16 -module XMonad.Core (xmonad) where +module XMonad.Main (xmonad) where hunk ./XMonad/Main.hs 31 -import XMonad +import XMonad.Core hunk ./XMonad/Operations.hs 21 -import XMonad +import XMonad.Core hunk ./xmonad.cabal 29 - XMonad.Config + XMonad.Main hunk ./xmonad.cabal 31 + XMonad.Config hunk ./xmonad.cabal 49 - other-modules: XMonad.Core XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad + other-modules: XMonad.Core XMonad.Main XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad hunk ./CONFIG 14 - import XMonad.Core - import XMonad.Config hunk ./CONFIG 10 - -- and also uses the DynamicLog extension. hunk ./XMonad/StackSet.hs 45 -import Data.Maybe (listToMaybe,fromJust) +import Data.Maybe (listToMaybe,fromJust,isJust) hunk ./XMonad/StackSet.hs 442 -member a s = maybe False (const True) (findTag a s) +member a s = isJust (findTag a s) hunk ./XMonad/Core.hs 284 -whenJust :: Maybe a -> (a -> X ()) -> X () +whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () hunk ./XMonad/Config.hs 32 +import XMonad.ManageHook hunk ./XMonad/Config.hs 116 -manageHook :: Window -- ^ the new window to manage - -> String -- ^ window title - -> String -- ^ window resource name - -> String -- ^ window resource class - -> X (WindowSet -> WindowSet) - --- Always float various programs: -manageHook w _ _ c | c `elem` floats = fmap (W.float w . snd) (floatLocation w) +manageHook :: ManageHook +manageHook = composeAll . concat $ + [ [ className =? c --> doFloat | c <- floats] + , [ resource =? r --> doIgnore | r <- ignore] + , [ resource =? "Gecko" --> doF (W.shift "web") ]] hunk ./XMonad/Config.hs 122 - --- Desktop panels and dock apps should be ignored by xmonad: -manageHook w _ n _ | n `elem` ignore = reveal w >> return (W.delete w) - where ignore = ["gnome-panel", "desktop_window", "kicker", "kdesktop"] - --- Automatically send Firefox windows to the "web" workspace: --- If a workspace named "web" doesn't exist, the window will appear on the --- current workspace. -manageHook _ _ "Gecko" _ = return $ W.shift "web" - --- The default rule: return the WindowSet unmodified. You typically do not --- want to modify this line. -manageHook _ _ _ _ = return id + ignore = ["gnome-panel", "desktop_window", "kicker", "kdesktop"] hunk ./XMonad/Core.hs 70 - , manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) + , manageHook :: Window -> X (WindowSet -> WindowSet) hunk ./XMonad/Core.hs 81 + addfile ./XMonad/ManageHook.hs hunk ./XMonad/ManageHook.hs 1 +----------------------------------------------------------------------------- +-- | +-- Module : XMonad/ManageHook.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : sjanssen@cse.unl.edu +-- Stability : unstable +-- Portability : not portable, uses cunning newtype deriving +-- +-- An EDSL for ManageHooks +-- +----------------------------------------------------------------------------- + +module XMonad.ManageHook where + +import XMonad.Core +import Graphics.X11 +import Graphics.X11.Xlib.Extras +import Control.Monad +import Data.Maybe +import qualified XMonad.StackSet as W +import XMonad.Operations (floatLocation, reveal) + +type ManageHook = Query (WindowSet -> WindowSet) +type Query a = Window -> X a + +idHook :: ManageHook +idHook = doF id + +(<+>) :: ManageHook -> ManageHook -> ManageHook +f <+> g = \w -> liftM2 (.) (f w) (g w) + +composeAll :: [ManageHook] -> ManageHook +composeAll = foldr (<+>) idHook + +(-->) :: Query Bool -> ManageHook -> ManageHook +p --> f = \w -> p w >>= \b -> if b then f w else idHook w + +(=?) :: Eq a => Query a -> a -> Query Bool +q =? x = \w -> fmap (== x) (q w) + +title, resource, className :: Query String +title = \w -> withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w +resource = \w -> withDisplay $ \d -> fmap resName $ io $ getClassHint d w +className = \w -> withDisplay $ \d -> fmap resClass $ io $ getClassHint d w + +doFloat :: ManageHook +doFloat = \w -> fmap (W.float w . snd) (floatLocation w) + +doIgnore :: ManageHook +doIgnore = \w -> reveal w >> return (W.delete w) + +doF :: (WindowSet -> WindowSet) -> ManageHook +doF f = const (return f) hunk ./XMonad/Operations.hs 66 - n <- fmap (fromMaybe "") $ io $ fetchName d w - (ClassHint rn rc) <- io $ getClassHint d w hunk ./XMonad/Operations.hs 67 - g <- mh w n rn rc `catchX` return id + g <- mh w `catchX` return id hunk ./xmonad.cabal 33 + XMonad.ManageHook hunk ./XMonad/ManageHook.hs 28 +-- | The identity hook that returns the WindowSet unchanged. hunk ./XMonad/ManageHook.hs 32 +-- | Compose two 'ManageHook's hunk ./XMonad/ManageHook.hs 36 +-- | Compose the list of 'ManageHook's hunk ./XMonad/ManageHook.hs 40 +-- | 'p --> x'. If 'p' returns 'True', execute the 'ManageHook'. hunk ./XMonad/ManageHook.hs 44 +-- | 'q =? x'. if the result of 'q' equals 'x', return 'True'. hunk ./XMonad/ManageHook.hs 48 +-- | Queries that return the window title, resource, or class. hunk ./XMonad/ManageHook.hs 54 +-- | Modify the 'WindowSet' with a pure function. +doF :: (WindowSet -> WindowSet) -> ManageHook +doF f = const (return f) + +-- | Move the window to the floating layer. hunk ./XMonad/ManageHook.hs 62 +-- | Map the window and remove it from the 'WindowSet'. hunk ./XMonad/ManageHook.hs 66 -doF :: (WindowSet -> WindowSet) -> ManageHook -doF f = const (return f) - hunk ./XMonad/Core.hs 261 -spawn :: String -> X () -spawn x = io $ do +spawn :: MonadIO m => String -> m () +spawn x = liftIO $ do hunk ./XMonad/Core.hs 294 -trace :: String -> X () -trace msg = io $! do hPutStrLn stderr msg; hFlush stderr +trace :: MonadIO m => String -> m () +trace msg = liftIO $ do hPutStrLn stderr msg; hFlush stderr hunk ./README 35 + + xmonad requires a recent version of Cabal, >= 1.2.0. If you're using + GHC 6.8, then it comes bundled with the right version. If you're + using GHC 6.6.x, you'll need to build and install Cabal from hackage + first: + + http://hackage.haskell.org/cgi-bin/hackage-scripts/package/Cabal + + You can check which version you have with the command: + + $ ghc-pkg list Cabal + Cabal-1.2.2.0 hunk ./README 1 - xmonad : a lightweight X11 window manager. + xmonad : a tiling window manager hunk ./README 7 - screen use. Window manager features are accessible from - the keyboard: a mouse is optional. xmonad is written, configured and + screen use. Window manager features are accessible from the + keyboard: a mouse is optional. xmonad is written, configured and hunk ./README 17 - Get the dependencies + Building is quite straightforward, and requries a basic Haskell toolchain. + We'll walk through the complete list of toolchain dependencies. hunk ./README 20 + * GHC: the Glasgow Haskell Compiler + hunk ./README 23 - system will have binaries of GHC (the Glasgow Haskell Compiler), the - system we use, so install that. If your distro doesn't provide a - binary, you can find them here: + system will have binaries of GHC (the Glasgow Haskell Compiler), the + compiler we use, so install that first. If your operating system's + package system doesn't provide a binary version of GHC, you can find + them here: hunk ./README 34 + It shouldn't be necessary to compile GHC from source -- every common + system has a pre-build binary version. + + * X11 libraries: + hunk ./README 45 + Typically you need: libXinerama libXext libX11 + + * Cabal + hunk ./README 61 + * Haskell libraries: mtl, unix, X11 + hunk ./README 72 -And then build xmonad with Cabal as follows (the same goes for the other -Haskell libraries): + * Build xmonad: + + Once you've got all the dependencies in place (which should be + straightforward), build xmonad: hunk ./README 77 - runhaskell Setup.lhs configure --user --prefix=$HOME - runhaskell Setup.lhs build - runhaskell Setup.lhs install --user + runhaskell Setup.lhs configure --user --prefix=$HOME + runhaskell Setup.lhs build + runhaskell Setup.lhs install --user hunk ./README 81 -And you're done. + And you're done! hunk ./README 110 - There are various contributed modules that can be used with xmonad. - Examples include an ion3-like tabbed layout, a prompt/program launcher, - and various other useful modules. XMonadContrib is available at: + There are many extensions to xmonad available in the XMonadContrib + (xmc) library. Examples include an ion3-like tabbed layout, a + prompt/program launcher, and various other useful modules. + XMonadContrib is available at: hunk ./README 115 - 0.4 release: http://www.xmonad.org/XMonadContrib-0.4.tar.gz + 0.4 release: http://www.xmonad.org/XMonadContrib-0.4.tar.gz hunk ./README 117 - darcs version: darcs get http://code.haskell.org/XMonadContrib + darcs version: darcs get http://code.haskell.org/XMonadContrib hunk ./xmonad.cabal 44 - build-depends: X11==1.3.0, mtl, unix + build-depends: X11==1.3.0.20071111, mtl, unix hunk ./XMonad/Config.hs 176 -keys :: XConfig -> M.Map (KeyMask, KeySym) (X ()) +keys :: XConfig Layout -> M.Map (KeyMask, KeySym) (X ()) hunk ./XMonad/Config.hs 237 -mouseBindings :: XConfig -> M.Map (KeyMask, Button) (Window -> X ()) +mouseBindings :: XConfig Layout -> M.Map (KeyMask, Button) (Window -> X ()) hunk ./XMonad/Config.hs 253 -defaultConfig :: XConfig hunk ./XMonad/Config.hs 257 - , XMonad.layoutHook = Layout layout + , XMonad.layoutHook = layout hunk ./XMonad/Core.hs 54 - , config :: !XConfig -- ^ initial user configuration + , config :: !(XConfig Layout) -- ^ initial user configuration hunk ./XMonad/Core.hs 65 -data XConfig = XConfig +data XConfig l = XConfig hunk ./XMonad/Core.hs 69 - , layoutHook :: !(Layout Window) + , layoutHook :: !(l Window) hunk ./XMonad/Core.hs 75 - , keys :: XConfig -> M.Map (ButtonMask,KeySym) (X ()) - , mouseBindings :: XConfig -> M.Map (ButtonMask, Button) (Window -> X ()) + , keys :: XConfig Layout -> M.Map (ButtonMask,KeySym) (X ()) + , mouseBindings :: XConfig Layout -> M.Map (ButtonMask, Button) (Window -> X ()) hunk ./XMonad/Main.hs 41 -xmonad :: XConfig -> IO () -xmonad xmc = do +xmonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO () +xmonad initxmc = do + -- First, wrap the layout in an existential, to keep things pretty: + let xmc = initxmc { layoutHook = Layout $ layoutHook initxmc } hunk ./XMonad/Main.hs 1 -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} hunk ./XMonad/Config.hs 40 --- % Extension-provided imports - hunk ./XMonad/Config.hs 147 - -- Add extra layouts you want to use here: - -- % Extension-provided layouts hunk ./XMonad/Config.hs 213 - - -- % Extension-provided key bindings hunk ./XMonad/Config.hs 227 - -- % Extension-provided key bindings lists - hunk ./XMonad/Config.hs 238 - - -- % Extension-provided mouse bindings hunk ./XMonad/Config.hs 240 --- % Extension-provided definitions - hunk ./XMonad/Config.hs 34 -import Data.Ratio hunk ./XMonad/Config.hs 154 - ratio = 1%2 + ratio = 0.5 hunk ./XMonad/Config.hs 157 - delta = 3%100 + delta = 0.03 hunk ./XMonad/Config.hs 13 --- Users will typically use record syntax to override particular fields --- they disagree with, in the defaultConfig structure. +-- Users should not modify this file. Rather, they should provide their +-- own ~/.xmonad/xmonad.hs that overrides specific fields in defaultConfig. hunk ./XMonad/Core.hs 295 -trace msg = liftIO $ do hPutStrLn stderr msg; hFlush stderr +trace = liftIO . hPutStrLn stderr hunk ./CONFIG 1 -xmonad is configure by creating and editing the file: +== Configuring xmonad == + +xmonad is configure by creating and editing the Haskell file: hunk ./CONFIG 7 -which is a Haskell source file. Here is an example, +xmonad then uses default settings from this file as arguments to the +window manager. + +== A simple example == + +Here is a basic example, which takes defaults from xmonad, and overrides +the border width, default terminal, and some colours: hunk ./CONFIG 24 + , terminal = "urxvt" hunk ./CONFIG 28 +This will run 'xmonad', the window manager, with your settings passed as +arguments. + +Overriding default settings like this (using "record update syntax"), +will yield the shortest config file, as you only have to describe values +that differ from the defaults. + +An alternative is to inline the entire default config file from xmonad, +and edit values you wish to change. This is requires more work, but some +users may find this easier. You can find the defaults in the file: + + XMonad/Config.hs + +== Checking your xmonad.hs is correct == + +Place this text in ~/.xmonad/xmonad.hs, and then check that it is +syntactically and type correct, by loading it in the Haskell +interpreter: hunk ./CONFIG 47 -You may typecheck this file, or develop it in ghci, as you see fit. + $ ghci ~/.xmonad/xmonad.hs + GHCi, version 6.8.1: http://www.haskell.org/ghc/ :? for help + Loading package base ... linking ... done. + Ok, modules loaded: Main. hunk ./CONFIG 52 -To have xmonad pick up your defaults, try mod-q. xmonad will attempt to -compile this file, and run it. If it is unable to, the defaults are -used. + Prelude Main> :t main + main :: IO () + +Ok, looks good. + +== Loading your configuration == + +To have xmonad start using your settings, try mod-q. xmonad will attempt +to compile this file, and run it. If it is unable to, the defaults are +used. This requires GHC and xmonad are in your $PATH settings. If +GHC isn't in your path, you can still compile the xmonad.hs file yourself: + + $ cd ~/.xmonad + $ ghc --make xmonad.hs + $ ls + xmonad xmonad.hi xmonad.hs xmonad.o + +When you hit mod-q, this newly compiled xmonad will be used. + +== Where are the defaults? == hunk ./CONFIG 81 +== Extensions == + +Since the xmonad.hs file is just another Haskell module, you may import +and use any Haskell code or libraries you wish. For example, you can use +things from the xmonad-contrib library, or other code you write +yourself. + hunk ./xmonad.cabal 19 -maintainer: sjanssen@cse.unl.edu +maintainer: xmonad@haskell.org hunk ./xmonad.cabal 36 - ghc-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s - ghc-prof-options: -prof -auto-all hunk ./xmonad.cabal 41 - hunk ./xmonad.cabal 43 - + ghc-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s + ghc-prof-options: -prof -auto-all hunk ./xmonad.cabal 48 - other-modules: XMonad.Core XMonad.Main XMonad.Layouts XMonad.Operations XMonad.StackSet XMonad + other-modules: XMonad.Core XMonad.Main XMonad.Layouts + XMonad.Operations XMonad.StackSet XMonad + hunk ./XMonad.hs 1 +-------------------------------------------------------------------- +-- | +-- Module : XMonad +-- Copyright : (c) Don Stewart +-- License : BSD3 +-- +-- Maintainer: Don Stewart +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- +-- +-- Useful exports for configuration files. + hunk ./XMonad.hs 19 - module XMonad.Config + module XMonad.Config, + -- module Graphics.X11.Xlib, -- conflicts with lots of extensions + (.|.) hunk ./XMonad.hs 25 +-- core modules hunk ./XMonad.hs 31 +-- modules needed to get basic configuration working +import Data.Bits +-- import Graphics.X11.Xlib + hunk ./Main.hs 19 +import XMonad.Core (recompile) hunk ./Main.hs 23 -import System.Process hunk ./Main.hs 46 + recompile hunk ./Main.hs 48 - pid <- runProcess "ghc" ["--make", "xmonad.hs"] (Just dir) - Nothing Nothing Nothing Nothing - waitForProcess pid hunk ./XMonad/Core.hs 23 - runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX, + runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, recompile, trace, whenJust, whenX, hunk ./XMonad/Core.hs 35 +import System.Process +import System.Directory hunk ./XMonad/Core.hs 286 +-- | Recompile ~\/xmonad\/xmonad.hs. +-- +-- Raises an exception if ghc can't be found. +recompile :: IO () +recompile = do + dir <- fmap (++ "/.xmonad") getHomeDirectory + pid <- runProcess "ghc" ["--make", "xmonad.hs"] (Just dir) + Nothing Nothing Nothing Nothing + waitForProcess pid + return () + hunk ./XMonad/Config.hs 154 - ratio = 0.5 + ratio = 1/2 hunk ./XMonad/Config.hs 157 - delta = 0.03 + delta = 3/100 hunk ./CONFIG 3 -xmonad is configure by creating and editing the Haskell file: +xmonad is configured by creating and editing the Haskell file: hunk ./CONFIG 12 -Here is a basic example, which takes defaults from xmonad, and overrides +Here is a basic example, which takes defaults from xmonad, and overrides hunk ./CONFIG 18 - -- + -- hunk ./CONFIG 47 - $ ghci ~/.xmonad/xmonad.hs + $ ghci ~/.xmonad/xmonad.hs hunk ./CONFIG 55 -Ok, looks good. +Ok, looks good. hunk ./CONFIG 71 -== Where are the defaults? == +== Where are the defaults? == hunk ./CONFIG 75 - XMonad/Config.hs + XMonad/Config.hs hunk ./CONFIG 79 - XMonad.hs + XMonad/Core.hs hunk ./TODO 17 -* upload X11/xmonad to hacakge +* upload X11/xmonad to hackage hunk ./XMonad/Core.hs 68 - { normalBorderColor :: !String - , focusedBorderColor :: !String - , terminal :: !String - , layoutHook :: !(l Window) - , manageHook :: Window -> X (WindowSet -> WindowSet) - , workspaces :: [String] - , defaultGaps :: [(Int,Int,Int,Int)] - , numlockMask :: !KeyMask - , modMask :: !KeyMask + { normalBorderColor :: !String -- ^ Non focused windows border color. Default: \"#dddddd\" + , focusedBorderColor :: !String -- ^ Focused windows border color. Default: \"#ff0000\" + , terminal :: !String -- ^ The preferred terminal application. Default: \"xterm\" + , layoutHook :: !(l Window) -- ^ The avaiable layouts + , manageHook :: Window -> X (WindowSet -> WindowSet) + -- ^ The action to run when a new window is opened + , workspaces :: [String] -- ^ The list of workspaces' names + , defaultGaps :: [(Int,Int,Int,Int)] -- ^ The list of gaps, per screen + , numlockMask :: !KeyMask -- ^ The numlock modifier + , modMask :: !KeyMask -- ^ the mod modifier hunk ./XMonad/Core.hs 79 + -- ^ The key binding: a map from key presses and actions hunk ./XMonad/Core.hs 81 - , borderWidth :: !Dimension - , logHook :: X () + -- ^ The mouse bindings + , borderWidth :: !Dimension -- ^ The border width + , logHook :: X () -- ^ The action to perform when the windows set is changed hunk ./XMonad/Core.hs 96 --- | TODO Comment me +-- | The 'Rectangle' with screen dimensions and the list of gaps hunk ./XMonad/Config.hs 14 --- own ~/.xmonad/xmonad.hs that overrides specific fields in defaultConfig. +-- own @~\/.xmonad\/xmonad.hs@ that overrides specific fields in defaultConfig. hunk ./xmonad.cabal 4 -synopsis: A lightweight X11 window manager. +synopsis: A tiling window manager hunk ./CONFIG 7 -xmonad then uses default settings from this file as arguments to the -window manager. +xmonad then uses settings from this file as arguments to the window manager, +on startup. hunk ./CONFIG 12 -Here is a basic example, which takes defaults from xmonad, and overrides +Here is a basic example, which takes defaults from xmonad, and overrides hunk ./CONFIG 18 - -- + -- hunk ./CONFIG 28 -This will run 'xmonad', the window manager, with your settings passed as -arguments. - -Overriding default settings like this (using "record update syntax"), -will yield the shortest config file, as you only have to describe values -that differ from the defaults. - -An alternative is to inline the entire default config file from xmonad, -and edit values you wish to change. This is requires more work, but some -users may find this easier. You can find the defaults in the file: +You can find the defaults in the file: hunk ./CONFIG 35 -syntactically and type correct, by loading it in the Haskell +syntactically and type correct by loading it in the Haskell hunk ./CONFIG 50 -To have xmonad start using your settings, try mod-q. xmonad will attempt -to compile this file, and run it. If it is unable to, the defaults are -used. This requires GHC and xmonad are in your $PATH settings. If -GHC isn't in your path, you can still compile the xmonad.hs file yourself: +To have xmonad start using your settings, type 'mod-q'. xmonad will +then load this new file, and run it. If it is unable to, the defaults +are used. + +To load succesfully, both 'xmonad' and 'ghc' must be in your $PATH +environment variable. If GHC isn't in your path, for some reason, you +can compile the xmonad.hs file yourself: hunk ./README 18 - We'll walk through the complete list of toolchain dependencies. + On many systems xmonad is available as a binary package in your + package system (e.g. on debian or gentoo). If at all possible, use this + in preference to a source build, as the dependency resolution will be + simpler. + + We'll now walk through the complete list of toolchain dependencies. hunk ./README 128 - For a program dispatch menu: + A nicer xterm replacment, that supports resizing better: hunk ./README 130 - dmenu http://www.suckless.org/download/ - or - gmrun (in your package system) + urxvt http://software.schmorp.de/pkg/rxvt-unicode.html hunk ./README 134 - dzen http://gotmor.googlepages.com/dzen + dzen http://gotmor.googlepages.com/dzen + xmobar http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmobar hunk ./README 137 - A nicer xterm replacment, that supports resizing better: + For a program dispatch menu: hunk ./README 139 - urxvt http://software.schmorp.de/pkg/rxvt-unicode.html + dmenu http://www.suckless.org/download/ + gmrun (in your package system) hunk ./TODO 17 -* upload X11/xmonad to hackage +* upload X11/xmonad to hacakge hunk ./TODO 20 -* bump xmonad.cabal version hunk ./XMonad/ManageHook.hs 14 + +-- XXX examples required hunk ./TODO 10 + +* configuration documentation hunk ./CONFIG 12 -Here is a basic example, which takes defaults from xmonad, and overrides -the border width, default terminal, and some colours: - - -- - -- An example, simple ~/.xmonad/xmonad.hs file. - -- It overrides a few basic settings, reusing all the other defaults, - -- +Here is a basic example, which overrides the default border width, +default terminal, and some colours. This text goes in the file +$HOME/.xmonad/xmonad.hs : hunk ./TODO 19 -* upload X11/xmonad to hacakge -* check examples/text in use-facing Config.hs +* bump xmonad.cabal version and X11 version +* upload X11 and xmonad to hackage +* check examples/text in user-facing Config.hs hunk ./XMonad/Core.hs 295 - pid <- runProcess "ghc" ["--make", "xmonad.hs"] (Just dir) + pid <- runProcess "ghc" ["--make", "xmonad.hs", "-i"] (Just dir) hunk ./XMonad/Core.hs 22 - X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), XConfig(..), LayoutClass(..), Layout(..), readsLayout, Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), - runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, recompile, trace, whenJust, whenX, + X, WindowSet, WindowSpace, WorkspaceId, + ScreenId(..), ScreenDetail(..), XState(..), + XConf(..), XConfig(..), LayoutClass(..), + Layout(..), readsLayout, Typeable, Message, + SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), + runX, catchX, userCode, io, catchIO, + withDisplay, withWindowSet, isRoot, + getAtom, spawn, restart, recompile, trace, whenJust, whenX, hunk ./Main.hs 47 - dir <- fmap (++ "/.xmonad") getHomeDirectory + dir <- fmap (++ "/.xmonad") getHomeDirectory hunk ./XMonad/Core.hs 297 --- Raises an exception if ghc can't be found. +-- The -i flag is used to restrict recompilation to the xmonad.hs file. +-- Raises an exception if GHC can't be found, or if anything else goes wrong. +-- hunk ./XMonad/Core.hs 302 - dir <- fmap (++ "/.xmonad") getHomeDirectory - pid <- runProcess "ghc" ["--make", "xmonad.hs", "-i"] (Just dir) - Nothing Nothing Nothing Nothing - waitForProcess pid - return () + dir <- liftM (++ "/.xmonad") getHomeDirectory + let src = dir ++ "/" ++ "xmonad.hs" + obj = dir ++ "/" ++ "xmonad.o" + yes <- doesFileExist src + when yes $ do + srcT <- getModificationTime src + objT <- getModificationTime obj + when (srcT > objT) $ do + waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i"] (Just dir) + Nothing Nothing Nothing Nothing + return () hunk ./XMonad/Core.hs 300 +-- The file is only recompiled if it is newer than its binary. +-- hunk ./XMonad/Core.hs 304 - dir <- liftM (++ "/.xmonad") getHomeDirectory - let src = dir ++ "/" ++ "xmonad.hs" - obj = dir ++ "/" ++ "xmonad.o" - yes <- doesFileExist src + dir <- liftM (++ "/.xmonad") getHomeDirectory + let bin = dir ++ "/" ++ "xmonad" + src = bin ++ ".hs" + yes <- doesFileExist src hunk ./XMonad/Core.hs 310 - objT <- getModificationTime obj - when (srcT > objT) $ do + binT <- getModificationTime bin + when (srcT > binT) $ do hunk ./XMonad/Core.hs 36 -import Control.Exception (catch, throw, Exception(ExitException)) +import Control.Exception (catch, bracket, throw, Exception(ExitException)) hunk ./XMonad/Core.hs 302 +-- In the event of an error, signalled with GHC returning non-zero exit +-- status, any stderr produced by GHC, written to the file xmonad.errors, +-- will be displayed to the user with xmessage +-- hunk ./XMonad/Core.hs 310 + err = bin ++ ".errors" hunk ./XMonad/Core.hs 317 - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i"] (Just dir) - Nothing Nothing Nothing Nothing - return () + status <- bracket (openFile err WriteMode) hClose $ \h -> do + waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-v0"] (Just dir) + Nothing Nothing Nothing (Just h) + + -- now, if it fails, run xmessage to let the user know: + when (status /= ExitSuccess) $ do + ghcErr <- readFile err + let msg = unlines $ + ["Error detected while loading xmonad configuration file: " ++ src] + ++ lines ghcErr ++ ["","Please check the file for errors."] + + waitForProcess =<< runProcess "xmessage" [msg] + Nothing Nothing Nothing Nothing Nothing + return () hunk ./XMonad/Core.hs 328 - waitForProcess =<< runProcess "xmessage" [msg] - Nothing Nothing Nothing Nothing Nothing - return () + spawn $ "xmessage '" ++ msg ++ "'" hunk ./XMonad/Core.hs 328 - spawn $ "xmessage '" ++ msg ++ "'" + waitForProcess =<< runProcess "xmessage" [msg] + Nothing Nothing Nothing Nothing Nothing + return () hunk ./XMonad/Core.hs 327 - - waitForProcess =<< runProcess "xmessage" [msg] - Nothing Nothing Nothing Nothing Nothing + -- usual double fork for async processes, and no zombies. + -- careful to use exec directly, avoiding shell + -- interpreting chars in the command line args + pid <- forkProcess $ do + forkProcess $ createSession >> executeFile "xmessage" True [msg] Nothing + exitWith ExitSuccess + getProcessStatus True False pid hunk ./XMonad/Core.hs 315 - binT <- getModificationTime bin - when (srcT > binT) $ do + binT <- catch (getModificationTime bin) (const $ return srcT) -- needs recompiling + when (srcT >= binT) $ do hunk ./XMonad/Core.hs 273 -spawn x = liftIO $ do +spawn x = doubleFork $ executeFile "/bin/sh" False ["-c", x] Nothing + +-- | Double fork and execute an IO action (usually one of the exec family of +-- functions) +doubleFork :: MonadIO m => IO () -> m () +doubleFork m = liftIO $ do hunk ./XMonad/Core.hs 280 - forkProcess (createSession >> executeFile "/bin/sh" False ["-c", x] Nothing) + forkProcess (createSession >> m) hunk ./XMonad/Core.hs 332 - -- usual double fork for async processes, and no zombies. - -- careful to use exec directly, avoiding shell - -- interpreting chars in the command line args - pid <- forkProcess $ do - forkProcess $ createSession >> executeFile "xmessage" True [msg] Nothing - exitWith ExitSuccess - getProcessStatus True False pid - return () + doubleFork $ executeFile "xmessage" True [msg] Nothing hunk ./XMonad/Core.hs 311 -recompile :: IO () -recompile = do +recompile :: MonadIO m => m () +recompile = liftIO $ do hunk ./XMonad/Core.hs 320 - binT <- catch (getModificationTime bin) (const $ return srcT) -- needs recompiling + binT <- catch (getModificationTime bin) (const $ return srcT) -- needs recompiling hunk ./XMonad/Core.hs 317 - yes <- doesFileExist src - when yes $ do - srcT <- getModificationTime src - binT <- catch (getModificationTime bin) (const $ return srcT) -- needs recompiling - when (srcT >= binT) $ do - status <- bracket (openFile err WriteMode) hClose $ \h -> do - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-v0"] (Just dir) - Nothing Nothing Nothing (Just h) + srcT <- getModTime src + binT <- getModTime bin + when (srcT > binT) $ do + status <- bracket (openFile err WriteMode) hClose $ \h -> do + waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-v0"] (Just dir) + Nothing Nothing Nothing (Just h) hunk ./XMonad/Core.hs 324 - -- now, if it fails, run xmessage to let the user know: - when (status /= ExitSuccess) $ do - ghcErr <- readFile err - let msg = unlines $ - ["Error detected while loading xmonad configuration file: " ++ src] - ++ lines ghcErr ++ ["","Please check the file for errors."] - doubleFork $ executeFile "xmessage" True [msg] Nothing + -- now, if it fails, run xmessage to let the user know: + when (status /= ExitSuccess) $ do + ghcErr <- readFile err + let msg = unlines $ + ["Error detected while loading xmonad configuration file: " ++ src] + ++ lines ghcErr ++ ["","Please check the file for errors."] + doubleFork $ executeFile "xmessage" True [msg] Nothing + where getModTime f = catch (fmap Just $ getModificationTime f) (const $ return Nothing) hunk ./XMonad/Core.hs 154 -isRoot w = liftM (w==) (asks theRoot) +isRoot w = fmap (w==) (asks theRoot) hunk ./XMonad/Core.hs 219 - doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s + doLayout (Layout l) r s = fmap (fmap Layout) `fmap` doLayout l r s hunk ./XMonad/Core.hs 313 - dir <- liftM (++ "/.xmonad") getHomeDirectory + dir <- fmap (++ "/.xmonad") getHomeDirectory hunk ./XMonad/Operations.hs 54 - isTransient <- isJust `liftM` io (getTransientForHint d w) + isTransient <- isJust `fmap` io (getTransientForHint d w) hunk ./XMonad/Operations.hs 299 - whenX (not `liftM` isRoot w) $ setButtonGrab False w + whenX (not `fmap` isRoot w) $ setButtonGrab False w hunk ./XMonad/Operations.hs 379 -initColor dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c +initColor dpy c = (color_pixel . fst) `fmap` allocNamedColor dpy colormap c hunk ./XMonad/Core.hs 30 - atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW + atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW, ManageHook, Query(..), runManageHook hunk ./XMonad/Core.hs 48 +import Data.Monoid hunk ./XMonad/Core.hs 79 - , manageHook :: Window -> X (WindowSet -> WindowSet) + , manageHook :: !ManageHook hunk ./XMonad/Core.hs 120 +instance (Monoid a) => Monoid (X a) where + mempty = return mempty + mappend = liftM2 mappend + +type ManageHook = Query (Endo WindowSet) +newtype Query a = Query (ReaderT Window X a) deriving (Functor, Monad, MonadReader Window) + +runManageHook :: ManageHook -> Window -> X (WindowSet -> WindowSet) +runManageHook (Query m) w = fmap appEndo $ runReaderT m w + +instance Monoid a => Monoid (Query a) where + mempty = return mempty + mappend = liftM2 mappend + hunk ./XMonad/ManageHook.hs 1 +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + hunk ./XMonad/ManageHook.hs 22 -import Graphics.X11 hunk ./XMonad/ManageHook.hs 23 -import Control.Monad +import Control.Monad.Reader hunk ./XMonad/ManageHook.hs 25 +import Data.Monoid hunk ./XMonad/ManageHook.hs 29 -type ManageHook = Query (WindowSet -> WindowSet) -type Query a = Window -> X a +liftX :: X a -> Query a +liftX = Query . lift hunk ./XMonad/ManageHook.hs 38 -f <+> g = \w -> liftM2 (.) (f w) (g w) +f <+> g = mappend f g hunk ./XMonad/ManageHook.hs 42 -composeAll = foldr (<+>) idHook +composeAll = mconcat hunk ./XMonad/ManageHook.hs 46 -p --> f = \w -> p w >>= \b -> if b then f w else idHook w +p --> f = p >>= \b -> if b then f else mempty hunk ./XMonad/ManageHook.hs 50 -q =? x = \w -> fmap (== x) (q w) +q =? x = fmap (== x) q hunk ./XMonad/ManageHook.hs 54 -title = \w -> withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w -resource = \w -> withDisplay $ \d -> fmap resName $ io $ getClassHint d w -className = \w -> withDisplay $ \d -> fmap resClass $ io $ getClassHint d w +title = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w) +resource = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w) +className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w) hunk ./XMonad/ManageHook.hs 60 -doF f = const (return f) +doF = return . Endo hunk ./XMonad/ManageHook.hs 64 -doFloat = \w -> fmap (W.float w . snd) (floatLocation w) +doFloat = ask >>= \w -> doF . W.float w . snd =<< liftX (floatLocation w) hunk ./XMonad/ManageHook.hs 68 -doIgnore = \w -> reveal w >> return (W.delete w) +doIgnore = ask >>= \w -> liftX (reveal w) >> doF (W.delete w) hunk ./XMonad/Operations.hs 67 - g <- mh w `catchX` return id + g <- runManageHook mh w `catchX` return id hunk ./XMonad/Core.hs 37 +import Control.Applicative hunk ./XMonad/Core.hs 129 -runManageHook (Query m) w = fmap appEndo $ runReaderT m w +runManageHook (Query m) w = appEndo <$> runReaderT m w hunk ./XMonad/Core.hs 170 -isRoot w = fmap (w==) (asks theRoot) +isRoot w = (w==) <$> asks theRoot hunk ./XMonad/Core.hs 329 - dir <- fmap (++ "/.xmonad") getHomeDirectory + dir <- (++ "/.xmonad") <$> getHomeDirectory hunk ./XMonad/Core.hs 347 - where getModTime f = catch (fmap Just $ getModificationTime f) (const $ return Nothing) + where getModTime f = catch (Just <$> getModificationTime f) (const $ return Nothing) hunk ./XMonad/Operations.hs 32 +import Control.Applicative hunk ./XMonad/Operations.hs 51 -manage w = whenX (fmap not $ isClient w) $ withDisplay $ \d -> do +manage w = whenX (not <$> isClient w) $ withDisplay $ \d -> do hunk ./XMonad/Operations.hs 55 - isTransient <- isJust `fmap` io (getTransientForHint d w) + isTransient <- isJust <$> io (getTransientForHint d w) hunk ./XMonad/Operations.hs 238 - bw <- (fromIntegral . wa_border_width) `fmap` io (getWindowAttributes d w) + bw <- (fromIntegral . wa_border_width) <$> io (getWindowAttributes d w) hunk ./XMonad/Operations.hs 300 - whenX (not `fmap` isRoot w) $ setButtonGrab False w + whenX (not <$> isRoot w) $ setButtonGrab False w hunk ./XMonad/Operations.hs 311 - w <- (W.workspace . W.current) `fmap` gets windowset + w <- W.workspace . W.current <$> gets windowset hunk ./XMonad/Operations.hs 339 - c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s)) + c:v <- mapM (\s -> (\w -> s { W.workspace = w}) <$> job (W.workspace s)) hunk ./XMonad/Operations.hs 380 -initColor dpy c = (color_pixel . fst) `fmap` allocNamedColor dpy colormap c +initColor dpy c = (color_pixel . fst) <$> allocNamedColor dpy colormap c hunk ./XMonad/Operations.hs 392 - bw <- fi `fmap` asks (borderWidth . config) + bw <- fi <$> asks (borderWidth . config) hunk ./XMonad/ManageHook.hs 38 -f <+> g = mappend f g +(<+>) = mappend hunk ./XMonad/Core.hs 337 - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-v0"] (Just dir) + waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-no-recomp", "-v0"] (Just dir) hunk ./XMonad/Core.hs 319 --- Raises an exception if GHC can't be found, or if anything else goes wrong. hunk ./Main.hs 46 - recompile + recompile False hunk ./XMonad/Core.hs 316 --- | Recompile ~\/xmonad\/xmonad.hs. +-- | 'recompile force', recompile ~\/.xmonad\/xmonad.hs when any of the +-- following apply: +-- * force is True +-- * the xmonad executable does not exist +-- * the xmonad executable is older than xmonad.hs hunk ./XMonad/Core.hs 322 --- The -i flag is used to restrict recompilation to the xmonad.hs file. +-- The -i flag is used to restrict recompilation to the xmonad.hs file only. hunk ./XMonad/Core.hs 324 --- The file is only recompiled if it is newer than its binary. +-- Compilation errors (if any) are logged to ~\/.xmonad\/xmonad.errors. If +-- GHC indicates failure with a non-zero exit code, an xmessage containing +-- GHC's is spawned. hunk ./XMonad/Core.hs 328 --- In the event of an error, signalled with GHC returning non-zero exit --- status, any stderr produced by GHC, written to the file xmonad.errors, --- will be displayed to the user with xmessage --- -recompile :: MonadIO m => m () -recompile = liftIO $ do +recompile :: MonadIO m => Bool -> m () +recompile force = liftIO $ do hunk ./XMonad/Core.hs 336 - when (srcT > binT) $ do + when (force || srcT > binT) $ do hunk ./XMonad/Core.hs 279 -io :: IO a -> X a +io :: MonadIO m => IO a -> m a hunk ./XMonad/Core.hs 285 -catchIO f = liftIO (f `catch` \e -> hPrint stderr e >> hFlush stderr) +catchIO f = io (f `catch` \e -> hPrint stderr e >> hFlush stderr) hunk ./XMonad/Core.hs 294 -doubleFork m = liftIO $ do +doubleFork m = io $ do hunk ./XMonad/Core.hs 329 -recompile force = liftIO $ do +recompile force = io $ do hunk ./XMonad/Core.hs 361 -trace = liftIO . hPutStrLn stderr +trace = io . hPutStrLn stderr hunk ./XMonad/ManageHook.hs 51 + +infixr 3 <&&>, <||> + +-- | 'p <&&> q'. '&&' lifted to a Monad. +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +(<&&>) = liftM2 (&&) + +-- | 'p <||> q'. '||' lifted to a Monad. +(<||>) :: Monad m => m Bool -> m Bool -> m Bool +(<||>) = liftM2 (||) hunk ./Main.hs 19 -import XMonad.Core (recompile) +import XMonad.Core (getXMonadDir, recompile) hunk ./Main.hs 23 -import System.Directory hunk ./Main.hs 46 - dir <- fmap (++ "/.xmonad") getHomeDirectory + dir <- getXMonadDir hunk ./XMonad/Core.hs 29 - getAtom, spawn, restart, recompile, trace, whenJust, whenX, + getAtom, spawn, restart, getXMonadDir, recompile, trace, whenJust, whenX, hunk ./XMonad/Core.hs 316 +-- | Return the path to @~\/.xmonad@. +getXMonadDir :: MonadIO m => m String +getXMonadDir = io $ getAppUserDataDirectory "xmonad" + hunk ./XMonad/Core.hs 334 - dir <- (++ "/.xmonad") <$> getHomeDirectory + dir <- getXMonadDir hunk ./xmonad.cabal 41 - build-depends: X11==1.3.0.20071111, mtl, unix + build-depends: X11==1.4.0, mtl, unix hunk ./TODO 13 -* build and typecheck all XMC hunk ./TODO 15 -* document, with photos, any new layouts hunk ./XMonad.hs 20 + module XMonad.ManageHook, hunk ./XMonad.hs 30 +import XMonad.ManageHook hunk ./XMonad/Core.hs 126 -newtype Query a = Query (ReaderT Window X a) deriving (Functor, Monad, MonadReader Window) +newtype Query a = Query (ReaderT Window X a) deriving (Functor, Monad, MonadReader Window, MonadIO) hunk ./util/GenerateManpage.hs 45 - troffBindings <- (concatMap troff . allBindings) `liftM` readFile "./Config.hs" + troffBindings <- (concatMap troff . allBindings) `liftM` readFile "./XMonad/Config.hs" hunk ./xmonad.cabal 20 -extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1.in - util/GenerateManpage.hs man/xmonad.1 man/xmonad.html +extra-source-files: README TODO CONFIG STYLE tests/loc.hs tests/Properties.hs + man/xmonad.1.in man/xmonad.1 man/xmonad.html + util/GenerateManpage.hs hunk ./xmonad.cabal 42 - build-depends: X11==1.4.0, mtl, unix + build-depends: X11>=1.4.0, mtl, unix hunk ./XMonad.hs 21 - -- module Graphics.X11.Xlib, -- conflicts with lots of extensions - (.|.) + module Graphics.X11, + module Graphics.X11.Xlib.Extras, + (.|.), + MonadState(..), gets, modify, + MonadReader(..), asks, + MonadIO(..) hunk ./XMonad.hs 39 --- import Graphics.X11.Xlib +import Graphics.X11 hiding (refreshKeyboardMapping) +import Graphics.X11.Xlib.Extras + +import Control.Monad.State +import Control.Monad.Reader hunk ./XMonad.hs 21 + module XMonad.Operations, hunk ./XMonad.hs 36 +import XMonad.Operations hunk ./XMonad.hs 20 + module XMonad.Layouts, hunk ./XMonad.hs 36 +import XMonad.Layouts hunk ./XMonad/Core.hs 119 +#ifndef __HADDOCK__ hunk ./XMonad/Core.hs 121 +#endif hunk ./XMonad/Core.hs 128 -newtype Query a = Query (ReaderT Window X a) deriving (Functor, Monad, MonadReader Window, MonadIO) +newtype Query a = Query (ReaderT Window X a) +#ifndef __HADDOCK__ + deriving (Functor, Monad, MonadReader Window, MonadIO) +#endif hunk ./xmonad.cabal 46 + extensions: CPP hunk ./xmonad.cabal 55 + extensions: CPP move ./XMonad/Layouts.hs ./XMonad/Layout.hs hunk ./XMonad/Config.hs 30 -import XMonad.Layouts +import XMonad.Layout hunk ./XMonad/Layout.hs 18 -module XMonad.Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), +module XMonad.Layout (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), hunk ./XMonad/Operations.hs 22 -import XMonad.Layouts (Full(..)) +import XMonad.Layout (Full(..)) hunk ./xmonad.cabal 33 - XMonad.Layouts + XMonad.Layout hunk ./xmonad.cabal 50 - other-modules: XMonad.Core XMonad.Main XMonad.Layouts + other-modules: XMonad.Core XMonad.Main XMonad.Layout hunk ./XMonad/Core.hs 216 - -- access to the X monad to determine how to layou out the windows, and + -- access to the X monad to determine how to layout the windows, and hunk ./XMonad/Core.hs 224 - -- returns an updated 'LayoutClass' and the screen is refreshed. + -- returns an updated 'Layout' and the screen is refreshed. hunk ./XMonad/ManageHook.hs 64 -title = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w) -resource = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w) -className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w) +title = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w) +resource = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w) +className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w) hunk ./XMonad.hs 20 - module XMonad.Layouts, + module XMonad.Layout, hunk ./XMonad.hs 36 -import XMonad.Layouts +import XMonad.Layout hunk ./XMonad/Config.hs 114 -manageHook = composeAll . concat $ - [ [ className =? c --> doFloat | c <- floats] - , [ resource =? r --> doIgnore | r <- ignore] - , [ resource =? "Gecko" --> doF (W.shift "web") ]] - where floats = ["MPlayer", "Gimp"] - ignore = ["gnome-panel", "desktop_window", "kicker", "kdesktop"] +manageHook = composeAll + [ className =? "MPlayer" --> doFloat + , className =? "Gimp" --> doFloat + , resource =? "desktop_window" --> doIgnore + , resource =? "kdesktop" --> doIgnore ] hunk ./CONFIG 3 -xmonad is configured by creating and editing the Haskell file: +xmonad is configured by creating and editing the file: hunk ./CONFIG 8 -on startup. +on startup. For a complete example of possible settings, see the file: + + man/xmonad-template.hs + +Further examples are on the website, wiki and extension documentation. + + http://haskell.org/haskellwiki/Xmonad hunk ./README 112 + +Configuring: + + See the CONFIG document + +------------------------------------------------------------------------ addfile ./man/xmonad-template.hs hunk ./man/xmonad-template.hs 1 +-- +-- xmonad example config file. +-- +-- A template showing all available configuration hooks, +-- and how to override the defaults in your own xmonad.hs conf file. +-- +-- Normally, you'd only override those defaults you care about. +-- + +import XMonad +import System.Exit + +import qualified XMonad.StackSet as W +import qualified Data.Map as M + +-- The preferred terminal program, which is used in a binding below and by +-- certain contrib modules. +-- +myTerminal = "xterm" + +-- Width of the window border in pixels. +-- +myBorderWidth = 1 + +-- modMask lets you specify which modkey you want to use. The default +-- is mod1Mask ("left alt"). You may also consider using mod3Mask +-- ("right alt"), which does not conflict with emacs keybindings. The +-- "windows key" is usually mod4Mask. +-- +myModMask = mod1Mask + +-- The mask for the numlock key. Numlock status is "masked" from the +-- current modifier status, so the keybindings will work with numlock on or +-- off. You may need to change this on some systems. +-- +-- You can find the numlock modifier by running "xmodmap" and looking for a +-- modifier with Num_Lock bound to it: +-- +-- > $ xmodmap | grep Num +-- > mod2 Num_Lock (0x4d) +-- +-- Set numlockMask = 0 if you don't have a numlock key, or want to treat +-- numlock status separately. +-- +myNumlockMask = mod2Mask + +-- The default number of workspaces (virtual screens) and their names. +-- By default we use numeric strings, but any string may be used as a +-- workspace name. The number of workspaces is determined by the length +-- of this list. +-- +-- A tagging example: +-- +-- > workspaces = ["web", "irc", "code" ] ++ map show [4..9] +-- +myWorkspaces = ["1","2","3","4","5","6","7","8","9"] + +-- Border colors for unfocused and focused windows, respectively. +-- +myNormalBorderColor = "#dddddd" +myFocusedBorderColor = "#ff0000" + +-- Default offset of drawable screen boundaries from each physical +-- screen. Anything non-zero here will leave a gap of that many pixels +-- on the given edge, on the that screen. A useful gap at top of screen +-- for a menu bar (e.g. 15) +-- +-- An example, to set a top gap on monitor 1, and a gap on the bottom of +-- monitor 2, you'd use a list of geometries like so: +-- +-- > defaultGaps = [(18,0,0,0),(0,18,0,0)] -- 2 gaps on 2 monitors +-- +-- Fields are: top, bottom, left, right. +-- +myDefaultGaps = [(0,0,0,0)] + +------------------------------------------------------------------------ +-- Key bindings. Add, modify or remove key bindings here. +-- +myKeys conf@(XConfig {XMonad.modMask = modMask}) = M.fromList $ + + -- launch a terminal + [ ((modMask .|. shiftMask, xK_Return), spawn $ XMonad.terminal conf) + + -- launch dmenu + , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") + + -- launch gmrun + , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") + + -- close focused window + , ((modMask .|. shiftMask, xK_c ), kill) + + -- Rotate through the available layout algorithms + , ((modMask, xK_space ), sendMessage NextLayout) + + -- Reset the layouts on the current workspace to default + , ((modMask .|. shiftMask, xK_space ), setLayout $ XMonad.layoutHook conf) + + -- Resize viewed windows to the correct size + , ((modMask, xK_n ), refresh) + + -- Move focus to the next window + , ((modMask, xK_Tab ), windows W.focusDown) + + -- Move focus to the next window + , ((modMask, xK_j ), windows W.focusDown) + + -- Move focus to the previous window + , ((modMask, xK_k ), windows W.focusUp ) + + -- Move focus to the master window + , ((modMask, xK_m ), windows W.focusMaster ) + + -- Swap the focused window and the master window + , ((modMask, xK_Return), windows W.swapMaster) + + -- Swap the focused window with the next window + , ((modMask .|. shiftMask, xK_j ), windows W.swapDown ) + + -- Swap the focused window with the previous window + , ((modMask .|. shiftMask, xK_k ), windows W.swapUp ) + + -- Shrink the master area + , ((modMask, xK_h ), sendMessage Shrink) + + -- Expand the master area + , ((modMask, xK_l ), sendMessage Expand) + + -- Push window back into tiling + , ((modMask, xK_t ), withFocused $ windows . W.sink) + + -- Increment the number of windows in the master area + , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) + + -- Deincrement the number of windows in the master area + , ((modMask , xK_period), sendMessage (IncMasterN (-1))) + + -- toggle the status bar gap + , ((modMask , xK_b ), + modifyGap (\i n -> let x = (XMonad.defaultGaps conf ++ repeat (0,0,0,0)) !! i + in if n == x then (0,0,0,0) else x)) + + -- Quit xmonad + , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) + + -- Restart xmonad + , ((modMask , xK_q ), + broadcastMessage ReleaseResources >> restart (Just "xmonad") True) + ] + ++ + + -- + -- mod-[1..9], Switch to workspace N + -- mod-shift-[1..9], Move client to workspace N + -- + [((m .|. modMask, k), windows $ f i) + | (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9] + , (f, m) <- [(W.greedyView, 0), (W.shift, shiftMask)]] + ++ + + -- + -- mod-{w,e,r}, Switch to physical/Xinerama screens 1, 2, or 3 + -- mod-shift-{w,e,r}, Move client to screen 1, 2, or 3 + -- + [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust (windows . f)) + | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..] + , (f, m) <- [(W.view, 0), (W.shift, shiftMask)]] + + +------------------------------------------------------------------------ +-- Mouse bindings: default actions bound to mouse events +-- +myMouseBindings (XConfig {XMonad.modMask = modMask}) = M.fromList $ + + -- mod-button1, Set the window to floating mode and move by dragging + [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w)) + + -- mod-button2, Raise the window to the top of the stack + , ((modMask, button2), (\w -> focus w >> windows W.swapMaster)) + + -- mod-button3, Set the window to floating mode and resize by dragging + , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) + + -- you may also bind events to the mouse scroll wheel (button4 and button5) + ] + +------------------------------------------------------------------------ +-- Layouts: + +-- You can specify and transform your layouts by modifying these values. +-- If you change layout bindings be sure to use 'mod-shift-space' after +-- restarting (with 'mod-q') to reset your layout state to the new +-- defaults, as xmonad preserves your old layout settings by default. +-- +-- The available layouts. Note that each layout is separated by |||, +-- which denotes layout choice. +-- +myLayout = tiled ||| Mirror tiled ||| Full + where + -- default tiling algorithm partitions the screen into two panes + tiled = Tall nmaster delta ratio + + -- The default number of windows in the master pane + nmaster = 1 + + -- Default proportion of screen occupied by master pane + ratio = 1/2 + + -- Percent of screen to increment by when resizing panes + delta = 3/100 + +------------------------------------------------------------------------ +-- Window rules: + +-- Execute arbitrary actions and WindowSet manipulations when managing +-- a new window. You can use this to, for example, always float a +-- particular program, or have a client always appear on a particular +-- workspace. +-- +-- To find the property name associated with a program, use +-- > xprop | grep WM_CLASS +-- and click on the client you're interested in. +-- +myManageHook = composeAll + [ className =? "MPlayer" --> doFloat + , className =? "Gimp" --> doFloat + , resource =? "desktop_window" --> doIgnore + , resource =? "kdesktop" --> doIgnore ] + + +------------------------------------------------------------------------ +-- Status bars and logging + +-- Perform an arbitrary action on each internal state change or X event. +-- See the 'DynamicLog' extension for examples. +-- +-- To emulate dwm's status bar +-- +-- > logHook = dynamicLogDzen +-- +myLogHook = return () + +------------------------------------------------------------------------ +-- Now run xmonad with all the defaults we set up. + +-- Run xmonad with the settings you specify. No need to modify this. +-- +main = xmonad defaults + +-- A structure containing your configuration settings, overriding +-- fields in the default config. Any you don't override, will +-- use the defaults defined in xmonad/XMonad/Config.hs +-- +-- No need to modify this. +-- +defaults = defaultConfig { + -- simple stuff + terminal = myTerminal, + borderWidth = myBorderWidth, + modMask = myModMask, + numlockMask = myNumlockMask, + workspaces = myWorkspaces, + normalBorderColor = myNormalBorderColor, + focusedBorderColor = myFocusedBorderColor, + defaultGaps = myDefaultGaps, + + -- key bindings + keys = myKeys, + mouseBindings = myMouseBindings, + + -- hooks, layouts + layoutHook = myLayout, + manageHook = myManageHook, + logHook = myLogHook + } hunk ./xmonad.cabal 21 - man/xmonad.1.in man/xmonad.1 man/xmonad.html + man/xmonad.1.in man/xmonad.1 man/xmonad.html man/xmonad-template.hs hunk ./XMonad/StackSet.hs 17 + + -- ** The Zipper + -- $zipper + + -- ** Xinerama support + -- $xinerama + + -- ** Master and Focus + -- $focus + hunk ./XMonad/StackSet.hs 78 --- --- Zipper + +-- $zipper hunk ./XMonad/StackSet.hs 107 --- --- Xinerama support: --- + +-- $xinerama hunk ./XMonad/StackSet.hs 116 --- --- Master and Focus + +-- $focus move ./man/xmonad-template.hs ./man/xmonad.hs hunk ./CONFIG 10 - man/xmonad-template.hs + man/xmonad.hs hunk ./xmonad.cabal 21 - man/xmonad.1.in man/xmonad.1 man/xmonad.html man/xmonad-template.hs + man/xmonad.1.in man/xmonad.1 man/xmonad.html man/xmonad.hs hunk ./xmonad.cabal 2 -version: 0.4 +version: 0.5 hunk ./README 126 - 0.4 release: http://www.xmonad.org/XMonadContrib-0.4.tar.gz + 0.5 release: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmonad-contrib-0.5 hunk ./Main.hs 17 -import XMonad.Main -import XMonad.Config -import XMonad.Core (getXMonadDir, recompile) +import XMonad hunk ./xmonad.cabal 28 +flag testing + description: Testing mode, only build minimal components + default: False + hunk ./xmonad.cabal 51 + if flag(testing) + buildable: False changepref test runghc Setup.lhs configure --disable-optimization --user && runghc Setup.lhs build && runghc -itests tests/Main.hs 50 && cat *.hs XMonad/*.hs | runghc tests/loc.hs runghc Setup.lhs configure --disable-optimization --user -f testing && runghc Setup.lhs build && runghc -itests tests/Main.hs 50 && cat *.hs XMonad/*.hs | runghc tests/loc.hs hunk ./Main.hs 3 --- Module : Main.hs +-- Module : Main hunk ./XMonad/Core.hs 8 --- Module : XMonad/Core.hs +-- Module : XMonad.Core hunk ./XMonad/Layout.hs 6 --- Module : Layouts.hs +-- Module : XMonad.Layout hunk ./XMonad/Main.hs 4 --- Module : Core.hs +-- Module : XMonad.Main hunk ./XMonad/ManageHook.hs 5 --- Module : XMonad/ManageHook.hs +-- Module : XMonad.ManageHook hunk ./XMonad/Operations.hs 7 --- Module : Operations.hs +-- Module : XMonad.Operations hunk ./XMonad/StackSet.hs 5 --- Module : StackSet +-- Module : XMonad.StackSet hunk ./man/xmonad.hs 224 +-- +-- To match on the WM_NAME, you can use 'title' in the same way that +-- 'className' and 'resource' are used below. hunk ./XMonad/Main.hs 154 - else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) }) + else modify (\s -> s { waitingUnmap = M.update mpred w (waitingUnmap s) }) + where mpred 1 = Nothing + mpred n = Just $ pred n hunk ./XMonad/Main.hs 146 -handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w +handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ do + unmanage w + modify (\s -> s { mapped = S.delete w (mapped s) + , waitingUnmap = M.delete w (waitingUnmap s)}) hunk ./XMonad/Operations.hs 80 - modify (\s -> s {mapped = S.delete w (mapped s), waitingUnmap = M.delete w (waitingUnmap s)}) hunk ./XMonad/Operations.hs 74 --- should also unmap? --- hunk ./XMonad/Operations.hs 75 -unmanage w = do - windows (W.delete w) - setWMState w withdrawnState +unmanage = windows . W.delete hunk ./XMonad/Operations.hs 114 + hunk ./XMonad/Operations.hs 116 + mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws) + hunk ./XMonad/Operations.hs 166 - -- io performGC -- really helps, but seems to trigger GC bugs? hunk ./XMonad/Operations.hs 116 - mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws) hunk ./XMonad/Operations.hs 170 + -- all windows that are no longer in the windowset are marked as + -- withdrawn, it is important to do this after the above, otherwise 'hide' + -- will overwrite withdrawnState with iconicState + mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws) + hunk ./README 75 - X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.3.0 + X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.4.1 hunk ./xmonad.cabal 46 - build-depends: X11>=1.4.0, mtl, unix + build-depends: X11>=1.4.1, mtl, unix hunk ./man/xmonad.1.in 19 -When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. If you switch to a workspace which is currently visible on another screen, \fBxmonad\fR simply switches focus to that screen. If you switch to a workspace which is *not* visible, \fBxmonad\fR replaces the workspace on the *current* screen with the workspace you selected. +When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. mod-{w,e,r} switch the focus between screens, while shift-mod-{w,e,r} move the current window to that screen. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. When switching workspaces to one that is already visible, the current and visible workspaces are swapped. hunk ./man/xmonad.1.in 21 -For example, if you have the following configuration: -.RS -.PP -Screen 1: Workspace 2 -.PP -Screen 2: Workspace 5 (current workspace) -.RE -.PP -and you wanted to view workspace 7 on screen 1, you would press: -.RS -.PP -mod-2 (to select workspace 2, and make screen 1 the current screen) -.PP -mod-7 (to select workspace 7) -.RE -.PP -Since switching to the workspace currently visible on a given screen is such a common operation, shortcuts are provided: mod-{w,e,r} switch to the workspace currently visible on screens 1, 2, and 3 respectively. Likewise, shift-mod-{w,e,r} moves the current window to the workspace on that screen. Using these keys, the above example would become mod-w mod-7. hunk ./man/xmonad.1.in 30 -\fBxmonad\fR is customized by creating a custom Config.hs and (re)compiling the source code. After recompiling, 'restart' is used to fork the new version, with changes reflected immediately. +\fBxmonad\fR is customized in ~/.xmonad/xmonad.hs, and then restarting with mod-q. hunk ./XMonad/Config.hs 210 - , ((modMask , xK_q ), broadcastMessage ReleaseResources >> restart (Just "xmonad") True) -- %! Restart xmonad + , ((modMask , xK_q ), restart (Just "xmonad") True) -- %! Restart xmonad hunk ./XMonad/Core.hs 28 - withDisplay, withWindowSet, isRoot, + withDisplay, withWindowSet, isRoot, runOnWorkspaces, broadcastMessage, hunk ./XMonad/Core.hs 33 -import XMonad.StackSet +import XMonad.StackSet hiding (modify) hunk ./XMonad/Core.hs 306 +-- | Send a message to all visible layouts, without necessarily refreshing. +-- This is how we implement the hooks, such as UnDoLayout. +broadcastMessage :: Message a => a -> X () +broadcastMessage a = runOnWorkspaces $ \w -> do + ml' <- handleMessage (layout w) (SomeMessage a) `catchX` return Nothing + return $ w { layout = maybe (layout w) id ml' } + +-- | This is basically a map function, running a function in the X monad on +-- each workspace with the output of that function being the modified workspace. +runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X () +runOnWorkspaces job =do + ws <- gets windowset + h <- mapM job $ hidden ws + c:v <- mapM (\s -> (\w -> s { workspace = w}) <$> job (workspace s)) + $ current ws : visible ws + modify $ \s -> s { windowset = ws { current = c, visible = v, hidden = h } } + hunk ./XMonad/Core.hs 333 + broadcastMessage ReleaseResources hunk ./XMonad/Operations.hs 326 - --- | Send a message to all visible layouts, without necessarily refreshing. --- This is how we implement the hooks, such as UnDoLayout. -broadcastMessage :: Message a => a -> X () -broadcastMessage a = runOnWorkspaces $ \w -> do - ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - return $ w { W.layout = maybe (W.layout w) id ml' } - --- | This is basically a map function, running a function in the X monad on --- each workspace with the output of that function being the modified workspace. -runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X () -runOnWorkspaces job =do - ws <- gets windowset - h <- mapM job $ W.hidden ws - c:v <- mapM (\s -> (\w -> s { W.workspace = w}) <$> job (W.workspace s)) - $ W.current ws : W.visible ws - modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } } hunk ./man/xmonad.hs 148 - , ((modMask , xK_q ), - broadcastMessage ReleaseResources >> restart (Just "xmonad") True) + , ((modMask , xK_q ), restart (Just "xmonad") True) hunk ./Main.hs 21 +import System.Info hunk ./Main.hs 47 - executeFile (dir ++ "/xmonad") False args Nothing + executeFile (dir ++ "/xmonad-"++arch++"-"++os) False args Nothing hunk ./XMonad/Core.hs 41 +import System.Info hunk ./XMonad/Core.hs 359 - let bin = dir ++ "/" ++ "xmonad" - err = bin ++ ".errors" - src = bin ++ ".hs" + let binn = "xmonad-"++arch++"-"++os + bin = dir ++ "/" ++ binn + base = dir ++ "/" ++ "xmonad" + err = base ++ ".errors" + src = base ++ ".hs" hunk ./XMonad/Core.hs 368 - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-no-recomp", "-v0"] (Just dir) + waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-no-recomp", "-v0", "-o",binn] (Just dir) hunk ./XMonad/Core.hs 335 + io . flush =<< asks display hunk ./XMonad/Config.hs 210 - , ((modMask , xK_q ), restart (Just "xmonad") True) -- %! Restart xmonad + , ((modMask , xK_q ), restart "xmonad" True) -- %! Restart xmonad hunk ./XMonad/Core.hs 46 -import System.Environment hunk ./XMonad/Core.hs 323 --- | Restart xmonad via exec(). +-- | @restart name resume@. Attempt to restart xmonad by executing the program +-- @name@. If @resume@ is 'True', restart with the current window state. +-- When executing another window manager, @resume@ should be 'False'. hunk ./XMonad/Core.hs 327 --- If the first parameter is 'Just name', restart will attempt to execute the --- program corresponding to 'name'. Otherwise, xmonad will attempt to execute --- the name of the current program. --- --- When the second parameter is 'True', xmonad will attempt to resume with the --- current window state. -restart :: Maybe String -> Bool -> X () -restart mprog resume = do +restart :: String -> Bool -> X () +restart prog resume = do hunk ./XMonad/Core.hs 331 - prog <- maybe (io getProgName) return mprog hunk ./man/xmonad.hs 148 - , ((modMask , xK_q ), restart (Just "xmonad") True) + , ((modMask , xK_q ), restart "xmonad" True) hunk ./Main.hs 29 - handle (hPrint stderr) buildLaunch - xmonad defaultConfig -- if buildLaunch returns, execute the trusted core + args <- getArgs + let launch = handle (hPrint stderr) buildLaunch >> xmonad defaultConfig + case args of + [] -> launch + ["--resume", _] -> launch + ["--recompile"] -> recompile False + ["--recompile-force"] -> recompile True + ["--version"] -> putStrLn "xmonad 0.5" + _ -> fail "unrecognized flags" hunk ./XMonad/Core.hs 316 -runOnWorkspaces job =do +runOnWorkspaces job = do hunk ./XMonad/Config.hs 116 - , className =? "Gimp" --> doFloat - , resource =? "desktop_window" --> doIgnore - , resource =? "kdesktop" --> doIgnore ] + , className =? "Gimp" --> doFloat ] hunk ./XMonad/Config.hs 13 --- Users should not modify this file. Rather, they should provide their --- own @~\/.xmonad\/xmonad.hs@ that overrides specific fields in defaultConfig. +-- +-- DO NOT MODIFY THIS FILE! It won't work. You may configure xmonad +-- by providing your own @~\/.xmonad\/xmonad.hs@ that overrides +-- specific fields in 'defaultConfig'. For a starting point, you can +-- copy the @xmonad.hs@ found in the @man@ directory, or look at +-- examples on the xmonad wiki. hunk ./XMonad/Main.hs 192 - sendMessage e -- Always send button events. + broadcastMessage e -- Always send button events. hunk ./XMonad/Core.hs 80 - , manageHook :: !ManageHook - -- ^ The action to run when a new window is opened + , manageHook :: !ManageHook -- ^ The action to run when a new window is opened hunk ./XMonad/Core.hs 79 - , layoutHook :: !(l Window) -- ^ The avaiable layouts + , layoutHook :: !(l Window) -- ^ The available layouts hunk ./XMonad/Core.hs 76 - { normalBorderColor :: !String -- ^ Non focused windows border color. Default: \"#dddddd\" - , focusedBorderColor :: !String -- ^ Focused windows border color. Default: \"#ff0000\" - , terminal :: !String -- ^ The preferred terminal application. Default: \"xterm\" - , layoutHook :: !(l Window) -- ^ The available layouts - , manageHook :: !ManageHook -- ^ The action to run when a new window is opened - , workspaces :: [String] -- ^ The list of workspaces' names - , defaultGaps :: [(Int,Int,Int,Int)] -- ^ The list of gaps, per screen - , numlockMask :: !KeyMask -- ^ The numlock modifier - , modMask :: !KeyMask -- ^ the mod modifier - , keys :: XConfig Layout -> M.Map (ButtonMask,KeySym) (X ()) - -- ^ The key binding: a map from key presses and actions - , mouseBindings :: XConfig Layout -> M.Map (ButtonMask, Button) (Window -> X ()) - -- ^ The mouse bindings - , borderWidth :: !Dimension -- ^ The border width - , logHook :: X () -- ^ The action to perform when the windows set is changed + { normalBorderColor :: !String -- ^ Non focused windows border color. Default: \"#dddddd\" + , focusedBorderColor :: !String -- ^ Focused windows border color. Default: \"#ff0000\" + , terminal :: !String -- ^ The preferred terminal application. Default: \"xterm\" + , layoutHook :: !(l Window) -- ^ The available layouts + , manageHook :: !ManageHook -- ^ The action to run when a new window is opened + , workspaces :: ![String] -- ^ The list of workspaces' names + , defaultGaps :: ![(Int,Int,Int,Int)] -- ^ The list of gaps, per screen + , numlockMask :: !KeyMask -- ^ The numlock modifier + , modMask :: !KeyMask -- ^ the mod modifier + , keys :: !(XConfig Layout -> M.Map (ButtonMask,KeySym) (X ())) + -- ^ The key binding: a map from key presses and actions + , mouseBindings :: !(XConfig Layout -> M.Map (ButtonMask, Button) (Window -> X ())) + -- ^ The mouse bindings + , borderWidth :: !Dimension -- ^ The border width + , logHook :: !(X ()) -- ^ The action to perform when the windows set is changed hunk ./XMonad/Config.hs 29 - ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) + ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor + ,focusFollowsMouse) hunk ./XMonad/Config.hs 33 - ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor) + ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor + ,focusFollowsMouse) hunk ./XMonad/Config.hs 170 +-- | Whether focus follows the mouse pointer. +focusFollowsMouse :: Bool +focusFollowsMouse = True + hunk ./XMonad/Config.hs 260 - , XMonad.manageHook = manageHook } + , XMonad.manageHook = manageHook + , XMonad.focusFollowsMouse = focusFollowsMouse } hunk ./XMonad/Core.hs 91 + , focusFollowsMouse :: !Bool -- ^ Whether window entry events can change focus hunk ./XMonad/Main.hs 197 - && ev_detail e /= notifyInferior = focus w + && ev_detail e /= notifyInferior + = whenX (asks $ focusFollowsMouse . config) (focus w) hunk ./Main.hs 34 - ["--recompile"] -> recompile False - ["--recompile-force"] -> recompile True + ["--recompile"] -> recompile False >> return () + ["--recompile-force"] -> recompile True >> return () hunk ./XMonad/Core.hs 351 -recompile :: MonadIO m => Bool -> m () +-- False is returned if there is compilation errors. +-- +recompile :: MonadIO m => Bool -> m Bool hunk ./XMonad/Core.hs 363 - when (force || srcT > binT) $ do + if (force || srcT > binT) + then do hunk ./XMonad/Core.hs 376 + return (status == ExitSuccess) + else return True hunk ./XMonad/Core.hs 348 --- GHC indicates failure with a non-zero exit code, an xmessage containing --- GHC's is spawned. +-- GHC indicates failure with a non-zero exit code, an xmessage displaying +-- that file is spawned. hunk ./XMonad/Core.hs 27 - runX, catchX, userCode, io, catchIO, + runX, catchX, userCode, io, catchIO, doubleFork, hunk ./xmonad.cabal 48 - ghc-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s + ghc-options: -funbox-strict-fields -Wall -optl-Wl,-s hunk ./xmonad.cabal 59 - ghc-options: -funbox-strict-fields -Wall -Werror -optl-Wl,-s + ghc-options: -funbox-strict-fields -Wall -optl-Wl,-s hunk ./xmonad.cabal 62 + if flag(testing) + ghc-options: -Werror hunk ./XMonad/Operations.hs 253 - xinesc <- withDisplay (io . getScreenInfo) + xinesc' <- withDisplay (io . getScreenInfo) + let xinescN' = zip [0..] xinesc' + containedIn :: Rectangle -> Rectangle -> Bool + containedIn (Rectangle x1 y1 w1 h1) (Rectangle x2 y2 w2 h2) = + x1 >= x2 && + y1 >= y2 && + fromIntegral x1 + w1 <= fromIntegral x2 + w2 && + fromIntegral y1 + h1 <= fromIntegral y2 + h2 + -- remove all screens completely contained in another. + xinescS' = filter (\(_,r1) -> not (any (\r2 -> r1 `containedIn` r2 && r1 /= r2) xinesc')) xinescN' + -- removes all duplicate screens but the first + xinesc = foldr (\r l -> if snd r `elem` map snd l then l else r:l) [] xinescS' hunk ./XMonad/Operations.hs 268 - (a:as) = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs + (a:as) = zipWith3 (\x (n,s) g -> W.Screen x n (SD s g)) xs xinesc gs hunk ./XMonad/Operations.hs 249 --- | rescreen. The screen configuration may have changed (due to --- xrandr), update the state and refresh the screen, and reset the gap. -rescreen :: X () -rescreen = do - xinesc' <- withDisplay (io . getScreenInfo) +-- | getCleanedScreenInfo. reads the list of screens and removes +-- duplicated or contained screens. +getCleanedScreenInfo :: Display -> IO ([(ScreenId, Rectangle)]) +getCleanedScreenInfo dpy = do + xinesc' <- getScreenInfo dpy hunk ./XMonad/Operations.hs 265 + return xinesc + + +-- | rescreen. The screen configuration may have changed (due to +-- xrandr), update the state and refresh the screen, and reset the gap. +rescreen :: X () +rescreen = do + xinesc <- withDisplay (io . getCleanedScreenInfo) hunk ./XMonad/Main.hs 29 -import Graphics.X11.Xinerama (getScreenInfo) hunk ./XMonad/Main.hs 48 - xinesc <- getScreenInfo dpy + xinesc <- getCleanedScreenInfo dpy hunk ./XMonad/Operations.hs 249 --- | getCleanedScreenInfo. reads the list of screens and removes --- duplicated or contained screens. -getCleanedScreenInfo :: Display -> IO ([(ScreenId, Rectangle)]) -getCleanedScreenInfo dpy = do - xinesc' <- getScreenInfo dpy - let xinescN' = zip [0..] xinesc' - containedIn :: Rectangle -> Rectangle -> Bool - containedIn (Rectangle x1 y1 w1 h1) (Rectangle x2 y2 w2 h2) = - x1 >= x2 && - y1 >= y2 && - fromIntegral x1 + w1 <= fromIntegral x2 + w2 && - fromIntegral y1 + h1 <= fromIntegral y2 + h2 - -- remove all screens completely contained in another. - xinescS' = filter (\(_,r1) -> not (any (\r2 -> r1 `containedIn` r2 && r1 /= r2) xinesc')) xinescN' - -- removes all duplicate screens but the first - xinesc = foldr (\r l -> if snd r `elem` map snd l then l else r:l) [] xinescS' - return xinesc +-- | Returns True if the first rectangle is contained within, but not equal +-- to the second. +containedIn :: Rectangle -> Rectangle -> Bool +containedIn r1@(Rectangle x1 y1 w1 h1) r2@(Rectangle x2 y2 w2 h2) + = and [ r1 /= r2 + , x1 >= x2 + , y1 >= y2 + , fromIntegral x1 + w1 <= fromIntegral x2 + w2 + , fromIntegral y1 + h1 <= fromIntegral y2 + h2 ] hunk ./XMonad/Operations.hs 259 +-- | Given a list of screens, remove all duplicated screens and screens that +-- are entirely contained within another. +nubScreens :: [Rectangle] -> [Rectangle] +nubScreens xs = nub . filter (\x -> not $ any (x `containedIn`) xs) $ xs + +-- | Cleans the list of screens according to the rules documented for +-- nubScreens. +getCleanedScreenInfo :: MonadIO m => Display -> m [Rectangle] +getCleanedScreenInfo = io . fmap nubScreens . getScreenInfo hunk ./XMonad/Operations.hs 273 - xinesc <- withDisplay (io . getCleanedScreenInfo) + xinesc <- withDisplay getCleanedScreenInfo hunk ./XMonad/Operations.hs 277 - (a:as) = zipWith3 (\x (n,s) g -> W.Screen x n (SD s g)) xs xinesc gs + (a:as) = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs hunk ./Main.hs 25 +#ifdef TESTING +import qualified Properties +#endif + hunk ./Main.hs 41 +#ifdef TESTING + ("--run-tests":_) -> Properties.main +#endif hunk ./tests/Main.hs 1 -module Main where - -import qualified Properties - --- This will run all of the QC files for xmonad core. Currently, that's just --- Properties. If any more get added, sequence the main actions together. -main = do - Properties.main rmfile ./tests/Main.hs hunk ./tests/Properties.hs 1 -{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fglasgow-exts -w #-} hunk ./tests/Properties.hs 55 - coarbitrary = error "no coarbitrary for StackSet" hunk ./tests/Properties.hs 654 - args <- getArgs + args <- fmap (drop 1) getArgs hunk ./tests/Properties.hs 943 + coarbitrary = error "coarbitrary EmptyStackSet" hunk ./xmonad.cabal 26 - description: Choose the new smaller, split-up base package. + description: Choose the new smaller, split-up base package. hunk ./xmonad.cabal 29 - description: Testing mode, only build minimal components - default: False + description: Testing mode, only build minimal components + default: False hunk ./xmonad.cabal 51 + hunk ./xmonad.cabal 63 + hunk ./xmonad.cabal 65 - ghc-options: -Werror + cpp-options: -DTESTING + hs-source-dirs: . tests/ + build-depends: QuickCheck + ghc-options: -Werror + if flag(testing) && flag(small_base) + build-depends: random changepref test runghc Setup.lhs configure --disable-optimization --user -f testing && runghc Setup.lhs build && runghc -itests tests/Main.hs 50 && cat *.hs XMonad/*.hs | runghc tests/loc.hs runghc Setup.lhs configure --disable-optimization --user -f testing && runghc Setup.lhs build && ./dist/build/xmonad/xmonad --run-tests 50 && cat *.hs XMonad/*.hs | runghc tests/loc.hs hunk ./xmonad.cabal 67 - build-depends: QuickCheck + build-depends: QuickCheck < 2 hunk ./man/xmonad.1.in 21 +.SS Flags +\fBxmonad\fR has several flags which you may pass to the executable. These flags are: +.TP +\fB--recompile +Recompiles your configuration in ~/.xmonad/xmonad.hs if it is newer than your already existing ~/.xmonad/xmonad executable. +.TP +\fB--recompile-force +Unconditionally recompiles your configuration in ~/.xmonad/xmonad.hs. +.TP +\fB--version +Display version of \fBxmonad\fR. hunk ./xmonad.cabal 2 -version: 0.5 +version: 0.6 hunk ./man/xmonad.hs 233 +-- Whether focus follows the mouse pointer. +myFocusFollowsMouse :: Bool +myFocusFollowsMouse = True + hunk ./man/xmonad.hs 266 + focusFollowsMouse = myFocusFollowsMouse, hunk ./xmonad.cabal 57 - other-modules: XMonad.Core XMonad.Main XMonad.Layout - XMonad.Operations XMonad.StackSet XMonad + other-modules: XMonad + XMonad.Main + XMonad.Core + XMonad.Config + XMonad.Layout + XMonad.ManageHook + XMonad.Operations + XMonad.StackSet hunk ./LICENSE 1 -Copyright (c) Spencer Janssen +Copyright (c) 2007,2008 Spencer Janssen +Copyright (c) 2007,2008 Don Stewart hunk ./LICENSE 9 + hunk ./LICENSE 12 + hunk ./LICENSE 16 + hunk ./LICENSE 21 -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL hunk ./LICENSE 28 -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. hunk ./XMonad/Core.hs 221 + -- | 'emptyLayout' is called when there is no window. + emptyLayout :: layout a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a)) + emptyLayout _ _ = return ([], Nothing) + hunk ./XMonad/Core.hs 245 + emptyLayout (Layout l) r = fmap (fmap Layout) `fmap` emptyLayout l r hunk ./XMonad/Core.hs 253 -runLayout l r = maybe (return ([], Nothing)) (doLayout l r) +runLayout l r = maybe (emptyLayout l r) (doLayout l r) hunk ./XMonad/Layout.hs 56 + + emptyLayout (SLeft r l) = (fmap (second . fmap $ SLeft r) .) $ emptyLayout l + emptyLayout (SRight l r) = (fmap (second . fmap $ SRight l) .) $ emptyLayout r hunk ./Main.hs 19 -import Control.Exception (handle) hunk ./Main.hs 33 - let launch = handle (hPrint stderr) buildLaunch >> xmonad defaultConfig + let launch = catchIO buildLaunch >> xmonad defaultConfig hunk ./XMonad/Core.hs 294 -catchIO :: IO () -> X () +catchIO :: MonadIO m => IO () -> m () hunk ./Main.hs 39 - ["--version"] -> putStrLn "xmonad 0.5" + ["--version"] -> putStrLn "xmonad 0.6" hunk ./TODO 21 +* md5sums for tarballs. hunk ./TODO 13 +* Be sure to bump --version hunk ./README 126 - 0.5 release: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmonad-contrib-0.5 + 0.6 release: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmonad-contrib-0.6 hunk ./XMonad/StackSet.hs 125 --- | --- API changes from xmonad 0.1: --- StackSet constructor arguments changed. StackSet workspace window screen --- --- * new, -- was: empty --- --- * view, --- --- * index, --- --- * peek, -- was: peek\/peekStack --- --- * focusUp, focusDown, -- was: rotate --- --- * swapUp, swapDown --- --- * focus -- was: raiseFocus --- --- * insertUp, -- was: insert\/push --- --- * delete, --- --- * swapMaster, -- was: promote\/swap --- --- * member, --- --- * shift, --- --- * lookupWorkspace, -- was: workspace --- --- * visibleWorkspaces -- gone. --- hunk ./Main.hs 24 +import Paths_xmonad (version) +import Data.Version (showVersion) + hunk ./Main.hs 42 - ["--version"] -> putStrLn "xmonad 0.6" + ["--version"] -> putStrLn ("xmonad " ++ showVersion version) hunk ./TODO 13 -* Be sure to bump --version hunk ./xmonad.cabal 24 +build-type: Simple hunk ./XMonad/Layout.hs 139 + emptyLayout (Mirror l) r = (map (second mirrorRect) *** fmap Mirror) + `fmap` emptyLayout l (mirrorRect r) hunk ./XMonad/Core.hs 54 --- | XState, the window manager state. --- Just the display, width, height and a window list +-- | XState, the (mutable) window manager state. hunk ./XMonad/Core.hs 61 +-- | XConf, the (read-only) window manager configuration. hunk ./XMonad/Core.hs 98 --- | Virtual workspace indicies +-- | Virtual workspace indices hunk ./XMonad/Core.hs 101 --- | Physical screen indicies +-- | Physical screen indices hunk ./XMonad/Core.hs 106 - , statusGap :: !(Int,Int,Int,Int) -- ^ width of status bar on the screen + , statusGap :: !(Int,Int,Int,Int) -- ^ gaps on the sides of the screen that shouldn't be tiled, usually for status bars hunk ./XMonad/Core.hs 111 --- | The X monad, a StateT transformer over IO encapsulating the window --- manager state +-- | The X monad, ReaderT and StateT transformers over IO +-- encapsulating the window manager configuration and state, +-- respectively. hunk ./XMonad/Core.hs 199 --- | The different layout modes --- --- 'doLayout': given a Rectangle and a Stack, layout the stack elements --- inside the given Rectangle. If an element is not given a Rectangle --- by 'doLayout', then it is not shown on screen. Windows are restacked --- according to the order they are returned by 'doLayout'. +-- | Every layout must be an instance of LayoutClass, which defines +-- the basic layout operations along with a sensible default for each. hunk ./XMonad/Core.hs 204 - -- | Given a Rectangle in which to place the windows, and a Stack of - -- windows, return a list of windows and their corresponding Rectangles. - -- The order of windows in this list should be the desired stacking order. + -- | Given a Rectangle in which to place the windows, and a Stack + -- of windows, return a list of windows and their corresponding + -- Rectangles. If an element is not given a Rectangle by + -- 'doLayout', then it is not shown on screen. The order of + -- windows in this list should be the desired stacking order. + -- hunk ./XMonad/Core.hs 251 --- | This calls doLayout if there are any windows to be laid out. +-- | This calls doLayout if there are any windows to be laid out, and +-- emptyLayout otherwise. hunk ./XMonad/Core.hs 345 --- | 'recompile force', recompile ~\/.xmonad\/xmonad.hs when any of the +-- | 'recompile force', recompile @~\/.xmonad\/xmonad.hs@ when any of the hunk ./XMonad/Core.hs 357 --- False is returned if there is compilation errors. +-- False is returned if there are compilation errors. hunk ./XMonad/Core.hs 386 --- | Run a side effecting action with the current workspace. Like 'when' but +-- | Conditionally run an action, using a @Maybe a@ to decide. hunk ./XMonad/StackSet.hs 115 --- workspaces, and non-visible workspaces. +-- workspaces, and non-visible workspaces. hunk ./XMonad/StackSet.hs 148 --- A workspace is just a tag - its index - and a stack +-- A workspace is just a tag, a layout, and a stack. hunk ./XMonad/StackSet.hs 304 --- | +-- | hunk ./XMonad/StackSet.hs 417 --- | /O(n)/. Is a window in the StackSet. +-- | /O(n)/. Is a window in the StackSet? hunk ./XMonad/Core.hs 381 - doubleFork $ executeFile "xmessage" True [msg] Nothing + doubleFork $ executeFile "xmessage" True ["-default", "okay", msg] Nothing hunk ./XMonad/Core.hs 134 -runManageHook :: ManageHook -> Window -> X (WindowSet -> WindowSet) -runManageHook (Query m) w = appEndo <$> runReaderT m w +runManageHook :: Query a -> Window -> X a +runManageHook (Query m) w = runReaderT m w replace ./XMonad/Core.hs [A-Za-z_0-9] runManageHook runQuery hunk ./XMonad/Operations.hs 26 +import Data.Monoid (appEndo) hunk ./XMonad/Operations.hs 69 - g <- runManageHook mh w `catchX` return id + g <- fmap appEndo (runManageHook mh w) `catchX` return id replace ./XMonad/Operations.hs [A-Za-z_0-9] runManageHook runQuery hunk ./XMonad/Core.hs 2 - MultiParamTypeClasses, TypeSynonymInstances #-} + MultiParamTypeClasses, TypeSynonymInstances, CPP #-} hunk ./TODO 21 -* md5sums for tarballs. +* confirm template config is type correct hunk ./XMonad/Main.hs 31 +import qualified XMonad.Config as Default hunk ./XMonad/Main.hs 50 - nbc <- initColor dpy $ normalBorderColor xmc - fbc <- initColor dpy $ focusedBorderColor xmc + nbc <- do v <- initColor dpy $ normalBorderColor xmc + ~(Just nbc_) <- initColor dpy $ normalBorderColor Default.defaultConfig + return (fromMaybe nbc_ v) + + fbc <- do v <- initColor dpy $ focusedBorderColor xmc + ~(Just fbc_) <- initColor dpy $ focusedBorderColor Default.defaultConfig + return (fromMaybe fbc_ v) + hunk ./XMonad/Operations.hs 34 -import Control.Monad.State hunk ./XMonad/Operations.hs 35 +import Control.Monad.State +import qualified Control.Exception as C hunk ./XMonad/Operations.hs 385 -initColor :: Display -> String -> IO Pixel -initColor dpy c = (color_pixel . fst) <$> allocNamedColor dpy colormap c +initColor :: Display -> String -> IO (Maybe Pixel) +initColor dpy c = C.handle (\_ -> return Nothing) $ + (Just . color_pixel . fst) <$> allocNamedColor dpy colormap c hunk ./XMonad/Main.hs 19 +import Data.List ((\\)) hunk ./XMonad/Main.hs 107 + ws <- io $ scan dpy rootw + hunk ./XMonad/Main.hs 111 - -- those windows - windows (const winset) + -- those windows. Remove all windows that are no longer top-level + -- children of the root, they may have disappeared since + -- restarting. + windows . const . foldr W.delete winset $ W.allWindows winset \\ ws hunk ./XMonad/Main.hs 116 - -- scan for all top-level windows, add the unmanaged ones to the - -- windowset - ws <- io $ scan dpy rootw - mapM_ manage ws + -- manage the as-yet-unmanaged windows + mapM_ manage (ws \\ W.allWindows winset) hunk ./README 14 + +Quick start: + +Obtain the dependent libraries, then build with: + + runhaskell Setup.lhs configure --user --prefix=$HOME + runhaskell Setup.lhs build + runhaskell Setup.lhs install --user + +For the full story, read on. hunk ./man/xmonad.1.in 12 -By utilising the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 500 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. +By utilising the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 1200 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. hunk ./man/xmonad.1.in 19 -When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. mod-{w,e,r} switch the focus between screens, while shift-mod-{w,e,r} move the current window to that screen. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. When switching workspaces to one that is already visible, the current and visible workspaces are swapped. +When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. mod-{w,e,r} switch the focus between screens, while shift-mod-{w,e,r} move the current window to that screen. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. When switching workspaces to one that is already visible, the current and visible workspaces are swapped. hunk ./man/xmonad.1.in 24 -\fB--recompile +\fB--recompile hunk ./XMonad/Core.hs 124 +instance Applicative X where + pure = return + (<*>) = ap + hunk ./XMonad/Config.hs 28 - (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings + (workspaces,manageHook,numlockMask,keys,logHook,startupHook,borderWidth,mouseBindings hunk ./XMonad/Config.hs 32 - (workspaces,manageHook,numlockMask,keys,logHook,borderWidth,mouseBindings + (workspaces,manageHook,numlockMask,keys,logHook,startupHook,borderWidth,mouseBindings hunk ./XMonad/Config.hs 137 +-- | Perform an arbitrary action at xmonad startup. +startupHook :: X () +startupHook = return () + hunk ./XMonad/Config.hs 263 + , XMonad.startupHook = startupHook hunk ./XMonad/Core.hs 91 + , startupHook :: !(X ()) -- ^ The action to perform on startup hunk ./XMonad/Main.hs 119 + startupHook initxmc + hunk ./man/xmonad.hs 250 +------------------------------------------------------------------------ +-- Startup hook + +-- Perform an arbitrary action each time xmonad starts or is restarted +-- with mod-q. Used by, e.g., XMonad.Layout.PerWorkspace to initialize +-- per-workspace layout choices. +-- +-- By default, do nothing. +myStartupHook = return () + hunk ./man/xmonad.hs 292 - logHook = myLogHook + logHook = myLogHook, + startupHook = myStartupHook hunk ./tests/Properties.hs 142 - n `tagMember` x ==> invariant $ view (fromIntegral n) x + n `tagMember` x ==> invariant $ greedyView (fromIntegral n) x hunk ./tests/Properties.hs 239 +-- greedyView leaves things unchanged for invalid workspaces +prop_greedyView_current_id (x :: T) (n :: NonNegative Int) = not (i `tagMember` x) ==> + tag (workspace $ current (greedyView i x)) == j + where + i = fromIntegral n + j = tag (workspace (current x)) + hunk ./tests/Properties.hs 685 + ,("greedyView is safe " , mytest prop_greedyView_current_id) hunk ./tests/Properties.hs 550 +prop_float_geometry n (x :: T) = + n `member` x ==> let s = float n geom x + in M.lookup n (floating s) == Just geom + where + geom = RationalRect 100 100 100 100 + hunk ./tests/Properties.hs 765 + ,("floating sets geometry" , mytest prop_float_geometry) hunk ./tests/Properties.hs 556 --- check rectanges were set -{- -prop_float_sets_geometry n (x :: T) = - n `member` x ==> let y = float n geom x in M.lookup y (floating x) == Just geom +prop_float_delete n (x :: T) = + n `member` x ==> let s = float n geom x + t = delete n s + in not (n `member` t) hunk ./tests/Properties.hs 562 --} + hunk ./tests/Properties.hs 766 + ,("floats can be deleted", mytest prop_float_delete) hunk ./tests/Properties.hs 768 + hunk ./tests/Properties.hs 358 +-- On an invalid window, the stackset is unmodified +prop_focusWindow_identity (n :: Char) (x::T ) = + not (n `member` x) ==> focusWindow n x == x + hunk ./tests/Properties.hs 725 + ,("focusWindow identity", mytest prop_focusWindow_identity) hunk ./XMonad/StackSet.hs 213 - | not (i `tagMember` s) - || i == tag (workspace (current s)) = s -- out of bounds or current + | i == tag (workspace (current s)) = s -- current hunk ./XMonad/StackSet.hs 224 - | otherwise = s -- can't happen: all workspaces are either invalid, current, visible, or hidden + | otherwise = s -- not a member of the stackset hunk ./tests/Properties.hs 139 - n `tagMember` x ==> invariant $ view (fromIntegral n) x + invariant $ view (fromIntegral n) x hunk ./tests/Properties.hs 142 - n `tagMember` x ==> invariant $ greedyView (fromIntegral n) x + invariant $ greedyView (fromIntegral n) x hunk ./xmonad.cabal 75 - ghc-options: -Werror + ghc-options: -Werror -fhpc hunk ./XMonad/ManageHook.hs 74 -doFloat = ask >>= \w -> doF . W.float w . snd =<< liftX (floatLocation w) +doFloat = ask >>= \w -> doF . W.float w =<< liftX (floatLocation w) hunk ./XMonad/Operations.hs 59 - (sc, rr) <- floatLocation w + rr <- floatLocation w hunk ./XMonad/Operations.hs 67 - where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws + where i = W.tag $ W.workspace $ W.current ws hunk ./XMonad/Operations.hs 395 -floatLocation :: Window -> X (ScreenId, W.RationalRect) +floatLocation :: Window -> X (W.RationalRect) hunk ./XMonad/Operations.hs 409 - return (W.screen $ sc, rr) + return rr hunk ./XMonad/Operations.hs 420 - (sc, rr) <- floatLocation w + rr <- floatLocation w hunk ./XMonad/Operations.hs 422 + let sc = W.screen $ W.current ws hunk ./XMonad/Operations.hs 422 - let sc = W.screen $ W.current ws hunk ./XMonad/Operations.hs 425 - sw <- W.lookupWorkspace sc ws + sw <- W.lookupWorkspace (W.screen $ W.current ws) ws hunk ./tests/Properties.hs 625 +-- | +-- Ensure that a given set of workspace tags is present by renaming +-- existing workspaces and\/or creating new hidden workspaces as +-- necessary. +-- hunk ./tests/Properties.hs 633 +-- adding a tag should create a new hidden workspace +prop_ensure_append (x :: T) l n = + not (n `tagMember` x) + ==> + (hidden y /= hidden x -- doesn't append, renames + && + and [ isNothing (stack z) && layout z == l | z <- hidden y, tag z == n ] + ) + where + y = ensureTags l (n:ts) x + ts = [ tag z | z <- workspaces x ] + hunk ./tests/Properties.hs 797 + ,("ensure hidden semantics", mytest prop_ensure_append) hunk ./XMonad/Core.hs 26 - SomeMessage(..), fromMessage, runLayout, LayoutMessages(..), + SomeMessage(..), fromMessage, LayoutMessages(..), hunk ./XMonad/Core.hs 209 + -- | This calls doLayout if there are any windows to be laid out, and + -- emptyLayout otherwise. + runLayout :: Workspace WorkspaceId (layout a) a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a)) + runLayout (Workspace _ l ms) r = maybe (emptyLayout l r) (doLayout l r) ms + hunk ./XMonad/Core.hs 239 - -- hunk ./XMonad/Core.hs 253 + runLayout (Workspace i (Layout l) ms) r = fmap (fmap Layout) `fmap` runLayout (Workspace i l ms) r hunk ./XMonad/Core.hs 261 --- | This calls doLayout if there are any windows to be laid out, and --- emptyLayout otherwise. -runLayout :: LayoutClass l a => l a -> Rectangle -> Maybe (Stack a) -> X ([(a, Rectangle)], Maybe (l a)) -runLayout l r = maybe (emptyLayout l r) (doLayout l r) - hunk ./XMonad/Operations.hs 131 - let n = W.tag (W.workspace w) - this = W.view n ws - l = W.layout (W.workspace w) - flt = filter (flip M.member (W.floating ws)) (W.index this) + let wsp = W.workspace w + this = W.view n ws + n = W.tag wsp + flt = filter (flip M.member (W.floating ws)) (W.index this) hunk ./XMonad/Operations.hs 145 - (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (Layout Full) viewrect tiled + (rs, ml') <- runLayout wsp { W.stack = tiled } viewrect`catchX` runLayout wsp { W.layout = Layout Full, W.stack = tiled } viewrect hunk ./XMonad/Layout.hs 54 - doLayout (SLeft r l) = (fmap (second . fmap $ SLeft r) .) . doLayout l - doLayout (SRight l r) = (fmap (second . fmap $ SRight l) .) . doLayout r - - emptyLayout (SLeft r l) = (fmap (second . fmap $ SLeft r) .) $ emptyLayout l - emptyLayout (SRight l r) = (fmap (second . fmap $ SRight l) .) $ emptyLayout r + runLayout (W.Workspace i (SLeft r l) ms) = fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) + runLayout (W.Workspace i (SRight l r) ms) = fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) hunk ./XMonad/Layout.hs 133 - doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror) - `fmap` doLayout l (mirrorRect r) s + runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) + `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) hunk ./XMonad/Layout.hs 136 - emptyLayout (Mirror l) r = (map (second mirrorRect) *** fmap Mirror) - `fmap` emptyLayout l (mirrorRect r) hunk ./XMonad/Core.hs 194 --- | LayoutClass handling. See particular instances in Operations.hs +-- LayoutClass handling. See particular instances in Operations.hs hunk ./XMonad/Core.hs 196 --- | An existential type that can hold any object that is in Read and LayoutClass. +-- | An existential type that can hold any object that is in 'Read' +-- and 'LayoutClass'. hunk ./XMonad/Core.hs 201 --- from a 'String' +-- from a 'String'. hunk ./XMonad/Core.hs 205 --- | Every layout must be an instance of LayoutClass, which defines +-- | Every layout must be an instance of 'LayoutClass', which defines hunk ./XMonad/Core.hs 208 +-- Minimal complete definition: +-- +-- * 'runLayout' || (('doLayout' || 'pureLayout') && 'emptyLayout'), and +-- +-- * 'handleMessage' || 'pureMessage' +-- +-- You should also strongly consider implementing 'description', +-- although it is not required. +-- +-- Note that any code which /uses/ 'LayoutClass' methods should only +-- ever call 'runLayout', 'handleMessage', and 'description'! In +-- other words, the only calls to 'doLayout', 'pureMessage', and other +-- such methods should be from the default implementations of +-- 'runLayout', 'handleMessage', and so on. This ensures that the +-- proper methods will be used, regardless of the particular methods +-- that any 'LayoutClass' instance chooses to define. hunk ./XMonad/Core.hs 226 - -- | This calls doLayout if there are any windows to be laid out, and - -- emptyLayout otherwise. + -- | By default, 'runLayout' calls 'doLayout' if there are any + -- windows to be laid out, and 'emptyLayout' otherwise. Most + -- instances of 'LayoutClass' probably do not need to implement + -- 'runLayout'; it is only useful for layouts which wish to make + -- use of more of the 'Workspace' information (for example, + -- "XMonad.Layout.PerWorkspace"). hunk ./XMonad/Core.hs 235 - -- | Given a Rectangle in which to place the windows, and a Stack + -- | Given a 'Rectangle' in which to place the windows, and a 'Stack' hunk ./XMonad/Core.hs 241 - -- Also return a modified layout, if this layout needs to be modified - -- (e.g. if we keep track of the windows we have displayed). + -- Also possibly return a modified layout (by returning @Just + -- newLayout@), if this layout needs to be modified (e.g. if it + -- keeps track of some sort of state). Return @Nothing@ if the + -- layout does not need to be modified. + -- + -- Layouts which do not need access to the 'X' monad ('IO', window + -- manager state, or configuration) and do not keep track of their + -- own state should implement 'pureLayout' instead of 'doLayout'. hunk ./XMonad/Core.hs 252 - -- | This is a pure version of doLayout, for cases where we don't need - -- access to the X monad to determine how to layout the windows, and - -- we don't need to modify our layout itself. + -- | This is a pure version of 'doLayout', for cases where we + -- don't need access to the 'X' monad to determine how to lay out + -- the windows, and we don't need to modify the layout itself. hunk ./XMonad/Core.hs 258 - -- | 'emptyLayout' is called when there is no window. + -- | 'emptyLayout' is called when there are no windows. hunk ./XMonad/Core.hs 262 - -- | 'handleMessage' performs message handling for that layout. If - -- 'handleMessage' returns Nothing, then the layout did not respond to - -- that message and the screen is not refreshed. Otherwise, 'handleMessage' - -- returns an updated 'Layout' and the screen is refreshed. + -- | 'handleMessage' performs message handling. If + -- 'handleMessage' returns @Nothing@, then the layout did not + -- respond to the message and the screen is not refreshed. + -- Otherwise, 'handleMessage' returns an updated layout and the + -- screen is refreshed. + -- + -- Layouts which do not need access to the 'X' monad to decide how + -- to handle messages should implement 'pureMessage' instead of + -- 'handleMessage'. hunk ./XMonad/Core.hs 274 - -- | Respond to a message by (possibly) changing our layout, but taking - -- no other action. If the layout changes, the screen will be refreshed. + -- | Respond to a message by (possibly) changing our layout, but + -- taking no other action. If the layout changes, the screen will + -- be refreshed. hunk ./XMonad/Core.hs 280 - -- | This should be a human-readable string that is used when selecting - -- layouts by name. + -- | This should be a human-readable string that is used when + -- selecting layouts by name. The default implementation is + -- 'show', which is in some cases a poor default. hunk ./XMonad/Core.hs 295 --- | Based on ideas in /An Extensible Dynamically-Typed Hierarchy of Exceptions/, --- Simon Marlow, 2006. Use extensible messages to the handleMessage handler. +-- | Based on ideas in /An Extensible Dynamically-Typed Hierarchy of +-- Exceptions/, Simon Marlow, 2006. Use extensible messages to the +-- 'handleMessage' handler. hunk ./XMonad/Core.hs 304 --- A wrapped value of some type in the Message class. +-- A wrapped value of some type in the 'Message' class. hunk ./XMonad/Core.hs 309 --- And now, unwrap a given, unknown Message type, performing a (dynamic) +-- And now, unwrap a given, unknown 'Message' type, performing a (dynamic) hunk ./XMonad/Core.hs 315 --- | X Events are valid Messages +-- X Events are valid Messages. hunk ./XMonad/Core.hs 318 --- | LayoutMessages are core messages that all layouts (especially stateful +-- | 'LayoutMessages' are core messages that all layouts (especially stateful hunk ./XMonad/Main.hs 112 - -- children of the root, they may have disappeared since + -- children of the root, they may have disappeared since hunk ./XMonad/Main.hs 205 --- entered a normal window, makes this focused. +-- entered a normal window: focus it if focusFollowsMouse is set to +-- True in the user's config. hunk ./XMonad/Main.hs 27 +import System.Posix.Signals hunk ./XMonad/Main.hs 45 + -- ignore SIGPIPE + installHandler openEndedPipe Ignore Nothing hunk ./XMonad/ManageHook.hs 74 -doFloat = ask >>= \w -> doF . W.float w =<< liftX (floatLocation w) +doFloat = ask >>= \w -> doF . W.float w . snd =<< liftX (floatLocation w) hunk ./XMonad/Operations.hs 59 - rr <- floatLocation w + (sc, rr) <- floatLocation w hunk ./XMonad/Operations.hs 67 - where i = W.tag $ W.workspace $ W.current ws + where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws hunk ./XMonad/Operations.hs 395 -floatLocation :: Window -> X (W.RationalRect) +floatLocation :: Window -> X (ScreenId, W.RationalRect) hunk ./XMonad/Operations.hs 409 - return rr + return (W.screen $ sc, rr) hunk ./XMonad/Operations.hs 420 - rr <- floatLocation w + (sc, rr) <- floatLocation w hunk ./XMonad/Operations.hs 422 - i <- W.findTag w ws + i <- W.findTag w ws hunk ./XMonad/Operations.hs 424 - f <- W.peek ws - sw <- W.lookupWorkspace (W.screen $ W.current ws) ws + f <- W.peek ws + sw <- W.lookupWorkspace sc ws hunk ./XMonad/Core.hs 232 - runLayout :: Workspace WorkspaceId (layout a) a -> Rectangle -> X ([(a, Rectangle)], Maybe (layout a)) + runLayout :: Workspace WorkspaceId (layout a) a + -> Rectangle + -> X ([(a, Rectangle)], Maybe (layout a)) hunk ./XMonad/Core.hs 251 - doLayout :: layout a -> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (layout a)) + doLayout :: layout a -> Rectangle -> Stack a + -> X ([(a, Rectangle)], Maybe (layout a)) hunk ./XMonad/Layout.hs 18 -module XMonad.Layout (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), - Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, - splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where +module XMonad.Layout ( + ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), + Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, + splitHorizontally, splitHorizontallyBy, splitVerticallyBy, + + tile + + ) where hunk ./tests/Properties.hs 5 +import XMonad.Layout hunk ./tests/Properties.hs 660 -{- hunk ./tests/Properties.hs 661 + where pct = 1/2 hunk ./tests/Properties.hs 683 --} - hunk ./tests/Properties.hs 810 -{- hunk ./tests/Properties.hs 812 --} + hunk ./XMonad/Layout.hs 142 + +------------------------------------------------------------------------ hunk ./tests/Properties.hs 6 +import XMonad.Core (pureLayout) hunk ./tests/Properties.hs 664 +-- pureLayout works. +prop_purelayout_tall n r1 r2 rect (t :: T) = + isJust (peek t) ==> + length ts == length (index t) + && + noOverlaps (map snd ts) + + where layoot = Tall n r1 r2 + st = fromJust . stack . workspace . current $ t + ts = pureLayout layoot rect st + hunk ./tests/Properties.hs 824 + ,("pure layout tall", mytest prop_purelayout_tall) hunk ./tests/Properties.hs 670 - hunk ./tests/Properties.hs 674 +-- pureLayout works. +prop_purelayout_full rect (t :: T) = + isJust (peek t) ==> + length ts == 1 -- only one window to view + && + snd (head ts) == rect -- and sets fullscreen + && + fst (head ts) == fromJust (peek t) -- and the focused window is shown + + where layoot = Full + st = fromJust . stack . workspace . current $ t + ts = pureLayout layoot rect st + hunk ./tests/Properties.hs 837 + ,("pure layout full", mytest prop_purelayout_full) addfile ./tests/coverage.hs hunk ./tests/coverage.hs 1 +#!/usr/bin/env runhaskell + +import System.Cmd + +-- generate appropriate .hpc files +main = do + system $ "rm -rf *.tix" + system $ "dist/build/xmonad/xmonad --run-tests" + system $ "hpc markup xmonad --exclude=Main --exclude=Properties --exclude=XMonad --exclude=Paths_xmonad" + system $ "hpc report xmonad --exclude=Main --exclude=Properties --exclude=XMonad --exclude=Paths_xmonad" hunk ./XMonad/Core.hs 273 - -- 'handleMessage'. + -- 'handleMessage' (this restricts the risk of error, and makes + -- testing much easier). hunk ./XMonad/Layout.hs 35 - hunk ./XMonad/Layout.hs 36 --- LayoutClass selection manager - --- | A layout that allows users to switch between various layout options. - --- | Messages to change the current layout. -data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) - -instance Message ChangeLayout - --- | The layout choice combinator -(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a -(|||) = flip SLeft -infixr 5 ||| - -data Choose l r a = SLeft (r a) (l a) - | SRight (l a) (r a) deriving (Read, Show) - -data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) -instance Message NextNoWrap - --- This has lots of pseudo duplicated code, we must find a better way -instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where - runLayout (W.Workspace i (SLeft r l) ms) = fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) - runLayout (W.Workspace i (SRight l r) ms) = fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) - - description (SLeft _ l) = description l - description (SRight _ r) = description r - - handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of - SLeft {} -> return Nothing - SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) - $ handleMessage r (SomeMessage Hide) - - handleMessage lr m | Just NextLayout <- fromMessage m = do - mlr <- handleMessage lr $ SomeMessage NextNoWrap - maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr - - handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do - handleMessage l (SomeMessage Hide) - mr <- handleMessage r (SomeMessage FirstLayout) - return . Just . SRight l $ fromMaybe r mr - - handleMessage lr m | Just ReleaseResources <- fromMessage m = - liftM2 ((Just .) . cons) - (fmap (fromMaybe l) $ handleMessage l m) - (fmap (fromMaybe r) $ handleMessage r m) - where (cons, l, r) = case lr of - (SLeft r' l') -> (flip SLeft, l', r') - (SRight l' r') -> (SRight, l', r') - - -- The default cases for left and right: - handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m - handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m - --- --- | Builtin layout algorithms: +-- | Builtin basic layout algorithms: hunk ./XMonad/Layout.hs 59 --- | The inbuilt tiling mode of xmonad, and its operations. +-- | The builtin tiling mode of xmonad, and its operations. hunk ./XMonad/Layout.hs 61 + -- TODO should be capped [0..1] .. hunk ./XMonad/Layout.hs 63 +-- a nice pure layout, lots of properties for the layout, and its messages, in Properties.hs hunk ./XMonad/Layout.hs 69 - pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m) - ,fmap incmastern (fromMessage m)] - where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) - resize Expand = Tall nmaster delta (min 1 $ frac+delta) - incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac - description _ = "Tall" + pureMessage (Tall nmaster delta frac) m = + msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] hunk ./XMonad/Layout.hs 73 --- | Mirror a rectangle -mirrorRect :: Rectangle -> Rectangle -mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) - --- | Mirror a layout, compute its 90 degree rotated form. -data Mirror l a = Mirror (l a) deriving (Show, Read) + where resize Shrink = Tall nmaster delta (max 0 $ frac-delta) + resize Expand = Tall nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac hunk ./XMonad/Layout.hs 77 -instance LayoutClass l a => LayoutClass (Mirror l) a where - runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) - `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) - handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l - description (Mirror l) = "Mirror "++ description l - ------------------------------------------------------------------------- + description _ = "Tall" hunk ./XMonad/Layout.hs 107 +-- Not used in the core, but exported hunk ./XMonad/Layout.hs 117 +-- Not used in the core, but exported hunk ./XMonad/Layout.hs 120 +------------------------------------------------------------------------ +-- | Mirror a layout, compute its 90 degree rotated form. + +-- | Mirror a layout, compute its 90 degree rotated form. +data Mirror l a = Mirror (l a) deriving (Show, Read) + +instance LayoutClass l a => LayoutClass (Mirror l) a where + runLayout (W.Workspace i (Mirror l) ms) r = (map (second mirrorRect) *** fmap Mirror) + `fmap` runLayout (W.Workspace i l ms) (mirrorRect r) + handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l + description (Mirror l) = "Mirror "++ description l + +-- | Mirror a rectangle +mirrorRect :: Rectangle -> Rectangle +mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) + +------------------------------------------------------------------------ +-- LayoutClass selection manager +-- Layouts that transition between other layouts + +-- | A layout that allows users to switch between various layout options. + +-- | Messages to change the current layout. +data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable) + +instance Message ChangeLayout + +-- | The layout choice combinator +(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a +(|||) = flip SLeft +infixr 5 ||| + +data Choose l r a = SLeft (r a) (l a) + | SRight (l a) (r a) deriving (Read, Show) + +data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable) +instance Message NextNoWrap + +-- This has lots of pseudo duplicated code, we must find a better way +instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where + runLayout (W.Workspace i (SLeft r l) ms) = fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) + runLayout (W.Workspace i (SRight l r) ms) = fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) + + description (SLeft _ l) = description l + description (SRight _ r) = description r + + handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of + SLeft {} -> return Nothing + SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) + $ handleMessage r (SomeMessage Hide) + + handleMessage lr m | Just NextLayout <- fromMessage m = do + mlr <- handleMessage lr $ SomeMessage NextNoWrap + maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr + + handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do + handleMessage l (SomeMessage Hide) + mr <- handleMessage r (SomeMessage FirstLayout) + return . Just . SRight l $ fromMaybe r mr + + handleMessage lr m | Just ReleaseResources <- fromMessage m = + liftM2 ((Just .) . cons) + (fmap (fromMaybe l) $ handleMessage l m) + (fmap (fromMaybe r) $ handleMessage r m) + where (cons, l, r) = case lr of + (SLeft r' l') -> (flip SLeft, l', r') + (SRight l' r') -> (SRight, l', r') + + -- The default cases for left and right: + handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m + handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m + hunk ./tests/Properties.hs 6 -import XMonad.Core (pureLayout) +import XMonad.Core hiding (workspaces,trace) hunk ./tests/Properties.hs 658 --- some properties for layouts: +-- The Tall layout hunk ./tests/Properties.hs 664 +-- multiple windows +prop_tile_non_overlap rect windows nmaster = noOverlaps (tile pct rect nmaster windows) + where _ = rect :: Rectangle + pct = 3 % 100 + hunk ./tests/Properties.hs 675 + && + description layoot == "Tall" hunk ./tests/Properties.hs 681 --- pureLayout works. +-- Test message handling of Tall + +-- what happens when we send a Shrink message to Tall +prop_shrink_tall (NonNegative n) (NonZero (NonNegative delta)) (NonNegative frac) = + n == n' && delta == delta' -- these state components are unchanged + && frac' <= frac && (if frac' < frac then frac' == 0 || frac' == frac - delta + else frac == 0 ) + -- remaining fraction should shrink + where + l1 = Tall n delta frac + Just l2@(Tall n' delta' frac') = l1 `pureMessage` (SomeMessage Shrink) + -- pureMessage :: layout a -> SomeMessage -> Maybe (layout a) + + +-- what happens when we send a Shrink message to Tall +prop_expand_tall (NonNegative n) + (NonZero (NonNegative delta)) + (NonNegative n1) + (NonZero (NonNegative d1)) = + + n == n' + && delta == delta' -- these state components are unchanged + && frac' >= frac + && (if frac' > frac + then frac' == 1 || frac' == frac + delta + else frac == 1 ) + + -- remaining fraction should shrink + where + frac = min 1 (n1 % d1) + l1 = Tall n delta frac + Just l2@(Tall n' delta' frac') = l1 `pureMessage` (SomeMessage Expand) + -- pureMessage :: layout a -> SomeMessage -> Maybe (layout a) + +-- what happens when we send an IncMaster message to Tall +prop_incmaster_tall (NonNegative n) (NonZero (NonNegative delta)) (NonNegative frac) + (NonNegative k) = + delta == delta' && frac == frac' && n' == n + k + where + l1 = Tall n delta frac + Just l2@(Tall n' delta' frac') = l1 `pureMessage` (SomeMessage (IncMasterN k)) + -- pureMessage :: layout a -> SomeMessage -> Maybe (layout a) + + + + -- toMessage LT = SomeMessage Shrink + -- toMessage EQ = SomeMessage Expand + -- toMessage GT = SomeMessage (IncMasterN 1) + + +------------------------------------------------------------------------ +-- Full layout + +-- pureLayout works for Full hunk ./tests/Properties.hs 747 --- multiple windows -prop_tile_non_overlap rect windows nmaster = noOverlaps (tile pct rect nmaster windows) - where _ = rect :: Rectangle + +------------------------------------------------------------------------ hunk ./tests/Properties.hs 750 -pct = 3 % 100 hunk ./tests/Properties.hs 771 - (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-25s: " s >> a n) tests + (results, passed) <- liftM unzip $ mapM (\(s,a) -> printf "%-40s: " s >> a n) tests hunk ./tests/Properties.hs 895 + + ,("send shrink tall", mytest prop_shrink_tall) + ,("send expand tall", mytest prop_expand_tall) + ,("send incmaster tall", mytest prop_incmaster_tall) + hunk ./XMonad/Layout.hs 49 -data IncMasterN = IncMasterN Int deriving Typeable +data IncMasterN = IncMasterN !Int deriving Typeable hunk ./XMonad/Layout.hs 60 -data Tall a = Tall Int Rational Rational deriving (Show, Read) +data Tall a = Tall !Int !Rational !Rational deriving (Show, Read) hunk ./XMonad/Layout.hs 160 - runLayout (W.Workspace i (SLeft r l) ms) = fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) - runLayout (W.Workspace i (SRight l r) ms) = fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) + runLayout (W.Workspace i (SLeft r l) ms) = + fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) + runLayout (W.Workspace i (SRight l r) ms) = + fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) hunk ./tests/Properties.hs 747 +-- what happens when we send an IncMaster message to Full --- Nothing +prop_sendmsg_full (NonNegative k) = + isNothing (Full `pureMessage` (SomeMessage (IncMasterN k))) + +prop_desc_full = description Full == show Full hunk ./tests/Properties.hs 895 - -- renaming + -- tall layout hunk ./tests/Properties.hs 900 - hunk ./tests/Properties.hs 904 + -- full layout + hunk ./tests/Properties.hs 907 + ,("send message full", mytest prop_sendmsg_full) + ,("describe full", mytest prop_desc_full) hunk ./tests/Properties.hs 669 +-- splitting horizontally yields sensible results +prop_split_hoziontal (NonNegative n) x = +{- + trace (show (rect_x x + ,rect_width x + ,rect_x x + fromIntegral (rect_width x) + ,map rect_x xs)) + $ +-} + + sum (map rect_width xs) == rect_width x + && + all (== rect_height x) (map rect_height xs) + && + (map rect_x xs) == (sort $ map rect_x xs) + + where + xs = splitHorizontally n x + +-- splitting horizontally yields sensible results +prop_splitVertically (r :: Rational) x = + + rect_x x == rect_x a && rect_x x == rect_x b + && + rect_width x == rect_width a && rect_width x == rect_width b + +{- + trace (show (rect_x x + ,rect_width x + ,rect_x x + fromIntegral (rect_width x) + ,map rect_x xs)) + $ +-} + + where + (a,b) = splitVerticallyBy r x + + hunk ./tests/Properties.hs 793 +prop_desc_mirror n r1 r2 = description (Mirror $! t) == "Mirror Tall" + where t = Tall n r1 r2 + +------------------------------------------------------------------------ hunk ./tests/Properties.hs 941 + ,("split hozizontally", mytest prop_split_hoziontal) + ,("split verticalBy", mytest prop_splitVertically) + hunk ./tests/Properties.hs 955 + ,("describe mirror", mytest prop_desc_mirror) hunk ./tests/Properties.hs 7 +import XMonad.Operations ( applyResizeIncHint ) hunk ./tests/Properties.hs 813 +------------------------------------------------------------------------ +-- Aspect ratios + +prop_resize_inc (NonZero (NonNegative inc_w),NonZero (NonNegative inc_h)) b@(w,h) = + w' `mod` inc_w == 0 && h' `mod` inc_h == 0 + where (w',h') = applyResizeIncHint a b + a = (inc_w,inc_h) + +prop_resize_inc_extra ((NonNegative inc_w)) b@(w,h) = + (w,h) == (w',h') + where (w',h') = applyResizeIncHint a b + a = (-inc_w,0::Dimension)-- inc_h) + hunk ./tests/Properties.hs 971 + -- resize hints + ,("window hints: inc", mytest prop_resize_inc) + ,("window hints: inc all", mytest prop_resize_inc_extra) + hunk ./tests/Properties.hs 7 -import XMonad.Operations ( applyResizeIncHint ) +import XMonad.Operations ( applyResizeIncHint, applyMaxSizeHint ) hunk ./tests/Properties.hs 826 +prop_resize_max (NonZero (NonNegative inc_w),NonZero (NonNegative inc_h)) b@(w,h) = + w' <= inc_w && h' <= inc_h + where (w',h') = applyMaxSizeHint a b + a = (inc_w,inc_h) + +prop_resize_max_extra ((NonNegative inc_w)) b@(w,h) = + (w,h) == (w',h') + where (w',h') = applyMaxSizeHint a b + a = (-inc_w,0::Dimension)-- inc_h) + hunk ./tests/Properties.hs 984 + ,("window hints: max", mytest prop_resize_max) + ,("window hints: max all ", mytest prop_resize_max_extra) hunk ./XMonad/Config.hs 197 + , ((modMask .|. shiftMask, xK_Tab ), windows W.focusUp ) -- %! Move focus to the previous window hunk ./Main.hs 40 + ["--help"] -> usage hunk ./Main.hs 49 +usage :: IO () +usage = do + self <- getProgName + putStr . unlines $ + concat ["Usage: ", self, " [OPTION]"] : + "Options:" : + " --help Print this message" : + " --version Print the version number" : + " --recompile Recompile your ~/.xmonad/xmonad.hs if it's been changed" : + " --recompile-force Recompile your ~/.xmonad/xmonad.hs" : +#ifdef TESTING + " --run-tests Run the test suite" : +#endif + " --resume STATE Internal flag, do not use" : + [] + hunk ./Main.hs 41 - ["--recompile"] -> recompile False >> return () - ["--recompile-force"] -> recompile True >> return () + ["--recompile"] -> recompile True >> return () hunk ./Main.hs 56 - " --recompile Recompile your ~/.xmonad/xmonad.hs if it's been changed" : - " --recompile-force Recompile your ~/.xmonad/xmonad.hs" : + " --recompile Recompile your ~/.xmonad/xmonad.hs" : hunk ./man/xmonad.1.in 25 -Recompiles your configuration in ~/.xmonad/xmonad.hs if it is newer than your already existing ~/.xmonad/xmonad executable. -.TP -\fB--recompile-force -Unconditionally recompiles your configuration in ~/.xmonad/xmonad.hs. +Recompiles your configuration in ~/.xmonad/xmonad.hs hunk ./XMonad/Core.hs 28 - withDisplay, withWindowSet, isRoot, runOnWorkspaces, broadcastMessage, - getAtom, spawn, restart, getXMonadDir, recompile, trace, whenJust, whenX, + withDisplay, withWindowSet, isRoot, runOnWorkspaces, + getAtom, spawn, getXMonadDir, recompile, trace, whenJust, whenX, hunk ./XMonad/Core.hs 356 --- | Send a message to all visible layouts, without necessarily refreshing. --- This is how we implement the hooks, such as UnDoLayout. -broadcastMessage :: Message a => a -> X () -broadcastMessage a = runOnWorkspaces $ \w -> do - ml' <- handleMessage (layout w) (SomeMessage a) `catchX` return Nothing - return $ w { layout = maybe (layout w) id ml' } - hunk ./XMonad/Core.hs 366 --- | @restart name resume@. Attempt to restart xmonad by executing the program --- @name@. If @resume@ is 'True', restart with the current window state. --- When executing another window manager, @resume@ should be 'False'. --- -restart :: String -> Bool -> X () -restart prog resume = do - broadcastMessage ReleaseResources - io . flush =<< asks display - args <- if resume then gets (("--resume":) . return . showWs . windowset) else return [] - catchIO (executeFile prog True args Nothing) - where showWs = show . mapLayout show - hunk ./XMonad/Operations.hs 39 +import System.Posix.Process (executeFile) hunk ./XMonad/Operations.hs 125 - gottenhidden = filter (`elem` tags_oldvisible) $ map W.tag $ W.hidden ws - sendMessageToWorkspaces Hide gottenhidden + gottenhidden = filter (flip elem tags_oldvisible . W.tag) $ W.hidden ws + mapM_ (sendMessageWithNoRefresh Hide) gottenhidden hunk ./XMonad/Operations.hs 148 - whenJust ml' $ \l' -> runOnWorkspaces (\ww -> if W.tag ww == n - then return $ ww { W.layout = l'} - else return ww) + updateLayout n ml' hunk ./XMonad/Operations.hs 340 --- | Send a message to a list of workspaces' layouts, without necessarily refreshing. -sendMessageToWorkspaces :: Message a => a -> [WorkspaceId] -> X () -sendMessageToWorkspaces a l = runOnWorkspaces $ \w -> - if W.tag w `elem` l - then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - return $ w { W.layout = maybe (W.layout w) id ml' } - else return w +-- | Send a message to all layouts, without refreshing. +broadcastMessage :: Message a => a -> X () +broadcastMessage a = withWindowSet $ \ws -> do + let c = W.workspace . W.current $ ws + v = map W.workspace . W.visible $ ws + h = W.hidden ws + mapM_ (sendMessageWithNoRefresh a) (c : v ++ h) + +-- | Send a message to a layout, without refreshing. +sendMessageWithNoRefresh :: Message a => a -> W.Workspace WorkspaceId (Layout Window) Window -> X () +sendMessageWithNoRefresh a w = + handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>= + updateLayout (W.tag w) + +-- | Update the layout field of a workspace +updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X () +updateLayout i ml = whenJust ml $ \l -> + runOnWorkspaces $ \ww -> if W.tag ww == i + then return $ ww { W.layout = l} + else return ww hunk ./XMonad/Operations.hs 402 +-- | @restart name resume@. Attempt to restart xmonad by executing the program +-- @name@. If @resume@ is 'True', restart with the current window state. +-- When executing another window manager, @resume@ should be 'False'. +restart :: String -> Bool -> X () +restart prog resume = do + broadcastMessage ReleaseResources + io . flush =<< asks display + args <- if resume then gets (("--resume":) . return . showWs . windowset) else return [] + catchIO (executeFile prog True args Nothing) + where showWs = show . W.mapLayout show + hunk ./XMonad/Operations.hs 146 - (rs, ml') <- runLayout wsp { W.stack = tiled } viewrect`catchX` runLayout wsp { W.layout = Layout Full, W.stack = tiled } viewrect + (rs, ml') <- runLayout wsp { W.stack = tiled } viewrect `catchX` + runLayout wsp { W.stack = tiled, W.layout = Layout Full } viewrect hunk ./XMonad/Operations.hs 344 - let c = W.workspace . W.current $ ws - v = map W.workspace . W.visible $ ws - h = W.hidden ws - mapM_ (sendMessageWithNoRefresh a) (c : v ++ h) + let c = W.workspace . W.current $ ws + v = map W.workspace . W.visible $ ws + h = W.hidden ws + mapM_ (sendMessageWithNoRefresh a) (c : v ++ h) hunk ./XMonad/Operations.hs 352 - handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>= - updateLayout (W.tag w) + handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>= + updateLayout (W.tag w) hunk ./XMonad/Operations.hs 358 - runOnWorkspaces $ \ww -> if W.tag ww == i - then return $ ww { W.layout = l} - else return ww + runOnWorkspaces $ \ww -> return $ if W.tag ww == i then ww { W.layout = l} else ww hunk ./XMonad/Operations.hs 401 +------------------------------------------------------------------------ + hunk ./XMonad/Core.hs 406 + -- nb, the ordering of printing, then forking, is crucial due to + -- lazy evaluation + hPutStrLn stderr msg hunk ./XMonad/Main.hs 122 - startupHook initxmc + userCode $ startupHook initxmc hunk ./XMonad/ManageHook.hs 23 +import Graphics.X11.Xlib (Display,Window) hunk ./XMonad/ManageHook.hs 69 +-- | A query that can return an arbitrary X property of type String, +-- identified by name. +property :: String -> Query String +property p = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ getProperty d w p) + +getProperty :: Display -> Window -> String -> X (Maybe String) +getProperty d w p = do + a <- getAtom p + md <- io $ getWindowProperty8 d a w + return $ fmap (map (toEnum . fromIntegral)) md + hunk ./XMonad/ManageHook.hs 71 -property :: String -> Query String -property p = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ getProperty d w p) +stringProperty :: String -> Query String +stringProperty p = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ getStringProperty d w p) hunk ./XMonad/ManageHook.hs 74 -getProperty :: Display -> Window -> String -> X (Maybe String) -getProperty d w p = do +getStringProperty :: Display -> Window -> String -> X (Maybe String) +getStringProperty d w p = do hunk ./Main.hs 60 - " --resume STATE Internal flag, do not use" : hunk ./xmonad.cabal 2 -version: 0.6 +version: 0.7 hunk ./README 136 - 0.6 release: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmonad-contrib-0.6 + latest release: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmonad-contrib hunk ./README 138 - darcs version: darcs get http://code.haskell.org/XMonadContrib + darcs version: darcs get http://code.haskell.org/XMonadContrib hunk ./xmonad.cabal 75 - ghc-options: -Werror -fhpc + ghc-options: -Werror hunk ./XMonad/Config.hs 29 - ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor - ,focusFollowsMouse) + ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse) hunk ./XMonad/Config.hs 32 - ,defaultGaps,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor - ,focusFollowsMouse) + ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse) hunk ./XMonad/Config.hs 90 --- | Default offset of drawable screen boundaries from each physical --- screen. Anything non-zero here will leave a gap of that many pixels --- on the given edge, on the that screen. A useful gap at top of screen --- for a menu bar (e.g. 15) --- --- An example, to set a top gap on monitor 1, and a gap on the bottom of --- monitor 2, you'd use a list of geometries like so: --- --- > defaultGaps = [(18,0,0,0),(0,18,0,0)] -- 2 gaps on 2 monitors --- --- Fields are: top, bottom, left, right. --- -defaultGaps :: [(Int,Int,Int,Int)] -defaultGaps = [(0,0,0,0)] -- 15 for default dzen font - hunk ./XMonad/Config.hs 202 - , ((modMask , xK_b ), modifyGap (\i n -> let x = (XMonad.defaultGaps conf ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap + --, ((modMask , xK_b ), modifyGap (\i n -> let x = (XMonad.defaultGaps conf ++ repeat (0,0,0,0)) !! i in if n == x then (0,0,0,0) else x)) -- %! Toggle the status bar gap hunk ./XMonad/Config.hs 238 - , XMonad.defaultGaps = defaultGaps hunk ./XMonad/Core.hs 82 - , defaultGaps :: ![(Int,Int,Int,Int)] -- ^ The list of gaps, per screen hunk ./XMonad/Core.hs 104 --- | The 'Rectangle' with screen dimensions and the list of gaps -data ScreenDetail = SD { screenRect :: !Rectangle - , statusGap :: !(Int,Int,Int,Int) -- ^ gaps on the sides of the screen that shouldn't be tiled, usually for status bars - } deriving (Eq,Show, Read) +-- | The 'Rectangle' with screen dimensions +data ScreenDetail = SD { screenRect :: !Rectangle } deriving (Eq,Show, Read) hunk ./XMonad/Main.hs 67 - initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps + initialWinset = new layout (workspaces xmc) $ map SD xinesc hunk ./XMonad/Main.hs 79 - gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0) - hunk ./XMonad/Operations.hs 80 --- | Modify the size of the status gap at the top of the current screen --- Taking a function giving the current screen, and current geometry. -modifyGap :: (Int -> (Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X () -modifyGap f = do - windows $ \ws@(W.StackSet { W.current = c@(W.Screen { W.screenDetail = sd }) }) -> - let n = fromIntegral . W.screen $ c - g = f n . statusGap $ sd - in ws { W.current = c { W.screenDetail = sd { statusGap = g } } } - hunk ./XMonad/Operations.hs 130 - (SD (Rectangle sx sy sw sh) - (gt,gb,gl,gr)) = W.screenDetail w - viewrect = Rectangle (sx + fromIntegral gl) (sy + fromIntegral gt) - (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb)) + viewrect@(Rectangle sx sy sw sh) = screenRect $ W.screenDetail w hunk ./XMonad/Operations.hs 267 - (a:as) = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs - sgs = map (statusGap . W.screenDetail) (v:vs) - gs = take (length xinesc) (sgs ++ repeat (0,0,0,0)) + (a:as) = zipWith3 W.Screen xs [0..] $ map SD xinesc hunk ./man/xmonad.hs 63 --- Default offset of drawable screen boundaries from each physical --- screen. Anything non-zero here will leave a gap of that many pixels --- on the given edge, on the that screen. A useful gap at top of screen --- for a menu bar (e.g. 15) --- --- An example, to set a top gap on monitor 1, and a gap on the bottom of --- monitor 2, you'd use a list of geometries like so: --- --- > defaultGaps = [(18,0,0,0),(0,18,0,0)] -- 2 gaps on 2 monitors --- --- Fields are: top, bottom, left, right. --- -myDefaultGaps = [(0,0,0,0)] - hunk ./man/xmonad.hs 126 - , ((modMask , xK_b ), - modifyGap (\i n -> let x = (XMonad.defaultGaps conf ++ repeat (0,0,0,0)) !! i - in if n == x then (0,0,0,0) else x)) + -- TODO, update this binding with avoidStruts , ((modMask , xK_b ), hunk ./man/xmonad.hs 267 - defaultGaps = myDefaultGaps, hunk ./XMonad/Layout.hs 19 - ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..), - Full(..), Tall(..), Mirror(..), mirrorRect, splitVertically, + Full(..), Tall(..), Mirror(..), + Resize(..), IncMasterN(..), Choose, (|||), ChangeLayout(..), + mirrorRect, splitVertically, hunk ./XMonad/Layout.hs 37 --- | Builtin basic layout algorithms: --- --- > fullscreen mode --- > tall mode --- --- The latter algorithms support the following operations: --- --- > Shrink --- > Expand --- + +-- | Change the size of the master pane. hunk ./XMonad/Layout.hs 41 --- | You can also increase the number of clients in the master pane +-- | Increase the number of clients in the master pane. hunk ./XMonad/Layout.hs 47 --- | Simple fullscreen mode, just render all windows fullscreen. +-- | Simple fullscreen mode. Renders the focused window fullscreen. hunk ./XMonad/Layout.hs 52 --- | The builtin tiling mode of xmonad, and its operations. +-- | The builtin tiling mode of xmonad. Supports 'Shrink', 'Expand' and +-- 'IncMasterN'. hunk ./XMonad/Layout.hs 73 --- | tile. Compute the positions for windows using the default 2 pane tiling algorithm. --- --- The screen is divided (currently) into two panes. all clients are --- then partioned between these two panes. one pane, the `master', by --- convention has the least number of windows in it (by default, 1). --- the variable `nmaster' controls how many windows are rendered in the --- master pane. +-- | Compute the positions for windows using the default two-pane tiling +-- algorithm. hunk ./XMonad/Layout.hs 76 --- `delta' specifies the ratio of the screen to resize by. --- --- 'frac' specifies what proportion of the screen to devote to the --- master area. --- -tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle] +-- The screen is divided into two panes. All clients are +-- then partioned between these two panes. One pane, the master, by +-- convention has the least number of windows in it. +tile + :: Rational -- ^ @frac@, what proportion of the screen to devote to the master area + -> Rectangle -- ^ @r@, the rectangle representing the screen + -> Int -- ^ @nmaster@, the number of windows in the master pane + -> Int -- ^ @n@, the total number of windows to tile + -> [Rectangle] hunk ./XMonad/Layout.hs 113 --- | Mirror a layout, compute its 90 degree rotated form. hunk ./XMonad/Layout.hs 123 --- | Mirror a rectangle +-- | Mirror a rectangle. hunk ./XMonad/Layout.hs 131 --- | A layout that allows users to switch between various layout options. - hunk ./XMonad/Layout.hs 141 +-- | A layout that allows users to switch between various layout options. hunk ./XMonad/Operations.hs 482 - applySizeHints sh (ex - fromIntegral (wa_x wa), - ey - fromIntegral (wa_y wa))) + applySizeHintsContents sh (ex - fromIntegral (wa_x wa), + ey - fromIntegral (wa_y wa))) hunk ./XMonad/Operations.hs 491 +-- | Given a window, build an adjuster function that will reduce the given +-- dimensions according to the window's border width and size hints. +mkAdjust :: Window -> X (D -> D) +mkAdjust w = withDisplay $ \d -> liftIO $ do + sh <- getWMNormalHints d w + bw <- fmap (fromIntegral . wa_border_width) $ getWindowAttributes d w + return $ applySizeHints bw sh + +-- | Reduce the dimensions if needed to comply to the given SizeHints, taking +-- window borders into account. +applySizeHints :: Integral a => Dimension -> SizeHints -> (a, a) -> D +applySizeHints bw sh = + tmap (+ 2 * bw) . applySizeHintsContents sh . tmap (subtract $ 2 * fromIntegral bw) + where + tmap f (x, y) = (f x, f y) + hunk ./XMonad/Operations.hs 508 -applySizeHints :: Integral a => SizeHints -> (a,a) -> D -applySizeHints sh (w,h) = applySizeHints' sh (fromIntegral $ max 1 w, - fromIntegral $ max 1 h) +applySizeHintsContents :: Integral a => SizeHints -> (a, a) -> D +applySizeHintsContents sh (w, h) = + applySizeHints' sh (fromIntegral $ max 1 w, fromIntegral $ max 1 h) hunk ./XMonad/Operations.hs 60 - (sc, rr) <- floatLocation w + rr <- snd `fmap` floatLocation w hunk ./XMonad/Operations.hs 68 - where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws + where i = W.tag $ W.workspace $ W.current ws move ./XMonad/Main.hs ./XMonad/Main.hsc hunk ./XMonad/Main.hsc 1 -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, ForeignFunctionInterface #-} hunk ./XMonad/Main.hsc 26 +import Foreign.C +import Foreign.Ptr + hunk ./XMonad/Main.hsc 43 +#include + +foreign import ccall unsafe "locale.h setlocale" c_setlocale :: CInt -> Ptr CChar -> IO (Ptr CChar) + hunk ./XMonad/Main.hsc 52 + -- setup locale information from environment + withCString "" $ \p -> do + c_setlocale (#const LC_ALL) p hunk ./XMonad/ManageHook.hs 21 +import Prelude hiding (catch) hunk ./XMonad/ManageHook.hs 24 -import Graphics.X11.Xlib (Display,Window) +import Graphics.X11.Xlib (Display, Window, internAtom, wM_NAME) +import Control.Exception (bracket, catch) hunk ./XMonad/ManageHook.hs 32 +-- | Lift an 'X' action to a 'Query'. hunk ./XMonad/ManageHook.hs 40 --- | Compose two 'ManageHook's +-- | Compose two 'ManageHook's. hunk ./XMonad/ManageHook.hs 44 --- | Compose the list of 'ManageHook's +-- | Compose the list of 'ManageHook's. hunk ./XMonad/ManageHook.hs 48 --- | 'p --> x'. If 'p' returns 'True', execute the 'ManageHook'. +-- | @p --> x@. If @p@ returns 'True', execute the 'ManageHook'. hunk ./XMonad/ManageHook.hs 52 --- | 'q =? x'. if the result of 'q' equals 'x', return 'True'. +-- | @q =? x@. if the result of @q@ equals @x@, return 'True'. hunk ./XMonad/ManageHook.hs 58 --- | 'p <&&> q'. '&&' lifted to a Monad. +-- | '&&' lifted to a Monad. hunk ./XMonad/ManageHook.hs 62 --- | 'p <||> q'. '||' lifted to a Monad. +-- | '||' lifted to a Monad. hunk ./XMonad/ManageHook.hs 66 --- | Queries that return the window title, resource, or class. -title, resource, className :: Query String -title = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ io $ fetchName d w) +-- | Return the window title. +title :: Query String +title = ask >>= \w -> liftX $ do + d <- asks display + let + getProp = + (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w) + `catch` \_ -> getTextProperty d w wM_NAME + extract = fmap head . wcTextPropertyToTextList d + io $ bracket getProp (xFree . tp_value) extract `catch` \_ -> return "" + +-- | Return the application name. +resource :: Query String hunk ./XMonad/ManageHook.hs 80 + +-- | Return the resource class. +className :: Query String hunk ./XMonad/ManageHook.hs 78 +appName :: Query String +appName = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w) + +-- | Backwards compatible alias for 'appName'. hunk ./XMonad/ManageHook.hs 83 -resource = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w) +resource = appName hunk ./XMonad/ManageHook.hs 87 -className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w) +className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w) hunk ./XMonad/Main.hsc 43 +------------------------------------------------------------------------ +-- Locale support + hunk ./XMonad/Main.hsc 48 -foreign import ccall unsafe "locale.h setlocale" c_setlocale :: CInt -> Ptr CChar -> IO (Ptr CChar) +foreign import ccall unsafe "locale.h setlocale" + c_setlocale :: CInt -> Ptr CChar -> IO (Ptr CChar) + +------------------------------------------------------------------------ hunk ./XMonad/Main.hsc 59 - withCString "" $ \p -> do - c_setlocale (#const LC_ALL) p + withCString "" $ c_setlocale (#const LC_ALL) hunk ./XMonad/Operations.hs 106 + newwindows = W.allWindows ws \\ W.allWindows old hunk ./XMonad/Operations.hs 159 - mapM_ hide (nub oldvisible \\ visible) + mapM_ hide (nub (oldvisible ++ newwindows) \\ visible) hunk ./XMonad/Operations.hs 157 + mapM_ reveal visible + hunk ./XMonad/Operations.hs 238 - reveal w hunk ./XMonad/Operations.hs 154 - setTopFocus hunk ./XMonad/Operations.hs 157 + setTopFocus hunk ./XMonad/Config.hs 87 -normalBorderColor = "#dddddd" -focusedBorderColor = "#ff0000" +normalBorderColor = "gray" -- "#dddddd" +focusedBorderColor = "red" -- "#ff0000" don't use hex, not <24 bit safe hunk ./XMonad/ManageHook.hs 112 +-- | Move the window to a given workspace +doShift :: WorkspaceId -> ManageHook +doShift = doF . W.shift + hunk ./XMonad/Operations.hs 110 - mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) + mapM_ setInitialProperties newwindows hunk ./XMonad/Core.hs 72 + , mouseFocused :: !Bool -- ^ was refocus caused by mouse action? hunk ./XMonad/Main.hsc 101 - , buttonActions = mouseBindings xmc xmc } + , buttonActions = mouseBindings xmc xmc + , mouseFocused = False } hunk ./XMonad/Operations.hs 168 - clearEvents enterWindowMask + isMouseFocused <- asks mouseFocused + unless isMouseFocused $ clearEvents enterWindowMask hunk ./XMonad/Operations.hs 298 - if W.member w s then when (W.peek s /= Just w) $ windows (W.focusWindow w) + if W.member w s then when (W.peek s /= Just w) $ do + local (\c -> c { mouseFocused = True }) $ do + windows (W.focusWindow w) hunk ./XMonad/Layout.hs 138 -(|||) = flip SLeft +(|||) = Choose L hunk ./XMonad/Layout.hs 142 -data Choose l r a = SLeft (r a) (l a) - | SRight (l a) (r a) deriving (Read, Show) +data Choose l r a = Choose LR (l a) (r a) deriving (Read, Show) + +data LR = L | R deriving (Read, Show, Eq) hunk ./XMonad/Layout.hs 149 --- This has lots of pseudo duplicated code, we must find a better way -instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where - runLayout (W.Workspace i (SLeft r l) ms) = - fmap (second . fmap $ SLeft r) . runLayout (W.Workspace i l ms) - runLayout (W.Workspace i (SRight l r) ms) = - fmap (second . fmap $ SRight l) . runLayout (W.Workspace i r ms) +handle :: (LayoutClass l a, Message m) => l a -> m -> X (Maybe (l a)) +handle l m = handleMessage l (SomeMessage m) hunk ./XMonad/Layout.hs 152 - description (SLeft _ l) = description l - description (SRight _ r) = description r +choose :: (LayoutClass l a, LayoutClass r a) => Choose l r a -> LR -> Maybe (l a) -> Maybe (r a) -> X (Maybe (Choose l r a)) +choose (Choose d _ _) d' Nothing Nothing | d == d' = return Nothing +choose (Choose d l r) d' ml mr = f lr + where + (l', r') = (fromMaybe l ml, fromMaybe r mr) + lr = case (d, d') of + (L, R) -> (hide l' , return r') + (R, L) -> (return l', hide r' ) + (_, _) -> (return l', return r') + f (x,y) = fmap Just $ liftM2 (Choose d') x y + hide x = fmap (fromMaybe x) $ handle x Hide + +instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where + runLayout (W.Workspace i (Choose L l r) ms) = + fmap (second . fmap $ flip (Choose L) $ r) . runLayout (W.Workspace i l ms) + runLayout (W.Workspace i (Choose R l r) ms) = + fmap (second . fmap $ Choose R l) . runLayout (W.Workspace i r ms) hunk ./XMonad/Layout.hs 170 - handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of - SLeft {} -> return Nothing - SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) - $ handleMessage r (SomeMessage Hide) + description (Choose L l _) = description l + description (Choose R _ r) = description r hunk ./XMonad/Layout.hs 174 - mlr <- handleMessage lr $ SomeMessage NextNoWrap - maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr + mlr' <- handle lr NextNoWrap + maybe (handle lr FirstLayout) (return . Just) mlr' + + handleMessage c@(Choose d l r) m | Just NextNoWrap <- fromMessage m = + case d of + L -> do + ml <- handle l NextNoWrap + case ml of + Just _ -> choose c L ml Nothing + Nothing -> choose c R Nothing =<< handle r FirstLayout + + R -> choose c R Nothing =<< handle r NextNoWrap + + handleMessage c@(Choose _ l _) m | Just FirstLayout <- fromMessage m = do + ml' <- handle l FirstLayout + choose c L ml' Nothing hunk ./XMonad/Layout.hs 191 - handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do - handleMessage l (SomeMessage Hide) - mr <- handleMessage r (SomeMessage FirstLayout) - return . Just . SRight l $ fromMaybe r mr - - handleMessage lr m | Just ReleaseResources <- fromMessage m = - liftM2 ((Just .) . cons) - (fmap (fromMaybe l) $ handleMessage l m) - (fmap (fromMaybe r) $ handleMessage r m) - where (cons, l, r) = case lr of - (SLeft r' l') -> (flip SLeft, l', r') - (SRight l' r') -> (SRight, l', r') + handleMessage c@(Choose d l r) m | Just ReleaseResources <- fromMessage m = do + ml' <- handle l ReleaseResources + mr' <- handle r ReleaseResources + choose c d ml' mr' hunk ./XMonad/Layout.hs 196 - -- The default cases for left and right: - handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m - handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m + handleMessage c@(Choose d l r) m = do + ml' <- case d of + L -> handleMessage l m + R -> return Nothing + mr' <- case d of + L -> return Nothing + R -> handleMessage r m + choose c d ml' mr' hunk ./XMonad/Layout.hs 191 - handleMessage c@(Choose d l r) m | Just ReleaseResources <- fromMessage m = do - ml' <- handle l ReleaseResources - mr' <- handle r ReleaseResources - choose c d ml' mr' + handleMessage c@(Choose d l r) m | Just ReleaseResources <- fromMessage m = + join $ liftM2 (choose c d) (handle l ReleaseResources) (handle r ReleaseResources) hunk ./XMonad/Layout.hs 188 - ml' <- handle l FirstLayout - choose c L ml' Nothing + flip (choose c L) Nothing =<< handle l FirstLayout hunk ./XMonad/Layout.hs 152 -choose :: (LayoutClass l a, LayoutClass r a) => Choose l r a -> LR -> Maybe (l a) -> Maybe (r a) -> X (Maybe (Choose l r a)) +choose :: (LayoutClass l a, LayoutClass r a) + => Choose l r a-> LR -> Maybe (l a) -> Maybe (r a) -> X (Maybe (Choose l r a)) hunk ./XMonad/Layout.hs 144 +-- | Are we on the left or right sub-layout? hunk ./XMonad/Layout.hs 150 +-- | A small wrapper around handleMessage, as it is tedious to write +-- SomeMessage repeatedly. hunk ./XMonad/Layout.hs 155 +-- | A smart constructor that takes some potential modifications, returns a +-- new structure if any fields have changed, and performs any necessary cleanup +-- on newly non-visible layouts. hunk ./XMonad/Layout.hs 115 -data Mirror l a = Mirror (l a) deriving (Show, Read) +newtype Mirror l a = Mirror (l a) deriving (Show, Read) hunk ./XMonad/StackSet.hs 34 - screens, workspaces, allWindows, + screens, workspaces, allWindows, currentTag, hunk ./XMonad/StackSet.hs 213 - | i == tag (workspace (current s)) = s -- current + | i == currentTag s = s -- current hunk ./XMonad/StackSet.hs 383 +-- | Get the tag of the currently focused workspace. +currentTag :: StackSet i l a s sd -> i +currentTag = tag . workspace . current + hunk ./XMonad/StackSet.hs 527 - curtag = tag (workspace (current s)) + curtag = currentTag s hunk ./XMonad/StackSet.hs 543 - curtag = tag (workspace (current s)) - on i f = view curtag . f . view i + on i f = view (currentTag s) . f . view i hunk ./tests/Properties.hs 381 +prop_currentTag (x :: T) = + currentTag x == tag (workspace (current x)) + hunk ./tests/Properties.hs 901 + ,("currentTag" , mytest prop_currentTag) hunk ./XMonad/Config.hs 226 - [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w)) + [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w + >> windows W.swapMaster)) hunk ./XMonad/Config.hs 231 - , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) + , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w + >> windows W.swapMaster)) hunk ./XMonad/Core.hs 12 --- Maintainer : sjanssen@cse.unl.edu +-- Maintainer : spencerjanssen@gmail.com hunk ./XMonad/Layout.hs 10 --- Maintainer : sjanssen@cse.unl.edu +-- Maintainer : spencerjanssen@gmail.com hunk ./XMonad/Main.hsc 8 --- Maintainer : sjanssen@cse.unl.edu +-- Maintainer : spencerjanssen@gmail.com hunk ./XMonad/ManageHook.hs 9 --- Maintainer : sjanssen@cse.unl.edu +-- Maintainer : spencerjanssen@gmail.com hunk ./Main.hs 65 +-- hunk ./Main.hs 67 +-- hunk ./Main.hs 69 +-- hunk ./Main.hs 71 +-- hunk ./Main.hs 73 +-- hunk ./Main.hs 75 +-- hunk ./XMonad/Config.hs 112 +-- hunk ./XMonad/Config.hs 114 +-- hunk ./XMonad/Core.hs 370 +-- hunk ./XMonad/Core.hs 372 +-- hunk ./XMonad/Core.hs 374 +-- hunk ./XMonad/StackSet.hs 462 +-- hunk ./XMonad/StackSet.hs 464 +-- hunk ./XMonad/StackSet.hs 466 +-- hunk ./XMonad/StackSet.hs 472 +-- hunk ./XMonad/Core.hs 16 --- The X monad, a state monad transformer over IO, for the window +-- The 'X' monad, a state monad transformer over 'IO', for the window hunk ./XMonad/Core.hs 110 --- | The X monad, ReaderT and StateT transformers over IO +-- | The X monad, 'ReaderT' and 'StateT' transformers over 'IO' hunk ./XMonad/Core.hs 116 --- instantiated on XConf and XState automatically. +-- instantiated on 'XConf' and 'XState' automatically. hunk ./XMonad/Core.hs 144 --- | Run the X monad, given a chunk of X monad code, and an initial state +-- | Run the 'X' monad, given a chunk of 'X' monad code, and an initial state hunk ./XMonad/Core.hs 149 --- | Run in the X monad, and in case of exception, and catch it and log it +-- | Run in the 'X' monad, and in case of exception, and catch it and log it hunk ./XMonad/Core.hs 162 --- catchX should be used at all callsites of user customized code. +-- 'catchX' should be used at all callsites of user customized code. hunk ./XMonad/Core.hs 331 --- Lift an IO action into the X monad +-- Lift an 'IO' action into the 'X' monad hunk ./XMonad/Core.hs 335 --- | Lift an IO action into the X monad. If the action results in an IO +-- | Lift an 'IO' action into the 'X' monad. If the action results in an 'IO' hunk ./XMonad/Core.hs 344 --- | Double fork and execute an IO action (usually one of the exec family of +-- | Double fork and execute an 'IO' action (usually one of the exec family of hunk ./XMonad/Core.hs 354 --- | This is basically a map function, running a function in the X monad on +-- | This is basically a map function, running a function in the 'X' monad on hunk ./XMonad/Core.hs 371 --- * force is True +-- * force is 'True' hunk ./XMonad/Core.hs 383 --- False is returned if there are compilation errors. +-- 'False' is returned if there are compilation errors. hunk ./XMonad/Core.hs 419 --- | Conditionally run an action, using a X event to decide +-- | Conditionally run an action, using a 'X' event to decide hunk ./XMonad/Core.hs 423 --- | A 'trace' for the X monad. Logs a string to stderr. The result may +-- | A 'trace' for the 'X' monad. Logs a string to stderr. The result may hunk ./XMonad/ManageHook.hs 58 --- | '&&' lifted to a Monad. +-- | '&&' lifted to a 'Monad'. hunk ./XMonad/ManageHook.hs 62 --- | '||' lifted to a Monad. +-- | '||' lifted to a 'Monad'. hunk ./XMonad/ManageHook.hs 89 --- | A query that can return an arbitrary X property of type String, +-- | A query that can return an arbitrary X property of type 'String', hunk ./XMonad/Operations.hs 213 --- the StackSet. Also, set focus to the focused window. +-- the 'StackSet'. Also, set focus to the focused window. hunk ./XMonad/Operations.hs 242 --- | Returns True if the first rectangle is contained within, but not equal +-- | Returns 'True' if the first rectangle is contained within, but not equal hunk ./XMonad/Operations.hs 321 --- | Throw a message to the current LayoutClass possibly modifying how we +-- | Throw a message to the current 'LayoutClass' possibly modifying how we hunk ./XMonad/Operations.hs 361 --- | Return workspace visible on screen 'sc', or Nothing. +-- | Return workspace visible on screen 'sc', or 'Nothing'. hunk ./XMonad/Operations.hs 365 --- | Apply an X operation to the currently focused window, if there is one. +-- | Apply an 'X' operation to the currently focused window, if there is one. hunk ./XMonad/Operations.hs 369 --- | True if window is under management by us +-- | 'True' if window is under management by us hunk ./XMonad/Operations.hs 386 --- | Get the Pixel value for a named color +-- | Get the 'Pixel' value for a named color hunk ./XMonad/StackSet.hs 114 --- this, StackSet keeps separate lists of visible but non-focused +-- this, 'StackSet' keeps separate lists of visible but non-focused hunk ./XMonad/StackSet.hs 205 --- If the index is out of range, return the original StackSet. +-- If the index is out of range, return the original 'StackSet'. hunk ./XMonad/StackSet.hs 255 --- Nothing if screen is out of bounds. +-- 'Nothing' if screen is out of bounds. hunk ./XMonad/StackSet.hs 272 --- Apply a function, and a default value for Nothing, to modify the current stack. +-- Apply a function, and a default value for 'Nothing', to modify the current stack. hunk ./XMonad/StackSet.hs 287 --- Return Just that element, or Nothing for an empty stack. +-- Return 'Just' that element, or 'Nothing' for an empty stack. hunk ./XMonad/StackSet.hs 293 --- /O(n)/. Flatten a Stack into a list. +-- /O(n)/. Flatten a 'Stack' into a list. hunk ./XMonad/StackSet.hs 313 --- True. Order is preserved, and focus moves as described for 'delete'. +-- 'True'. Order is preserved, and focus moves as described for 'delete'. hunk ./XMonad/StackSet.hs 371 --- | Get a list of all screens in the StackSet. +-- | Get a list of all screens in the 'StackSet'. hunk ./XMonad/StackSet.hs 375 --- | Get a list of all workspaces in the StackSet. +-- | Get a list of all workspaces in the 'StackSet'. hunk ./XMonad/StackSet.hs 379 --- | Get a list of all windows in the StackSet in no particular order +-- | Get a list of all windows in the 'StackSet' in no particular order hunk ./XMonad/StackSet.hs 387 --- | Is the given tag present in the StackSet? +-- | Is the given tag present in the 'StackSet'? hunk ./XMonad/StackSet.hs 391 --- | Rename a given tag if present in the StackSet. +-- | Rename a given tag if present in the 'StackSet'. hunk ./XMonad/StackSet.hs 406 --- | Map a function on all the workspaces in the StackSet. +-- | Map a function on all the workspaces in the 'StackSet'. hunk ./XMonad/StackSet.hs 413 --- | Map a function on all the layouts in the StackSet. +-- | Map a function on all the layouts in the 'StackSet'. hunk ./XMonad/StackSet.hs 420 --- | /O(n)/. Is a window in the StackSet? +-- | /O(n)/. Is a window in the 'StackSet'? hunk ./XMonad/StackSet.hs 425 --- Return Just the workspace tag of the given window, or Nothing --- if the window is not in the StackSet. +-- Return 'Just' the workspace tag of the given window, or 'Nothing' +-- if the window is not in the 'StackSet'. hunk ./XMonad/StackSet.hs 461 --- * delete on an Nothing workspace leaves it Nothing +-- * delete on an 'Nothing' workspace leaves it Nothing hunk ./XMonad/StackSet.hs 467 --- * otherwise, you've got an empty workspace, becomes Nothing +-- * otherwise, you've got an empty workspace, becomes 'Nothing' hunk ./XMonad/StackSet.hs 479 --- information saved in the Stackset +-- information saved in the 'Stackset' hunk ./XMonad/StackSet.hs 490 --- A floating window should already be managed by the StackSet. +-- A floating window should already be managed by the 'StackSet'. hunk ./xmonad.cabal 49 - ghc-options: -funbox-strict-fields -Wall -optl-Wl,-s + ghc-options: -funbox-strict-fields -Wall hunk ./xmonad.cabal 67 - ghc-options: -funbox-strict-fields -Wall -optl-Wl,-s + ghc-options: -funbox-strict-fields -Wall hunk ./README 83 - mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl-1.0 - unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 - X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.4.1 + mtl http://hackage.haskell.org/cgi-bin/hackage-scripts/package/mtl + unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix + X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11 hunk ./README 100 -Notes for using the darcs version - - If you're building the darcs version of xmonad, be sure to also - use the darcs version of the X11 library, which is developed - concurrently with xmonad. - - darcs get http://darcs.haskell.org/X11 - - Not using X11 from darcs is the most common reason for the - darcs version of xmonad to fail to build. - ------------------------------------------------------------------------- - hunk ./xmonad.cabal 2 -version: 0.7 +version: 0.8 hunk ./README 27 - Building is quite straightforward, and requries a basic Haskell toolchain. + Building is quite straightforward, and requires a basic Haskell toolchain. hunk ./XMonad/Config.hs 229 - >> windows W.swapMaster)) + >> windows W.shiftMaster)) hunk ./XMonad/Config.hs 231 - , ((modMask, button2), (\w -> focus w >> windows W.swapMaster)) + , ((modMask, button2), (\w -> focus w >> windows W.shiftMaster)) hunk ./XMonad/Config.hs 234 - >> windows W.swapMaster)) + >> windows W.shiftMaster)) hunk ./XMonad/StackSet.hs 45 - swapUp, swapDown, swapMaster, modify, modify', float, sink, -- needed by users + swapUp, swapDown, swapMaster, shiftMaster, modify, modify', float, sink, -- needed by users hunk ./XMonad/StackSet.hs 511 +-- | /O(s)/. Set the master window to the focused window. +-- The other windows are kept in order and shifted down on the stack, as if you +-- just hit mod-shift-k a bunch of times. +-- Focus stays with the item moved. +shiftMaster :: StackSet i l a s sd -> StackSet i l a s sd +shiftMaster = modify' $ \c -> case c of + Stack _ [] _ -> c -- already master. + Stack t ls rs -> Stack t [] (reverse ls ++ rs) + hunk ./man/xmonad.hs 160 - [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w)) + [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w + >> windows W.shiftMaster)) hunk ./man/xmonad.hs 164 - , ((modMask, button2), (\w -> focus w >> windows W.swapMaster)) + , ((modMask, button2), (\w -> focus w >> windows W.shiftMaster)) hunk ./man/xmonad.hs 167 - , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w)) + , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w + >> windows W.shiftMaster)) hunk ./tests/Properties.hs 531 +------------------------------------------------------------------------ +-- shiftMaster + +-- focus/local/idempotent same as swapMaster: +prop_shift_master_focus (x :: T) = peek x == (peek $ shiftMaster x) +prop_shift_master_local (x :: T) = hidden_spaces x == hidden_spaces (shiftMaster x) +prop_shift_master_idempotent (x :: T) = shiftMaster (shiftMaster x) == shiftMaster x +-- ordering is constant modulo the focused window: +prop_shift_master_ordering (x :: T) = case peek x of + Nothing -> True + Just m -> L.delete m (index x) == L.delete m (index $ shiftMaster x) + hunk ./tests/Properties.hs 948 + ,("shiftMaster id on focus", mytest prop_shift_master_focus) + ,("shiftMaster is local", mytest prop_shift_master_local) + ,("shiftMaster is idempotent", mytest prop_shift_master_idempotent) + ,("shiftMaster preserves ordering", mytest prop_shift_master_ordering) + hunk ./XMonad/StackSet.hs 38 - focusUp, focusDown, focusMaster, focusWindow, + focusUp, focusDown, focusUp', focusDown', focusMaster, focusWindow, hunk ./XMonad/StackSet.hs 345 -focusDown = modify' (reverseStack . focusUp' . reverseStack) +focusDown = modify' focusDown' hunk ./XMonad/StackSet.hs 350 -focusUp', swapUp' :: Stack a -> Stack a +-- | Variants of 'focusUp' and 'focusDown' that work on a +-- 'Stack' rather than an entire 'StackSet'. +focusUp', focusDown' :: Stack a -> Stack a hunk ./XMonad/StackSet.hs 355 +focusDown' = reverseStack . focusUp' . reverseStack hunk ./XMonad/StackSet.hs 357 +swapUp' :: Stack a -> Stack a hunk ./xmonad.cabal 47 - build-depends: X11>=1.4.1, mtl, unix + build-depends: X11>=1.4.3, mtl, unix hunk ./CONFIG 54 -are used. +are used. hunk ./CONFIG 56 -To load succesfully, both 'xmonad' and 'ghc' must be in your $PATH +To load successfully, both 'xmonad' and 'ghc' must be in your $PATH hunk ./README 29 - package system (e.g. on debian or gentoo). If at all possible, use this + package system (e.g. on Debian or Gentoo). If at all possible, use this hunk ./README 36 - + hunk ./README 38 - system will have binaries of GHC (the Glasgow Haskell Compiler), the + system will have binaries of GHC (the Glasgow Haskell Compiler), the hunk ./README 49 - It shouldn't be necessary to compile GHC from source -- every common + It shouldn't be necessary to compile GHC from source -- every common hunk ./README 63 - + hunk ./README 87 - * Build xmonad: + * Build xmonad: hunk ./README 131 - A nicer xterm replacment, that supports resizing better: + A nicer xterm replacement, that supports resizing better: hunk ./README 138 - xmobar http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmobar + xmobar http://hackage.haskell.org/cgi-bin/hackage-scripts/package/xmobar hunk ./STYLE 5 -* Comment every top level function (particularly exported funtions), and +* Comment every top level function (particularly exported functions), and hunk ./STYLE 18 - precisely defining its behaviour. + precisely defining its behavior. hunk ./TODO 4 - - current floating layer handling is unoptimal. FocusUp should raise, + - current floating layer handling is nonoptimal. FocusUp should raise, hunk ./TODO 18 -* upload X11 and xmonad to hackage +* upload X11 and xmonad to Hackage hunk ./XMonad/Operations.hs 426 - pointWithin :: Integer -> Integer -> Rectangle -> Bool - pointWithin x y r = x >= fi (rect_x r) && - x < fi (rect_x r) + fi (rect_width r) && - y >= fi (rect_y r) && - y < fi (rect_y r) + fi (rect_height r) + +-- | 'pointWithin x y r' returns 'True' if the '(x, y)' co-ordinate is within +-- the 'Rectangle'. +pointWithin :: Position -> Position -> Rectangle -> Bool +pointWithin x y r = x >= rect_x r && + x < rect_x r + fromIntegral (rect_width r) && + y >= rect_y r && + y < rect_y r + fromIntegral (rect_height r) hunk ./XMonad/Operations.hs 415 + sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa) hunk ./XMonad/Operations.hs 417 - -- XXX horrible - let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.screens ws - sr = screenRect . W.screenDetail $ sc + let sr = screenRect . W.screenDetail $ sc hunk ./XMonad/Operations.hs 426 +-- | Given a point, determine the screen (if any) that contains it. +pointScreen :: Position -> Position + -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)) +pointScreen x y = withWindowSet $ return . find p . W.screens + where p = pointWithin x y . screenRect . W.screenDetail + hunk ./XMonad/Operations.hs 432 --- | 'pointWithin x y r' returns 'True' if the '(x, y)' co-ordinate is within --- the 'Rectangle'. +-- | @pointWithin x y r@ returns 'True' if the @(x, y)@ co-ordinate is within +-- @r@. hunk ./XMonad/Core.hs 73 + , mousePosition :: !(Maybe (Position, Position)) + -- ^ position of the mouse according to + -- the event currently being processed hunk ./XMonad/Main.hsc 102 - , mouseFocused = False } + , mouseFocused = False + , mousePosition = Nothing } hunk ./XMonad/Main.hsc 140 - forever_ $ handle =<< io (nextEvent dpy e >> getEvent e) + forever_ $ prehandle =<< io (nextEvent dpy e >> getEvent e) hunk ./XMonad/Main.hsc 143 - where forever_ a = a >> forever_ a + where + forever_ a = a >> forever_ a + + -- if the event gives us the position of the pointer, set mousePosition + prehandle e = let mouse = do guard (ev_event_type e `elem` evs) + return (fromIntegral (ev_x_root e) + ,fromIntegral (ev_y_root e)) + in local (\c -> c { mousePosition = mouse }) (handle e) + evs = [ keyPress, keyRelease, enterNotify, leaveNotify + , buttonPress, buttonRelease] hunk ./XMonad/Operations.hs 297 -focus w = withWindowSet $ \s -> do - if W.member w s then when (W.peek s /= Just w) $ do - local (\c -> c { mouseFocused = True }) $ do - windows (W.focusWindow w) - else whenX (isRoot w) $ setFocusX w +focus w = local (\c -> c { mouseFocused = True }) $ withWindowSet $ \s -> do + let stag = W.tag . W.workspace + curr = stag $ W.current s + mnew <- maybe (return Nothing) (fmap (fmap stag) . uncurry pointScreen) + =<< asks mousePosition + root <- asks theRoot + case () of + _ | W.member w s && W.peek s /= Just w -> windows (W.focusWindow w) + | Just new <- mnew, w == root && curr /= new + -> windows (W.view new) + | otherwise -> return () hunk ./XMonad/Operations.hs 320 - whenX (not <$> isRoot w) $ setButtonGrab False w + whenX (isRoot w) $ setButtonGrab False w hunk ./XMonad/Operations.hs 320 - whenX (isRoot w) $ setButtonGrab False w + whenX (not <$> isRoot w) $ setButtonGrab False w hunk ./XMonad/Core.hs 343 --- | spawn. Launch an external application +-- | spawn. Launch an external application. Specifically, it double-forks and +-- runs the 'String' you pass as a command to /bin/sh. hunk ./XMonad/Layout.hs 54 -data Tall a = Tall !Int !Rational !Rational deriving (Show, Read) +data Tall a = Tall !Int -- ^ The default number of windows in the master pane (default: 1) + !Rational -- ^ Default proportion of screen occupied by master pane (default: 1/2) + !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100) + deriving (Show, Read) hunk ./man/xmonad.1.in 39 +.PP +You can find many extensions to the core feature set in the xmonad-contrib package, available through your package manager or from http://xmonad.org/. hunk ./XMonad/Operations.hs 80 --- | Kill the currently focused client. If we do kill it, we'll get a +-- | Kill the specified window. If we do kill it, we'll get a hunk ./XMonad/Operations.hs 86 -kill :: X () -kill = withDisplay $ \d -> withFocused $ \w -> do +killWindow :: Window -> X () +killWindow w = withDisplay $ \d -> do hunk ./XMonad/Operations.hs 98 +-- | Kill the currently focused client. +kill :: X () +kill = withFocused killWindow + hunk ./xmonad.cabal 44 - build-depends: base >= 3, containers, directory, process + build-depends: base < 4 && >=3, containers, directory, process hunk ./XMonad/Main.hsc 68 + + -- If another WM is running, a BadAccess error will be returned. The + -- default error handler will write the exception to stderr and exit with + -- an error. + selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask + .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask + sync dpy False -- sync to ensure all outstanding errors are delivered + + -- turn off the default handler in favor of one that ignores all errors + -- (ugly, I know) + xSetErrorHandler -- in C, I'm too lazy to write the binding: dons + hunk ./XMonad/Main.hsc 122 - xSetErrorHandler -- in C, I'm too lazy to write the binding: dons - - -- setup initial X environment - sync dpy False - selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask - .|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask - hunk ./XMonad/Main.hsc 74 + .|. buttonPressMask hunk ./XMonad/Main.hsc 233 - ba <- asks buttonActions - if isr then userCode $ whenJust (M.lookup (m, b) ba) ($ ev_subwindow e) - else focus w + mact <- asks (M.lookup (m, b) . buttonActions) + case mact of + (Just act) | isr -> act $ ev_subwindow e + _ -> focus w hunk ./XMonad/Operations.hs 135 - viewrect@(Rectangle sx sy sw sh) = screenRect $ W.screenDetail w + viewrect = screenRect $ W.screenDetail w hunk ./XMonad/Operations.hs 147 - \(W.RationalRect rx ry rw rh) -> do - tileWindow fw $ Rectangle - (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry)) - (floor (toRational sw*rw)) (floor (toRational sh*rh)) + \r -> tileWindow fw $ scaleRationalRect viewrect r hunk ./XMonad/Operations.hs 172 +-- | Produce the actual rectangle from a screen and a ratio on that screen. +scaleRationalRect :: Rectangle -> W.RationalRect -> Rectangle +scaleRationalRect (Rectangle sx sy sw sh) (W.RationalRect rx ry rw rh) + = Rectangle (sx + scale sw rx) (sy + scale sh ry) (scale sw rw) (scale sh rh) + where scale s r = floor (toRational s * r) + hunk ./XMonad/Operations.hs 127 - visible <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do + rects <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do hunk ./XMonad/Operations.hs 131 - flt = filter (flip M.member (W.floating ws)) (W.index this) hunk ./XMonad/Operations.hs 140 - mapM_ (uncurry tileWindow) rs hunk ./XMonad/Operations.hs 142 - -- now the floating windows: - -- move/resize the floating windows, if there are any - forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ - \r -> tileWindow fw $ scaleRationalRect viewrect r + let m = W.floating ws + flt = [(fw, scaleRationalRect viewrect r) + | fw <- filter (flip M.member m) (W.index this) + , Just r <- [M.lookup fw m]] + vs = flt ++ rs hunk ./XMonad/Operations.hs 148 - let vs = flt ++ map fst rs - io $ restackWindows d vs + io $ restackWindows d (map fst vs) hunk ./XMonad/Operations.hs 152 + let visible = map fst rects + + mapM_ (uncurry tileWindow) rects + hunk ./XMonad/Main.hsc 243 - && ev_detail e /= notifyInferior hunk ./XMonad/Operations.hs 157 - asks (logHook . config) >>= userCode - - mapM_ reveal visible - setTopFocus hunk ./XMonad/Operations.hs 162 + mapM_ reveal visible + setTopFocus + hunk ./XMonad/Operations.hs 172 + asks (logHook . config) >>= userCode hunk ./XMonad/Core.hs 27 - runX, catchX, userCode, io, catchIO, doubleFork, + runX, catchX, userCode, userCodeDef, io, catchIO, doubleFork, hunk ./XMonad/Core.hs 50 +import Data.Maybe (fromMaybe) hunk ./XMonad/Core.hs 167 -userCode :: X () -> X () -userCode a = catchX (a >> return ()) (return ()) +userCode :: X a -> X (Maybe a) +userCode a = catchX (Just `liftM` a) (return Nothing) + +-- | Same as userCode but with a default argument to return instead of using +-- Maybe, provided for convenience. +userCodeDef :: a -> X a -> X a +userCodeDef def a = fromMaybe def `liftM` userCode a hunk ./XMonad/Main.hsc 179 - userCode $ whenJust (M.lookup (mClean, s) ks) id + userCodeDef () $ whenJust (M.lookup (mClean, s) ks) id hunk ./XMonad/Main.hsc 282 - | t == propertyNotify && a == wM_NAME = userCode =<< asks (logHook . config) + | t == propertyNotify && a == wM_NAME = userCodeDef () =<< asks (logHook . config) hunk ./XMonad/Operations.hs 26 -import Data.Monoid (appEndo) +import Data.Monoid (Endo(..)) hunk ./XMonad/Operations.hs 71 - g <- fmap appEndo (runQuery mh w) `catchX` return id + g <- fmap appEndo $ userCodeDef (Endo id) (runQuery mh w) hunk ./XMonad/Operations.hs 172 - asks (logHook . config) >>= userCode + asks (logHook . config) >>= userCodeDef () hunk ./Main.hs 62 --- | Build "~/.xmonad/xmonad.hs" with ghc, then execute it. If there are no +-- | Build "~\/.xmonad\/xmonad.hs" with ghc, then execute it. If there are no hunk ./Main.hs 68 --- * ~/.xmonad/xmonad.hs missing +-- * "~\/.xmonad\/xmonad.hs" missing hunk ./Main.hs 76 --- * Missing xmonad/XMonadContrib modules due to ghc upgrade +-- * Missing XMonad\/XMonadContrib modules due to ghc upgrade hunk ./Main.hs 35 + installSignalHandlers -- important to ignore SIGCHLD to avoid zombies hunk ./XMonad/Core.hs 27 - runX, catchX, userCode, userCodeDef, io, catchIO, doubleFork, + runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, hunk ./XMonad/Core.hs 29 - getAtom, spawn, getXMonadDir, recompile, trace, whenJust, whenX, + getAtom, spawn, spawnPID, getXMonadDir, recompile, trace, whenJust, whenX, hunk ./XMonad/Core.hs 36 -import Control.Exception (catch, bracket, throw, Exception(ExitException)) +import Control.Exception (catch, try, bracket, throw, Exception(ExitException)) hunk ./XMonad/Core.hs 42 -import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession) +import System.Posix.Process (executeFile, forkProcess, getAnyProcessStatus) +import System.Posix.Signals +import System.Posix.Types (ProcessID) hunk ./XMonad/Core.hs 51 +import Data.Maybe (isJust) hunk ./XMonad/Core.hs 355 -spawn x = doubleFork $ executeFile "/bin/sh" False ["-c", x] Nothing +spawn x = spawnPID x >> return () hunk ./XMonad/Core.hs 357 --- | Double fork and execute an 'IO' action (usually one of the exec family of --- functions) -doubleFork :: MonadIO m => IO () -> m () -doubleFork m = io $ do - pid <- forkProcess $ do - forkProcess (createSession >> m) - exitWith ExitSuccess - getProcessStatus True False pid - return () +spawnPID :: MonadIO m => String -> m ProcessID +spawnPID x = io $ forkProcess $ executeFile "/bin/sh" False ["-c", x] Nothing hunk ./XMonad/Core.hs 403 + -- temporarily disable SIGCHLD ignoring: + installHandler sigCHLD Default Nothing hunk ./XMonad/Core.hs 409 + -- re-enable SIGCHLD: + installSignalHandlers + hunk ./XMonad/Core.hs 421 - doubleFork $ executeFile "xmessage" True ["-default", "okay", msg] Nothing + forkProcess $ executeFile "xmessage" True ["-default", "okay", msg] Nothing + return () hunk ./XMonad/Core.hs 439 + +-- | Ignore SIGPIPE to avoid termination when a pipe is full, and SIGCHLD to +-- avoid zombie processes, and clean up any extant zombie processes. +installSignalHandlers :: MonadIO m => m () +installSignalHandlers = io $ do + installHandler openEndedPipe Ignore Nothing + installHandler sigCHLD Ignore Nothing + try $ fix $ \more -> do + x <- getAnyProcessStatus False False + when (isJust x) more + return () hunk ./XMonad/Main.hsc 30 -import System.Posix.Signals hunk ./XMonad/Main.hsc 59 - -- ignore SIGPIPE - installHandler openEndedPipe Ignore Nothing + -- ignore SIGPIPE and SIGCHLD + installSignalHandlers hunk ./xmonad.cabal 2 -version: 0.8 +version: 0.8.1 hunk ./Main.hs 43 + ["--restart"] -> sendRestart >> return () hunk ./Main.hs 59 + " --restart Request a running xmonad process to restart" : hunk ./Main.hs 88 + +sendRestart :: IO () +sendRestart = do + dpy <- openDisplay "" + rw <- rootWindow dpy $ defaultScreen dpy + xmonad_restart <- internAtom dpy "XMONAD_RESTART" False + allocaXEvent $ \e -> do + setEventType e clientMessage + setClientMessageEvent e rw xmonad_restart 32 0 currentTime + sendEvent dpy rw False structureNotifyMask e + sync dpy False hunk ./XMonad/Main.hsc 283 +handle e@ClientMessageEvent { ev_message_type = mt } = do + a <- getAtom "XMONAD_RESTART" + if (mt == a) + then restart "xmonad" True + else broadcastMessage e + hunk ./man/xmonad.1.in 26 +\fB--restart +Causes the currently running xmonad process to restart hunk ./XMonad/Config.hs 208 - , ((modMask , xK_q ), restart "xmonad" True) -- %! Restart xmonad + , ((modMask , xK_q ), spawn "xmonad --recompile; xmonad --restart") -- %! Restart xmonad hunk ./man/xmonad.hs 132 - , ((modMask , xK_q ), restart "xmonad" True) + , ((modMask , xK_q ), spawn "xmonad --recompile; xmonad --restart") hunk ./XMonad/Core.hs 357 +-- | Like 'spawn', but returns the 'ProcessID' of the launched application hunk ./XMonad/Core.hs 36 -import Control.Exception (catch, try, bracket, throw, Exception(ExitException)) +import Control.Exception (catch, try, bracket, throw, finally, Exception(ExitException)) hunk ./XMonad/Core.hs 44 +import System.Posix.IO hunk ./XMonad/Core.hs 360 -spawnPID x = io $ forkProcess $ executeFile "/bin/sh" False ["-c", x] Nothing +spawnPID x = io . forkProcess . finally nullStdin $ + executeFile "/bin/sh" False ["-c", x] Nothing + where + nullStdin = do + fd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags + dupTo fd stdInput + closeFd fd hunk ./XMonad/Core.hs 42 -import System.Posix.Process (executeFile, forkProcess, getAnyProcessStatus) +import System.Posix.Process (executeFile, forkProcess, getAnyProcessStatus, createSession) hunk ./XMonad/Core.hs 360 -spawnPID x = io . forkProcess . finally nullStdin $ +spawnPID x = io . forkProcess . finally nullStdin $ do + createSession hunk ./XMonad/Core.hs 27 - runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, + runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, uninstallSignalHandlers, hunk ./XMonad/Core.hs 361 + uninstallSignalHandlers hunk ./XMonad/Core.hs 414 - installHandler sigCHLD Default Nothing + uninstallSignalHandlers hunk ./XMonad/Core.hs 460 + +uninstallSignalHandlers :: MonadIO m => m () +uninstallSignalHandlers = io $ do + installHandler sigCHLD Default Nothing + return () hunk ./XMonad/Core.hs 128 - deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf) + deriving (Functor, Monad, MonadIO, MonadState XState, MonadReader XConf, Typeable) hunk ./XMonad/Config.hs 29 - ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse) + ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse + ,handleEventHook) hunk ./XMonad/Config.hs 33 - ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse) + ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse + ,handleEventHook) hunk ./XMonad/Config.hs 41 +import Data.Monoid hunk ./XMonad/Config.hs 45 +import Graphics.X11.Xlib.Extras hunk ./XMonad/Config.hs 126 +------------------------------------------------------------------------ +-- Event handling + +-- | Defines a custom handler function for X Events. The function should +-- return True if the default handler is to be run afterwards. +handleEventHook :: Event -> X All +handleEventHook _ = return (All True) + hunk ./XMonad/Config.hs 265 + , XMonad.handleEventHook = handleEventHook hunk ./XMonad/Core.hs 90 + , handleEventHook :: !(Event -> X All) -- ^ Handle an X event, returns (All True) if the default handler + -- should also be run afterwards. mappend should be used for combining + -- event hooks in most cases. hunk ./XMonad/Main.hsc 25 +import Data.Monoid (getAll) hunk ./XMonad/Main.hsc 156 - in local (\c -> c { mousePosition = mouse }) (handle e) + in local (\c -> c { mousePosition = mouse }) (handleWithHook e) hunk ./XMonad/Main.hsc 161 +-- | Runs handleEventHook from the configuration and runs the default handler +-- function if it returned True. +handleWithHook :: Event -> X () +handleWithHook e = do + evHook <- asks (handleEventHook . config) + whenX (userCodeDef True $ getAll `fmap` evHook e) (handle e) + hunk ./XMonad/Core.hs 419 - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-no-recomp", "-v0", "-o",binn] (Just dir) + waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-fforce-recomp", "-v0", "-o",binn] (Just dir) hunk ./XMonad/StackSet.hs 55 -import Data.Maybe (listToMaybe,fromJust,isJust) +import Data.Maybe (listToMaybe,isJust) hunk ./XMonad/StackSet.hs 541 -shift n s | n `tagMember` s && n /= curtag = maybe s go (peek s) - | otherwise = s - where go w = view curtag . insertUp w . view n . delete' w $ s - curtag = currentTag s +shift n s = maybe s (\w -> shiftWin n w s) (peek s) hunk ./XMonad/StackSet.hs 549 --- TODO how does this duplicate 'shift's behaviour? hunk ./XMonad/StackSet.hs 550 -shiftWin n w s | from == Nothing = s -- not found - | n `tagMember` s && (Just n) /= from = go - | otherwise = s - where from = findTag w s - - go = on n (insertUp w) . on (fromJust from) (delete' w) $ s - on i f = view (currentTag s) . f . view i +shiftWin n w s = case findTag w s of + Just from | n `tagMember` s && n /= from -> go from s + _ -> s + where go from = onWorkspace n (insertUp w) . onWorkspace from (delete' w) hunk ./XMonad/StackSet.hs 555 +onWorkspace :: (Eq i, Eq s) => i -> (StackSet i l a s sd -> StackSet i l a s sd) + -> (StackSet i l a s sd -> StackSet i l a s sd) +onWorkspace n f s = view (currentTag s) . f . view n $ s hunk ./XMonad/ManageHook.hs 114 -doShift = doF . W.shift +doShift i = doF . W.shiftWin i =<< ask hunk ./XMonad/ManageHook.hs 74 - extract = fmap head . wcTextPropertyToTextList d + extract prop = do l <- wcTextPropertyToTextList d prop + return $ if null l then "" else head l hunk ./XMonad/Layout.hs 54 -data Tall a = Tall !Int -- ^ The default number of windows in the master pane (default: 1) - !Rational -- ^ Default proportion of screen occupied by master pane (default: 1/2) - !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100) +data Tall a = Tall { tallNMaster :: !Int -- ^ The default number of windows in the master pane (default: 1) + , tallRatio :: !Rational -- ^ Default proportion of screen occupied by master pane (default: 1/2) + , tallRatioIncrement :: !Rational } -- ^ Percent of screen to increment by when resizing panes (default: 3/100) hunk ./XMonad/Config.hs 130 --- return True if the default handler is to be run afterwards. +-- return (All True) if the default handler is to be run afterwards. +-- To combine event hooks, use mappend or mconcat from Data.Monoid. hunk ./man/xmonad.hs 21 +-- Whether focus follows the mouse pointer. +myFocusFollowsMouse :: Bool +myFocusFollowsMouse = True + hunk ./man/xmonad.hs 81 - -- close focused window + -- close focused window hunk ./man/xmonad.hs 223 --- Whether focus follows the mouse pointer. -myFocusFollowsMouse :: Bool -myFocusFollowsMouse = True +------------------------------------------------------------------------ +-- Event handling hunk ./man/xmonad.hs 226 +-- * EwmhDesktops users should change this to ewmhDesktopsEventHook +-- +-- Defines a custom handler function for X Events. The function should +-- return (All True) if the default handler is to be run afterwards. To +-- combine event hooks use mappend or mconcat from Data.Monoid. +-- +myEventHook = handleEventHook hunk ./man/xmonad.hs 264 --- fields in the default config. Any you don't override, will +-- fields in the default config. Any you don't override, will hunk ./man/xmonad.hs 266 --- +-- hunk ./man/xmonad.hs 287 + handleEventHook = myEventHook, hunk ./man/xmonad.hs 232 -myEventHook = handleEventHook +myEventHook = mempty hunk ./XMonad/StackSet.hs 197 -new l wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty +new l wids m | not (null wids) && length m <= length wids && not (null m) + = StackSet cur visi unseen M.empty hunk ./Main.hs 19 +import Control.Monad (unless) hunk ./Main.hs 24 +import System.Exit (exitFailure) hunk ./Main.hs 44 - ["--recompile"] -> recompile True >> return () + ["--recompile"] -> recompile True >>= flip unless exitFailure hunk ./XMonad/Config.hs 221 - , ((modMask , xK_q ), spawn "xmonad --recompile; xmonad --restart") -- %! Restart xmonad + , ((modMask , xK_q ), spawn "xmonad --recompile && xmonad --restart") -- %! Restart xmonad hunk ./XMonad/ManageHook.hs 48 +infix 0 --> + hunk ./XMonad/ManageHook.hs 77 - return $ if null l then "" else head l + return $ if null l then "" else head l hunk ./XMonad/Core.hs 40 +import System.FilePath hunk ./XMonad/Core.hs 53 +import Data.List ((\\)) hunk ./XMonad/Core.hs 410 - bin = dir ++ "/" ++ binn - base = dir ++ "/" ++ "xmonad" + bin = dir binn + base = dir "xmonad" hunk ./XMonad/Core.hs 414 + lib = dir "lib" + libTs <- mapM getModTime =<< allFiles lib hunk ./XMonad/Core.hs 418 - if (force || srcT > binT) + if (force || srcT > binT || any (binT<) libTs) hunk ./XMonad/Core.hs 423 - waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-fforce-recomp", "-v0", "-o",binn] (Just dir) + waitForProcess =<< runProcess "ghc" ["--make", "xmonad.hs", "-i", "-ilib", "-fforce-recomp", "-v0", "-o",binn] (Just dir) hunk ./XMonad/Core.hs 443 + allFiles t = do + let prep = map (t) . Prelude.filter (`notElem` [".",".."]) + cs <- prep <$> catch (getDirectoryContents t) (\_ -> return []) + ds <- filterM doesDirectoryExist cs + concat . ((cs \\ ds):) <$> mapM allFiles ds hunk ./xmonad.cabal 44 - build-depends: base < 4 && >=3, containers, directory, process + build-depends: base < 4 && >=3, containers, directory, process, filepath hunk ./XMonad/Core.hs 415 - libTs <- mapM getModTime =<< allFiles lib + libTs <- mapM getModTime . Prelude.filter isSource =<< allFiles lib hunk ./XMonad/Core.hs 443 + isSource = flip elem [".hs",".lhs",".hsc"] hunk ./man/xmonad.hs 11 +import Data.Monoid hunk ./man/xmonad.hs 71 -myKeys conf@(XConfig {XMonad.modMask = modMask}) = M.fromList $ +myKeys conf@(XConfig {XMonad.modMask = modm}) = M.fromList $ hunk ./man/xmonad.hs 74 - [ ((modMask .|. shiftMask, xK_Return), spawn $ XMonad.terminal conf) + [ ((modm .|. shiftMask, xK_Return), spawn $ XMonad.terminal conf) hunk ./man/xmonad.hs 77 - , ((modMask, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") + , ((modm, xK_p ), spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") hunk ./man/xmonad.hs 80 - , ((modMask .|. shiftMask, xK_p ), spawn "gmrun") + , ((modm .|. shiftMask, xK_p ), spawn "gmrun") hunk ./man/xmonad.hs 83 - , ((modMask .|. shiftMask, xK_c ), kill) + , ((modm .|. shiftMask, xK_c ), kill) hunk ./man/xmonad.hs 86 - , ((modMask, xK_space ), sendMessage NextLayout) + , ((modm, xK_space ), sendMessage NextLayout) hunk ./man/xmonad.hs 89 - , ((modMask .|. shiftMask, xK_space ), setLayout $ XMonad.layoutHook conf) + , ((modm .|. shiftMask, xK_space ), setLayout $ XMonad.layoutHook conf) hunk ./man/xmonad.hs 92 - , ((modMask, xK_n ), refresh) + , ((modm, xK_n ), refresh) hunk ./man/xmonad.hs 95 - , ((modMask, xK_Tab ), windows W.focusDown) + , ((modm, xK_Tab ), windows W.focusDown) hunk ./man/xmonad.hs 98 - , ((modMask, xK_j ), windows W.focusDown) + , ((modm, xK_j ), windows W.focusDown) hunk ./man/xmonad.hs 101 - , ((modMask, xK_k ), windows W.focusUp ) + , ((modm, xK_k ), windows W.focusUp ) hunk ./man/xmonad.hs 104 - , ((modMask, xK_m ), windows W.focusMaster ) + , ((modm, xK_m ), windows W.focusMaster ) hunk ./man/xmonad.hs 107 - , ((modMask, xK_Return), windows W.swapMaster) + , ((modm, xK_Return), windows W.swapMaster) hunk ./man/xmonad.hs 110 - , ((modMask .|. shiftMask, xK_j ), windows W.swapDown ) + , ((modm .|. shiftMask, xK_j ), windows W.swapDown ) hunk ./man/xmonad.hs 113 - , ((modMask .|. shiftMask, xK_k ), windows W.swapUp ) + , ((modm .|. shiftMask, xK_k ), windows W.swapUp ) hunk ./man/xmonad.hs 116 - , ((modMask, xK_h ), sendMessage Shrink) + , ((modm, xK_h ), sendMessage Shrink) hunk ./man/xmonad.hs 119 - , ((modMask, xK_l ), sendMessage Expand) + , ((modm, xK_l ), sendMessage Expand) hunk ./man/xmonad.hs 122 - , ((modMask, xK_t ), withFocused $ windows . W.sink) + , ((modm, xK_t ), withFocused $ windows . W.sink) hunk ./man/xmonad.hs 125 - , ((modMask , xK_comma ), sendMessage (IncMasterN 1)) + , ((modm , xK_comma ), sendMessage (IncMasterN 1)) hunk ./man/xmonad.hs 128 - , ((modMask , xK_period), sendMessage (IncMasterN (-1))) + , ((modm , xK_period), sendMessage (IncMasterN (-1))) hunk ./man/xmonad.hs 130 - -- toggle the status bar gap - -- TODO, update this binding with avoidStruts , ((modMask , xK_b ), + -- Toggle the status bar gap + -- Use this binding with avoidStruts from Hooks.ManageDocks. + -- See also the statusBar function from Hooks.DynamicLog. + -- + -- , ((modm , xK_b ), sendMessage ToggleStruts) hunk ./man/xmonad.hs 137 - , ((modMask .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) + , ((modm .|. shiftMask, xK_q ), io (exitWith ExitSuccess)) hunk ./man/xmonad.hs 140 - , ((modMask , xK_q ), spawn "xmonad --recompile; xmonad --restart") + , ((modm , xK_q ), spawn "xmonad --recompile; xmonad --restart") hunk ./man/xmonad.hs 148 - [((m .|. modMask, k), windows $ f i) + [((m .|. modm, k), windows $ f i) hunk ./man/xmonad.hs 157 - [((m .|. modMask, key), screenWorkspace sc >>= flip whenJust (windows . f)) + [((m .|. modm, key), screenWorkspace sc >>= flip whenJust (windows . f)) hunk ./man/xmonad.hs 165 -myMouseBindings (XConfig {XMonad.modMask = modMask}) = M.fromList $ +myMouseBindings (XConfig {XMonad.modMask = modm}) = M.fromList $ hunk ./man/xmonad.hs 168 - [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w - >> windows W.shiftMaster)) + [ ((modm, button1), (\w -> focus w >> mouseMoveWindow w + >> windows W.shiftMaster)) hunk ./man/xmonad.hs 172 - , ((modMask, button2), (\w -> focus w >> windows W.shiftMaster)) + , ((modm, button2), (\w -> focus w >> windows W.shiftMaster)) hunk ./man/xmonad.hs 175 - , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w - >> windows W.shiftMaster)) + , ((modm, button3), (\w -> focus w >> mouseResizeWindow w + >> windows W.shiftMaster)) hunk ./XMonad/Core.hs 418 - if (force || srcT > binT || any (binT<) libTs) + if force || any (binT <) (srcT : libTs) hunk ./man/xmonad.1.in 43 +.SS "Modular Configuration" +As of \fBxmonad-0.9\fR, any additional Haskell modules may be placed in \fI~/.xmonad/lib/\fR are available in GHC's searchpath. Hierarchical modules are supported: for example, the file \fI~/.xmonad/lib/XMonad/Stack/MyAdditions.hs\fR could contain: +.IP +.nf +module XMonad.Stack.MyAdditions (function1) where +function1 = error "function1: Not implemented yet!" +.PP +Your xmonad.hs may then \fBimport XMonad.Stack.MyAdditions\fR as if that module was contained within \fBxmonad\fR or \fBxmonad-contrib\fR. hunk ./man/xmonad.1.in 8 -\fBxmonad\fR is a minimalist tiling window manager for X, written in Haskell. Windows are managed using automatic layout algorithms, which can be dynamically reconfigured. At any time windows are arranged so as to maximise the use of screen real estate. All features of the window manager are accessible purely from the keyboard: a mouse is entirely optional. \fBxmonad\fR is configured in Haskell, and custom layout algorithms may be implemented by the user in config files. A principle of \fBxmonad\fR is predictability: the user should know in advance precisely the window arrangement that will result from any action. +\fBxmonad\fR is a minimalist tiling window manager for X, written in Haskell. Windows are managed using automatic layout algorithms, which can be dynamically reconfigured. At any time windows are arranged so as to maximize the use of screen real estate. All features of the window manager are accessible purely from the keyboard: a mouse is entirely optional. \fBxmonad\fR is configured in Haskell, and custom layout algorithms may be implemented by the user in config files. A principle of \fBxmonad\fR is predictability: the user should know in advance precisely the window arrangement that will result from any action. hunk ./man/xmonad.1.in 10 -By default, \fBxmonad\fR provides three layout algorithms: tall, wide and fullscreen. In tall or wide mode, windows are tiled and arranged to prevent overlap and maximise screen use. Sets of windows are grouped together on virtual screens, and each screen retains its own layout, which may be reconfigured dynamically. Multiple physical monitors are supported via Xinerama, allowing simultaneous display of a number of screens. +By default, \fBxmonad\fR provides three layout algorithms: tall, wide and fullscreen. In tall or wide mode, windows are tiled and arranged to prevent overlap and maximize screen use. Sets of windows are grouped together on virtual screens, and each screen retains its own layout, which may be reconfigured dynamically. Multiple physical monitors are supported via Xinerama, allowing simultaneous display of a number of screens. hunk ./man/xmonad.1.in 12 -By utilising the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 1200 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. +By utilizing the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 1200 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. hunk ./man/xmonad.1.in 36 -xmonad +exec xmonad hunk ./xmonad.cabal 26 +data-files: man/xmonad.hs + hunk ./xmonad.cabal 21 - man/xmonad.1.in man/xmonad.1 man/xmonad.html man/xmonad.hs + man/xmonad.1.in man/xmonad.1 man/xmonad.html hunk ./Main.hs 73 --- * "~\/.xmonad\/xmonad.hs" missing +-- * both "~\/.xmonad\/xmonad.hs" and "~\/.xmonad\/xmonad-$arch-$os" missing hunk ./XMonad/Layout.hs 55 - , tallRatio :: !Rational -- ^ Default proportion of screen occupied by master pane (default: 1/2) - , tallRatioIncrement :: !Rational } -- ^ Percent of screen to increment by when resizing panes (default: 3/100) + , tallRatioIncrement :: !Rational -- ^ Percent of screen to increment by when resizing panes (default: 3/100) + , tallRatio :: !Rational } -- ^ Default proportion of screen occupied by master pane (default: 1/2) hunk ./xmonad.cabal 49 - build-depends: X11>=1.4.3, mtl, unix + build-depends: X11>=1.4.6.1, mtl, unix hunk ./man/xmonad.1.in 45 -.IP +.RS hunk ./man/xmonad.1.in 47 + hunk ./man/xmonad.1.in 50 +.fi +.RE hunk ./man/xmonad.1.in 3 -.TH xmonad 1 "18 April 07" xmonad\-1.0 "xmonad manual" +.TH xmonad 1 "8 September 09"\ +___RELEASE___\ +"xmonad manual" hunk ./util/GenerateManpage.hs 23 +import Distribution.PackageDescription.Parse +import Distribution.Verbosity +import Distribution.Package +import Distribution.PackageDescription +import Text.PrettyPrint.HughesPJ +import Distribution.Text + hunk ./util/GenerateManpage.hs 52 + releaseName <- ((' ':) . (++" \\") . show . disp . package . packageDescription) `liftM` readPackageDescription normal "xmonad.cabal" + hunk ./util/GenerateManpage.hs 55 - let sed = unlines . replace "___KEYBINDINGS___" troffBindings . lines + + let sed = unlines . replace "___RELEASE___\\" releaseName . replace "___KEYBINDINGS___" troffBindings . lines hunk ./xmonad.cabal 2 -version: 0.8.1 +version: 0.9 hunk ./XMonad/Core.hs 476 + installHandler openEndedPipe Default Nothing hunk ./Main.hs 42 - ["--resume", _] -> launch + ("--resume":_) -> launch hunk ./XMonad/Config.hs 267 - , XMonad.focusFollowsMouse = focusFollowsMouse } - + , XMonad.focusFollowsMouse = focusFollowsMouse + } hunk ./XMonad/Core.hs 27 + StateExtension(..), ExtensionClass(..), hunk ./XMonad/Core.hs 55 -import Data.Maybe (isJust) +import Data.Maybe (isJust,fromMaybe) hunk ./XMonad/Core.hs 57 -import Data.Maybe (fromMaybe) hunk ./XMonad/Core.hs 63 - { windowset :: !WindowSet -- ^ workspace list - , mapped :: !(S.Set Window) -- ^ the Set of mapped windows - , waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents - , dragging :: !(Maybe (Position -> Position -> X (), X ())) } - + { windowset :: !WindowSet -- ^ workspace list + , mapped :: !(S.Set Window) -- ^ the Set of mapped windows + , waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents + , dragging :: !(Maybe (Position -> Position -> X (), X ())) + , extensibleState :: !(M.Map String (Either String StateExtension)) + -- ^ stores custom state information. + -- + -- The module XMonad.Utils.ExtensibleState in xmonad-contrib + -- provides additional information and a simple interface for using this. + } hunk ./XMonad/Core.hs 351 +-- --------------------------------------------------------------------- +-- Extensible state +-- + +-- | Every module must make the data it wants to store +-- an instance of this class. +-- +-- Minimal complete definition: initialValue +class Typeable a => ExtensionClass a where + -- | Defines an initial value for the state extension + initialValue :: a + -- | Specifies whether the state extension should be + -- persistent. Setting this method to 'PersistentExtension' + -- will make the stored data survive restarts, but + -- requires a to be an instance of Read and Show. + -- + -- It defaults to 'StateExtension', i.e. no persistence. + extensionType :: a -> StateExtension + extensionType = StateExtension + +-- | Existential type to store a state extension. +data StateExtension = + forall a. ExtensionClass a => StateExtension a + -- ^ Non-persistent state extension + | forall a. (Read a, Show a, ExtensionClass a) => PersistentExtension a + -- ^ Persistent extension + hunk ./XMonad/Main.hsc 18 +import Control.Arrow (second) hunk ./XMonad/Main.hsc 97 - hunk ./XMonad/Main.hsc 106 + extState = fromMaybe M.empty $ do + ("--resume" : _ : dyns : _) <- return args + vals <- maybeRead reads dyns + return . M.fromList . map (second Left) $ vals hunk ./XMonad/Main.hsc 121 - st = XState - { windowset = initialWinset - , mapped = S.empty - , waitingUnmap = M.empty - , dragging = Nothing } hunk ./XMonad/Main.hsc 122 + st = XState + { windowset = initialWinset + , mapped = S.empty + , waitingUnmap = M.empty + , dragging = Nothing + , extensibleState = extState + } hunk ./XMonad/Operations.hs 71 - g <- fmap appEndo $ userCodeDef (Endo id) (runQuery mh w) + g <- appEndo <$> userCodeDef (Endo id) (runQuery mh w) hunk ./XMonad/Operations.hs 416 - args <- if resume then gets (("--resume":) . return . showWs . windowset) else return [] + let wsData = show . W.mapLayout show . windowset + maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext) + maybeShow (t, Left str) = Just (t, str) + maybeShow _ = Nothing + extState = return . show . catMaybes . map maybeShow . M.toList . extensibleState + args <- if resume then gets (\s -> "--resume":wsData s:extState s) else return [] hunk ./XMonad/Operations.hs 423 - where showWs = show . W.mapLayout show hunk ./man/xmonad.1.in 1 -./" man page created by David Lazar on April 24, 2007 -./" uses ``tmac.an'' macro set -.TH xmonad 1 "8 September 09"\ -___RELEASE___\ -"xmonad manual" -.SH NAME -xmonad \- a tiling window manager -.SH DESCRIPTION -.PP -\fBxmonad\fR is a minimalist tiling window manager for X, written in Haskell. Windows are managed using automatic layout algorithms, which can be dynamically reconfigured. At any time windows are arranged so as to maximize the use of screen real estate. All features of the window manager are accessible purely from the keyboard: a mouse is entirely optional. \fBxmonad\fR is configured in Haskell, and custom layout algorithms may be implemented by the user in config files. A principle of \fBxmonad\fR is predictability: the user should know in advance precisely the window arrangement that will result from any action. -.PP -By default, \fBxmonad\fR provides three layout algorithms: tall, wide and fullscreen. In tall or wide mode, windows are tiled and arranged to prevent overlap and maximize screen use. Sets of windows are grouped together on virtual screens, and each screen retains its own layout, which may be reconfigured dynamically. Multiple physical monitors are supported via Xinerama, allowing simultaneous display of a number of screens. -.PP -By utilizing the expressivity of a modern functional language with a rich static type system, \fBxmonad\fR provides a complete, featureful window manager in less than 1200 lines of code, with an emphasis on correctness and robustness. Internal properties of the window manager are checked using a combination of static guarantees provided by the type system, and type-based automated testing. A benefit of this is that the code is simple to understand, and easy to modify. -.SH USAGE -.PP -\fBxmonad\fR places each window into a "workspace". Each workspace can have any number of windows, which you can cycle though with mod-j and mod-k. Windows are either displayed full screen, tiled horizontally, or tiled vertically. You can toggle the layout mode with mod-space, which will cycle through the available modes. -.PP -You can switch to workspace N with mod-N. For example, to switch to workspace 5, you would press mod-5. Similarly, you can move the current window to another workspace with mod-shift-N. -.PP -When running with multiple monitors (Xinerama), each screen has exactly 1 workspace visible. mod-{w,e,r} switch the focus between screens, while shift-mod-{w,e,r} move the current window to that screen. When \fBxmonad\fR starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. When switching workspaces to one that is already visible, the current and visible workspaces are swapped. -.PP -.SS Flags -\fBxmonad\fR has several flags which you may pass to the executable. These flags are: -.TP -\fB--recompile -Recompiles your configuration in ~/.xmonad/xmonad.hs -\fB--restart -Causes the currently running xmonad process to restart -.TP -\fB--version -Display version of \fBxmonad\fR. -.SS Default keyboard bindings -___KEYBINDINGS___ -.SH EXAMPLES -To use \fBxmonad\fR as your window manager add: -.RS -exec xmonad -.RE -to your \fI~/.xinitrc\fR file -.SH CUSTOMIZATION -\fBxmonad\fR is customized in ~/.xmonad/xmonad.hs, and then restarting with mod-q. -.PP -You can find many extensions to the core feature set in the xmonad-contrib package, available through your package manager or from http://xmonad.org/. -.SS "Modular Configuration" -As of \fBxmonad-0.9\fR, any additional Haskell modules may be placed in \fI~/.xmonad/lib/\fR are available in GHC's searchpath. Hierarchical modules are supported: for example, the file \fI~/.xmonad/lib/XMonad/Stack/MyAdditions.hs\fR could contain: -.RS -.nf - -module XMonad.Stack.MyAdditions (function1) where -function1 = error "function1: Not implemented yet!" -.fi -.RE -.PP -Your xmonad.hs may then \fBimport XMonad.Stack.MyAdditions\fR as if that module was contained within \fBxmonad\fR or \fBxmonad-contrib\fR. -.SH BUGS -Probably. If you find any, please report them: http://code.google.com/p/xmonad/issues/list rmfile ./man/xmonad.1.in addfile ./man/xmonad.1.markdown hunk ./man/xmonad.1.markdown 1 +#Name +xmonad - a tiling window manager + +#Description + +_xmonad_ is a minimalist tiling window manager for X, written in Haskell. +Windows are managed using automatic layout algorithms, which can be +dynamically reconfigured. At any time windows are arranged so as to +maximize the use of screen real estate. All features of the window manager +are accessible purely from the keyboard: a mouse is entirely optional. +_xmonad_ is configured in Haskell, and custom layout algorithms may be +implemented by the user in config files. A principle of _xmonad_ is +predictability: the user should know in advance precisely the window +arrangement that will result from any action. + +By default, _xmonad_ provides three layout algorithms: tall, wide and +fullscreen. In tall or wide mode, windows are tiled and arranged to prevent +overlap and maximize screen use. Sets of windows are grouped together on +virtual screens, and each screen retains its own layout, which may be +reconfigured dynamically. Multiple physical monitors are supported via +Xinerama, allowing simultaneous display of a number of screens. + +By utilizing the expressivity of a modern functional language with a rich +static type system, _xmonad_ provides a complete, featureful window manager +in less than 1200 lines of code, with an emphasis on correctness and +robustness. Internal properties of the window manager are checked using a +combination of static guarantees provided by the type system, and +type-based automated testing. A benefit of this is that the code is simple +to understand, and easy to modify. + +#Usage + +_xmonad_ places each window into a "workspace". Each workspace can have +any number of windows, which you can cycle though with mod-j and mod-k. +Windows are either displayed full screen, tiled horizontally, or tiled +vertically. You can toggle the layout mode with mod-space, which will cycle +through the available modes. + +You can switch to workspace N with mod-N. For example, to switch to +workspace 5, you would press mod-5. Similarly, you can move the current +window to another workspace with mod-shift-N. + +When running with multiple monitors (Xinerama), each screen has exactly 1 +workspace visible. mod-{w,e,r} switch the focus between screens, while +shift-mod-{w,e,r} move the current window to that screen. When _xmonad_ +starts, workspace 1 is on screen 1, workspace 2 is on screen 2, etc. When +switching workspaces to one that is already visible, the current and +visible workspaces are swapped. + +##Flags +xmonad has several flags which you may pass to the executable. +These flags are: + +--recompile +: Recompiles your configuration in _~/.xmonad/xmonad.hs_ + +--restart +: Causes the currently running _xmonad_ process to restart + +--version +: Display version of _xmonad_ + +##Default keyboard bindings + +___KEYBINDINGS___ + +#Examples +To use xmonad as your window manager add to your _~/.xinitrc_ file: + +> exec xmonad + +#Customization +xmonad is customized in ~/.xmonad/xmonad.hs, and then restarting +with mod-q. + +You can find many extensions to the core feature set in the xmonad- +contrib package, available through your package manager or from +[xmonad.org]. + +##Modular Configuration +As of _xmonad-0.9_, any additional Haskell modules may be placed in +_~/.xmonad/lib/_ are available in GHC's searchpath. Hierarchical modules +are supported: for example, the file +_~/.xmonad/lib/XMonad/Stack/MyAdditions.hs_ could contain: + +> module XMonad.Stack.MyAdditions (function1) where +> function1 = error "function1: Not implemented yet!" + +Your xmonad.hs may then import XMonad.Stack.MyAdditions as if that +module was contained within xmonad or xmonad-contrib. + +#Bugs +Probably. If you find any, please report them to the [bugtracker] + +[xmonad.org]: http://xmonad.org +[bugtracker]: http://code.google.com/p/xmonad/issues/list hunk ./util/GenerateManpage.hs 5 +-- Uses cabal to grab the xmonad version from xmonad.cabal +-- +-- Uses pandoc to convert the "xmonad.1.markdown" to "xmonad.1" +-- hunk ./util/GenerateManpage.hs 21 --- hunk ./util/GenerateManpage.hs 22 +import Control.Applicative hunk ./util/GenerateManpage.hs 34 +import Text.Pandoc + +releaseDate = "\"8 September 09\"" + hunk ./util/GenerateManpage.hs 53 -troff :: (String, String) -> String -troff (key, desc) = ".IP\n \\fB" ++ key ++ "\\fR\n" ++ desc ++ "\n" +markdownDefn :: (String, String) -> String +markdownDefn (key, desc) = key ++ "\n: " ++ desc hunk ./util/GenerateManpage.hs 59 +-- rawSystem "pandoc" ["--read=markdown","--write=man","man/xmonad.1.markdown"] + hunk ./util/GenerateManpage.hs 62 - releaseName <- ((' ':) . (++" \\") . show . disp . package . packageDescription) `liftM` readPackageDescription normal "xmonad.cabal" + releaseName <- (show . disp . package . packageDescription) + `liftM`readPackageDescription normal "xmonad.cabal" + keybindings <- (intercalate "\n\n" . map markdownDefn . allBindings) + `liftM` readFile "./XMonad/Config.hs" + + let manHeader = unwords [".TH xmonad 1",releaseDate,releaseName,"\"xmonad manual\""] + writeOpts = defaultWriterOptions -- { writerLiterateHaskell = True } + + parsed <- readMarkdown defaultParserState { stateLiterateHaskell = True } + . unlines + . replace "___KEYBINDINGS___" keybindings + . lines + <$> readFile "./man/xmonad.1.markdown" hunk ./util/GenerateManpage.hs 76 - troffBindings <- (concatMap troff . allBindings) `liftM` readFile "./XMonad/Config.hs" + writeFile "./man/xmonad.1" + . (manHeader ++) + . writeMan writeOpts + $ parsed + putStrLn "Documentation created: man/xmonad.1" hunk ./util/GenerateManpage.hs 82 - let sed = unlines . replace "___RELEASE___\\" releaseName . replace "___KEYBINDINGS___" troffBindings . lines - readFile "./man/xmonad.1.in" >>= return . sed >>= writeFile "./man/xmonad.1" + writeFile "./man/xmonad.1.html" + . writeHtmlString writeOpts { writerStandalone = True } + $ parsed + putStrLn "Documentation created: man/xmonad.1.html" hunk ./util/GenerateManpage.hs 36 -releaseDate = "\"8 September 09\"" +releaseDate = "25 October 09" hunk ./util/GenerateManpage.hs 67 - let manHeader = unwords [".TH xmonad 1",releaseDate,releaseName,"\"xmonad manual\""] + let manHeader = unwords [".TH xmonad 1","\""++releaseDate++"\"",releaseName,"\"xmonad manual\""] hunk ./util/GenerateManpage.hs 83 - . writeHtmlString writeOpts { writerStandalone = True } + . writeHtmlString writeOpts + { writerHeader = "

"++releaseName++"

"++ + "

Section: xmonad manual (1)
"++ + "Updated: "++releaseDate++"

"++ + "
" + , writerStandalone = True + , writerTableOfContents = True } hunk ./util/GenerateManpage.hs 1 +-- Unlike the rest of xmonad, this file is copyright under the terms of the +-- GPL. + hunk ./XMonad/Operations.hs 158 + mapM_ reveal visible + setTopFocus + hunk ./XMonad/Operations.hs 165 - mapM_ reveal visible - setTopFocus - hunk ./Main.hs 47 + ["--verbose-version"] -> putStrLn ("xmonad " ++ showVersion version ++ " compiled by " ++ compilerName + ++ " " ++ showVersion compilerVersion ++ " for " ++ os ++ "/" ++ arch) hunk ./XMonad/ManageHook.hs 40 --- | Compose two 'ManageHook's. -(<+>) :: ManageHook -> ManageHook -> ManageHook +-- | Infix 'mappend'. Compose two 'ManageHook' from right to left. +(<+>) :: Monoid m => m -> m -> m hunk ./Main.hs 29 +import Graphics.X11.Xinerama (compiledWithXinerama) + hunk ./Main.hs 48 - ["--version"] -> putStrLn ("xmonad " ++ showVersion version) - ["--verbose-version"] -> putStrLn ("xmonad " ++ showVersion version ++ " compiled by " ++ compilerName - ++ " " ++ showVersion compilerVersion ++ " for " ++ os ++ "/" ++ arch) + ["--version"] -> putStrLn $ unwords shortVersion + ["--verbose-version"] -> putStrLn . unwords $ shortVersion ++ longVersion hunk ./Main.hs 54 + where + shortVersion = ["xmonad", showVersion version] + longVersion = [ "compiled by", compilerName, showVersion compilerVersion + , "for", arch ++ "-" ++ os + , "\nXinerama:", show compiledWithXinerama ] hunk ./man/xmonad.1.markdown 63 +--verbose-version +: Display detailed version of _xmonad_ + hunk ./man/xmonad.hs 242 --- See the 'DynamicLog' extension for examples. --- --- To emulate dwm's status bar --- --- > logHook = dynamicLogDzen +-- See the 'XMonad.Hooks.DynamicLog' extension for examples. hunk ./xmonad.cabal 49 - build-depends: X11>=1.4.6.1, mtl, unix + build-depends: X11>=1.4.6.1 && < 1.5, mtl, unix hunk ./XMonad/Main.hsc 338 - when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers + when (kc /= 0) $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers hunk ./xmonad.cabal 49 - build-depends: X11>=1.4.6.1 && < 1.5, mtl, unix + build-depends: X11>=1.5.0.0 && < 1.6, mtl, unix hunk ./XMonad/Config.hs 28 - (workspaces,manageHook,numlockMask,keys,logHook,startupHook,borderWidth,mouseBindings + (workspaces,manageHook,keys,logHook,startupHook,borderWidth,mouseBindings hunk ./XMonad/Config.hs 32 - (workspaces,manageHook,numlockMask,keys,logHook,startupHook,borderWidth,mouseBindings + (workspaces,manageHook,keys,logHook,startupHook,borderWidth,mouseBindings hunk ./XMonad/Config.hs 67 --- | The mask for the numlock key. Numlock status is "masked" from the --- current modifier status, so the keybindings will work with numlock on or --- off. You may need to change this on some systems. --- --- You can find the numlock modifier by running "xmodmap" and looking for a --- modifier with Num_Lock bound to it: --- --- > $ xmodmap | grep Num --- > mod2 Num_Lock (0x4d) --- --- Set numlockMask = 0 if you don't have a numlock key, or want to treat --- numlock status separately. --- -numlockMask :: KeyMask -numlockMask = mod2Mask - hunk ./XMonad/Config.hs 243 - , XMonad.numlockMask = numlockMask hunk ./XMonad/Core.hs 67 + , numlockMask :: !KeyMask -- ^ The numlock modifier hunk ./XMonad/Core.hs 74 + hunk ./XMonad/Core.hs 103 - , numlockMask :: !KeyMask -- ^ The numlock modifier hunk ./XMonad/Main.hsc 124 + , numlockMask = 0 hunk ./XMonad/Main.hsc 133 + setNumlockMask hunk ./XMonad/Main.hsc 223 - when (ev_request e == mappingKeyboard) grabKeys + when (ev_request e `elem` [mappingKeyboard, mappingModifier]) $ do + setNumlockMask + grabKeys hunk ./XMonad/Main.hsc 331 +setNumlockMask :: X () +setNumlockMask = do + dpy <- asks display + ms <- io $ getModifierMapping dpy + xs <- sequence [ do + ks <- io $ keycodeToKeysym dpy kc 0 + if ks == xK_Num_Lock + then return (setBit 0 (fromIntegral m)) + else return (0 :: KeyMask) + | (m, kcs) <- ms, kc <- kcs, kc /= 0] + modify (\s -> s { numlockMask = foldr (.|.) 0 xs }) + hunk ./XMonad/Operations.hs 392 - nlm <- asks (numlockMask . config) + nlm <- gets numlockMask hunk ./XMonad/Operations.hs 398 - nlm <- asks (numlockMask . config) + nlm <- gets numlockMask hunk ./man/xmonad.hs 37 --- The mask for the numlock key. Numlock status is "masked" from the --- current modifier status, so the keybindings will work with numlock on or --- off. You may need to change this on some systems. --- --- You can find the numlock modifier by running "xmodmap" and looking for a --- modifier with Num_Lock bound to it: --- --- > $ xmodmap | grep Num --- > mod2 Num_Lock (0x4d) --- --- Set numlockMask = 0 if you don't have a numlock key, or want to treat --- numlock status separately. --- -myNumlockMask = mod2Mask - hunk ./man/xmonad.hs 260 - numlockMask = myNumlockMask, hunk ./xmonad.cabal 2 -version: 0.9 +version: 0.9.1 hunk ./xmonad.cabal 21 - man/xmonad.1.in man/xmonad.1 man/xmonad.html + man/xmonad.1.markdown man/xmonad.1 man/xmonad.1.html hunk ./XMonad/Core.hs 30 - getAtom, spawn, spawnPID, getXMonadDir, recompile, trace, whenJust, whenX, + getAtom, spawn, spawnPID, xfork, getXMonadDir, recompile, trace, whenJust, whenX, hunk ./XMonad/Core.hs 398 -spawnPID x = io . forkProcess . finally nullStdin $ do +spawnPID x = xfork $ executeFile "/bin/sh" False ["-c", x] Nothing + +-- | A replacement for 'forkProcess' which resets default signal handlers. +xfork :: MonadIO m => IO () -> m ProcessID +xfork x = io . forkProcess . finally nullStdin $ do hunk ./XMonad/Core.hs 405 - executeFile "/bin/sh" False ["-c", x] Nothing + x hunk ./Main.hs 20 -import System.IO hunk ./XMonad/Core.hs 37 -import Control.Exception (catch, try, bracket, throw, finally, Exception(ExitException)) +import Control.Exception.Extensible (catch, fromException, try, bracket, throw, finally, SomeException(..)) hunk ./XMonad/Core.hs 174 - (a, s') <- io $ runX c st job `catch` \e -> case e of - ExitException {} -> throw e - _ -> do hPrint stderr e; runX c st errcase + (a, s') <- io $ runX c st job `catch` \e -> case fromException e of + Just x -> throw e `const` (x `asTypeOf` ExitSuccess) + _ -> do hPrint stderr e; runX c st errcase hunk ./XMonad/Core.hs 389 -catchIO f = io (f `catch` \e -> hPrint stderr e >> hFlush stderr) +catchIO f = io (f `catch` \(SomeException e) -> hPrint stderr e >> hFlush stderr) hunk ./XMonad/Core.hs 479 - where getModTime f = catch (Just <$> getModificationTime f) (const $ return Nothing) + where getModTime f = catch (Just <$> getModificationTime f) (\(SomeException _) -> return Nothing) hunk ./XMonad/Core.hs 483 - cs <- prep <$> catch (getDirectoryContents t) (\_ -> return []) + cs <- prep <$> catch (getDirectoryContents t) (\(SomeException _) -> return []) hunk ./XMonad/Core.hs 506 - try $ fix $ \more -> do + (try :: IO a -> IO (Either SomeException a)) + $ fix $ \more -> do hunk ./XMonad/ManageHook.hs 25 -import Control.Exception (bracket, catch) +import Control.Exception (bracket, catch, SomeException(..)) hunk ./XMonad/ManageHook.hs 75 - `catch` \_ -> getTextProperty d w wM_NAME + `catch` \(SomeException _) -> getTextProperty d w wM_NAME hunk ./XMonad/ManageHook.hs 78 - io $ bracket getProp (xFree . tp_value) extract `catch` \_ -> return "" + io $ bracket getProp (xFree . tp_value) extract `catch` \(SomeException _) -> return "" hunk ./XMonad/Operations.hs 36 -import qualified Control.Exception as C +import qualified Control.Exception.Extensible as C hunk ./XMonad/Operations.hs 38 -import System.IO hunk ./XMonad/Operations.hs 402 -initColor dpy c = C.handle (\_ -> return Nothing) $ +initColor dpy c = C.handle (\(C.SomeException _) -> return Nothing) $ hunk ./tests/Properties.hs 17 -import qualified Control.Exception as C +import qualified Control.Exception.Extensible as C hunk ./tests/Properties.hs 616 - (\e -> return $ show e == "xmonad: StackSet: fail" ) + (\(C.SomeException e) -> return $ show e == "xmonad: StackSet: fail" ) hunk ./tests/Properties.hs 622 - (\e -> return $ show e == "xmonad: StackSet: non-positive argument to StackSet.new" ) + (\(C.SomeException e) -> return $ show e == "xmonad: StackSet: non-positive argument to StackSet.new" ) hunk ./xmonad.cabal 46 - build-depends: base < 4 && >=3, containers, directory, process, filepath + build-depends: base < 5 && >=3, containers, directory, process, filepath, extensible-exceptions hunk ./xmonad.cabal 51 - ghc-options: -funbox-strict-fields -Wall + if true + ghc-options: -funbox-strict-fields -Wall + + if impl(ghc >= 6.12.1) + ghc-options: -fno-warn-unused-do-bind + hunk ./xmonad.cabal 74 - ghc-options: -funbox-strict-fields -Wall + if true + ghc-options: -funbox-strict-fields -Wall + + if impl(ghc >= 6.12.1) + ghc-options: -fno-warn-unused-do-bind + hunk ./xmonad.cabal 89 - build-depends: random + build-depends: filepath, process, directory, mtl, unix, X11, base, containers, random, extensible-exceptions hunk ./XMonad/Core.hs 67 - , numlockMask :: !KeyMask -- ^ The numlock modifier + , numberlockMask :: !KeyMask -- ^ The numlock modifier hunk ./XMonad/Main.hsc 124 - , numlockMask = 0 + , numberlockMask = 0 hunk ./XMonad/Main.hsc 341 - modify (\s -> s { numlockMask = foldr (.|.) 0 xs }) + modify (\s -> s { numberlockMask = foldr (.|.) 0 xs }) hunk ./XMonad/Operations.hs 391 - nlm <- gets numlockMask + nlm <- gets numberlockMask hunk ./XMonad/Operations.hs 397 - nlm <- gets numlockMask + nlm <- gets numberlockMask hunk ./XMonad/Main.hsc 298 -handle PropertyEvent { ev_event_type = t, ev_atom = a } - | t == propertyNotify && a == wM_NAME = userCodeDef () =<< asks (logHook . config) +handle event@(PropertyEvent { ev_event_type = t, ev_atom = a }) + | t == propertyNotify && a == wM_NAME = asks (logHook . config) >>= userCodeDef () >> + broadcastMessage event hunk ./XMonad/ManageHook.hs 25 -import Control.Exception (bracket, catch, SomeException(..)) +import Control.Exception.Extensible (bracket, catch, SomeException(..)) hunk ./Main.hs 68 + " --replace Request the running window manage to exit" : hunk ./XMonad/Main.hsc 21 +import Data.Function hunk ./XMonad/Main.hsc 71 + args <- getArgs + + when ("--replace" `elem` args) $ replace dpy dflt rootw + hunk ./XMonad/Main.hsc 97 - args <- getArgs hunk ./XMonad/Main.hsc 371 + +-- | @replace@ to signals compliant window managers to exit. +replace :: Display -> ScreenNumber -> Window -> IO () +replace dpy dflt rootw = do + -- check for other WM + wmSnAtom <- internAtom dpy ("WM_S" ++ show dflt) False + currentWmSnOwner <- xGetSelectionOwner dpy wmSnAtom + when (currentWmSnOwner /= 0) $ do + -- prepare to receive destroyNotify for old WM + selectInput dpy currentWmSnOwner structureNotifyMask + + -- create off-screen window + netWmSnOwner <- allocaSetWindowAttributes $ \attributes -> do + set_override_redirect attributes True + set_event_mask attributes propertyChangeMask + let screen = defaultScreenOfDisplay dpy + visual = defaultVisualOfScreen screen + attrmask = cWOverrideRedirect .|. cWEventMask + createWindow dpy rootw (-100) (-100) 1 1 0 copyFromParent copyFromParent visual attrmask attributes + + -- try to acquire wmSnAtom, this should signal the old WM to terminate + xSetSelectionOwner dpy wmSnAtom netWmSnOwner currentTime + + -- SKIPPED: check if we acquired the selection + -- SKIPPED: send client message indicating that we are now the WM + + -- wait for old WM to go away + fix $ \again -> do + evt <- allocaXEvent $ \event -> do + windowEvent dpy currentWmSnOwner structureNotifyMask event + get_EventType event + + when (evt /= destroyNotify) again hunk ./man/xmonad.1.markdown 60 +--replace +: Replace an existing window manager + hunk ./Main.hs 68 - " --replace Request the running window manage to exit" : + " --replace Replace the running window manager with xmonad" : hunk ./man/xmonad.1.markdown 61 -: Replace an existing window manager +: Replace the current window manager with xmonad hunk ./XMonad/Config.hs 223 -mouseBindings (XConfig {XMonad.modMask = modMask}) = M.fromList $ +mouseBindings (XConfig {XMonad.modMask = modMask}) = M.fromList hunk ./XMonad/Config.hs 225 - [ ((modMask, button1), (\w -> focus w >> mouseMoveWindow w - >> windows W.shiftMaster)) + [ ((modMask, button1), \w -> focus w >> mouseMoveWindow w + >> windows W.shiftMaster) hunk ./XMonad/Config.hs 228 - , ((modMask, button2), (\w -> focus w >> windows W.shiftMaster)) + , ((modMask, button2), \w -> focus w >> windows W.shiftMaster) hunk ./XMonad/Config.hs 230 - , ((modMask, button3), (\w -> focus w >> mouseResizeWindow w - >> windows W.shiftMaster)) + , ((modMask, button3), \w -> focus w >> mouseResizeWindow w + >> windows W.shiftMaster) hunk ./XMonad/Config.hs 252 + hunk ./XMonad/Core.hs 459 - status <- bracket (openFile err WriteMode) hClose $ \h -> do + status <- bracket (openFile err WriteMode) hClose $ \h -> hunk ./XMonad/Layout.hs 128 -mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw) +mirrorRect (Rectangle rx ry rw rh) = Rectangle ry rx rh rw hunk ./XMonad/Layout.hs 176 - fmap (second . fmap $ flip (Choose L) $ r) . runLayout (W.Workspace i l ms) + fmap (second . fmap $ flip (Choose L) r) . runLayout (W.Workspace i l ms) hunk ./XMonad/Layout.hs 197 - handleMessage c@(Choose _ l _) m | Just FirstLayout <- fromMessage m = do + handleMessage c@(Choose _ l _) m | Just FirstLayout <- fromMessage m = hunk ./XMonad/Operations.hs 213 - io $ selectInput d w $ clientMask + io $ selectInput d w clientMask hunk ./XMonad/Operations.hs 323 - forM_ (W.current ws : W.visible ws) $ \wk -> do - forM_ (W.index (W.view (W.tag (W.workspace wk)) ws)) $ \otherw -> do + forM_ (W.current ws : W.visible ws) $ \wk -> + forM_ (W.index (W.view (W.tag (W.workspace wk)) ws)) $ \otherw -> hunk ./XMonad/Operations.hs 329 - io $ do setInputFocus dpy w revertToPointerRoot 0 - -- raiseWindow dpy w + io $ setInputFocus dpy w revertToPointerRoot 0 hunk ./XMonad/Operations.hs 340 - whenJust ml' $ \l' -> do + whenJust ml' $ \l' -> hunk ./XMonad/Operations.hs 440 - return (W.screen $ sc, rr) + return (W.screen sc, rr) hunk ./XMonad/Operations.hs 510 - mouseDrag (\ex ey -> do + mouseDrag (\ex ey -> hunk ./XMonad/StackSet.hs 55 -import Data.Maybe (listToMaybe,isJust) +import Data.Maybe (listToMaybe,isJust,fromMaybe) hunk ./XMonad/StackSet.hs 372 - | otherwise = maybe s id $ do + | otherwise = fromMaybe s $ do hunk ./tests/loc.hs 8 - putStrLn $ show loc + print loc hunk ./tests/loc.hs 10 - -- putStr $ unlines $ actual_loc + -- print actual_loc move ./xmonad.cabal ./xmonad-bluetilebranch.cabal hunk ./Main.hs 25 -import Paths_xmonad (version) +import Paths_xmonad_bluetilebranch (version) hunk ./xmonad-bluetilebranch.cabal 1 -name: xmonad -version: 0.9.1 +name: xmonad-bluetilebranch +version: 0.9.1.4 hunk ./xmonad-bluetilebranch.cabal 5 -description: - xmonad is a tiling window manager for X. Windows are arranged - automatically to tile the screen without gaps or overlap, maximising - screen use. All features of the window manager are accessible from - the keyboard: a mouse is strictly optional. xmonad is written and - extensible in Haskell. Custom layout algorithms, and other - extensions, may be written by the user in config files. Layouts are - applied dynamically, and different layouts may be used on each - workspace. Xinerama is fully supported, allowing windows to be tiled - on several screens. +description: This is a modified version of xmonad used by Bluetile. hunk ./xmonad-bluetilebranch.cabal 10 -maintainer: xmonad@haskell.org +maintainer: jan.vornberger@informatik.uni-oldenburg.de hunk ./xmonad-bluetilebranch.cabal 35 + exposed: False