From 41a42c118f1b023d09588fde1fba4028fea5d70b Mon Sep 17 00:00:00 2001
From: Don Stewart <dons@galois.com>
Date: Sun, 14 Oct 2007 00:10:24 +0200
Subject: clean up Layout code a little more
darcs-hash:20071013221024-cba2c-9ea5ee1066d9b30c90d3c58b66854c1ed31c3fb7.gz
---
Operations.hs | 131 +++++++++++++++++++++++++++++++---------------------------
1 file changed, 69 insertions(+), 62 deletions(-)
(limited to 'Operations.hs')
diff --git a/Operations.hs b/Operations.hs
index ec2dd04..0edfbb9 100644
--- a/Operations.hs
+++ b/Operations.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
+{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
-- --------------------------------------------------------------------------
@@ -304,42 +304,44 @@ setFocusX w = withWindowSet $ \ws -> do
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' }}}
+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 modw
- where modw w = if W.tag w `elem` l
- then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
- return $ w { W.layout = maybe (W.layout w) id ml' }
- else return w
+sendMessageToWorkspaces a l = runOnWorkspaces $ \w ->
+ if W.tag w `elem` l
+ then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
+ return $ w { W.layout = maybe (W.layout w) id ml' }
+ else return w
-- | 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 modw
- where modw w = do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
- return $ w { W.layout = maybe (W.layout w) id ml' }
+broadcastMessage a = runOnWorkspaces $ \w -> do
+ ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing
+ return $ w { W.layout = maybe (W.layout w) id ml' }
-- | 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 } }
-
-instance Message Event
+runOnWorkspaces job =do
+ ws <- gets windowset
+ h <- mapM job $ W.hidden ws
+ c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s))
+ $ W.current ws : W.visible ws
+ modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } }
-- | Set the layout of the currently viewed workspace
setLayout :: Layout Window -> X ()
@@ -348,14 +350,21 @@ setLayout l = do
handleMessage (W.layout ws) (SomeMessage ReleaseResources)
windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = l } } }
--- LayoutClass selection manager
+-- | X Events are valid Messages
+instance Message Event
--- This is a layout that allows users to switch between various layout
--- options. This layout accepts three Messages, NextLayout, PrevLayout and
--- JumpToLayout.
+------------------------------------------------------------------------
+-- LayoutClass selection manager
+-- | A layout that allows users to switch between various layout options.
+-- This layout accepts three Messages:
+--
+-- > NextLayout
+-- > PrevLayout
+-- > JumpToLayout.
+--
data ChangeLayout = NextLayout | PrevLayout | JumpToLayout String
- deriving ( Eq, Show, Typeable )
+ deriving (Eq, Show, Typeable)
instance Message ChangeLayout
@@ -368,74 +377,72 @@ instance ReadableLayout Window where
data Select a = Select [Layout a] deriving (Show, Read)
instance ReadableLayout a => LayoutClass Select a where
- doLayout (Select (l:ls)) r s = do
- (x,ml') <- doLayout l r s
- return (x, (\l' -> Select (l':ls)) `fmap` ml')
-
- doLayout (Select []) r s = do
- (x,_) <- doLayout Full r s
- return (x,Nothing)
+ doLayout (Select (l:ls)) r s =
+ second (fmap (Select . (:ls))) `fmap` doLayout l r s
+ doLayout (Select []) r s =
+ second (const Nothing) `fmap` doLayout Full r s
-- respond to messages only when there's an actual choice:
handleMessage (Select (l:ls@(_:_))) m
- | Just NextLayout <- fromMessage m = switchl rls
- | Just PrevLayout <- fromMessage m = switchl rls'
- | Just (JumpToLayout x) <- fromMessage m = switchl (j x)
- | Just ReleaseResources <- fromMessage m =
- do mlls' <- mapM (\ll -> handleMessage ll m) (l:ls)
- let lls' = zipWith (\x mx -> maybe x id mx) (l:ls) mlls'
- return $ Just $ Select lls'
- where rls (x:xs) = xs ++ [x]
- rls [] = []
+ | Just NextLayout <- fromMessage m = switchl rls
+ | Just PrevLayout <- fromMessage m = switchl rls'
+ | Just (JumpToLayout x) <- fromMessage m = switchl (j x)
+ | Just ReleaseResources <- fromMessage m = do -- each branch has a different type
+ mlls' <- mapM (flip handleMessage m) (l:ls)
+ let lls' = zipWith (flip maybe id) (l:ls) mlls'
+ return (Just (Select lls'))
+
+ where rls [] = []
+ rls (x:xs) = xs ++ [x]
rls' = reverse . rls . reverse
+
j s zs = case partition ((s ==) . description) zs of (xs,ys) -> xs++ys
switchl f = do ml' <- handleMessage l (SomeMessage Hide)
return $ Just (Select $ f $ fromMaybe l ml':ls)
-- otherwise, or if we don't understand the message, pass it along to the real layout:
- handleMessage (Select (l:ls)) m = do
- ml' <- handleMessage l m
- return $ (\l' -> Select (l':ls)) `fmap` ml'
+ handleMessage (Select (l:ls)) m =
+ fmap (Select . (:ls)) `fmap` handleMessage l m
-- Unless there is no layout...
handleMessage (Select []) _ = return Nothing
description (Select (x:_)) = description x
description _ = "default"
+
--
--- Builtin layout algorithms:
+-- | Builtin layout algorithms:
--
--- fullscreen mode
--- tall mode
+-- > fullscreen mode
+-- > tall mode
--
-- The latter algorithms support the following operations:
--
--- Shrink
--- Expand
+-- > Shrink
+-- > Expand
--
-
data Resize = Shrink | Expand deriving Typeable
+-- | You can also increase the number of clients in the master pane
data IncMasterN = IncMasterN Int deriving Typeable
instance Message Resize
instance Message IncMasterN
--- simple fullscreen mode, just render all windows fullscreen.
--- a plea for tuple sections: map . (,sc)
-data Full a = Full deriving ( Show, Read )
+-- | Simple fullscreen mode, just render all windows fullscreen.
+data Full a = Full deriving (Show, Read)
instance LayoutClass Full a
---
--- The tiling mode of xmonad, and its operations.
---
-data Tall a = Tall Int Rational Rational deriving ( Show, Read )
+
+-- | The inbuilt tiling mode of xmonad, and its operations.
+data Tall a = Tall Int Rational Rational deriving (Show, Read)
instance LayoutClass Tall a where
doLayout (Tall nmaster _ frac) r =
- return . (\x->(x,Nothing)) .
+ return . (flip (,) Nothing) .
ap zip (tile frac r nmaster . length) . W.integrate
+
pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m)
,fmap incmastern (fromMessage m)]
where resize Shrink = Tall nmaster delta (max 0 $ frac-delta)
@@ -617,7 +624,7 @@ mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
type D = (Dimension, Dimension)
-- | Reduce the dimensions if needed to comply to the given SizeHints.
-applySizeHints :: Integral a => SizeHints -> (a,a) -> D
+applySizeHints :: Integral a => SizeHints -> (a,a) -> D
applySizeHints sh (w,h) = applySizeHints' sh (fromIntegral $ max 1 w,
fromIntegral $ max 1 h)
--
cgit v1.2.3