diff options
| -rw-r--r-- | EventLoop.hs | 45 | ||||
| -rw-r--r-- | Layouts.hs | 166 | ||||
| -rw-r--r-- | Main.hs | 28 | ||||
| -rw-r--r-- | Main.hs-boot | 1 | ||||
| -rw-r--r-- | Operations.hs | 160 | ||||
| -rw-r--r-- | XMonad.hs | 59 | ||||
| -rw-r--r-- | tests/Properties.hs | 1 | ||||
| -rw-r--r-- | xmonad.cabal | 2 |
8 files changed, 227 insertions, 235 deletions
diff --git a/EventLoop.hs b/EventLoop.hs index eec62fd..78e75b7 100644 --- a/EventLoop.hs +++ b/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 diff --git a/Layouts.hs b/Layouts.hs new file mode 100644 index 0000000..5605917 --- /dev/null +++ b/Layouts.hs @@ -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 @@ -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. diff --git a/Main.hs-boot b/Main.hs-boot index becb178..1ad5791 100644 --- a/Main.hs-boot +++ b/Main.hs-boot @@ -4,4 +4,3 @@ import XMonad numlockMask :: KeyMask workspaces :: [WorkspaceId] manageHook :: Window -> String -> String -> String -> X (WindowSet -> WindowSet) -serialisedLayouts :: [Layout Window] diff --git a/Operations.hs b/Operations.hs index ae5cd39..929ca9d 100644 --- a/Operations.hs +++ b/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 @@ -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 -- diff --git a/tests/Properties.hs b/tests/Properties.hs index e62172d..0b3e728 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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 diff --git a/xmonad.cabal b/xmonad.cabal index 05eaed2..0663f24 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -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 |