mirror of
https://github.com/xmonad/xmonad.git
synced 2025-05-19 00:20:22 -07:00
This is a massive update, here's what has changed:
* Read is no longer a superclass of Layout
* All of the core layouts have moved to the new Layouts.hs module
* Select has been replaced by the new statically typed Choose combinator,
which is heavily based on David Roundy's NewSelect proposal for
XMonadContrib. Consequently:
- Rather than a list of choosable layouts, we use the ||| combinator to
combine several layouts into a single switchable layout
- We've lost the capability to JumpToLayout and PrevLayout. Both can be
added with some effort
This commit is contained in:
Spencer Janssen
parent
48ccbc7fb2
commit
3789f37f25
45
EventLoop.hs
45
EventLoop.hs
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Main.hs
|
||||
@ -35,22 +36,23 @@ import Operations
|
||||
|
||||
import System.IO
|
||||
|
||||
data XMonadConfig l = XMonadConfig { normalBorderColor :: !String
|
||||
, focusedBorderColor :: !String
|
||||
, defaultTerminal :: !String
|
||||
, layoutHook :: !(l Window)
|
||||
, workspaces :: ![String]
|
||||
, defaultGaps :: ![(Int,Int,Int,Int)]
|
||||
, keys :: !(M.Map (ButtonMask,KeySym) (X ()))
|
||||
, mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ()))
|
||||
, borderWidth :: !Dimension
|
||||
, logHook :: !(X ())
|
||||
}
|
||||
data XMonadConfig = forall l. (LayoutClass l Window, Read (l Window)) =>
|
||||
XMonadConfig { normalBorderColor :: !String
|
||||
, focusedBorderColor :: !String
|
||||
, defaultTerminal :: !String
|
||||
, layoutHook :: !(l Window)
|
||||
, workspaces :: ![String]
|
||||
, defaultGaps :: ![(Int,Int,Int,Int)]
|
||||
, keys :: !(M.Map (ButtonMask,KeySym) (X ()))
|
||||
, mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ()))
|
||||
, borderWidth :: !Dimension
|
||||
, logHook :: !(X ())
|
||||
}
|
||||
|
||||
-- |
|
||||
-- The main entry point
|
||||
--
|
||||
makeMain :: LayoutClass l Window => XMonadConfig l -> IO ()
|
||||
makeMain :: XMonadConfig -> IO ()
|
||||
makeMain xmc = do
|
||||
dpy <- openDisplay ""
|
||||
let dflt = defaultScreen dpy
|
||||
@ -62,17 +64,18 @@ makeMain xmc = do
|
||||
hSetBuffering stdout NoBuffering
|
||||
args <- getArgs
|
||||
|
||||
let initialWinset = new (Layout $ layoutHook xmc) (workspaces xmc) $ zipWith SD xinesc gaps
|
||||
let (layout, lreads) = case xmc of XMonadConfig {layoutHook = lh } -> (Layout lh, \s -> [(Layout (x `asTypeOf` lh), s') | (x, s') <- reads s])
|
||||
initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps
|
||||
|
||||
maybeRead s = case reads s of
|
||||
[(x, "")] -> Just x
|
||||
_ -> Nothing
|
||||
maybeRead reads' s = case reads' s of
|
||||
[(x, "")] -> Just x
|
||||
_ -> Nothing
|
||||
|
||||
winset = fromMaybe initialWinset $ do
|
||||
("--resume" : s : _) <- return args
|
||||
ws <- maybeRead s
|
||||
return . W.ensureTags (Layout $ layoutHook xmc) (workspaces xmc)
|
||||
$ W.mapLayout (fromMaybe (Layout $ layoutHook xmc) . maybeRead) ws
|
||||
ws <- maybeRead reads s
|
||||
return . W.ensureTags layout (workspaces xmc)
|
||||
$ W.mapLayout (fromMaybe layout . maybeRead lreads) ws
|
||||
|
||||
gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0)
|
||||
|
||||
@ -256,7 +259,7 @@ scan dpy rootw = do
|
||||
&& (wa_map_state wa == waIsViewable || ic)
|
||||
|
||||
-- | Grab the keys back
|
||||
grabKeys :: XMonadConfig l -> X ()
|
||||
grabKeys :: XMonadConfig -> X ()
|
||||
grabKeys xmc = do
|
||||
XConf { display = dpy, theRoot = rootw } <- ask
|
||||
let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync
|
||||
@ -268,7 +271,7 @@ grabKeys xmc = do
|
||||
when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) extraModifiers
|
||||
|
||||
-- | XXX comment me
|
||||
grabButtons :: XMonadConfig l -> X ()
|
||||
grabButtons :: XMonadConfig -> X ()
|
||||
grabButtons xmc = do
|
||||
XConf { display = dpy, theRoot = rootw } <- ask
|
||||
let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask
|
||||
|
||||
166
Layouts.hs
Normal file
166
Layouts.hs
Normal file
@ -0,0 +1,166 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Layouts.hs
|
||||
-- Copyright : (c) Spencer Janssen 2007
|
||||
-- License : BSD3-style (see LICENSE)
|
||||
--
|
||||
-- Maintainer : sjanssen@cse.unl.edu
|
||||
-- Stability : unstable
|
||||
-- Portability : not portable, Typeable deriving, mtl, posix
|
||||
--
|
||||
-- The collection of core layouts.
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module Layouts (ChangeLayout(..), Choose, (|||), Resize(..), IncMasterN(..),
|
||||
Full(..), Tall(..), Mirror(..), splitVertically,
|
||||
splitHorizontally, splitHorizontallyBy, splitVerticallyBy) where
|
||||
|
||||
import XMonad
|
||||
|
||||
import Graphics.X11 (Rectangle(..))
|
||||
import qualified StackSet as W
|
||||
import Control.Arrow ((***), second)
|
||||
import Control.Monad
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- LayoutClass selection manager
|
||||
|
||||
-- | A layout that allows users to switch between various layout options.
|
||||
|
||||
-- | Messages to change the current layout.
|
||||
data ChangeLayout = FirstLayout | NextLayout deriving (Eq, Show, Typeable)
|
||||
|
||||
instance Message ChangeLayout
|
||||
|
||||
-- | The layout choice combinator
|
||||
(|||) :: (LayoutClass l a, LayoutClass r a) => l a -> r a -> Choose l r a
|
||||
(|||) = flip SLeft
|
||||
infixr 5 |||
|
||||
|
||||
data Choose l r a = SLeft (r a) (l a)
|
||||
| SRight (l a) (r a) deriving (Read, Show)
|
||||
|
||||
data NextNoWrap = NextNoWrap deriving (Eq, Show, Typeable)
|
||||
instance Message NextNoWrap
|
||||
|
||||
-- This has lots of pseudo duplicated code, we must find a better way
|
||||
instance (LayoutClass l a, LayoutClass r a) => LayoutClass (Choose l r) a where
|
||||
doLayout (SLeft r l) = (fmap (second . fmap $ SLeft r) .) . doLayout l
|
||||
doLayout (SRight l r) = (fmap (second . fmap $ SRight l) .) . doLayout r
|
||||
|
||||
description (SLeft _ l) = description l
|
||||
description (SRight _ r) = description r
|
||||
|
||||
handleMessage lr m | Just FirstLayout <- fromMessage m = case lr of
|
||||
SLeft {} -> return Nothing
|
||||
SRight l r -> fmap (Just . flip SLeft l . fromMaybe r) $ handleMessage r m
|
||||
|
||||
handleMessage lr m | Just NextLayout <- fromMessage m = do
|
||||
mlr <- handleMessage lr $ SomeMessage NextNoWrap
|
||||
maybe (handleMessage lr $ SomeMessage FirstLayout) (return . Just) mlr
|
||||
|
||||
handleMessage (SLeft r l) m | Just NextNoWrap <- fromMessage m = do
|
||||
handleMessage l (SomeMessage Hide)
|
||||
mr <- handleMessage r (SomeMessage FirstLayout)
|
||||
return . Just . SRight l $ fromMaybe r mr
|
||||
|
||||
-- The default cases for left and right:
|
||||
handleMessage (SLeft r l) m = fmap (fmap $ SLeft r) $ handleMessage l m
|
||||
handleMessage (SRight l r) m = fmap (fmap $ SRight l) $ handleMessage r m
|
||||
|
||||
--
|
||||
-- | Builtin layout algorithms:
|
||||
--
|
||||
-- > fullscreen mode
|
||||
-- > tall mode
|
||||
--
|
||||
-- The latter algorithms support the following operations:
|
||||
--
|
||||
-- > Shrink
|
||||
-- > Expand
|
||||
--
|
||||
data Resize = Shrink | Expand deriving Typeable
|
||||
|
||||
-- | You can also increase the number of clients in the master pane
|
||||
data IncMasterN = IncMasterN Int deriving Typeable
|
||||
|
||||
instance Message Resize
|
||||
instance Message IncMasterN
|
||||
|
||||
-- | Simple fullscreen mode, just render all windows fullscreen.
|
||||
data Full a = Full deriving (Show, Read)
|
||||
|
||||
instance LayoutClass Full a
|
||||
|
||||
-- | The inbuilt tiling mode of xmonad, and its operations.
|
||||
data Tall a = Tall Int Rational Rational deriving (Show, Read)
|
||||
|
||||
instance LayoutClass Tall a where
|
||||
pureLayout (Tall nmaster _ frac) r s = zip ws rs
|
||||
where ws = W.integrate s
|
||||
rs = tile frac r nmaster (length ws)
|
||||
|
||||
pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m)
|
||||
,fmap incmastern (fromMessage m)]
|
||||
where resize Shrink = Tall nmaster delta (max 0 $ frac-delta)
|
||||
resize Expand = Tall nmaster delta (min 1 $ frac+delta)
|
||||
incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac
|
||||
description _ = "Tall"
|
||||
|
||||
-- | Mirror a rectangle
|
||||
mirrorRect :: Rectangle -> Rectangle
|
||||
mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw)
|
||||
|
||||
-- | Mirror a layout, compute its 90 degree rotated form.
|
||||
data Mirror l a = Mirror (l a) deriving (Show, Read)
|
||||
|
||||
instance LayoutClass l a => LayoutClass (Mirror l) a where
|
||||
doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror)
|
||||
`fmap` doLayout l (mirrorRect r) s
|
||||
handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l
|
||||
description (Mirror l) = "Mirror "++ description l
|
||||
|
||||
-- | tile. Compute the positions for windows using the default 2 pane tiling algorithm.
|
||||
--
|
||||
-- The screen is divided (currently) into two panes. all clients are
|
||||
-- then partioned between these two panes. one pane, the `master', by
|
||||
-- convention has the least number of windows in it (by default, 1).
|
||||
-- the variable `nmaster' controls how many windows are rendered in the
|
||||
-- master pane.
|
||||
--
|
||||
-- `delta' specifies the ratio of the screen to resize by.
|
||||
--
|
||||
-- 'frac' specifies what proportion of the screen to devote to the
|
||||
-- master area.
|
||||
--
|
||||
tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle]
|
||||
tile f r nmaster n = if n <= nmaster || nmaster == 0
|
||||
then splitVertically n r
|
||||
else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns
|
||||
where (r1,r2) = splitHorizontallyBy f r
|
||||
|
||||
--
|
||||
-- Divide the screen vertically into n subrectangles
|
||||
--
|
||||
splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle]
|
||||
splitVertically n r | n < 2 = [r]
|
||||
splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh :
|
||||
splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh))
|
||||
where smallh = sh `div` fromIntegral n --hmm, this is a fold or map.
|
||||
|
||||
splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect
|
||||
|
||||
-- Divide the screen into two rectangles, using a rational to specify the ratio
|
||||
splitHorizontallyBy, splitVerticallyBy :: 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
|
||||
|
||||
splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect
|
||||
28
Main.hs
28
Main.hs
@ -21,6 +21,7 @@ module Main where
|
||||
--
|
||||
import Control.Monad.Reader ( asks )
|
||||
import XMonad hiding ( logHook, borderWidth )
|
||||
import Layouts
|
||||
import Operations
|
||||
import qualified StackSet as W
|
||||
import Data.Ratio
|
||||
@ -128,14 +129,11 @@ manageHook _ _ _ _ = return id
|
||||
-- defaults, as xmonad preserves your old layout settings by default.
|
||||
--
|
||||
|
||||
-- | The list of possible layouts. Add your custom layouts to this list.
|
||||
layouts :: [Layout Window]
|
||||
layouts = [ Layout tiled
|
||||
, Layout $ Mirror tiled
|
||||
, Layout Full
|
||||
-- Add extra layouts you want to use here:
|
||||
-- % Extension-provided layouts
|
||||
]
|
||||
-- | The available layouts. Note that each layout is separated by |||, which
|
||||
-- denotes layout choice.
|
||||
layout = tiled ||| Mirror tiled ||| Full
|
||||
-- Add extra layouts you want to use here:
|
||||
-- % Extension-provided layouts
|
||||
where
|
||||
-- default tiling algorithm partitions the screen into two panes
|
||||
tiled = Tall nmaster delta ratio
|
||||
@ -149,12 +147,6 @@ layouts = [ Layout tiled
|
||||
-- Percent of screen to increment by when resizing panes
|
||||
delta = 3%100
|
||||
|
||||
-- | Register with xmonad a list of layouts whose state we can preserve over restarts.
|
||||
-- There is typically no need to modify this list, the defaults are fine.
|
||||
--
|
||||
serialisedLayouts :: [Layout Window]
|
||||
serialisedLayouts = Layout (layoutHook defaultConfig) : layouts
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- Key bindings:
|
||||
|
||||
@ -171,7 +163,7 @@ keys = M.fromList $
|
||||
, ((modMask .|. shiftMask, xK_c ), kill) -- %! Close the focused window
|
||||
|
||||
, ((modMask, xK_space ), sendMessage NextLayout) -- %! Rotate through the available layout algorithms
|
||||
, ((modMask .|. shiftMask, xK_space ), setLayout $ layoutHook defaultConfig) -- %! Reset the layouts on the current workspace to default
|
||||
, ((modMask .|. shiftMask, xK_space ), setLayout $ Layout layout) -- %! Reset the layouts on the current workspace to default
|
||||
|
||||
, ((modMask, xK_n ), refresh) -- %! Resize viewed windows to the correct size
|
||||
|
||||
@ -238,7 +230,7 @@ mouseBindings = M.fromList $
|
||||
|
||||
-- % Extension-provided definitions
|
||||
|
||||
defaultConfig :: XMonadConfig Select
|
||||
defaultConfig :: XMonadConfig
|
||||
defaultConfig = XMonadConfig { borderWidth = 1 -- Width of the window border in pixels.
|
||||
, EventLoop.workspaces = workspaces
|
||||
, defaultGaps = [(0,0,0,0)] -- 15 for default dzen font
|
||||
@ -247,8 +239,8 @@ defaultConfig = XMonadConfig { borderWidth = 1 -- Width of the window border in
|
||||
-- By default, we simply switch between the layouts listed in `layouts'
|
||||
-- above, but you may program your own selection behaviour here. Layout
|
||||
-- transformers, for example, would be hooked in here.
|
||||
--
|
||||
, layoutHook = Select layouts
|
||||
--
|
||||
, layoutHook = layout
|
||||
, defaultTerminal = "xterm" -- The preferred terminal program.
|
||||
, normalBorderColor = "#dddddd" -- Border color for unfocused windows.
|
||||
, focusedBorderColor = "#ff0000" -- Border color for focused windows.
|
||||
|
||||
@ -4,4 +4,3 @@ import XMonad
|
||||
numlockMask :: KeyMask
|
||||
workspaces :: [WorkspaceId]
|
||||
manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet)
|
||||
serialisedLayouts :: [Layout Window]
|
||||
|
||||
160
Operations.hs
160
Operations.hs
@ -19,6 +19,7 @@
|
||||
module Operations where
|
||||
|
||||
import XMonad
|
||||
import Layouts (Full(..))
|
||||
import qualified StackSet as W
|
||||
|
||||
import Data.Maybe
|
||||
@ -37,7 +38,7 @@ import Graphics.X11.Xlib
|
||||
import Graphics.X11.Xinerama (getScreenInfo)
|
||||
import Graphics.X11.Xlib.Extras
|
||||
|
||||
import {-# SOURCE #-} Main (manageHook,numlockMask,serialisedLayouts)
|
||||
import {-# SOURCE #-} Main (manageHook,numlockMask)
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- |
|
||||
@ -111,10 +112,6 @@ kill = withDisplay $ \d -> withFocused $ \w -> do
|
||||
-- ---------------------------------------------------------------------
|
||||
-- Managing windows
|
||||
|
||||
data LayoutMessages = Hide | ReleaseResources deriving ( Typeable, Eq )
|
||||
|
||||
instance Message LayoutMessages
|
||||
|
||||
-- | windows. Modify the current window list with a pure function, and refresh
|
||||
windows :: (WindowSet -> WindowSet) -> X ()
|
||||
windows f = do
|
||||
@ -353,159 +350,6 @@ setLayout l = do
|
||||
handleMessage (W.layout ws) (SomeMessage ReleaseResources)
|
||||
windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = Layout l } } }
|
||||
|
||||
-- | X Events are valid Messages
|
||||
instance Message Event
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- LayoutClass selection manager
|
||||
|
||||
-- | A layout that allows users to switch between various layout options.
|
||||
-- This layout accepts three Messages:
|
||||
--
|
||||
-- > NextLayout
|
||||
-- > PrevLayout
|
||||
-- > JumpToLayout.
|
||||
--
|
||||
data ChangeLayout = NextLayout | PrevLayout | JumpToLayout String
|
||||
deriving (Eq, Show, Typeable)
|
||||
|
||||
instance Message ChangeLayout
|
||||
|
||||
instance ReadableLayout Window where
|
||||
readTypes = Layout (Select []) :
|
||||
Layout Full : Layout (Tall 1 0.1 0.5) :
|
||||
Layout (Mirror $ Tall 1 0.1 0.5) :
|
||||
serialisedLayouts
|
||||
|
||||
data Select a = Select [Layout a] deriving (Show, Read)
|
||||
|
||||
instance ReadableLayout a => LayoutClass Select a where
|
||||
doLayout (Select (l:ls)) r s =
|
||||
second (fmap (Select . (:ls))) `fmap` doLayout l r s
|
||||
doLayout (Select []) r s =
|
||||
second (const Nothing) `fmap` doLayout Full r s
|
||||
|
||||
-- respond to messages only when there's an actual choice:
|
||||
handleMessage (Select (l:ls@(_:_))) m
|
||||
| Just NextLayout <- fromMessage m = switchl rls
|
||||
| Just PrevLayout <- fromMessage m = switchl rls'
|
||||
| Just (JumpToLayout x) <- fromMessage m = switchl (j x)
|
||||
| Just ReleaseResources <- fromMessage m = do -- each branch has a different type
|
||||
mlls' <- mapM (flip handleMessage m) (l:ls)
|
||||
let lls' = zipWith fromMaybe (l:ls) mlls'
|
||||
return (Just (Select lls'))
|
||||
|
||||
where rls [] = []
|
||||
rls (x:xs) = xs ++ [x]
|
||||
rls' = reverse . rls . reverse
|
||||
|
||||
j s zs = case partition ((s ==) . description) zs of (xs,ys) -> xs++ys
|
||||
|
||||
switchl f = do ml' <- handleMessage l (SomeMessage Hide)
|
||||
return $ Just (Select $ f $ fromMaybe l ml':ls)
|
||||
|
||||
-- otherwise, or if we don't understand the message, pass it along to the real layout:
|
||||
handleMessage (Select (l:ls)) m =
|
||||
fmap (Select . (:ls)) `fmap` handleMessage l m
|
||||
|
||||
-- Unless there is no layout...
|
||||
handleMessage (Select []) _ = return Nothing
|
||||
|
||||
description (Select (x:_)) = description x
|
||||
description _ = "default"
|
||||
|
||||
--
|
||||
-- | Builtin layout algorithms:
|
||||
--
|
||||
-- > fullscreen mode
|
||||
-- > tall mode
|
||||
--
|
||||
-- The latter algorithms support the following operations:
|
||||
--
|
||||
-- > Shrink
|
||||
-- > Expand
|
||||
--
|
||||
data Resize = Shrink | Expand deriving Typeable
|
||||
|
||||
-- | You can also increase the number of clients in the master pane
|
||||
data IncMasterN = IncMasterN Int deriving Typeable
|
||||
|
||||
instance Message Resize
|
||||
instance Message IncMasterN
|
||||
|
||||
-- | Simple fullscreen mode, just render all windows fullscreen.
|
||||
data Full a = Full deriving (Show, Read)
|
||||
|
||||
instance LayoutClass Full a
|
||||
|
||||
-- | The inbuilt tiling mode of xmonad, and its operations.
|
||||
data Tall a = Tall Int Rational Rational deriving (Show, Read)
|
||||
|
||||
instance LayoutClass Tall a where
|
||||
pureLayout (Tall nmaster _ frac) r s = zip ws rs
|
||||
where ws = W.integrate s
|
||||
rs = tile frac r nmaster (length ws)
|
||||
|
||||
pureMessage (Tall nmaster delta frac) m = msum [fmap resize (fromMessage m)
|
||||
,fmap incmastern (fromMessage m)]
|
||||
where resize Shrink = Tall nmaster delta (max 0 $ frac-delta)
|
||||
resize Expand = Tall nmaster delta (min 1 $ frac+delta)
|
||||
incmastern (IncMasterN d) = Tall (max 0 (nmaster+d)) delta frac
|
||||
description _ = "Tall"
|
||||
|
||||
-- | Mirror a rectangle
|
||||
mirrorRect :: Rectangle -> Rectangle
|
||||
mirrorRect (Rectangle rx ry rw rh) = (Rectangle ry rx rh rw)
|
||||
|
||||
-- | Mirror a layout, compute its 90 degree rotated form.
|
||||
data Mirror l a = Mirror (l a) deriving (Show, Read)
|
||||
|
||||
instance LayoutClass l a => LayoutClass (Mirror l) a where
|
||||
doLayout (Mirror l) r s = (map (second mirrorRect) *** fmap Mirror)
|
||||
`fmap` doLayout l (mirrorRect r) s
|
||||
handleMessage (Mirror l) = fmap (fmap Mirror) . handleMessage l
|
||||
description (Mirror l) = "Mirror "++ description l
|
||||
|
||||
-- | tile. Compute the positions for windows using the default 2 pane tiling algorithm.
|
||||
--
|
||||
-- The screen is divided (currently) into two panes. all clients are
|
||||
-- then partioned between these two panes. one pane, the `master', by
|
||||
-- convention has the least number of windows in it (by default, 1).
|
||||
-- the variable `nmaster' controls how many windows are rendered in the
|
||||
-- master pane.
|
||||
--
|
||||
-- `delta' specifies the ratio of the screen to resize by.
|
||||
--
|
||||
-- 'frac' specifies what proportion of the screen to devote to the
|
||||
-- master area.
|
||||
--
|
||||
tile :: Rational -> Rectangle -> Int -> Int -> [Rectangle]
|
||||
tile f r nmaster n = if n <= nmaster || nmaster == 0
|
||||
then splitVertically n r
|
||||
else splitVertically nmaster r1 ++ splitVertically (n-nmaster) r2 -- two columns
|
||||
where (r1,r2) = splitHorizontallyBy f r
|
||||
|
||||
--
|
||||
-- Divide the screen vertically into n subrectangles
|
||||
--
|
||||
splitVertically, splitHorizontally :: Int -> Rectangle -> [Rectangle]
|
||||
splitVertically n r | n < 2 = [r]
|
||||
splitVertically n (Rectangle sx sy sw sh) = Rectangle sx sy sw smallh :
|
||||
splitVertically (n-1) (Rectangle sx (sy+fromIntegral smallh) sw (sh-smallh))
|
||||
where smallh = sh `div` fromIntegral n --hmm, this is a fold or map.
|
||||
|
||||
splitHorizontally n = map mirrorRect . splitVertically n . mirrorRect
|
||||
|
||||
-- Divide the screen into two rectangles, using a rational to specify the ratio
|
||||
splitHorizontallyBy, splitVerticallyBy :: 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
|
||||
|
||||
-- | XXX comment me
|
||||
splitVerticallyBy f = (mirrorRect *** mirrorRect) . splitHorizontallyBy f . mirrorRect
|
||||
|
||||
------------------------------------------------------------------------
|
||||
-- Utilities
|
||||
|
||||
|
||||
59
XMonad.hs
59
XMonad.hs
@ -16,8 +16,8 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module XMonad (
|
||||
X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), LayoutClass(..), Layout(..), ReadableLayout(..),
|
||||
Typeable, Message, SomeMessage(..), fromMessage, runLayout,
|
||||
X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), LayoutClass(..), Layout(..),
|
||||
Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..),
|
||||
runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX,
|
||||
atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW
|
||||
) where
|
||||
@ -28,14 +28,12 @@ import Prelude hiding ( catch )
|
||||
import Control.Exception (catch, throw, Exception(ExitException))
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Reader
|
||||
import Control.Arrow (first)
|
||||
import System.IO
|
||||
import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession)
|
||||
import System.Exit
|
||||
import System.Environment
|
||||
import Graphics.X11.Xlib
|
||||
-- for Read instance
|
||||
import Graphics.X11.Xlib.Extras ()
|
||||
import Graphics.X11.Xlib.Extras (Event)
|
||||
import Data.Typeable
|
||||
|
||||
import qualified Data.Map as M
|
||||
@ -49,13 +47,13 @@ data XState = XState
|
||||
, waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents
|
||||
, dragging :: !(Maybe (Position -> Position -> X (), X ())) }
|
||||
data XConf = XConf
|
||||
{ display :: Display -- ^ the X11 display
|
||||
, logHook :: !(X ()) -- ^ the loghook function
|
||||
, terminal :: !String -- ^ the user's preferred terminal
|
||||
, theRoot :: !Window -- ^ the root window
|
||||
, borderWidth :: !Dimension -- ^ the preferred border width
|
||||
, normalBorder :: !Pixel -- ^ border color of unfocused windows
|
||||
, focusedBorder :: !Pixel } -- ^ border color of the focused window
|
||||
{ display :: Display -- ^ the X11 display
|
||||
, logHook :: !(X ()) -- ^ the loghook function
|
||||
, terminal :: !String -- ^ the user's preferred terminal
|
||||
, theRoot :: !Window -- ^ the root window
|
||||
, borderWidth :: !Dimension -- ^ the preferred border width
|
||||
, normalBorder :: !Pixel -- ^ border color of unfocused windows
|
||||
, focusedBorder :: !Pixel } -- ^ border color of the focused window
|
||||
|
||||
type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
|
||||
type WindowSpace = Workspace WorkspaceId (Layout Window) Window
|
||||
@ -135,14 +133,9 @@ atom_WM_STATE = getAtom "WM_STATE"
|
||||
-- | LayoutClass handling. See particular instances in Operations.hs
|
||||
|
||||
-- | An existential type that can hold any object that is in the LayoutClass.
|
||||
data Layout a = forall l. LayoutClass l a => Layout (l a)
|
||||
data Layout a = forall l. (LayoutClass l a) => Layout (l a)
|
||||
|
||||
|
||||
-- | This class defines a set of layout types (held in Layout
|
||||
-- objects) that are used when trying to read an existentially wrapped Layout.
|
||||
class ReadableLayout a where
|
||||
readTypes :: [Layout a]
|
||||
|
||||
-- | The different layout modes
|
||||
--
|
||||
-- 'doLayout': given a Rectangle and a Stack, layout the stack elements
|
||||
@ -150,7 +143,7 @@ class ReadableLayout a where
|
||||
-- by 'doLayout', then it is not shown on screen. Windows are restacked
|
||||
-- according to the order they are returned by 'doLayout'.
|
||||
--
|
||||
class (Show (layout a), Read (layout a)) => LayoutClass layout a where
|
||||
class Show (layout a) => LayoutClass layout a where
|
||||
|
||||
-- | Given a Rectangle in which to place the windows, and a Stack of
|
||||
-- windows, return a list of windows and their corresponding Rectangles.
|
||||
@ -184,22 +177,7 @@ class (Show (layout a), Read (layout a)) => LayoutClass layout a where
|
||||
description :: layout a -> String
|
||||
description = show
|
||||
|
||||
-- Here's the magic for parsing serialised state of existentially
|
||||
-- wrapped layouts: attempt to parse using the Read instance from each
|
||||
-- type in our list of types, if any suceed, take the first one.
|
||||
instance ReadableLayout a => Read (Layout a) where
|
||||
|
||||
-- We take the first parse only, because multiple matches indicate a bad parse.
|
||||
readsPrec _ s = take 1 $ concatMap readLayout readTypes
|
||||
where
|
||||
readLayout (Layout x) = map (first Layout) $ readAsType x
|
||||
|
||||
-- the type indicates which Read instance to dispatch to.
|
||||
-- That is, read asTypeOf the argument from the readTypes.
|
||||
readAsType :: LayoutClass l a => l a -> [(l a, String)]
|
||||
readAsType _ = reads s
|
||||
|
||||
instance ReadableLayout a => LayoutClass Layout a where
|
||||
instance LayoutClass Layout Window where
|
||||
doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s
|
||||
handleMessage (Layout l) = fmap (fmap Layout) . handleMessage l
|
||||
description (Layout l) = description l
|
||||
@ -229,6 +207,17 @@ data SomeMessage = forall a. Message a => SomeMessage a
|
||||
fromMessage :: Message m => SomeMessage -> Maybe m
|
||||
fromMessage (SomeMessage m) = cast m
|
||||
|
||||
-- | X Events are valid Messages
|
||||
instance Message Event
|
||||
|
||||
-- | LayoutMessages are core messages that all layouts (especially stateful
|
||||
-- layouts) should consider handling.
|
||||
data LayoutMessages = Hide -- ^ sent when a layout becomes non-visible
|
||||
| ReleaseResources -- ^ sent when xmonad is exiting or restarting
|
||||
deriving (Typeable, Eq)
|
||||
|
||||
instance Message LayoutMessages
|
||||
|
||||
-- ---------------------------------------------------------------------
|
||||
-- | General utilities
|
||||
--
|
||||
|
||||
@ -3,7 +3,6 @@ module Properties where
|
||||
|
||||
import StackSet hiding (filter)
|
||||
import qualified StackSet as S (filter)
|
||||
import Operations (tile)
|
||||
|
||||
import Debug.Trace
|
||||
import Data.Word
|
||||
|
||||
@ -23,7 +23,7 @@ extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1.in
|
||||
|
||||
executable: xmonad
|
||||
main-is: Main.hs
|
||||
other-modules: EventLoop Operations StackSet XMonad
|
||||
other-modules: EventLoop Layouts Operations StackSet XMonad
|
||||
ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s
|
||||
ghc-prof-options: -prof -auto-all
|
||||
extensions: GeneralizedNewtypeDeriving
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user