diff options
Diffstat (limited to 'XMonad/Layout')
29 files changed, 3183 insertions, 0 deletions
diff --git a/XMonad/Layout/Accordion.hs b/XMonad/Layout/Accordion.hs new file mode 100644 index 0000000..f844c22 --- /dev/null +++ b/XMonad/Layout/Accordion.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Accordion +-- Copyright : (c) glasser@mit.edu +-- License : BSD +-- +-- Maintainer : glasser@mit.edu +-- Stability : unstable +-- Portability : unportable +-- +-- LayoutClass that puts non-focused windows in ribbons at the top and bottom +-- of the screen. +----------------------------------------------------------------------------- + +module XMonad.Layout.Accordion ( + -- * Usage + -- $usage + Accordion(Accordion)) where + +import XMonad +import XMonad.Layouts +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Data.Ratio + +-- $usage +-- > import XMonad.Layout.Accordion +-- > layouts = [ Layout Accordion ] + +-- %import XMonad.Layout.Accordion +-- %layout , Layout Accordion + +data Accordion a = Accordion deriving ( Read, Show ) + +instance LayoutClass Accordion Window where + pureLayout _ sc ws = zip ups tops ++ [(W.focus ws, mainPane)] ++ zip dns bottoms + where + ups = W.up ws + dns = W.down ws + (top, allButTop) = splitVerticallyBy (1%8 :: Ratio Int) sc + (center, bottom) = splitVerticallyBy (6%7 :: Ratio Int) allButTop + (allButBottom, _) = splitVerticallyBy (7%8 :: Ratio Int) sc + mainPane | ups /= [] && dns /= [] = center + | ups /= [] = allButTop + | dns /= [] = allButBottom + | otherwise = sc + tops = if ups /= [] then splitVertically (length ups) top else [] + bottoms = if dns /= [] then splitVertically (length dns) bottom else [] diff --git a/XMonad/Layout/Circle.hs b/XMonad/Layout/Circle.hs new file mode 100644 index 0000000..2d85dfc --- /dev/null +++ b/XMonad/Layout/Circle.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Circle +-- Copyright : (c) Peter De Wachter +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Peter De Wachter <pdewacht@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- Circle is an elliptical, overlapping layout, by Peter De Wachter +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Circle ( + -- * Usage + -- $usage + Circle (..) + ) where -- actually it's an ellipse + +import Data.List +import Graphics.X11.Xlib +import XMonad +import XMonad.StackSet (integrate, peek) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Circle +-- > layouts = [ Layout Circle ] + +-- %import XMonad.Layout.Circle + +data Circle a = Circle deriving ( Read, Show ) + +instance LayoutClass Circle Window where + doLayout Circle r s = do layout <- raiseFocus $ circleLayout r $ integrate s + return (layout, Nothing) + +circleLayout :: Rectangle -> [a] -> [(a, Rectangle)] +circleLayout _ [] = [] +circleLayout r (w:ws) = master : rest + where master = (w, center r) + rest = zip ws $ map (satellite r) [0, pi * 2 / fromIntegral (length ws) ..] + +raiseFocus :: [(Window, Rectangle)] -> X [(Window, Rectangle)] +raiseFocus xs = do focused <- withWindowSet (return . peek) + return $ case find ((== focused) . Just . fst) xs of + Just x -> x : delete x xs + Nothing -> xs + +center :: Rectangle -> Rectangle +center (Rectangle sx sy sw sh) = Rectangle x y w h + where s = sqrt 2 :: Double + w = round (fromIntegral sw / s) + h = round (fromIntegral sh / s) + x = sx + fromIntegral (sw - w) `div` 2 + y = sy + fromIntegral (sh - h) `div` 2 + +satellite :: Rectangle -> Double -> Rectangle +satellite (Rectangle sx sy sw sh) a = Rectangle (sx + round (rx + rx * cos a)) + (sy + round (ry + ry * sin a)) + w h + where rx = fromIntegral (sw - w) / 2 + ry = fromIntegral (sh - h) / 2 + w = sw * 10 `div` 25 + h = sh * 10 `div` 25 + diff --git a/XMonad/Layout/Combo.hs b/XMonad/Layout/Combo.hs new file mode 100644 index 0000000..a89f281 --- /dev/null +++ b/XMonad/Layout/Combo.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Combo +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +-- A layout that combines multiple layouts. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Combo ( + -- * Usage + -- $usage + combineTwo, + CombineTwo + ) where + +import Control.Arrow ( first ) +import Data.List ( delete, intersect, (\\) ) +import Data.Maybe ( isJust ) +import XMonad +import XMonad.StackSet ( integrate, Stack(..) ) +import XMonad.Util.Invisible +import XMonad.Layout.WindowNavigation ( MoveWindowToWindow(..) ) +import qualified XMonad.StackSet as W ( differentiate ) + +-- $usage +-- +-- To use this layout write, in your Config.hs: +-- +-- > import XMonad.Layout.Combo +-- +-- and add something like +-- +-- > combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf) +-- +-- to your layouts. + +-- combineTwo is a new simple layout combinator. It allows the combination +-- of two layouts using a third to split the screen between the two, but +-- has the advantage of allowing you to dynamically adjust the layout, in +-- terms of the number of windows in each sublayout. To do this, use +-- WindowNavigation, and add the following key bindings (or something +-- similar): + +-- , ((modMask .|. controlMask .|. shiftMask, xK_Right), sendMessage $ Move R) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Left), sendMessage $ Move L) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Up), sendMessage $ Move U) +-- , ((modMask .|. controlMask .|. shiftMask, xK_Down), sendMessage $ Move D) + +-- These bindings will move a window into the sublayout that is +-- up/down/left/right of its current position. Note that there is some +-- weirdness in combineTwo, in that the mod-tab focus order is not very +-- closely related to the layout order. This is because we're forced to +-- keep track of the window positions sparately, and this is ugly. If you +-- don't like this, lobby for hierarchical stacks in core xmonad or go +-- reimelement the core of xmonad yourself. + +-- %import XMonad.Layout.Combo +-- %layout , combineTwo (TwoPane 0.03 0.5) (tabbed shrinkText defaultTConf) (tabbed shrinkText defaultTConf) + +data CombineTwo l l1 l2 a = C2 [a] [a] (l ()) (l1 a) (l2 a) + deriving (Read, Show) + +combineTwo :: (Read a, Eq a, LayoutClass super (), LayoutClass l1 a, LayoutClass l2 a) => + super () -> l1 a -> l2 a -> CombineTwo super l1 l2 a +combineTwo = C2 [] [] + +instance (LayoutClass l (), LayoutClass l1 a, LayoutClass l2 a, Read a, Show a, Eq a, Typeable a) + => LayoutClass (CombineTwo l l1 l2) a where + doLayout (C2 f w2 super l1 l2) rinput s = arrange (integrate s) + where arrange [] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage Hide) + l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage Hide) + return ([], Just $ C2 [] [] super l1' l2') + arrange [w] = do l1' <- maybe l1 id `fmap` handleMessage l1 (SomeMessage Hide) + l2' <- maybe l2 id `fmap` handleMessage l2 (SomeMessage Hide) + return ([(w,rinput)], Just $ C2 [w] [w] super l1' l2') + arrange origws = + do let w2' = case origws `intersect` w2 of [] -> [head origws] + [x] -> [x] + x -> case origws \\ x of + [] -> init x + _ -> x + superstack = if focus s `elem` w2' + then Stack { focus=(), up=[], down=[()] } + else Stack { focus=(), up=[], down=[()] } + s1 = differentiate f' (origws \\ w2') + s2 = differentiate f' w2' + f' = focus s:delete (focus s) f + ([((),r1),((),r2)], msuper') <- doLayout super rinput superstack + (wrs1, ml1') <- runLayout l1 r1 s1 + (wrs2, ml2') <- runLayout l2 r2 s2 + return (wrs1++wrs2, Just $ C2 f' w2' + (maybe super id msuper') (maybe l1 id ml1') (maybe l2 id ml2')) + handleMessage (C2 f ws2 super l1 l2) m + | Just (MoveWindowToWindow w1 w2) <- fromMessage m, + w1 `notElem` ws2, + w2 `elem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m + l2' <- maybe l2 id `fmap` handleMessage l2 m + return $ Just $ C2 f (w1:ws2) super l1' l2' + | Just (MoveWindowToWindow w1 w2) <- fromMessage m, + w1 `elem` ws2, + w2 `notElem` ws2 = do l1' <- maybe l1 id `fmap` handleMessage l1 m + l2' <- maybe l2 id `fmap` handleMessage l2 m + let ws2' = case delete w1 ws2 of [] -> [w2] + x -> x + return $ Just $ C2 f ws2' super l1' l2' + | otherwise = do ml1' <- broadcastPrivate m [l1] + ml2' <- broadcastPrivate m [l2] + msuper' <- broadcastPrivate m [super] + if isJust msuper' || isJust ml1' || isJust ml2' + then return $ Just $ C2 f ws2 + (maybe super head msuper') + (maybe l1 head ml1') + (maybe l2 head ml2') + else return Nothing + description (C2 _ _ super l1 l2) = "combining "++ description l1 ++" and "++ + description l2 ++" with "++ description super + + +differentiate :: Eq q => [q] -> [q] -> Maybe (Stack q) +differentiate (z:zs) xs | z `elem` xs = Just $ Stack { focus=z + , up = reverse $ takeWhile (/=z) xs + , down = tail $ dropWhile (/=z) xs } + | otherwise = differentiate zs xs +differentiate [] xs = W.differentiate xs + +broadcastPrivate :: LayoutClass l b => SomeMessage -> [l b] -> X (Maybe [l b]) +broadcastPrivate a ol = do nml <- mapM f ol + if any isJust nml + then return $ Just $ zipWith ((flip maybe) id) ol nml + else return Nothing + where f l = handleMessage l a `catchX` return Nothing diff --git a/XMonad/Layout/Dishes.hs b/XMonad/Layout/Dishes.hs new file mode 100644 index 0000000..ecc27db --- /dev/null +++ b/XMonad/Layout/Dishes.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Dishes +-- Copyright : (c) Jeremy Apthorp +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jeremy Apthorp <nornagon@gmail.com> +-- Stability : unstable +-- Portability : portable +-- +-- Dishes is a layout that stacks extra windows underneath the master +-- windows. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Dishes ( + -- * Usage + -- $usage + Dishes (..) + ) where + +import Data.List +import XMonad +import XMonad.Layouts +import XMonad.StackSet (integrate) +import Control.Monad (ap) +import Graphics.X11.Xlib + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Dishes +-- +-- and add the following line to your 'layouts' +-- +-- > , Layout $ Dishes 2 (1%6) + +-- %import XMonad.Layout.Dishes +-- %layout , Layout $ Dishes 2 (1%6) + +data Dishes a = Dishes Int Rational deriving (Show, Read) +instance LayoutClass Dishes a where + doLayout (Dishes nmaster h) r = + return . (\x->(x,Nothing)) . + ap zip (dishes h r nmaster . length) . integrate + pureMessage (Dishes nmaster h) m = fmap incmastern (fromMessage m) + where incmastern (IncMasterN d) = Dishes (max 0 (nmaster+d)) h + +dishes :: Rational -> Rectangle -> Int -> Int -> [Rectangle] +dishes h s nmaster n = if n <= nmaster + then splitHorizontally n s + else ws + where + (m,rest) = splitVerticallyBy (1 - (fromIntegral $ n - nmaster) * h) s + ws = splitHorizontally nmaster m ++ splitVertically (n - nmaster) rest diff --git a/XMonad/Layout/DragPane.hs b/XMonad/Layout/DragPane.hs new file mode 100644 index 0000000..8428d2b --- /dev/null +++ b/XMonad/Layout/DragPane.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.DragPane +-- Copyright : (c) Spencer Janssen <sjanssen@cse.unl.edu> +-- David Roundy <droundy@darcs.net>, +-- Andrea Rossato <andrea.rossato@unibz.it> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Andrea Rossato <andrea.rossato@unibz.it> +-- Stability : unstable +-- Portability : unportable +-- +-- Layouts that splits the screen either horizontally or vertically and +-- shows two windows. The first window is always the master window, and +-- the other is either the currently focused window or the second window in +-- layout order. + +----------------------------------------------------------------------------- + +module XMonad.Layout.DragPane ( + -- * Usage + -- $usage + dragPane + , DragPane, DragType (..) + ) where + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import XMonad +import Data.Bits +import Data.Unique + +import XMonad.Layouts +import XMonad.Operations +import qualified XMonad.StackSet as W +import XMonad.Util.Invisible +import XMonad.Util.XUtils + +-- $usage +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.DragPane +-- +-- and add, to the list of layouts: +-- +-- > Layout $ dragPane Horizontal 0.1 0.5 + +halfHandleWidth :: Integral a => a +halfHandleWidth = 1 + +handleColor :: String +handleColor = "#000000" + +dragPane :: DragType -> Double -> Double -> DragPane a +dragPane t x y = DragPane (I Nothing) t x y + +data DragPane a = + DragPane (Invisible Maybe (Window,Rectangle,Int)) DragType Double Double + deriving ( Show, Read ) + +data DragType = Horizontal | Vertical deriving ( Show, Read ) + +instance LayoutClass DragPane a where + doLayout d@(DragPane _ Vertical _ _) = doLay id d + doLayout d@(DragPane _ Horizontal _ _) = doLay mirrorRect d + handleMessage = handleMess + +data SetFrac = SetFrac Int Double deriving ( Show, Read, Eq, Typeable ) +instance Message SetFrac + +handleMess :: DragPane a -> SomeMessage -> X (Maybe (DragPane a)) +handleMess d@(DragPane mb@(I (Just (win,_,ident))) ty delta split) x + | Just e <- fromMessage x :: Maybe Event = do handleEvent d e + return Nothing + | Just Hide <- fromMessage x = do hideWindow win + return $ Just (DragPane mb ty delta split) + | Just ReleaseResources <- fromMessage x = do deleteWindow win + return $ Just (DragPane (I Nothing) ty delta split) + -- layout specific messages + | Just Shrink <- fromMessage x = return $ Just (DragPane mb ty delta (split - delta)) + | Just Expand <- fromMessage x = return $ Just (DragPane mb ty delta (split + delta)) + | Just (SetFrac ident' frac) <- fromMessage x, ident' == ident = do + return $ Just (DragPane mb ty delta frac) +handleMess _ _ = return Nothing + +handleEvent :: DragPane a -> Event -> X () +handleEvent (DragPane (I (Just (win,r,ident))) ty _ _) + (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t }) + | t == buttonPress && thisw == win || thisbw == win = do + mouseDrag (\ex ey -> do + let frac = case ty of + Vertical -> (fromIntegral ex - (fromIntegral $ rect_x r))/(fromIntegral $ rect_width r) + Horizontal -> (fromIntegral ey - (fromIntegral $ rect_x r))/(fromIntegral $ rect_width r) + sendMessage (SetFrac ident frac)) + (return ()) +handleEvent _ _ = return () + +doLay :: (Rectangle -> Rectangle) -> DragPane a -> Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (DragPane a)) +doLay mirror (DragPane mw ty delta split) r s = do + let r' = mirror r + (left', right') = splitHorizontallyBy split r' + left = case left' of Rectangle x y w h -> + mirror $ Rectangle x y (w-halfHandleWidth) h + right = case right' of + Rectangle x y w h -> + mirror $ Rectangle (x+halfHandleWidth) y (w-halfHandleWidth) h + handr = case left' of + Rectangle x y w h -> + mirror $ Rectangle (x + fromIntegral w - halfHandleWidth) y (2*halfHandleWidth) h + wrs = case reverse (W.up s) of + (master:_) -> [(master,left),(W.focus s,right)] + [] -> case W.down s of + (next:_) -> [(W.focus s,left),(next,right)] + [] -> [(W.focus s, r)] + if length wrs > 1 + then case mw of + I (Just (w,_,ident)) -> do + w' <- deleteWindow w >> newDragWin handr + return (wrs, Just $ DragPane (I $ Just (w',r',ident)) ty delta split) + I Nothing -> do + w <- newDragWin handr + i <- io $ newUnique + return (wrs, Just $ DragPane (I $ Just (w,r',hashUnique i)) ty delta split) + else return (wrs, Nothing) + + +newDragWin :: Rectangle -> X Window +newDragWin r = do + let mask = Just $ exposureMask .|. buttonPressMask + w <- createNewWindow r mask handleColor + showWindow w + return w diff --git a/XMonad/Layout/Grid.hs b/XMonad/Layout/Grid.hs new file mode 100644 index 0000000..b10a8ac --- /dev/null +++ b/XMonad/Layout/Grid.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Grid +-- Copyright : (c) Lukas Mai +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : <l.mai@web.de> +-- Stability : unstable +-- Portability : unportable +-- +-- A simple layout that attempts to put all windows in a square grid. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Grid ( + -- * Usage + -- $usage + Grid(..) +) where + +import XMonad +import XMonad.StackSet +import Graphics.X11.Xlib.Types + +-- $usage +-- Put the following in your Config.hs file: +-- +-- > import XMonad.Layout.Grid +-- > ... +-- > layouts = [ ... +-- > , Layout Grid +-- > ] + +-- %import XMonad.Layout.Grid +-- %layout , Layout Grid + +data Grid a = Grid deriving (Read, Show) + +instance LayoutClass Grid a where + pureLayout Grid r s = arrange r (integrate s) + +arrange :: Rectangle -> [a] -> [(a, Rectangle)] +arrange (Rectangle rx ry rw rh) st = zip st rectangles + where + nwins = length st + ncols = ceiling . (sqrt :: Double -> Double) . fromIntegral $ nwins + mincs = nwins `div` ncols + extrs = nwins - ncols * mincs + chop :: Int -> Dimension -> [(Position, Dimension)] + chop n m = ((0, m - k * fromIntegral (pred n)) :) . map (flip (,) k) . tail . reverse . take n . tail . iterate (subtract k') $ m' + where + k :: Dimension + k = m `div` fromIntegral n + m' = fromIntegral m + k' :: Position + k' = fromIntegral k + xcoords = chop ncols rw + ycoords = chop mincs rh + ycoords' = chop (succ mincs) rh + (xbase, xext) = splitAt (ncols - extrs) xcoords + rectangles = combine ycoords xbase ++ combine ycoords' xext + where + combine ys xs = [Rectangle (rx + x) (ry + y) w h | (x, w) <- xs, (y, h) <- ys] diff --git a/XMonad/Layout/HintedTile.hs b/XMonad/Layout/HintedTile.hs new file mode 100644 index 0000000..2ec9d3c --- /dev/null +++ b/XMonad/Layout/HintedTile.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.HintedTile +-- Copyright : (c) Peter De Wachter <pdewacht@gmail.com> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Peter De Wachter <pdewacht@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- A gapless tiled layout that attempts to obey window size hints, +-- rather than simply ignoring them. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.HintedTile ( + -- * Usage + -- $usage + tall, wide) where + +import XMonad +import XMonad.Operations (Resize(..), IncMasterN(..), applySizeHints) +import qualified XMonad.StackSet as W +import {-# SOURCE #-} Config (borderWidth) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import Control.Monad + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import qualified XMonad.Layout.HintedTile +-- +-- > layouts = [ XMonad.Layout.HintedTile.tall nmaster delta ratio, ... ] + +-- %import qualified XMonad.Layout.HintedTile +-- +-- %layout , XMonad.Layout.HintedTile.tall nmaster delta ratio + +-- this sucks +addBorder, substractBorder :: (Dimension, Dimension) -> (Dimension, Dimension) +addBorder (w, h) = (w + 2 * borderWidth, h + 2 * borderWidth) +substractBorder (w, h) = (w - 2 * borderWidth, h - 2 * borderWidth) + + +tall, wide :: Int -> Rational -> Rational -> Layout Window +wide = tile splitVertically divideHorizontally +tall = tile splitHorizontally divideVertically + +tile split divide nmaster delta frac = + Layout { doLayout = \r w' -> let w = W.integrate w' + in do { hints <- sequence (map getHints w) + ; return (zip w (tiler frac r `uncurry` splitAt nmaster hints) + , Nothing) } + , modifyLayout = \m -> return $ fmap resize (fromMessage m) `mplus` + fmap incmastern (fromMessage m) } + + where resize Shrink = tile split divide nmaster delta (frac-delta) + resize Expand = tile split divide nmaster delta (frac+delta) + incmastern (IncMasterN d) = tile split divide (max 0 (nmaster+d)) delta frac + + tiler f r masters slaves = if null masters || null slaves + then divide (masters ++ slaves) r + else split f r (divide masters) (divide slaves) + +getHints :: Window -> X SizeHints +getHints w = withDisplay $ \d -> io $ getWMNormalHints d w + +-- +-- Divide the screen vertically (horizontally) into n subrectangles +-- +divideVertically, divideHorizontally :: [SizeHints] -> Rectangle -> [Rectangle] +divideVertically [] _ = [] -- there's a fold here, struggling to get out +divideVertically (hints:rest) (Rectangle sx sy sw sh) = (Rectangle sx sy w h) : + (divideVertically rest (Rectangle sx (sy + fromIntegral h) sw (sh - h))) + where (w, h) = addBorder $ applySizeHints hints $ substractBorder + (sw, sh `div` fromIntegral (1 + (length rest))) + +divideHorizontally [] _ = [] +divideHorizontally (hints:rest) (Rectangle sx sy sw sh) = (Rectangle sx sy w h) : + (divideHorizontally rest (Rectangle (sx + fromIntegral w) sy (sw - w) sh)) + where (w, h) = addBorder $ applySizeHints hints $ substractBorder + (sw `div` fromIntegral (1 + (length rest)), sh) + + +-- Split the screen into two rectangles, using a rational to specify the ratio +splitHorizontally, splitVertically :: Rational -> Rectangle -> (Rectangle -> [Rectangle]) -> (Rectangle -> [Rectangle]) -> [Rectangle] +splitHorizontally f (Rectangle sx sy sw sh) left right = leftRects ++ rightRects + where leftw = floor $ fromIntegral sw * f + leftRects = left $ Rectangle sx sy leftw sh + rightx = (maximum . map rect_width) leftRects + rightRects = right $ Rectangle (sx + fromIntegral rightx) sy (sw - rightx) sh + +splitVertically f (Rectangle sx sy sw sh) top bottom = topRects ++ bottomRects + where toph = floor $ fromIntegral sh * f + topRects = top $ Rectangle sx sy sw toph + bottomy = (maximum . map rect_height) topRects + bottomRects = bottom $ Rectangle sx (sy + fromIntegral bottomy) sw (sh - bottomy) diff --git a/XMonad/Layout/LayoutCombinators.hs b/XMonad/Layout/LayoutCombinators.hs new file mode 100644 index 0000000..4b2aa09 --- /dev/null +++ b/XMonad/Layout/LayoutCombinators.hs @@ -0,0 +1,128 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutCombinators +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : portable +-- +-- A module for combining Layouts +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutCombinators ( + -- * Usage + -- $usage + (<|>), (</>), (<||>), (<//>), (|||), JumpToLayout(JumpToLayout) + ) where + +import Data.Maybe ( isJust ) + +import XMonad +import Layouts ( Tall(..), Mirror(..), ChangeLayout(NextLayout) ) +import XMonad.Layout.Combo +import XMonad.Layout.DragPane + +-- $usage +-- Use LayoutCombinators to easily combine Layouts. + +(<||>), (<//>) :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a) => + l1 a -> l2 a -> CombineTwo DragPane l1 l2 a +(<|>) :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a) + => l1 a -> l2 a -> CombineTwo Tall l1 l2 a +(</>) :: (Read a, Eq a, LayoutClass l1 a, LayoutClass l2 a) + => l1 a -> l2 a -> CombineTwo (Mirror Tall) l1 l2 a + +(<||>) = combineTwo (dragPane Vertical 0.1 0.5) +(<//>) = combineTwo (dragPane Horizontal 0.1 0.5) +(<|>) = combineTwo (Tall 1 0.1 0.5) +(</>) = combineTwo (Mirror $ Tall 1 0.1 0.5) + +(|||) :: (LayoutClass l1 a, LayoutClass l2 a) => l1 a -> l2 a -> NewSelect l1 l2 a +(|||) = NewSelect True + +data NewSelect l1 l2 a = NewSelect Bool (l1 a) (l2 a) deriving ( Read, Show ) + +data NoWrap = NextLayoutNoWrap | Wrap deriving ( Read, Show, Typeable ) +instance Message NoWrap + +data JumpToLayout = JumpToLayout String deriving ( Read, Show, Typeable ) +instance Message JumpToLayout + +instance (LayoutClass l1 a, LayoutClass l2 a) => LayoutClass (NewSelect l1 l2) a where + doLayout (NewSelect True l1 l2) r s = do (wrs, ml1') <- doLayout l1 r s + return (wrs, (\l1' -> NewSelect True l1' l2) `fmap` ml1') + doLayout (NewSelect False l1 l2) r s = do (wrs, ml2') <- doLayout l2 r s + return (wrs, (\l2' -> NewSelect False l1 l2') `fmap` ml2') + description (NewSelect True l1 _) = description l1 + description (NewSelect False _ l2) = description l2 + handleMessage (NewSelect False l1 l2) m + | Just Wrap <- fromMessage m = + do ml2' <- handleMessage l2 (SomeMessage Hide) + ml1' <- handleMessage l1 m + return $ Just $ NewSelect True (maybe l1 id ml1') (maybe l2 id ml2') + handleMessage (NewSelect True l1 l2) m + | Just NextLayoutNoWrap <- fromMessage m = + do ml1' <- handleMessage l1 m + case ml1' of + Just l1' -> return $ Just (NewSelect True l1' l2) + Nothing -> do ml1'' <- handleMessage l1 (SomeMessage Hide) + ml2' <- handleMessage l2 (SomeMessage Wrap) + return $ Just $ NewSelect False (maybe l1 id ml1'') (maybe l2 id ml2') + handleMessage l@(NewSelect True _ _) m + | Just NextLayout <- fromMessage m = handleMessage l (SomeMessage NextLayoutNoWrap) + handleMessage l@(NewSelect False l1 l2) m + | Just NextLayout <- fromMessage m = + do ml' <- handleMessage l (SomeMessage NextLayoutNoWrap) + case ml' of + Just l' -> return $ Just l' + Nothing -> do ml2' <- handleMessage l2 (SomeMessage Hide) + ml1' <- handleMessage l1 (SomeMessage Wrap) + return $ Just $ NewSelect True (maybe l1 id ml1') (maybe l2 id ml2') + handleMessage (NewSelect True l1 l2) m + | Just (JumpToLayout d) <- fromMessage m, + d == description l2 = do ml1' <- handleMessage l1 (SomeMessage Hide) + return $ Just $ NewSelect False (maybe l1 id ml1') l2 + handleMessage (NewSelect True l1 l2) m + | Just (JumpToLayout d) <- fromMessage m + = do ml1' <- handleMessage l1 m + case ml1' of + Just l1' -> return $ Just $ NewSelect True l1' l2 + Nothing -> + do ml2' <- handleMessage l2 m + case ml2' of + Nothing -> return Nothing + Just l2' -> do ml1'' <- handleMessage l1 (SomeMessage Hide) + return $ Just $ NewSelect False (maybe l1 id ml1'') l2' + handleMessage (NewSelect False l1 l2) m + | Just (JumpToLayout d) <- fromMessage m, + d == description l1 = do ml2' <- handleMessage l2 (SomeMessage Hide) + return $ Just $ NewSelect True l1 (maybe l2 id ml2') + handleMessage (NewSelect False l1 l2) m + | Just (JumpToLayout d) <- fromMessage m + = do ml2' <- handleMessage l2 m + case ml2' of + Just l2' -> return $ Just $ NewSelect False l1 l2' + Nothing -> + do ml1' <- handleMessage l1 m + case ml1' of + Nothing -> return Nothing + Just l1' -> do ml2'' <- handleMessage l2 (SomeMessage Hide) + return $ Just $ NewSelect True l1' (maybe l2 id ml2'') + handleMessage (NewSelect b l1 l2) m + | Just ReleaseResources <- fromMessage m = + do ml1' <- handleMessage l1 m + ml2' <- handleMessage l2 m + return $ if isJust ml1' || isJust ml2' + then Just $ NewSelect b (maybe l1 id ml1') (maybe l2 id ml2') + else Nothing + handleMessage (NewSelect True l1 l2) m = + do ml1' <- handleMessage l1 m + return $ (\l1' -> NewSelect True l1' l2) `fmap` ml1' + handleMessage (NewSelect False l1 l2) m = + do ml2' <- handleMessage l2 m + return $ (\l2' -> NewSelect False l1 l2') `fmap` ml2' diff --git a/XMonad/Layout/LayoutHints.hs b/XMonad/Layout/LayoutHints.hs new file mode 100644 index 0000000..1268b3f --- /dev/null +++ b/XMonad/Layout/LayoutHints.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutHints +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : portable +-- +-- Make layouts respect size hints. +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutHints ( + -- * usage + -- $usage + layoutHints, + LayoutHints) where + +import XMonad.Operations ( applySizeHints, D ) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras ( getWMNormalHints ) +import {-#SOURCE#-} Config (borderWidth) +import XMonad hiding ( trace ) +import XMonad.Layout.LayoutModifier + +-- $usage +-- > import XMonad.Layout.LayoutHints +-- > layouts = [ layoutHints tiled , layoutHints $ Mirror tiled ] + +-- %import XMonad.Layout.LayoutHints +-- %layout , layoutHints $ tiled +-- %layout , layoutHints $ Mirror tiled + +layoutHints :: (LayoutClass l a) => l a -> ModifiedLayout LayoutHints l a +layoutHints = ModifiedLayout LayoutHints + +-- | Expand a size by the given multiple of the border width. The +-- multiple is most commonly 1 or -1. +adjBorders :: Dimension -> D -> D +adjBorders mult (w,h) = (w+2*mult*borderWidth, h+2*mult*borderWidth) + +data LayoutHints a = LayoutHints deriving (Read, Show) + +instance LayoutModifier LayoutHints Window where + modifierDescription _ = "Hinted" + redoLayout _ _ _ xs = do + xs' <- mapM applyHint xs + return (xs', Nothing) + where + applyHint (w,Rectangle a b c d) = + withDisplay $ \disp -> do + sh <- io $ getWMNormalHints disp w + let (c',d') = adjBorders 1 . applySizeHints sh . adjBorders (-1) $ (c,d) + return (w, Rectangle a b c' d') diff --git a/XMonad/Layout/LayoutModifier.hs b/XMonad/Layout/LayoutModifier.hs new file mode 100644 index 0000000..7d8c615 --- /dev/null +++ b/XMonad/Layout/LayoutModifier.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutModifier +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : portable +-- +-- A module for writing easy Layouts +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutModifier ( + -- * Usage + -- $usage + LayoutModifier(..), ModifiedLayout(..) + ) where + +import Graphics.X11.Xlib ( Rectangle ) +import XMonad +import XMonad.StackSet ( Stack ) + +-- $usage +-- Use LayoutHelpers to help write easy Layouts. + +class (Show (m a), Read (m a)) => LayoutModifier m a where + handleMess :: m a -> SomeMessage -> X (Maybe (m a)) + handleMess m mess | Just Hide <- fromMessage mess = doUnhook + | Just ReleaseResources <- fromMessage mess = doUnhook + | otherwise = return Nothing + where doUnhook = do unhook m; return Nothing + handleMessOrMaybeModifyIt :: m a -> SomeMessage -> X (Maybe (Either (m a) SomeMessage)) + handleMessOrMaybeModifyIt m mess = do mm' <- handleMess m mess + return (Left `fmap` mm') + redoLayout :: m a -> Rectangle -> Stack a -> [(a, Rectangle)] + -> X ([(a, Rectangle)], Maybe (m a)) + redoLayout m _ _ wrs = do hook m; return (wrs, Nothing) + hook :: m a -> X () + hook _ = return () + unhook :: m a -> X () + unhook _ = return () + modifierDescription :: m a -> String + modifierDescription = const "" + +instance (LayoutModifier m a, LayoutClass l a) => LayoutClass (ModifiedLayout m l) a where + doLayout (ModifiedLayout m l) r s = + do (ws, ml') <- doLayout l r s + (ws', mm') <- redoLayout m r s ws + let ml'' = case mm' of + Just m' -> Just $ (ModifiedLayout m') $ maybe l id ml' + Nothing -> ModifiedLayout m `fmap` ml' + return (ws', ml'') + handleMessage (ModifiedLayout m l) mess = + do mm' <- handleMessOrMaybeModifyIt m mess + ml' <- case mm' of + Just (Right mess') -> handleMessage l mess' + _ -> handleMessage l mess + return $ case mm' of + Just (Left m') -> Just $ (ModifiedLayout m') $ maybe l id ml' + _ -> (ModifiedLayout m) `fmap` ml' + description (ModifiedLayout m l) = modifierDescription m <> description l + where "" <> x = x + x <> y = x ++ " " ++ y + +data ModifiedLayout m l a = ModifiedLayout (m a) (l a) deriving ( Read, Show ) diff --git a/XMonad/Layout/LayoutScreens.hs b/XMonad/Layout/LayoutScreens.hs new file mode 100644 index 0000000..7277681 --- /dev/null +++ b/XMonad/Layout/LayoutScreens.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.LayoutScreens +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.LayoutScreens ( + -- * Usage + -- $usage + layoutScreens, fixedLayout + ) where + +import Control.Monad.Reader ( asks ) + +import XMonad +import qualified XMonad.StackSet as W +import qualified XMonad.Operations as O +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +-- $usage +-- This module allows you to pretend that you have more than one screen by +-- dividing a single screen into multiple screens that xmonad will treat as +-- separate screens. This should definitely be useful for testing the +-- behavior of xmonad under Xinerama, and it's possible that it'd also be +-- handy for use as an actual user interface, if you've got a very large +-- screen and long for greater flexibility (e.g. being able to see your +-- email window at all times, a crude mimic of sticky windows). +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.LayoutScreens +-- +-- > , ((modMask .|. shiftMask, xK_space), layoutScreens 2 (TwoPane 0.5 0.5)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen) +-- +-- Another example use would be to handle a scenario where xrandr didn't +-- work properly (e.g. a VNC X server in my case) and you want to be able +-- to resize your screen (e.g. to match the size of a remote VNC client): +-- +-- > import XMonad.Layout.LayoutScreens +-- +-- > , ((modMask .|. shiftMask, xK_space), +-- > layoutScreens 1 (fixedLayout $ Rectangle 0 0 1024 768)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen) + +-- %import XMonad.Layout.LayoutScreens +-- %keybind , ((modMask .|. shiftMask, xK_space), layoutScreens 2 (twoPane 0.5 0.5)) +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_space), rescreen) + +layoutScreens :: LayoutClass l Int => Int -> l Int -> X () +layoutScreens nscr _ | nscr < 1 = trace $ "Can't layoutScreens with only " ++ show nscr ++ " screens." +layoutScreens nscr l = + do rtrect <- asks theRoot >>= getWindowRectangle + (wss, _) <- doLayout l rtrect W.Stack { W.focus=1, W.up=[],W.down=[1..nscr-1] } + O.windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) -> + let (x:xs, ys) = splitAt nscr $ map W.workspace (v:vs) ++ hs + gaps = map (statusGap . W.screenDetail) $ v:vs + (s:ss, g:gg) = (map snd wss, take nscr $ gaps ++ repeat (head gaps)) + in ws { W.current = W.Screen x 0 (SD s g) + , W.visible = zipWith3 W.Screen xs [1 ..] $ zipWith SD ss gg + , W.hidden = ys } + +getWindowRectangle :: Window -> X Rectangle +getWindowRectangle w = withDisplay $ \d -> + do a <- io $ getWindowAttributes d w + return $ Rectangle (fromIntegral $ wa_x a) (fromIntegral $ wa_y a) + (fromIntegral $ wa_width a) (fromIntegral $ wa_height a) + +data FixedLayout a = FixedLayout [Rectangle] deriving (Read,Show) + +instance LayoutClass FixedLayout a where + doLayout (FixedLayout rs) _ s = return (zip (W.integrate s) rs, Nothing) + +fixedLayout :: [Rectangle] -> FixedLayout a +fixedLayout = FixedLayout diff --git a/XMonad/Layout/MagicFocus.hs b/XMonad/Layout/MagicFocus.hs new file mode 100644 index 0000000..57e5b7a --- /dev/null +++ b/XMonad/Layout/MagicFocus.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.MagicFocus +-- Copyright : (c) Peter De Wachter <pdewacht@gmail.com> +-- License : BSD +-- +-- Maintainer : Peter De Wachter <pdewacht@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- Automagically put the focused window in the master area. +----------------------------------------------------------------------------- + +module XMonad.Layout.MagicFocus + (-- * Usage + -- $usage + MagicFocus(MagicFocus) + ) where + +import Graphics.X11.Xlib +import XMonad +import XMonad.StackSet + +-- $usage +-- > import XMonad.Layout.MagicFocus +-- > layouts = [ Layout $ MagicFocus tiled , Layout $ MagicFocus $ Mirror tiled ] + +-- %import XMonad.Layout.MagicFocus +-- %layout , Layout $ MagicFocus tiled +-- %layout , Layout $ MagicFocus $ Mirror tiled + + +data MagicFocus l a = MagicFocus (l a) deriving ( Show , Read ) + +instance (LayoutClass l Window) => LayoutClass (MagicFocus l) Window where + doLayout = magicFocus + +magicFocus :: LayoutClass l Window => MagicFocus l Window -> Rectangle + -> Stack Window -> X ([(Window, Rectangle)], Maybe (MagicFocus l Window)) +magicFocus (MagicFocus l) r s = + withWindowSet $ \wset -> do + (ws,nl) <- doLayout l r (swap s $ peek wset) + case nl of + Nothing -> return (ws, Nothing) + Just l' -> return (ws, Just $ MagicFocus l') + +swap :: (Eq a) => Stack a -> Maybe a -> Stack a +swap (Stack f u d) focused | Just f == focused = Stack f [] (reverse u ++ d) + | otherwise = Stack f u d diff --git a/XMonad/Layout/Magnifier.hs b/XMonad/Layout/Magnifier.hs new file mode 100644 index 0000000..bcff71d --- /dev/null +++ b/XMonad/Layout/Magnifier.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Magnifier +-- Copyright : (c) Peter De Wachter 2007 +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : Peter De Wachter <pdewacht@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- Screenshot : <http://caladan.rave.org/magnifier.png> +-- +-- This layout hack increases the size of the window that has focus. +-- +----------------------------------------------------------------------------- + + +module XMonad.Layout.Magnifier ( + -- * Usage + -- $usage + magnifier, magnifier') where + +import Graphics.X11.Xlib (Window, Rectangle(..)) +import XMonad +import XMonad.StackSet +import XMonad.Layout.LayoutHelpers + +-- $usage +-- > import XMonad.Layout.Magnifier +-- > layouts = [ magnifier tiled , magnifier $ mirror tiled ] + +-- %import XMonad.Layout.Magnifier +-- %layout , magnifier tiled +-- %layout , magnifier $ mirror tiled + +-- | Increase the size of the window that has focus, unless it is the master window. +magnifier :: Layout Window -> Layout Window +magnifier = layoutModify (unlessMaster applyMagnifier) idModMod + +-- | Increase the size of the window that has focus, even if it is the master window. +magnifier' :: Layout Window -> Layout Window +magnifier' = layoutModify applyMagnifier idModMod + +unlessMaster :: ModDo Window -> ModDo Window +unlessMaster mainmod r s wrs = if null (up s) then return (wrs, Nothing) + else mainmod r s wrs + +applyMagnifier :: ModDo Window +applyMagnifier r _ wrs = do focused <- withWindowSet (return . peek) + let mag (w,wr) ws | focused == Just w = ws ++ [(w, shrink r $ magnify wr)] + | otherwise = (w,wr) : ws + return (reverse $ foldr mag [] wrs, Nothing) + +magnify :: Rectangle -> Rectangle +magnify (Rectangle x y w h) = Rectangle x' y' w' h' + where x' = x - fromIntegral (w' - w) `div` 2 + y' = y - fromIntegral (h' - h) `div` 2 + w' = round $ fromIntegral w * zoom + h' = round $ fromIntegral h * zoom + zoom = 1.5 :: Double + +shrink :: Rectangle -> Rectangle -> Rectangle +shrink (Rectangle sx sy sw sh) (Rectangle x y w h) = Rectangle x' y' w' h' + where x' = max sx x + y' = max sy y + w' = min w (fromIntegral sx + sw - fromIntegral x') + h' = min h (fromIntegral sy + sh - fromIntegral y') diff --git a/XMonad/Layout/Maximize.hs b/XMonad/Layout/Maximize.hs new file mode 100644 index 0000000..cf1e938 --- /dev/null +++ b/XMonad/Layout/Maximize.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Maximize +-- Copyright : (c) 2007 James Webb +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : xmonad#jwebb,sygneca,com +-- Stability : unstable +-- Portability : unportable +-- +-- Temporarily yanks the focused window out of the layout to mostly fill +-- the screen. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Maximize ( + -- * Usage + -- $usage + maximize, + maximizeRestore + ) where + +import Graphics.X11.Xlib +import XMonad +import XMonad.Layout.LayoutModifier +import Data.List ( partition ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Maximize +-- +-- > layouts = ... +-- > , Layout $ maximize $ tiled ... +-- > ... +-- +-- > keys = ... +-- > , ((modMask, xK_backslash), withFocused (sendMessage . maximizeRestore)) +-- > ... + +-- %import XMonad.Layout.Maximize +-- %layout , Layout $ maximize $ tiled + +data Maximize a = Maximize (Maybe Window) deriving ( Read, Show ) +maximize :: LayoutClass l Window => l Window -> ModifiedLayout Maximize l Window +maximize = ModifiedLayout $ Maximize Nothing + +data MaximizeRestore = MaximizeRestore Window deriving ( Typeable, Eq ) +instance Message MaximizeRestore +maximizeRestore :: Window -> MaximizeRestore +maximizeRestore = MaximizeRestore + +instance LayoutModifier Maximize Window where + modifierDescription (Maximize _) = "Maximize" + redoLayout (Maximize mw) rect _ wrs = case mw of + Just win -> + return (maxed ++ rest, Nothing) + where + maxed = map (\(w, _) -> (w, maxRect)) toMax + (toMax, rest) = partition (\(w, _) -> w == win) wrs + maxRect = Rectangle (rect_x rect + 50) (rect_y rect + 50) + (rect_width rect - 100) (rect_height rect - 100) + Nothing -> return (wrs, Nothing) + handleMess (Maximize mw) m = case fromMessage m of + Just (MaximizeRestore w) -> case mw of + Just _ -> return $ Just $ Maximize Nothing + Nothing -> return $ Just $ Maximize $ Just w + _ -> return Nothing + +-- vim: sw=4:et diff --git a/XMonad/Layout/Mosaic.hs b/XMonad/Layout/Mosaic.hs new file mode 100644 index 0000000..aec7aab --- /dev/null +++ b/XMonad/Layout/Mosaic.hs @@ -0,0 +1,407 @@ +{-# OPTIONS -fglasgow-exts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Mosaic +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +-- This module defines a \"mosaic\" layout, which tries to give each window a +-- user-configurable relative area, while also trying to give them aspect +-- ratios configurable at run-time by the user. +-- +----------------------------------------------------------------------------- +module XMonad.Layout.Mosaic ( + -- * Usage + -- $usage + mosaic, expandWindow, shrinkWindow, squareWindow, myclearWindow, + tallWindow, wideWindow, flexibleWindow, + getName, withNamedWindow ) where + +import Control.Monad.State ( State, put, get, runState ) +import System.Random ( StdGen, mkStdGen ) + +import Data.Ratio +import Graphics.X11.Xlib +import XMonad hiding ( trace ) +import XMonad.Operations ( full, Resize(Shrink, Expand) ) +import qualified XMonad.StackSet as W +import qualified Data.Map as M +import Data.List ( sort ) +import Data.Typeable ( Typeable ) +import Control.Monad ( mplus ) + +import XMonad.Util.NamedWindows +import XMonad.Util.Anneal + +-- $usage +-- +-- Key bindings: +-- +-- You can use this module with the following in your Config.hs: +-- +-- > import XMonad.Layout.Mosaic +-- +-- > layouts :: [Layout Window] +-- > layouts = [ mosaic 0.25 0.5 M.empty, full ] +-- +-- In the key-bindings, do something like: +-- +-- > , ((controlMask .|. modMask .|. shiftMask, xK_h), withNamedWindow (sendMessage . tallWindow)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_l), withNamedWindow (sendMessage . wideWindow)) +-- > , ((modMask .|. shiftMask, xK_h ), withNamedWindow (sendMessage . shrinkWindow)) +-- > , ((modMask .|. shiftMask, xK_l ), withNamedWindow (sendMessage . expandWindow)) +-- > , ((modMask .|. shiftMask, xK_s ), withNamedWindow (sendMessage . squareWindow)) +-- > , ((modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . myclearWindow)) +-- > , ((controlMask .|. modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . flexibleWindow)) +-- + +-- %import XMonad.Layout.Mosaic +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_h), withNamedWindow (sendMessage . tallWindow)) +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_l), withNamedWindow (sendMessage . wideWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_h ), withNamedWindow (sendMessage . shrinkWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_l ), withNamedWindow (sendMessage . expandWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_s ), withNamedWindow (sendMessage . squareWindow)) +-- %keybind , ((modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . myclearWindow)) +-- %keybind , ((controlMask .|. modMask .|. shiftMask, xK_o ), withNamedWindow (sendMessage . flexibleWindow)) +-- %layout , mosaic 0.25 0.5 M.empty + +data HandleWindow = ExpandWindow NamedWindow | ShrinkWindow NamedWindow + | SquareWindow NamedWindow | ClearWindow NamedWindow + | TallWindow NamedWindow | WideWindow NamedWindow + | FlexibleWindow NamedWindow + deriving ( Typeable, Eq ) + +instance Message HandleWindow + +expandWindow, shrinkWindow, squareWindow, flexibleWindow, myclearWindow,tallWindow, wideWindow :: NamedWindow -> HandleWindow +expandWindow = ExpandWindow +shrinkWindow = ShrinkWindow +squareWindow = SquareWindow +flexibleWindow = FlexibleWindow +myclearWindow = ClearWindow +tallWindow = TallWindow +wideWindow = WideWindow + +largeNumber :: Int +largeNumber = 50 + +defaultArea :: Double +defaultArea = 1 + +flexibility :: Double +flexibility = 0.1 + +mosaic :: Double -> Double -> M.Map NamedWindow [WindowHint] -> Layout Window +mosaic delta tileFrac hints = full { doLayout = \r -> mosaicL tileFrac hints r . W.integrate + , modifyLayout = return . mlayout } + where mlayout x = (m1 `fmap` fromMessage x) `mplus` (m2 `fmap` fromMessage x) + m1 Shrink = mosaic delta (tileFrac/(1+delta)) hints + m1 Expand = mosaic delta (tileFrac*(1+delta)) hints + m2 (ExpandWindow w) = mosaic delta tileFrac (multiply_area (1+delta) w hints) + m2 (ShrinkWindow w) = mosaic delta tileFrac (multiply_area (1/(1+ delta)) w hints) + m2 (SquareWindow w) = mosaic delta tileFrac (set_aspect_ratio 1 w hints) + m2 (FlexibleWindow w) = mosaic delta tileFrac (make_flexible w hints) + m2 (TallWindow w) = mosaic delta tileFrac (multiply_aspect (1/(1+delta)) w hints) + m2 (WideWindow w) = mosaic delta tileFrac (multiply_aspect (1+delta) w hints) + m2 (ClearWindow w) = mosaic delta tileFrac (M.delete w hints) + +multiply_area :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +multiply_area a = alterlist f where f [] = [RelArea (defaultArea*a)] + f (RelArea a':xs) = RelArea (a'*a) : xs + f (x:xs) = x : f xs + +set_aspect_ratio :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +set_aspect_ratio r = alterlist f where f [] = [AspectRatio r] + f (FlexibleAspectRatio _:x) = AspectRatio r:x + f (AspectRatio _:x) = AspectRatio r:x + f (x:xs) = x:f xs + +make_flexible :: NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +make_flexible = alterlist (map f) where f (AspectRatio r) = FlexibleAspectRatio r + f (FlexibleAspectRatio r) = AspectRatio r + f x = x + +multiply_aspect :: Double -> NamedWindow + -> M.Map NamedWindow [WindowHint] -> M.Map NamedWindow [WindowHint] +multiply_aspect r = alterlist f where f [] = [FlexibleAspectRatio r] + f (AspectRatio r':x) = AspectRatio (r*r'):x + f (FlexibleAspectRatio r':x) = FlexibleAspectRatio (r*r'):x + f (x:xs) = x:f xs + +findlist :: Ord k => k -> M.Map k [a] -> [a] +findlist = M.findWithDefault [] + +alterlist :: (Ord k, Ord a) => ([a] -> [a]) -> k -> M.Map k [a] -> M.Map k [a] +alterlist f k = M.alter f' k + where f' Nothing = f' (Just []) + f' (Just xs) = case f xs of + [] -> Nothing + xs' -> Just xs' + +mosaicL :: Double -> M.Map NamedWindow [WindowHint] + -> Rectangle -> [Window] -> X ([(Window, Rectangle)],Maybe (Layout Window)) +mosaicL _ _ _ [] = return ([], Nothing) +mosaicL f hints origRect origws + = do namedws <- mapM getName origws + let sortedws = reverse $ map the_value $ sort $ map (\w -> Rated (sumareas [w]) w) namedws + -- TODO: remove all this dead code + myv = runCountDown largeNumber $ mosaic_splits even_split origRect Vertical sortedws + myv2 = mc_mosaic sortedws Vertical + myh2 = mc_mosaic sortedws Horizontal +-- myv2 = maxL $ runCountDown largeNumber $ +-- sequence $ replicate mediumNumber $ +-- mosaic_splits one_split origRect Vertical sortedws + myh = runCountDown largeNumber $ mosaic_splits even_split origRect Horizontal sortedws +-- myh2 = maxL $ runCountDown largeNumber $ +-- sequence $ replicate mediumNumber $ +-- mosaic_splits one_split origRect Horizontal sortedws + return (map (\(nw,r)->(--trace ("rate1:"++ unlines [show nw, + -- show $ rate f meanarea (findlist nw hints) r, + -- show r, + -- show $ area r/meanarea, + -- show $ findlist nw hints]) $ + unName nw,crop' (findlist nw hints) r)) $ + flattenMosaic $ the_value $ maxL [myh,myv,myh2,myv2], Nothing) + where mosaic_splits _ _ _ [] = return $ Rated 0 $ M [] + mosaic_splits _ r _ [w] = return $ Rated (rate f meanarea (findlist w hints) r) $ OM (w,r) + mosaic_splits spl r d ws = maxL `fmap` mapCD (spl r d) (init $ allsplits ws) + even_split :: Rectangle -> CutDirection -> [[NamedWindow]] + -> State CountDown (Rated Double (Mosaic (NamedWindow, Rectangle))) + even_split r d [ws] = even_split r d $ map (:[]) ws + even_split r d wss = + do let areas = map sumareas wss + let wsr_s :: [([NamedWindow], Rectangle)] + wsr_s = zip wss (partitionR d r areas) + submosaics <- mapM (\(ws',r') -> + mosaic_splits even_split r' (otherDirection d) ws') wsr_s + return $ fmap M $ catRated submosaics + {- + another_mosaic :: [NamedWindow] -> CutDirection + -> Rated Double (Mosaic (NamedWindow,Rectangle)) + another_mosaic ws d = rate_mosaic ratew $ + rect_mosaic origRect d $ + zipML (example_mosaic ws) (map findarea ws) + -} + mc_mosaic :: [NamedWindow] -> CutDirection + -> Rated Double (Mosaic (NamedWindow,Rectangle)) + mc_mosaic ws d = fmap (rect_mosaic origRect d) $ + annealMax (zipML (example_mosaic ws) (map findarea ws)) + (the_rating . rate_mosaic ratew . rect_mosaic origRect d ) + changeMosaic + + ratew :: (NamedWindow,Rectangle) -> Double + ratew (w,r) = rate f meanarea (findlist w hints) r + example_mosaic :: [NamedWindow] -> Mosaic NamedWindow + example_mosaic ws = M (map OM ws) + rect_mosaic :: Rectangle -> CutDirection -> Mosaic (a,Double) -> Mosaic (a,Rectangle) + rect_mosaic r _ (OM (w,_)) = OM (w,r) + rect_mosaic r d (M ws) = M $ zipWith (\w' r' -> rect_mosaic r' d' w') ws rs + where areas = map (sum . map snd . flattenMosaic) ws + rs = partitionR d r areas + d' = otherDirection d + rate_mosaic :: ((NamedWindow,Rectangle) -> Double) + -> Mosaic (NamedWindow,Rectangle) -> Rated Double (Mosaic (NamedWindow,Rectangle)) + rate_mosaic r m = catRatedM $ fmap (\x -> Rated (r x) x) m +{- + one_split :: Rectangle -> CutDirection -> [[NamedWindow]] + -> State CountDown (Rated Double (Mosaic (NamedWindow, Rectangle))) + one_split r d [ws] = one_split r d $ map (:[]) ws + one_split r d wss = + do rnd <- mapM (const (fractional resolutionNumber)) [1..length wss] + let wsr_s :: [([NamedWindow], Rectangle)] + wsr_s = zip wss (partitionR d r rnd) + submosaics <- mapM (\(ws',r') -> + mosaic_splits even_split r' (otherDirection d) ws') wsr_s + return $ fmap M $ catRated submosaics +-} + partitionR :: CutDirection -> Rectangle -> [Double] -> [Rectangle] + partitionR _ _ [] = [] + partitionR _ r [_] = [r] + partitionR d r (a:ars) = r1 : partitionR d r2 ars + where totarea = sum (a:ars) + (r1,r2) = split d (a/totarea) r + theareas = hints2area `fmap` hints + sumareas ws = sum $ map findarea ws + findarea :: NamedWindow -> Double + findarea w = M.findWithDefault 1 w theareas + meanarea = area origRect / fromIntegral (length origws) + +maxL :: Ord a => [a] -> a +maxL [] = error "maxL on empty list" +maxL [a] = a +maxL (a:b:c) = maxL (max a b:c) + +catRated :: Floating v => [Rated v a] -> Rated v [a] +catRated xs = Rated (product $ map the_rating xs) (map the_value xs) + +catRatedM :: Floating v => Mosaic (Rated v a) -> Rated v (Mosaic a) +catRatedM (OM (Rated v x)) = Rated v (OM x) +catRatedM (M xs) = case catRated $ map catRatedM xs of Rated v xs' -> Rated v (M xs') + +data CountDown = CD !StdGen !Int + +tries_left :: State CountDown Int +tries_left = do CD _ n <- get + return (max 0 n) + +mapCD :: (a -> State CountDown b) -> [a] -> State CountDown [b] +mapCD f xs = do n <- tries_left + let len = length xs + mapM (run_with_only ((n `div` len)+1) . f) $ take (n+1) xs + +run_with_only :: Int -> State CountDown a -> State CountDown a +run_with_only limit j = + do CD g n <- get + let leftover = n - limit + if leftover < 0 then j + else do put $ CD g limit + x <- j + CD g' n' <- get + put $ CD g' (leftover + n') + return x + +data WindowHint = RelArea Double + | AspectRatio Double + | FlexibleAspectRatio Double + deriving ( Show, Read, Eq, Ord ) + +fixedAspect :: [WindowHint] -> Bool +fixedAspect [] = False +fixedAspect (AspectRatio _:_) = True +fixedAspect (_:x) = fixedAspect x + +rate :: Double -> Double -> [WindowHint] -> Rectangle -> Double +rate defaulta meanarea xs rr + | fixedAspect xs = (area (crop xs rr) / meanarea) ** weight + | otherwise = (area rr / meanarea)**(weight-flexibility) + * (area (crop (xs++[FlexibleAspectRatio defaulta]) rr) / meanarea)**flexibility + where weight = hints2area xs + +crop :: [WindowHint] -> Rectangle -> Rectangle +crop (AspectRatio f:_) = cropit f +crop (FlexibleAspectRatio f:_) = cropit f +crop (_:hs) = crop hs +crop [] = id + +crop' :: [WindowHint] -> Rectangle -> Rectangle +crop' (AspectRatio f:_) = cropit f +crop' (_:hs) = crop' hs +crop' [] = id + +cropit :: Double -> Rectangle -> Rectangle +cropit f (Rectangle a b w h) | w -/- h > f = Rectangle a b (ceiling $ h -* f) h + | otherwise = Rectangle a b w (ceiling $ w -/ f) + +hints2area :: [WindowHint] -> Double +hints2area [] = defaultArea +hints2area (RelArea r:_) = r +hints2area (_:x) = hints2area x + +area :: Rectangle -> Double +area (Rectangle _ _ w h) = fromIntegral w * fromIntegral h + +(-/-) :: (Integral a, Integral b) => a -> b -> Double +a -/- b = fromIntegral a / fromIntegral b + +(-/) :: (Integral a) => a -> Double -> Double +a -/ b = fromIntegral a / b + +(-*) :: (Integral a) => a -> Double -> Double +a -* b = fromIntegral a * b + +split :: CutDirection -> Double -> Rectangle -> (Rectangle, Rectangle) +split Vertical frac (Rectangle sx sy sw sh) = (Rectangle sx sy sw h, + Rectangle sx (sy+fromIntegral h) sw (sh-h)) + where h = floor $ fromIntegral sh * frac +split Horizontal frac (Rectangle sx sy sw sh) = (Rectangle sx sy w sh, + Rectangle (sx+fromIntegral w) sy (sw-w) sh) + where w = floor $ fromIntegral sw * frac + +data CutDirection = Vertical | Horizontal +otherDirection :: CutDirection -> CutDirection +otherDirection Vertical = Horizontal +otherDirection Horizontal = Vertical + +data Mosaic a = M [Mosaic a] | OM a + deriving ( Show ) + +instance Functor Mosaic where + fmap f (OM x) = OM (f x) + fmap f (M xs) = M (map (fmap f) xs) + +zipMLwith :: (a -> b -> c) -> Mosaic a -> [b] -> Mosaic c +zipMLwith f (OM x) (y:_) = OM (f x y) +zipMLwith _ (OM _) [] = error "bad zipMLwith" +zipMLwith f (M xxs) yys = makeM $ foo xxs yys + where foo (x:xs) ys = zipMLwith f x (take (lengthM x) ys) : + foo xs (drop (lengthM x) ys) + foo [] _ = [] + +zipML :: Mosaic a -> [b] -> Mosaic (a,b) +zipML = zipMLwith (\a b -> (a,b)) + +lengthM :: Mosaic a -> Int +lengthM (OM _) = 1 +lengthM (M x) = sum $ map lengthM x + +changeMosaic :: Mosaic a -> [Mosaic a] +changeMosaic (OM _) = [] +changeMosaic (M xs) = map makeM (concatenations xs) ++ + map makeM (splits xs) ++ + map M (tryAll changeMosaic xs) + +tryAll :: (a -> [a]) -> [a] -> [[a]] +tryAll _ [] = [] +tryAll f (x:xs) = map (:xs) (f x) ++ map (x:) (tryAll f xs) + +splits :: [Mosaic a] -> [[Mosaic a]] +splits [] = [] +splits (OM x:y) = map (OM x:) $ splits y +splits (M (x:y):z) = (x:makeM y:z) : map (makeM (x:y) :) (splits z) +splits (M []:x) = splits x + +concatenations :: [Mosaic a] -> [[Mosaic a]] +concatenations (x:y:z) = (concatenateMosaic x y:z):(map (x:) $ concatenations (y:z)) +concatenations _ = [] + +concatenateMosaic :: Mosaic a -> Mosaic a -> Mosaic a +concatenateMosaic (OM a) (OM b) = M [OM a, OM b] +concatenateMosaic (OM a) (M b) = M (OM a:b) +concatenateMosaic (M a) (OM b) = M (a++[OM b]) +concatenateMosaic (M a) (M b) = M (a++b) + +makeM :: [Mosaic a] -> Mosaic a +makeM [m] = m +makeM [] = error "makeM []" +makeM ms = M ms + +flattenMosaic :: Mosaic a -> [a] +flattenMosaic (OM a) = [a] +flattenMosaic (M xs) = concatMap flattenMosaic xs + +allsplits :: [a] -> [[[a]]] +allsplits [] = [[[]]] +allsplits [a] = [[[a]]] +allsplits (x:xs) = (map ([x]:) splitsrest) ++ (map (maphead (x:)) splitsrest) + where splitsrest = allsplits' xs + +allsplits' :: [a] -> [[[a]]] +allsplits' [] = [[[]]] +allsplits' [a] = [[[a]]] +allsplits' (x:xs) = (map (maphead (x:)) splitsrest) ++ (map ([x]:) splitsrest) + where splitsrest = allsplits xs + +maphead :: (a->a) -> [a] -> [a] +maphead f (x:xs) = f x : xs +maphead _ [] = [] + +runCountDown :: Int -> State CountDown a -> a +runCountDown n x = fst $ runState x (CD (mkStdGen n) n) diff --git a/XMonad/Layout/MosaicAlt.hs b/XMonad/Layout/MosaicAlt.hs new file mode 100644 index 0000000..a2b9e6a --- /dev/null +++ b/XMonad/Layout/MosaicAlt.hs @@ -0,0 +1,163 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.MosaicAlt +-- Copyright : (c) 2007 James Webb +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : xmonad#jwebb,sygneca,com +-- Stability : unstable +-- Portability : unportable +-- +-- A layout which gives each window a specified amount of screen space +-- relative to the others. Compared to the 'Mosaic' layout, this one +-- divides the space in a more balanced way. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.MosaicAlt ( + -- * Usage: + -- $usage + MosaicAlt(..) + , shrinkWindowAlt + , expandWindowAlt + , tallWindowAlt + , wideWindowAlt + , resetAlt + ) where + +import XMonad +import XMonad.Layouts +import Graphics.X11.Xlib +import qualified XMonad.StackSet as W +import qualified Data.Map as M +import Data.List ( sortBy ) +import Data.Ratio +import Graphics.X11.Types ( Window ) + +-- $usage +-- You can use this module with the following in your configuration file: +-- +-- > import XMonad.Layout.MosaicAlt +-- +-- > layouts = ... +-- > , Layout $ MosaicAlt M.empty +-- > ... +-- +-- > keys = ... +-- > , ((modMask .|. shiftMask, xK_a), withFocused (sendMessage . expandWindowAlt)) +-- > , ((modMask .|. shiftMask, xK_z), withFocused (sendMessage . shrinkWindowAlt)) +-- > , ((modMask .|. shiftMask, xK_s), withFocused (sendMessage . tallWindowAlt)) +-- > , ((modMask .|. shiftMask, xK_d), withFocused (sendMessage . wideWindowAlt)) +-- > , ((modMask .|. controlMask, xK_space), sendMessage resetAlt) +-- > ... + +-- %import XMonad.Layout.MosaicAlt +-- %layout , Layout $ MosaicAlt M.empty + +data HandleWindowAlt = + ShrinkWindowAlt Window + | ExpandWindowAlt Window + | TallWindowAlt Window + | WideWindowAlt Window + | ResetAlt + deriving ( Typeable, Eq ) +instance Message HandleWindowAlt +shrinkWindowAlt, expandWindowAlt :: Window -> HandleWindowAlt +tallWindowAlt, wideWindowAlt :: Window -> HandleWindowAlt +shrinkWindowAlt = ShrinkWindowAlt +expandWindowAlt = ExpandWindowAlt +tallWindowAlt = TallWindowAlt +wideWindowAlt = WideWindowAlt +resetAlt :: HandleWindowAlt +resetAlt = ResetAlt + +data Param = Param { area, aspect :: Rational } deriving ( Show, Read ) +type Params = M.Map Window Param +data MosaicAlt a = MosaicAlt Params deriving ( Show, Read ) + +instance LayoutClass MosaicAlt Window where + description _ = "MosaicAlt" + doLayout (MosaicAlt params) rect stack = + return (arrange rect stack params', Just $ MosaicAlt params') + where + params' = ins (W.up stack) $ ins (W.down stack) $ ins [W.focus stack] params + ins wins as = foldl M.union as $ map (`M.singleton` (Param 1 1.5)) wins + + handleMessage (MosaicAlt params) msg = return $ case fromMessage msg of + Just (ShrinkWindowAlt w) -> Just $ MosaicAlt $ alter params w (4 % 5) 1 + Just (ExpandWindowAlt w) -> Just $ MosaicAlt $ alter params w (6 % 5) 1 + Just (TallWindowAlt w) -> Just $ MosaicAlt $ alter params w 1 (3 % 4) + Just (WideWindowAlt w) -> Just $ MosaicAlt $ alter params w 1 (5 % 4) + Just ResetAlt -> Just $ MosaicAlt M.empty + _ -> Nothing + +-- Change requested params for a window. +alter :: Params -> Window -> Rational -> Rational -> Params +alter params win arDelta asDelta = case M.lookup win params of + Just (Param ar as) -> M.insert win (Param (ar * arDelta) (as * asDelta)) params + Nothing -> M.insert win (Param arDelta (1.5 * asDelta)) params + +-- Layout algorithm entry point. +arrange :: Rectangle -> W.Stack Window -> Params -> [(Window, Rectangle)] +arrange rect stack params = r + where + (_, r) = findSplits 3 rect tree params + tree = makeTree (sortBy areaCompare wins) params + wins = reverse (W.up stack) ++ W.focus stack : W.down stack + areaCompare a b = or1 b `compare` or1 a + or1 w = maybe 1 area $ M.lookup w params + +-- Recursively group windows into a binary tree. Aim to balance the tree +-- according to the total requested area in each branch. +data Tree = Node (Rational, Tree) (Rational, Tree) | Leaf Window | None +makeTree :: [Window] -> Params -> Tree +makeTree wins params = case wins of + [] -> None + [x] -> Leaf x + _ -> Node (aArea, makeTree aWins params) (bArea, makeTree bWins params) + where ((aWins, aArea), (bWins, bArea)) = areaSplit params wins + +-- Split a list of windows in half by area. +areaSplit :: Params -> [Window] -> (([Window], Rational), ([Window], Rational)) +areaSplit params wins = gather [] 0 [] 0 wins + where + gather a aa b ba (r : rs) = + if aa <= ba + then gather (r : a) (aa + or1 r) b ba rs + else gather a aa (r : b) (ba + or1 r) rs + gather a aa b ba [] = ((reverse a, aa), (b, ba)) + or1 w = maybe 1 area $ M.lookup w params + +-- Figure out which ways to split the space, by exhaustive search. +-- Complexity is quadratic in the number of windows. +findSplits :: Int -> Rectangle -> Tree -> Params -> (Double, [(Window, Rectangle)]) +findSplits _ _ None _ = (0, []) +findSplits _ rect (Leaf w) params = (aspectBadness rect w params, [(w, rect)]) +findSplits depth rect (Node (aArea, aTree) (bArea, bTree)) params = + if hBadness < vBadness then (hBadness, hList) else (vBadness, vList) + where + (hBadness, hList) = trySplit splitHorizontallyBy + (vBadness, vList) = trySplit splitVerticallyBy + trySplit splitBy = + (aBadness + bBadness, aList ++ bList) + where + (aBadness, aList) = findSplits (depth - 1) aRect aTree params + (bBadness, bList) = findSplits (depth - 1) bRect bTree params + (aRect, bRect) = splitBy ratio rect + ratio = aArea / (aArea + bArea) + +-- Decide how much we like this rectangle. +aspectBadness :: Rectangle -> Window -> Params -> Double +aspectBadness rect win params = + (if a < 1 then tall else wide) * sqrt(w * h) + where + tall = if w < 700 then ((1 / a) * (700 / w)) else 1 / a + wide = if w < 700 then a else (a * w / 700) + a = (w / h) / fromRational (maybe 1.5 aspect $ M.lookup win params) + w = fromIntegral $ rect_width rect + h = fromIntegral $ rect_height rect + +-- vim: sw=4:et diff --git a/XMonad/Layout/NoBorders.hs b/XMonad/Layout/NoBorders.hs new file mode 100644 index 0000000..8aa64fb --- /dev/null +++ b/XMonad/Layout/NoBorders.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.NoBorders +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +-- Make a given layout display without borders. This is useful for +-- full-screen or tabbed layouts, where you don't really want to waste a +-- couple of pixels of real estate just to inform yourself that the visible +-- window has focus. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.NoBorders ( + -- * Usage + -- $usage + noBorders, + smartBorders, + withBorder + ) where + +import Control.Monad.State (gets) +import Control.Monad.Reader (asks) +import Graphics.X11.Xlib + +import XMonad +import XMonad.Layout.LayoutModifier +import qualified XMonad.StackSet as W +import Data.List ((\\)) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.NoBorders +-- +-- and modify the layouts to call noBorders on the layouts you want to lack +-- borders +-- +-- > layouts = [ Layout (noBorders Full), ... ] +-- + +-- %import XMonad.Layout.NoBorders +-- %layout -- prepend noBorders to default layouts above to remove their borders, like so: +-- %layout , noBorders Full + +-- todo, use an InvisibleList. +data WithBorder a = WithBorder Dimension [a] deriving ( Read, Show ) + +instance LayoutModifier WithBorder Window where + modifierDescription (WithBorder 0 _) = "NoBorders" + modifierDescription (WithBorder n _) = "Borders " ++ show n + + unhook (WithBorder _ s) = asks (borderWidth . config) >>= setBorders s + + redoLayout (WithBorder n s) _ _ wrs = do + asks (borderWidth . config) >>= setBorders (s \\ ws) + setBorders ws n + return (wrs, Just $ WithBorder n ws) + where + ws = map fst wrs + +noBorders :: LayoutClass l Window => l Window -> ModifiedLayout WithBorder l Window +noBorders = ModifiedLayout $ WithBorder 0 [] + +withBorder :: LayoutClass l a => Dimension -> l a -> ModifiedLayout WithBorder l a +withBorder b = ModifiedLayout $ WithBorder b [] + +setBorders :: [Window] -> Dimension -> X () +setBorders ws bw = withDisplay $ \d -> mapM_ (\w -> io $ setWindowBorderWidth d w bw) ws + +data SmartBorder a = SmartBorder [a] deriving (Read, Show) + +instance LayoutModifier SmartBorder Window where + modifierDescription _ = "SmartBorder" + + unhook (SmartBorder s) = asks (borderWidth . config) >>= setBorders s + + redoLayout (SmartBorder s) _ _ wrs = do + ss <- gets (W.screens . windowset) + + if singleton ws && singleton ss + then do + asks (borderWidth . config) >>= setBorders (s \\ ws) + setBorders ws 0 + return (wrs, Just $ SmartBorder ws) + else do + asks (borderWidth . config) >>= setBorders s + return (wrs, Just $ SmartBorder []) + where + ws = map fst wrs + singleton = null . drop 1 + +-- +-- | You can cleverly set no borders on a range of layouts, using a +-- layoutHook like so: +-- +-- > layoutHook = Layout $ smartBorders $ Select layouts +-- +smartBorders :: LayoutClass l a => l a -> ModifiedLayout SmartBorder l a +smartBorders = ModifiedLayout (SmartBorder []) diff --git a/XMonad/Layout/ResizableTile.hs b/XMonad/Layout/ResizableTile.hs new file mode 100644 index 0000000..a70a987 --- /dev/null +++ b/XMonad/Layout/ResizableTile.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ResizableTile +-- Copyright : (c) MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com> +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : MATSUYAMA Tomohiro <t.matsuyama.pub@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- More useful tiled layout that allows you to change a width\/height of window. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.ResizableTile ( + -- * Usage + -- $usage + ResizableTall(..), MirrorResize(..) + ) where + +import XMonad +import XMonad.Layouts (Resize(..), IncMasterN(..)) +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Control.Monad.State +import Control.Monad + +-- $usage +-- +-- To use, modify your Config.hs to: +-- +-- > import XMonad.Layout.ResizableTile +-- +-- and add a keybinding: +-- +-- > , ((modMask, xK_a ), sendMessage MirrorShrink) +-- > , ((modMask, xK_z ), sendMessage MirrorExpand) +-- +-- and redefine "tiled" as: +-- +-- > tiled = ResizableTall nmaster delta ratio [] + +data MirrorResize = MirrorShrink | MirrorExpand deriving Typeable +instance Message MirrorResize + +data ResizableTall a = ResizableTall Int Rational Rational [Rational] deriving (Show, Read) +instance LayoutClass ResizableTall a where + doLayout (ResizableTall nmaster _ frac mfrac) r = + return . (\x->(x,Nothing)) . + ap zip (tile frac (mfrac ++ repeat 1) r nmaster . length) . W.integrate + handleMessage (ResizableTall nmaster delta frac mfrac) m = + do ms <- (W.stack . W.workspace . W.current) `fmap` gets windowset + case ms of + Nothing -> return Nothing + Just s -> return $ msum [fmap resize (fromMessage m) + ,fmap (\x -> mresize x s) (fromMessage m) + ,fmap incmastern (fromMessage m)] + where resize Shrink = ResizableTall nmaster delta (max 0 $ frac-delta) mfrac + resize Expand = ResizableTall nmaster delta (min 1 $ frac+delta) mfrac + mresize MirrorShrink s = mresize' s delta + mresize MirrorExpand s = mresize' s (0-delta) + mresize' s d = let n = length $ W.up s + total = n + (length $ W.down s) + 1 + pos = if n == (nmaster-1) || n == (total-1) then n-1 else n + mfrac' = modifymfrac (mfrac ++ repeat 1) d pos + in ResizableTall nmaster delta frac $ take total mfrac' + modifymfrac [] _ _ = [] + modifymfrac (f:fx) d n | n == 0 = f+d : fx + | otherwise = f : modifymfrac fx d (n-1) + incmastern (IncMasterN d) = ResizableTall (max 0 (nmaster+d)) delta frac mfrac + description _ = "ResizableTall" + +tile :: Rational -> [Rational] -> Rectangle -> Int -> Int -> [Rectangle] +tile f mf r nmaster n = if n <= nmaster || nmaster == 0 + then splitVertically mf n r + else splitVertically mf nmaster r1 ++ splitVertically (drop nmaster mf) (n-nmaster) r2 -- two columns + where (r1,r2) = splitHorizontallyBy f r + +splitVertically :: RealFrac r => [r] -> Int -> Rectangle -> [Rectangle] +splitVertically [] _ r = [r] +splitVertically _ n r | n < 2 = [r] +splitVertically (f:fx) n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh : + splitVertically fx (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh)) + where smallh = floor $ fromIntegral (sh `div` fromIntegral n) * f --hmm, this is a fold or map. + +splitHorizontallyBy :: RealFrac r => r -> Rectangle -> (Rectangle, Rectangle) +splitHorizontallyBy f (Rectangle sx sy sw sh) = + ( Rectangle sx sy leftw sh + , Rectangle (sx + fromIntegral leftw) sy (sw-fromIntegral leftw) sh) + where leftw = floor $ fromIntegral sw * f diff --git a/XMonad/Layout/Roledex.hs b/XMonad/Layout/Roledex.hs new file mode 100644 index 0000000..0c4eb5f --- /dev/null +++ b/XMonad/Layout/Roledex.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Roledex +-- Copyright : (c) tim.thelion@gmail.com +-- License : BSD +-- +-- Maintainer : tim.thelion@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- Screenshot : <http://www.timthelion.com/rolodex.png> +-- +-- This is a completely pointless layout which acts like Microsoft's Flip 3D +----------------------------------------------------------------------------- + +module XMonad.Layout.Roledex ( + -- * Usage + -- $usage + Roledex(Roledex)) where + +import XMonad +import XMonad.Layouts +import qualified XMonad.StackSet as W +import Graphics.X11.Xlib +import Data.Ratio + +-- $usage +-- +-- > import XMonad.Layout.Roledex +-- > layouts = [ Layout Roledex ] + +-- %import XMonad.Layout.Roledex +-- %layout , Layout Roledex + +data Roledex a = Roledex deriving ( Show, Read ) + +instance LayoutClass Roledex Window where + doLayout _ = roledexLayout + +roledexLayout :: Eq a => Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (Roledex a)) +roledexLayout sc ws = return ([(W.focus ws, mainPane)] ++ + (zip ups tops) ++ + (reverse (zip dns bottoms)) + ,Nothing) + where ups = W.up ws + dns = W.down ws + c = length ups + length dns + rect = fst $ splitHorizontallyBy (2%3 :: Ratio Int) $ fst (splitVerticallyBy (2%3 :: Ratio Int) sc) + gw = div' (w - rw) (fromIntegral c) + where + (Rectangle _ _ w _) = sc + (Rectangle _ _ rw _) = rect + gh = div' (h - rh) (fromIntegral c) + where + (Rectangle _ _ _ h) = sc + (Rectangle _ _ _ rh) = rect + mainPane = mrect (gw * fromIntegral c) (gh * fromIntegral c) rect + mrect mx my (Rectangle x y w h) = Rectangle (x + (fromIntegral mx)) (y + (fromIntegral my)) w h + tops = map f $ cd c (length dns) + bottoms = map f $ [0..(length dns)] + f n = mrect (gw * (fromIntegral n)) (gh * (fromIntegral n)) rect + cd n m = if n > m + then (n - 1) : (cd (n-1) m) + else [] + +div' :: Integral a => a -> a -> a +div' _ 0 = 0 +div' n o = div n o diff --git a/XMonad/Layout/Spiral.hs b/XMonad/Layout/Spiral.hs new file mode 100644 index 0000000..013a017 --- /dev/null +++ b/XMonad/Layout/Spiral.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Spiral +-- Copyright : (c) Joe Thornber <joe.thornber@gmail.com> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Joe Thornber <joe.thornber@gmail.com> +-- Stability : stable +-- Portability : portable +-- +-- Spiral adds a spiral tiling layout +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Spiral ( + -- * Usage + -- $usage + spiral + , spiralWithDir + , Rotation (..) + , Direction (..) + ) where + +import Graphics.X11.Xlib +import XMonad.Operations +import Data.Ratio +import XMonad +import XMonad.Layouts +import XMonad.StackSet ( integrate ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Spiral +-- +-- > layouts = [ ..., Layout $ spiral (1 % 1), ... ] + +-- %import XMonad.Layout.Spiral +-- %layout , Layout $ spiral (1 % 1) + +fibs :: [Integer] +fibs = 1 : 1 : (zipWith (+) fibs (tail fibs)) + +mkRatios :: [Integer] -> [Rational] +mkRatios (x1:x2:xs) = (x1 % x2) : mkRatios (x2:xs) +mkRatios _ = [] + +data Rotation = CW | CCW deriving (Read, Show) +data Direction = East | South | West | North deriving (Eq, Enum, Read, Show) + +blend :: Rational -> [Rational] -> [Rational] +blend scale ratios = zipWith (+) ratios scaleFactors + where + len = length ratios + step = (scale - (1 % 1)) / (fromIntegral len) + scaleFactors = map (* step) . reverse . take len $ [0..] + +spiral :: Rational -> SpiralWithDir a +spiral = spiralWithDir East CW + +spiralWithDir :: Direction -> Rotation -> Rational -> SpiralWithDir a +spiralWithDir = SpiralWithDir + +data SpiralWithDir a = SpiralWithDir Direction Rotation Rational + deriving ( Read, Show ) + +instance LayoutClass SpiralWithDir a where + pureLayout (SpiralWithDir dir rot scale) sc stack = zip ws rects + where ws = integrate stack + ratios = blend scale . reverse . take (length ws - 1) . mkRatios $ tail fibs + rects = divideRects (zip ratios dirs) sc + dirs = dropWhile (/= dir) $ case rot of + CW -> cycle [East .. North] + CCW -> cycle [North, West, South, East] + handleMessage (SpiralWithDir dir rot scale) = return . fmap resize . fromMessage + where resize Expand = spiralWithDir dir rot $ (21 % 20) * scale + resize Shrink = spiralWithDir dir rot $ (20 % 21) * scale + description _ = "Spiral" + +-- This will produce one more rectangle than there are splits details +divideRects :: [(Rational, Direction)] -> Rectangle -> [Rectangle] +divideRects [] r = [r] +divideRects ((r,d):xs) rect = case divideRect r d rect of + (r1, r2) -> r1 : (divideRects xs r2) + +-- It's much simpler if we work with all Integers and convert to +-- Rectangle at the end. +data Rect = Rect Integer Integer Integer Integer + +fromRect :: Rect -> Rectangle +fromRect (Rect x y w h) = Rectangle (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + +toRect :: Rectangle -> Rect +toRect (Rectangle x y w h) = Rect (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + +divideRect :: Rational -> Direction -> Rectangle -> (Rectangle, Rectangle) +divideRect r d rect = let (r1, r2) = divideRect' r d $ toRect rect in + (fromRect r1, fromRect r2) + +divideRect' :: Rational -> Direction -> Rect -> (Rect, Rect) +divideRect' ratio dir (Rect x y w h) = + case dir of + East -> let (w1, w2) = chop ratio w in (Rect x y w1 h, Rect (x + w1) y w2 h) + South -> let (h1, h2) = chop ratio h in (Rect x y w h1, Rect x (y + h1) w h2) + West -> let (w1, w2) = chop (1 - ratio) w in (Rect (x + w1) y w2 h, Rect x y w1 h) + North -> let (h1, h2) = chop (1 - ratio) h in (Rect x (y + h1) w h2, Rect x y w h1) + +chop :: Rational -> Integer -> (Integer, Integer) +chop rat n = let f = ((fromIntegral n) * (numerator rat)) `div` (denominator rat) in + (f, n - f) diff --git a/XMonad/Layout/Square.hs b/XMonad/Layout/Square.hs new file mode 100644 index 0000000..e05f549 --- /dev/null +++ b/XMonad/Layout/Square.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Square +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +-- A layout that splits the screen into a square area and the rest of the +-- screen. +-- This is probably only ever useful in combination with +-- "XMonad.Layout.Combo". +-- It sticks one window in a square region, and makes the rest +-- of the windows live with what's left (in a full-screen sense). +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Square ( + -- * Usage + -- $usage + Square(..) ) where + +import XMonad +import Graphics.X11.Xlib +import XMonad.StackSet ( integrate ) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.Square +-- +-- An example layout using square together with "XMonad.Layout.Combo" +-- to make the very last area square: +-- +-- > , combo (combo (mirror $ twoPane 0.03 0.85),1)] (twoPane 0.03 0.5) ) +-- > [(twoPane 0.03 0.2,1),(combo [(twoPane 0.03 0.8,1),(square,1)] +-- > [(tabbed,3),(tabbed,30),(tabbed,1),(tabbed,1)] + +-- %import XMonad.Layout.Square + +data Square a = Square deriving ( Read, Show ) + +instance LayoutClass Square a where + pureLayout Square r s = arrange (integrate s) + where arrange ws@(_:_) = map (\w->(w,rest)) (init ws) ++ [(last ws,sq)] + arrange [] = [] -- actually, this is an impossible case + (rest, sq) = splitSquare r + +splitSquare :: Rectangle -> (Rectangle, Rectangle) +splitSquare (Rectangle x y w h) + | w > h = (Rectangle x y (w - h) h, Rectangle (x+fromIntegral (w-h)) y h h) + | otherwise = (Rectangle x y w (h-w), Rectangle x (y+fromIntegral (h-w)) w w) diff --git a/XMonad/Layout/SwitchTrans.hs b/XMonad/Layout/SwitchTrans.hs new file mode 100644 index 0000000..986202e --- /dev/null +++ b/XMonad/Layout/SwitchTrans.hs @@ -0,0 +1,194 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.SwitchTrans +-- Copyright : (c) Lukas Mai +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : <l.mai@web.de> +-- Stability : unstable +-- Portability : unportable +-- +-- +-- Ordinary layout transformers are simple and easy to use but inflexible. +-- This module provides a more structured interface to them. +-- +-- The basic idea is to have a base layout and a set of layout transformers, +-- of which at most one is active at any time. Enabling another transformer +-- first disables any currently active transformer; i.e. it works like +-- a group of radio buttons. +-- +-- A side effect of this meta-layout is that layout transformers no longer +-- receive any messages; any message not handled by @SwitchTrans@ itself will +-- undo the current layout transformer, pass the message on to the base layout, +-- then reapply the transformer. +-- +-- Another potential problem is that functions can't be (de-)serialized so this +-- layout will not preserve state across xmonad restarts. +-- +-- Here's how you might use this in Config.hs: +-- +-- > layouts = +-- > map ( +-- > mkSwitch (M.fromList [ +-- > ("full", const $ Layout $ noBorders Full) +-- > ]) . +-- > mkSwitch (M.fromList [ +-- > ("mirror", Layout . Mirror) +-- > ]) +-- > ) [ Layout tiled ] +-- +-- (The @noBorders@ transformer is from "XMonad.Layout.NoBorders".) +-- +-- This example is probably overkill but it's very close to what I actually use. +-- Anyway, this layout behaves like the default @tiled@ layout, until you send it +-- @Enable@\/@Disable@\/@Toggle@ messages. From the definition of @keys@: +-- +-- > ... +-- > , ((modMask, xK_f ), sendMessage $ Toggle "full") +-- > , ((modMask, xK_r ), sendMessage $ Toggle "mirror") +-- +-- (You may want to use other keys. I don't use Xinerama so the default mod-r +-- binding is useless to me.) +-- +-- After this, pressing @mod-f@ switches the current window to fullscreen mode. +-- Pressing @mod-f@ again switches it back. Similarly, @mod-r@ rotates the layout +-- by 90 degrees (and back). The nice thing is that your changes are kept: +-- Rotating first then changing the size of the master area then rotating back +-- does not undo the master area changes. +-- +-- The reason I use two stacked @SwitchTrans@ transformers instead of @mkSwitch +-- (M.fromList [(\"full\", const $ Layout $ noBorders Full), (\"mirror\", +-- Layout . Mirror)])@ is that I use @mod-f@ to \"zoom in\" on interesting +-- windows, no matter what other layout transformers may be active. Having an +-- extra fullscreen mode on top of everything else means I can zoom in and out +-- without implicitly undoing \"normal\" layout transformers, like @Mirror@. +-- Remember, inside a @SwitchTrans@ there can be at most one active layout +-- transformer. +----------------------------------------------------------------------------- + +module XMonad.Layout.SwitchTrans ( + Toggle(..), + Enable(..), + Disable(..), + mkSwitch +) where + +import XMonad +import XMonad.Operations + +import qualified Data.Map as M +import Data.Map (Map) + +--import System.IO + + +-- | Toggle the specified layout transformer. +data Toggle = Toggle String deriving (Eq, Typeable) +instance Message Toggle +-- | Enable the specified transformer. +data Enable = Enable String deriving (Eq, Typeable) +instance Message Enable +-- | Disable the specified transformer. +data Disable = Disable String deriving (Eq, Typeable) +instance Message Disable + +data SwitchTrans a = SwitchTrans { + base :: Layout a, + currTag :: Maybe String, + currLayout :: Layout a, + currFilt :: Layout a -> Layout a, + filters :: Map String (Layout a -> Layout a) +} + +instance Show (SwitchTrans a) where + show st = "SwitchTrans #<base: " ++ show (base st) ++ ", tag: " ++ show (currTag st) ++ ", layout: " ++ show (currLayout st) ++ ", ...>" + +instance Read (SwitchTrans a) where + readsPrec _ _ = [] + +unLayout :: Layout a -> (forall l. (LayoutClass l a) => l a -> r) -> r +unLayout (Layout l) k = k l + +acceptChange :: (LayoutClass l a) => SwitchTrans a -> ((l a -> SwitchTrans a) -> b -> c) -> X b -> X c +acceptChange st f action = + -- seriously, Dave, you need to stop this + fmap (f (\l -> st{ currLayout = Layout l})) action + +instance LayoutClass SwitchTrans a where + description _ = "SwitchTrans" + + doLayout st r s = currLayout st `unLayout` \l -> do + --io $ hPutStrLn stderr $ "[ST]{ " ++ show st + x{- @(_, w) -} <- acceptChange st (fmap . fmap) (doLayout l r s) + --io $ hPutStrLn stderr $ "[ST]} " ++ show w + return x + + pureLayout st r s = currLayout st `unLayout` \l -> pureLayout l r s + + handleMessage st m + | Just (Disable tag) <- fromMessage m + , M.member tag (filters st) + = provided (currTag st == Just tag) $ disable + | Just (Enable tag) <- fromMessage m + , Just alt <- M.lookup tag (filters st) + = provided (currTag st /= Just tag) $ enable tag alt + | Just (Toggle tag) <- fromMessage m + , Just alt <- M.lookup tag (filters st) + = + if (currTag st == Just tag) then + disable + else + enable tag alt + | Just ReleaseResources <- fromMessage m + = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]~ " ++ show st + acceptChange st fmap (handleMessage cl m) + | Just Hide <- fromMessage m + = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]< " ++ show st + x <- acceptChange st fmap (handleMessage cl m) + --io $ hPutStrLn stderr $ "[ST]> " ++ show x + return x + | otherwise = base st `unLayout` \b -> do + x <- handleMessage b m + case x of + Nothing -> return Nothing + Just b' -> currLayout st `unLayout` \cl -> do + handleMessage cl (SomeMessage ReleaseResources) + let b'' = Layout b' + return . Just $ st{ base = b'', currLayout = currFilt st b'' } + where + enable tag alt = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]+ " ++ show cl ++ " -> " ++ show (alt (base st)) + handleMessage cl (SomeMessage ReleaseResources) + return . Just $ st{ + currTag = Just tag, + currFilt = alt, + currLayout = alt (base st) } + disable = currLayout st `unLayout` \cl -> do + --io $ hPutStrLn stderr $ "[ST]- " ++ show cl ++ " -> " ++ show (base st) + handleMessage cl (SomeMessage ReleaseResources) + return . Just $ st{ + currTag = Nothing, + currFilt = id, + currLayout = base st } + +-- | Take a transformer table and a base layout, and return a +-- SwitchTrans layout. +mkSwitch :: Map String (Layout a -> Layout a) -> Layout a -> Layout a +mkSwitch fs b = Layout st + where + st = SwitchTrans{ + base = b, + currTag = Nothing, + currLayout = b, + currFilt = id, + filters = fs } + +provided :: Bool -> X (Maybe a) -> X (Maybe a) +provided c x + | c = x + | otherwise = return Nothing + diff --git a/XMonad/Layout/Tabbed.hs b/XMonad/Layout/Tabbed.hs new file mode 100644 index 0000000..92ef150 --- /dev/null +++ b/XMonad/Layout/Tabbed.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Tabbed +-- Copyright : (c) 2007 David Roundy, Andrea Rossato +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : droundy@darcs.net, andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A tabbed layout for the Xmonad Window Manager +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Tabbed ( + -- * Usage: + -- $usage + tabbed + , shrinkText + , TConf (..), defaultTConf + ) where + +import Control.Monad.State ( gets ) +import Control.Monad.Reader +import Data.Maybe +import Data.Bits +import Data.List + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad +import XMonad.Operations +import qualified XMonad.StackSet as W + +import XMonad.Util.NamedWindows +import XMonad.Util.Invisible +import XMonad.Util.XUtils + +-- $usage +-- You can use this module with the following in your configuration file: +-- +-- > import XMonad.Layout.Tabbed +-- +-- > layouts :: [Layout Window] +-- > layouts = [ Layout tiled +-- > , Layout $ Mirror tiled +-- > , Layout Full +-- > +-- > -- Extension-provided layouts +-- > , Layout $ tabbed shrinkText defaultTConf +-- > ] +-- > +-- > , ... ] +-- +-- You can also edit the default configuration options. +-- +-- > myTabConfig = defaultTConf { inactiveBorderColor = "#FF0000" +-- > , activeTextColor = "#00FF00"} +-- +-- and +-- +-- > layouts = [ ... +-- > , Layout $ tabbed shrinkText myTabConfig ] + +-- %import XMonad.Layout.Tabbed +-- %layout , tabbed shrinkText defaultTConf + +tabbed :: Shrinker -> TConf -> Tabbed a +tabbed s t = Tabbed (I Nothing) (I (Just s)) t + +data TConf = + TConf { activeColor :: String + , inactiveColor :: String + , activeBorderColor :: String + , inactiveTextColor :: String + , inactiveBorderColor :: String + , activeTextColor :: String + , fontName :: String + , tabSize :: Int + } deriving (Show, Read) + +defaultTConf :: TConf +defaultTConf = + TConf { activeColor = "#999999" + , inactiveColor = "#666666" + , activeBorderColor = "#FFFFFF" + , inactiveBorderColor = "#BBBBBB" + , activeTextColor = "#FFFFFF" + , inactiveTextColor = "#BFBFBF" + , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , tabSize = 20 + } + +data TabState = + TabState { tabsWindows :: [(Window,Window)] + , scr :: Rectangle + , fontS :: FontStruct -- FontSet + } + +data Tabbed a = + Tabbed (Invisible Maybe TabState) (Invisible Maybe Shrinker) TConf + deriving (Show, Read) + +instance LayoutClass Tabbed Window where + doLayout (Tabbed ist ishr conf) = doLay ist ishr conf + handleMessage = handleMess + description _ = "Tabbed" + +doLay :: Invisible Maybe TabState -> Invisible Maybe Shrinker -> TConf + -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed Window)) +doLay ist ishr c sc (W.Stack w [] []) = do + whenIJust ist $ \st -> mapM_ deleteWindow (map fst $ tabsWindows st) + return ([(w,sc)], Just $ Tabbed (I Nothing) ishr c) +doLay ist ishr conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do + let ws = W.integrate s + width = wid `div` fromIntegral (length ws) + -- initialize state + st <- case ist of + (I Nothing ) -> initState conf sc ws + (I (Just ts)) -> if map snd (tabsWindows ts) == ws && scr ts == sc + then return ts + else do mapM_ deleteWindow (map fst $ tabsWindows ts) + tws <- createTabs conf sc ws + return (ts {scr = sc, tabsWindows = zip tws ws}) + mapM_ showWindow $ map fst $ tabsWindows st + mapM_ (updateTab ishr conf (fontS st) width) $ tabsWindows st + return ([(w,shrink conf sc)], Just (Tabbed (I (Just st)) ishr conf)) + +handleMess :: Tabbed Window -> SomeMessage -> X (Maybe (Tabbed Window)) +handleMess (Tabbed (I (Just st@(TabState {tabsWindows = tws}))) ishr conf) m + | Just e <- fromMessage m :: Maybe Event = handleEvent ishr conf st e >> return Nothing + | Just Hide == fromMessage m = mapM_ hideWindow (map fst tws) >> return Nothing + | Just ReleaseResources == fromMessage m = do mapM_ deleteWindow $ map fst tws + releaseFont (fontS st) + return $ Just $ Tabbed (I Nothing) (I Nothing) conf +handleMess _ _ = return Nothing + +handleEvent :: Invisible Maybe Shrinker -> TConf -> TabState -> Event -> X () +-- button press +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t }) + | t == buttonPress, tl <- map fst tws, thisw `elem` tl || thisbw `elem` tl = do + case lookup thisw tws of + Just x -> do focus x + updateTab ishr conf fs width (thisw, x) + Nothing -> return () + where width = rect_width screen `div` fromIntegral (length tws) +-- propertyNotify +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (PropertyEvent {ev_window = thisw }) + | thisw `elem` (map snd tws) = do + let tabwin = (fst $ fromJust $ find ((== thisw) . snd) tws, thisw) + updateTab ishr conf fs width tabwin + where width = rect_width screen `div` fromIntegral (length tws) +-- expose +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (ExposeEvent {ev_window = thisw }) + | thisw `elem` (map fst tws) = do + updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws) + where width = rect_width screen `div` fromIntegral (length tws) +handleEvent _ _ _ _ = return () + +initState :: TConf -> Rectangle -> [Window] -> X TabState +initState conf sc ws = do + fs <- initFont (fontName conf) + tws <- createTabs conf sc ws + return $ TabState (zip tws ws) sc fs + +createTabs :: TConf -> Rectangle -> [Window] -> X [Window] +createTabs _ _ [] = return [] +createTabs c (Rectangle x y wh ht) owl@(ow:ows) = do + let wid = wh `div` (fromIntegral $ length owl) + height = fromIntegral $ tabSize c + mask = Just (exposureMask .|. buttonPressMask) + d <- asks display + w <- createNewWindow (Rectangle x y wid height) mask (inactiveColor c) + io $ restackWindows d $ w : [ow] + ws <- createTabs c (Rectangle (x + fromIntegral wid) y (wh - wid) ht) ows + return (w:ws) + +updateTab :: Invisible Maybe Shrinker -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X () +updateTab ishr c fs wh (tabw,ow) = do + nw <- getName ow + let ht = fromIntegral $ tabSize c :: Dimension + focusColor win ic ac = (maybe ic (\focusw -> if focusw == win + then ac else ic) . W.peek) + `fmap` gets windowset + (bc',borderc',tc') <- focusColor ow + (inactiveColor c, inactiveBorderColor c, inactiveTextColor c) + (activeColor c, activeBorderColor c, activeTextColor c) + let s = fromIMaybe shrinkText ishr + name = shrinkWhile s (\n -> textWidth fs n > + fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) + paintAndWrite tabw fs wh ht 1 bc' borderc' tc' bc' AlignCenter name + +shrink :: TConf -> Rectangle -> Rectangle +shrink c (Rectangle x y w h) = + Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c)) + +type Shrinker = String -> [String] + +shrinkWhile :: Shrinker -> (String -> Bool) -> String -> String +shrinkWhile sh p x = sw $ sh x + where sw [n] = n + sw [] = "" + sw (n:ns) | p n = sw ns + | otherwise = n + +shrinkText :: Shrinker +shrinkText "" = [""] +shrinkText cs = cs : shrinkText (init cs) diff --git a/XMonad/Layout/ThreeColumns.hs b/XMonad/Layout/ThreeColumns.hs new file mode 100644 index 0000000..2dd2551 --- /dev/null +++ b/XMonad/Layout/ThreeColumns.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ThreeColumns +-- Copyright : (c) Kai Grossjohann <kai@emptydomain.de> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : ? +-- Stability : unstable +-- Portability : unportable +-- +-- A layout similar to tall but with three columns. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.ThreeColumns ( + -- * Usage + -- $usage + ThreeCol(..) + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Layouts ( Resize(..), IncMasterN(..), splitVertically, splitHorizontallyBy ) + +import Data.Ratio + +--import Control.Monad.State +import Control.Monad.Reader + +import Graphics.X11.Xlib + +-- $usage +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.ThreeColumns +-- +-- and add, to the list of layouts: +-- +-- > ThreeCol nmaster delta ratio + +-- %import XMonad.Layout.ThreeColumns +-- %layout , ThreeCol nmaster delta ratio + +data ThreeCol a = ThreeCol Int Rational Rational deriving (Show,Read) + +instance LayoutClass ThreeCol a where + doLayout (ThreeCol nmaster _ frac) r = + return . (\x->(x,Nothing)) . + ap zip (tile3 frac r nmaster . length) . W.integrate + handleMessage (ThreeCol nmaster delta frac) m = + return $ msum [fmap resize (fromMessage m) + ,fmap incmastern (fromMessage m)] + where resize Shrink = ThreeCol nmaster delta (max 0 $ frac-delta) + resize Expand = ThreeCol nmaster delta (min 1 $ frac+delta) + incmastern (IncMasterN d) = ThreeCol (max 0 (nmaster+d)) delta frac + description _ = "ThreeCol" + +-- | tile3. Compute window positions using 3 panes +tile3 :: Rational -> Rectangle -> Int -> Int -> [Rectangle] +tile3 f r nmaster n + | n <= nmaster || nmaster == 0 = splitVertically n r + | n <= nmaster+1 = splitVertically nmaster s1 ++ splitVertically (n-nmaster) s2 + | otherwise = splitVertically nmaster r1 ++ splitVertically nmid r2 ++ splitVertically nright r3 + where (r1, r2, r3) = split3HorizontallyBy f r + (s1, s2) = splitHorizontallyBy f r + nslave = (n - nmaster) + nmid = ceiling (nslave % 2) + nright = (n - nmaster - nmid) + +split3HorizontallyBy :: Rational -> Rectangle -> (Rectangle, Rectangle, Rectangle) +split3HorizontallyBy f (Rectangle sx sy sw sh) = + ( Rectangle sx sy leftw sh + , Rectangle (sx + fromIntegral leftw) sy midw sh + , Rectangle (sx + fromIntegral leftw + fromIntegral midw) sy rightw sh ) + where leftw = ceiling $ fromIntegral sw * (2/3) * f + midw = ceiling ( (sw - leftw) % 2 ) + rightw = sw - leftw - midw diff --git a/XMonad/Layout/TilePrime.hs b/XMonad/Layout/TilePrime.hs new file mode 100644 index 0000000..36d54f6 --- /dev/null +++ b/XMonad/Layout/TilePrime.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} +-- -------------------------------------------------------------------------- +-- -- | +-- -- Module : TilePrime.hs +-- -- Copyright : (c) Eric Mertens 2007 +-- -- License : BSD3-style (see LICENSE) +-- -- +-- -- Maintainer : emertens@gmail.com +-- -- Stability : unstable +-- -- Portability : not portable +-- -- +-- -- TilePrime. Tile windows filling gaps created by resize hints +-- -- +-- ----------------------------------------------------------------------------- +-- + +module XMonad.Layout.TilePrime ( + -- * Usage + -- $usage + TilePrime(TilePrime) + ) where + +import Control.Monad (mplus) +import Data.List (mapAccumL) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras (getWMNormalHints) +import XMonad.Operations +import XMonad hiding (trace) +import qualified XMonad.StackSet as W +import {-#SOURCE#-} Config (borderWidth) + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.TilePrime +-- +-- and add the following line to your 'layouts' +-- +-- > , Layout $ TilePrime nmaster delta ratio False +-- +-- Use True as the last argument to get a wide layout. + +-- %import XMonad.Layout.TilePrime +-- %layout , Layout $ TilePrime nmaster delta ratio False + +data TilePrime a = TilePrime + { nmaster :: Int + , delta, frac :: Rational + , flipped :: Bool + } deriving (Show, Read) + +instance LayoutClass TilePrime Window where + description c | flipped c = "TilePrime Horizontal" + | otherwise = "TilePrime Vertical" + + pureMessage c m = fmap resize (fromMessage m) `mplus` + fmap incmastern (fromMessage m) + where + resize Shrink = c { frac = max 0 $ frac c - delta c } + resize Expand = c { frac = min 1 $ frac c + delta c } + incmastern (IncMasterN d) = c { nmaster = max 0 $ nmaster c + d } + + doLayout TilePrime { frac = f, nmaster = m, flipped = flp } rect s = do + let xs = W.integrate s + hints <- withDisplay $ \ disp -> io (mapM (getWMNormalHints disp) xs) + let xs' = zip xs hints + (leftXs, rightXs) = splitAt m xs' + (leftRect, rightRect) + | null rightXs = (rect, Rectangle 0 0 0 0) + | null leftXs = (Rectangle 0 0 0 0, rect) + | flp = splitVerticallyBy f rect + | otherwise = splitHorizontallyBy f rect + masters = fillWindows leftRect leftXs + slaves = fillWindows rightRect rightXs + return (masters ++ slaves, Nothing) + + where + fillWindows r xs = snd $ mapAccumL aux (r,n) xs + where n = fromIntegral (length xs) :: Rational + + aux (r,n) (x,hint) = ((rest,n-1),(x,r')) + where + (allocated, _) | flp = splitHorizontallyBy (recip n) r + | otherwise = splitVerticallyBy (recip n) r + + (w,h) = applySizeHints hint `underBorders` rect_D allocated + + r' = r { rect_width = w, rect_height = h } + + rest | flp = r { rect_x = rect_x r + toEnum (fromEnum w) + , rect_width = rect_width r - w } + | otherwise = r { rect_y = rect_y r + toEnum (fromEnum h) + , rect_height = rect_height r - h } + +rect_D :: Rectangle -> D +rect_D Rectangle { rect_width = w, rect_height = h } = (w,h) + +-- | Transform a function on dimensions into one without regard for borders +underBorders :: (D -> D) -> D -> D +underBorders f = adjBorders 1 . f . adjBorders (-1) + +-- | Modify dimensions by a multiple of the current borders +adjBorders :: Dimension -> D -> D +adjBorders mult (w,h) = (w+2*mult*borderWidth, h+2*mult*borderWidth) diff --git a/XMonad/Layout/ToggleLayouts.hs b/XMonad/Layout/ToggleLayouts.hs new file mode 100644 index 0000000..0130cf7 --- /dev/null +++ b/XMonad/Layout/ToggleLayouts.hs @@ -0,0 +1,84 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ToggleLayouts +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : portable +-- +-- A module for writing easy Layouts +----------------------------------------------------------------------------- + +module XMonad.Layout.ToggleLayouts ( + -- * Usage + -- $usage + toggleLayouts, ToggleLayout(..) + ) where + +import XMonad + +-- $usage +-- Use toggleLayouts to toggle between two layouts. +-- +-- import XMonad.Layout.ToggleLayouts +-- +-- and add to your layoutHook something like +-- +-- > layoutHook = Layout $ toggleLayouts (noBorders Full) $ Select layouts +-- +-- and a key binding like +-- > , ((modMask .|. controlMask, xK_space), sendMessage ToggleLayout) +-- +-- or a key binding like +-- > , ((modMask .|. controlMask, xK_space), sendMessage (Toggle "Full")) + +data ToggleLayouts lt lf a = ToggleLayouts Bool (lt a) (lf a) deriving (Read,Show) +data ToggleLayout = ToggleLayout | Toggle String deriving (Read,Show,Typeable) +instance Message ToggleLayout + +toggleLayouts :: (LayoutClass lt a, LayoutClass lf a) => lt a -> lf a -> ToggleLayouts lt lf a +toggleLayouts = ToggleLayouts False + +instance (LayoutClass lt a, LayoutClass lf a) => LayoutClass (ToggleLayouts lt lf) a where + doLayout (ToggleLayouts True lt lf) r s = do (ws,mlt') <- doLayout lt r s + return (ws,fmap (\lt' -> ToggleLayouts True lt' lf) mlt') + doLayout (ToggleLayouts False lt lf) r s = do (ws,mlf') <- doLayout lf r s + return (ws,fmap (\lf' -> ToggleLayouts False lt lf') mlf') + description (ToggleLayouts True lt _) = description lt + description (ToggleLayouts False _ lf) = description lf + handleMessage (ToggleLayouts bool lt lf) m + | Just ReleaseResources <- fromMessage m = + do mlf' <- handleMessage lf m + mlt' <- handleMessage lt m + return $ case (mlt',mlf') of + (Nothing ,Nothing ) -> Nothing + (Just lt',Nothing ) -> Just $ ToggleLayouts bool lt' lf + (Nothing ,Just lf') -> Just $ ToggleLayouts bool lt lf' + (Just lt',Just lf') -> Just $ ToggleLayouts bool lt' lf' + handleMessage (ToggleLayouts True lt lf) m + | Just ToggleLayout <- fromMessage m = do mlt' <- handleMessage lt (SomeMessage Hide) + let lt' = maybe lt id mlt' + return $ Just $ ToggleLayouts False lt' lf + | Just (Toggle d) <- fromMessage m, + d == description lt || d == description lf = + do mlt' <- handleMessage lt (SomeMessage Hide) + let lt' = maybe lt id mlt' + return $ Just $ ToggleLayouts False lt' lf + | otherwise = do mlt' <- handleMessage lt m + return $ fmap (\lt' -> ToggleLayouts True lt' lf) mlt' + handleMessage (ToggleLayouts False lt lf) m + | Just ToggleLayout <- fromMessage m = do mlf' <- handleMessage lf (SomeMessage Hide) + let lf' = maybe lf id mlf' + return $ Just $ ToggleLayouts True lt lf' + | Just (Toggle d) <- fromMessage m, + d == description lt || d == description lf = + do mlf' <- handleMessage lf (SomeMessage Hide) + let lf' = maybe lf id mlf' + return $ Just $ ToggleLayouts True lt lf' + | otherwise = do mlf' <- handleMessage lf m + return $ fmap (\lf' -> ToggleLayouts False lt lf') mlf' diff --git a/XMonad/Layout/TwoPane.hs b/XMonad/Layout/TwoPane.hs new file mode 100644 index 0000000..bca49a7 --- /dev/null +++ b/XMonad/Layout/TwoPane.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.TwoPane +-- Copyright : (c) Spencer Janssen <sjanssen@cse.unl.edu> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <sjanssen@cse.unl.edu> +-- Stability : unstable +-- Portability : unportable +-- +-- A layout that splits the screen horizontally and shows two windows. The +-- left window is always the master window, and the right is either the +-- currently focused window or the second window in layout order. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.TwoPane ( + -- * Usage + -- $usage + TwoPane (..) + ) where + +import XMonad +import XMonad.Layouts ( Resize(..), splitHorizontallyBy ) +import XMonad.StackSet ( focus, up, down) + +-- $usage +-- +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.TwoPane +-- +-- and add, to the list of layouts: +-- +-- > , (Layout $ TwoPane 0.03 0.5) + +-- %import XMonad.Layout.TwoPane +-- %layout , (Layout $ TwoPane 0.03 0.5) + +data TwoPane a = + TwoPane Rational Rational + deriving ( Show, Read ) + +instance LayoutClass TwoPane a where + doLayout (TwoPane _ split) r s = return (arrange r s,Nothing) + where + arrange rect st = case reverse (up st) of + (master:_) -> [(master,left),(focus st,right)] + [] -> case down st of + (next:_) -> [(focus st,left),(next,right)] + [] -> [(focus st, rect)] + where (left, right) = splitHorizontallyBy split rect + + handleMessage (TwoPane delta split) x = + return $ case fromMessage x of + Just Shrink -> Just (TwoPane delta (split - delta)) + Just Expand -> Just (TwoPane delta (split + delta)) + _ -> Nothing + diff --git a/XMonad/Layout/WindowNavigation.hs b/XMonad/Layout/WindowNavigation.hs new file mode 100644 index 0000000..4608ba5 --- /dev/null +++ b/XMonad/Layout/WindowNavigation.hs @@ -0,0 +1,214 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.WindowNavigation +-- Copyright : (c) 2007 David Roundy <droundy@darcs.net> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +-- WindowNavigation is an extension to allow easy navigation of a workspace. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.WindowNavigation ( + -- * Usage + -- $usage + windowNavigation, configurableNavigation, + Navigate(..), Direction(..), + MoveWindowToWindow(..), + navigateColor, navigateBrightness, + noNavigateBorders, defaultWNConfig + ) where + +import Graphics.X11.Xlib ( Rectangle(..), Window, Pixel, setWindowBorder ) +import Control.Monad.Reader ( ask ) +import Control.Monad.State ( gets ) +import Data.List ( nub, sortBy, (\\) ) +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Operations ( windows, focus ) +import XMonad.Layout.LayoutModifier +import XMonad.Util.Invisible +import XMonad.Util.XUtils + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.WindowNavigation +-- > +-- > layoutHook = Layout $ windowNavigation $ Select ... +-- +-- or perhaps +-- +-- > layoutHook = Layout $ configurableNavigation (navigateColor "green") $ Select ... +-- +-- In keybindings: +-- +-- > , ((modMask, xK_Right), sendMessage $ Go R) +-- > , ((modMask, xK_Left ), sendMessage $ Go L) +-- > , ((modMask, xK_Up ), sendMessage $ Go U) +-- > , ((modMask, xK_Down ), sendMessage $ Go D) + +-- %import XMonad.Layout.WindowNavigation +-- %keybind , ((modMask, xK_Right), sendMessage $ Go R) +-- %keybind , ((modMask, xK_Left ), sendMessage $ Go L) +-- %keybind , ((modMask, xK_Up ), sendMessage $ Go U) +-- %keybind , ((modMask, xK_Down ), sendMessage $ Go D) +-- %keybind , ((modMask .|. controlMask, xK_Right), sendMessage $ Swap R) +-- %keybind , ((modMask .|. controlMask, xK_Left ), sendMessage $ Swap L) +-- %keybind , ((modMask .|. controlMask, xK_Up ), sendMessage $ Swap U) +-- %keybind , ((modMask .|. controlMask, xK_Down ), sendMessage $ Swap D) +-- %layout -- include 'windowNavigation' in layoutHook definition above. +-- %layout -- just before the list, like the following (don't uncomment next line): +-- %layout -- layoutHook = Layout $ windowNavigation $ ... +-- %layout -- or +-- %layout -- layoutHook = Layout $ configurableNavigation (navigateColor "green") $ ... + +data MoveWindowToWindow a = MoveWindowToWindow a a deriving ( Read, Show, Typeable ) +instance Typeable a => Message (MoveWindowToWindow a) + +data Navigate = Go Direction | Swap Direction | Move Direction deriving ( Read, Show, Typeable ) +data Direction = U | D | R | L deriving ( Read, Show, Eq ) +instance Message Navigate + +data WNConfig = + WNC { brightness :: Maybe Double -- Indicates a fraction of the focus color. + , upColor :: String + , downColor :: String + , leftColor :: String + , rightColor :: String + } deriving (Show, Read) + +noNavigateBorders :: WNConfig +noNavigateBorders = + defaultWNConfig {brightness = Just 0} + +navigateColor :: String -> WNConfig +navigateColor c = + WNC Nothing c c c c + +navigateBrightness :: Double -> WNConfig +navigateBrightness f | f > 1 = navigateBrightness 1 + | f < 0 = navigateBrightness 0 +navigateBrightness f = defaultWNConfig { brightness = Just f } + +defaultWNConfig :: WNConfig +defaultWNConfig = WNC (Just 0.5) "#0000FF" "#00FFFF" "#FF0000" "#FF00FF" + +data NavigationState a = NS Point [(a,Rectangle)] + +data WindowNavigation a = WindowNavigation WNConfig (Invisible Maybe (NavigationState a)) deriving ( Read, Show ) + +windowNavigation :: LayoutClass l a => l a -> ModifiedLayout WindowNavigation l a +windowNavigation = ModifiedLayout (WindowNavigation defaultWNConfig (I Nothing)) + +configurableNavigation :: LayoutClass l a => WNConfig -> l a -> ModifiedLayout WindowNavigation l a +configurableNavigation conf = ModifiedLayout (WindowNavigation conf (I Nothing)) + +instance LayoutModifier WindowNavigation Window where + redoLayout (WindowNavigation conf (I state)) rscr s wrs = + do XConf { normalBorder = nbc, focusedBorder = fbc } <- ask + [uc,dc,lc,rc] <- + case brightness conf of + Just frac -> do myc <- averagePixels fbc nbc frac + return [myc,myc,myc,myc] + Nothing -> mapM stringToPixel [upColor conf, downColor conf, + leftColor conf, rightColor conf] + let dirc U = uc + dirc D = dc + dirc L = lc + dirc R = rc + let w = W.focus s + r = case filter ((==w).fst) wrs of ((_,x):_) -> x + [] -> rscr + pt = case state of Just (NS ptold _) | ptold `inrect` r -> ptold + _ -> center r + wrs' = filter ((/=w) . fst) wrs + wnavigable = nub $ concatMap + (\d -> truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L] + wnavigablec = nub $ concatMap + (\d -> map (\(win,_) -> (win,dirc d)) $ + truncHead $ sortby d $ filter (inr d pt . snd) wrs') [U,D,R,L] + wothers = case state of Just (NS _ wo) -> map fst wo + _ -> [] + mapM_ (sc nbc) (wothers \\ map fst wnavigable) + mapM_ (\(win,c) -> sc c win) wnavigablec + return (wrs, Just $ WindowNavigation conf $ I $ Just $ NS pt wnavigable) + + handleMessOrMaybeModifyIt (WindowNavigation conf (I (Just (NS pt wrs)))) m + | Just (Go d) <- fromMessage m = + case sortby d $ filter (inr d pt . snd) wrs of + [] -> return Nothing + ((w,r):_) -> do focus w + return $ Just $ Left $ WindowNavigation conf $ I $ Just $ + NS (centerd d pt r) wrs + | Just (Swap d) <- fromMessage m = + case sortby d $ filter (inr d pt . snd) wrs of + [] -> return Nothing + ((w,_):_) -> do let swap st = unint (W.focus st) $ map (swapw (W.focus st)) $ W.integrate st + swapw y x | x == w = y + | x == y = w + | otherwise = x + unint f xs = case span (/= f) xs of + (u,_:dn) -> W.Stack { W.focus = f + , W.up = reverse u + , W.down = dn } + _ -> W.Stack { W.focus = f + , W.down = xs + , W.up = [] } + windows $ W.modify' swap + return Nothing + | Just (Move d) <- fromMessage m = + case sortby d $ filter (inr d pt . snd) wrs of + [] -> return Nothing + ((w,_):_) -> do mst <- gets (W.stack . W.workspace . W.current . windowset) + return $ do st <- mst + Just $ Right $ SomeMessage $ MoveWindowToWindow (W.focus st) w + | Just Hide <- fromMessage m = + do XConf { normalBorder = nbc } <- ask + mapM_ (sc nbc . fst) wrs + return $ Just $ Left $ WindowNavigation conf $ I $ Just $ NS pt [] + | Just ReleaseResources <- fromMessage m = + handleMessOrMaybeModifyIt (WindowNavigation conf (I $ Just (NS pt wrs))) (SomeMessage Hide) + handleMessOrMaybeModifyIt _ _ = return Nothing + +truncHead :: [a] -> [a] +truncHead (x:_) = [x] +truncHead [] = [] + +sc :: Pixel -> Window -> X () +sc c win = withDisplay $ \dpy -> io $ setWindowBorder dpy win c + +center :: Rectangle -> Point +center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2) (fromIntegral y + fromIntegral h/2) + +centerd :: Direction -> Point -> Rectangle -> Point +centerd d (P xx yy) (Rectangle x y w h) | d == U || d == D = P xx (fromIntegral y + fromIntegral h/2) + | otherwise = P (fromIntegral x + fromIntegral w/2) yy + +inr :: Direction -> Point -> Rectangle -> Bool +inr D (P x y) (Rectangle l yr w h) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + y < fromIntegral yr + fromIntegral h +inr U (P x y) (Rectangle l yr w _) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + y > fromIntegral yr +inr R (P a x) (Rectangle b l _ w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + a < fromIntegral b +inr L (P a x) (Rectangle b l c w) = x >= fromIntegral l && x < fromIntegral l + fromIntegral w && + a > fromIntegral b + fromIntegral c + +inrect :: Point -> Rectangle -> Bool +inrect (P x y) (Rectangle a b w h) = x > fromIntegral a && x < fromIntegral a + fromIntegral w && + y > fromIntegral b && y < fromIntegral b + fromIntegral h + +sortby :: Direction -> [(a,Rectangle)] -> [(a,Rectangle)] +sortby U = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y' y) +sortby D = sortBy (\(_,Rectangle _ y _ _) (_,Rectangle _ y' _ _) -> compare y y') +sortby R = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x x') +sortby L = sortBy (\(_,Rectangle x _ _ _) (_,Rectangle x' _ _ _) -> compare x' x) + +data Point = P Double Double diff --git a/XMonad/Layout/WorkspaceDir.hs b/XMonad/Layout/WorkspaceDir.hs new file mode 100644 index 0000000..e5f15ce --- /dev/null +++ b/XMonad/Layout/WorkspaceDir.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.WorkspaceDir +-- Copyright : (c) 2007 David Roundy <droundy@darcs.net> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +-- WorkspaceDir is an extension to set the current directory in a workspace. +-- +-- Actually, it sets the current directory in a layout, since there's no way I +-- know of to attach a behavior to a workspace. This means that any terminals +-- (or other programs) pulled up in that workspace (with that layout) will +-- execute in that working directory. Sort of handy, I think. +-- +-- Requires the 'directory' package +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.WorkspaceDir ( + -- * Usage + -- $usage + workspaceDir, + changeDir + ) where + +import System.Directory ( setCurrentDirectory ) + +import XMonad +import XMonad.Operations ( sendMessage ) +import XMonad.Util.Run ( runProcessWithInput ) +import XMonad.Prompt ( XPConfig ) +import XMonad.Prompt.Directory ( directoryPrompt ) +import XMonad.Layout.LayoutModifier + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Layout.WorkspaceDir +-- > +-- > layouts = map (workspaceDir "~") [ tiled, ... ] +-- +-- In keybindings: +-- +-- > , ((modMask .|. shiftMask, xK_x ), changeDir defaultXPConfig) + +-- %import XMonad.Layout.WorkspaceDir +-- %keybind , ((modMask .|. shiftMask, xK_x ), changeDir defaultXPConfig) +-- %layout -- prepend 'map (workspaceDir "~")' to layouts definition above, +-- %layout -- just before the list, like the following (don't uncomment next line): +-- %layout -- layouts = map (workspaceDir "~") [ tiled, ... ] + + +data Chdir = Chdir String deriving ( Typeable ) +instance Message Chdir + +data WorkspaceDir a = WorkspaceDir String deriving ( Read, Show ) + +instance LayoutModifier WorkspaceDir a where + hook (WorkspaceDir s) = scd s + handleMess (WorkspaceDir _) m = return $ do Chdir wd <- fromMessage m + Just (WorkspaceDir wd) + +workspaceDir :: LayoutClass l a => String -> l a + -> ModifiedLayout WorkspaceDir l a +workspaceDir s = ModifiedLayout (WorkspaceDir s) + +scd :: String -> X () +scd x = do x' <- io (runProcessWithInput "bash" [] ("echo -n " ++ x) `catch` \_ -> return x) + catchIO $ setCurrentDirectory x' + +changeDir :: XPConfig -> X () +changeDir c = directoryPrompt c "Set working directory: " (sendMessage . Chdir) |