Hierarchify

darcs-hash:20071101180846-a5988-25ba1c9ce37a35c1533e4075cc9494c6f7dd5ade

1 files changed, 0 insertions, 505 deletions

diff --git a/Operations.hs b/Operations.hs
deleted file mode 100644
index b911cf5..0000000
--- a/Operations.hs
+++ /dev/null
@@ -1,505 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fglasgow-exts    #-} -- For deriving Data/Typeable
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
-
--- --------------------------------------------------------------------------
--- |
--- Module      :  Operations.hs
--- Copyright   :  (c) Spencer Janssen 2007
--- License     :  BSD3-style (see LICENSE)
---
--- Maintainer  :  dons@cse.unsw.edu.au
--- Stability   :  unstable
--- Portability :  not portable, Typeable deriving, mtl, posix
---
--- Operations.
---
------------------------------------------------------------------------------
-
-module Operations where
-
-import XMonad
-import Layouts (Full(..))
-import qualified StackSet as W
-
-import Data.Maybe
-import Data.List            (nub, (\\), find)
-import Data.Bits            ((.|.), (.&.), complement)
-import Data.Ratio
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Control.Monad.State
-import Control.Monad.Reader
-
-import System.IO
-import Graphics.X11.Xlib
-import Graphics.X11.Xinerama (getScreenInfo)
-import Graphics.X11.Xlib.Extras
-
--- ---------------------------------------------------------------------
--- |
--- Window manager operations
--- manage. Add a new window to be managed in the current workspace.
--- Bring it into focus.
---
--- Whether the window is already managed, or not, it is mapped, has its
--- border set, and its event mask set.
---
-manage :: Window -> X ()
-manage w = whenX (fmap not $ isClient w) $ withDisplay $ \d -> do
-    sh <- io $ getWMNormalHints d w
-
-    let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh
-    isTransient <- isJust `liftM` io (getTransientForHint d w)
-
-    (sc, rr) <- floatLocation w
-    -- ensure that float windows don't go over the edge of the screen
-    let adjust (W.RationalRect x y wid h) | x + wid > 1 || y + h > 1 || x < 0 || y < 0
-                                              = W.RationalRect (0.5 - wid/2) (0.5 - h/2) wid h
-        adjust r = r
-
-        f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws
-             | otherwise                  = W.insertUp w ws
-            where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws
-
-    n <- fmap (fromMaybe "") $ io $ fetchName d w
-    (ClassHint rn rc) <- io $ getClassHint d w
-    mh <- asks (manageHook . config)
-    g <- mh w n rn rc `catchX` return id
-    windows (g . f)
-
--- | unmanage. A window no longer exists, remove it from the window
--- list, on whatever workspace it is.
---
--- should also unmap?
---
-unmanage :: Window -> X ()
-unmanage w = do
-    windows (W.delete w)
-    setWMState w withdrawnState
-    modify (\s -> s {mapped = S.delete w (mapped s), waitingUnmap = M.delete w (waitingUnmap s)})
-
--- | Modify the size of the status gap at the top of the current screen
--- Taking a function giving the current screen, and current geometry.
-modifyGap :: (Int -> (Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X ()
-modifyGap f = do
-    windows $ \ws@(W.StackSet { W.current = c@(W.Screen { W.screenDetail = sd }) }) ->
-        let n = fromIntegral . W.screen $ c
-            g = f n . statusGap $ sd
-        in ws { W.current = c { W.screenDetail = sd { statusGap = g } } }
-
--- | Kill the currently focused client. If we do kill it, we'll get a
--- delete notify back from X.
---
--- There are two ways to delete a window. Either just kill it, or if it
--- supports the delete protocol, send a delete event (e.g. firefox)
---
-kill :: X ()
-kill = withDisplay $ \d -> withFocused $ \w -> do
-    wmdelt <- atom_WM_DELETE_WINDOW  ;  wmprot <- atom_WM_PROTOCOLS
-
-    protocols <- io $ getWMProtocols d w
-    io $ if wmdelt `elem` protocols
-        then allocaXEvent $ \ev -> do
-                setEventType ev clientMessage
-                setClientMessageEvent ev w wmprot 32 wmdelt 0
-                sendEvent d w False noEventMask ev
-        else killClient d w >> return ()
-
--- ---------------------------------------------------------------------
--- Managing windows
-
--- | windows. Modify the current window list with a pure function, and refresh
-windows :: (WindowSet -> WindowSet) -> X ()
-windows f = do
-    XState { windowset = old } <- get
-    let oldvisible = concatMap (W.integrate' . W.stack . W.workspace) $ W.current old : W.visible old
-        ws = f old
-    XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask
-    mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old)
-    whenJust (W.peek old) $ \otherw -> io $ setWindowBorder d otherw nbc
-    modify (\s -> s { windowset = ws })
-
-    -- notify non visibility
-    let tags_oldvisible = map (W.tag . W.workspace) $ W.current old : W.visible old
-        gottenhidden    = filter (`elem` tags_oldvisible) $ map W.tag $ W.hidden ws
-    sendMessageToWorkspaces Hide gottenhidden
-
-    -- for each workspace, layout the currently visible workspaces
-    let allscreens     = W.screens ws
-        summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.workspace) allscreens
-    visible <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do
-        let n      = W.tag (W.workspace w)
-            this   = W.view n ws
-            l = W.layout (W.workspace w)
-            flt = filter (flip M.member (W.floating ws)) (W.index this)
-            tiled = (W.stack . W.workspace . W.current $ this)
-                    >>= W.filter (`M.notMember` W.floating ws)
-                    >>= W.filter (`notElem` vis)
-            (SD (Rectangle sx sy sw sh)
-                (gt,gb,gl,gr))          = W.screenDetail w
-            viewrect = Rectangle (sx + fromIntegral gl)        (sy + fromIntegral gt)
-                                 (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb))
-
-        -- just the tiled windows:
-        -- now tile the windows on this workspace, modified by the gap
-        (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (Layout Full) viewrect tiled
-        mapM_ (uncurry tileWindow) rs
-        whenJust ml' $ \l' -> runOnWorkspaces (\ww -> if W.tag ww == n
-                                                      then return $ ww { W.layout = l'}
-                                                      else return ww)
-
-        -- now the floating windows:
-        -- move/resize the floating windows, if there are any
-        forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $
-          \(W.RationalRect rx ry rw rh) -> do
-            tileWindow fw $ Rectangle
-                (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry))
-                (floor (toRational sw*rw)) (floor (toRational sh*rh))
-
-        let vs = flt ++ map fst rs
-        io $ restackWindows d vs
-        -- return the visible windows for this workspace:
-        return vs
-
-    whenJust (W.peek ws) $ \w -> io $ setWindowBorder d w fbc
-    setTopFocus
-    asks (logHook . config) >>= userCode
-    -- io performGC -- really helps, but seems to trigger GC bugs?
-
-    -- hide every window that was potentially visible before, but is not
-    -- given a position by a layout now.
-    mapM_ hide (nub oldvisible \\ visible)
-
-    clearEvents enterWindowMask
-
--- | setWMState.  set the WM_STATE property
-setWMState :: Window -> Int -> X ()
-setWMState w v = withDisplay $ \dpy -> do
-    a <- atom_WM_STATE
-    io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none]
-
--- | hide. Hide a window by unmapping it, and setting Iconified.
-hide :: Window -> X ()
-hide w = whenX (gets (S.member w . mapped)) $ withDisplay $ \d -> do
-    io $ do selectInput d w (clientMask .&. complement structureNotifyMask)
-            unmapWindow d w
-            selectInput d w clientMask
-    setWMState w iconicState
-    -- this part is key: we increment the waitingUnmap counter to distinguish
-    -- between client and xmonad initiated unmaps.
-    modify (\s -> s { waitingUnmap = M.insertWith (+) w 1 (waitingUnmap s)
-                    , mapped       = S.delete w (mapped s) })
-
--- | reveal. Show a window by mapping it and setting Normal
--- this is harmless if the window was already visible
-reveal :: Window -> X ()
-reveal w = withDisplay $ \d -> do
-    setWMState w normalState
-    io $ mapWindow d w
-    modify (\s -> s { mapped = S.insert w (mapped s) })
-
--- | The client events that xmonad is interested in
-clientMask :: EventMask
-clientMask = structureNotifyMask .|. enterWindowMask .|. propertyChangeMask
-
--- | Set some properties when we initially gain control of a window
-setInitialProperties :: Window -> X ()
-setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do
-    setWMState w iconicState
-    io $ selectInput d w $ clientMask
-    bw <- asks (borderWidth . config)
-    io $ setWindowBorderWidth d w bw
-    -- we must initially set the color of new windows, to maintain invariants
-    -- required by the border setting in 'windows'
-    io $ setWindowBorder d w nb
-
--- | refresh. Render the currently visible workspaces, as determined by
--- the StackSet. Also, set focus to the focused window.
---
--- This is our 'view' operation (MVC), in that it pretty prints our model
--- with X calls.
---
-refresh :: X ()
-refresh = windows id
-
--- | clearEvents.  Remove all events of a given type from the event queue.
-clearEvents :: EventMask -> X ()
-clearEvents mask = withDisplay $ \d -> io $ do
-    sync d False
-    allocaXEvent $ \p -> fix $ \again -> do
-        more <- checkMaskEvent d mask p
-        when more again -- beautiful
-
--- | tileWindow. Moves and resizes w such that it fits inside the given
--- rectangle, including its border.
-tileWindow :: Window -> Rectangle -> X ()
-tileWindow w r = withDisplay $ \d -> do
-    bw <- (fromIntegral . wa_border_width) `fmap` io (getWindowAttributes d w)
-    -- give all windows at least 1x1 pixels
-    let least x | x <= bw*2  = 1
-                | otherwise  = x - bw*2
-    io $ moveResizeWindow d w (rect_x r) (rect_y r)
-                              (least $ rect_width r) (least $ rect_height r)
-    reveal w
-
--- ---------------------------------------------------------------------
-
--- | rescreen.  The screen configuration may have changed (due to
--- xrandr), update the state and refresh the screen, and reset the gap.
-rescreen :: X ()
-rescreen = do
-    xinesc <- withDisplay (io . getScreenInfo)
-
-    windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) ->
-        let (xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs
-            (a:as)   = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs
-            sgs      = map (statusGap . W.screenDetail) (v:vs)
-            gs       = take (length xinesc) (sgs ++ repeat (0,0,0,0))
-        in  ws { W.current = a
-               , W.visible = as
-               , W.hidden  = ys }
-
--- ---------------------------------------------------------------------
-
--- | setButtonGrab. Tell whether or not to intercept clicks on a given window
-setButtonGrab :: Bool -> Window -> X ()
-setButtonGrab grab w = withDisplay $ \d -> io $
-    if grab
-        then forM_ [button1, button2, button3] $ \b ->
-            grabButton d b anyModifier w False buttonPressMask
-                       grabModeAsync grabModeSync none none
-        else ungrabButton d anyButton anyModifier w
-
--- ---------------------------------------------------------------------
--- Setting keyboard focus
-
--- | Set the focus to the window on top of the stack, or root
-setTopFocus :: X ()
-setTopFocus = withWindowSet $ maybe (setFocusX =<< asks theRoot) setFocusX . W.peek
-
--- | Set focus explicitly to window 'w' if it is managed by us, or root.
--- This happens if X notices we've moved the mouse (and perhaps moved
--- the mouse to a new screen).
-focus :: Window -> X ()
-focus w = withWindowSet $ \s -> do
-    if W.member w s then when (W.peek s /= Just w) $ windows (W.focusWindow w)
-                    else whenX (isRoot w) $ setFocusX w
-
--- | Call X to set the keyboard focus details.
-setFocusX :: Window -> X ()
-setFocusX w = withWindowSet $ \ws -> do
-    dpy <- asks display
-
-    -- clear mouse button grab and border on other windows
-    forM_ (W.current ws : W.visible ws) $ \wk -> do
-        forM_ (W.index (W.view (W.tag (W.workspace wk)) ws)) $ \otherw -> do
-            setButtonGrab True otherw
-
-    -- If we ungrab buttons on the root window, we lose our mouse bindings.
-    whenX (not `liftM` isRoot w) $ setButtonGrab False w
-    io $ do setInputFocus dpy w revertToPointerRoot 0
-            -- raiseWindow dpy w
-
-------------------------------------------------------------------------
--- Message handling
-
--- | Throw a message to the current LayoutClass possibly modifying how we
--- layout the windows, then refresh.
-sendMessage :: Message a => a -> X ()
-sendMessage a = do
-    w <- (W.workspace . W.current) `fmap` gets windowset
-    ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
-    whenJust ml' $ \l' -> do
-        windows $ \ws -> ws { W.current = (W.current ws)
-                                { W.workspace = (W.workspace $ W.current ws)
-                                  { W.layout = l' }}}
-
--- | Send a message to a list of workspaces' layouts, without necessarily refreshing.
-sendMessageToWorkspaces :: Message a => a -> [WorkspaceId] -> X ()
-sendMessageToWorkspaces a l = runOnWorkspaces $ \w ->
-   if W.tag w `elem` l
-      then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
-              return $ w { W.layout = maybe (W.layout w) id ml' }
-      else return w
-
--- | Send a message to all visible layouts, without necessarily refreshing.
--- This is how we implement the hooks, such as UnDoLayout.
-broadcastMessage :: Message a => a -> X ()
-broadcastMessage a = runOnWorkspaces $ \w -> do
-    ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
-    return $ w { W.layout = maybe (W.layout w) id ml' }
-
--- | This is basically a map function, running a function in the X monad on
--- each workspace with the output of that function being the modified workspace.
-runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X ()
-runOnWorkspaces job =do
-    ws <- gets windowset
-    h <- mapM job $ W.hidden ws
-    c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s))
-             $ W.current ws : W.visible ws
-    modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } }
-
--- | Set the layout of the currently viewed workspace
-setLayout :: Layout Window -> X ()
-setLayout l = do
-    ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) <- gets windowset
-    handleMessage (W.layout ws) (SomeMessage ReleaseResources)
-    windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = l } } }
-
-------------------------------------------------------------------------
--- Utilities
-
--- | Return workspace visible on screen 'sc', or Nothing.
-screenWorkspace :: ScreenId -> X (Maybe WorkspaceId)
-screenWorkspace sc = withWindowSet $ return . W.lookupWorkspace sc
-
--- | Apply an X operation to the currently focused window, if there is one.
-withFocused :: (Window -> X ()) -> X ()
-withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f
-
--- | True if window is under management by us
-isClient :: Window -> X Bool
-isClient w = withWindowSet $ return . W.member w
-
--- | Combinations of extra modifier masks we need to grab keys\/buttons for.
--- (numlock and capslock)
-extraModifiers :: X [KeyMask]
-extraModifiers = do
-    nlm <- asks (numlockMask . config)
-    return [0, nlm, lockMask, nlm .|. lockMask ]
-
--- | Strip numlock\/capslock from a mask
-cleanMask :: KeyMask -> X KeyMask
-cleanMask km = do
-    nlm <- asks (numlockMask . config)
-    return (complement (nlm .|. lockMask) .&. km)
-
--- | Get the Pixel value for a named color
-initColor :: Display -> String -> IO Pixel
-initColor dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c
-    where colormap = defaultColormap dpy (defaultScreen dpy)
-
-------------------------------------------------------------------------
--- | Floating layer support
-
--- | Given a window, find the screen it is located on, and compute
--- the geometry of that window wrt. that screen.
-floatLocation :: Window -> X (ScreenId, W.RationalRect)
-floatLocation w = withDisplay $ \d -> do
-    ws <- gets windowset
-    wa <- io $ getWindowAttributes d w
-    bw <- fi `fmap` asks (borderWidth . config)
-
-    -- XXX horrible
-    let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.screens ws
-        sr = screenRect . W.screenDetail $ sc
-        rr = W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr))
-                            ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr))
-                            (fi (wa_width  wa + bw*2) % fi (rect_width sr))
-                            (fi (wa_height wa + bw*2) % fi (rect_height sr))
-
-    return (W.screen $ sc, rr)
-  where fi x = fromIntegral x
-        pointWithin :: Integer -> Integer -> Rectangle -> Bool
-        pointWithin x y r = x >= fi (rect_x r) &&
-                            x <  fi (rect_x r) + fi (rect_width r) &&
-                            y >= fi (rect_y r) &&
-                            y <  fi (rect_y r) + fi (rect_height r)
-
--- | Make a tiled window floating, using its suggested rectangle
-float :: Window -> X ()
-float w = do
-    (sc, rr) <- floatLocation w
-    windows $ \ws -> W.float w rr . fromMaybe ws $ do
-        i <- W.findTag w ws
-        guard $ i `elem` map (W.tag . W.workspace) (W.screens ws)
-        f <- W.peek ws
-        sw <- W.lookupWorkspace sc ws
-        return (W.focusWindow f . W.shiftWin sw w $ ws)
-
--- ---------------------------------------------------------------------
--- Mouse handling
-
--- | Accumulate mouse motion events
-mouseDrag :: (Position -> Position -> X ()) -> X () -> X ()
-mouseDrag f done = do
-    drag <- gets dragging
-    case drag of
-        Just _ -> return () -- error case? we're already dragging
-        Nothing -> do
-            XConf { theRoot = root, display = d } <- ask
-            io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask)
-                    grabModeAsync grabModeAsync none none currentTime
-            modify $ \s -> s { dragging = Just (motion, cleanup) }
- where
-    cleanup = do
-        withDisplay $ io . flip ungrabPointer currentTime
-        modify $ \s -> s { dragging = Nothing }
-        done
-    motion x y = do z <- f x y
-                    clearEvents pointerMotionMask
-                    return z
-
--- | XXX comment me
-mouseMoveWindow :: Window -> X ()
-mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do
-    io $ raiseWindow d w
-    wa <- io $ getWindowAttributes d w
-    (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w
-    let ox = fromIntegral ox'
-        oy = fromIntegral oy'
-    mouseDrag (\ex ey -> io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
-                                             (fromIntegral (fromIntegral (wa_y wa) + (ey - oy))))
-              (float w)
-
--- | XXX comment me
-mouseResizeWindow :: Window -> X ()
-mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
-    io $ raiseWindow d w
-    wa <- io $ getWindowAttributes d w
-    sh <- io $ getWMNormalHints d w
-    io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa))
-    mouseDrag (\ex ey -> do
-                 io $ resizeWindow d w `uncurry`
-                    applySizeHints sh (ex - fromIntegral (wa_x wa),
-                                       ey - fromIntegral (wa_y wa)))
-              (float w)
-
--- ---------------------------------------------------------------------
--- | Support for window size hints
-
-type D = (Dimension, Dimension)
-
--- | Reduce the dimensions if needed to comply to the given SizeHints.
-applySizeHints :: Integral a => SizeHints -> (a,a) -> D
-applySizeHints sh (w,h) = applySizeHints' sh (fromIntegral $ max 1 w,
-                                              fromIntegral $ max 1 h)
-
--- | XXX comment me
-applySizeHints' :: SizeHints -> D -> D
-applySizeHints' sh =
-      maybe id applyMaxSizeHint                   (sh_max_size   sh)
-    . maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size  sh)
-    . maybe id applyResizeIncHint                 (sh_resize_inc sh)
-    . maybe id applyAspectHint                    (sh_aspect     sh)
-    . maybe id (\(bw,bh) (w,h)   -> (w-bw, h-bh)) (sh_base_size  sh)
-
--- | Reduce the dimensions so their aspect ratio falls between the two given aspect ratios.
-applyAspectHint :: (D, D) -> D -> D
-applyAspectHint ((minx, miny), (maxx, maxy)) x@(w,h)
-    | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = x
-    | w * maxy > h * maxx                         = (h * maxx `div` maxy, h)
-    | w * miny < h * minx                         = (w, w * miny `div` minx)
-    | otherwise                                   = x
-
--- | Reduce the dimensions so they are a multiple of the size increments.
-applyResizeIncHint :: D -> D -> D
-applyResizeIncHint (iw,ih) x@(w,h) =
-    if iw > 0 && ih > 0 then (w - w `mod` iw, h - h `mod` ih) else x
-
--- | Reduce the dimensions if they exceed the given maximum dimensions.
-applyMaxSizeHint  :: D -> D -> D
-applyMaxSizeHint (mw,mh) x@(w,h) =
-    if mw > 0 && mh > 0 then (min w mw,min h mh) else x