xmonad (empty) → 0.1
raw patch · 12 files changed
+1477/−0 lines, 12 filesdep +X11dep +X11-extrasdep +basebuild-type:Customsetup-changed
Dependencies added: X11, X11-extras, base, mtl, unix
Files
- Config.hs +150/−0
- LICENSE +27/−0
- Main.hs +189/−0
- Operations.hs +282/−0
- README +42/−0
- Setup.lhs +3/−0
- StackSet.hs +252/−0
- TODO +29/−0
- XMonad.hs +122/−0
- tests/Properties.hs +347/−0
- tests/loc.hs +16/−0
- xmonad.cabal +18/−0
+ Config.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+-- |+-- Module : Config.hs+-- Copyright : (c) Spencer Janssen 2007+-- License : BSD3-style (see LICENSE)+-- +-- Maintainer : dons@cse.unsw.edu.au+-- Stability : stable+-- Portability : portable+--+-----------------------------------------------------------------------------++module Config where++--+-- 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 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 cycle the current tiling order+-- +-- 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.+-- ++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+-- ("left alt"). You may also consider using mod3Mask ("right alt"), which+-- does not conflict with emacs keybindings. The "windows key" is usually+-- mod4Mask.+modMask :: KeyMask+modMask = mod1Mask++-- How much to change the horizontal/vertical split bar by defalut.+defaultDelta :: Rational+defaultDelta = 3%100++-- The mask for the numlock key. You may need to change this on some systems.+numlockMask :: KeyMask+numlockMask = lockMask++-- 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 }++-- 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")+ , ((modMask .|. shiftMask, xK_p ), spawn "gmrun")+ , ((modMask, xK_space ), switchLayout)++ , ((modMask, xK_Tab ), raise GT)+ , ((modMask, xK_j ), raise GT)+ , ((modMask, xK_k ), raise LT)++ , ((modMask, xK_h ), changeSplit (negate defaultDelta))+ , ((modMask, xK_l ), changeSplit defaultDelta)++ , ((modMask .|. shiftMask, xK_c ), kill)++ , ((modMask .|. shiftMask, xK_q ), io $ exitWith ExitSuccess)+ , ((modMask .|. shiftMask .|. controlMask, xK_q ), io restart)++ -- Cycle the current tiling order+ , ((modMask, xK_Return), promote)++ ] +++ -- Keybindings to get to each workspace:+ [((m .|. modMask, xK_0 + fromIntegral i), f (fromIntegral (pred i))) -- index from 0.+ | i <- [1 .. workspaces]+ , (f, m) <- [(view, 0), (tag, shiftMask)]]++ -- Keybindings to each screen :+ -- mod-wer (underneath 123) switches to physical/Xinerama screens 1 2 and 3+ +++ [((m .|. modMask, key), screenWorkspace sc >>= f)+ | (key, sc) <- zip [xK_w, xK_e, xK_r] [0..]+ , (f, m) <- [(view, 0), (tag, shiftMask)]]+
+ LICENSE view
@@ -0,0 +1,27 @@+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.
+ Main.hs view
@@ -0,0 +1,189 @@+-----------------------------------------------------------------------------+-- |+-- 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 minimal window manager for X11+--++import Data.Bits+import qualified Data.Map as M++import Graphics.X11.Xlib hiding (refreshKeyboardMapping)+import Graphics.X11.Xlib.Extras+import Graphics.X11.Xinerama++import Control.Monad.State++import qualified StackSet as W++import XMonad+import Operations+import Config++--+-- The main entry point+--+main :: IO ()+main = do+ dpy <- openDisplay ""+ let dflt = defaultScreen dpy+ rootw <- rootWindow dpy dflt+ wmdelt <- internAtom dpy "WM_DELETE_WINDOW" False+ wmprot <- internAtom dpy "WM_PROTOCOLS" False+ xinesc <- getScreenInfo dpy++ let st = XState+ { display = dpy+ , xineScreens = xinesc+ , theRoot = rootw+ , wmdelete = wmdelt+ , wmprotocols = wmprot+ -- fromIntegral needed for X11 versions that use Int instead of CInt.+ , dimensions = (fromIntegral (displayWidth dpy dflt),+ fromIntegral (displayHeight dpy dflt))+ , workspace = W.empty workspaces (length xinesc)+ , defaultLayoutDesc = startingLayoutDesc+ , layoutDescs = M.empty+ }++ xSetErrorHandler -- in C, I'm too lazy to write the binding++ -- setup initial X environment+ sync dpy False+ selectInput dpy rootw $ substructureRedirectMask+ .|. substructureNotifyMask+ .|. enterWindowMask+ .|. leaveWindowMask+ grabKeys dpy rootw+ sync dpy False++ ws <- scan dpy rootw+ allocaXEvent $ \e ->+ runX 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++-- ---------------------------------------------------------------------+-- IO stuff. Doesn't require any X state+-- Most of these things run only on startup (bar grabkeys)++-- | scan for any initial windows to manage+scan :: Display -> Window -> IO [Window]+scan dpy rootw = do+ (_, _, ws) <- queryTree dpy rootw+ filterM ok ws+ where+ ok w = do wa <- getWindowAttributes dpy w+ return $ not (wa_override_redirect wa)+ && wa_map_state wa == waIsViewable++-- | Grab the keys back+grabKeys :: Display -> Window -> IO ()+grabKeys dpy rootw = do+ ungrabKey dpy '\0' {-AnyKey-} anyModifier rootw+ flip mapM_ (M.keys keys) $ \(mask,sym) -> do+ kc <- keysymToKeycode dpy sym+ mapM_ (grab kc) [mask, mask .|. numlockMask] -- note: no numlock+ where+ grab kc m = grabKey dpy kc m rootw True grabModeAsync grabModeAsync++-- ---------------------------------------------------------------------+-- Event handler+--+-- | handle. Handle X events+--+-- Events dwm handles that we don't:+--+-- [ButtonPress] = buttonpress,+-- [Expose] = expose,+-- [PropertyNotify] = propertynotify,+--+-- 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.+--++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+ whenJust (M.lookup (m,s) keys) id++-- manage a new window+handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do+ wa <- io $ getWindowAttributes dpy w -- ignore override windows+ when (not (wa_override_redirect wa)) $ manage w++-- window destroyed, unmanage it+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++-- set keyboard mapping+handle e@(MappingNotifyEvent {ev_window = w}) = do+ -- 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+ when (ev_request e == mappingKeyboard) $ withDisplay $ io . flip grabKeys w++-- click on an unfocussed window+handle (ButtonEvent {ev_window = w, ev_event_type = t})+ | t == buttonPress+ = safeFocus w++-- entered a normal window+handle e@(CrossingEvent {ev_window = w, ev_event_type = t})+ | t == enterNotify && ev_mode e == notifyNormal && ev_detail e /= notifyInferior+ = safeFocus w++-- left a window, check if we need to focus root+handle e@(CrossingEvent {ev_event_type = t})+ | t == leaveNotify+ = do rootw <- gets theRoot+ when (ev_window e == rootw && not (ev_same_screen e)) $ setFocus rootw++-- configure a window+handle e@(ConfigureRequestEvent {ev_window = w}) = do+ XState { display = dpy, workspace = ws } <- get++ when (W.member w ws) $ -- already managed, reconfigure (see client:configure()+ trace ("Reconfigure already managed window: " ++ show w)++ 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+ }++ io $ sync dpy False++handle e = trace (eventName e) -- ignoring
+ Operations.hs view
@@ -0,0 +1,282 @@+-----------------------------------------------------------------------------+-- |+-- Module : Operations.hs+-- Copyright : (c) Spencer Janssen 2007+-- License : BSD3-style (see LICENSE)+-- +-- Maintainer : dons@cse.unsw.edu.au+-- Stability : stable+-- Portability : portable+--+-----------------------------------------------------------------------------++module Operations where++import Data.List+import Data.Maybe+import Data.Bits+import qualified Data.Map as M++import Control.Monad.State+import Control.Arrow++import System.Posix.Process+import System.Environment+import System.Directory++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+ XState {workspace = ws, xineScreens = xinesc+ ,display = d ,layoutDescs = fls ,defaultLayoutDesc = dfltfl } <- get++ flip mapM_ (M.assocs (W.screen2ws ws)) $ \(scn, n) -> do+ let sc = genericIndex xinesc scn -- temporary coercion!+ fl = M.findWithDefault dfltfl n fls+ mapM_ (\(w, rect) -> io $ moveWindowInside d w rect) $+ 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+ whenJust (W.peekStack n ws) (io . raiseWindow d)+ whenJust (W.peek ws) setFocus+ 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++-- | tile. Compute the positions for windows in horizontal layout+-- mode.+--+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))++-- | vtile. Tile vertically.+vtile :: Rational -> Rectangle -> [Window] -> [(Window, Rectangle)]+vtile r rect = map (second flipRect) . tile r (flipRect rect)++-- | Flip rectangles around+flipRect :: Rectangle -> Rectangle+flipRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw)++-- | 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 $ \fl -> fl { layoutType = rotateLayout (layoutType fl) }++-- | changeSplit. Changes the window split.+changeSplit :: Rational -> X ()+changeSplit delta = 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++-- | 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+ 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++-- | 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+ 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++ -- clear mouse button grab and border on other windows+ flip mapM_ (W.visibleWorkspaces ws) $ \n -> do+ flip mapM_ (W.index n ws) $ \otherw -> do+ setButtonGrab True otherw+ setBorder otherw 0xdddddd++ withDisplay $ \d -> io $ setInputFocus d w revertToPointerRoot 0+ setButtonGrab False w+ setBorder w 0xff0000 -- make this configurable++ -- 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 -> gets theRoot >>= setFocus++-- | Set the border color for a particular window.+setBorder :: Window -> Pixel -> X ()+setBorder w p = withDisplay $ \d -> io $ setWindowBorder d w p++-- | 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+ XState {wmdelete = wmdelt, wmprotocols = wmprot} <- get+ 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')) (mapM_ hide (W.index m ws))+ clearEnterEvents+ setTopFocus++-- | 'screenWorkspace sc' returns the workspace number viewed by 'sc'.+screenWorkspace :: ScreenId -> X WorkspaceId+screenWorkspace sc = fmap (fromMaybe 0 . W.workspace sc) (gets workspace)++-- | True if window is under management by us+isClient :: Window -> X Bool+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
+ README view
@@ -0,0 +1,42 @@+ xmonad : a lightweight X11 window manager.++Motivation:++ 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.++ 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.++Building:++ Get the dependencies++ 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+ X11 http://hackage.haskell.org/cgi-bin/hackage-scripts/package/X11-1.2+ (Unfortunately X11-1.2 does not work correctly on AMD64. The latest+ darcs version from http://darcs.haskell.org/packages/X11 does.)+ unix http://hackage.haskell.org/cgi-bin/hackage-scripts/package/unix-2.0 + (included with ghc)++ dmenu 2.{5,6,7} http://www.suckless.org/download/dmenu-2.7.tar.gz++And then build with Cabal:++ runhaskell Setup.lhs configure --prefix=/home/dons+ runhaskell Setup.lhs build+ runhaskell Setup.lhs install++Then add:++ exec /home/dons/bin/xmonad++ to the last line of your .xsession file++Authors:++ Spencer Janssen+ Don Stewart+ Jason Creigh
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ StackSet.hs view
@@ -0,0 +1,252 @@+-----------------------------------------------------------------------------+-- |+-- 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. Elements may appear only once in the entire+-- stack set.+--+-- 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.+--++module StackSet (+ StackSet(..), -- abstract++ screen, peekStack, index, empty, peek, push, delete, member,+ raiseFocus, rotate, promote, shift, view, workspace, fromList,+ toList, size, visibleWorkspaces, swap {- helper -}+ ) where++import Data.Maybe+import qualified Data.List as L (delete,genericLength,elemIndex)+import qualified Data.Map as M++------------------------------------------------------------------------++-- | 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]) -- ^ 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+ } deriving Eq++instance (Show i, Show a) => Show (StackSet i j a) where+ showsPrec p s r = showsPrec p (show . toList $ s) r++-- The cache is used to check on insertion that we don't already have+-- this window managed on another stack++------------------------------------------------------------------------++-- | /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 :: (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 }++ where (scrs,wrks) = unzip $ map (\x -> (fromIntegral x, fromIntegral x)) [0..m-1]+ wsScrs2Works = M.fromList (zip scrs wrks)+ wsWorks2Scrs = M.fromList (zip wrks scrs)++-- | /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(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(n)/. Number of stacks+size :: StackSet i j a -> Int+size = M.size . stacks++------------------------------------------------------------------------++-- | 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)+++-- | 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))++-- | 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(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++-- | /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)++-- | /O(log s)/. Index. Extract the stack at workspace 'n'.+-- If the index is invalid, an exception is thrown.+index :: Integral i => i -> StackSet i j a -> [a]+index k w = fromJust (M.lookup k (stacks w))++-- | 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 an exception is+-- thrown.+view :: (Integral i, Integral j) => i -> StackSet i j a -> StackSet i j 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+ 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 :: Integral i => i -> StackSet i j a -> Maybe j+screen n w = M.lookup n (ws2screen w)++-- | 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)++-- | A list of the currently visible workspaces.+visibleWorkspaces :: StackSet i j a -> [i]+visibleWorkspaces = M.keys . ws2screen++--+-- | /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]+--+-- where xs = [5..8] ++ [1..4]+--+rotate :: (Integral i, Eq a) => Ordering -> StackSet i j a -> StackSet i j 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) }++-- | /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 (delete k w)) (peek w)++-- | /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.+--+insert :: (Integral i, Ord a) => a -> i -> StackSet i j a -> StackSet i j a+insert k n old = new { cache = M.insert k n (cache new)+ , stacks = M.adjust (k:) n (stacks new)+ , focus = M.insert n k (focus new) }+ where new = delete k old++-- | /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 tweak (M.lookup k (cache 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)+ }++-- | /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 = case M.lookup k (cache w) of+ Nothing -> w+ Just i -> (view i w) { focus = M.insert i k (focus w) }++-- | 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+ 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.+--+-- Given a set as a list (no duplicates)+--+-- > swap a b . swap a b == id+--+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:+-- promote w = w { stacks = M.adjust next (current w) (stacks w) }+-- where next [] = []+-- next xs = last xs : init xs+--++-- | 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
+ TODO view
@@ -0,0 +1,29 @@+- 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.
+ XMonad.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS -fglasgow-exts #-}+-----------------------------------------------------------------------------+-- |+-- Module : XMonad.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 X monad, a state monad transformer over IO, for the window+-- manager state, and support routines.+--++module XMonad (+ X, WindowSet, WorkspaceId(..), ScreenId(..), XState(..), Layout(..), LayoutDesc(..),+ runX, io, withDisplay, isRoot, spawn, trace, whenJust, rotateLayout+ ) where++import StackSet (StackSet)++import Control.Monad.State+import System.IO+import System.Posix.Process (executeFile, forkProcess, getProcessStatus)+import System.Exit+import Graphics.X11.Xlib++import qualified Data.Map as M++-- | XState, the window manager state.+-- Just the display, width, height and a window list+data XState = XState+ { display :: Display -- ^ the X11 display++ , 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 :: !WindowSet -- ^ workspace list++ , xineScreens :: ![Rectangle] -- ^ dimensions of each screen+ , defaultLayoutDesc :: !LayoutDesc -- ^ default layout+ , layoutDescs :: !(M.Map WorkspaceId LayoutDesc) -- ^ mapping of workspaces + -- to descriptions of their layouts+ }++type WindowSet = 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)++------------------------------------------------------------------------++-- | The X monad, a StateT transformer over IO encapsulating the window+-- manager state+newtype X a = X (StateT XState IO a)+ deriving (Functor, Monad, MonadIO, MonadState XState)++-- | Run the X monad, given a chunk of X monad code, and an initial state+-- Return the result, and final state+runX :: XState -> X a -> IO ()+runX st (X a) = runStateT a st >> return ()++-- ---------------------------------------------------------------------+-- Convenient wrappers to state++-- | Run a monad action with the current display settings+withDisplay :: (Display -> X ()) -> X ()+withDisplay f = gets display >>= f++-- | True if the given window is the root window+isRoot :: Window -> X Bool+isRoot w = liftM (w==) (gets theRoot)++------------------------------------------------------------------------+-- Layout handling++-- | The different layout modes+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+ }++-- ---------------------------------------------------------------------+-- Utilities++-- | Lift an IO action into the X monad+io :: IO a -> X a+io = liftIO+{-# INLINE io #-}++-- | spawn. Launch an external application+spawn :: String -> X ()+spawn x = io $ do+ pid <- forkProcess $ do+ forkProcess (executeFile "/bin/sh" False ["-c", x] Nothing)+ exitWith ExitSuccess+ return ()+ getProcessStatus True False pid+ return ()++-- | Run a side effecting action with the current workspace. Like 'when' but+whenJust :: Maybe a -> (a -> X ()) -> X ()+whenJust mg f = maybe (return ()) f mg++-- | A 'trace' for the X monad. Logs a string to stderr. The result may+-- be found in your .xsession-errors file+trace :: String -> X ()+trace msg = io $! do hPutStrLn stderr msg; hFlush stderr
+ tests/Properties.hs view
@@ -0,0 +1,347 @@+{-# OPTIONS -fglasgow-exts #-}++import StackSet+import Operations (tile,vtile)++import Debug.Trace+import Data.Word+import Graphics.X11.Xlib.Types (Rectangle(..),Position,Dimension)+import Data.Ratio+import Data.Maybe+import System.Environment+import Control.Exception (assert)+import Control.Monad+import Test.QuickCheck hiding (promote)+import System.IO+import System.Random+import Text.Printf+import Data.List (nub,sort,group,sort,intersperse)+import Data.Map (keys,elems)++-- ---------------------------------------------------------------------+-- QuickCheck properties for the StackSet++-- | Height of stack 'n'+height :: Int -> T -> Int+height i w = length (index i w)++-- build (non-empty) StackSets with between 1 and 100 stacks+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+ return $ fromList (fromIntegral n,sc,ls)+ coarbitrary = error "no coarbitrary for StackSet"++prop_id x = fromList (toList x) == x+ where _ = x :: T++prop_member1 i n m = member i (push i x)+ where x = empty n m :: T++prop_member2 i x = not (member i (delete i x))+ where _ = x :: T++prop_member3 i n m = member i (empty n m :: T) == False++prop_sizepush is n m = n > 0 ==> size (foldr push x is ) == n+ where x = empty n m :: T++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_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++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++------------------------------------------------------------------------++type T = StackSet Int Int Int++prop_delete_uniq i x = not (member i x) ==> delete i x == x+ where _ = x :: T++prop_delete_push i x = not (member i x) ==> delete i (push i x) == x+ where _ = x :: T++prop_delete2 i x =+ delete i x == delete i (delete i x)+ where _ = x :: T++prop_focus1 i x = member i x ==> peek (raiseFocus i x) == Just i+ where _ = x :: T++prop_rotaterotate x = rotate LT (rotate GT x) == x+ where _ = x :: T++prop_viewview r x =+ let n = current x+ sz = size x+ i = r `mod` sz+ in view n (view (fromIntegral i) x) == x++ where _ = x :: T++prop_shiftshift r x =+ let n = current x+ in shift n (shift r x) == x+ where _ = x :: T++prop_fullcache x = cached == allvals where+ cached = sort . keys $ cache x+ allvals = sort . concat . elems $ stacks x+ _ = x :: T++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++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++prop_swap a b xs = swap a b (swap a b ys) == ys+ where ys = nub xs :: [Int]++------------------------------------------------------------------------++-- promote is idempotent+prop_promote2 x = promote (promote x) == (promote x)+ where _ = x :: T++-- 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+ where _ = x :: T++-- the physical screen doesn't change+prop_promotescreen n x = screen n (promote x) == screen n x+ where _ = x :: T++-- 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++------------------------------------------------------------------------+-- 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))++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++instance Arbitrary Rational where+ arbitrary = do+ n <- arbitrary+ d' <- arbitrary+ let d = if d' == 0 then 1 else d'+ return (n % d)+ coarbitrary = undefined++------------------------------------------------------------------------++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 =+ [("read.show ", mytest prop_id)++ ,("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)++ ,("peek/peekStack" , mytest prop_peek_peekStack)+ ,("not . peek/peekStack", mytest prop_notpeek_peekStack)++ ,("delete/not.member", mytest prop_delete_uniq)+ ,("delete idempotent", mytest prop_delete2)+ ,("delete.push identity" , mytest prop_delete_push)++ ,("focus", mytest prop_focus1)++ ,("rotate/rotate ", mytest prop_rotaterotate)++ ,("view/view ", mytest prop_viewview)+ ,("fullcache ", mytest prop_fullcache)+ ,("currentwsvisible ", mytest prop_currentwsvisible)+ ,("ws screen mapping", mytest prop_ws2screen_screen2ws)+ ,("screen/workspace ", mytest prop_screenworkspace)++ ,("promote idempotent", mytest prop_promote2)+ ,("promote focus", mytest prop_promotefocus)+ ,("promote current", mytest prop_promotecurrent)+ ,("promote only swaps", mytest prop_promoterotate)+ ,("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 )++ ]++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) ++ "%"++------------------------------------------------------------------------
+ tests/loc.hs view
@@ -0,0 +1,16 @@+import Control.Monad+import System.Exit++main = do foo <- getContents+ let actual_loc = filter (not.null) $ 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 > 500) $ fail "Too many lines of code!"++isntcomment "" = False+isntcomment ('-':'-':_) = False+isntcomment ('{':'-':_) = False -- pragmas+isntcomment _ = True
+ xmonad.cabal view
@@ -0,0 +1,18 @@+name: xmonad+version: 0.1+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 TODO tests/loc.hs tests/Properties.hs++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