diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -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)]] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/Operations.hs b/Operations.hs new file mode 100644 --- /dev/null +++ b/Operations.hs @@ -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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/StackSet.hs b/StackSet.hs new file mode 100644 --- /dev/null +++ b/StackSet.hs @@ -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 diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -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. diff --git a/XMonad.hs b/XMonad.hs new file mode 100644 --- /dev/null +++ b/XMonad.hs @@ -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 diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -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) ++ "%" + +------------------------------------------------------------------------ diff --git a/tests/loc.hs b/tests/loc.hs new file mode 100644 --- /dev/null +++ b/tests/loc.hs @@ -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 diff --git a/xmonad.cabal b/xmonad.cabal new file mode 100644 --- /dev/null +++ b/xmonad.cabal @@ -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