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 2007-11-01 06:43:18 +00:00
parent 48ccbc7fb2
commit 3789f37f25
8 changed files with 227 additions and 235 deletions

View File

@ -1,3 +1,4 @@
{-# LANGUAGE MultiParamTypeClasses #-}
---------------------------------------------------------------------------- ----------------------------------------------------------------------------
-- | -- |
-- Module : Main.hs -- Module : Main.hs
@ -35,22 +36,23 @@ import Operations
import System.IO import System.IO
data XMonadConfig l = XMonadConfig { normalBorderColor :: !String data XMonadConfig = forall l. (LayoutClass l Window, Read (l Window)) =>
, focusedBorderColor :: !String XMonadConfig { normalBorderColor :: !String
, defaultTerminal :: !String , focusedBorderColor :: !String
, layoutHook :: !(l Window) , defaultTerminal :: !String
, workspaces :: ![String] , layoutHook :: !(l Window)
, defaultGaps :: ![(Int,Int,Int,Int)] , workspaces :: ![String]
, keys :: !(M.Map (ButtonMask,KeySym) (X ())) , defaultGaps :: ![(Int,Int,Int,Int)]
, mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ())) , keys :: !(M.Map (ButtonMask,KeySym) (X ()))
, borderWidth :: !Dimension , mouseBindings :: !(M.Map (ButtonMask, Button) (Window -> X ()))
, logHook :: !(X ()) , borderWidth :: !Dimension
} , logHook :: !(X ())
}
-- | -- |
-- The main entry point -- The main entry point
-- --
makeMain :: LayoutClass l Window => XMonadConfig l -> IO () makeMain :: XMonadConfig -> IO ()
makeMain xmc = do makeMain xmc = do
dpy <- openDisplay "" dpy <- openDisplay ""
let dflt = defaultScreen dpy let dflt = defaultScreen dpy
@ -62,17 +64,18 @@ makeMain xmc = do
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
args <- getArgs 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 maybeRead reads' s = case reads' s of
[(x, "")] -> Just x [(x, "")] -> Just x
_ -> Nothing _ -> Nothing
winset = fromMaybe initialWinset $ do winset = fromMaybe initialWinset $ do
("--resume" : s : _) <- return args ("--resume" : s : _) <- return args
ws <- maybeRead s ws <- maybeRead reads s
return . W.ensureTags (Layout $ layoutHook xmc) (workspaces xmc) return . W.ensureTags layout (workspaces xmc)
$ W.mapLayout (fromMaybe (Layout $ layoutHook xmc) . maybeRead) ws $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws
gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0) 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) && (wa_map_state wa == waIsViewable || ic)
-- | Grab the keys back -- | Grab the keys back
grabKeys :: XMonadConfig l -> X () grabKeys :: XMonadConfig -> X ()
grabKeys xmc = do grabKeys xmc = do
XConf { display = dpy, theRoot = rootw } <- ask XConf { display = dpy, theRoot = rootw } <- ask
let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync 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 when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) extraModifiers
-- | XXX comment me -- | XXX comment me
grabButtons :: XMonadConfig l -> X () grabButtons :: XMonadConfig -> X ()
grabButtons xmc = do grabButtons xmc = do
XConf { display = dpy, theRoot = rootw } <- ask XConf { display = dpy, theRoot = rootw } <- ask
let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask

166
Layouts.hs Normal file
View 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
View File

@ -21,6 +21,7 @@ module Main where
-- --
import Control.Monad.Reader ( asks ) import Control.Monad.Reader ( asks )
import XMonad hiding ( logHook, borderWidth ) import XMonad hiding ( logHook, borderWidth )
import Layouts
import Operations import Operations
import qualified StackSet as W import qualified StackSet as W
import Data.Ratio import Data.Ratio
@ -128,14 +129,11 @@ manageHook _ _ _ _ = return id
-- defaults, as xmonad preserves your old layout settings by default. -- defaults, as xmonad preserves your old layout settings by default.
-- --
-- | The list of possible layouts. Add your custom layouts to this list. -- | The available layouts. Note that each layout is separated by |||, which
layouts :: [Layout Window] -- denotes layout choice.
layouts = [ Layout tiled layout = tiled ||| Mirror tiled ||| Full
, Layout $ Mirror tiled -- Add extra layouts you want to use here:
, Layout Full -- % Extension-provided layouts
-- Add extra layouts you want to use here:
-- % Extension-provided layouts
]
where where
-- default tiling algorithm partitions the screen into two panes -- default tiling algorithm partitions the screen into two panes
tiled = Tall nmaster delta ratio tiled = Tall nmaster delta ratio
@ -149,12 +147,6 @@ layouts = [ Layout tiled
-- Percent of screen to increment by when resizing panes -- Percent of screen to increment by when resizing panes
delta = 3%100 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: -- Key bindings:
@ -171,7 +163,7 @@ keys = M.fromList $
, ((modMask .|. shiftMask, xK_c ), kill) -- %! Close the focused window , ((modMask .|. shiftMask, xK_c ), kill) -- %! Close the focused window
, ((modMask, xK_space ), sendMessage NextLayout) -- %! Rotate through the available layout algorithms , ((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 , ((modMask, xK_n ), refresh) -- %! Resize viewed windows to the correct size
@ -238,7 +230,7 @@ mouseBindings = M.fromList $
-- % Extension-provided definitions -- % Extension-provided definitions
defaultConfig :: XMonadConfig Select defaultConfig :: XMonadConfig
defaultConfig = XMonadConfig { borderWidth = 1 -- Width of the window border in pixels. defaultConfig = XMonadConfig { borderWidth = 1 -- Width of the window border in pixels.
, EventLoop.workspaces = workspaces , EventLoop.workspaces = workspaces
, defaultGaps = [(0,0,0,0)] -- 15 for default dzen font , 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' -- By default, we simply switch between the layouts listed in `layouts'
-- above, but you may program your own selection behaviour here. Layout -- above, but you may program your own selection behaviour here. Layout
-- transformers, for example, would be hooked in here. -- transformers, for example, would be hooked in here.
-- --
, layoutHook = Select layouts , layoutHook = layout
, defaultTerminal = "xterm" -- The preferred terminal program. , defaultTerminal = "xterm" -- The preferred terminal program.
, normalBorderColor = "#dddddd" -- Border color for unfocused windows. , normalBorderColor = "#dddddd" -- Border color for unfocused windows.
, focusedBorderColor = "#ff0000" -- Border color for focused windows. , focusedBorderColor = "#ff0000" -- Border color for focused windows.

View File

@ -4,4 +4,3 @@ import XMonad
numlockMask :: KeyMask numlockMask :: KeyMask
workspaces :: [WorkspaceId] workspaces :: [WorkspaceId]
manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet)
serialisedLayouts :: [Layout Window]

View File

@ -19,6 +19,7 @@
module Operations where module Operations where
import XMonad import XMonad
import Layouts (Full(..))
import qualified StackSet as W import qualified StackSet as W
import Data.Maybe import Data.Maybe
@ -37,7 +38,7 @@ import Graphics.X11.Xlib
import Graphics.X11.Xinerama (getScreenInfo) import Graphics.X11.Xinerama (getScreenInfo)
import Graphics.X11.Xlib.Extras 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 -- 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. Modify the current window list with a pure function, and refresh
windows :: (WindowSet -> WindowSet) -> X () windows :: (WindowSet -> WindowSet) -> X ()
windows f = do windows f = do
@ -353,159 +350,6 @@ setLayout l = do
handleMessage (W.layout ws) (SomeMessage ReleaseResources) handleMessage (W.layout ws) (SomeMessage ReleaseResources)
windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = Layout l } } } 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 -- Utilities

View File

@ -16,8 +16,8 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module XMonad ( module XMonad (
X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), LayoutClass(..), Layout(..), ReadableLayout(..), X, WindowSet, WindowSpace, WorkspaceId, ScreenId(..), ScreenDetail(..), XState(..), XConf(..), LayoutClass(..), Layout(..),
Typeable, Message, SomeMessage(..), fromMessage, runLayout, Typeable, Message, SomeMessage(..), fromMessage, runLayout, LayoutMessages(..),
runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX, runX, catchX, userCode, io, catchIO, withDisplay, withWindowSet, isRoot, getAtom, spawn, restart, trace, whenJust, whenX,
atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW atom_WM_STATE, atom_WM_PROTOCOLS, atom_WM_DELETE_WINDOW
) where ) where
@ -28,14 +28,12 @@ import Prelude hiding ( catch )
import Control.Exception (catch, throw, Exception(ExitException)) import Control.Exception (catch, throw, Exception(ExitException))
import Control.Monad.State import Control.Monad.State
import Control.Monad.Reader import Control.Monad.Reader
import Control.Arrow (first)
import System.IO import System.IO
import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession) import System.Posix.Process (executeFile, forkProcess, getProcessStatus, createSession)
import System.Exit import System.Exit
import System.Environment import System.Environment
import Graphics.X11.Xlib import Graphics.X11.Xlib
-- for Read instance import Graphics.X11.Xlib.Extras (Event)
import Graphics.X11.Xlib.Extras ()
import Data.Typeable import Data.Typeable
import qualified Data.Map as M import qualified Data.Map as M
@ -49,13 +47,13 @@ data XState = XState
, waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents , waitingUnmap :: !(M.Map Window Int) -- ^ the number of expected UnmapEvents
, dragging :: !(Maybe (Position -> Position -> X (), X ())) } , dragging :: !(Maybe (Position -> Position -> X (), X ())) }
data XConf = XConf data XConf = XConf
{ display :: Display -- ^ the X11 display { display :: Display -- ^ the X11 display
, logHook :: !(X ()) -- ^ the loghook function , logHook :: !(X ()) -- ^ the loghook function
, terminal :: !String -- ^ the user's preferred terminal , terminal :: !String -- ^ the user's preferred terminal
, theRoot :: !Window -- ^ the root window , theRoot :: !Window -- ^ the root window
, borderWidth :: !Dimension -- ^ the preferred border width , borderWidth :: !Dimension -- ^ the preferred border width
, normalBorder :: !Pixel -- ^ border color of unfocused windows , normalBorder :: !Pixel -- ^ border color of unfocused windows
, focusedBorder :: !Pixel } -- ^ border color of the focused window , focusedBorder :: !Pixel } -- ^ border color of the focused window
type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail type WindowSet = StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
type WindowSpace = Workspace WorkspaceId (Layout Window) Window 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 -- | LayoutClass handling. See particular instances in Operations.hs
-- | An existential type that can hold any object that is in the LayoutClass. -- | 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 -- | The different layout modes
-- --
-- 'doLayout': given a Rectangle and a Stack, layout the stack elements -- '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 -- by 'doLayout', then it is not shown on screen. Windows are restacked
-- according to the order they are returned by 'doLayout'. -- 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 -- | Given a Rectangle in which to place the windows, and a Stack of
-- windows, return a list of windows and their corresponding Rectangles. -- 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 :: layout a -> String
description = show description = show
-- Here's the magic for parsing serialised state of existentially instance LayoutClass Layout Window where
-- 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
doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s doLayout (Layout l) r s = fmap (fmap Layout) `liftM` doLayout l r s
handleMessage (Layout l) = fmap (fmap Layout) . handleMessage l handleMessage (Layout l) = fmap (fmap Layout) . handleMessage l
description (Layout l) = description 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 :: Message m => SomeMessage -> Maybe m
fromMessage (SomeMessage m) = cast 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 -- | General utilities
-- --

View File

@ -3,7 +3,6 @@ module Properties where
import StackSet hiding (filter) import StackSet hiding (filter)
import qualified StackSet as S (filter) import qualified StackSet as S (filter)
import Operations (tile)
import Debug.Trace import Debug.Trace
import Data.Word import Data.Word

View File

@ -23,7 +23,7 @@ extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1.in
executable: xmonad executable: xmonad
main-is: Main.hs 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-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s
ghc-prof-options: -prof -auto-all ghc-prof-options: -prof -auto-all
extensions: GeneralizedNewtypeDeriving extensions: GeneralizedNewtypeDeriving