diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,18 @@ #!/usr/bin/env runhaskell +> import Distribution.PackageDescription > import Distribution.Simple -> main = defaultMain +> import Distribution.Simple.LocalBuildInfo +> import Distribution.Simple.Setup +> import System.FilePath +> import System.Directory +> import Control.Monad +> main = defaultMainWithHooks (simpleUserHooks { postInst = myPostInst } ) +> +> -- postInst hook to move helper binaries to the libexec directory +> myPostInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () +> myPostInst _ _ pkgdesc lbi = do +> let dirs = absoluteInstallDirs pkgdesc lbi NoCopyDest +> let lexecdir = libexecdir dirs +> createDirectoryIfMissing True lexecdir +> forM_ ["bluetiledock", "bluetilemockwin", "bluetilegreet"] $ \binary -> +> renameFile (bindir dirs binary) (lexecdir binary) diff --git a/bluetile.cabal b/bluetile.cabal --- a/bluetile.cabal +++ b/bluetile.cabal @@ -1,14 +1,14 @@ Name: bluetile -Version: 0.4 +Version: 0.4.1 +homepage: http://www.bluetile.org/ synopsis: A modern tiling window manager with a gentle learning curve description: - Bluetile is a tiling window manager for X based on xmonad. Windows are arranged - automatically to tile the screen without gaps or overlap, maximising - screen use. Bluetile's focus lies on making the tiling paradigm easily - accessible to users coming from traditional window managers by drawing - on known conventions and providing both mouse and keyboard access for all features. - It also tries to be usable 'out of the box', requiring minimal to - no configuration in most cases. + Bluetile is a tiling window manager for X based on xmonad. Windows are + arranged to use the entire screen without overlapping. Bluetile's focus lies + on making the tiling paradigm easily accessible to users coming from + traditional window managers by drawing on known conventions and providing + both mouse and keyboard access for all features. It also tries to be usable + 'out of the box', requiring minimal to no configuration in most cases. category: System License: BSD3 License-file: LICENSE @@ -16,42 +16,77 @@ Maintainer: jan.vornberger@informatik.uni-oldenburg.de extra-source-files: src/Config.hs, src/BluetileDock.hs, + src/XMonad/Actions/BluetileCommands.hs, + src/XMonad/Actions/WindowMenu.hs, + src/XMonad/Hooks/CurrentWorkspaceOnTop.hs, + src/XMonad/Hooks/EwmhDesktops.hs, + src/XMonad/Hooks/PositionStoreHooks.hs, + src/XMonad/Layout/BorderResize.hs, + src/XMonad/Layout/ButtonDecoration.hs, + src/XMonad/Layout/DecorationAddons.hs, + src/XMonad/Layout/Decoration.hs, + src/XMonad/Layout/DraggingVisualizer.hs, + src/XMonad/Layout/ImageButtonDecoration.hs + src/XMonad/Layout/Minimize.hs, + src/XMonad/Layout/MouseResizableTile.hs, + src/XMonad/Layout/PositionStoreFloat.hs, + src/XMonad/Layout/WindowSwitcherDecoration.hs, + src/XMonad/Util/Font.hs, + src/XMonad/Util/Image.hs, + src/XMonad/Util/PositionStore.hs, + src/XMonad/Util/XUtils.hs, bluetiledock/Utils.hs, - bluetilegreet/Utils.hs + bluetilegreet/Utils.hs, + man/bluetile.1 data-files: bluetiledock/bluetiledock.glade, bluetiledock/floating.svg, bluetiledock/tiled1.svg, bluetiledock/tiled2.svg, bluetiledock/fullscreen.svg, - bluetilegreet/bluetilegreet.glade -Build-Type: Simple + bluetilegreet/bluetilegreet.glade, + logo/bluetile-icon-48x48.png, + logo/bluetile-icon.svg +Build-Type: Custom Cabal-Version: >=1.2 Executable bluetile Main-is: Main.hs Hs-Source-Dirs: src - Build-Depends: base>=3, base<4, containers, process, - xmonad-bluetilebranch>=0.9, xmonad-contrib-bluetilebranch>=0.9 - Ghc-Options: -Wall + Build-Depends: base>=3, base<5, containers, process, filepath, + random, utf8-string, + xmonad>=0.9.1, xmonad-contrib>=0.9.1 + if true + Ghc-Options: -Wall + if impl(ghc >= 6.12.1) + Ghc-Options: -fno-warn-unused-do-bind Executable bluetiledock Buildable: True Hs-Source-Dirs: bluetiledock Main-is: BluetileDock.hs - Build-Depends: base>=3, base<4, unix, glade, gtk, X11>=1.4 + Build-Depends: base>=3, base<5, unix, glade, gtk, X11>=1.4 C-sources: bluetiledock/gdk_property_change_wrapper.c - Ghc-options: -Wall + if true + Ghc-Options: -Wall + if impl(ghc >= 6.12.1) + Ghc-Options: -fno-warn-unused-do-bind Executable bluetilemockwin Buildable: True Hs-Source-Dirs: bluetilemockwin Main-is: BluetileMockWin.hs - Build-Depends: base>=3, base<4, gtk - Ghc-options: -Wall + Build-Depends: base>=3, base<5, gtk + if true + Ghc-Options: -Wall + if impl(ghc >= 6.12.1) + Ghc-Options: -fno-warn-unused-do-bind Executable bluetilegreet Buildable: True Hs-Source-Dirs: bluetilegreet Main-is: BluetileGreet.hs - Build-Depends: base>=3, base<4, directory, filepath, glade, gtk - Ghc-options: -Wall + Build-Depends: base>=3, base<5, directory, filepath, glade, gtk + if true + Ghc-Options: -Wall + if impl(ghc >= 6.12.1) + Ghc-Options: -fno-warn-unused-do-bind diff --git a/bluetiledock/BluetileDock.hs b/bluetiledock/BluetileDock.hs --- a/bluetiledock/BluetileDock.hs +++ b/bluetiledock/BluetileDock.hs @@ -22,7 +22,6 @@ import System.Environment import System.IO import System.FilePath(pathSeparator) -import Data.Char import Paths_bluetile import Utils import Data.IORef @@ -185,8 +184,8 @@ activateToggleButtons xml layoutDesc "layout" writeIORef lockSendCommand False when (sid /= myScreenId && isNothing hndlM) $ do - binDir <- getBinDir - hndl <- spawnPipe $ binDir ++ [pathSeparator] ++ "bluetiledock --otherscreen" + libexecDir <- getLibexecDir + hndl <- spawnPipe $ libexecDir ++ [pathSeparator] ++ "bluetiledock --otherscreen" writeIORef otherDockProcess (Just hndl) hPutStrLn hndl $ show update when (sid /= myScreenId && isJust hndlM) $ do diff --git a/bluetilegreet/BluetileGreet.hs b/bluetilegreet/BluetileGreet.hs --- a/bluetilegreet/BluetileGreet.hs +++ b/bluetilegreet/BluetileGreet.hs @@ -40,9 +40,9 @@ openWindowsBtn <- xmlGetWidget xml castToButton "openwindowsbutton" onClicked openWindowsBtn $ do - binDir <- getBinDir - spawnPipe $ binDir ++ [pathSeparator] ++ "bluetilemockwin 0 0 65535" - spawnPipe $ binDir ++ [pathSeparator] ++ "bluetilemockwin 65535 0 0" + libexecDir <- getLibexecDir + spawnPipe $ libexecDir ++ [pathSeparator] ++ "bluetilemockwin 0 0 65535" + spawnPipe $ libexecDir ++ [pathSeparator] ++ "bluetilemockwin 65535 0 0" return () startBtn <- xmlGetWidget xml castToButton "startbutton" diff --git a/logo/bluetile-icon-48x48.png b/logo/bluetile-icon-48x48.png new file mode 100644 Binary files /dev/null and b/logo/bluetile-icon-48x48.png differ diff --git a/logo/bluetile-icon.svg b/logo/bluetile-icon.svg new file mode 100644 --- /dev/null +++ b/logo/bluetile-icon.svg @@ -0,0 +1,138 @@ + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + diff --git a/man/bluetile.1 b/man/bluetile.1 new file mode 100644 --- /dev/null +++ b/man/bluetile.1 @@ -0,0 +1,224 @@ +.\" Automatically generated by Pod::Man 2.22 (Pod::Simple 3.07) +.\" +.\" Standard preamble: +.\" ======================================================================== +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Vb \" Begin verbatim text +.ft CW +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R +.fi +.. +.\" Set up some character translations and predefined strings. \*(-- will +.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left +.\" double quote, and \*(R" will give a right double quote. \*(C+ will +.\" give a nicer C++. Capital omega is used to do unbreakable dashes and +.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, +.\" nothing in troff, for use with C<>. +.tr \(*W- +.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' +.ie n \{\ +. ds -- \(*W- +. ds PI pi +. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch +. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch +. ds L" "" +. ds R" "" +. ds C` "" +. ds C' "" +'br\} +.el\{\ +. ds -- \|\(em\| +. ds PI \(*p +. ds L" `` +. ds R" '' +'br\} +.\" +.\" Escape single quotes in literal strings from groff's Unicode transform. +.ie \n(.g .ds Aq \(aq +.el .ds Aq ' +.\" +.\" If the F register is turned on, we'll generate index entries on stderr for +.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index +.\" entries marked with X<> in POD. Of course, you'll have to process the +.\" output yourself in some meaningful fashion. +.ie \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +.. +. nr % 0 +. rr F +.\} +.el \{\ +. de IX +.. +.\} +.\" +.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). +.\" Fear. Run. Save yourself. No user-serviceable parts. +. \" fudge factors for nroff and troff +.if n \{\ +. ds #H 0 +. ds #V .8m +. ds #F .3m +. ds #[ \f1 +. ds #] \fP +.\} +.if t \{\ +. ds #H ((1u-(\\\\n(.fu%2u))*.13m) +. ds #V .6m +. ds #F 0 +. ds #[ \& +. ds #] \& +.\} +. \" simple accents for nroff and troff +.if n \{\ +. ds ' \& +. ds ` \& +. ds ^ \& +. ds , \& +. ds ~ ~ +. ds / +.\} +.if t \{\ +. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" +. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' +. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' +. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' +. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' +. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' +.\} +. \" troff and (daisy-wheel) nroff accents +.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' +.ds 8 \h'\*(#H'\(*b\h'-\*(#H' +.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] +.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' +.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' +.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] +.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] +.ds ae a\h'-(\w'a'u*4/10)'e +.ds Ae A\h'-(\w'A'u*4/10)'E +. \" corrections for vroff +.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' +.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' +. \" for low resolution devices (crt and lpr) +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds : e +. ds 8 ss +. ds o a +. ds d- d\h'-1'\(ga +. ds D- D\h'-1'\(hy +. ds th \o'bp' +. ds Th \o'LP' +. ds ae ae +. ds Ae AE +.\} +.rm #[ #] #H #V #F C +.\" ======================================================================== +.\" +.IX Title "BLUETILE 1" +.TH BLUETILE 1 "2010-06-06" "perl v5.10.1" "" +.\" For nroff, turn off justification. Always turn off hyphenation; it makes +.\" way too many mistakes in technical documents. +.if n .ad l +.nh +.SH "NAME" +bluetile \- a modern tiling window manager with a gentle learning curve +.SH "SYNOPSIS" +.IX Header "SYNOPSIS" +bluetile [\-\-help] [\-\-version] [\-\-restart] +.SH "DESCRIPTION" +.IX Header "DESCRIPTION" +\&\fBBluetile\fR is a tiling window manager for X based on xmonad. Windows are +arranged to use the entire screen without overlapping. \fBBluetile\fR's focus +lies on making the tiling paradigm easily accessible to users coming +from traditional window managers by drawing on known conventions and +providing both mouse and keyboard access for all features. It also tries +to be usable 'out of the box', requiring minimal to no configuration in +most cases. +.IP "\(bu" 4 +Hybrid approach: Stacking window layout & tiling layouts available +.IP "\(bu" 4 +Maximizing & minimizing windows in all layouts +.IP "\(bu" 4 +All features accessible from mouse, as well as keyboard +.IP "\(bu" 4 +Good multihead support +.IP "\(bu" 4 +Proper handling of fullscreen applications +.IP "\(bu" 4 +Designed to integrate with the \s-1GNOME\s0 desktop environment +.SH "OPTIONS" +.IX Header "OPTIONS" +\&\fB\-\-help\fR print help message +.PP +\&\fB\-\-version\fR print the version number +.PP +\&\fB\-\-restart\fR request a running \fBBluetile\fR process to restart +.SH "KEYBOARD SHORTCUTS" +.IX Header "KEYBOARD SHORTCUTS" +This is a list of most keyboard shortcuts for \fBBluetile\fR: +.PP +.Vb 2 +\& Win+Return Launch terminal +\& Win+p Launch GNOME "Run application" dialog +\& +\& Win+a Switch to stacking window layout +\& Win+s Switch to tiled horizontal layout +\& Win+d Switch to tiled vertical layout +\& Win+f Switch to fullscreen layout +\& +\& Win+j Move focus to the next window +\& Win+k Move focus to the previous window +\& Win+Space Move focus to the master window +\& Win+Shift+j Swap the focused window with the next window +\& Win+Shift+k Swap the focused window with the previous window +\& Win+Shift+Space Swap the focused window with the master window +\& +\& Win+h Shrink the master area +\& Win+l Expand the master area +\& Win+u Shrink a slave area +\& Win+i Expand a slave area +\& Win+, Increment the number of windows in the master area +\& Win+. Decrement the number of windows in the master area +\& +\& Win+Shift+c Close the focused window +\& Win+z Maximize/zoom focused window +\& Win+m Minimize focused window +\& Win+Shift+m Restore next minimized window +\& Win+o Show window menu for focused window +\& Win+t Push dialog window back into tiling +\& +\& Win+1 .. Win+9, Win+0 +\& Switch to workspace N +\& +\& Win+Shift+1 .. Win+Shift+9, Win+Shift+0 +\& Move client to workspace N +\& +\& Win+w, Win+e, Win+r +\& Switch to physical/Xinerama screens 1, 2 or 3 +\& +\& Win+Shift+w, Win+Shift+e, Win+Shift+r +\& Move client to physical/Xinerama screen 1, 2 or 3 +\& +\& Win+F5 Refresh layout +\& Win+Shift+q Quit Bluetile +.Ve +.SH "CAVEATS" +.IX Header "CAVEATS" +The full list of keyboard shortcuts is currently only documented in the +source code. Also, there is currently no way to change the keyboard +shortcuts expect by modifying the source code. A user-friendly +configuration system that is more in line with \fBBluetile\fR's goals is +planned. You can also have a look at the wiki on +\&\fBhttp://www.bluetile.org\fR for a possible workaround. +.SH "AUTHOR" +.IX Header "AUTHOR" +Jan Vornberger diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -19,7 +19,6 @@ import XMonad hiding ( (|||) ) -import XMonad.Layout hiding ( (|||) ) import XMonad.Layout.BorderResize import XMonad.Layout.BoringWindows import XMonad.Layout.ButtonDecoration @@ -158,7 +157,7 @@ bluetileManageHook :: ManageHook bluetileManageHook = composeAll - [ workspaceByPos, positionStoreManageHook + [ workspaceByPos, positionStoreManageHook (Just defaultThemeWithButtons) , className =? "MPlayer" --> doFloat , isFullscreen --> doFullFloat , manageDocks] @@ -171,7 +170,7 @@ ) where floating = floatingDeco $ maximize $ borderResize $ positionStoreFloat - tiled1 = tilingDeco $ maximize $ mouseResizableTileMirrored + tiled1 = tilingDeco $ maximize $ mouseResizableTile { isMirrored = True } tiled2 = tilingDeco $ maximize $ mouseResizableTile fullscreen = tilingDeco $ maximize $ smartBorders Full diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -21,7 +21,6 @@ import BluetileDock import Config -import System.IO import System.Environment import System.Cmd import System.Exit @@ -55,9 +54,9 @@ putStrLn "" -- start docks and greeting screen - binDir <- getBinDir - dockHandle <- spawnPipe $ binDir ++ [pathSeparator] ++ "bluetiledock" - spawnPipe $ binDir ++ [pathSeparator] ++ "bluetilegreet" + libexecDir <- getLibexecDir + dockHandle <- spawnPipe $ libexecDir ++ [pathSeparator] ++ "bluetiledock" + spawnPipe $ libexecDir ++ [pathSeparator] ++ "bluetilegreet" -- check terminal uninstallSignalHandlers -- make sure we can receive SIGCHLD to check terminal @@ -75,7 +74,7 @@ "Options:" : " --help Print this message" : " --version Print the version number" : - " --restart Request a running xmonad process to restart" : + " --restart Request a running Bluetile process to restart" : [] sendRestart :: IO () diff --git a/src/XMonad/Actions/BluetileCommands.hs b/src/XMonad/Actions/BluetileCommands.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Actions/BluetileCommands.hs @@ -0,0 +1,83 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.BluetileCommands +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- This is a list of selected commands that can be made available using +-- "XMonad.Hooks.ServerMode" to allow external programs to control +-- the window manager. Bluetile () +-- uses this to enable its dock application to do things like changing +-- workspaces and layouts. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.BluetileCommands ( + -- * Usage + -- $usage + bluetileCommands + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Layout.LayoutCombinators +import System.Exit + +-- $usage +-- +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.ServerMode +-- > import XMonad.Actions.BluetileCommands +-- +-- Then edit your @handleEventHook@: +-- +-- > main = xmonad defaultConfig { handleEventHook = serverModeEventHook' bluetileCommands } +-- +-- See the documentation of "XMonad.Hooks.ServerMode" for details on +-- how to actually invoke the commands from external programs. + +workspaceCommands :: Int -> X [(String, X ())] +workspaceCommands sid = asks (workspaces . config) >>= \spaces -> return + [(("greedyView" ++ show i), + activateScreen sid >> windows (W.greedyView i)) + | i <- spaces ] + +layoutCommands :: Int -> [(String, X ())] +layoutCommands sid = [ ("layout floating" , activateScreen sid >> + sendMessage (JumpToLayout "Floating")) + , ("layout tiled1" , activateScreen sid >> + sendMessage (JumpToLayout "Tiled1")) + , ("layout tiled2" , activateScreen sid >> + sendMessage (JumpToLayout "Tiled2")) + , ("layout fullscreen" , activateScreen sid >> + sendMessage (JumpToLayout "Fullscreen")) + ] + +masterAreaCommands :: Int -> [(String, X ())] +masterAreaCommands sid = [ ("increase master n", activateScreen sid >> + sendMessage (IncMasterN 1)) + , ("decrease master n", activateScreen sid >> + sendMessage (IncMasterN (-1))) + ] + +quitCommands :: [(String, X ())] +quitCommands = [ ("quit bluetile", io (exitWith ExitSuccess)) + , ("quit bluetile and start metacity", restart "metacity" False) + ] + +bluetileCommands :: X [(String, X ())] +bluetileCommands = do + let restartCommand = [ ("restart bluetile", restart "bluetile" True) ] + wscmds0 <- workspaceCommands 0 + wscmds1 <- workspaceCommands 1 + return $ restartCommand + ++ wscmds0 ++ layoutCommands 0 ++ masterAreaCommands 0 ++ quitCommands + ++ wscmds1 ++ layoutCommands 1 ++ masterAreaCommands 1 ++ quitCommands + +activateScreen :: Int -> X () +activateScreen sid = screenWorkspace (S sid) >>= flip whenJust (windows . W.view) diff --git a/src/XMonad/Actions/WindowMenu.hs b/src/XMonad/Actions/WindowMenu.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Actions/WindowMenu.hs @@ -0,0 +1,79 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Actions.WindowMenu +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- Uses "XMonad.Actions.GridSelect" to display a number of actions related to +-- window management in the center of the focused window. Actions include: Closing, +-- maximizing, minimizing and shifting the window to another workspace. +-- +-- Note: For maximizing and minimizing to actually work, you will need +-- to integrate "XMonad.Layout.Maximize" and "XMonad.Layout.Minimize" into your +-- setup. See the documentation of those modules for more information. +-- +----------------------------------------------------------------------------- + +module XMonad.Actions.WindowMenu ( + -- * Usage + -- $usage + windowMenu + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Actions.GridSelect +import XMonad.Layout.Maximize +import XMonad.Layout.Minimize +import XMonad.Util.XUtils (fi) + +-- $usage +-- +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Actions.WindowMenu +-- +-- Then add a keybinding, e.g. +-- +-- > , ((modm, xK_o ), windowMenu) + +colorizer :: a -> Bool -> X (String, String) +colorizer _ isFg = do + fBC <- asks (focusedBorderColor . config) + nBC <- asks (normalBorderColor . config) + return $ if isFg + then (fBC, nBC) + else (nBC, fBC) + +windowMenu :: X () +windowMenu = withFocused $ \w -> do + tags <- asks (workspaces . config) + Rectangle x y wh ht <- getSize w + Rectangle sx sy swh sht <- gets $ screenRect . W.screenDetail . W.current . windowset + let originFractX = (fi x - fi sx + fi wh / 2) / fi swh + originFractY = (fi y - fi sy + fi ht / 2) / fi sht + gsConfig = (buildDefaultGSConfig colorizer) + { gs_originFractX = originFractX + , gs_originFractY = originFractY } + actions = [ ("Cancel menu", return ()) + , ("Close" , kill) + , ("Maximize" , sendMessage $ maximizeRestore w) + , ("Minimize" , sendMessage $ MinimizeWin w) + ] ++ + [ ("Move to " ++ tag, windows $ W.shift tag) + | tag <- tags ] + runSelectedAction gsConfig actions + +getSize :: Window -> X (Rectangle) +getSize w = do + d <- asks display + wa <- io $ getWindowAttributes d w + let x = fi $ wa_x wa + y = fi $ wa_y wa + wh = fi $ wa_width wa + ht = fi $ wa_height wa + return (Rectangle x y wh ht) diff --git a/src/XMonad/Hooks/CurrentWorkspaceOnTop.hs b/src/XMonad/Hooks/CurrentWorkspaceOnTop.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Hooks/CurrentWorkspaceOnTop.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.CurrentWorkspaceOnTop +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- Ensures that the windows of the current workspace are always in front +-- of windows that are located on other visible screens. This becomes important +-- if you use decoration and drag windows from one screen to another. Using this +-- module, the dragged window will always be in front of other windows. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.CurrentWorkspaceOnTop ( + -- * Usage + -- $usage + currentWorkspaceOnTop + ) where + +import XMonad +import qualified XMonad.StackSet as S +import Control.Monad(when) +import System.Posix.Env + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.CurrentWorkspaceOnTop +-- > +-- > main = xmonad $ defaultConfig { +-- > ... +-- > logHook = currentWorkspaceOnTop +-- > ... +-- > } +-- + +data CWOTState = CWOTS String deriving (Read, Show, Typeable) + +currentWorkspaceOnTop :: X () +currentWorkspaceOnTop = withDisplay $ \d -> do + ws <- gets windowset + cwotsEnvM <- io $ getEnv "BLUETILE_CWOTS" + let (CWOTS lastTag) = maybe (CWOTS "") read cwotsEnvM + let curTag = S.tag . S.workspace . S.current $ ws + when (curTag /= lastTag) $ do + let s = S.current ws + wsp = S.workspace s + viewrect = screenRect $ S.screenDetail s + tmpStack = S.stack . S.workspace $ s + (rs, _) <- runLayout wsp { S.stack = tmpStack } viewrect + let wins = map fst rs + when (not . null $ wins) $ do + io $ raiseWindow d (head wins) -- raise first window of current workspace to the very top, + io $ restackWindows d wins -- then use restackWindows to let all other windows from the workspace follow + io $ setEnv "BLUETILE_CWOTS" (show (CWOTS curTag)) True diff --git a/src/XMonad/Hooks/EwmhDesktops.hs b/src/XMonad/Hooks/EwmhDesktops.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Hooks/EwmhDesktops.hs @@ -0,0 +1,254 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.EwmhDesktops +-- Copyright : (c) 2007, 2008 Joachim Breitner +-- License : BSD +-- +-- Maintainer : Joachim Breitner +-- Stability : unstable +-- Portability : unportable +-- +-- Makes xmonad use the EWMH hints to tell panel applications about its +-- workspaces and the windows therein. It also allows the user to interact +-- with xmonad by clicking on panels and window lists. +----------------------------------------------------------------------------- +module XMonad.Hooks.EwmhDesktops ( + -- * Usage + -- $usage + ewmh, + ewmhDesktopsStartup, + ewmhDesktopsLogHook, + ewmhDesktopsLogHookCustom, + ewmhDesktopsEventHook, + fullscreenEventHook + ) where + +import Codec.Binary.UTF8.String (encode) +import Data.List +import Data.Maybe +import Data.Monoid + +import XMonad +import Control.Monad +import qualified XMonad.StackSet as W + +import XMonad.Hooks.SetWMName +import XMonad.Util.XUtils (fi) +import XMonad.Util.WorkspaceCompare +import XMonad.Util.WindowProperties (getProp32) + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad +-- > import XMonad.Hooks.EwmhDesktops +-- > +-- > main = xmonad $ ewmh defaultConfig +-- +-- You may also be interested in 'avoidStruts' from XMonad.Hooks.ManageDocks. + + +-- | Add EWMH functionality to the given config. See above for an example. +ewmh :: XConfig a -> XConfig a +ewmh c = c { startupHook = startupHook c +++ ewmhDesktopsStartup + , handleEventHook = handleEventHook c +++ ewmhDesktopsEventHook + , logHook = logHook c +++ ewmhDesktopsLogHook } + where x +++ y = mappend x y + +-- | +-- Initializes EwmhDesktops and advertises EWMH support to the X +-- server +ewmhDesktopsStartup :: X () +ewmhDesktopsStartup = setSupported + +-- | +-- Notifies pagers and window lists, such as those in the gnome-panel +-- of the current state of workspaces and windows. +ewmhDesktopsLogHook :: X () +ewmhDesktopsLogHook = ewmhDesktopsLogHookCustom id +-- | +-- Generalized version of ewmhDesktopsLogHook that allows an arbitrary +-- user-specified function to transform the workspace list (post-sorting) +ewmhDesktopsLogHookCustom :: ([WindowSpace] -> [WindowSpace]) -> X () +ewmhDesktopsLogHookCustom f = withWindowSet $ \s -> do + sort' <- getSortByIndex + let ws = f $ sort' $ W.workspaces s + + -- Number of Workspaces + setNumberOfDesktops (length ws) + + -- Names thereof + setDesktopNames (map W.tag ws) + + -- all windows, with focused windows last + let wins = nub . concatMap (maybe [] (\(W.Stack x l r)-> reverse l ++ r ++ [x]) . W.stack) $ ws + setClientList wins + + -- Current desktop + case (elemIndex (W.currentTag s) $ map W.tag ws) of + Nothing -> return () + Just curr -> do + setCurrentDesktop curr + + -- Per window Desktop + -- To make gnome-panel accept our xinerama stuff, we display + -- all visible windows on the current desktop. + forM_ (W.current s : W.visible s) $ \x -> + forM_ (W.integrate' (W.stack (W.workspace x))) $ \win -> do + setWindowDesktop win curr + + forM_ (W.hidden s) $ \w -> + case elemIndex (W.tag w) (map W.tag ws) of + Nothing -> return () + Just wn -> forM_ (W.integrate' (W.stack w)) $ \win -> do + setWindowDesktop win wn + + setActiveWindow + + return () + +-- | +-- Intercepts messages from pagers and similar applications and reacts on them. +-- Currently supports: +-- +-- * _NET_CURRENT_DESKTOP (switching desktops) +-- +-- * _NET_WM_DESKTOP (move windows to other desktops) +-- +-- * _NET_ACTIVE_WINDOW (activate another window, changing workspace if needed) +-- +ewmhDesktopsEventHook :: Event -> X All +ewmhDesktopsEventHook e = handle e >> return (All True) + +handle :: Event -> X () +handle ClientMessageEvent { + ev_window = w, + ev_message_type = mt, + ev_data = d + } = withWindowSet $ \s -> do + sort' <- getSortByIndex + let ws = sort' $ W.workspaces s + + a_cd <- getAtom "_NET_CURRENT_DESKTOP" + a_d <- getAtom "_NET_WM_DESKTOP" + a_aw <- getAtom "_NET_ACTIVE_WINDOW" + a_cw <- getAtom "_NET_CLOSE_WINDOW" + a_ignore <- mapM getAtom ["XMONAD_TIMER"] + if mt == a_cd then do + let n = head d + if 0 <= n && fi n < length ws then + windows $ W.view (W.tag (ws !! fi n)) + else trace $ "Bad _NET_CURRENT_DESKTOP with data[0]="++show n + else if mt == a_d then do + let n = head d + if 0 <= n && fi n < length ws then + windows $ W.shiftWin (W.tag (ws !! fi n)) w + else trace $ "Bad _NET_DESKTOP with data[0]="++show n + else if mt == a_aw then do + windows $ W.focusWindow w + else if mt == a_cw then do + killWindow w + else if mt `elem` a_ignore then do + return () + else do + -- The Message is unknown to us, but that is ok, not all are meant + -- to be handled by the window manager + return () +handle _ = return () + +-- | +-- An event hook to handle applications that wish to fullscreen using the +-- _NET_WM_STATE protocol. This includes users of the gtk_window_fullscreen() +-- function, such as Totem, Evince and OpenOffice.org. +fullscreenEventHook :: Event -> X All +fullscreenEventHook (ClientMessageEvent _ _ _ dpy win typ (action:dats)) = do + state <- getAtom "_NET_WM_STATE" + fullsc <- getAtom "_NET_WM_STATE_FULLSCREEN" + wstate <- fromMaybe [] `fmap` getProp32 state win + + let isFull = fromIntegral fullsc `elem` wstate + + -- Constants for the _NET_WM_STATE protocol: + remove = 0 + add = 1 + toggle = 2 + ptype = 4 -- The atom property type for changeProperty + chWstate f = io $ changeProperty32 dpy win state ptype propModeReplace (f wstate) + + when (typ == state && fi fullsc `elem` dats) $ do + when (action == add || (action == toggle && not isFull)) $ do + chWstate (fi fullsc:) + windows $ W.float win $ W.RationalRect 0 0 1 1 + when (action == remove || (action == toggle && isFull)) $ do + chWstate $ delete (fi fullsc) + windows $ W.sink win + + return $ All True + +fullscreenEventHook _ = return $ All True + +setNumberOfDesktops :: (Integral a) => a -> X () +setNumberOfDesktops n = withDisplay $ \dpy -> do + a <- getAtom "_NET_NUMBER_OF_DESKTOPS" + c <- getAtom "CARDINAL" + r <- asks theRoot + io $ changeProperty32 dpy r a c propModeReplace [fromIntegral n] + +setCurrentDesktop :: (Integral a) => a -> X () +setCurrentDesktop i = withDisplay $ \dpy -> do + a <- getAtom "_NET_CURRENT_DESKTOP" + c <- getAtom "CARDINAL" + r <- asks theRoot + io $ changeProperty32 dpy r a c propModeReplace [fromIntegral i] + +setDesktopNames :: [String] -> X () +setDesktopNames names = withDisplay $ \dpy -> do + -- Names thereof + r <- asks theRoot + a <- getAtom "_NET_DESKTOP_NAMES" + c <- getAtom "UTF8_STRING" + let names' = map fromIntegral $ concatMap ((++[0]) . encode) names + io $ changeProperty8 dpy r a c propModeReplace names' + +setClientList :: [Window] -> X () +setClientList wins = withDisplay $ \dpy -> do + -- (What order do we really need? Something about age and stacking) + r <- asks theRoot + c <- getAtom "WINDOW" + a <- getAtom "_NET_CLIENT_LIST" + io $ changeProperty32 dpy r a c propModeReplace (fmap fromIntegral wins) + a' <- getAtom "_NET_CLIENT_LIST_STACKING" + io $ changeProperty32 dpy r a' c propModeReplace (fmap fromIntegral wins) + +setWindowDesktop :: (Integral a) => Window -> a -> X () +setWindowDesktop win i = withDisplay $ \dpy -> do + a <- getAtom "_NET_WM_DESKTOP" + c <- getAtom "CARDINAL" + io $ changeProperty32 dpy win a c propModeReplace [fromIntegral i] + +setSupported :: X () +setSupported = withDisplay $ \dpy -> do + r <- asks theRoot + a <- getAtom "_NET_SUPPORTED" + c <- getAtom "ATOM" + supp <- mapM getAtom ["_NET_WM_STATE_HIDDEN" + ,"_NET_NUMBER_OF_DESKTOPS" + ,"_NET_CLIENT_LIST" + ,"_NET_CLIENT_LIST_STACKING" + ,"_NET_CURRENT_DESKTOP" + ,"_NET_DESKTOP_NAMES" + ,"_NET_ACTIVE_WINDOW" + ,"_NET_WM_DESKTOP" + ,"_NET_WM_STRUT" + ] + io $ changeProperty32 dpy r a c propModeReplace (fmap fromIntegral supp) + + setWMName "xmonad" + +setActiveWindow :: X () +setActiveWindow = withWindowSet $ \s -> withDisplay $ \dpy -> do + let w = fromMaybe none (W.peek s) + r <- asks theRoot + a <- getAtom "_NET_ACTIVE_WINDOW" + c <- getAtom "WINDOW" + io $ changeProperty32 dpy r a c propModeReplace [fromIntegral w] diff --git a/src/XMonad/Hooks/PositionStoreHooks.hs b/src/XMonad/Hooks/PositionStoreHooks.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Hooks/PositionStoreHooks.hs @@ -0,0 +1,106 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Hooks.PositionStoreHooks +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- This module contains two hooks for the +-- PositionStore (see "XMonad.Util.PositionStore") - a ManageHook and +-- an EventHook. +-- +-- The ManageHook can be used to fill the PositionStore with position and size +-- information about new windows. The advantage of using this hook is, that the +-- information is recorded independent of the currently active layout. So the +-- floating shape of the window can later be restored even if it was opened in a +-- tiled layout initially. +-- +-- For windows, that do not request a particular position, a random position will +-- be assigned. This prevents windows from piling up exactly on top of each other. +-- +-- The EventHook makes sure that windows are deleted from the PositionStore +-- when they are closed. +-- +----------------------------------------------------------------------------- + +module XMonad.Hooks.PositionStoreHooks ( + -- * Usage + -- $usage + positionStoreManageHook, + positionStoreEventHook + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Util.PositionStore +import XMonad.Hooks.ManageDocks +import XMonad.Layout.Decoration + +import System.Random(randomRIO) +import Control.Applicative((<$>)) +import Control.Monad(when) +import Data.Maybe +import Data.Monoid +import qualified Data.Set as S + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Hooks.PositionStoreHooks +-- +-- and adding 'positionStoreManageHook' to your 'ManageHook' as well +-- as 'positionStoreEventHook' to your event hooks. To be accurate +-- about window sizes, the module needs to know if any decoration is in effect. +-- This is specified with the first argument: Supply 'Nothing' for no decoration, +-- otherwise use 'Just defaultTheme' or similar to inform the module about the +-- decoration theme used. +-- +-- > myManageHook = positionStoreManageHook Nothing <+> manageHook defaultConfig +-- > myHandleEventHook = positionStoreEventHook +-- > +-- > main = xmonad defaultConfig { manageHook = myManageHook +-- > , handleEventHook = myHandleEventHook +-- > } +-- + +positionStoreManageHook :: Maybe Theme -> ManageHook +positionStoreManageHook mDecoTheme = ask >>= liftX . positionStoreInit mDecoTheme >> idHook + +positionStoreInit :: Maybe Theme -> Window -> X () +positionStoreInit mDecoTheme w = withDisplay $ \d -> do + let decoH = maybe 0 decoHeight mDecoTheme -- take decoration into account, which - in its current + -- form - makes windows smaller to make room for it + wa <- io $ getWindowAttributes d w + ws <- gets windowset + arbitraryOffsetX <- randomIntOffset + arbitraryOffsetY <- randomIntOffset + if (wa_x wa == 0) && (wa_y wa == 0) + then do + let sr@(Rectangle srX srY _ _) = screenRect . W.screenDetail . W.current $ ws + modifyPosStore (\ps -> posStoreInsert ps w + (Rectangle (srX + fi arbitraryOffsetX) + (srY + fi arbitraryOffsetY) + (fi $ wa_width wa) + (decoH + fi (wa_height wa))) sr ) + else do + sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa) + let sr = screenRect . W.screenDetail $ sc + sr' <- fmap ($ sr) (calcGap $ S.fromList [minBound .. maxBound]) -- take docks into account, accepting + -- a somewhat unfortunate inter-dependency + -- with 'XMonad.Hooks.ManageDocks' + modifyPosStore (\ps -> posStoreInsert ps w + (Rectangle (fi $ wa_x wa) (fi (wa_y wa) - fi decoH) + (fi $ wa_width wa) (decoH + fi (wa_height wa))) sr' ) + where + randomIntOffset :: X (Int) + randomIntOffset = io $ randomRIO (42, 242) + +positionStoreEventHook :: Event -> X All +positionStoreEventHook (DestroyWindowEvent {ev_window = w, ev_event_type = et}) = do + when (et == destroyNotify) $ do + modifyPosStore (\ps -> posStoreRemove ps w) + return (All True) +positionStoreEventHook _ = return (All True) diff --git a/src/XMonad/Layout/BorderResize.hs b/src/XMonad/Layout/BorderResize.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/BorderResize.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.BorderResize +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- This layout modifier will allow to resize windows by dragging their +-- borders with the mouse. However, it only works in layouts or modified +-- layouts that react to the 'SetGeometry' message. +-- "XMonad.Layout.WindowArranger" can be used to create such a setup, +-- but it is probably must useful in a floating layout such as +-- "XMonad.Layout.PositionStoreFloat" with which it has been mainly tested. +-- See the documentation of PositionStoreFloat for a typical usage example. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.BorderResize + ( -- * Usage + -- $usage + borderResize + , BorderResize (..) + ) where + +import XMonad +import XMonad.Layout.Decoration +import XMonad.Layout.WindowArranger +import XMonad.Util.XUtils +import Control.Monad(when) +import qualified Data.Map as M + +-- $usage +-- You can use this module with the following in your +-- @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.BorderResize +-- > myLayout = borderResize (... layout setup that reacts to SetGeometry ...) +-- > main = xmonad defaultConfig { layoutHook = myLayout } +-- + +type BorderBlueprint = (Rectangle, Glyph, BorderType) + +data BorderType = RightSideBorder + | LeftSideBorder + | TopSideBorder + | BottomSideBorder + deriving (Show, Read, Eq) +data BorderInfo = BI { bWin :: Window, + bRect :: Rectangle, + bType :: BorderType + } deriving (Show, Read) + +type RectWithBorders = (Rectangle, [BorderInfo]) + +data BorderResize a = BR (M.Map Window RectWithBorders) deriving (Show, Read) + +brBorderOffset :: Position +brBorderOffset = 5 +brBorderSize :: Dimension +brBorderSize = 10 + +borderResize :: l a -> ModifiedLayout BorderResize l a +borderResize = ModifiedLayout (BR M.empty) + +instance LayoutModifier BorderResize Window where + redoLayout _ _ Nothing wrs = return (wrs, Nothing) + redoLayout (BR wrsLastTime) _ _ wrs = do + let correctOrder = map fst wrs + wrsCurrent = M.fromList wrs + wrsGone = M.difference wrsLastTime wrsCurrent + wrsAppeared = M.difference wrsCurrent wrsLastTime + wrsStillThere = M.intersectionWith testIfUnchanged wrsLastTime wrsCurrent + handleGone wrsGone + wrsCreated <- handleAppeared wrsAppeared + let wrsChanged = handleStillThere wrsStillThere + wrsThisTime = M.union wrsChanged wrsCreated + return (compileWrs wrsThisTime correctOrder, Just $ BR wrsThisTime) + -- What we return is the original wrs with the new border + -- windows inserted at the correct positions - this way, the core + -- will restack the borders correctly. + -- We also return information about our borders, so that we + -- can handle events that they receive and destroy them when + -- they are no longer needed. + where + testIfUnchanged entry@(rLastTime, _) rCurrent = + if rLastTime == rCurrent + then (Nothing, entry) + else (Just rCurrent, entry) + + handleMess (BR wrsLastTime) m + | Just e <- fromMessage m :: Maybe Event = + handleResize (createBorderLookupTable wrsLastTime) e >> return Nothing + | Just _ <- fromMessage m :: Maybe LayoutMessages = + handleGone wrsLastTime >> return (Just $ BR M.empty) + handleMess _ _ = return Nothing + +compileWrs :: M.Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)] +compileWrs wrsThisTime correctOrder = let wrs = reorder (M.toList wrsThisTime) correctOrder + in concat $ map compileWr wrs + +compileWr :: (Window, RectWithBorders) -> [(Window, Rectangle)] +compileWr (w, (r, borderInfos)) = + let borderWrs = for borderInfos $ \bi -> (bWin bi, bRect bi) + in borderWrs ++ [(w, r)] + +handleGone :: M.Map Window RectWithBorders -> X () +handleGone wrsGone = mapM_ deleteWindow borderWins + where + borderWins = map bWin . concat . map snd . M.elems $ wrsGone + +handleAppeared :: M.Map Window Rectangle -> X (M.Map Window RectWithBorders) +handleAppeared wrsAppeared = do + let wrs = M.toList wrsAppeared + wrsCreated <- mapM handleSingleAppeared wrs + return $ M.fromList wrsCreated + +handleSingleAppeared :: (Window, Rectangle) -> X (Window, RectWithBorders) +handleSingleAppeared (w, r) = do + let borderBlueprints = prepareBorders r + borderInfos <- mapM createBorder borderBlueprints + return (w, (r, borderInfos)) + +handleStillThere :: M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders +handleStillThere wrsStillThere = M.map handleSingleStillThere wrsStillThere + +handleSingleStillThere :: (Maybe Rectangle, RectWithBorders) -> RectWithBorders +handleSingleStillThere (Nothing, entry) = entry +handleSingleStillThere (Just rCurrent, (_, borderInfos)) = (rCurrent, updatedBorderInfos) + where + changedBorderBlueprints = prepareBorders rCurrent + updatedBorderInfos = map updateBorderInfo . zip borderInfos $ changedBorderBlueprints + -- assuming that the four borders are always in the same order + +updateBorderInfo :: (BorderInfo, BorderBlueprint) -> BorderInfo +updateBorderInfo (borderInfo, (r, _, _)) = borderInfo { bRect = r } + +createBorderLookupTable :: M.Map Window RectWithBorders -> [(Window, (BorderType, Window, Rectangle))] +createBorderLookupTable wrsLastTime = concat $ map processSingleEntry $ M.toList wrsLastTime + where + processSingleEntry :: (Window, RectWithBorders) -> [(Window, (BorderType, Window, Rectangle))] + processSingleEntry (w, (r, borderInfos)) = for borderInfos $ \bi -> (bWin bi, (bType bi, w, r)) + +prepareBorders :: Rectangle -> [BorderBlueprint] +prepareBorders (Rectangle x y wh ht) = + [((Rectangle (x + fi wh - brBorderOffset) y brBorderSize ht), xC_right_side , RightSideBorder), + ((Rectangle (x - brBorderOffset) y brBorderSize ht) , xC_left_side , LeftSideBorder), + ((Rectangle x (y - brBorderOffset) wh brBorderSize) , xC_top_side , TopSideBorder), + ((Rectangle x (y + fi ht - brBorderOffset) wh brBorderSize), xC_bottom_side, BottomSideBorder) + ] + +handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X () +handleResize borders ButtonEvent { ev_window = ew, ev_event_type = et } + | et == buttonPress, Just edge <- lookup ew borders = + case edge of + (RightSideBorder, hostWin, (Rectangle hx hy _ hht)) -> + mouseDrag (\x _ -> do + let nwh = max 1 $ fi (x - hx) + rect = Rectangle hx hy nwh hht + focus hostWin + when (x - hx > 0) $ sendMessage (SetGeometry rect)) (focus hostWin) + (LeftSideBorder, hostWin, (Rectangle hx hy hwh hht)) -> + mouseDrag (\x _ -> do + let nx = max 0 $ min (hx + fi hwh) $ x + nwh = max 1 $ hwh + fi (hx - x) + rect = Rectangle nx hy nwh hht + focus hostWin + when (x < hx + fi hwh) $ sendMessage (SetGeometry rect)) (focus hostWin) + (TopSideBorder, hostWin, (Rectangle hx hy hwh hht)) -> + mouseDrag (\_ y -> do + let ny = max 0 $ min (hy + fi hht) $ y + nht = max 1 $ hht + fi (hy - y) + rect = Rectangle hx ny hwh nht + focus hostWin + when (y < hy + fi hht) $ sendMessage (SetGeometry rect)) (focus hostWin) + (BottomSideBorder, hostWin, (Rectangle hx hy hwh _)) -> + mouseDrag (\_ y -> do + let nht = max 1 $ fi (y - hy) + rect = Rectangle hx hy hwh nht + focus hostWin + when (y - hy > 0) $ sendMessage (SetGeometry rect)) (focus hostWin) +handleResize _ _ = return () + +createBorder :: BorderBlueprint -> X (BorderInfo) +createBorder (borderRect, borderCursor, borderType) = do + borderWin <- createInputWindow borderCursor borderRect + return BI { bWin = borderWin, bRect = borderRect, bType = borderType } + +createInputWindow :: Glyph -> Rectangle -> X Window +createInputWindow cursorGlyph r = withDisplay $ \d -> do + win <- mkInputWindow d r + io $ selectInput d win (exposureMask .|. buttonPressMask) + cursor <- io $ createFontCursor d cursorGlyph + io $ defineCursor d win cursor + io $ freeCursor d cursor + showWindow win + return win + +mkInputWindow :: Display -> Rectangle -> X Window +mkInputWindow d (Rectangle x y w h) = do + rw <- asks theRoot + let screen = defaultScreenOfDisplay d + visual = defaultVisualOfScreen screen + attrmask = cWOverrideRedirect + io $ allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes True + createWindow d rw x y w h 0 0 inputOnly visual attrmask attributes + +for :: [a] -> (a -> b) -> [b] +for = flip map + +reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)] +reorder wrs order = + let ordered = concat $ map (pickElem wrs) order + rest = filter (\(w, _) -> not (w `elem` order)) wrs + in ordered ++ rest + where + pickElem list e = case (lookup e list) of + Just result -> [(e, result)] + Nothing -> [] diff --git a/src/XMonad/Layout/ButtonDecoration.hs b/src/XMonad/Layout/ButtonDecoration.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/ButtonDecoration.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ButtonDecoration +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A decoration that includes small buttons on both ends which invoke +-- various actions when clicked on: Show a window menu (see +-- "XMonad.Actions.WindowMenu"), minimize, maximize or close the window. +-- +-- Note: For maximizing and minimizing to actually work, you will need +-- to integrate "XMonad.Layout.Maximize" and "XMonad.Layout.Minimize" into your +-- setup. See the documentation of those modules for more information. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.ButtonDecoration + ( -- * Usage: + -- $usage + buttonDeco + ) where + +import XMonad +import XMonad.Layout.Decoration +import XMonad.Layout.DecorationAddons + +-- $usage +-- You can use this module with the following in your +-- @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.DecorationAddons +-- > import XMonad.Layout.ButtonDecoration +-- +-- Then edit your @layoutHook@ by adding the ButtonDecoration to +-- your layout: +-- +-- > myL = buttonDeco shrinkText defaultThemeWithButtons (layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- + +buttonDeco :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration ButtonDecoration s) l a +buttonDeco s c = decoration s c $ NFD True + +data ButtonDecoration a = NFD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle ButtonDecoration a where + describeDeco _ = "ButtonDeco" + decorationCatchClicksHook _ mainw dFL dFR = titleBarButtonHandler mainw dFL dFR + decorationAfterDraggingHook _ (mainw, _) decoWin = focus mainw >> handleScreenCrossing mainw decoWin >> return () diff --git a/src/XMonad/Layout/Decoration.hs b/src/XMonad/Layout/Decoration.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/Decoration.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Decoration +-- Copyright : (c) 2007 Andrea Rossato, 2009 Jan Vornberger +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A layout modifier and a class for easily creating decorated +-- layouts. +----------------------------------------------------------------------------- + +module XMonad.Layout.Decoration + ( -- * Usage: + -- $usage + decoration + , Theme (..), defaultTheme + , Decoration + , DecorationMsg (..) + , DecorationStyle (..) + , DefaultDecoration (..) + , Shrinker (..), DefaultShrinker + , shrinkText, CustomShrink ( CustomShrink ), shrinkWhile + , isInStack, isVisible, isInvisible, isWithin, fi + , findWindowByDecoration + , module XMonad.Layout.LayoutModifier + ) where + +import Control.Monad (when) +import Data.Maybe +import Data.List +import Foreign.C.Types(CInt) + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Hooks.UrgencyHook +import XMonad.Layout.LayoutModifier +import XMonad.Layout.WindowArranger (WindowArrangerMsg (..), diff, listFromList) +import XMonad.Util.NamedWindows (getName) +import XMonad.Util.Invisible +import XMonad.Util.XUtils +import XMonad.Util.Font +import XMonad.Util.Image + +-- $usage +-- This module is intended for layout developers, who want to decorate +-- their layouts. End users will not find here very much for them. +-- +-- For examples of 'DecorationStyle' instances you can have a look at +-- "XMonad.Layout.SimpleDecoration", "XMonad.Layout.Tabbed", +-- "XMonad.Layout.DwmStyle", or "XMonad.Layout.TabBarDecoration". + +-- | A layout modifier that, with a 'Shrinker', a 'Theme', a +-- 'DecorationStyle', and a layout, will decorate this layout +-- according to the decoration style provided. +-- +-- For some usage examples see "XMonad.Layout.DecorationMadness". +decoration :: (DecorationStyle ds a, Shrinker s) => s -> Theme -> ds a + -> l a -> ModifiedLayout (Decoration ds s) l a +decoration s t ds = ModifiedLayout (Decoration (I Nothing) s t ds) + +-- | A 'Theme' is a record of colors, font etc., to customize a +-- 'DecorationStyle'. +-- +-- For a collection of 'Theme's see "XMonad.Util.Themes" +data Theme = + Theme { activeColor :: String -- ^ Color of the active window + , inactiveColor :: String -- ^ Color of the inactive window + , urgentColor :: String -- ^ Color of the urgent window + , activeBorderColor :: String -- ^ Color of the border of the active window + , inactiveBorderColor :: String -- ^ Color of the border of the inactive window + , urgentBorderColor :: String -- ^ Color of the border of the urgent window + , activeTextColor :: String -- ^ Color of the text of the active window + , inactiveTextColor :: String -- ^ Color of the text of the inactive window + , urgentTextColor :: String -- ^ Color of the text of the urgent window + , fontName :: String -- ^ Font name + , decoWidth :: Dimension -- ^ Maximum width of the decorations (if supported by the 'DecorationStyle') + , decoHeight :: Dimension -- ^ Height of the decorations + , windowTitleAddons :: [(String, Align)] -- ^ Extra text to appear in a window's title bar + , windowTitleIcons :: [([[Bool]], Placement)] -- ^ Extra icons to appear in a window's title bar + } deriving (Show, Read) + +-- | The default xmonad 'Theme'. +defaultTheme :: Theme +defaultTheme = + Theme { activeColor = "#999999" + , inactiveColor = "#666666" + , urgentColor = "#FFFF00" + , activeBorderColor = "#FFFFFF" + , inactiveBorderColor = "#BBBBBB" + , urgentBorderColor = "##00FF00" + , activeTextColor = "#FFFFFF" + , inactiveTextColor = "#BFBFBF" + , urgentTextColor = "#FF0000" + , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , decoWidth = 200 + , decoHeight = 20 + , windowTitleAddons = [] + , windowTitleIcons = [] + } + +-- | A 'Decoration' layout modifier will handle 'SetTheme', a message +-- to dynamically change the decoration 'Theme'. +data DecorationMsg = SetTheme Theme deriving ( Typeable ) +instance Message DecorationMsg + +-- | The 'Decoration' state component, where the list of decorated +-- window's is zipped with a list of decoration. A list of decoration +-- is a list of tuples, a 'Maybe' 'Window' and a 'Maybe Rectangle'. +-- The 'Window' will be displayed only if the rectangle is of type +-- 'Just'. +data DecorationState = + DS { decos :: [(OrigWin,DecoWin)] + , font :: XMonadFont + } +type DecoWin = (Maybe Window, Maybe Rectangle) +type OrigWin = (Window,Rectangle) + +-- | The 'Decoration' 'LayoutModifier'. This data type is an instance +-- of the 'LayoutModifier' class. This data type will be passed, +-- together with a layout, to the 'ModifiedLayout' type constructor +-- to modify the layout by adding decorations according to a +-- 'DecorationStyle'. +data Decoration ds s a = + Decoration (Invisible Maybe DecorationState) s Theme (ds a) + deriving (Show, Read) + +-- | The 'DecorationStyle' class, defines methods used in the +-- implementation of the 'Decoration' 'LayoutModifier' instance. A +-- type instance of this class is passed to the 'Decoration' type in +-- order to decorate a layout, by using these methods. +class (Read (ds a), Show (ds a), Eq a) => DecorationStyle ds a where + + -- | The description that the 'Decoration' modifier will display. + describeDeco :: ds a -> String + describeDeco ds = show ds + + -- | Shrink the window's rectangle when applying a decoration. + shrink :: ds a -> Rectangle -> Rectangle -> Rectangle + shrink _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh) + + -- | The decoration event hook + decorationEventHook :: ds a -> DecorationState -> Event -> X () + decorationEventHook ds s e = handleMouseFocusDrag ds s e + + -- | A hook that can be used to catch the cases when the user + -- clicks on the decoration. If you return True here, the click event + -- will be considered as dealt with and no further processing will take place. + decorationCatchClicksHook :: ds a + -> Window + -> Int -- ^ distance from the left where the click happened on the decoration + -> Int -- ^ distance from the right where the click happened on the decoration + -> X Bool + decorationCatchClicksHook _ _ _ _ = return False + + -- | This hook is called while a window is dragged using the decoration. + -- The hook can be overwritten if a different way of handling the dragging + -- is required. + decorationWhileDraggingHook :: ds a -> CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X () + decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleDraggingInProgress ex ey (mainw, r) x y + + -- | This hoook is called after a window has been dragged using the decoration. + decorationAfterDraggingHook :: ds a -> (Window, Rectangle) -> Window -> X () + decorationAfterDraggingHook _ds (mainw, _r) _decoWin = focus mainw + + -- | The pure version of the main method, 'decorate'. + pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle + -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle + pureDecoration _ _ ht _ s _ (w,Rectangle x y wh ht') = if isInStack s w && (ht < ht') + then Just $ Rectangle x y wh ht + else Nothing + + -- | Given the theme's decoration width and height, the screen + -- rectangle, the windows stack, the list of windows and + -- rectangles returned by the underlying layout and window to be + -- decorated, tupled with its rectangle, produce a 'Just' + -- 'Rectangle' or 'Nothing' if the window is not to be decorated. + decorate :: ds a -> Dimension -> Dimension -> Rectangle + -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> X (Maybe Rectangle) + decorate ds w h r s wrs wr = return $ pureDecoration ds w h r s wrs wr + +-- | The default 'DecorationStyle', with just the default methods' +-- implementations. +data DefaultDecoration a = DefaultDecoration deriving ( Read, Show ) +instance Eq a => DecorationStyle DefaultDecoration a + +-- | The long 'LayoutModifier' instance for the 'Decoration' type. +-- +-- In 'redoLayout' we check the state: if there is no state we +-- initialize it. +-- +-- The state is 'diff'ed against the list of windows produced by the +-- underlying layout: removed windows get deleted and new ones +-- decorated by 'createDecos', which will call 'decorate' to decide if +-- a window must be given a 'Rectangle', in which case a decoration +-- window will be created. +-- +-- After that we resync the updated state with the windows' list and +-- then we process the resynced stated (as we do with a new state). +-- +-- First we map the decoration windows, we update each decoration to +-- reflect any decorated window's change, and we insert, in the list +-- of windows and rectangles returned by the underlying layout, the +-- decoration for each window. This way xmonad will restack the +-- decorations and their windows accordingly. At the end we remove +-- invisible\/stacked windows. +-- +-- Message handling is quite simple: when needed we release the state +-- component of the 'Decoration' 'LayoutModifier'. Otherwise we call +-- 'handleEvent', which will call the appropriate 'DecorationStyle' +-- methods to perform its tasks. +instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration ds s) Window where + redoLayout (Decoration (I (Just s)) sh t ds) _ Nothing _ = do + releaseResources s + return ([], Just $ Decoration (I Nothing) sh t ds) + redoLayout _ _ Nothing _ = return ([], Nothing) + + redoLayout (Decoration st sh t ds) sc (Just stack) wrs + | I Nothing <- st = initState t ds sc stack wrs >>= processState + | I (Just s) <- st = do let dwrs = decos s + (d,a) = curry diff (get_ws dwrs) ws + toDel = todel d dwrs + toAdd = toadd a wrs + deleteDecos (map snd toDel) + let ndwrs = zip toAdd $ repeat (Nothing,Nothing) + ndecos <- resync (ndwrs ++ del_dwrs d dwrs) wrs + processState (s {decos = ndecos }) + | otherwise = return (wrs, Nothing) + + where + ws = map fst wrs + get_w = fst . fst + get_ws = map get_w + del_dwrs = listFromList get_w notElem + find_dw i = fst . snd . flip (!!) i + todel d = filter (flip elem d . get_w) + toadd a = filter (flip elem a . fst ) + + check_dwr dwr = case dwr of + (Nothing, Just dr) -> do dw <- createDecoWindow t dr + return (Just dw, Just dr) + _ -> return dwr + + resync _ [] = return [] + resync d ((w,r):xs) = case w `elemIndex` get_ws d of + Just i -> do dr <- decorate ds (decoWidth t) (decoHeight t) sc stack wrs (w,r) + dwr <- check_dwr (find_dw i d, dr) + dwrs <- resync d xs + return $ ((w,r),dwr) : dwrs + Nothing -> resync d xs + + -- We drop any windows that are *precisely* stacked underneath + -- another window: these must be intended to be tabbed! + remove_stacked rs ((w,r):xs) + | r `elem` rs = remove_stacked rs xs + | otherwise = (w,r) : remove_stacked (r:rs) xs + remove_stacked _ [] = [] + + insert_dwr ((w,r),(Just dw,Just dr)) xs = (dw,dr):(w, shrink ds dr r):xs + insert_dwr (x ,( _ , _ )) xs = x:xs + + dwrs_to_wrs = remove_stacked [] . foldr insert_dwr [] + + processState s = do let ndwrs = decos s + showDecos (map snd ndwrs) + updateDecos sh t (font s) ndwrs + return (dwrs_to_wrs ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh t ds)) + + handleMess (Decoration (I (Just s@(DS {decos = dwrs}))) sh t ds) m + | Just e <- fromMessage m = do decorationEventHook ds s e + handleEvent sh t s e + return Nothing + | Just Hide <- fromMessage m = do hideDecos (map snd dwrs) + return Nothing + | Just (SetTheme nt) <- fromMessage m = do releaseResources s + return $ Just $ Decoration (I Nothing) sh nt ds + | Just ReleaseResources <- fromMessage m = do releaseResources s + return $ Just $ Decoration (I Nothing) sh t ds + handleMess _ _ = return Nothing + + modifierDescription (Decoration _ _ _ ds) = describeDeco ds + +-- | By default 'Decoration' handles 'PropertyEvent' and 'ExposeEvent' +-- only. +handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X () +handleEvent sh t (DS dwrs fs) e + | PropertyEvent {ev_window = w} <- e + , Just i <- w `elemIndex` (map (fst . fst) dwrs) = updateDeco sh t fs (dwrs !! i) + | ExposeEvent {ev_window = w} <- e + , Just i <- w `elemIndex` (catMaybes $ map (fst . snd) dwrs) = updateDeco sh t fs (dwrs !! i) +handleEvent _ _ _ _ = return () + +-- | Mouse focus and mouse drag are handled by the same function, this +-- way we can start dragging unfocused windows too. +handleMouseFocusDrag :: (DecorationStyle ds a) => ds a -> DecorationState -> Event -> X () +handleMouseFocusDrag ds (DS dwrs _) ButtonEvent { ev_window = ew + , ev_event_type = et + , ev_x_root = ex + , ev_y_root = ey } + | et == buttonPress + , Just ((mainw,r), (_, decoRectM)) <- lookFor ew dwrs = do + let Just (Rectangle dx _ dwh _) = decoRectM + distFromLeft = ex - fi dx + distFromRight = fi dwh - (ex - fi dx) + dealtWith <- decorationCatchClicksHook ds mainw (fi distFromLeft) (fi distFromRight) + when (not dealtWith) $ do + mouseDrag (\x y -> focus mainw >> decorationWhileDraggingHook ds ex ey (mainw, r) x y) + (decorationAfterDraggingHook ds (mainw, r) ew) +handleMouseFocusDrag _ _ _ = return () + +handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X () +handleDraggingInProgress ex ey (_, r) x y = do + let rect = Rectangle (x - (fi ex - rect_x r)) + (y - (fi ey - rect_y r)) + (rect_width r) + (rect_height r) + sendMessage $ SetGeometry rect + +-- | Given a window and the state, if a matching decoration is in the +-- state return it with its ('Maybe') 'Rectangle'. +lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle)) +lookFor w ((wr,(Just dw,dr)):dwrs) | w == dw = Just (wr,(dw,dr)) + | otherwise = lookFor w dwrs +lookFor w ((_, (Nothing, _)):dwrs) = lookFor w dwrs +lookFor _ [] = Nothing + +findWindowByDecoration :: Window -> DecorationState -> Maybe (OrigWin,(Window,Maybe Rectangle)) +findWindowByDecoration w ds = lookFor w (decos ds) + +-- | Initialize the 'DecorationState' by initializing the font +-- structure and by creating the needed decorations. +initState :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle + -> W.Stack Window -> [(Window,Rectangle)] -> X DecorationState +initState t ds sc s wrs = do + fs <- initXMF (fontName t) + dwrs <- createDecos t ds sc s wrs wrs + return $ DS dwrs fs + +-- | Delete windows stored in the state and release the font structure. +releaseResources :: DecorationState -> X () +releaseResources s = do + deleteDecos (map snd $ decos s) + releaseXMF (font s) + +-- | Create the decoration windows of a list of windows and their +-- rectangles, by calling the 'decorate' method of the +-- 'DecorationStyle' received. +createDecos :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle -> W.Stack Window + -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)] +createDecos t ds sc s wrs ((w,r):xs) = do + deco <- decorate ds (decoWidth t) (decoHeight t) sc s wrs (w,r) + case deco of + Just dr -> do dw <- createDecoWindow t dr + dwrs <- createDecos t ds sc s wrs xs + return $ ((w,r), (Just dw, Just dr)) : dwrs + Nothing -> do dwrs <- createDecos t ds sc s wrs xs + return $ ((w,r), (Nothing, Nothing)) : dwrs +createDecos _ _ _ _ _ [] = return [] + +createDecoWindow :: Theme -> Rectangle -> X Window +createDecoWindow t r = let mask = Just (exposureMask .|. buttonPressMask) in + createNewWindow r mask (inactiveColor t) True + +showDecos :: [DecoWin] -> X () +showDecos = showWindows . catMaybes . map fst . filter (isJust . snd) + +hideDecos :: [DecoWin] -> X () +hideDecos = hideWindows . catMaybes . map fst + +deleteDecos :: [DecoWin] -> X () +deleteDecos = deleteWindows . catMaybes . map fst + +updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X () +updateDecos s t f = mapM_ $ updateDeco s t f + +-- | Update a decoration window given a shrinker, a theme, the font +-- structure and the needed 'Rectangle's +updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X () +updateDeco sh t fs ((w,_),(Just dw,Just (Rectangle _ _ wh ht))) = do + nw <- getName w + ur <- readUrgents + dpy <- asks display + let focusColor win ic ac uc = (maybe ic (\focusw -> case () of + _ | focusw == win -> ac + | win `elem` ur -> uc + | otherwise -> ic) . W.peek) + `fmap` gets windowset + (bc,borderc,tc) <- focusColor w (inactiveColor t, inactiveBorderColor t, inactiveTextColor t) + (activeColor t, activeBorderColor t, activeTextColor t) + (urgentColor t, urgentBorderColor t, urgentTextColor t) + let s = shrinkIt sh + name <- shrinkWhile s (\n -> do size <- io $ textWidthXMF dpy fs n + return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) + let als = AlignCenter : map snd (windowTitleAddons t) + strs = name : map fst (windowTitleAddons t) + i_als = map snd (windowTitleIcons t) + icons = map fst (windowTitleIcons t) + paintTextAndIcons dw fs wh ht 1 bc borderc tc bc als strs i_als icons +updateDeco _ _ _ (_,(Just w,Nothing)) = hideWindow w +updateDeco _ _ _ _ = return () + +-- | True if the window is in the 'Stack'. The 'Window' comes second +-- to facilitate list processing, even though @w \`isInStack\` s@ won't +-- work...;) +isInStack :: Eq a => W.Stack a -> a -> Bool +isInStack s = flip elem (W.integrate s) + +-- | Given a 'Rectangle' and a list of 'Rectangle's is True if the +-- 'Rectangle' is not completely contained by any 'Rectangle' of the +-- list. +isVisible :: Rectangle -> [Rectangle] -> Bool +isVisible r = and . foldr f [] + where f x xs = if r `isWithin` x then False : xs else True : xs + +-- | The contrary of 'isVisible'. +isInvisible :: Rectangle -> [Rectangle] -> Bool +isInvisible r = not . isVisible r + +-- | True is the first 'Rectangle' is totally within the second +-- 'Rectangle'. +isWithin :: Rectangle -> Rectangle -> Bool +isWithin (Rectangle x y w h) (Rectangle rx ry rw rh) + | x >= rx, x <= rx + fi rw + , y >= ry, y <= ry + fi rh + , x + fi w <= rx + fi rw + , y + fi h <= ry + fi rh = True + | otherwise = False + +shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X String +shrinkWhile sh p x = sw $ sh x + where sw [n] = return n + sw [] = return "" + sw (n:ns) = do + cond <- p n + if cond + then sw ns + else return n + +data CustomShrink = CustomShrink +instance Show CustomShrink where show _ = "" +instance Read CustomShrink where readsPrec _ s = [(CustomShrink,s)] + +class (Read s, Show s) => Shrinker s where + shrinkIt :: s -> String -> [String] + +data DefaultShrinker = DefaultShrinker +instance Show DefaultShrinker where show _ = "" +instance Read DefaultShrinker where readsPrec _ s = [(DefaultShrinker,s)] +instance Shrinker DefaultShrinker where + shrinkIt _ "" = [""] + shrinkIt s cs = cs : shrinkIt s (init cs) + +shrinkText :: DefaultShrinker +shrinkText = DefaultShrinker diff --git a/src/XMonad/Layout/DecorationAddons.hs b/src/XMonad/Layout/DecorationAddons.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/DecorationAddons.hs @@ -0,0 +1,123 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.DecorationAddons +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- Various stuff that can be added to the decoration. Most of it +-- is intended to be used by other modules. See +-- "XMonad.Layout.ButtonDecoration" for a module that makes use of this. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.DecorationAddons ( + titleBarButtonHandler + ,defaultThemeWithButtons + ,handleScreenCrossing + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Layout.Decoration +import XMonad.Actions.WindowMenu +import XMonad.Layout.Minimize +import XMonad.Layout.Maximize +import XMonad.Hooks.ManageDocks +import XMonad.Util.Font +import XMonad.Util.PositionStore + +import Control.Applicative((<$>)) +import Data.Maybe +import qualified Data.Set as S + +minimizeButtonOffset :: Int +minimizeButtonOffset = 48 + +maximizeButtonOffset :: Int +maximizeButtonOffset = 25 + +closeButtonOffset :: Int +closeButtonOffset = 10 + +buttonSize :: Int +buttonSize = 10 + +-- | A function intended to be plugged into the 'decorationCatchClicksHook' of a decoration. +-- It will intercept clicks on the buttons of the decoration and invoke the associated action. +-- To actually see the buttons, you will need to use a theme that includes them. +-- See 'defaultThemeWithButtons' below. +titleBarButtonHandler :: Window -> Int -> Int -> X Bool +titleBarButtonHandler mainw distFromLeft distFromRight = do + let action = if (fi distFromLeft <= 3 * buttonSize) + then focus mainw >> windowMenu >> return True + else if (fi distFromRight >= closeButtonOffset && + fi distFromRight <= closeButtonOffset + buttonSize) + then focus mainw >> kill >> return True + else if (fi distFromRight >= maximizeButtonOffset && + fi distFromRight <= maximizeButtonOffset + (2 * buttonSize)) + then focus mainw >> sendMessage (maximizeRestore mainw) >> return True + else if (fi distFromRight >= minimizeButtonOffset && + fi distFromRight <= minimizeButtonOffset + buttonSize) + then focus mainw >> sendMessage (MinimizeWin mainw) >> return True + else return False + action + +-- | Intended to be used together with 'titleBarButtonHandler'. See above. +defaultThemeWithButtons :: Theme +defaultThemeWithButtons = defaultTheme { + windowTitleAddons = [ (" (M)", AlignLeft) + , ("_" , AlignRightOffset minimizeButtonOffset) + , ("[]" , AlignRightOffset maximizeButtonOffset) + , ("X" , AlignRightOffset closeButtonOffset) + ] + } + +-- | A function intended to be plugged into the 'decorationAfterDraggingHook' of a decoration. +-- It will check if the window has been dragged onto another screen and shift it there. +-- The PositionStore is also updated accordingly, as this is designed to be used together +-- with "XMonad.Layout.PositionStoreFloat". +handleScreenCrossing :: Window -> Window -> X Bool +handleScreenCrossing w decoWin = withDisplay $ \d -> do + root <- asks theRoot + (_, _, _, px, py, _, _, _) <- io $ queryPointer d root + ws <- gets windowset + sc <- fromMaybe (W.current ws) <$> pointScreen (fi px) (fi py) + maybeWksp <- screenWorkspace $ W.screen sc + let targetWksp = maybeWksp >>= \wksp -> + W.findTag w ws >>= \currentWksp -> + if (currentWksp /= wksp) + then Just wksp + else Nothing + case targetWksp of + Just wksp -> do + -- find out window under cursor on target workspace + -- apparently we have to switch to the workspace first + -- to make this work, which unforunately introduces some flicker + windows $ \ws' -> W.view wksp ws' + (_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root + + -- adjust PositionStore + let oldScreenRect = screenRect . W.screenDetail $ W.current ws + newScreenRect = screenRect . W.screenDetail $ sc + {-- somewhat ugly hack to get proper ScreenRect, + creates unwanted inter-dependencies + TODO: get ScreenRects in a proper way --} + oldScreenRect' <- fmap ($ oldScreenRect) (calcGap $ S.fromList [minBound .. maxBound]) + newScreenRect' <- fmap ($ newScreenRect) (calcGap $ S.fromList [minBound .. maxBound]) + wa <- io $ getWindowAttributes d decoWin + modifyPosStore (\ps -> + posStoreMove ps w (fi $ wa_x wa) (fi $ wa_y wa) + oldScreenRect' newScreenRect') + + -- set focus correctly so the window will be inserted + -- at the correct position on the target workspace + -- and then shift the window + windows $ \ws' -> W.shiftWin wksp w . W.focusWindow selWin $ ws' + + -- return True to signal that screen crossing has taken place + return True + Nothing -> return False diff --git a/src/XMonad/Layout/DraggingVisualizer.hs b/src/XMonad/Layout/DraggingVisualizer.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/DraggingVisualizer.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.DraggingVisualizer +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A helper module to visualize the process of dragging a window by +-- making it follow the mouse cursor. See "XMonad.Layout.WindowSwitcherDecoration" +-- for a module that makes use of this. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.DraggingVisualizer + ( draggingVisualizer, + DraggingVisualizerMsg (..) + ) where + +import XMonad +import XMonad.Layout.LayoutModifier + +data DraggingVisualizer a = DraggingVisualizer (Maybe (Window, Rectangle)) deriving ( Read, Show ) +draggingVisualizer :: LayoutClass l Window => l Window -> ModifiedLayout DraggingVisualizer l Window +draggingVisualizer = ModifiedLayout $ DraggingVisualizer Nothing + +data DraggingVisualizerMsg = DraggingWindow Window Rectangle + | DraggingStopped + deriving ( Typeable, Eq ) +instance Message DraggingVisualizerMsg + +instance LayoutModifier DraggingVisualizer Window where + modifierDescription (DraggingVisualizer _) = "DraggingVisualizer" + pureModifier (DraggingVisualizer (Just dragged@(draggedWin, _))) _ _ wrs = + if draggedWin `elem` (map fst wrs) + then (dragged : rest, Nothing) + else (wrs, Just $ DraggingVisualizer Nothing) + where + rest = filter (\(w, _) -> w /= draggedWin) wrs + pureModifier _ _ _ wrs = (wrs, Nothing) + + pureMess (DraggingVisualizer _) m = case fromMessage m of + Just (DraggingWindow w rect) -> Just $ DraggingVisualizer $ Just (w, rect) + Just (DraggingStopped) -> Just $ DraggingVisualizer Nothing + _ -> Nothing diff --git a/src/XMonad/Layout/ImageButtonDecoration.hs b/src/XMonad/Layout/ImageButtonDecoration.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/ImageButtonDecoration.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ImageButtonDecoration +-- Copyright : (c) Jan Vornberger 2009 +-- Alejandro Serrano 2010 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : trupill@gmail.com +-- Stability : unstable +-- Portability : not portable +-- +-- A decoration that includes small image buttons on both ends which invoke +-- various actions when clicked on: Show a window menu (see +-- "XMonad.Actions.WindowMenu"), minimize, maximize or close the window. +-- +-- Note: For maximizing and minimizing to actually work, you will need +-- to integrate "XMonad.Layout.Maximize" and "XMonad.Layout.Minimize" into your +-- setup. See the documentation of those modules for more information. +-- +----------------------------------------------------------------------------- + +-- This module is mostly derived from "XMonad.Layout.DecorationAddons" +-- and "XMonad.Layout.ButtonDecoration" + +module XMonad.Layout.ImageButtonDecoration + ( -- * Usage: + -- $usage + imageButtonDeco + , defaultThemeWithImageButtons + , imageTitleBarButtonHandler + ) where + +import XMonad +import XMonad.Layout.Decoration +import XMonad.Layout.DecorationAddons +import XMonad.Util.Image + +import XMonad.Actions.WindowMenu +import XMonad.Layout.Minimize +import XMonad.Layout.Maximize + +-- $usage +-- You can use this module with the following in your +-- @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.ImageButtonDecoration +-- +-- Then edit your @layoutHook@ by adding the ImageButtonDecoration to +-- your layout: +-- +-- > myL = imageButtonDeco shrinkText defaultThemeWithImageButtons (layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- + +-- The buttons' dimension and placements + +buttonSize :: Int +buttonSize = 10 + +menuButtonOffset :: Int +menuButtonOffset = 4 + +minimizeButtonOffset :: Int +minimizeButtonOffset = 32 + +maximizeButtonOffset :: Int +maximizeButtonOffset = 18 + +closeButtonOffset :: Int +closeButtonOffset = 4 + + +-- The images in a 0-1 scale to make +-- it easier to visualize + +convertToBool' :: [Int] -> [Bool] +convertToBool' = map (\x -> x == 1) + +convertToBool :: [[Int]] -> [[Bool]] +convertToBool = map convertToBool' + +menuButton' :: [[Int]] +menuButton' = [[1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1]] + +menuButton :: [[Bool]] +menuButton = convertToBool menuButton' + +miniButton' :: [[Int]] +miniButton' = [[0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [0,0,0,0,0,0,0,0,0,0], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1]] + +miniButton :: [[Bool]] +miniButton = convertToBool miniButton' + +maxiButton' :: [[Int]] +maxiButton' = [[1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,0,0,0,0,0,0,1,1], + [1,1,1,1,1,1,1,1,1,1], + [1,1,1,1,1,1,1,1,1,1]] + +maxiButton :: [[Bool]] +maxiButton = convertToBool maxiButton' + +closeButton' :: [[Int]] +closeButton' = [[1,1,0,0,0,0,0,0,1,1], + [1,1,1,0,0,0,0,1,1,1], + [0,1,1,1,0,0,1,1,1,0], + [0,0,1,1,1,1,1,1,0,0], + [0,0,0,1,1,1,1,0,0,0], + [0,0,0,1,1,1,1,0,0,0], + [0,0,1,1,1,1,1,1,0,0], + [0,1,1,1,0,0,1,1,1,0], + [1,1,1,0,0,0,0,1,1,1], + [1,1,0,0,0,0,0,0,1,1]] + + +closeButton :: [[Bool]] +closeButton = convertToBool closeButton' + +-- | A function intended to be plugged into the 'decorationCatchClicksHook' of a decoration. +-- It will intercept clicks on the buttons of the decoration and invoke the associated action. +-- To actually see the buttons, you will need to use a theme that includes them. +-- See 'defaultThemeWithImageButtons' below. +imageTitleBarButtonHandler :: Window -> Int -> Int -> X Bool +imageTitleBarButtonHandler mainw distFromLeft distFromRight = do + let action = if (fi distFromLeft >= menuButtonOffset && + fi distFromLeft <= menuButtonOffset + buttonSize) + then focus mainw >> windowMenu >> return True + else if (fi distFromRight >= closeButtonOffset && + fi distFromRight <= closeButtonOffset + buttonSize) + then focus mainw >> kill >> return True + else if (fi distFromRight >= maximizeButtonOffset && + fi distFromRight <= maximizeButtonOffset + buttonSize) + then focus mainw >> sendMessage (maximizeRestore mainw) >> return True + else if (fi distFromRight >= minimizeButtonOffset && + fi distFromRight <= minimizeButtonOffset + buttonSize) + then focus mainw >> sendMessage (MinimizeWin mainw) >> return True + else return False + action + +defaultThemeWithImageButtons :: Theme +defaultThemeWithImageButtons = defaultTheme { + windowTitleIcons = [ (menuButton, CenterLeft 3), + (closeButton, CenterRight 3), + (maxiButton, CenterRight 18), + (miniButton, CenterRight 33) ] + } + +imageButtonDeco :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration ImageButtonDecoration s) l a +imageButtonDeco s c = decoration s c $ NFD True + +data ImageButtonDecoration a = NFD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle ImageButtonDecoration a where + describeDeco _ = "ImageButtonDeco" + decorationCatchClicksHook _ mainw dFL dFR = imageTitleBarButtonHandler mainw dFL dFR + decorationAfterDraggingHook _ (mainw, _) decoWin = focus mainw >> handleScreenCrossing mainw decoWin >> return () diff --git a/src/XMonad/Layout/Minimize.hs b/src/XMonad/Layout/Minimize.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/Minimize.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleContexts, PatternGuards #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Minimize +-- Copyright : (c) Jan Vornberger 2009, Alejandro Serrano 2010 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- Makes it possible to minimize windows, temporarily removing them +-- from the layout until they are restored. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Minimize ( + -- * Usage + -- $usage + minimize, + MinimizeMsg(..) + ) where + +import XMonad +import qualified XMonad.StackSet as W +import XMonad.Layout.LayoutModifier +import XMonad.Layout.BoringWindows as BW +import XMonad.Util.WindowProperties (getProp32) +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Foreign.C.Types (CLong) + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.Minimize +-- +-- Then edit your @layoutHook@ by adding the Minimize layout modifier: +-- +-- > myLayout = minimize (Tall 1 (3/100) (1/2)) ||| Full ||| etc.. +-- > main = xmonad defaultConfig { layoutHook = myLayout } +-- +-- For more detailed instructions on editing the layoutHook see: +-- +-- "XMonad.Doc.Extending#Editing_the_layout_hook" +-- +-- In the key-bindings, do something like: +-- +-- > , ((modm, xK_m ), withFocused (\f -> sendMessage (MinimizeWin f))) +-- > , ((modm .|. shiftMask, xK_m ), sendMessage RestoreNextMinimizedWin) +-- +-- The first action will minimize the focused window, while the second one will restore +-- the next minimized window. +-- +-- For detailed instruction on editing the key binding see: +-- +-- "XMonad.Doc.Extending#Editing_key_bindings". +-- +-- The module is designed to work together with "XMonad.Layout.BoringWindows" so +-- that minimized windows will be skipped over when switching the focused window with +-- the keyboard. Include 'BW.boringWindows' in your layout hook and see the +-- documentation of "XMonad.Layout.BoringWindows" on how to modify your keybindings. +-- +-- Also see "XMonad.Hooks.RestoreMinimized" if you want to be able to restore +-- minimized windows from your taskbar. + +data Minimize a = Minimize [Window] (M.Map Window W.RationalRect) deriving ( Read, Show ) +minimize :: LayoutClass l Window => l Window -> ModifiedLayout Minimize l Window +minimize = ModifiedLayout $ Minimize [] M.empty + +data MinimizeMsg = MinimizeWin Window + | RestoreMinimizedWin Window + | RestoreNextMinimizedWin + deriving (Typeable, Eq) +instance Message MinimizeMsg + + +setMinimizedState :: Window -> Int -> (CLong -> [CLong] -> [CLong]) -> X () +setMinimizedState win st f = do + setWMState win st + withDisplay $ \dpy -> do + state <- getAtom "_NET_WM_STATE" + mini <- getAtom "_NET_WM_STATE_HIDDEN" + wstate <- fromMaybe [] `fmap` getProp32 state win + let ptype = 4 -- The atom property type for changeProperty + fi_mini = fromIntegral mini + io $ changeProperty32 dpy win state ptype propModeReplace (f fi_mini wstate) + +setMinimized :: Window -> X () +setMinimized win = setMinimizedState win iconicState (:) + +setNotMinimized :: Window -> X () +setNotMinimized win = setMinimizedState win normalState delete + +instance LayoutModifier Minimize Window where + modifierDescription _ = "Minimize" + + modifyLayout (Minimize minimized _) wksp rect = do + let stack = W.stack wksp + filtStack = stack >>=W.filter (\w -> not (w `elem` minimized)) + runLayout (wksp {W.stack = filtStack}) rect + + handleMess (Minimize minimized unfloated) m + | Just (MinimizeWin w) <- fromMessage m, not (w `elem` minimized) = do + BW.focusDown + setMinimized w + ws <- gets windowset + case M.lookup w (W.floating ws) of + Nothing -> return $ Just $ Minimize (w:minimized) unfloated + Just r -> do + (windows . W.sink) w + return $ Just $ Minimize (w:minimized) (M.insert w r unfloated) + | Just (RestoreMinimizedWin w) <- fromMessage m = do + setNotMinimized w + case M.lookup w unfloated of + Nothing -> return $ Just $ Minimize (minimized \\ [w]) unfloated + Just r -> do + (windows . (W.float w)) r + return $ Just $ Minimize (minimized \\ [w]) (M.delete w unfloated) + | Just RestoreNextMinimizedWin <- fromMessage m = + if not (null minimized) + then case M.lookup (head minimized) unfloated of + Nothing -> do + let w = head minimized + setNotMinimized w + focus w + return $ Just $ Minimize (tail minimized) unfloated + Just r -> do + let w = head minimized + setNotMinimized w + (windows . (W.float w)) r + focus w + return $ Just $ Minimize (tail minimized) (M.delete w unfloated) + else return Nothing + | Just BW.UpdateBoring <- fromMessage m = do + ws <- gets (W.workspace . W.current . windowset) + flip sendMessageWithNoRefresh ws $ BW.Replace "Minimize" minimized + return Nothing + | otherwise = return Nothing diff --git a/src/XMonad/Layout/MouseResizableTile.hs b/src/XMonad/Layout/MouseResizableTile.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/MouseResizableTile.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.MouseResizableTile +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A layout in the spirit of "XMonad.Layout.ResizableTile", but with the option +-- to use the mouse to adjust the layout. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.MouseResizableTile ( + -- * Usage + -- $usage + mouseResizableTile, + mouseResizableTileMirrored, + MRTMessage (ShrinkSlave, ExpandSlave), + + -- * Parameters + -- $mrtParameters + nmaster, + masterFrac, + slaveFrac, + fracIncrement, + isMirrored, + draggerType, + DraggerType (..), + ) where + +import XMonad hiding (tile, splitVertically, splitHorizontallyBy) +import qualified XMonad.StackSet as W +import XMonad.Util.XUtils +import Control.Applicative((<$>)) + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.MouseResizableTile +-- +-- Then edit your @layoutHook@ by adding the MouseResizableTile layout. +-- Either in its normal form or the mirrored version. (The mirror layout modifier +-- will not work correctly here because of the use of the mouse.) +-- +-- > myLayout = mouseResizableTile ||| etc.. +-- > main = xmonad defaultConfig { layoutHook = myLayout } +-- +-- +-- For more detailed instructions on editing the layoutHook see: +-- +-- "XMonad.Doc.Extending#Editing_the_layout_hook" +-- +-- You may also want to add the following key bindings: +-- +-- > , ((modm, xK_u), sendMessage ShrinkSlave) -- %! Shrink a slave area +-- > , ((modm, xK_i), sendMessage ExpandSlave) -- %! Expand a slave area +-- +-- For detailed instruction on editing the key binding see: +-- +-- "XMonad.Doc.Extending#Editing_key_bindings". + +-- $mrtParameters +-- The following functions are also labels for updating the @data@ (whose +-- representation is otherwise hidden) produced by 'mouseResizableTile'. +-- +-- Usage: +-- +-- > myLayout = mouseResizableTile{ masterFrac = 0.7, +-- > fracIncrement = 0.05, +-- > draggerType = BordersDragger } +-- > ||| etc.. + +data MRTMessage = SetMasterFraction Rational + | SetLeftSlaveFraction Int Rational + | SetRightSlaveFraction Int Rational + | ShrinkSlave + | ExpandSlave + deriving Typeable +instance Message MRTMessage + +data DraggerInfo = MasterDragger Position Rational + | LeftSlaveDragger Position Rational Int + | RightSlaveDragger Position Rational Int + deriving (Show, Read) +type DraggerWithRect = (Rectangle, Glyph, DraggerInfo) +type DraggerWithWin = (Window, DraggerInfo) + +-- | Specifies the size of the clickable area between windows. +data DraggerType = FixedDragger + { gapWidth :: Dimension -- ^ width of a gap between windows + , draggerWidth :: Dimension -- ^ width of the dragger itself + -- (will overlap windows if greater than gap) + } + | BordersDragger -- ^ no gaps, draggers overlap window borders + deriving (Show, Read) +type DraggerGeometry = (Position, Dimension, Position, Dimension) + +data MouseResizableTile a = MRT { nmaster :: Int, + -- ^ Get/set the number of windows in + -- master pane (default: 1). + masterFrac :: Rational, + -- ^ Get/set the proportion of screen + -- occupied by master pane (default: 1/2). + slaveFrac :: Rational, + -- ^ Get/set the proportion of remaining + -- space in a column occupied by a slave + -- window (default: 1/2). + fracIncrement :: Rational, + -- ^ Get/set the increment used when + -- modifying masterFrac/slaveFrac by the + -- Shrink, Expand, etc. messages (default: + -- 3/100). + leftFracs :: [Rational], + rightFracs :: [Rational], + draggers :: [DraggerWithWin], + draggerType :: DraggerType, + -- ^ Get/set dragger and gap dimensions + -- (default: FixedDragger 6 6). + focusPos :: Int, + numWindows :: Int, + isMirrored :: Bool + -- ^ Get/set whether the layout is + -- mirrored (default: False). + } deriving (Show, Read) + +mouseResizableTile :: MouseResizableTile a +mouseResizableTile = MRT 1 0.5 0.5 0.03 [] [] [] (FixedDragger 6 6) 0 0 False + +-- | May be removed in favor of @mouseResizableTile { isMirrored = True }@ +mouseResizableTileMirrored :: MouseResizableTile a +mouseResizableTileMirrored = mouseResizableTile { isMirrored = True } + +instance LayoutClass MouseResizableTile Window where + doLayout state sr (W.Stack w l r) = do + drg <- draggerGeometry $ draggerType state + let wins = reverse l ++ w : r + num = length wins + sr' = mirrorAdjust sr (mirrorRect sr) + (rects, preparedDraggers) = tile (nmaster state) (masterFrac state) + (leftFracs state ++ repeat (slaveFrac state)) + (rightFracs state ++ repeat (slaveFrac state)) sr' num drg + rects' = map (mirrorAdjust id mirrorRect . sanitizeRectangle sr') rects + mapM_ deleteDragger $ draggers state + (draggerWrs, newDraggers) <- unzip <$> mapM + (createDragger sr . adjustForMirror (isMirrored state)) + preparedDraggers + return (draggerWrs ++ zip wins rects', Just $ state { draggers = newDraggers, + focusPos = length l, + numWindows = length wins }) + where + mirrorAdjust a b = if (isMirrored state) + then b + else a + + handleMessage state m + | Just (IncMasterN d) <- fromMessage m = + return $ Just $ state { nmaster = max 0 (nmaster state + d) } + | Just Shrink <- fromMessage m = + return $ Just $ state { masterFrac = max 0 (masterFrac state - fracIncrement state) } + | Just Expand <- fromMessage m = + return $ Just $ state { masterFrac = min 1 (masterFrac state + fracIncrement state) } + | Just ShrinkSlave <- fromMessage m = + return $ Just $ modifySlave state (- fracIncrement state) + | Just ExpandSlave <- fromMessage m = + return $ Just $ modifySlave state (fracIncrement state) + | Just (SetMasterFraction f) <- fromMessage m = + return $ Just $ state { masterFrac = max 0 (min 1 f) } + | Just (SetLeftSlaveFraction pos f) <- fromMessage m = + return $ Just $ state { leftFracs = replaceAtPos (slaveFrac state) + (leftFracs state) pos (max 0 (min 1 f)) } + | Just (SetRightSlaveFraction pos f) <- fromMessage m = + return $ Just $ state { rightFracs = replaceAtPos (slaveFrac state) + (rightFracs state) pos (max 0 (min 1 f)) } + + | Just e <- fromMessage m :: Maybe Event = handleResize (draggers state) (isMirrored state) e >> return Nothing + | Just Hide <- fromMessage m = releaseResources >> return (Just $ state { draggers = [] }) + | Just ReleaseResources <- fromMessage m = releaseResources >> return (Just $ state { draggers = [] }) + where releaseResources = mapM_ deleteDragger $ draggers state + handleMessage _ _ = return Nothing + + description state = mirror "MouseResizableTile" + where mirror = if isMirrored state then ("Mirror " ++) else id + +draggerGeometry :: DraggerType -> X DraggerGeometry +draggerGeometry (FixedDragger g d) = + return (fromIntegral $ g `div` 2, g, fromIntegral $ d `div` 2, d) +draggerGeometry BordersDragger = do + w <- asks (borderWidth . config) + return (0, 0, fromIntegral w, 2*w) + +adjustForMirror :: Bool -> DraggerWithRect -> DraggerWithRect +adjustForMirror False dragger = dragger +adjustForMirror True (draggerRect, draggerCursor, draggerInfo) = + (mirrorRect draggerRect, draggerCursor', draggerInfo) + where + draggerCursor' = if (draggerCursor == xC_sb_h_double_arrow) + then xC_sb_v_double_arrow + else xC_sb_h_double_arrow + +modifySlave :: MouseResizableTile a -> Rational -> MouseResizableTile a +modifySlave state delta = + let pos = focusPos state + num = numWindows state + nmaster' = nmaster state + leftFracs' = leftFracs state + rightFracs' = rightFracs state + slFrac = slaveFrac state + draggersLeft = nmaster' - 1 + draggersRight = (num - nmaster') - 1 + in if pos < nmaster' + then if draggersLeft > 0 + then let draggerPos = min (draggersLeft - 1) pos + oldFraction = (leftFracs' ++ repeat slFrac) !! draggerPos + in state { leftFracs = replaceAtPos slFrac leftFracs' draggerPos + (max 0 (min 1 (oldFraction + delta))) } + else state + else if draggersRight > 0 + then let draggerPos = min (draggersRight - 1) (pos - nmaster') + oldFraction = (rightFracs' ++ repeat slFrac) !! draggerPos + in state { rightFracs = replaceAtPos slFrac rightFracs' draggerPos + (max 0 (min 1 (oldFraction + delta))) } + else state + +replaceAtPos :: (Num t) => Rational -> [Rational] -> t -> Rational -> [Rational] +replaceAtPos _ [] 0 x' = [x'] +replaceAtPos d [] pos x' = d : replaceAtPos d [] (pos - 1) x' +replaceAtPos _ (_:xs) 0 x' = x' : xs +replaceAtPos d (x:xs) pos x' = x : replaceAtPos d xs (pos -1 ) x' + +sanitizeRectangle :: Rectangle -> Rectangle -> Rectangle +sanitizeRectangle (Rectangle sx sy swh sht) (Rectangle x y wh ht) = + (Rectangle (within 0 (sx + fromIntegral swh) x) (within 0 (sy + fromIntegral sht) y) + (within 1 swh wh) (within 1 sht ht)) + +within :: (Ord a) => a -> a -> a -> a +within low high a = max low $ min high a + +tile :: Int -> Rational -> [Rational] -> [Rational] -> Rectangle -> Int -> DraggerGeometry -> ([Rectangle], [DraggerWithRect]) +tile nmaster' masterFrac' leftFracs' rightFracs' sr num drg + | num <= nmaster' = splitVertically (take (num - 1) leftFracs') sr True 0 drg + | nmaster' == 0 = splitVertically (take (num - 1) rightFracs') sr False 0 drg + | otherwise = (leftRects ++ rightRects, masterDragger : leftDraggers ++ rightDraggers) + where ((sr1, sr2), masterDragger) = splitHorizontallyBy masterFrac' sr drg + (leftRects, leftDraggers) = splitVertically (take (nmaster' - 1) leftFracs') sr1 True 0 drg + (rightRects, rightDraggers) = splitVertically (take (num - nmaster' - 1) rightFracs') sr2 False 0 drg + +splitVertically :: RealFrac r => [r] -> Rectangle -> Bool -> Int -> DraggerGeometry -> ([Rectangle], [DraggerWithRect]) +splitVertically [] r _ _ _ = ([r], []) +splitVertically (f:fx) (Rectangle sx sy sw sh) isLeft num drg@(drOff, drSz, drOff2, drSz2) = + let nextRect = Rectangle sx sy sw $ smallh - div drSz 2 + (otherRects, otherDragger) = splitVertically fx + (Rectangle sx (sy + fromIntegral smallh + drOff) + sw (sh - smallh - div drSz 2)) + isLeft (num + 1) drg + draggerRect = Rectangle sx (sy + fromIntegral smallh - drOff2) sw drSz2 + draggerInfo = if isLeft + then LeftSlaveDragger sy (fromIntegral sh) num + else RightSlaveDragger sy (fromIntegral sh) num + nextDragger = (draggerRect, xC_sb_v_double_arrow, draggerInfo) + in (nextRect : otherRects, nextDragger : otherDragger) + where smallh = floor $ fromIntegral sh * f + +splitHorizontallyBy :: RealFrac r => r -> Rectangle -> DraggerGeometry -> ((Rectangle, Rectangle), DraggerWithRect) +splitHorizontallyBy f (Rectangle sx sy sw sh) (drOff, drSz, drOff2, drSz2) = + ((leftHalf, rightHalf), (draggerRect, xC_sb_h_double_arrow, draggerInfo)) + where leftw = floor $ fromIntegral sw * f + leftHalf = Rectangle sx sy (leftw - drSz `div` 2) sh + rightHalf = Rectangle (sx + fromIntegral leftw + drOff) sy + (sw - fromIntegral leftw - drSz `div` 2) sh + draggerRect = Rectangle (sx + fromIntegral leftw - drOff2) sy drSz2 sh + draggerInfo = MasterDragger sx (fromIntegral sw) + +createDragger :: Rectangle -> DraggerWithRect -> X ((Window, Rectangle), DraggerWithWin) +createDragger sr (draggerRect, draggerCursor, draggerInfo) = do + let draggerRect' = sanitizeRectangle sr draggerRect + draggerWin <- createInputWindow draggerCursor draggerRect' + return ((draggerWin, draggerRect'), (draggerWin, draggerInfo)) + +deleteDragger :: DraggerWithWin -> X () +deleteDragger (draggerWin, _) = deleteWindow draggerWin + +handleResize :: [DraggerWithWin] -> Bool -> Event -> X () +handleResize draggers' isM ButtonEvent { ev_window = ew, ev_event_type = et } + | et == buttonPress, Just x <- lookup ew draggers' = case x of + MasterDragger lb r -> mouseDrag' id lb r SetMasterFraction + LeftSlaveDragger lb r num -> mouseDrag' flip lb r (SetLeftSlaveFraction num) + RightSlaveDragger lb r num -> mouseDrag' flip lb r (SetRightSlaveFraction num) + where + chooseAxis isM' axis1 axis2 = if isM' then axis2 else axis1 + mouseDrag' flp lowerBound range msg = flip mouseDrag (return ()) $ \x y -> do + let axis = flp (chooseAxis isM) x y + fraction = fromIntegral (axis - lowerBound) / range + sendMessage (msg fraction) + +handleResize _ _ _ = return () + +createInputWindow :: Glyph -> Rectangle -> X Window +createInputWindow cursorGlyph r = withDisplay $ \d -> do + win <- mkInputWindow d r + io $ selectInput d win (exposureMask .|. buttonPressMask) + cursor <- io $ createFontCursor d cursorGlyph + io $ defineCursor d win cursor + io $ freeCursor d cursor + showWindow win + return win + +mkInputWindow :: Display -> Rectangle -> X Window +mkInputWindow d (Rectangle x y w h) = do + rw <- asks theRoot + let screen = defaultScreenOfDisplay d + visual = defaultVisualOfScreen screen + attrmask = cWOverrideRedirect + io $ allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes True + createWindow d rw x y w h 0 0 inputOnly visual attrmask attributes diff --git a/src/XMonad/Layout/PositionStoreFloat.hs b/src/XMonad/Layout/PositionStoreFloat.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/PositionStoreFloat.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.PositionStoreFloat +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A floating layout which has been designed with a dual-head setup +-- in mind. It makes use of "XMonad.Util.PositionStore" as well as +-- "XMonad.Hooks.PositionStoreHooks" . Since there is currently no way +-- to move or resize windows with the keyboard alone in this layout, +-- it is adviced to use it in combination with a decoration such as +-- "XMonad.Layout.NoFrillsDecoration" (to move windows) and the +-- layout modifier "XMonad.Layout.BorderResize" (to resize windows). +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.PositionStoreFloat + ( -- * Usage + -- $usage + positionStoreFloat + ) where + +import XMonad +import XMonad.Util.PositionStore +import qualified XMonad.StackSet as S +import XMonad.Layout.WindowArranger +import Control.Monad(when) +import Data.Maybe(isJust) +import Data.List(nub) + +-- $usage +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.PositionStoreFloat +-- > import XMonad.Layout.NoFrillsDecoration +-- > import XMonad.Layout.BorderResize +-- +-- Then edit your @layoutHook@ by adding the PositionStoreFloat layout. +-- Below is a suggestion which uses the mentioned NoFrillsDecoration and +-- BorderResize: +-- +-- > myLayouts = floatingDeco $ borderResize $ positionStoreFloat ||| etc.. +-- > where floatingDeco l = noFrillsDeco shrinkText defaultTheme l +-- > main = xmonad defaultConfig { layoutHook = myLayouts } +-- +-- See the documentation of "XMonad.Hooks.PositionStoreHooks" on how +-- to add the support hooks. + +positionStoreFloat :: PositionStoreFloat a +positionStoreFloat = PSF (Nothing, []) + +data PositionStoreFloat a = PSF (Maybe Rectangle, [a]) deriving (Show, Read) +instance LayoutClass PositionStoreFloat Window where + description _ = "PSF" + doLayout (PSF (maybeChange, paintOrder)) sr (S.Stack w l r) = do + posStore <- getPosStore + let wrs = map (\w' -> (w', pSQ posStore w' sr)) (reverse l ++ r) + let focused = case maybeChange of + Nothing -> (w, pSQ posStore w sr) + Just changedRect -> (w, changedRect) + let wrs' = focused : wrs + let paintOrder' = nub (w : paintOrder) + when (isJust maybeChange) $ do + updatePositionStore focused sr + return (reorder wrs' paintOrder', Just $ PSF (Nothing, paintOrder')) + where + pSQ posStore w' sr' = case (posStoreQuery posStore w' sr') of + Just rect -> rect + Nothing -> (Rectangle 50 50 200 200) -- should usually not happen + pureMessage (PSF (_, paintOrder)) m + | Just (SetGeometry rect) <- fromMessage m = + Just $ PSF (Just rect, paintOrder) + | otherwise = Nothing + +updatePositionStore :: (Window, Rectangle) -> Rectangle -> X () +updatePositionStore (w, rect) sr = modifyPosStore (\ps -> + posStoreInsert ps w rect sr) + +reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)] +reorder wrs order = + let ordered = concat $ map (pickElem wrs) order + rest = filter (\(w, _) -> not (w `elem` order)) wrs + in ordered ++ rest + where + pickElem list e = case (lookup e list) of + Just result -> [(e, result)] + Nothing -> [] diff --git a/src/XMonad/Layout/WindowSwitcherDecoration.hs b/src/XMonad/Layout/WindowSwitcherDecoration.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Layout/WindowSwitcherDecoration.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.WindowSwitcherDecoration +-- Copyright : (c) Jan Vornberger 2009 +-- Alejandro Serrano 2010 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A decoration that allows to switch the position of windows by dragging +-- them onto each other. +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.WindowSwitcherDecoration + ( -- * Usage: + -- $usage + windowSwitcherDecoration, + windowSwitcherDecorationWithButtons, + windowSwitcherDecorationWithImageButtons + ) where + +import XMonad +import XMonad.Layout.Decoration +import XMonad.Layout.DecorationAddons +import XMonad.Layout.ImageButtonDecoration +import XMonad.Layout.DraggingVisualizer +import qualified XMonad.StackSet as S +import Control.Monad +import Foreign.C.Types(CInt) + +-- $usage +-- You can use this module with the following in your +-- @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Layout.WindowSwitcherDecoration +-- > import XMonad.Layout.DraggingVisualizer +-- +-- Then edit your @layoutHook@ by adding the WindowSwitcherDecoration to +-- your layout: +-- +-- > myL = windowSwitcherDecoration shrinkText defaultTheme (draggingVisualizer $ layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- +-- There is also a version of the decoration that contains buttons like +-- "XMonad.Layout.ButtonDecoration". To use that version, you will need to +-- import "XMonad.Layout.DecorationAddons" as well and modify your @layoutHook@ +-- in the following way: +-- +-- > import XMonad.Layout.DecorationAddons +-- > +-- > myL = windowSwitcherDecorationWithButtons shrinkText defaultThemeWithButtons (draggingVisualizer $ layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- +-- Additionaly, there is a version of the decoration that contains image buttons like +-- "XMonad.Layout.ImageButtonDecoration". To use that version, you will need to +-- import "XMonad.Layout.ImageButtonDecoration" as well and modify your @layoutHook@ +-- in the following way: +-- +-- > import XMonad.Layout.ImageButtonDecoration +-- > +-- > myL = windowSwitcherDecorationWithImageButtons shrinkText defaultThemeWithImageButtons (draggingVisualizer $ layoutHook defaultConfig) +-- > main = xmonad defaultConfig { layoutHook = myL } +-- + +windowSwitcherDecoration :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration WindowSwitcherDecoration s) l a +windowSwitcherDecoration s c = decoration s c $ WSD False + +windowSwitcherDecorationWithButtons :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration WindowSwitcherDecoration s) l a +windowSwitcherDecorationWithButtons s c = decoration s c $ WSD True + +data WindowSwitcherDecoration a = WSD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle WindowSwitcherDecoration a where + describeDeco _ = "WindowSwitcherDeco" + + decorationCatchClicksHook (WSD withButtons) mainw dFL dFR = if withButtons + then titleBarButtonHandler mainw dFL dFR + else return False + decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleTiledDraggingInProgress ex ey (mainw, r) x y + decorationAfterDraggingHook _ (mainw, _) decoWin = do focus mainw + hasCrossed <- handleScreenCrossing mainw decoWin + unless hasCrossed $ do sendMessage $ DraggingStopped + performWindowSwitching mainw + +-- Note: the image button code is duplicated from the above +-- because the title bar handle is different + +windowSwitcherDecorationWithImageButtons :: (Eq a, Shrinker s) => s -> Theme + -> l a -> ModifiedLayout (Decoration ImageWindowSwitcherDecoration s) l a +windowSwitcherDecorationWithImageButtons s c = decoration s c $ IWSD True + +data ImageWindowSwitcherDecoration a = IWSD Bool deriving (Show, Read) + +instance Eq a => DecorationStyle ImageWindowSwitcherDecoration a where + describeDeco _ = "ImageWindowSwitcherDeco" + + decorationCatchClicksHook (IWSD withButtons) mainw dFL dFR = if withButtons + then imageTitleBarButtonHandler mainw dFL dFR + else return False + decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleTiledDraggingInProgress ex ey (mainw, r) x y + decorationAfterDraggingHook _ (mainw, _) decoWin = do focus mainw + hasCrossed <- handleScreenCrossing mainw decoWin + unless hasCrossed $ do sendMessage $ DraggingStopped + performWindowSwitching mainw + +handleTiledDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X () +handleTiledDraggingInProgress ex ey (mainw, r) x y = do + let rect = Rectangle (x - (fi ex - rect_x r)) + (y - (fi ey - rect_y r)) + (rect_width r) + (rect_height r) + sendMessage $ DraggingWindow mainw rect + +performWindowSwitching :: Window -> X () +performWindowSwitching win = + withDisplay $ \d -> do + root <- asks theRoot + (_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root + ws <- gets windowset + let allWindows = S.index ws + -- do a little double check to be sure + if (win `elem` allWindows) && (selWin `elem` allWindows) + then do + let allWindowsSwitched = map (switchEntries win selWin) allWindows + let (ls, t:rs) = break (win ==) allWindowsSwitched + let newStack = S.Stack t (reverse ls) rs + windows $ S.modify' $ \_ -> newStack + else return () + where + switchEntries a b x + | x == a = b + | x == b = a + | otherwise = x diff --git a/src/XMonad/Util/Font.hs b/src/XMonad/Util/Font.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Util/Font.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE CPP #-} +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Font +-- Copyright : (c) 2007 Andrea Rossato and Spencer Janssen +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for abstracting a font facility over Core fonts and Xft +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Font + ( -- * Usage: + -- $usage + XMonadFont(..) + , initXMF + , releaseXMF + , initCoreFont + , releaseCoreFont + , initUtf8Font + , releaseUtf8Font + , Align (..) + , stringPosition + , textWidthXMF + , textExtentsXMF + , printStringXMF + , stringToPixel + , decodeInput + , encodeOutput + ) where + +import XMonad +import Foreign +import Control.Applicative +import Data.Maybe + +#ifdef XFT +import Data.List +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +import Codec.Binary.UTF8.String (encodeString, decodeString) + + +-- Hide the Core Font/Xft switching here +data XMonadFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft XftFont +#endif + +-- $usage +-- See "Xmonad.Layout.Tabbed" or "XMonad.Prompt" for usage examples + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +stringToPixel :: (Functor m, MonadIO m) => Display -> String -> m Pixel +stringToPixel d s = fromMaybe fallBack <$> io getIt + where getIt = initColor d s + fallBack = blackPixel d (defaultScreen d) + + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initCoreFont :: String -> X FontStruct +initCoreFont s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = loadQueryFont d s + fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseCoreFont :: FontStruct -> X () +releaseCoreFont fs = do + d <- asks display + io $ freeFont d fs + +initUtf8Font :: String -> X FontSet +initUtf8Font s = do + d <- asks display + (_,_,fs) <- io $ catch (getIt d) (fallBack d) + return fs + where getIt d = createFontSet d s + fallBack d = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseUtf8Font :: FontSet -> X () +releaseUtf8Font fs = do + d <- asks display + io $ freeFontSet d fs + +-- | When initXMF gets a font name that starts with 'xft:' it switches to the Xft backend +-- Example: 'xft: Sans-10' +initXMF :: String -> X XMonadFont +initXMF s = +#ifdef XFT + if xftPrefix `isPrefixOf` s then + do dpy <- asks display + xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s) + return (Xft xftdraw) + else +#endif + fmap Utf8 $ initUtf8Font s +#ifdef XFT + where xftPrefix = "xft:" +#endif + +releaseXMF :: XMonadFont -> X () +#ifdef XFT +releaseXMF (Xft xftfont) = do + dpy <- asks display + io $ xftFontClose dpy xftfont +#endif +releaseXMF (Utf8 fs) = releaseUtf8Font fs +releaseXMF (Core fs) = releaseCoreFont fs + + +textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int +textWidthXMF _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s +textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s +#ifdef XFT +textWidthXMF dpy (Xft xftdraw) s = liftIO $ do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32) +textExtentsXMF (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + (fi $ rect_y rl) + return (ascent, descent) +textExtentsXMF (Core fs) s = do + let (_,a,d,_) = textExtents fs s + return (a,d) +#ifdef XFT +textExtentsXMF (Xft xftfont) _ = io $ do + ascent <- fi `fmap` xftfont_ascent xftfont + descent <- fi `fmap` xftfont_descent xftfont + return (ascent, descent) +#endif + +-- | String position +data Align = AlignCenter | AlignRight | AlignLeft | AlignRightOffset Int + deriving (Show, Read) + +-- | Return the string x and y 'Position' in a 'Rectangle', given a +-- 'FontStruct' and the 'Align'ment +stringPosition :: (Functor m, MonadIO m) => Display -> XMonadFont -> Rectangle -> Align -> String -> m (Position,Position) +stringPosition dpy fs (Rectangle _ _ w h) al s = do + width <- textWidthXMF dpy fs s + (a,d) <- textExtentsXMF fs s + let y = fi $ ((h - fi (a + d)) `div` 2) + fi a; + x = case al of + AlignCenter -> fi (w `div` 2) - fi (width `div` 2) + AlignLeft -> 1 + AlignRight -> fi (w - (fi width + 1)); + AlignRightOffset offset -> fi (w - (fi width + 1)) - fi offset; + return (x,y) + +printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String + -> Position -> Position -> String -> m () +printStringXMF d p (Core fs) gc fc bc x y s = io $ do + setFont d gc $ fontFromFontStruct fs + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + drawImageString d p gc x y s +printStringXMF d p (Utf8 fs) gc fc bc x y s = io $ do + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + io $ wcDrawImageString d p fs gc x y s +#ifdef XFT +printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + bcolor <- stringToPixel dpy bc + (a,d) <- textExtentsXMF fs s + gi <- io $ xftTextExtents dpy font s + io $ setForeground dpy gc bcolor + io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) + (y - fi a) + (fi $ xglyphinfo_xOff gi) + (fi $ a + d) + io $ withXftDraw dpy drw visual colormap $ + \draw -> withXftColorName dpy visual colormap fc $ + \color -> xftDrawString draw color font x y s +#endif + +decodeInput :: String -> String +decodeInput = decodeString + +encodeOutput :: String -> String +encodeOutput = encodeString + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral diff --git a/src/XMonad/Util/Image.hs b/src/XMonad/Util/Image.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Util/Image.hs @@ -0,0 +1,94 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Image +-- Copyright : (c) 2010 Alejandro Serrano +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : trupill@gmail.com +-- Stability : unstable +-- Portability : unportable +-- +-- Utilities for manipulating [[Bool]] as images +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Image + ( -- * Usage: + -- $usage + Placement(..), + iconPosition, + drawIcon, + + fi, + ) where + +import XMonad +import XMonad.Util.Font (stringToPixel) + +-- | Placement of the icon in the title bar +data Placement = OffsetLeft Int Int -- ^ An exact amount of pixels from the upper left corner + | OffsetRight Int Int -- ^ An exact amount of pixels from the right left corner + | CenterLeft Int -- ^ Centered in the y-axis, an amount of pixels from the left + | CenterRight Int -- ^ Centered in the y-axis, an amount of pixels from the right + deriving (Show, Read) + +-- $usage +-- This module uses matrices of boolean values as images. When drawing them, +-- a True value tells that we want the fore color, and a False value that we +-- want the background color to be painted. +-- In the module we suppose that those matrices are represented as [[Bool]], +-- so the lengths of the inner lists must be the same. +-- +-- See "Xmonad.Layout.Decoration" for usage examples + +-- | Gets the ('width', 'height') of an image +imageDims :: [[Bool]] -> (Int, Int) +imageDims img = (length (head img), length img) + +-- | Return the 'x' and 'y' positions inside a 'Rectangle' to start drawing +-- the image given its 'Placement' +iconPosition :: Rectangle -> Placement -> [[Bool]] -> (Position,Position) +iconPosition (Rectangle _ _ _ _) (OffsetLeft x y) _ = (fi x, fi y) +iconPosition (Rectangle _ _ w _) (OffsetRight x y) icon = + let (icon_w, _) = imageDims icon + in (fi w - fi x - fi icon_w, fi y) +iconPosition (Rectangle _ _ _ h) (CenterLeft x) icon = + let (_, icon_h) = imageDims icon + in (fi x, fi (h `div` 2) - fi (icon_h `div` 2)) +iconPosition (Rectangle _ _ w h) (CenterRight x) icon = + let (icon_w, icon_h) = imageDims icon + in (fi w - fi x - fi icon_w, fi (h `div` 2) - fi (icon_h `div` 2)) + +-- | Converts an image represented as [[Bool]] to a series of points +-- to be painted (the ones with True values) +iconToPoints :: [[Bool]] -> [Point] +iconToPoints icon = + let labels_inside = map (zip (iterate (1+) 0)) icon + filtered_inside = map (\l -> [x | (x, t) <- l, t]) labels_inside + labels_outside = zip (iterate (1+) 0) filtered_inside + in [Point x y | (y, l) <- labels_outside, x <- l] + +-- | Displaces a point ('a', 'b') along a vector ('x', 'y') +movePoint :: Position -> Position -> Point -> Point +movePoint x y (Point a b) = Point (a + x) (b + y) + +-- | Displaces a list of points along a vector 'x', 'y' +movePoints :: Position -> Position -> [Point] -> [Point] +movePoints x y points = map (movePoint x y) points + +-- | Draw an image into a X surface +drawIcon :: (Functor m, MonadIO m) => Display -> Drawable -> GC -> String + ->String -> Position -> Position -> [[Bool]] -> m () +drawIcon dpy drw gc fc bc x y icon = do + let (i_w, i_h) = imageDims icon + fcolor <- stringToPixel dpy fc + bcolor <- stringToPixel dpy bc + io $ setForeground dpy gc bcolor + io $ fillRectangle dpy drw gc x y (fi i_w) (fi i_h) + io $ setForeground dpy gc fcolor + io $ drawPoints dpy drw gc (movePoints x y (iconToPoints icon)) coordModeOrigin + + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral diff --git a/src/XMonad/Util/PositionStore.hs b/src/XMonad/Util/PositionStore.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Util/PositionStore.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.PositionStore +-- Copyright : (c) Jan Vornberger 2009 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de +-- Stability : unstable +-- Portability : not portable +-- +-- A utility module to store information about position and size of a window. +-- See "XMonad.Layout.PositionStoreFloat" for a layout that makes use of this. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.PositionStore ( + getPosStore, + modifyPosStore, + + posStoreInsert, + posStoreMove, + posStoreQuery, + posStoreRemove + ) where + +import XMonad +import qualified Data.Map as M +import System.Posix.Env + +-- Store window positions relative to the upper left screen edge +-- and windows sizes as well as positions as fractions of the screen size. +-- This way windows can be easily relocated and scaled when switching screens. + +data PositionStore = PS (M.Map Window PosStoreRectangle) + deriving (Read,Show,Typeable) +data PosStoreRectangle = PSRectangle Double Double Double Double + deriving (Read,Show,Typeable) + +getPosStore :: X (PositionStore) +getPosStore = do + posStoreEnvM <- io $ getEnv "BLUETILE_POSITION_STORE" + return $ maybe (PS M.empty) read posStoreEnvM + +modifyPosStore :: (PositionStore -> PositionStore) -> X () +modifyPosStore f = do + posStore <- getPosStore + io $ setEnv "BLUETILE_POSITION_STORE" (show (f posStore)) True + +posStoreInsert :: PositionStore -> Window -> Rectangle -> Rectangle -> PositionStore +posStoreInsert (PS posStoreMap) w (Rectangle x y wh ht) (Rectangle srX srY srWh srHt) = + let offsetX = x - srX + offsetY = y - srY + in PS $ M.insert w (PSRectangle (fromIntegral offsetX / fromIntegral srWh) + (fromIntegral offsetY / fromIntegral srHt) + (fromIntegral wh / fromIntegral srWh) + (fromIntegral ht / fromIntegral srHt)) posStoreMap + +posStoreRemove :: PositionStore -> Window -> PositionStore +posStoreRemove (PS posStoreMap) w = PS $ M.delete w posStoreMap + +posStoreQuery :: PositionStore -> Window -> Rectangle -> Maybe Rectangle +posStoreQuery (PS posStoreMap) w (Rectangle srX srY srWh srHt) = do + (PSRectangle x y wh ht) <- M.lookup w posStoreMap + let realWh = fromIntegral srWh * wh + realHt = fromIntegral srHt * ht + realOffsetX = fromIntegral srWh * x + realOffsetY = fromIntegral srHt * y + return (Rectangle (srX + round realOffsetX) (srY + round realOffsetY) + (round realWh) (round realHt)) + +posStoreMove :: PositionStore -> Window -> Position -> Position -> Rectangle -> Rectangle -> PositionStore +posStoreMove posStore w x y oldSr newSr = + case (posStoreQuery posStore w oldSr) of + Nothing -> posStore -- not in store, can't move -> do nothing + Just (Rectangle _ _ wh ht) -> posStoreInsert posStore w (Rectangle x y wh ht) newSr diff --git a/src/XMonad/Util/XUtils.hs b/src/XMonad/Util/XUtils.hs new file mode 100644 --- /dev/null +++ b/src/XMonad/Util/XUtils.hs @@ -0,0 +1,206 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.XUtils +-- Copyright : (c) 2007 Andrea Rossato +-- 2010 Alejandro Serrano +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for painting on the screen +-- +----------------------------------------------------------------------------- + +module XMonad.Util.XUtils + ( -- * Usage: + -- $usage + averagePixels + , createNewWindow + , showWindow + , showWindows + , hideWindow + , hideWindows + , deleteWindow + , deleteWindows + , paintWindow + , paintAndWrite + , paintTextAndIcons + , stringToPixel + , fi + ) where + +import Data.Maybe +import XMonad +import XMonad.Util.Font +import XMonad.Util.Image +import Control.Monad + +-- $usage +-- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" or +-- "XMonad.Layout.Decoration" for usage examples + +-- | Compute the weighted average the colors of two given Pixel values. +averagePixels :: Pixel -> Pixel -> Double -> X Pixel +averagePixels p1 p2 f = + do d <- asks display + let cm = defaultColormap d (defaultScreen d) + [Color _ r1 g1 b1 _,Color _ r2 g2 b2 _] <- io $ queryColors d cm [Color p1 0 0 0 0,Color p2 0 0 0 0] + let mn x1 x2 = round (fromIntegral x1 * f + fromIntegral x2 * (1-f)) + Color p _ _ _ _ <- io $ allocColor d cm (Color 0 (mn r1 r2) (mn g1 g2) (mn b1 b2) 0) + return p + +-- | Create a simple window given a rectangle. If Nothing is given +-- only the exposureMask will be set, otherwise the Just value. +-- Use 'showWindow' to map and hideWindow to unmap. +createNewWindow :: Rectangle -> Maybe EventMask -> String -> Bool -> X Window +createNewWindow (Rectangle x y w h) m col o = do + d <- asks display + rw <- asks theRoot + c <- stringToPixel d col + win <- io $ mkWindow d (defaultScreenOfDisplay d) rw x y w h c o + case m of + Just em -> io $ selectInput d win em + Nothing -> io $ selectInput d win exposureMask + return win + +-- | Map a window +showWindow :: Window -> X () +showWindow w = do + d <- asks display + io $ mapWindow d w + +-- | the list version +showWindows :: [Window] -> X () +showWindows = mapM_ showWindow + +-- | unmap a window +hideWindow :: Window -> X () +hideWindow w = do + d <- asks display + io $ unmapWindow d w + +-- | the list version +hideWindows :: [Window] -> X () +hideWindows = mapM_ hideWindow + +-- | destroy a window +deleteWindow :: Window -> X () +deleteWindow w = do + d <- asks display + io $ destroyWindow d w + +-- | the list version +deleteWindows :: [Window] -> X () +deleteWindows = mapM_ deleteWindow + +-- | Fill a window with a rectangle and a border +paintWindow :: Window -- ^ The window where to draw + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> X () +paintWindow w wh ht bw c bc = + paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing Nothing + +-- | Fill a window with a rectangle and a border, and write +-- | a number of strings to given positions +paintAndWrite :: Window -- ^ The window where to draw + -> XMonadFont -- ^ XMonad Font for drawing + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> String -- ^ String color + -> String -- ^ String background color + -> [Align] -- ^ String 'Align'ments + -> [String] -- ^ Strings to be printed + -> X () +paintAndWrite w fs wh ht bw bc borc ffc fbc als strs = do + d <- asks display + strPositions <- forM (zip als strs) $ \(al, str) -> + stringPosition d fs (Rectangle 0 0 wh ht) al str + let ms = Just (fs,ffc,fbc, zip strs strPositions) + paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms Nothing + +-- | Fill a window with a rectangle and a border, and write +-- | a number of strings and a number of icons to given positions +paintTextAndIcons :: Window -- ^ The window where to draw + -> XMonadFont -- ^ XMonad Font for drawing + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> String -- ^ String color + -> String -- ^ String background color + -> [Align] -- ^ String 'Align'ments + -> [String] -- ^ Strings to be printed + -> [Placement] -- ^ Icon 'Placements' + -> [[[Bool]]] -- ^ Icons to be printed + -> X () +paintTextAndIcons w fs wh ht bw bc borc ffc fbc als strs i_als icons = do + d <- asks display + strPositions <- forM (zip als strs) $ \(al, str) -> + stringPosition d fs (Rectangle 0 0 wh ht) al str + let iconPositions = map ( \(al, icon) -> iconPosition (Rectangle 0 0 wh ht) al icon ) (zip i_als icons) + ms = Just (fs,ffc,fbc, zip strs strPositions) + is = Just (ffc, fbc, zip iconPositions icons) + paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms is + +-- This stuff is not exported + +-- | Paints a titlebar with some strings and icons +-- drawn inside it. +-- Not exported. +paintWindow' :: Window -> Rectangle -> Dimension -> String -> String + -> Maybe (XMonadFont,String,String,[(String, (Position, Position))]) + -> Maybe (String, String, [((Position, Position), [[Bool]])]) -> X () +paintWindow' win (Rectangle _ _ wh ht) bw color b_color strStuff iconStuff = do + d <- asks display + p <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d) + gc <- io $ createGC d p + -- draw + io $ setGraphicsExposures d gc False + [color',b_color'] <- mapM (stringToPixel d) [color,b_color] + -- we start with the border + io $ setForeground d gc b_color' + io $ fillRectangle d p gc 0 0 wh ht + -- and now again + io $ setForeground d gc color' + io $ fillRectangle d p gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2)) + -- paint strings + when (isJust strStuff) $ do + let (xmf,fc,bc,strAndPos) = fromJust strStuff + forM_ strAndPos $ \(s, (x, y)) -> + printStringXMF d p xmf gc fc bc x y s + -- paint icons + when (isJust iconStuff) $ do + let (fc, bc, iconAndPos) = fromJust iconStuff + forM_ iconAndPos $ \((x, y), icon) -> + drawIcon d p gc fc bc x y icon + -- copy the pixmap over the window + io $ copyArea d p win gc 0 0 wh ht 0 0 + -- free the pixmap and GC + io $ freePixmap d p + io $ freeGC d gc + +-- | Creates a window with the possibility of setting some attributes. +-- Not exported. +mkWindow :: Display -> Screen -> Window -> Position + -> Position -> Dimension -> Dimension -> Pixel -> Bool -> IO Window +mkWindow d s rw x y w h p o = do + let visual = defaultVisualOfScreen s + attrmask = cWOverrideRedirect .|. cWBackPixel .|. cWBorderPixel + allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes o + set_border_pixel attributes p + set_background_pixel attributes p + createWindow d rw x y w h 0 (defaultDepthOfScreen s) + inputOutput visual attrmask attributes +